diff --git a/Makefile b/Makefile index 3ab1180..bc64096 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ -OBJS=metlib3.o tpfun4.o lukasnum.o pmod25.o matsmin.o smp1.o pmon6.o -EXE=oc2A +OBJS=metlib3.o tpfun4.o lukasnum.o gtp3.o matsmin.o smp1.o pmon6.o +EXE=oc3A all: gfortran -o linkoc linkocdate.F90 @@ -16,8 +16,8 @@ tpfun4.o: utilities/tpfun4.F90 lukasnum.o: numlib/lukasnum.F90 gfortran -c -fbounds-check -finit-local-zero numlib/lukasnum.F90 -pmod25.o: models/pmod25.F90 - gfortran -c -fbounds-check -finit-local-zero models/pmod25.F90 +gtp3.o: models/gtp3.F90 + gfortran -c -fbounds-check -finit-local-zero models/gtp3.F90 matsmin.o: minimizer/matsmin.F90 gfortran -c -fbounds-check -finit-local-zero minimizer/matsmin.F90 @@ -31,6 +31,6 @@ pmon6.o: userif/pmon6.F90 $(EXE): make $(OBJS) # liboceq.a - ar sq liboceq.a metlib3.o tpfun4.o lukasnum.o pmod25.o matsmin.o + ar sq liboceq.a metlib3.o tpfun4.o lukasnum.o gtp3.o matsmin.o # oc2A gfortran -o $(EXE) -fbounds-check pmain1.F90 pmon6.o smp1.o liboceq.a diff --git a/TQlib/F90/test1/crfe.TDB b/TQ3lib-clean/C/cexample1/crfe.TDB similarity index 100% rename from TQlib/F90/test1/crfe.TDB rename to TQ3lib-clean/C/cexample1/crfe.TDB diff --git a/TQlib/C/cexample1/liboctqc.F90 b/TQ3lib-clean/C/cexample1/liboctqc.F90 similarity index 100% rename from TQlib/C/cexample1/liboctqc.F90 rename to TQ3lib-clean/C/cexample1/liboctqc.F90 diff --git a/TQlib/C/cexample1/linktqc1.txt b/TQ3lib-clean/C/cexample1/linktqc1.txt similarity index 100% rename from TQlib/C/cexample1/linktqc1.txt rename to TQ3lib-clean/C/cexample1/linktqc1.txt diff --git a/TQlib/C/cexample1/readme.txt b/TQ3lib-clean/C/cexample1/readme.txt similarity index 97% rename from TQlib/C/cexample1/readme.txt rename to TQ3lib-clean/C/cexample1/readme.txt index f9e3da3..5e9b18b 100644 --- a/TQlib/C/cexample1/readme.txt +++ b/TQ3lib-clean/C/cexample1/readme.txt @@ -1,63 +1,63 @@ - -This is an example of a C program calling the OC TQ library - -The main program is testc1.c - -As I know almost nothing about C it is very primitive. I did not even -manage to loop the calculation asking for several values of the -conditions for calculations. - -You must copy the following files from the OC or TQ folders - -liboceq.a compiled Fortran library with the basic OC routines -liboctq.o compiled Fortran subroutines for the TQ interface -liboctq.mod module information about the TQ and EQ packages - -The other files are - -crfe.TDB the database file for the Cr-Fe system -liboctqc.F90 a Fortran subroutine callable from C to access the TQ library -linktqc1.txt a Windows command file to compile and link the test program -readme.txt this file -tqexc1.c a main program in C for testing the C interface - -The linktqc1.txt must be changed to a linktqc1.cmd to be executed in a -Windows environment. On linux or other OS one can create makefiles or -other scripts to do the same. - -The liboctq.F90 should be compiled with access to the liboceq.mod file -compiled and this generates a liboctq.o and liboctq.mod files. When -compiling the liboctqc.F90 it need access to liboctq.mod file. - -When compiling and linking tqexc1.c it need access to liboctqc.o, -liboctq.o and liboceq.a - -The files liboceq.a and liboceq.mod are created when compiling the -main OC program. They should normally be copied from that compilation -but are provided here to simplify. - -The C program will initiate the OC workspace, read the crfe.TDB file -and write some information about the system. It will then set the -conditions P=1E5 (1 bar) and N=1 (system size 1 mole) and then it will -ask for a temperature. I suggest 800 (Kelvin) as a first value. Then -it will ask for a mole fraction of Cr and 0.3 is a good value. - -Then there will be some output from OC which will eventually be removed -but can be useful while testing. - -If the calculation is successful the total Gibbs energy and the -chemical potentials of the components will be listed. - -If a C expert helps one can the loop to calculate again with another -temperature and composition but with my limited understanding of C -I have failed to implement this. - -The liboctq.F90 and the liboctqc.F90 libraries are currently very -limited, much more can be implemented. See also the Fortran examples -which are more elaborated. For example they allow arrays of data to -be extracted from the OC library, I do not know how to do this in C. - -Good luck and do not hesitate to ask questions and suggest changes. - -bo.sundman@gmail.com - + +This is an example of a C program calling the OC TQ library + +The main program is testc1.c + +As I know almost nothing about C it is very primitive. I did not even +manage to loop the calculation asking for several values of the +conditions for calculations. + +You must copy the following files from the OC or TQ folders + +liboceq.a compiled Fortran library with the basic OC routines +liboctq.o compiled Fortran subroutines for the TQ interface +liboctq.mod module information about the TQ and EQ packages + +The other files are + +crfe.TDB the database file for the Cr-Fe system +liboctqc.F90 a Fortran subroutine callable from C to access the TQ library +linktqc1.txt a Windows command file to compile and link the test program +readme.txt this file +tqexc1.c a main program in C for testing the C interface + +The linktqc1.txt must be changed to a linktqc1.cmd to be executed in a +Windows environment. On linux or other OS one can create makefiles or +other scripts to do the same. + +The liboctq.F90 should be compiled with access to the liboceq.mod file +compiled and this generates a liboctq.o and liboctq.mod files. When +compiling the liboctqc.F90 it need access to liboctq.mod file. + +When compiling and linking tqexc1.c it need access to liboctqc.o, +liboctq.o and liboceq.a + +The files liboceq.a and liboceq.mod are created when compiling the +main OC program. They should normally be copied from that compilation +but are provided here to simplify. + +The C program will initiate the OC workspace, read the crfe.TDB file +and write some information about the system. It will then set the +conditions P=1E5 (1 bar) and N=1 (system size 1 mole) and then it will +ask for a temperature. I suggest 800 (Kelvin) as a first value. Then +it will ask for a mole fraction of Cr and 0.3 is a good value. + +Then there will be some output from OC which will eventually be removed +but can be useful while testing. + +If the calculation is successful the total Gibbs energy and the +chemical potentials of the components will be listed. + +If a C expert helps one can the loop to calculate again with another +temperature and composition but with my limited understanding of C +I have failed to implement this. + +The liboctq.F90 and the liboctqc.F90 libraries are currently very +limited, much more can be implemented. See also the Fortran examples +which are more elaborated. For example they allow arrays of data to +be extracted from the OC library, I do not know how to do this in C. + +Good luck and do not hesitate to ask questions and suggest changes. + +bo.sundman@gmail.com + diff --git a/TQlib/C/cexample1/tqexc1.c b/TQ3lib-clean/C/cexample1/tqexc1.c similarity index 100% rename from TQlib/C/cexample1/tqexc1.c rename to TQ3lib-clean/C/cexample1/tqexc1.c diff --git a/TQlib/F90/test1/TQ1-crfe.F90 b/TQ3lib-clean/F90/test1/TQ1-crfe.F90 similarity index 100% rename from TQlib/F90/test1/TQ1-crfe.F90 rename to TQ3lib-clean/F90/test1/TQ1-crfe.F90 diff --git a/TQlib/C/cexample1/crfe.TDB b/TQ3lib-clean/F90/test1/crfe.TDB similarity index 97% rename from TQlib/C/cexample1/crfe.TDB rename to TQ3lib-clean/F90/test1/crfe.TDB index f50e7a4..4aa8beb 100644 --- a/TQlib/C/cexample1/crfe.TDB +++ b/TQ3lib-clean/F90/test1/crfe.TDB @@ -1,178 +1,178 @@ - -$ Database file written 2012- 9- 7 -$ From database: SSOL2 - ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! - ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! - ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01! - ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! - - - FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) - +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y - -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N ! - FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N ! - FUNCTION GFELIQ 2.98150E+02 +12040.17-6.55843*T-3.6751551E-21*T**7 - +GHSERFE#; 1.81100E+03 Y - -10839.7+291.302*T-46*T*LN(T); 6.00000E+03 N ! - FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N ! - FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N ! - FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T) - -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y - -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N - ! - FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N ! - FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N ! - FUNCTION GFEFCC 2.98150E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 - +GHSERFE#; 1.81100E+03 Y - -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N - ! - FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! - FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N ! - FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N ! - FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N ! - FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N ! - FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N ! - FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N ! - FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N ! - FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N ! - FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N ! - FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N ! - FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! - FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N ! - FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N - ! - FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N ! - FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N ! - FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 - N ! - FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N ! - FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 - N ! - FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N - ! - FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N ! - FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N ! - FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 - N ! - FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N ! - FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 - N ! - FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 - N ! - FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N ! - FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 - N ! - FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N - ! - FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N ! - FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N ! - FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N ! - FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; - 6.00000E+03 N ! - FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N ! - FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N - ! - FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N ! - FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N ! - FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; - 6.00000E+03 N ! - FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; - 6.00000E+03 N ! - FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N ! - FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N ! - FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; - 6.00000E+03 N ! - FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N ! - FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N ! - FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; - 6.00000E+03 N ! - FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N ! - FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; - 6.00000E+03 N ! - FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; - 6.00000E+03 N ! - FUNCTION UN_ASS 298.15 0; 300 N ! - - TYPE_DEFINITION % SEQ *! - DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! - DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! - - - PHASE LIQUID:L % 1 1.0 ! - CONSTITUENT LIQUID:L :CR,FE : ! - - PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T - +2.37615E-21*T**7+GHSERCR#+GPCRLIQ#; 2.18000E+03 Y - +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#+GPCRLIQ#; 6.00000E+03 - N REF283 ! - PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 - N REF283 ! - PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -14550+6.65*T; 6.00000E+03 - N REF107 ! - - - TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! - PHASE BCC_A2 %& 2 1 3 ! - CONSTITUENT BCC_A2 :CR%,FE% : VA% : ! - - PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; - 6.00000E+03 N REF283 ! - PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N - REF281 ! - PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.01; 6.00000E+03 N - REF281 ! - PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; - 6.00000E+03 N REF283 ! - PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF281 ! - PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N - REF281 ! - PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 - N REF107 ! - PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N - REF107 ! - PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N - REF107 ! - PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N - REF107 ! - - - TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! - PHASE FCC_A1 %' 2 1 1 ! - CONSTITUENT FCC_A1 :CR,FE% : VA% : ! - - PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; - 6.00000E+03 N REF281 ! - PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N - REF281 ! - PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N - REF281 ! - PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; - 6.00000E+03 N REF283 ! - PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF281 ! - PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N - REF281 ! - PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; - 6.00000E+03 N REF107 ! - PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N - REF107 ! - - - PHASE SIGMA % 3 8 4 18 ! - CONSTITUENT SIGMA :FE : CR : CR,FE : ! - - PARAMETER G(SIGMA,FE:CR:CR;0) 2.98150E+02 +8*GFEFCC#+22*GHSERCR#+92300 - -95.96*T+GPSIG1#; 6.00000E+03 N REF107 ! - PARAMETER G(SIGMA,FE:CR:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# - +18*GHSERFE#+117300-95.96*T+GPSIG2#; 6.00000E+03 N REF107 ! - - LIST_OF_REFERENCES - NUMBER SOURCE - REF283 'Alan Dinsdale, SGTE Data for Pure Elements, - Calphad Vol 15(1991) p 317-425, - also in NPL Report DMA(A)195 Rev. August 1990' - REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 - September 1989' - REF107 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 - TRITA 0270 (1986); CR-FE' - ! - + +$ Database file written 2012- 9- 7 +$ From database: SSOL2 + ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01! + ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! + + + FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) + +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y + -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N ! + FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N ! + FUNCTION GFELIQ 2.98150E+02 +12040.17-6.55843*T-3.6751551E-21*T**7 + +GHSERFE#; 1.81100E+03 Y + -10839.7+291.302*T-46*T*LN(T); 6.00000E+03 N ! + FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N ! + FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N ! + FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T) + -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y + -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N + ! + FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N ! + FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N ! + FUNCTION GFEFCC 2.98150E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 + +GHSERFE#; 1.81100E+03 Y + -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N + ! + FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! + FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N ! + FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N ! + FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N ! + FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N ! + FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N ! + FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N ! + FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N ! + FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N ! + FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N ! + FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N ! + FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! + FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N ! + FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N + ! + FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N ! + FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N ! + FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 + N ! + FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N ! + FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 + N ! + FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N + ! + FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N ! + FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N ! + FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 + N ! + FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N ! + FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 + N ! + FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 + N ! + FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N ! + FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 + N ! + FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N + ! + FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N ! + FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N ! + FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N ! + FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; + 6.00000E+03 N ! + FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N ! + FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N + ! + FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N ! + FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N ! + FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; + 6.00000E+03 N ! + FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; + 6.00000E+03 N ! + FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N ! + FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N ! + FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; + 6.00000E+03 N ! + FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N ! + FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N ! + FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; + 6.00000E+03 N ! + FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N ! + FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; + 6.00000E+03 N ! + FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; + 6.00000E+03 N ! + FUNCTION UN_ASS 298.15 0; 300 N ! + + TYPE_DEFINITION % SEQ *! + DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! + DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! + + + PHASE LIQUID:L % 1 1.0 ! + CONSTITUENT LIQUID:L :CR,FE : ! + + PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T + +2.37615E-21*T**7+GHSERCR#+GPCRLIQ#; 2.18000E+03 Y + +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#+GPCRLIQ#; 6.00000E+03 + N REF283 ! + PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 + N REF283 ! + PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -14550+6.65*T; 6.00000E+03 + N REF107 ! + + + TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! + PHASE BCC_A2 %& 2 1 3 ! + CONSTITUENT BCC_A2 :CR%,FE% : VA% : ! + + PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N + REF281 ! + PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.01; 6.00000E+03 N + REF281 ! + PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF281 ! + PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N + REF281 ! + PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 + N REF107 ! + PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N + REF107 ! + PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N + REF107 ! + PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N + REF107 ! + + + TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! + PHASE FCC_A1 %' 2 1 1 ! + CONSTITUENT FCC_A1 :CR,FE% : VA% : ! + + PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; + 6.00000E+03 N REF281 ! + PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N + REF281 ! + PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N + REF281 ! + PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF281 ! + PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N + REF281 ! + PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; + 6.00000E+03 N REF107 ! + PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N + REF107 ! + + + PHASE SIGMA % 3 8 4 18 ! + CONSTITUENT SIGMA :FE : CR : CR,FE : ! + + PARAMETER G(SIGMA,FE:CR:CR;0) 2.98150E+02 +8*GFEFCC#+22*GHSERCR#+92300 + -95.96*T+GPSIG1#; 6.00000E+03 N REF107 ! + PARAMETER G(SIGMA,FE:CR:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# + +18*GHSERFE#+117300-95.96*T+GPSIG2#; 6.00000E+03 N REF107 ! + + LIST_OF_REFERENCES + NUMBER SOURCE + REF283 'Alan Dinsdale, SGTE Data for Pure Elements, + Calphad Vol 15(1991) p 317-425, + also in NPL Report DMA(A)195 Rev. August 1990' + REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 + September 1989' + REF107 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 + TRITA 0270 (1986); CR-FE' + ! + diff --git a/TQlib/F90/test1/linktqex1.txt b/TQ3lib-clean/F90/test1/linktqex1.txt similarity index 100% rename from TQlib/F90/test1/linktqex1.txt rename to TQ3lib-clean/F90/test1/linktqex1.txt diff --git a/TQlib/F90/test2/FENI.TDB b/TQ3lib-clean/F90/test2/FENI.TDB similarity index 98% rename from TQlib/F90/test2/FENI.TDB rename to TQ3lib-clean/F90/test2/FENI.TDB index ec736be..c3133fa 100644 --- a/TQlib/F90/test2/FENI.TDB +++ b/TQ3lib-clean/F90/test2/FENI.TDB @@ -1,105 +1,105 @@ -$ Database file written 2014- 1-15 -$ From database: SSOL2 - ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! - ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! - ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! - ELEMENT NI FCC_A1 5.8690E+01 4.7870E+03 2.9796E+01! - - - FUNCTION GFELIQ 298.15 +12040.17-6.55843*T-3.6751551E-21*T**7 - +GHSERFE#; 1.81100E+03 Y - -10839.7+291.302*T-46*T*LN(T); 6000 N ! - FUNCTION GHSERFE 298.15 +1225.7+124.134*T-23.5143*T*LN(T) - -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y - -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6000 N ! - FUNCTION GNIBCC 298.15 +8715.084-3.556*T+GHSERNI#; 6000 N ! - FUNCTION GFEFCC 298.15 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 - +GHSERFE#; 1.81100E+03 Y - -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6000 N ! - FUNCTION GHSERNI 298.15 -5179.159+117.854*T-22.096*T*LN(T) - -.0048407*T**2; 1.72800E+03 Y - -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3.00000E+03 N ! - FUNCTION GPFELIQ 298.15 7E-6*P; 6000 N ! - FUNCTION GPFEFCC 298.15 5E-6*P; 6000 N ! - FUNCTION GPFEBCC 298.15 6E-6*P; 6000 N ! - FUNCTION GPNILIQ 298.15 8E-6*P; 6000 N ! - FUNCTION GPNIFCC 298.15 6E-6*P; 6000 N ! - FUNCTION GPNIBCC 298.15 7E-6*P; 6000 N ! -$ this is 1/RT - FUNCTION IQRT 298.15 0.12027167*T**(-1); 6000 N ! - - TYPE_DEFINITION % SEQ *! - DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! - DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! - - - PHASE LIQUID:L % 1 1.0 ! - CONSTITUENT LIQUID:L :FE,NI : ! - - PARAMETER G(LIQUID,FE;0) 298.15 +GFELIQ#+GPFELIQ#; 6000 N REF283 ! - PARAMETER G(LIQUID,NI;0) 298.15 +11235.527+108.457*T - -22.096*T*LN(T)-.0048407*T**2-3.82318E-21*T**7+GPNILIQ; 1.72800E+03 Y - -9549.775+268.598*T-43.1*T*LN(T)+GPNILIQ; 3.00000E+03 N REF283 ! - PARAMETER G(LIQUID,FE,NI;0) 298.15 -18378.86+6.03912*T; 6000 N REF158 ! - PARAMETER G(LIQUID,FE,NI;1) 298.15 +9228.1-3.54642*T; 6000 N REF158 ! -$ LN(mobilities) - PARAMETER MQ&FE(LIQUID,FE;0) 298.15 -10000*IQRT-18; 6000 N BOS ! - PARAMETER MQ&FE(LIQUID,NI;0) 298.15 -12000*IQRT-19; 6000 N BOS ! - PARAMETER MQ&NI(LIQUID,NI;0) 298.15 -11000*IQRT-18; 6000 N BOS ! - PARAMETER MQ&NI(LIQUID,FE;0) 298.15 -13000*IQRT-19; 6000 N BOS ! - - - TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! -$ PHASE BCC_A2 %& 2 1 3 ! -$ CONSTITUENT BCC_A2 :FE%,NI : VA% : ! - - PARAMETER G(BCC_A2,FE:VA;0) 298.15 +GHSERFE#+GPFEBCC#; 6000 N REF283 ! - PARAMETER TC(BCC_A2,FE:VA;0) 298.15 1043; 6000 N REF281 ! - PARAMETER BMAGN(BCC_A2,FE:VA;0) 298.15 2.22; 6000 N REF281 ! - PARAMETER G(BCC_A2,NI:VA;0) 298.15 +GNIBCC#+GPNIBCC; 3000 N REF283 ! - PARAMETER TC(BCC_A2,NI:VA;0) 298.15 575; 6000 N REF281 ! - PARAMETER BMAGN(BCC_A2,NI:VA;0) 298.15 .85; 6000 N REF281 ! - PARAMETER G(BCC_A2,FE,NI:VA;0) 298.15 -956.63-1.28726*T; 6000 N REF158 ! - PARAMETER G(BCC_A2,FE,NI:VA;1) 298.15 +1789.03-1.92912*T; 6000 N REF158 ! -$ LN(mobilities) - PARAMETER MQ&FE(BCC_A2,FE:VA;0) 298.15 -20000*IQRT-24; 6000 N BOS ! - PARAMETER MQ&FE(BCC_A2,NI:VA;0) 298.15 -22000*IQRT-24; 6000 N BOS ! - PARAMETER MQ&NI(BCC_A2,NI:VA;0) 298.15 -25000*IQRT-25; 6000 N BOS ! - PARAMETER MQ&NI(BCC_A2,FE:VA;0) 298.15 -28000*IQRT-25; 6000 N BOS ! - - TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! - PHASE FCC_A1 %' 2 1 1 ! - CONSTITUENT FCC_A1 :FE%,NI% : VA% : ! - - PARAMETER G(FCC_A1,FE:VA;0) 298.15 +GFEFCC#+GPFEFCC#; 6000 N REF283 ! - PARAMETER TC(FCC_A1,FE:VA;0) 298.15 -201; 6000 N REF281 ! - PARAMETER BMAGN(FCC_A1,FE:VA;0) 298.15 -2.1; 6000 N REF281 ! - PARAMETER G(FCC_A1,NI:VA;0) 298.15 +GHSERNI#+GPNIFCC; 3000 N REF283 ! - PARAMETER TC(FCC_A1,NI:VA;0) 298.15 633; 6000 N REF281 ! - PARAMETER BMAGN(FCC_A1,NI:VA;0) 298.15 .52; 6000 N REF281 ! - PARAMETER G(FCC_A1,FE,NI:VA;0) 298.15 -12054.355+3.27413*T; 6000 N REF158 ! - PARAMETER G(FCC_A1,FE,NI:VA;1) 298.15 +11082.1315-4.45077*T; 6000 N REF158 ! - PARAMETER G(FCC_A1,FE,NI:VA;2) 298.15 -725.805174; 6000 N REF158 ! - PARAMETER TC(FCC_A1,FE,NI:VA;0) 298.15 2133; 6000 N REF158 ! - PARAMETER TC(FCC_A1,FE,NI:VA;1) 298.15 -682; 6000 N REF158 ! - PARAMETER BMAGN(FCC_A1,FE,NI:VA;0) 298.15 9.55; 6000 N REF158 ! - PARAMETER BMAGN(FCC_A1,FE,NI:VA;1) 298.15 7.23; 6000 N REF158 ! - PARAMETER BMAGN(FCC_A1,FE,NI:VA;2) 298.15 5.93; 6000 N REF158 ! - PARAMETER BMAGN(FCC_A1,FE,NI:VA;3) 298.15 6.18; 6000 N REF158 ! -$ LN(mobilities) - PARAMETER MQ&FE(FCC_A1,FE:VA;0) 298.15 -30000*IQRT-30; 6000 N BOS ! - PARAMETER MQ&FE(FCC_A1,NI:VA;0) 298.15 -32000*IQRT-32; 6000 N BOS ! - PARAMETER MQ&NI(FCC_A1,NI:VA;0) 298.15 -33000*IQRT-32; 6000 N BOS ! - PARAMETER MQ&NI(FCC_A1,FE:VA;0) 298.15 -25000*IQRT-31; 6000 N BOS ! - - LIST_OF_REFERENCES - NUMBER SOURCE - REF283 'Alan Dinsdale, SGTE Data for Pure Elements, - Calphad Vol 15(1991) p 317-425, - also in NPL Report DMA(A)195 Rev. August 1990' - REF158 'A. Dinsdale, T. Chart, MTDS NPL, unpublished work (1986); FE-NI' - REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 - September 1989' - BOS 'Invented mobilities and molar volumes' - ! - +$ Database file written 2014- 1-15 +$ From database: SSOL2 + ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! + ELEMENT NI FCC_A1 5.8690E+01 4.7870E+03 2.9796E+01! + + + FUNCTION GFELIQ 298.15 +12040.17-6.55843*T-3.6751551E-21*T**7 + +GHSERFE#; 1.81100E+03 Y + -10839.7+291.302*T-46*T*LN(T); 6000 N ! + FUNCTION GHSERFE 298.15 +1225.7+124.134*T-23.5143*T*LN(T) + -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y + -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6000 N ! + FUNCTION GNIBCC 298.15 +8715.084-3.556*T+GHSERNI#; 6000 N ! + FUNCTION GFEFCC 298.15 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 + +GHSERFE#; 1.81100E+03 Y + -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6000 N ! + FUNCTION GHSERNI 298.15 -5179.159+117.854*T-22.096*T*LN(T) + -.0048407*T**2; 1.72800E+03 Y + -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3.00000E+03 N ! + FUNCTION GPFELIQ 298.15 7E-6*P; 6000 N ! + FUNCTION GPFEFCC 298.15 5E-6*P; 6000 N ! + FUNCTION GPFEBCC 298.15 6E-6*P; 6000 N ! + FUNCTION GPNILIQ 298.15 8E-6*P; 6000 N ! + FUNCTION GPNIFCC 298.15 6E-6*P; 6000 N ! + FUNCTION GPNIBCC 298.15 7E-6*P; 6000 N ! +$ this is 1/RT + FUNCTION IQRT 298.15 0.12027167*T**(-1); 6000 N ! + + TYPE_DEFINITION % SEQ *! + DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! + DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! + + + PHASE LIQUID:L % 1 1.0 ! + CONSTITUENT LIQUID:L :FE,NI : ! + + PARAMETER G(LIQUID,FE;0) 298.15 +GFELIQ#+GPFELIQ#; 6000 N REF283 ! + PARAMETER G(LIQUID,NI;0) 298.15 +11235.527+108.457*T + -22.096*T*LN(T)-.0048407*T**2-3.82318E-21*T**7+GPNILIQ; 1.72800E+03 Y + -9549.775+268.598*T-43.1*T*LN(T)+GPNILIQ; 3.00000E+03 N REF283 ! + PARAMETER G(LIQUID,FE,NI;0) 298.15 -18378.86+6.03912*T; 6000 N REF158 ! + PARAMETER G(LIQUID,FE,NI;1) 298.15 +9228.1-3.54642*T; 6000 N REF158 ! +$ LN(mobilities) + PARAMETER MQ&FE(LIQUID,FE;0) 298.15 -10000*IQRT-18; 6000 N BOS ! + PARAMETER MQ&FE(LIQUID,NI;0) 298.15 -12000*IQRT-19; 6000 N BOS ! + PARAMETER MQ&NI(LIQUID,NI;0) 298.15 -11000*IQRT-18; 6000 N BOS ! + PARAMETER MQ&NI(LIQUID,FE;0) 298.15 -13000*IQRT-19; 6000 N BOS ! + + + TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! +$ PHASE BCC_A2 %& 2 1 3 ! +$ CONSTITUENT BCC_A2 :FE%,NI : VA% : ! + + PARAMETER G(BCC_A2,FE:VA;0) 298.15 +GHSERFE#+GPFEBCC#; 6000 N REF283 ! + PARAMETER TC(BCC_A2,FE:VA;0) 298.15 1043; 6000 N REF281 ! + PARAMETER BMAGN(BCC_A2,FE:VA;0) 298.15 2.22; 6000 N REF281 ! + PARAMETER G(BCC_A2,NI:VA;0) 298.15 +GNIBCC#+GPNIBCC; 3000 N REF283 ! + PARAMETER TC(BCC_A2,NI:VA;0) 298.15 575; 6000 N REF281 ! + PARAMETER BMAGN(BCC_A2,NI:VA;0) 298.15 .85; 6000 N REF281 ! + PARAMETER G(BCC_A2,FE,NI:VA;0) 298.15 -956.63-1.28726*T; 6000 N REF158 ! + PARAMETER G(BCC_A2,FE,NI:VA;1) 298.15 +1789.03-1.92912*T; 6000 N REF158 ! +$ LN(mobilities) + PARAMETER MQ&FE(BCC_A2,FE:VA;0) 298.15 -20000*IQRT-24; 6000 N BOS ! + PARAMETER MQ&FE(BCC_A2,NI:VA;0) 298.15 -22000*IQRT-24; 6000 N BOS ! + PARAMETER MQ&NI(BCC_A2,NI:VA;0) 298.15 -25000*IQRT-25; 6000 N BOS ! + PARAMETER MQ&NI(BCC_A2,FE:VA;0) 298.15 -28000*IQRT-25; 6000 N BOS ! + + TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! + PHASE FCC_A1 %' 2 1 1 ! + CONSTITUENT FCC_A1 :FE%,NI% : VA% : ! + + PARAMETER G(FCC_A1,FE:VA;0) 298.15 +GFEFCC#+GPFEFCC#; 6000 N REF283 ! + PARAMETER TC(FCC_A1,FE:VA;0) 298.15 -201; 6000 N REF281 ! + PARAMETER BMAGN(FCC_A1,FE:VA;0) 298.15 -2.1; 6000 N REF281 ! + PARAMETER G(FCC_A1,NI:VA;0) 298.15 +GHSERNI#+GPNIFCC; 3000 N REF283 ! + PARAMETER TC(FCC_A1,NI:VA;0) 298.15 633; 6000 N REF281 ! + PARAMETER BMAGN(FCC_A1,NI:VA;0) 298.15 .52; 6000 N REF281 ! + PARAMETER G(FCC_A1,FE,NI:VA;0) 298.15 -12054.355+3.27413*T; 6000 N REF158 ! + PARAMETER G(FCC_A1,FE,NI:VA;1) 298.15 +11082.1315-4.45077*T; 6000 N REF158 ! + PARAMETER G(FCC_A1,FE,NI:VA;2) 298.15 -725.805174; 6000 N REF158 ! + PARAMETER TC(FCC_A1,FE,NI:VA;0) 298.15 2133; 6000 N REF158 ! + PARAMETER TC(FCC_A1,FE,NI:VA;1) 298.15 -682; 6000 N REF158 ! + PARAMETER BMAGN(FCC_A1,FE,NI:VA;0) 298.15 9.55; 6000 N REF158 ! + PARAMETER BMAGN(FCC_A1,FE,NI:VA;1) 298.15 7.23; 6000 N REF158 ! + PARAMETER BMAGN(FCC_A1,FE,NI:VA;2) 298.15 5.93; 6000 N REF158 ! + PARAMETER BMAGN(FCC_A1,FE,NI:VA;3) 298.15 6.18; 6000 N REF158 ! +$ LN(mobilities) + PARAMETER MQ&FE(FCC_A1,FE:VA;0) 298.15 -30000*IQRT-30; 6000 N BOS ! + PARAMETER MQ&FE(FCC_A1,NI:VA;0) 298.15 -32000*IQRT-32; 6000 N BOS ! + PARAMETER MQ&NI(FCC_A1,NI:VA;0) 298.15 -33000*IQRT-32; 6000 N BOS ! + PARAMETER MQ&NI(FCC_A1,FE:VA;0) 298.15 -25000*IQRT-31; 6000 N BOS ! + + LIST_OF_REFERENCES + NUMBER SOURCE + REF283 'Alan Dinsdale, SGTE Data for Pure Elements, + Calphad Vol 15(1991) p 317-425, + also in NPL Report DMA(A)195 Rev. August 1990' + REF158 'A. Dinsdale, T. Chart, MTDS NPL, unpublished work (1986); FE-NI' + REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 + September 1989' + BOS 'Invented mobilities and molar volumes' + ! + diff --git a/TQlib/F90/test2/TQ2-feni.F90 b/TQ3lib-clean/F90/test2/TQ2-feni.F90 similarity index 100% rename from TQlib/F90/test2/TQ2-feni.F90 rename to TQ3lib-clean/F90/test2/TQ2-feni.F90 diff --git a/TQlib/F90/test2/linktq2.txt b/TQ3lib-clean/F90/test2/linktq2.txt similarity index 96% rename from TQlib/F90/test2/linktq2.txt rename to TQ3lib-clean/F90/test2/linktq2.txt index 5c59c05..4910575 100644 --- a/TQlib/F90/test2/linktq2.txt +++ b/TQ3lib-clean/F90/test2/linktq2.txt @@ -1,2 +1,2 @@ -gfortran -o tqex2 TQ2-feni.F90 liboctq.o liboceq.a - +gfortran -o tqex2 TQ2-feni.F90 liboctq.o liboceq.a + diff --git a/TQlib/F90/test3/OU.TDB b/TQ3lib-clean/F90/test3/OU.TDB similarity index 100% rename from TQlib/F90/test3/OU.TDB rename to TQ3lib-clean/F90/test3/OU.TDB diff --git a/TQlib/F90/test3/TQ3-OU.F90 b/TQ3lib-clean/F90/test3/TQ3-OU.F90 similarity index 100% rename from TQlib/F90/test3/TQ3-OU.F90 rename to TQ3lib-clean/F90/test3/TQ3-OU.F90 diff --git a/TQlib/F90/test3/linktq3.txt b/TQ3lib-clean/F90/test3/linktq3.txt similarity index 100% rename from TQlib/F90/test3/linktq3.txt rename to TQ3lib-clean/F90/test3/linktq3.txt diff --git a/TQ3lib-clean/F90/test4/TQ4-crfe.F90 b/TQ3lib-clean/F90/test4/TQ4-crfe.F90 new file mode 100644 index 0000000..6bd9cc6 --- /dev/null +++ b/TQ3lib-clean/F90/test4/TQ4-crfe.F90 @@ -0,0 +1,220 @@ +! +! TQ test program 4 calculating various Cr-Fe equilibria +! +program octq4 +! + use liboctq +! + implicit none +! maxel and maxph defined in pmod package +! integer, parameter :: maxel=10,maxph=20 + integer n,n1,n2,n3,n4,ip,cnum(maxel+3),mm,m2,nsel + integer stable1,ll,kk,nlat,nlatc(10),conlista(100) + character filename*60,phnames(maxph)*24 + character condition*60,line*80,statevar*60,quest*60,ch1*1 + character target*60,phcsname*36,selel(maxel)*2 + double precision value,dummy,tp(2),mel(maxel) + double precision xf(maxel),pxf(10*maxph),npf(maxph),mu(maxel) + double precision yfr(100),sites(10),extra(5) +! with 20 constituents dimension of d2gdy2 is 20*(20+1)/2, upper triangle + double precision gtp(6),dgdy(20),d2gdydt(20),d2gdydp(20),d2gdy2(210) + type(gtp_equilibrium_data), pointer :: ceq +! +! initiate + call tqini(n,ceq) + if(gx%bmperr.ne.0) goto 1000 +! write(*,*)'step 1 OK: ',ceq%eqname +! +! read data for Cr and Fe from larger database file + filename='steel1 ' +! element names MUST be in UPPER CASE + nsel=2 + selel(1)='CR' + selel(2)='FE' + call tqrpfil(filename,nsel,selel,ceq) + if(gx%bmperr.ne.0) goto 1000 +! write(*,*)'step 2A OK' +! write(*,*)'test ceq: ',ceq%complist(1)%mass +! write(*,*)'step 2B OK' +! tqrpfil also enters the number of elements in nel and the element names +! in cnam and the number of phases in ntup and all phase tuples in phcs +! +! This stores the phase names in the array phnames +! write(*,*)'test ceq: ',ceq%eqname + do n=1,ntup + call tqgpn(n,phnames(n),ceq) + if(gx%bmperr.ne.0) goto 1000 + enddo +! write(*,*)'step 3A OK' +! write(*,*)'test ceq: ',ceq%eqname +! +! list elements and phases + write(*,10)nel,(cnam(n)(1:2),n=1,nel) +10 format(/'System with ',i2,' elements: ',10(a,', ')) + write(*,20)ntup,(phnames(n)(1:len_trim(phnames(n))),n=1,ntup) +20 format('and ',i3,' phases: ',6(' ',a,',')) +! +! set values of temperature and pressure + tp(1)=8.0D2 + tp(2)=1.0D5 +! set value of element 1 (Cr) + xf(1)=0.3D0 +! +! ------------------------------------- +! set conditions +! write(*,*)'step 3B OK' + n1=0 + n2=0 + condition='T' + call tqsetc(condition,n1,n2,tp(1),cnum(1),ceq) + if(gx%bmperr.ne.0) goto 1000 +! write(*,*)'step 3C OK' + condition='P' + call tqsetc(condition,n1,n2,tp(2),cnum(2),ceq) + if(gx%bmperr.ne.0) goto 1000 + condition='N' + call tqsetc(condition,n1,n2,one,cnum(3),ceq) + if(gx%bmperr.ne.0) goto 1000 + write(*,*)'step 4A OK' +! Mole fraction of first element + condition='X' + n=1 + call tqsetc(condition,n,n2,xf(1),cnum(4),ceq) + if(gx%bmperr.ne.0) goto 1000 +! write(*,*)'step 4B OK' +! +! calculate the equilibria +! n1=0 means call grid minimizer + target=' ' + n1=0 + n2=0 + call tqce(target,n1,n2,value,ceq) + if(gx%bmperr.ne.0) then + write(*,310)gx%bmperr,bmperrmess(gx%bmperr) +310 format('Calculation failed, error code: ',i5/a) + goto 1000 + else + write(*,320) +320 format(/'Successful calculation') + endif + write(*,*)'step 5 OK: ',ceq%eqname +! +!------------------------------------------------ +! list some results +! amount of all phases + statevar='NP' + n1=-1 + n2=0 + n3=size(npf) + call tqgetv(statevar,n1,n2,n3,npf,ceq) + if(gx%bmperr.ne.0) goto 1000 + write(*,505)n3,(npf(n),n=1,n3) +505 format(/'Amount of ',i2,' phases: ',6F8.4,(/21X,6F8.4)) +!------------------------------------------------ +! composition of stable phases +! NOTE that the number of phases may have changed if new composition sets +! created. n3 from previous call is current number of phase tuples + ntup=n3 + stable1=0 + phloop: do n=1,ntup + if(npf(n).gt.zero) then +! the phase is stable if it has a positive amount ... it can be stable with 0 + if(stable1.eq.0) stable1=n + call tqgpn(n,phcsname,ceq) + write(*,510)phcsname(1:len_trim(phcsname)),npf(n) +510 format(/'Stable phase: ',a,', amount: ',1PE12.4,', mole fractions:') +! composition of stable phase, n2=-1 means all fractions + statevar='X' + n2=-1 + n4=size(pxf) +! Use phase tupe index: n + call tqgetv(statevar,n,n2,n4,pxf,ceq) + if(gx%bmperr.ne.0) goto 1000 +! write 3 fractions on each line + write(*,520)(cnam(m2)(1:8),pxf(m2),m2=1,n4) +520 format(3(a,': ',F9.6,', ')) + endif + enddo phloop +! chemical potentials + write(*,525) +525 format(/'Component, mole fraction and chemical potential (SER)') + do n=1,nel + statevar='MU' + n2=0 + n4=size(pxf) + call tqgetv(statevar,n,n2,n4,pxf,ceq) + if(gx%bmperr.ne.0) goto 1000 + mu(n)=pxf(1) + statevar='X' + call tqgetv(statevar,n,n2,n4,pxf,ceq) + if(gx%bmperr.ne.0) goto 1000 + write(*,530)cnam(n)(1:2),pxf(1),mu(n) +530 format(a,10x,F10.6,10x,1PE14.6) + enddo +!---------------------------------------------------------- +! Now some phase specific calculations +! +! to obtain the constitution use tqgphd1 + call tqgphc1(stable1,nlat,nlatc,conlista,yfr,sites,extra,ceq) + if(gx%bmperr.ne.0) goto 1000 +! + write(*,602)stable1,extra(1) +602 format(//'Constitution of stable phase: ',i3,' with ',F8.4,& + ' moles of atoms/formula unit') + kk=0 + do ll=1,nlat + write(*,610)nlatc(ll),sites(ll) +610 format('Sublattice with ',i3,' constituents and ',F8.4' sites') + do mm=1,nlatc(ll) + kk=kk+1 + write(*,620)kk,yfr(kk) +620 format('Fraction of constituent ',i3,': ',1pe14.6) + enddo + enddo +! +! to change the constitution use tqsphc1, yfr in same order as above + call tqsphc1(stable1,yfr,extra,ceq) + if(gx%bmperr.ne.0) goto 1000 +! + write(*,*)'Calculate G and derivatives: ' +! this calculates G and all derivatives. With n1=0 only G and G.T, G.P + n1=2 + call tqcph1(stable1,n1,n2,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,ceq) + if(gx%bmperr.ne.0) goto 1000 +! G and derivatives wrt T and P + write(*,630)'G: ',gtp +630 format(a,6(1pe12.4)) +! first derivatives wrt fractions + write(*,630)'dgdy: ',(dgdy(ll),ll=1,n2) + write(*,630)'d2gdydt: ',(d2gdydt(ll),ll=1,n2) + write(*,630)'d2gdydp: ',(d2gdydp(ll),ll=1,n2) +! second derivatives wrt fractions + kk=n2*(n2+1)/2 + write(*,630)'d2gdy2: ',(d2gdy2(ll),ll=1,kk) +! +! write(*,*) +! write(*,*)'Test accessing data directly ... we do not know lokres!!! +! write(*,630)'G: ',(ceq%phase_varres(lokres)%gval(ll),ll=1,6) +! + write(*,*) + write(*,*)'Calculating chemical potential:' + value=gtp(1)+dgdy(1)-yfr(1)*dgdy(1)-yfr(2)*dgdy(2) + write(*,630)'mu(1)/RT: ',value + write(*,630)'mu(1) : ',value*8.31451*tp(1) + +! +! end of program, possible error messages +1000 continue + if(gx%bmperr.ne.0) then + if(gx%bmperr.ge.4000 .and. gx%bmperr.le.4220) then + write(*,1010)gx%bmperr,bmperrmess(gx%bmperr) +1010 format(' *** Error ',i5/a) + else + write(*,1020)gx%bmperr +1020 format(' *** Error ',i5/'Unknown reason') + endif + endif + write(*,*) + write(*,*)'Auf wiedersehen' +end program octq4 + diff --git a/TQ3lib-clean/F90/test4/linktqex4.txt b/TQ3lib-clean/F90/test4/linktqex4.txt new file mode 100644 index 0000000..a76c757 --- /dev/null +++ b/TQ3lib-clean/F90/test4/linktqex4.txt @@ -0,0 +1,2 @@ +gfortran -o tqex4 TQ4-crfe.F90 liboctq.o liboceq.a + diff --git a/macros/steel1.TDB b/TQ3lib-clean/F90/test4/steel1.TDB similarity index 97% rename from macros/steel1.TDB rename to TQ3lib-clean/F90/test4/steel1.TDB index 0809ffe..c820294 100644 --- a/macros/steel1.TDB +++ b/TQ3lib-clean/F90/test4/steel1.TDB @@ -1,1210 +1,1210 @@ - -$ Database file written 2012- 2-11 -$ From database: SSOL2 - ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! - ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! - ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7400E+00! - ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01! - ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! - ELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01! - ELEMENT SI DIAMOND_A4 2.8085E+01 3.2175E+03 1.8820E+01! - ELEMENT V BCC_A2 5.0941E+01 4.5070E+03 3.0890E+01! - - SPECIES C1 C! - SPECIES C2 C2! - SPECIES C3 C3! - SPECIES C4 C4! - SPECIES C5 C5! - SPECIES C6 C6! - SPECIES C7 C7! - SPECIES V1C1 V1C1! - - FUNCTION GHSERCC 2.98150E+02 -17368.441+170.73*T-24.3*T*LN(T) - -4.723E-04*T**2+2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3); - 6.00000E+03 N ! - FUNCTION GPCLIQ 2.98150E+02 +YCLIQ#*EXP(ZCLIQ#); 6.00000E+03 N ! - FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) - +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y - -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N ! - FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N ! - FUNCTION GFELIQ 2.98150E+02 +12040.17-6.55843*T-3.6751551E-21*T**7 - +GHSERFE#; 1.81100E+03 Y - -10839.7+291.302*T-46*T*LN(T); 6.00000E+03 N ! - FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N ! - FUNCTION GHSERMO 2.98150E+02 -7746.302+131.9197*T-23.56414*T*LN(T) - -.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4; - 2.89600E+03 Y - -30556.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9); - 5.00000E+03 N ! - FUNCTION GPMOLIQ 2.98150E+02 +YMOLIQ#*EXP(ZMOLIQ#); 6.00000E+03 N ! - FUNCTION GHSERSI 2.98150E+02 -8162.609+137.227259*T-22.8317533*T*LN(T) - -.001912904*T**2-3.552E-09*T**3+176667*T**(-1); 1.68700E+03 Y - -9457.642+167.271767*T-27.196*T*LN(T)-4.20369E+30*T**(-9); - 3.60000E+03 N ! - FUNCTION GHSERVV 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T) - -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y - -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; - 2.18300E+03 Y - -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); - 4.00000E+03 N ! - FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N ! - FUNCTION GPCGRA 2.98150E+02 +YCGRA#*EXP(ZCGRA#); 6.00000E+03 N ! - FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T) - -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y - -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N - ! - FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N ! - FUNCTION GSIBCC 2.98150E+02 +47000-22.5*T+GHSERSI#; 6.00000E+03 N ! - FUNCTION GPMOBCC 2.98150E+02 +YMOBCC#*EXP(ZMOBCC#); 6.00000E+03 N ! - FUNCTION GFECEM 2.98150E+02 -10745+706.04*T-120.6*T*LN(T)+GPCEM1#; - 6.00000E+03 N ! - FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N ! - FUNCTION GFEFCC 2.98150E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 - +GHSERFE#; 1.81100E+03 Y - -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N - ! - FUNCTION GMOFCC 2.98150E+02 +15200+.63*T+GHSERMO#; 6.00000E+03 N ! - FUNCTION GPCDIA 2.98150E+02 +YCDIA#*EXP(ZCDIA#); 6.00000E+03 N ! - FUNCTION GPCFCC 2.98150E+02 +YCFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! - FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! - FUNCTION GHSERVZ 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T) - -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y - -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; - 4.00000E+03 Y - -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); - 6.00000E+03 N ! - FUNCTION GPFEHCP 2.98150E+02 +YFEHCP#*EXP(ZFEHCP#); 6.00000E+03 N ! - FUNCTION GCRM23C6 2.98150E+02 -521983+3622.24*T-620.965*T*LN(T) - -.126431*T**2; 6.00000E+03 N ! - FUNCTION GFEM23C6 2.98150E+02 +7.666667*GFECEM#-1.666667*GHSERCC#+66920 - -40*T; 6.00000E+03 N ! - FUNCTION GVM23C6 2.98150E+02 -990367+4330.63*T-728.829*T*LN(T) - +5003425*T**(-1); 6.00000E+03 N ! - FUNCTION GCRM3C2 2.98150E+02 -100823.8+530.66989*T-89.6694*T*LN(T) - -.0301188*T**2; 6.00000E+03 N ! - FUNCTION GCRM7C3 2.98150E+02 -201690+1103.128*T-190.177*T*LN(T) - -.0578207*T**2; 6.00000E+03 N ! - FUNCTION GPMU1 2.98150E+02 +8.72E-05*P; 6.00000E+03 N ! - FUNCTION GPMU2 2.98150E+02 +1.04E-04*P; 6.00000E+03 N ! - FUNCTION GPR1 2.98150E+02 +3.81E-04*P; 6.00000E+03 N ! - FUNCTION GPR2 2.98150E+02 +4.33E-04*P; 6.00000E+03 N ! - FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N ! - FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N ! - FUNCTION L0BCC 2.98150E+02 -27809+11.62*T; 6.00000E+03 N ! - FUNCTION FESIW1 2.98150E+02 +1260*R#; 6.00000E+03 N ! - FUNCTION L1BCC 2.98150E+02 -11544; 6.00000E+03 N ! - FUNCTION L2BCC 2.98150E+02 3890; 6.00000E+03 N ! - FUNCTION ETCFESI 2.98150E+02 63; 6.00000E+03 N ! - FUNCTION YCLIQ 2.98150E+02 +VCLIQ#*EXP(-ECLIQ#); 6.00000E+03 N ! - FUNCTION ZCLIQ 2.98150E+02 +1*LN(XCLIQ#); 6.00000E+03 N ! - FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N ! - FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N ! - FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N ! - FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N ! - FUNCTION YMOLIQ 2.98150E+02 +VMOLIQ#*EXP(-EMOLIQ#); 6.00000E+03 N ! - FUNCTION ZMOLIQ 2.98150E+02 +1*LN(XMOLIQ#); 6.00000E+03 N ! - FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N ! - FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N ! - FUNCTION YCGRA 2.98150E+02 +VCGRA#*EXP(-ECGRA#); 6.00000E+03 N ! - FUNCTION ZCGRA 2.98150E+02 +1*LN(XCGRA#); 6.00000E+03 N ! - FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N ! - FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N ! - FUNCTION YMOBCC 2.98150E+02 +VMOBCC#*EXP(-EMOBCC#); 6.00000E+03 N ! - FUNCTION ZMOBCC 2.98150E+02 +1*LN(XMOBCC#); 6.00000E+03 N ! - FUNCTION GPCEM1 2.98150E+02 +VCEM1#*P; 6.00000E+03 N ! - FUNCTION YCDIA 2.98150E+02 +VCDIA#*EXP(-ECDIA#); 6.00000E+03 N ! - FUNCTION ZCDIA 2.98150E+02 +1*LN(XCDIA#); 6.00000E+03 N ! - FUNCTION YCFCC 2.98150E+02 +VCFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! - FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N ! - FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! - FUNCTION YFEHCP 2.98150E+02 +VFEHCP#*EXP(-EFEHCP#); 6.00000E+03 N ! - FUNCTION ZFEHCP 2.98150E+02 +1*LN(XFEHCP#); 6.00000E+03 N ! - FUNCTION VCLIQ 2.98150E+02 +7.626E-06*EXP(ACLIQ#); 6.00000E+03 N ! - FUNCTION ECLIQ 2.98150E+02 +1*LN(CCLIQ#); 6.00000E+03 N ! - FUNCTION XCLIQ 2.98150E+02 +1*EXP(.5*DCLIQ#)-1; 6.00000E+03 N ! - FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N - ! - FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N ! - FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N ! - FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 - N ! - FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N ! - FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 - N ! - FUNCTION VMOLIQ 2.98150E+02 +9.75079E-06*EXP(AMOLIQ#); 6.00000E+03 - N ! - FUNCTION EMOLIQ 2.98150E+02 +1*LN(CMOLIQ#); 6.00000E+03 N ! - FUNCTION XMOLIQ 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 - N ! - FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N - ! - FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N ! - FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N ! - FUNCTION VCGRA 2.98150E+02 +5.259E-06*EXP(ACGRA#); 6.00000E+03 N ! - FUNCTION ECGRA 2.98150E+02 +1*LN(CCGRA#); 6.00000E+03 N ! - FUNCTION XCGRA 2.98150E+02 +1*EXP(.9166667*DCGRA#)-1; 6.00000E+03 - N ! - FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 - N ! - FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N ! - FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 - N ! - FUNCTION VMOBCC 2.98150E+02 +9.34372E-06*EXP(AMOBCC#); 6.00000E+03 - N ! - FUNCTION EMOBCC 2.98150E+02 +1*LN(CMOBCC#); 6.00000E+03 N ! - FUNCTION XMOBCC 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 - N ! - FUNCTION VCEM1 2.98150E+02 +2.339E-05*EXP(ACEM1#); 6.00000E+03 N ! - FUNCTION VCDIA 2.98150E+02 +3.412E-06*EXP(ACDIA#); 6.00000E+03 N ! - FUNCTION ECDIA 2.98150E+02 +1*LN(CCDIA#); 6.00000E+03 N ! - FUNCTION XCDIA 2.98150E+02 +1*EXP(.8*DCDIA#)-1; 6.00000E+03 N ! - FUNCTION VCFCC 2.98150E+02 +1.031E-05*EXP(ACFCC#); 6.00000E+03 N ! - FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N ! - FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 - N ! - FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 - N ! - FUNCTION VFEHCP 2.98150E+02 +6.59121E-06*EXP(AFEHCP#); 6.00000E+03 - N ! - FUNCTION EFEHCP 2.98150E+02 +1*LN(CFEHCP#); 6.00000E+03 N ! - FUNCTION XFEHCP 2.98150E+02 +1*EXP(.8064454*DFEHCP#)-1; 6.00000E+03 - N ! - FUNCTION ACLIQ 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 - N ! - FUNCTION CCLIQ 2.98150E+02 1.6E-10; 6.00000E+03 N ! - FUNCTION DCLIQ 2.98150E+02 +1*LN(BCLIQ#); 6.00000E+03 N ! - FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N - ! - FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N ! - FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N ! - FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N ! - FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; - 6.00000E+03 N ! - FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N ! - FUNCTION AMOLIQ 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2 - +1.14687E-12*T**3; 6.00000E+03 N ! - FUNCTION CMOLIQ 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; - 6.00000E+03 N ! - FUNCTION DMOBCC 2.98150E+02 +1*LN(BMOBCC#); 6.00000E+03 N ! - FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N - ! - FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N ! - FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N ! - FUNCTION ACGRA 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 - N ! - FUNCTION CCGRA 2.98150E+02 3.3E-10; 6.00000E+03 N ! - FUNCTION DCGRA 2.98150E+02 +1*LN(BCGRA#); 6.00000E+03 N ! - FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; - 6.00000E+03 N ! - FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; - 6.00000E+03 N ! - FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N ! - FUNCTION AMOBCC 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2 - +1.14687E-12*T**3; 6.00000E+03 N ! - FUNCTION CMOBCC 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; - 6.00000E+03 N ! - FUNCTION ACEM1 2.98150E+02 -1.36E-05*T+4E-08*T**2; 6.00000E+03 N ! - FUNCTION ACDIA 2.98150E+02 +2.43E-06*T+5E-09*T**2; 6.00000E+03 N ! - FUNCTION CCDIA 2.98150E+02 6.8E-12; 6.00000E+03 N ! - FUNCTION DCDIA 2.98150E+02 +1*LN(BCDIA#); 6.00000E+03 N ! - FUNCTION ACFCC 2.98150E+02 +1.44E-04*T; 6.00000E+03 N ! - FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; - 6.00000E+03 N ! - FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N ! - FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N ! - FUNCTION AFEHCP 2.98150E+02 +7.3646E-05*T; 6.00000E+03 N ! - FUNCTION CFEHCP 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; - 6.00000E+03 N ! - FUNCTION DFEHCP 2.98150E+02 +1*LN(BFEHCP#); 6.00000E+03 N ! - FUNCTION BCLIQ 2.98150E+02 +1+3.2E-10*P; 6.00000E+03 N ! - FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N ! - FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; - 6.00000E+03 N ! - FUNCTION BMOBCC 2.98150E+02 +1+1.13837E-11*P+4.875E-16*T*P - +1.2675E-19*T**2*P; 6.00000E+03 N ! - FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N ! - FUNCTION BCGRA 2.98150E+02 +1+3.6E-10*P; 6.00000E+03 N ! - FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; - 6.00000E+03 N ! - FUNCTION BCDIA 2.98150E+02 +1+8.5E-12*P; 6.00000E+03 N ! - FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; - 6.00000E+03 N ! - FUNCTION BFEHCP 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; - 6.00000E+03 N ! - FUNCTION UN_ASS 298.15 0; 300 N ! - - TYPE_DEFINITION % SEQ *! - DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! - DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! - - - PHASE LIQUID:L % 1 1.0 ! - CONSTITUENT LIQUID:L :C,CR,FE,MO,SI,V : ! - - PARAMETER G(LIQUID,C;0) 2.98150E+02 +117369-24.63*T+GHSERCC#+GPCLIQ#; - 6.00000E+03 N REF283 ! - PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T - +2.37615E-21*T**7+GHSERCR#+GPCRLIQ#; 2.18000E+03 Y - +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#+GPCRLIQ#; 6.00000E+03 - N REF283 ! - PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 - N REF283 ! - PARAMETER G(LIQUID,MO;0) 2.98150E+02 +41831.347-14.694912*T - +4.24519E-22*T**7+GHSERMO#+GPMOLIQ#; 2.89600E+03 Y - +34095.373-11.890046*T+4.849315E+33*T**(-9)+GHSERMO#+GPMOLIQ#; - 5.00000E+03 N REF283 ! - PARAMETER G(LIQUID,SI;0) 2.98150E+02 +50696.36-30.099439*T - +2.09307E-21*T**7+GHSERSI#; 1.68700E+03 Y - +49828.165-29.559069*T+4.20369E+30*T**(-9)+GHSERSI#; 3.60000E+03 N - REF283 ! - PARAMETER G(LIQUID,V;0) 2.98150E+02 +20764.117-9.455552*T - -5.19136E-22*T**7+GHSERVV#; 7.90000E+02 Y - +20764.117-9.455552*T-5.19136E-22*T**7+GHSERVV#; 2.18300E+03 Y - +22072.354-10.0848*T-6.44389E+31*T**(-9)+GHSERVV#; 4.00000E+03 N REF283 ! - PARAMETER G(LIQUID,C,CR;0) 2.98150E+02 -90526-25.9116*T; 6.00000E+03 - N REF101 ! - PARAMETER G(LIQUID,C,CR;1) 2.98150E+02 80000; 6.00000E+03 N REF101 ! - PARAMETER G(LIQUID,C,CR;2) 2.98150E+02 80000; 6.00000E+03 N REF101 ! - PARAMETER G(LIQUID,C,CR,FE;0) 2.98150E+02 -496063; 6.00000E+03 N - REF322 ! - PARAMETER G(LIQUID,C,CR,FE;1) 2.98150E+02 57990; 6.00000E+03 N - REF322 ! - PARAMETER G(LIQUID,C,CR,FE;2) 2.98150E+02 61404; 6.00000E+03 N - REF322 ! - PARAMETER G(LIQUID,C,CR,V;0) 2.98150E+02 -769497; 6.00000E+03 N - REF324 ! - PARAMETER G(LIQUID,C,CR,V;1) 2.98150E+02 263981; 6.00000E+03 N - REF324 ! - PARAMETER G(LIQUID,C,CR,V;2) 2.98150E+02 3599; 6.00000E+03 N REF324 ! - PARAMETER G(LIQUID,C,FE;0) 2.98150E+02 -124320+28.5*T; 6.00000E+03 - N REF190 ! - PARAMETER G(LIQUID,C,FE;1) 2.98150E+02 19300; 6.00000E+03 N REF190 ! - PARAMETER G(LIQUID,C,FE;2) 2.98150E+02 +49260-19*T; 6.00000E+03 N - REF190 ! - PARAMETER G(LIQUID,C,FE,SI;0) 2.98150E+02 445740; 6.00000E+03 N - REF99 ! - PARAMETER G(LIQUID,C,FE,SI;1) 2.98150E+02 -6065-35.33*T; 6.00000E+03 - N REF99 ! - PARAMETER G(LIQUID,C,FE,SI;2) 2.98150E+02 +2545792-1450.6*T; - 6.00000E+03 N REF99 ! - PARAMETER G(LIQUID,C,FE,V;0) 2.98150E+02 -60000; 6.00000E+03 N - REF270 ! - PARAMETER G(LIQUID,C,FE,V;1) 2.98150E+02 -60000; 6.00000E+03 N - REF270 ! - PARAMETER G(LIQUID,C,FE,V;2) 2.98150E+02 100000; 6.00000E+03 N - REF270 ! - PARAMETER G(LIQUID,C,FE,MO;0) 2.98150E+02 -37800; 6.00000E+03 N - REF113 ! - PARAMETER G(LIQUID,C,MO;0) 2.98150E+02 -217800+38.41*T; 6.00000E+03 - N REF104 ! - PARAMETER G(LIQUID,C,MO;1) 2.98150E+02 30000; 6.00000E+03 N REF104 ! - PARAMETER G(LIQUID,C,MO;2) 2.98150E+02 47000; 6.00000E+03 N REF104 ! - PARAMETER G(LIQUID,C,SI;0) 2.98150E+02 -133000+30.97*T; 6.00000E+03 - N REF99 ! - PARAMETER G(LIQUID,C,V;0) 2.98150E+02 -284196+38.952*T; 6.00000E+03 - N REF256 ! - PARAMETER G(LIQUID,C,V;1) 2.98150E+02 +96335-17.775*T; 6.00000E+03 - N REF256 ! - PARAMETER G(LIQUID,C,V;2) 2.98150E+02 102050; 6.00000E+03 N REF256 ! - PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -14550+6.65*T; 6.00000E+03 - N REF107 ! - PARAMETER G(LIQUID,CR,FE,V;0) 2.98150E+02 14881; 6.00000E+03 N - REF323 ! - PARAMETER G(LIQUID,CR,FE,V;1) 2.98150E+02 17968; 6.00000E+03 N - REF323 ! - PARAMETER G(LIQUID,CR,FE,V;2) 2.98150E+02 -7692; 6.00000E+03 N - REF323 ! - PARAMETER G(LIQUID,CR,MO;0) 2.98150E+02 +15810-6.714*T; 6.00000E+03 - N REF123 ! - PARAMETER G(LIQUID,CR,MO;1) 2.98150E+02 -6220; 6.00000E+03 N REF123 ! - PARAMETER G(LIQUID,CR,SI;0) 2.98150E+02 -120157.52+16.63891*T; - 6.00000E+03 N REF90 ! - PARAMETER G(LIQUID,CR,SI;1) 2.98150E+02 -49502.35+13.76967*T; - 6.00000E+03 N REF90 ! - PARAMETER G(LIQUID,CR,V;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 - N REF323 ! - PARAMETER G(LIQUID,CR,V;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 - N REF323 ! - PARAMETER G(LIQUID,FE,MO;0) 2.98150E+02 -6973-.37*T; 6.00000E+03 N - REF10 ! - PARAMETER G(LIQUID,FE,MO;1) 2.98150E+02 -9424+4.502*T; 6.00000E+03 - N REF10 ! - PARAMETER G(LIQUID,FE,SI;0) 2.98150E+02 -164435+41.977*T; 6.00000E+03 - N REF99 ! - PARAMETER G(LIQUID,FE,SI;1) 2.98150E+02 -21.523*T; 6.00000E+03 N - REF99 ! - PARAMETER G(LIQUID,FE,SI;2) 2.98150E+02 -18821+22.07*T; 6.00000E+03 - N REF99 ! - PARAMETER G(LIQUID,FE,SI;3) 2.98150E+02 9696; 6.00000E+03 N REF99 ! - PARAMETER G(LIQUID,FE,V;0) 2.98150E+02 -34679+1.895*T; 6.00000E+03 - N REF269 ! - PARAMETER G(LIQUID,FE,V;1) 2.98150E+02 10209; 6.00000E+03 N REF269 ! - - - TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! - PHASE BCC_A2 %& 2 1 3 ! - CONSTITUENT BCC_A2 :CR%,FE%,MO%,SI,V% : C,VA% : ! - - PARAMETER G(BCC_A2,CR:C;0) 2.98150E+02 +GHSERCR#+3*GHSERCC#+GPCRBCC# - +3*GPCGRA#+416000; 6.00000E+03 N REF101 ! - PARAMETER TC(BCC_A2,CR:C;0) 2.98150E+02 -311.5; 6.00000E+03 N - REF101 ! - PARAMETER BMAGN(BCC_A2,CR:C;0) 2.98150E+02 -.008; 6.00000E+03 N - REF101 ! - PARAMETER G(BCC_A2,FE:C;0) 2.98150E+02 +322050+75.667*T+GHSERFE# - +GPFEBCC#+3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF190 ! - PARAMETER TC(BCC_A2,FE:C;0) 2.98150E+02 1043; 6.00000E+03 N REF190 ! - PARAMETER BMAGN(BCC_A2,FE:C;0) 2.98150E+02 2.22; 6.00000E+03 N - REF190 ! - PARAMETER G(BCC_A2,MO:C;0) 2.98150E+02 +331000-75*T+GHSERMO#+3*GHSERCC#; - 6.00000E+03 N REF104 ! - PARAMETER G(BCC_A2,SI:C;0) 2.98150E+02 +322050-75.667*T+GSIBCC# - +3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF98 ! - PARAMETER G(BCC_A2,V:C;0) 2.98150E+02 +108449+GHSERVV#+3*GHSERCC#; - 6.00000E+03 N REF256 ! - PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; - 6.00000E+03 N REF283 ! - PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N - REF281 ! - PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.01; 6.00000E+03 N - REF281 ! - PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; - 6.00000E+03 N REF283 ! - PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF281 ! - PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N - REF281 ! - PARAMETER G(BCC_A2,MO:VA;0) 2.98150E+02 +GHSERMO#+GPMOBCC#; - 5.00000E+03 N REF283 ! - PARAMETER G(BCC_A2,SI:VA;0) 2.98150E+02 +GSIBCC#; 3.60000E+03 N - REF283 ! - PARAMETER G(BCC_A2,V:VA;0) 2.98150E+02 +GHSERVV#; 4.00000E+03 N - REF283 ! - PARAMETER G(BCC_A2,CR,FE:C;0) 2.98150E+02 -1250000+667.7*T; - 6.00000E+03 N REF322 ! - PARAMETER TC(BCC_A2,CR,FE:C;0) 2.98150E+02 1650; 6.00000E+03 N - REF102 ! - PARAMETER TC(BCC_A2,CR,FE:C;1) 2.98150E+02 550; 6.00000E+03 N - REF102 ! - PARAMETER BMAGN(BCC_A2,CR,FE:C;0) 2.98150E+02 -.85; 6.00000E+03 N - REF102 ! - PARAMETER G(BCC_A2,CR:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N - REF101 ! - PARAMETER G(BCC_A2,FE,MO:C;0) 2.98150E+02 -1250000+667.7*T; - 6.00000E+03 N REF325 ! - PARAMETER TC(BCC_A2,FE,MO:C;0) 2.98150E+02 335; 6.00000E+03 N - REF104 ! - PARAMETER TC(BCC_A2,FE,MO:C;1) 2.98150E+02 526; 6.00000E+03 N - REF104 ! - PARAMETER G(BCC_A2,FE,SI:C;0) 2.98150E+02 78866; 6.00000E+03 N - REF99 ! - PARAMETER G(BCC_A2,FE,V:C;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 - N REF270 ! - PARAMETER G(BCC_A2,FE,V:C;1) 2.98150E+02 8283; 6.00000E+03 N REF270 ! - PARAMETER G(BCC_A2,FE:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N - REF190 ! - PARAMETER G(BCC_A2,V:C,VA;0) 2.98150E+02 -297868; 6.00000E+03 N - REF256 ! - PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 - N REF107 ! - PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N - REF107 ! - PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N - REF107 ! - PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N - REF107 ! - PARAMETER G(BCC_A2,CR,FE,V:VA;0) 2.98150E+02 14881; 6.00000E+03 N - REF323 ! - PARAMETER G(BCC_A2,CR,FE,V:VA;1) 2.98150E+02 17968; 6.00000E+03 N - REF323 ! - PARAMETER G(BCC_A2,CR,FE,V:VA;2) 2.98150E+02 -7692; 6.00000E+03 N - REF323 ! - PARAMETER G(BCC_A2,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; - 6.00000E+03 N REF123 ! - PARAMETER G(BCC_A2,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 - N REF123 ! - PARAMETER G(BCC_A2,CR,SI:VA;0) 2.98150E+02 -102850.19+9.85457*T; - 6.00000E+03 N REF90 ! - PARAMETER G(BCC_A2,CR,SI:VA;1) 2.98150E+02 -49502.35+13.76967*T; - 6.00000E+03 N REF90 ! - PARAMETER G(BCC_A2,CR,V:VA;0) 2.98150E+02 -9875-2.6964*T; 6.00000E+03 - N REF323 ! - PARAMETER G(BCC_A2,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 - N REF323 ! - PARAMETER G(BCC_A2,FE,MO:VA;0) 2.98150E+02 +36818-9.141*T; - 6.00000E+03 N REF10 ! - PARAMETER G(BCC_A2,FE,MO:VA;1) 2.98150E+02 -362-5.724*T; 6.00000E+03 - N REF10 ! - PARAMETER TC(BCC_A2,FE,MO:VA;0) 2.98150E+02 335; 6.00000E+03 N - REF10 ! - PARAMETER TC(BCC_A2,FE,MO:VA;1) 2.98150E+02 526; 6.00000E+03 N - REF10 ! - PARAMETER G(BCC_A2,FE,SI:VA;0) 2.98150E+02 +4*L0BCC#-4*FESIW1#; - 6.00000E+03 N REF98 ! - PARAMETER G(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*L1BCC#; 6.00000E+03 N - REF98 ! - PARAMETER G(BCC_A2,FE,SI:VA;2) 2.98150E+02 +16*L2BCC#; 6.00000E+03 - N REF98 ! - PARAMETER TC(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*ETCFESI#; 6.00000E+03 - N REF98 ! - PARAMETER G(BCC_A2,FE,V:VA;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 - N REF269 ! - PARAMETER G(BCC_A2,FE,V:VA;1) 2.98150E+02 8283; 6.00000E+03 N - REF269 ! - PARAMETER TC(BCC_A2,FE,V:VA;0) 2.98150E+02 -110; 6.00000E+03 N - REF111 ! - PARAMETER TC(BCC_A2,FE,V:VA;1) 2.98150E+02 3075; 6.00000E+03 N - REF111 ! - PARAMETER TC(BCC_A2,FE,V:VA;2) 2.98150E+02 808; 6.00000E+03 N - REF111 ! - PARAMETER TC(BCC_A2,FE,V:VA;3) 2.98150E+02 -2169; 6.00000E+03 N - REF111 ! - PARAMETER BMAGN(BCC_A2,FE,V:VA;0) 2.98150E+02 -2.26; 6.00000E+03 N - REF111 ! - - - TYPE_DEFINITION ' GES A_P_D CBCC_A12 MAGNETIC -3.0 2.80000E-01 ! - PHASE CBCC_A12 %' 2 1 1 ! - CONSTITUENT CBCC_A12 :CR,FE,SI,V : C,VA% : ! - - PARAMETER G(CBCC_A12,CR:C;0) 298.15 UN_ASS; 300 N REF0 ! - PARAMETER G(CBCC_A12,FE:C;0) 2.98150E+02 +80000+GHSERFE#+GHSERCC#; - 6.00000E+03 N REF267 ! - PARAMETER G(CBCC_A12,SI:C;0) 2.98150E+02 +1000000+566.0326*T - -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); - 3.00000E+03 N REF177 ! - PARAMETER G(CBCC_A12,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; - 6.00000E+03 N REF275 ! - PARAMETER G(CBCC_A12,CR:VA;0) 2.98150E+02 +11087+2.7196*T+GHSERCR#; - 6.00000E+03 N REF283 ! - PARAMETER G(CBCC_A12,FE:VA;0) 2.98150E+02 +4745+GHSERFE#; 6.00000E+03 - N REF283 ! - PARAMETER G(CBCC_A12,SI:VA;0) 2.98150E+02 +50208-20.377*T+GHSERSI#; - 3.60000E+03 N REF283 ! - PARAMETER G(CBCC_A12,V:VA;0) 298.15 UN_ASS; 300 N REF0 ! - PARAMETER G(CBCC_A12,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N - REF267 ! - PARAMETER G(CBCC_A12,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; - 6.00000E+03 N REF42 ! - PARAMETER G(CBCC_A12,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N - REF42 ! - PARAMETER G(CBCC_A12,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N - REF42 ! - PARAMETER G(CBCC_A12,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N - REF275 ! - - - PHASE CEMENTITE % 2 3 1 ! - CONSTITUENT CEMENTITE :CR,FE%,MO,V : C : ! - - PARAMETER G(CEMENTITE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#-48000 - -9.2888*T; 6.00000E+03 N REF322 ! - PARAMETER G(CEMENTITE,FE:C;0) 2.98150E+02 +GFECEM#; 6.00000E+03 N - REF190 ! - PARAMETER G(CEMENTITE,MO:C;0) 2.98150E+02 +3*GHSERMO#+GHSERCC#+77000 - -57.4*T; 6.00000E+03 N REF104 ! - PARAMETER G(CEMENTITE,V:C;0) 2.98150E+02 -156971+601.922*T - -100.438*T*LN(T)+765557*T**(-1); 6.00000E+03 N REF275 ! - PARAMETER G(CEMENTITE,CR,FE:C;0) 2.98150E+02 +25278-17.5*T; - 6.00000E+03 N REF322 ! - PARAMETER G(CEMENTITE,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N - REF316 ! - PARAMETER G(CEMENTITE,CR,V:C;0) 2.98150E+02 -29622-8.0892*T; - 6.00000E+03 N REF324 ! - PARAMETER G(CEMENTITE,CR,V:C;1) 2.98150E+02 -5160-7.5711*T; - 6.00000E+03 N REF324 ! - PARAMETER G(CEMENTITE,FE,V:C;0) 2.98150E+02 -45873-12.414*T; - 6.00000E+03 N REF270 ! - - - PHASE CHI_A12 % 3 24 10 24 ! - CONSTITUENT CHI_A12 :CR,FE : CR,MO : CR,FE,MO : ! - - PARAMETER G(CHI_A12,CR:CR:CR;0) 2.98150E+02 +48*GCRFCC#+10*GHSERCR# - +109000+123*T; 6.00000E+03 N REF213 ! - PARAMETER G(CHI_A12,FE:CR:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR# - +24*GCRFCC#+18300-100*T; 6.00000E+03 N REF115 ! - PARAMETER G(CHI_A12,CR:MO:CR;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# - +24*GCRFCC#-26000; 6.00000E+03 N REF213 ! - PARAMETER G(CHI_A12,FE:MO:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO# - +24*GCRFCC#+32555-385*T; 6.00000E+03 N REF213 ! - PARAMETER G(CHI_A12,CR:CR:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR# - +24*GFEFCC#+500000; 6.00000E+03 N REF213 ! - PARAMETER G(CHI_A12,FE:CR:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERCR# - +57300-100*T; 6.00000E+03 N REF115 ! - PARAMETER G(CHI_A12,CR:MO:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# - +24*GFEFCC#+500000; 6.00000E+03 N REF213 ! - PARAMETER G(CHI_A12,FE:MO:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERMO# - +305210-270*T; 6.00000E+03 N REF115 ! - PARAMETER G(CHI_A12,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR# - +24*GMOFCC#+500000; 6.00000E+03 N REF213 ! - PARAMETER G(CHI_A12,FE:CR:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR# - +24*GMOFCC#+100000; 6.00000E+03 N REF115 ! - PARAMETER G(CHI_A12,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# - +24*GMOFCC#+500000; 6.00000E+03 N REF213 ! - PARAMETER G(CHI_A12,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO# - +24*GMOFCC#+97300-100*T; 6.00000E+03 N REF115 ! - - - PHASE CR2VC2 % 3 2 1 2 ! - CONSTITUENT CR2VC2 :CR : V : C : ! - - PARAMETER G(CR2VC2,CR:V:C;0) 2.98150E+02 -105987-38.2069*T+2*GHSERCR# - +GHSERVV#+2*GHSERCC#; 6.00000E+03 N REF324 ! - - - PHASE CR3SI % 2 3 1 ! - CONSTITUENT CR3SI :CR%,SI : CR,SI% : ! - - PARAMETER G(CR3SI,CR:CR;0) 2.98150E+02 +17008.82+4*T+4*GHSERCR#; - 6.00000E+03 N REF90 ! - PARAMETER G(CR3SI,SI:CR;0) 2.98150E+02 +167008.8+4*T+GHSERCR# - +3*GHSERSI#; 6.00000E+03 N REF90 ! - PARAMETER G(CR3SI,CR:SI;0) 2.98150E+02 -125456.6+4*T+3*GHSERCR# - +GHSERSI#; 6.00000E+03 N REF90 ! - PARAMETER G(CR3SI,SI:SI;0) 2.98150E+02 +24543.3+4*T+4*GHSERSI#; - 6.00000E+03 N REF90 ! - - - PHASE CR5SI3 % 2 5 3 ! - CONSTITUENT CR5SI3 :CR : SI : ! - - PARAMETER G(CR5SI3,CR:SI;0) 2.98150E+02 -318953.76+1067.49776*T - -182.57818*T*LN(T)-.02391968*T**2-2.31728E-06*T**3; 6.00000E+03 N - REF90 ! - - - PHASE CRSI % 2 1 1 ! - CONSTITUENT CRSI :CR : SI : ! - - PARAMETER G(CRSI,CR:SI;0) 2.98150E+02 -79041.68+311.75228*T - -51.62865*T*LN(T)-.00447355*T**2+391330*T**(-1); 6.00000E+03 N REF90 ! - - - PHASE CRSI2 % 2 1 2 ! - CONSTITUENT CRSI2 :CR%,SI : CR,SI% : ! - - PARAMETER G(CRSI2,CR:CR;0) 2.98150E+02 +10000+10*T+3*GHSERCR#; - 6.00000E+03 N REF90 ! - PARAMETER G(CRSI2,SI:CR;0) 2.98150E+02 +150000-T+2*GHSERCR#+GHSERSI#; - 6.00000E+03 N REF90 ! - PARAMETER G(CRSI2,CR:SI;0) 2.98150E+02 -96793.65+333.25242*T - -57.85575*T*LN(T)-.01322769*T**2-4.3203E-07*T**3; 6.00000E+03 N REF90 ! - PARAMETER G(CRSI2,SI:SI;0) 2.98150E+02 +77711.85-15.05638*T+3*GHSERSI#; - 6.00000E+03 N REF90 ! - PARAMETER G(CRSI2,CR:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; - 6.00000E+03 N REF90 ! - PARAMETER G(CRSI2,SI:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; - 6.00000E+03 N REF90 ! - - - PHASE CUB_A13 % 2 1 1 ! - CONSTITUENT CUB_A13 :CR,FE,SI,V : C,VA% : ! - - PARAMETER G(CUB_A13,CR:C;0) 298.15 UN_ASS; 300 N REF0 ! - PARAMETER G(CUB_A13,FE:C;0) 2.98150E+02 +90000+GHSERFE#+GHSERCC#; - 6.00000E+03 N REF267 ! - PARAMETER G(CUB_A13,SI:C;0) 2.98150E+02 +1000000+566.0326*T - -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); - 3.00000E+03 N REF177 ! - PARAMETER G(CUB_A13,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; - 6.00000E+03 N REF275 ! - PARAMETER G(CUB_A13,CR:VA;0) 2.98150E+02 +15899+.6276*T+GHSERCR#; - 6.00000E+03 N REF283 ! - PARAMETER G(CUB_A13,FE:VA;0) 2.98150E+02 +3745+GHSERFE#; 6.00000E+03 - N REF283 ! - PARAMETER G(CUB_A13,SI:VA;0) 2.98150E+02 +47279-20.377*T+GHSERSI#; - 3.60000E+03 N REF283 ! - PARAMETER G(CUB_A13,V:VA;0) 298.15 UN_ASS; 300 N REF0 ! - PARAMETER G(CUB_A13,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N - REF267 ! - PARAMETER G(CUB_A13,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; - 6.00000E+03 N REF42 ! - PARAMETER G(CUB_A13,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N - REF42 ! - PARAMETER G(CUB_A13,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N - REF42 ! - PARAMETER G(CUB_A13,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N - REF275 ! - - - PHASE DIAMOND_A4 % 1 1.0 ! - CONSTITUENT DIAMOND_A4 :C,SI% : ! - - PARAMETER G(DIAMOND_A4,C;0) 2.98150E+02 -16359.441+175.61*T - -24.31*T*LN(T)-4.723E-04*T**2+2698000*T**(-1)-2.61E+08*T**(-2) - +1.11E+10*T**(-3)+GPCDIA#; 6.00000E+03 N REF283 ! - PARAMETER G(DIAMOND_A4,SI;0) 2.98150E+02 +GHSERSI#; 3.60000E+03 N - REF283 ! - - - TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! - PHASE FCC_A1 %( 2 1 1 ! - CONSTITUENT FCC_A1 :CR,FE%,MO,SI,V : C,VA% : ! - - PARAMETER G(FCC_A1,CR:C;0) 2.98150E+02 +GHSERCR#+GHSERCC#+1200-1.94*T; - 6.00000E+03 N REF322 ! - PARAMETER G(FCC_A1,FE:C;0) 2.98150E+02 +77207-15.877*T+GFEFCC#+GHSERCC# - +GPCFCC#; 6.00000E+03 N REF190 ! - PARAMETER TC(FCC_A1,FE:C;0) 2.98150E+02 -201; 6.00000E+03 N REF190 ! - PARAMETER BMAGN(FCC_A1,FE:C;0) 2.98150E+02 -2.1; 6.00000E+03 N - REF190 ! - PARAMETER G(FCC_A1,MO:C;0) 2.98150E+02 -7500-8.3*T-750000*T**(-1) - +GHSERMO#+GHSERCC#; 6.00000E+03 N REF104 ! - PARAMETER G(FCC_A1,SI:C;0) 2.98150E+02 +GHSERSI#+GHSERCC#-20510+38.7*T; - 6.00000E+03 N REF98 ! - PARAMETER G(FCC_A1,V:C;0) 2.98150E+02 -117302+262.57*T-41.756*T*LN(T) - -.00557101*T**2+590546*T**(-1); 6.00000E+03 N REF256 ! - PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; - 6.00000E+03 N REF281 ! - PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N - REF281 ! - PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N - REF281 ! - PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; - 6.00000E+03 N REF283 ! - PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF281 ! - PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N - REF281 ! - PARAMETER G(FCC_A1,MO:VA;0) 2.98150E+02 +15200+.63*T+GHSERMO#+GPMOBCC#; - 5.00000E+03 N REF283 ! - PARAMETER G(FCC_A1,SI:VA;0) 2.98150E+02 +51000-21.8*T+GHSERSI#; - 3.60000E+03 N REF283 ! - PARAMETER G(FCC_A1,V:VA;0) 2.98150E+02 +7500+1.7*T+GHSERVZ#; - 4.00000E+03 N REF283 ! - PARAMETER G(FCC_A1,CR,FE:C;0) 2.98150E+02 -74319+3.2353*T; - 6.00000E+03 N REF322 ! - PARAMETER G(FCC_A1,CR,V:C;0) 2.98150E+02 +35698-50.0981*T; - 6.00000E+03 N REF324 ! - PARAMETER G(FCC_A1,CR:C,VA;0) 2.98150E+02 -11977+6.8194*T; - 6.00000E+03 N REF322 ! - PARAMETER G(FCC_A1,FE,MO:C;0) 2.98150E+02 6000; 6.00000E+03 N - REF113 ! - PARAMETER G(FCC_A1,FE,SI:C;0) 2.98150E+02 +143220+39.31*T; - 6.00000E+03 N REF99 ! - PARAMETER G(FCC_A1,FE,SI:C;1) 2.98150E+02 -216321; 6.00000E+03 N - REF99 ! - PARAMETER G(FCC_A1,FE,V:C;0) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 - N REF270 ! - PARAMETER G(FCC_A1,FE,V:C;1) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 - N REF270 ! - PARAMETER G(FCC_A1,FE,V:C,VA;0) 2.98150E+02 -40000; 6.00000E+03 N - REF270 ! - PARAMETER G(FCC_A1,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N - REF190 ! - PARAMETER G(FCC_A1,MO,V:C;0) 2.98150E+02 -18000; 6.00000E+03 N - REF220 ! - PARAMETER G(FCC_A1,MO:C,VA;0) 2.98150E+02 -41300; 6.00000E+03 N - REF104 ! - PARAMETER G(FCC_A1,V:C,VA;0) 2.98150E+02 -74811+10.201*T; 6.00000E+03 - N REF256 ! - PARAMETER G(FCC_A1,V:C,VA;1) 2.98150E+02 -30394; 6.00000E+03 N - REF256 ! - PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; - 6.00000E+03 N REF107 ! - PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N - REF107 ! - PARAMETER G(FCC_A1,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; - 6.00000E+03 N REF58 ! - PARAMETER G(FCC_A1,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 - N REF58 ! - PARAMETER G(FCC_A1,CR,SI:VA;0) 2.98150E+02 -122850+9.85457*T; - 6.00000E+03 N REF58 ! - PARAMETER G(FCC_A1,CR,SI:VA;1) 2.98150E+02 -49502+13.76967*T; - 6.00000E+03 N REF58 ! - PARAMETER G(FCC_A1,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 - N REF323 ! - PARAMETER G(FCC_A1,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 - N REF323 ! - PARAMETER G(FCC_A1,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; - 6.00000E+03 N REF10 ! - PARAMETER G(FCC_A1,FE,SI:VA;0) 2.98150E+02 -125248+41.116*T; - 6.00000E+03 N REF98 ! - PARAMETER G(FCC_A1,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N - REF98 ! - PARAMETER G(FCC_A1,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N - REF98 ! - PARAMETER G(FCC_A1,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 - N REF269 ! - - - PHASE FE1SI1 % 2 .5 .5 ! - CONSTITUENT FE1SI1 :FE : SI : ! - - PARAMETER G(FE1SI1,FE:SI;0) 2.98150E+02 +.5*GHSERFE#+.5*GHSERSI#-36381 - +2.22*T; 6.00000E+03 N REF98 ! - - - PHASE FE2SI % 2 .666667 .333333 ! - CONSTITUENT FE2SI :FE : SI : ! - - PARAMETER G(FE2SI,FE:SI;0) 2.98150E+02 +.6666667*GHSERFE# - +.3333333*GHSERSI#-23752-3.54*T; 6.00000E+03 N REF98 ! - - - PHASE FE4N % 2 4 1 ! - CONSTITUENT FE4N :FE : C,VA : ! - - PARAMETER G(FE4N,FE:C;0) 2.98150E+02 +15965+4*GHSERFE#+GHSERCC#; - 6.00000E+03 N REF319 ! - PARAMETER G(FE4N,FE:VA;0) 2.98150E+02 +4*GFEFCC#+10; 6.00000E+03 N - REF319 ! - - - PHASE FE5SI3 % 2 .625 .375 ! - CONSTITUENT FE5SI3 :FE : SI : ! - - PARAMETER G(FE5SI3,FE:SI;0) 2.98150E+02 +.625*GHSERFE#+.375*GHSERSI# - -30143+.27*T; 6.00000E+03 N REF98 ! - - - PHASE FE8SI2C % 3 8 2 1 ! - CONSTITUENT FE8SI2C :FE : SI : C : ! - - PARAMETER G(FE8SI2C,FE:SI:C;0) 2.98150E+02 +8*GHSERFE#+2*GHSERSI# - +GHSERCC#-231047+5.566*T; 6.00000E+03 N REF99 ! - - - PHASE FECN_CHI % 2 5 2 ! - CONSTITUENT FECN_CHI :FE : C : ! - - PARAMETER G(FECN_CHI,FE:C;0) 2.98150E+02 -11287.4+1013.78*T - -176.412*T*LN(T)+810869*T**(-1); 6.00000E+03 N REF319 ! - - - PHASE FESI2_H % 2 .3 .7 ! - CONSTITUENT FESI2_H :FE : SI : ! - - PARAMETER G(FESI2_H,FE:SI;0) 2.98150E+02 +.3*GHSERFE#+.7*GHSERSI#-19649 - -.92*T; 6.00000E+03 N REF98 ! - - - PHASE FESI2_L % 2 .333333 .666667 ! - CONSTITUENT FESI2_L :FE : SI : ! - - PARAMETER G(FESI2_L,FE:SI;0) 2.98150E+02 +.333333*GHSERFE# - +.666667*GHSERSI#-27383+3.48*T; 6.00000E+03 N REF98 ! - - - PHASE GRAPHITE % 1 1.0 ! - CONSTITUENT GRAPHITE :C : ! - - PARAMETER G(GRAPHITE,C;0) 2.98150E+02 +GHSERCC#+GPCGRA#; 6.00000E+03 - N REF283 ! - - - TYPE_DEFINITION ) GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 ! - PHASE HCP_A3 %) 2 1 .5 ! - CONSTITUENT HCP_A3 :CR,FE,MO,SI,V : C,VA% : ! - - PARAMETER G(HCP_A3,CR:C;0) 2.98150E+02 +GHSERCR#+.5*GHSERCC#-18504 - +9.4173*T-2.4997*T*LN(T)+.001386*T**2; 6.00000E+03 N REF322 ! - PARAMETER G(HCP_A3,FE:C;0) 2.98150E+02 +52905-11.9075*T+GFEFCC# - +.5*GHSERCC#+GPCFCC#; 6.00000E+03 N REF190 ! - PARAMETER G(HCP_A3,MO:C;0) 2.98150E+02 -24150-3.625*T-163000*T**(-1) - +GHSERMO#+.5*GHSERCC#; 6.00000E+03 N REF104 ! - PARAMETER G(HCP_A3,SI:C;0) 298.15 UN_ASS; 300 N REF0 ! - PARAMETER G(HCP_A3,V:C;0) 2.98150E+02 -85473+182.441*T-30.551*T*LN(T) - -.00538998*T**2+229029*T**(-1); 6.00000E+03 N REF256 ! - PARAMETER G(HCP_A3,CR:VA;0) 2.98150E+02 +4438+GHSERCR#+GPCRBCC#; - 6.00000E+03 N REF283 ! - PARAMETER TC(HCP_A3,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N - REF281 ! - PARAMETER BMAGN(HCP_A3,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N - REF281 ! - PARAMETER G(HCP_A3,FE:VA;0) 2.98150E+02 -3705.78+12.591*T-1.15*T*LN(T) - +6.4E-04*T**2+GHSERFE#+GPFEHCP#; 1.81100E+03 Y - -3957.199+5.24951*T+4.9251E+30*T**(-9)+GHSERFE#+GPFEHCP#; 6.00000E+03 N - REF283 ! - PARAMETER G(HCP_A3,MO:VA;0) 2.98150E+02 +11550+GHSERMO#+GPMOBCC#; - 5.00000E+03 N REF283 ! - PARAMETER G(HCP_A3,SI:VA;0) 2.98150E+02 +49200-20.8*T+GHSERSI#; - 3.60000E+03 N REF283 ! - PARAMETER G(HCP_A3,V:VA;0) 2.98150E+02 +4000+2.4*T+GHSERVZ#; - 4.00000E+03 N REF283 ! - PARAMETER G(HCP_A3,CR,FE,MO:C;0) 2.98150E+02 -57062; 6.00000E+03 N - REF316 ! - PARAMETER G(HCP_A3,CR,MO:C;0) 2.98150E+02 -3905+18.5304*T; - 6.00000E+03 N REF316 ! - PARAMETER G(HCP_A3,CR,V:C;0) 2.98150E+02 +17165-9.9072*T; 6.00000E+03 - N REF323 ! - PARAMETER G(HCP_A3,CR:C,VA;0) 2.98150E+02 4165; 6.00000E+03 N - REF207 ! - PARAMETER G(HCP_A3,FE,MO:C;0) 2.98150E+02 +13030-33.8*T; 6.00000E+03 - N REF113 ! - PARAMETER G(HCP_A3,FE,V:C;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 - N REF270 ! - PARAMETER G(HCP_A3,FE:C,VA;0) 2.98150E+02 -22126; 6.00000E+03 N - REF319 ! - PARAMETER G(HCP_A3,MO:C,VA;0) 2.98150E+02 4150; 6.00000E+03 N - REF104 ! - PARAMETER G(HCP_A3,V:C,VA;0) 2.98150E+02 +12430-3.986*T; 6.00000E+03 - N REF256 ! - PARAMETER G(HCP_A3,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; - 6.00000E+03 N REF126 ! - PARAMETER G(HCP_A3,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; - 6.00000E+03 N REF117 ! - PARAMETER G(HCP_A3,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 - N REF117 ! - PARAMETER G(HCP_A3,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 - N REF323 ! - PARAMETER G(HCP_A3,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 - N REF323 ! - PARAMETER G(HCP_A3,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; - 6.00000E+03 N REF10 ! - PARAMETER G(HCP_A3,FE,SI:VA;0) 2.98150E+02 -123468+41.116*T; - 6.00000E+03 N REF42 ! - PARAMETER G(HCP_A3,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N - REF42 ! - PARAMETER G(HCP_A3,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N - REF42 ! - PARAMETER G(HCP_A3,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 - N REF270 ! - - - PHASE KSI_CARBIDE % 2 3 1 ! - CONSTITUENT KSI_CARBIDE :CR,FE,MO% : C : ! - - PARAMETER G(KSI_CARBIDE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#+114060 - -47.2519*T; 6.00000E+03 N REF316 ! - PARAMETER G(KSI_CARBIDE,FE:C;0) 2.98150E+02 +14540+20*T+3*GHSERFE# - +GHSERCC#; 6.00000E+03 N REF113 ! - PARAMETER G(KSI_CARBIDE,MO:C;0) 2.98150E+02 +167009-33*T+3*GHSERMO# - +GHSERCC#; 6.00000E+03 N REF113 ! - PARAMETER G(KSI_CARBIDE,CR,FE:C;0) 2.98150E+02 -139900; 6.00000E+03 - N REF316 ! - PARAMETER G(KSI_CARBIDE,CR,MO:C;0) 2.98150E+02 -348033; 6.00000E+03 - N REF316 ! - PARAMETER G(KSI_CARBIDE,FE,MO:C;0) 2.98150E+02 -380000; 6.00000E+03 - N REF113 ! - - - PHASE LAVES_PHASE % 2 2 1 ! - CONSTITUENT LAVES_PHASE :CR,FE : MO : ! - - PARAMETER G(LAVES_PHASE,CR:MO;0) 2.98150E+02 +2*GCRFCC#+GHSERMO#-8000 - -6*T; 6.00000E+03 N REF214 ! - PARAMETER G(LAVES_PHASE,FE:MO;0) 2.98150E+02 -10798-.132*T+2*GFEFCC# - +GHSERMO#; 6.00000E+03 N REF10 ! - - - PHASE M23C6 % 3 20 3 6 ! - CONSTITUENT M23C6 :CR%,FE%,V : CR%,FE%,MO%,V : C : ! - - PARAMETER G(M23C6,CR:CR:C;0) 2.98150E+02 +GCRM23C6#; 6.00000E+03 N - REF102 ! - PARAMETER G(M23C6,FE:CR:C;0) 2.98150E+02 +.1304348*GCRM23C6# - +.8695652*GFEM23C6#; 6.00000E+03 N REF102 ! - PARAMETER G(M23C6,V:CR:C;0) 2.98150E+02 +.869565*GVM23C6# - +.130435*GCRM23C6#; 6.00000E+03 N REF323 ! - PARAMETER G(M23C6,CR:FE:C;0) 2.98150E+02 +.8695652*GCRM23C6# - +.1304348*GFEM23C6#; 6.00000E+03 N REF102 ! - PARAMETER G(M23C6,FE:FE:C;0) 2.98150E+02 +GFEM23C6#; 6.00000E+03 N - REF102 ! - PARAMETER G(M23C6,V:FE:C;0) 2.98150E+02 +.869565*GVM23C6# - +.130435*GFEM23C6#; 6.00000E+03 N REF323 ! - PARAMETER G(M23C6,CR:MO:C;0) 2.98150E+02 +20*GHSERCR#+3*GHSERMO# - +6*GHSERCC#-439117-50.0535*T; 6.00000E+03 N REF316 ! - PARAMETER G(M23C6,FE:MO:C;0) 2.98150E+02 +20*GHSERFE#+3*GHSERMO# - +6*GHSERCC#-76351-5.095*T; 6.00000E+03 N REF316 ! - PARAMETER G(M23C6,V:MO:C;0) 298.15 UN_ASS; 300 N REF0 ! - PARAMETER G(M23C6,CR:V:C;0) 2.98150E+02 +.869565*GCRM23C6# - +.130435*GVM23C6#; 6.00000E+03 N REF323 ! - PARAMETER G(M23C6,FE:V:C;0) 2.98150E+02 +.869565*GFEM23C6# - +.130435*GVM23C6#; 6.00000E+03 N REF323 ! - PARAMETER G(M23C6,V:V:C;0) 2.98150E+02 +GVM23C6#; 6.00000E+03 N - REF323 ! - PARAMETER G(M23C6,CR,FE:CR:C;0) 2.98150E+02 -205342+141.6667*T; - 6.00000E+03 N REF322 ! - PARAMETER G(M23C6,CR,FE,V:CR:C;0) 2.98150E+02 -1499585; 6.00000E+03 - N REF324 ! - PARAMETER G(M23C6,CR,V:CR:C;0) 2.98150E+02 -385502; 6.00000E+03 N - REF324 ! - PARAMETER G(M23C6,CR,FE:FE:C;0) 2.98150E+02 -205342+141.6667*T; - 6.00000E+03 N REF322 ! - PARAMETER G(M23C6,CR,FE,V:FE:C;0) 2.98150E+02 -1499585; 6.00000E+03 - N REF324 ! - PARAMETER G(M23C6,CR,V:FE:C;0) 2.98150E+02 -385502; 6.00000E+03 N - REF324 ! - PARAMETER G(M23C6,CR,FE:MO:C;0) 2.98150E+02 -177850+153.905*T; - 6.00000E+03 N REF316 ! - PARAMETER G(M23C6,CR,FE:V:C;0) 2.98150E+02 -205342+141.6667*T; - 6.00000E+03 N REF324 ! - PARAMETER G(M23C6,CR,FE,V:V:C;0) 2.98150E+02 -1499585; 6.00000E+03 - N REF324 ! - PARAMETER G(M23C6,CR,V:V:C;0) 2.98150E+02 -385502; 6.00000E+03 N - REF324 ! - - - PHASE M3C2 % 2 3 2 ! - CONSTITUENT M3C2 :CR,MO,V : C : ! - - PARAMETER G(M3C2,CR:C;0) 2.98150E+02 +GCRM3C2#; 6.00000E+03 N - REF322 ! - PARAMETER G(M3C2,MO:C;0) 2.98150E+02 +3*GHSERMO#+2*GHSERCC#+27183; - 6.00000E+03 N REF316 ! - PARAMETER G(M3C2,V:C;0) 2.98150E+02 -222500+16.6545*T+3*GHSERVV# - +2*GHSERCC#; 6.00000E+03 N REF324 ! - PARAMETER G(M3C2,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N REF316 ! - PARAMETER G(M3C2,CR,V:C;0) 2.98150E+02 21072; 6.00000E+03 N REF324 ! - - - PHASE M3SI % 2 3 1 ! - CONSTITUENT M3SI :FE : SI : ! - - PARAMETER G(M3SI,FE:SI;0) 2.98150E+02 +3*GHSERFE#+GHSERSI#-94274-3.56*T; - 6.00000E+03 N REF42 ! - - - PHASE M5C2 % 2 5 2 ! - CONSTITUENT M5C2 :FE,V : C : ! - - PARAMETER G(M5C2,FE:C;0) 2.98150E+02 +5*GHSERFE#+2*GHSERCC#+54852 - -33.7518*T; 6.00000E+03 N REF322 ! - PARAMETER G(M5C2,V:C;0) 2.98150E+02 -307123.3+1059.7*T-175.66*T*LN(T) - +1453274*T**(-1); 6.00000E+03 N REF275 ! - - - PHASE M6C % 4 2 2 2 1 ! - CONSTITUENT M6C :FE : MO : CR,FE,MO,V : C : ! - - PARAMETER G(M6C,FE:MO:CR:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERCR# - +2*GHSERMO#+GHSERCC#-25298-54.8698*T; 6.00000E+03 N REF316 ! - PARAMETER G(M6C,FE:MO:FE:C;0) 2.98150E+02 +4*GHSERFE#+2*GHSERMO# - +GHSERCC#+77705-101.5*T; 6.00000E+03 N REF113 ! - PARAMETER G(M6C,FE:MO:MO:C;0) 2.98150E+02 +2*GHSERFE#+4*GHSERMO# - +GHSERCC#-122410+30.25*T; 6.00000E+03 N REF113 ! - PARAMETER G(M6C,FE:MO:V:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERMO# - +2*GHSERVV#+GHSERCC#-173000; 6.00000E+03 N REF220 ! - PARAMETER G(M6C,FE:MO:FE,MO:C;0) 2.98150E+02 -37700; 6.00000E+03 N - REF113 ! - - - PHASE M7C3 % 2 7 3 ! - CONSTITUENT M7C3 :CR%,FE,MO,V : C : ! - - PARAMETER G(M7C3,CR:C;0) 2.98150E+02 +GCRM7C3#; 6.00000E+03 N - REF322 ! - PARAMETER G(M7C3,FE:C;0) 2.98150E+02 +7*GHSERFE#+3*GHSERCC#+75000 - -48.2168*T; 6.00000E+03 N REF322 ! - PARAMETER G(M7C3,MO:C;0) 2.98150E+02 +7*GHSERMO#+3*GHSERCC#-140415 - +24.24*T; 6.00000E+03 N REF316 ! - PARAMETER G(M7C3,V:C;0) 2.98150E+02 -454245+1518.48*T-250.981*T*LN(T) - +2148691*T**(-1); 6.00000E+03 N REF324 ! - PARAMETER G(M7C3,CR,FE:C;0) 2.98150E+02 -4520-10*T; 6.00000E+03 N - REF322 ! - PARAMETER G(M7C3,CR,FE,V:C;0) 2.98150E+02 -250158; 6.00000E+03 N - REF324 ! - PARAMETER G(M7C3,CR,MO:C;0) 2.98150E+02 165280; 6.00000E+03 N - REF316 ! - PARAMETER G(M7C3,CR,V:C;0) 2.98150E+02 -110271; 6.00000E+03 N - REF324 ! - - - PHASE MC_ETA % 2 1 1 ! - CONSTITUENT MC_ETA :MO% : C%,VA : ! - - PARAMETER G(MC_ETA,MO:C;0) 2.98150E+02 -9100-5.35*T-750000*T**(-1) - +GHSERMO#+GHSERCC#; 6.00000E+03 N REF113 ! - PARAMETER G(MC_ETA,MO:VA;0) 2.98150E+02 +GHSERMO#+15200+.63*T; - 6.00000E+03 N REF113 ! - PARAMETER G(MC_ETA,MO:C,VA;0) 2.98150E+02 -59500; 6.00000E+03 N - REF104 ! - - - PHASE MC_SHP % 2 1 1 ! - CONSTITUENT MC_SHP :MO : C : ! - - PARAMETER G(MC_SHP,MO:C;0) 2.98150E+02 -32983+2.5*T+GHSERMO#+GHSERCC#; - 6.00000E+03 N REF104 ! - - - PHASE MONI_DELTA % 3 24 20 12 ! - CONSTITUENT MONI_DELTA :CR,FE : CR,FE,MO : MO : ! - - PARAMETER G(MONI_DELTA,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR# - +12*GHSERMO#+50000; 6.00000E+03 N REF133 ! - PARAMETER G(MONI_DELTA,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! - PARAMETER G(MONI_DELTA,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 ! - PARAMETER G(MONI_DELTA,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE# - +12*GHSERMO#+100000; 6.00000E+03 N REF132 ! - PARAMETER G(MONI_DELTA,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO# - +100000; 6.00000E+03 N REF133 ! - PARAMETER G(MONI_DELTA,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO# - +100000; 6.00000E+03 N REF132 ! - - - PHASE MU_PHASE % 3 7 2 4 ! - CONSTITUENT MU_PHASE :CR,FE : MO : CR,FE,MO : ! - - PARAMETER G(MU_PHASE,CR:MO:CR;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# - +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 ! - PARAMETER G(MU_PHASE,FE:MO:CR;0) 2.98150E+02 +7*GFEFCC#+2*GHSERMO# - +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 ! - PARAMETER G(MU_PHASE,CR:MO:FE;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# - +4*GHSERFE#+130000-100*T; 6.00000E+03 N REF115 ! - PARAMETER G(MU_PHASE,FE:MO:FE;0) 2.98150E+02 +39475-6.032*T+7*GFEFCC# - +2*GHSERMO#+4*GHSERFE#+GPMU1#; 6.00000E+03 N REF10 ! - PARAMETER G(MU_PHASE,CR:MO:MO;0) 2.98150E+02 +7*GCRFCC#+6*GHSERMO# - +130000-100*T; 6.00000E+03 N REF115 ! - PARAMETER G(MU_PHASE,FE:MO:MO;0) 2.98150E+02 -46663-5.891*T+7*GFEFCC# - +6*GHSERMO#+GPMU2#; 6.00000E+03 N REF10 ! - PARAMETER G(MU_PHASE,CR,FE:MO:MO;0) 2.98150E+02 -45000; 6.00000E+03 - N REF115 ! - - - PHASE P_PHASE % 3 24 20 12 ! - CONSTITUENT P_PHASE :CR,FE : CR,FE,MO : MO : ! - - PARAMETER G(P_PHASE,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR# - +12*GHSERMO#+252300-100*T; 6.00000E+03 N REF133 ! - PARAMETER G(P_PHASE,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! - PARAMETER G(P_PHASE,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 ! - PARAMETER G(P_PHASE,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE# - +12*GHSERMO#+111361; 6.00000E+03 N REF132 ! - PARAMETER G(P_PHASE,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO# - +95573-200*T; 6.00000E+03 N REF133 ! - PARAMETER G(P_PHASE,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO# - +362525-332.7*T; 6.00000E+03 N REF132 ! - - - PHASE R_PHASE % 3 27 14 12 ! - CONSTITUENT R_PHASE :CR,FE : MO : CR,FE,MO : ! - - PARAMETER G(R_PHASE,CR:MO:CR;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO# - +12*GHSERCR#-20000; 6.00000E+03 N REF115 ! - PARAMETER G(R_PHASE,FE:MO:CR;0) 2.98150E+02 +27*GFEFCC#+14*GHSERMO# - +12*GHSERCR#+600260-620*T; 6.00000E+03 N REF115 ! - PARAMETER G(R_PHASE,CR:MO:FE;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO# - +12*GHSERFE#+645260-620*T; 6.00000E+03 N REF115 ! - PARAMETER G(R_PHASE,FE:MO:FE;0) 2.98150E+02 -77487-50.486*T+27*GFEFCC# - +14*GHSERMO#+12*GHSERFE#+GPR1#; 6.00000E+03 N REF10 ! - PARAMETER G(R_PHASE,CR:MO:MO;0) 2.98150E+02 +27*GCRFCC#+26*GHSERMO# - -20000; 6.00000E+03 N REF115 ! - PARAMETER G(R_PHASE,FE:MO:MO;0) 2.98150E+02 +313474-289.472*T - +27*GFEFCC#+26*GHSERMO#+GPR2#; 6.00000E+03 N REF10 ! - - - PHASE SIC % 2 1 1 ! - CONSTITUENT SIC :SI : C : ! - - PARAMETER G(SIC,SI:C;0) 2.98150E+02 -85572.2636+173.200518*T - -25.856*T*LN(T)-.02106825*T**2+3.2153E-06*T**3+438415*T**(-1); - 7.00000E+02 Y - -95145.9018+300.345769*T-45.093*T*LN(T)-.00366815*T**2 - +2.19983333E-07*T**3+1341065*T**(-1); 2.10000E+03 Y - -105007.971+360.308813*T-53.073*T*LN(T)-7.4525E-04*T**2 - +1.73166667E-08*T**3+3693345*T**(-1); 4.00000E+03 N REF286 ! - - - PHASE SIGMA % 3 8 4 18 ! - CONSTITUENT SIGMA :FE : CR,MO,V : CR,FE,MO,V : ! - - PARAMETER G(SIGMA,FE:CR:CR;0) 2.98150E+02 +8*GFEFCC#+22*GHSERCR#+92300 - -95.96*T+GPSIG1#; 6.00000E+03 N REF107 ! - PARAMETER G(SIGMA,FE:MO:CR;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO# - +18*GHSERCR#+488480-360*T; 6.00000E+03 N REF115 ! - PARAMETER G(SIGMA,FE:V:CR;0) 2.98150E+02 +155735-89.5976*T+8*GFEFCC# - +4*GHSERVV#+18*GHSERCR#; 6.00000E+03 N REF323 ! - PARAMETER G(SIGMA,FE:CR:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# - +18*GHSERFE#+117300-95.96*T+GPSIG2#; 6.00000E+03 N REF107 ! - PARAMETER G(SIGMA,FE:MO:FE;0) 2.98150E+02 -1813-27.272*T+8*GFEFCC# - +18*GHSERFE#+4*GHSERMO#; 6.00000E+03 N REF10 ! - PARAMETER G(SIGMA,FE:V:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV# - +18*GHSERFE#-157961+60.729*T; 6.00000E+03 N REF269 ! - PARAMETER G(SIGMA,FE:CR:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# - +18*GHSERMO#+312580-260*T; 6.00000E+03 N REF115 ! - PARAMETER G(SIGMA,FE:MO:MO;0) 2.98150E+02 +83326-69.618*T+8*GFEFCC# - +22*GHSERMO#; 6.00000E+03 N REF10 ! - PARAMETER G(SIGMA,FE:V:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV# - +18*GHSERMO#; 6.00000E+03 N REF136 ! - PARAMETER G(SIGMA,FE:CR:V;0) 2.98150E+02 -245761-67.3294*T+8*GFEFCC# - +4*GHSERCR#+18*GHSERVV#; 6.00000E+03 N REF323 ! - PARAMETER G(SIGMA,FE:MO:V;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO# - +18*GHSERVV#; 6.00000E+03 N REF136 ! - PARAMETER G(SIGMA,FE:V:V;0) 2.98150E+02 +8*GFEFCC#+22*GHSERVV#-205321 - -60.967*T; 6.00000E+03 N REF269 ! - PARAMETER G(SIGMA,FE:CR:CR,MO;0) 2.98150E+02 -148000; 6.00000E+03 N - REF115 ! - PARAMETER G(SIGMA,FE:MO:CR,MO;0) 2.98150E+02 121000; 6.00000E+03 N - REF115 ! - PARAMETER G(SIGMA,FE:CR:FE,MO;0) 2.98150E+02 570000; 6.00000E+03 N - REF115 ! - PARAMETER G(SIGMA,FE:CR:FE,V;0) 2.98150E+02 -235158; 6.00000E+03 N - REF323 ! - PARAMETER G(SIGMA,FE:MO:FE,MO;0) 2.98150E+02 222909; 6.00000E+03 N - REF10 ! - PARAMETER G(SIGMA,FE:V:FE,V;0) 2.98150E+02 -305784; 6.00000E+03 N - REF269 ! - - - PHASE V3C2 % 2 3 2 ! - CONSTITUENT V3C2 :FE,V : C : ! - - PARAMETER G(V3C2,FE:C;0) 2.98150E+02 +7250+741.566*T-125.833*T*LN(T) - +779485*T**(-1); 6.00000E+03 N REF275 ! - PARAMETER G(V3C2,V:C;0) 2.98150E+02 -260341+16.897*T+3*GHSERVV# - +2*GHSERCC#; 6.00000E+03 N REF256 ! - - LIST_OF_REFERENCES - NUMBER SOURCE - REF283 'Alan Dinsdale, SGTE Data for Pure Elements, - Calphad Vol 15(1991) p 317-425, - also in NPL Report DMA(A)195 Rev. August 1990' - REF101 'J-O Andersson, Calphad Vol 11 (1987) p 271-276, TRITA 0314; C-CR' - REF190 'P. Gustafson, Scan. J. Metall. vol 14, (1985) p 259-267 - TRITA 0237 (1984); C-FE' - REF104 'J-O Andersson, Calphad Vol 12 (1988) p 1-8 TRITA 0317 (1986); C - -MO' - REF98 'J. Lacaze and B. Sundman, provisional; Fe-Si' - REF256 'W. Huang, TRITA-MAC 431 (1990); C-V' - REF267 'W. Huang, Metall. Trans. Vol 21A(1990) p 2115-2123, - TRITA-MAC 411 (Rev 1989); C-FE-MN' - REF177 'NPL, unpublished work (1989); C-Mn-Si' - REF275 'W. Huang, TRITA-MAC 441 (1990), Fe-Mn-V-C *' - REF322 'Byeong-Joo Lee, unpublished revision (1991); C-Cr-Fe-Ni' - REF213 'P. Gustafson, TRITA-MAC 342, (1987); CR-FE-W' - REF115 'J-O Andersson, Met Trans A, Vol 19A, (1988) p 1385-1394 - TRITA 0322 (1986); CR-FE-MO' - REF324 'Byeong-Joo Lee, TRITA-MAC 475 (1991), C-Cr-Fe-V' - REF90 'I Ansara, unpublished work (1991); Cr-Si' - REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 - September 1989' - REF319 'H. Du and M. Hillert, revision; C-Fe-N' - REF99 'J. Lacaze and B. Sundman, Met. Trans A, Vol 22A (1991) - pp 2211-2223; C-Fe-Si' - REF316 'Caian Qui, Trita-MAC 482 (1992) Revision ; C-Cr-Fe-Mo' - REF113 'J-O Andersson, Calphad Vol 12 (1988), p 9-23 - TRITA 0321 (1986); C-FE-MO' - REF214 'P. Gustafson, TRITA-MAC 354 (1987); C-Cr-Fe-Mo-W' - REF10 'A. Fernandez Guillermet, CALPHAD Vol 6 (1982), p 127-140 - (sigma phase revised 1986), TRITA-MAC 200 (1982); FE-MO' - REF102 'J-O Andersson, Met. Trans A, Vol 19A, (1988) p 627-636 - TRITA 0207 (1986); C-CR-FE' - REF323 'Byeong-Joo Lee, TRITA-MAC 474 (1991), Cr-Fe-V' - REF42 'Annika Forsberg and John ]gren, TRITA-MAC 483 (1992); Fe-Mn-Si' - REF220 'P Gustafson, Inst. Met. Res. (Sweden) (1990); Estimations of - C-CR-FE-V, C-CR-FE-MO-V-W, FE-N-W, FE-MN-N, FE-N-SI, CR-N-V, C-CR - -N, - FE-MO-N, CR-N-W, CR-TI-N' - REF133 'K. Frisk, TRITA-MAC 429 (1990); CR-MO-NI' - REF132 'K. Frisk, TRITA-MAC 428 (1990); FE-MO-NI' - REF286 'SGTE Substance database, AUG 1989.' - REF107 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 - TRITA 0270 (1986); CR-FE' - REF269 'W. Huang, TRITA-MAC 432 (Rev 1989,1990); FE-V' - REF136 'Unassessed parameter, linear combination of unary data. (MU, - SIGMA)' - REF123 'K. Frisk, Report D 60, KTH, (1984); CR-MO' - REF325 'Byeong-Joo Lee, unpublished revision (1991), C-Cr-Fe-Mo-Ni' - REF270 'W. Huang, TRITA-MAC 432 (1990); C-Fe-V' - REF58 'B. Sundman, TEST' - REF207 'P. Gustafson, Metall. Trans. 19A(1988) p 2547-2554, - TRITA-MAC 348, (1987); C-CR-FE-W' - REF126 'K. Frisk, Metall. Trans. Vol 21A (1990) p 2477-2488, - TRITA 0409 (1989); CR-FE-N' - REF117 'J-O Andersson, TRITA-MAC 323 (1986); C-CR-FE-MO' - REF111 'J-O Andersson, CALPHAD Vol 7, (1983), p 305-315 (parameters - revised - 1986 due to new decription of V) TRITA 0201 (1982); FE-V' - ! - + +$ Database file written 2012- 2-11 +$ From database: SSOL2 + ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7400E+00! + ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01! + ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! + ELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01! + ELEMENT SI DIAMOND_A4 2.8085E+01 3.2175E+03 1.8820E+01! + ELEMENT V BCC_A2 5.0941E+01 4.5070E+03 3.0890E+01! + + SPECIES C1 C! + SPECIES C2 C2! + SPECIES C3 C3! + SPECIES C4 C4! + SPECIES C5 C5! + SPECIES C6 C6! + SPECIES C7 C7! + SPECIES V1C1 V1C1! + + FUNCTION GHSERCC 2.98150E+02 -17368.441+170.73*T-24.3*T*LN(T) + -4.723E-04*T**2+2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3); + 6.00000E+03 N ! + FUNCTION GPCLIQ 2.98150E+02 +YCLIQ#*EXP(ZCLIQ#); 6.00000E+03 N ! + FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) + +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y + -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N ! + FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N ! + FUNCTION GFELIQ 2.98150E+02 +12040.17-6.55843*T-3.6751551E-21*T**7 + +GHSERFE#; 1.81100E+03 Y + -10839.7+291.302*T-46*T*LN(T); 6.00000E+03 N ! + FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N ! + FUNCTION GHSERMO 2.98150E+02 -7746.302+131.9197*T-23.56414*T*LN(T) + -.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4; + 2.89600E+03 Y + -30556.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9); + 5.00000E+03 N ! + FUNCTION GPMOLIQ 2.98150E+02 +YMOLIQ#*EXP(ZMOLIQ#); 6.00000E+03 N ! + FUNCTION GHSERSI 2.98150E+02 -8162.609+137.227259*T-22.8317533*T*LN(T) + -.001912904*T**2-3.552E-09*T**3+176667*T**(-1); 1.68700E+03 Y + -9457.642+167.271767*T-27.196*T*LN(T)-4.20369E+30*T**(-9); + 3.60000E+03 N ! + FUNCTION GHSERVV 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T) + -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y + -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; + 2.18300E+03 Y + -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); + 4.00000E+03 N ! + FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N ! + FUNCTION GPCGRA 2.98150E+02 +YCGRA#*EXP(ZCGRA#); 6.00000E+03 N ! + FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T) + -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y + -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N + ! + FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N ! + FUNCTION GSIBCC 2.98150E+02 +47000-22.5*T+GHSERSI#; 6.00000E+03 N ! + FUNCTION GPMOBCC 2.98150E+02 +YMOBCC#*EXP(ZMOBCC#); 6.00000E+03 N ! + FUNCTION GFECEM 2.98150E+02 -10745+706.04*T-120.6*T*LN(T)+GPCEM1#; + 6.00000E+03 N ! + FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N ! + FUNCTION GFEFCC 2.98150E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 + +GHSERFE#; 1.81100E+03 Y + -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N + ! + FUNCTION GMOFCC 2.98150E+02 +15200+.63*T+GHSERMO#; 6.00000E+03 N ! + FUNCTION GPCDIA 2.98150E+02 +YCDIA#*EXP(ZCDIA#); 6.00000E+03 N ! + FUNCTION GPCFCC 2.98150E+02 +YCFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! + FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! + FUNCTION GHSERVZ 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T) + -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y + -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; + 4.00000E+03 Y + -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); + 6.00000E+03 N ! + FUNCTION GPFEHCP 2.98150E+02 +YFEHCP#*EXP(ZFEHCP#); 6.00000E+03 N ! + FUNCTION GCRM23C6 2.98150E+02 -521983+3622.24*T-620.965*T*LN(T) + -.126431*T**2; 6.00000E+03 N ! + FUNCTION GFEM23C6 2.98150E+02 +7.666667*GFECEM#-1.666667*GHSERCC#+66920 + -40*T; 6.00000E+03 N ! + FUNCTION GVM23C6 2.98150E+02 -990367+4330.63*T-728.829*T*LN(T) + +5003425*T**(-1); 6.00000E+03 N ! + FUNCTION GCRM3C2 2.98150E+02 -100823.8+530.66989*T-89.6694*T*LN(T) + -.0301188*T**2; 6.00000E+03 N ! + FUNCTION GCRM7C3 2.98150E+02 -201690+1103.128*T-190.177*T*LN(T) + -.0578207*T**2; 6.00000E+03 N ! + FUNCTION GPMU1 2.98150E+02 +8.72E-05*P; 6.00000E+03 N ! + FUNCTION GPMU2 2.98150E+02 +1.04E-04*P; 6.00000E+03 N ! + FUNCTION GPR1 2.98150E+02 +3.81E-04*P; 6.00000E+03 N ! + FUNCTION GPR2 2.98150E+02 +4.33E-04*P; 6.00000E+03 N ! + FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N ! + FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N ! + FUNCTION L0BCC 2.98150E+02 -27809+11.62*T; 6.00000E+03 N ! + FUNCTION FESIW1 2.98150E+02 +1260*R#; 6.00000E+03 N ! + FUNCTION L1BCC 2.98150E+02 -11544; 6.00000E+03 N ! + FUNCTION L2BCC 2.98150E+02 3890; 6.00000E+03 N ! + FUNCTION ETCFESI 2.98150E+02 63; 6.00000E+03 N ! + FUNCTION YCLIQ 2.98150E+02 +VCLIQ#*EXP(-ECLIQ#); 6.00000E+03 N ! + FUNCTION ZCLIQ 2.98150E+02 +1*LN(XCLIQ#); 6.00000E+03 N ! + FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N ! + FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N ! + FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N ! + FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N ! + FUNCTION YMOLIQ 2.98150E+02 +VMOLIQ#*EXP(-EMOLIQ#); 6.00000E+03 N ! + FUNCTION ZMOLIQ 2.98150E+02 +1*LN(XMOLIQ#); 6.00000E+03 N ! + FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N ! + FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N ! + FUNCTION YCGRA 2.98150E+02 +VCGRA#*EXP(-ECGRA#); 6.00000E+03 N ! + FUNCTION ZCGRA 2.98150E+02 +1*LN(XCGRA#); 6.00000E+03 N ! + FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N ! + FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N ! + FUNCTION YMOBCC 2.98150E+02 +VMOBCC#*EXP(-EMOBCC#); 6.00000E+03 N ! + FUNCTION ZMOBCC 2.98150E+02 +1*LN(XMOBCC#); 6.00000E+03 N ! + FUNCTION GPCEM1 2.98150E+02 +VCEM1#*P; 6.00000E+03 N ! + FUNCTION YCDIA 2.98150E+02 +VCDIA#*EXP(-ECDIA#); 6.00000E+03 N ! + FUNCTION ZCDIA 2.98150E+02 +1*LN(XCDIA#); 6.00000E+03 N ! + FUNCTION YCFCC 2.98150E+02 +VCFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! + FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N ! + FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! + FUNCTION YFEHCP 2.98150E+02 +VFEHCP#*EXP(-EFEHCP#); 6.00000E+03 N ! + FUNCTION ZFEHCP 2.98150E+02 +1*LN(XFEHCP#); 6.00000E+03 N ! + FUNCTION VCLIQ 2.98150E+02 +7.626E-06*EXP(ACLIQ#); 6.00000E+03 N ! + FUNCTION ECLIQ 2.98150E+02 +1*LN(CCLIQ#); 6.00000E+03 N ! + FUNCTION XCLIQ 2.98150E+02 +1*EXP(.5*DCLIQ#)-1; 6.00000E+03 N ! + FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N + ! + FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N ! + FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N ! + FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 + N ! + FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N ! + FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 + N ! + FUNCTION VMOLIQ 2.98150E+02 +9.75079E-06*EXP(AMOLIQ#); 6.00000E+03 + N ! + FUNCTION EMOLIQ 2.98150E+02 +1*LN(CMOLIQ#); 6.00000E+03 N ! + FUNCTION XMOLIQ 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 + N ! + FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N + ! + FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N ! + FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N ! + FUNCTION VCGRA 2.98150E+02 +5.259E-06*EXP(ACGRA#); 6.00000E+03 N ! + FUNCTION ECGRA 2.98150E+02 +1*LN(CCGRA#); 6.00000E+03 N ! + FUNCTION XCGRA 2.98150E+02 +1*EXP(.9166667*DCGRA#)-1; 6.00000E+03 + N ! + FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 + N ! + FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N ! + FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 + N ! + FUNCTION VMOBCC 2.98150E+02 +9.34372E-06*EXP(AMOBCC#); 6.00000E+03 + N ! + FUNCTION EMOBCC 2.98150E+02 +1*LN(CMOBCC#); 6.00000E+03 N ! + FUNCTION XMOBCC 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 + N ! + FUNCTION VCEM1 2.98150E+02 +2.339E-05*EXP(ACEM1#); 6.00000E+03 N ! + FUNCTION VCDIA 2.98150E+02 +3.412E-06*EXP(ACDIA#); 6.00000E+03 N ! + FUNCTION ECDIA 2.98150E+02 +1*LN(CCDIA#); 6.00000E+03 N ! + FUNCTION XCDIA 2.98150E+02 +1*EXP(.8*DCDIA#)-1; 6.00000E+03 N ! + FUNCTION VCFCC 2.98150E+02 +1.031E-05*EXP(ACFCC#); 6.00000E+03 N ! + FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N ! + FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 + N ! + FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 + N ! + FUNCTION VFEHCP 2.98150E+02 +6.59121E-06*EXP(AFEHCP#); 6.00000E+03 + N ! + FUNCTION EFEHCP 2.98150E+02 +1*LN(CFEHCP#); 6.00000E+03 N ! + FUNCTION XFEHCP 2.98150E+02 +1*EXP(.8064454*DFEHCP#)-1; 6.00000E+03 + N ! + FUNCTION ACLIQ 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 + N ! + FUNCTION CCLIQ 2.98150E+02 1.6E-10; 6.00000E+03 N ! + FUNCTION DCLIQ 2.98150E+02 +1*LN(BCLIQ#); 6.00000E+03 N ! + FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N + ! + FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N ! + FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N ! + FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N ! + FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; + 6.00000E+03 N ! + FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N ! + FUNCTION AMOLIQ 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2 + +1.14687E-12*T**3; 6.00000E+03 N ! + FUNCTION CMOLIQ 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; + 6.00000E+03 N ! + FUNCTION DMOBCC 2.98150E+02 +1*LN(BMOBCC#); 6.00000E+03 N ! + FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N + ! + FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N ! + FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N ! + FUNCTION ACGRA 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 + N ! + FUNCTION CCGRA 2.98150E+02 3.3E-10; 6.00000E+03 N ! + FUNCTION DCGRA 2.98150E+02 +1*LN(BCGRA#); 6.00000E+03 N ! + FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; + 6.00000E+03 N ! + FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; + 6.00000E+03 N ! + FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N ! + FUNCTION AMOBCC 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2 + +1.14687E-12*T**3; 6.00000E+03 N ! + FUNCTION CMOBCC 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; + 6.00000E+03 N ! + FUNCTION ACEM1 2.98150E+02 -1.36E-05*T+4E-08*T**2; 6.00000E+03 N ! + FUNCTION ACDIA 2.98150E+02 +2.43E-06*T+5E-09*T**2; 6.00000E+03 N ! + FUNCTION CCDIA 2.98150E+02 6.8E-12; 6.00000E+03 N ! + FUNCTION DCDIA 2.98150E+02 +1*LN(BCDIA#); 6.00000E+03 N ! + FUNCTION ACFCC 2.98150E+02 +1.44E-04*T; 6.00000E+03 N ! + FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; + 6.00000E+03 N ! + FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N ! + FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N ! + FUNCTION AFEHCP 2.98150E+02 +7.3646E-05*T; 6.00000E+03 N ! + FUNCTION CFEHCP 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; + 6.00000E+03 N ! + FUNCTION DFEHCP 2.98150E+02 +1*LN(BFEHCP#); 6.00000E+03 N ! + FUNCTION BCLIQ 2.98150E+02 +1+3.2E-10*P; 6.00000E+03 N ! + FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N ! + FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; + 6.00000E+03 N ! + FUNCTION BMOBCC 2.98150E+02 +1+1.13837E-11*P+4.875E-16*T*P + +1.2675E-19*T**2*P; 6.00000E+03 N ! + FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N ! + FUNCTION BCGRA 2.98150E+02 +1+3.6E-10*P; 6.00000E+03 N ! + FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; + 6.00000E+03 N ! + FUNCTION BCDIA 2.98150E+02 +1+8.5E-12*P; 6.00000E+03 N ! + FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; + 6.00000E+03 N ! + FUNCTION BFEHCP 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; + 6.00000E+03 N ! + FUNCTION UN_ASS 298.15 0; 300 N ! + + TYPE_DEFINITION % SEQ *! + DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! + DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! + + + PHASE LIQUID:L % 1 1.0 ! + CONSTITUENT LIQUID:L :C,CR,FE,MO,SI,V : ! + + PARAMETER G(LIQUID,C;0) 2.98150E+02 +117369-24.63*T+GHSERCC#+GPCLIQ#; + 6.00000E+03 N REF283 ! + PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T + +2.37615E-21*T**7+GHSERCR#+GPCRLIQ#; 2.18000E+03 Y + +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#+GPCRLIQ#; 6.00000E+03 + N REF283 ! + PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 + N REF283 ! + PARAMETER G(LIQUID,MO;0) 2.98150E+02 +41831.347-14.694912*T + +4.24519E-22*T**7+GHSERMO#+GPMOLIQ#; 2.89600E+03 Y + +34095.373-11.890046*T+4.849315E+33*T**(-9)+GHSERMO#+GPMOLIQ#; + 5.00000E+03 N REF283 ! + PARAMETER G(LIQUID,SI;0) 2.98150E+02 +50696.36-30.099439*T + +2.09307E-21*T**7+GHSERSI#; 1.68700E+03 Y + +49828.165-29.559069*T+4.20369E+30*T**(-9)+GHSERSI#; 3.60000E+03 N + REF283 ! + PARAMETER G(LIQUID,V;0) 2.98150E+02 +20764.117-9.455552*T + -5.19136E-22*T**7+GHSERVV#; 7.90000E+02 Y + +20764.117-9.455552*T-5.19136E-22*T**7+GHSERVV#; 2.18300E+03 Y + +22072.354-10.0848*T-6.44389E+31*T**(-9)+GHSERVV#; 4.00000E+03 N REF283 ! + PARAMETER G(LIQUID,C,CR;0) 2.98150E+02 -90526-25.9116*T; 6.00000E+03 + N REF101 ! + PARAMETER G(LIQUID,C,CR;1) 2.98150E+02 80000; 6.00000E+03 N REF101 ! + PARAMETER G(LIQUID,C,CR;2) 2.98150E+02 80000; 6.00000E+03 N REF101 ! + PARAMETER G(LIQUID,C,CR,FE;0) 2.98150E+02 -496063; 6.00000E+03 N + REF322 ! + PARAMETER G(LIQUID,C,CR,FE;1) 2.98150E+02 57990; 6.00000E+03 N + REF322 ! + PARAMETER G(LIQUID,C,CR,FE;2) 2.98150E+02 61404; 6.00000E+03 N + REF322 ! + PARAMETER G(LIQUID,C,CR,V;0) 2.98150E+02 -769497; 6.00000E+03 N + REF324 ! + PARAMETER G(LIQUID,C,CR,V;1) 2.98150E+02 263981; 6.00000E+03 N + REF324 ! + PARAMETER G(LIQUID,C,CR,V;2) 2.98150E+02 3599; 6.00000E+03 N REF324 ! + PARAMETER G(LIQUID,C,FE;0) 2.98150E+02 -124320+28.5*T; 6.00000E+03 + N REF190 ! + PARAMETER G(LIQUID,C,FE;1) 2.98150E+02 19300; 6.00000E+03 N REF190 ! + PARAMETER G(LIQUID,C,FE;2) 2.98150E+02 +49260-19*T; 6.00000E+03 N + REF190 ! + PARAMETER G(LIQUID,C,FE,SI;0) 2.98150E+02 445740; 6.00000E+03 N + REF99 ! + PARAMETER G(LIQUID,C,FE,SI;1) 2.98150E+02 -6065-35.33*T; 6.00000E+03 + N REF99 ! + PARAMETER G(LIQUID,C,FE,SI;2) 2.98150E+02 +2545792-1450.6*T; + 6.00000E+03 N REF99 ! + PARAMETER G(LIQUID,C,FE,V;0) 2.98150E+02 -60000; 6.00000E+03 N + REF270 ! + PARAMETER G(LIQUID,C,FE,V;1) 2.98150E+02 -60000; 6.00000E+03 N + REF270 ! + PARAMETER G(LIQUID,C,FE,V;2) 2.98150E+02 100000; 6.00000E+03 N + REF270 ! + PARAMETER G(LIQUID,C,FE,MO;0) 2.98150E+02 -37800; 6.00000E+03 N + REF113 ! + PARAMETER G(LIQUID,C,MO;0) 2.98150E+02 -217800+38.41*T; 6.00000E+03 + N REF104 ! + PARAMETER G(LIQUID,C,MO;1) 2.98150E+02 30000; 6.00000E+03 N REF104 ! + PARAMETER G(LIQUID,C,MO;2) 2.98150E+02 47000; 6.00000E+03 N REF104 ! + PARAMETER G(LIQUID,C,SI;0) 2.98150E+02 -133000+30.97*T; 6.00000E+03 + N REF99 ! + PARAMETER G(LIQUID,C,V;0) 2.98150E+02 -284196+38.952*T; 6.00000E+03 + N REF256 ! + PARAMETER G(LIQUID,C,V;1) 2.98150E+02 +96335-17.775*T; 6.00000E+03 + N REF256 ! + PARAMETER G(LIQUID,C,V;2) 2.98150E+02 102050; 6.00000E+03 N REF256 ! + PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -14550+6.65*T; 6.00000E+03 + N REF107 ! + PARAMETER G(LIQUID,CR,FE,V;0) 2.98150E+02 14881; 6.00000E+03 N + REF323 ! + PARAMETER G(LIQUID,CR,FE,V;1) 2.98150E+02 17968; 6.00000E+03 N + REF323 ! + PARAMETER G(LIQUID,CR,FE,V;2) 2.98150E+02 -7692; 6.00000E+03 N + REF323 ! + PARAMETER G(LIQUID,CR,MO;0) 2.98150E+02 +15810-6.714*T; 6.00000E+03 + N REF123 ! + PARAMETER G(LIQUID,CR,MO;1) 2.98150E+02 -6220; 6.00000E+03 N REF123 ! + PARAMETER G(LIQUID,CR,SI;0) 2.98150E+02 -120157.52+16.63891*T; + 6.00000E+03 N REF90 ! + PARAMETER G(LIQUID,CR,SI;1) 2.98150E+02 -49502.35+13.76967*T; + 6.00000E+03 N REF90 ! + PARAMETER G(LIQUID,CR,V;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 + N REF323 ! + PARAMETER G(LIQUID,CR,V;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 + N REF323 ! + PARAMETER G(LIQUID,FE,MO;0) 2.98150E+02 -6973-.37*T; 6.00000E+03 N + REF10 ! + PARAMETER G(LIQUID,FE,MO;1) 2.98150E+02 -9424+4.502*T; 6.00000E+03 + N REF10 ! + PARAMETER G(LIQUID,FE,SI;0) 2.98150E+02 -164435+41.977*T; 6.00000E+03 + N REF99 ! + PARAMETER G(LIQUID,FE,SI;1) 2.98150E+02 -21.523*T; 6.00000E+03 N + REF99 ! + PARAMETER G(LIQUID,FE,SI;2) 2.98150E+02 -18821+22.07*T; 6.00000E+03 + N REF99 ! + PARAMETER G(LIQUID,FE,SI;3) 2.98150E+02 9696; 6.00000E+03 N REF99 ! + PARAMETER G(LIQUID,FE,V;0) 2.98150E+02 -34679+1.895*T; 6.00000E+03 + N REF269 ! + PARAMETER G(LIQUID,FE,V;1) 2.98150E+02 10209; 6.00000E+03 N REF269 ! + + + TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! + PHASE BCC_A2 %& 2 1 3 ! + CONSTITUENT BCC_A2 :CR%,FE%,MO%,SI,V% : C,VA% : ! + + PARAMETER G(BCC_A2,CR:C;0) 2.98150E+02 +GHSERCR#+3*GHSERCC#+GPCRBCC# + +3*GPCGRA#+416000; 6.00000E+03 N REF101 ! + PARAMETER TC(BCC_A2,CR:C;0) 2.98150E+02 -311.5; 6.00000E+03 N + REF101 ! + PARAMETER BMAGN(BCC_A2,CR:C;0) 2.98150E+02 -.008; 6.00000E+03 N + REF101 ! + PARAMETER G(BCC_A2,FE:C;0) 2.98150E+02 +322050+75.667*T+GHSERFE# + +GPFEBCC#+3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF190 ! + PARAMETER TC(BCC_A2,FE:C;0) 2.98150E+02 1043; 6.00000E+03 N REF190 ! + PARAMETER BMAGN(BCC_A2,FE:C;0) 2.98150E+02 2.22; 6.00000E+03 N + REF190 ! + PARAMETER G(BCC_A2,MO:C;0) 2.98150E+02 +331000-75*T+GHSERMO#+3*GHSERCC#; + 6.00000E+03 N REF104 ! + PARAMETER G(BCC_A2,SI:C;0) 2.98150E+02 +322050-75.667*T+GSIBCC# + +3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF98 ! + PARAMETER G(BCC_A2,V:C;0) 2.98150E+02 +108449+GHSERVV#+3*GHSERCC#; + 6.00000E+03 N REF256 ! + PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N + REF281 ! + PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.01; 6.00000E+03 N + REF281 ! + PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF281 ! + PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N + REF281 ! + PARAMETER G(BCC_A2,MO:VA;0) 2.98150E+02 +GHSERMO#+GPMOBCC#; + 5.00000E+03 N REF283 ! + PARAMETER G(BCC_A2,SI:VA;0) 2.98150E+02 +GSIBCC#; 3.60000E+03 N + REF283 ! + PARAMETER G(BCC_A2,V:VA;0) 2.98150E+02 +GHSERVV#; 4.00000E+03 N + REF283 ! + PARAMETER G(BCC_A2,CR,FE:C;0) 2.98150E+02 -1250000+667.7*T; + 6.00000E+03 N REF322 ! + PARAMETER TC(BCC_A2,CR,FE:C;0) 2.98150E+02 1650; 6.00000E+03 N + REF102 ! + PARAMETER TC(BCC_A2,CR,FE:C;1) 2.98150E+02 550; 6.00000E+03 N + REF102 ! + PARAMETER BMAGN(BCC_A2,CR,FE:C;0) 2.98150E+02 -.85; 6.00000E+03 N + REF102 ! + PARAMETER G(BCC_A2,CR:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N + REF101 ! + PARAMETER G(BCC_A2,FE,MO:C;0) 2.98150E+02 -1250000+667.7*T; + 6.00000E+03 N REF325 ! + PARAMETER TC(BCC_A2,FE,MO:C;0) 2.98150E+02 335; 6.00000E+03 N + REF104 ! + PARAMETER TC(BCC_A2,FE,MO:C;1) 2.98150E+02 526; 6.00000E+03 N + REF104 ! + PARAMETER G(BCC_A2,FE,SI:C;0) 2.98150E+02 78866; 6.00000E+03 N + REF99 ! + PARAMETER G(BCC_A2,FE,V:C;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 + N REF270 ! + PARAMETER G(BCC_A2,FE,V:C;1) 2.98150E+02 8283; 6.00000E+03 N REF270 ! + PARAMETER G(BCC_A2,FE:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N + REF190 ! + PARAMETER G(BCC_A2,V:C,VA;0) 2.98150E+02 -297868; 6.00000E+03 N + REF256 ! + PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 + N REF107 ! + PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N + REF107 ! + PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N + REF107 ! + PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N + REF107 ! + PARAMETER G(BCC_A2,CR,FE,V:VA;0) 2.98150E+02 14881; 6.00000E+03 N + REF323 ! + PARAMETER G(BCC_A2,CR,FE,V:VA;1) 2.98150E+02 17968; 6.00000E+03 N + REF323 ! + PARAMETER G(BCC_A2,CR,FE,V:VA;2) 2.98150E+02 -7692; 6.00000E+03 N + REF323 ! + PARAMETER G(BCC_A2,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; + 6.00000E+03 N REF123 ! + PARAMETER G(BCC_A2,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 + N REF123 ! + PARAMETER G(BCC_A2,CR,SI:VA;0) 2.98150E+02 -102850.19+9.85457*T; + 6.00000E+03 N REF90 ! + PARAMETER G(BCC_A2,CR,SI:VA;1) 2.98150E+02 -49502.35+13.76967*T; + 6.00000E+03 N REF90 ! + PARAMETER G(BCC_A2,CR,V:VA;0) 2.98150E+02 -9875-2.6964*T; 6.00000E+03 + N REF323 ! + PARAMETER G(BCC_A2,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 + N REF323 ! + PARAMETER G(BCC_A2,FE,MO:VA;0) 2.98150E+02 +36818-9.141*T; + 6.00000E+03 N REF10 ! + PARAMETER G(BCC_A2,FE,MO:VA;1) 2.98150E+02 -362-5.724*T; 6.00000E+03 + N REF10 ! + PARAMETER TC(BCC_A2,FE,MO:VA;0) 2.98150E+02 335; 6.00000E+03 N + REF10 ! + PARAMETER TC(BCC_A2,FE,MO:VA;1) 2.98150E+02 526; 6.00000E+03 N + REF10 ! + PARAMETER G(BCC_A2,FE,SI:VA;0) 2.98150E+02 +4*L0BCC#-4*FESIW1#; + 6.00000E+03 N REF98 ! + PARAMETER G(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*L1BCC#; 6.00000E+03 N + REF98 ! + PARAMETER G(BCC_A2,FE,SI:VA;2) 2.98150E+02 +16*L2BCC#; 6.00000E+03 + N REF98 ! + PARAMETER TC(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*ETCFESI#; 6.00000E+03 + N REF98 ! + PARAMETER G(BCC_A2,FE,V:VA;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 + N REF269 ! + PARAMETER G(BCC_A2,FE,V:VA;1) 2.98150E+02 8283; 6.00000E+03 N + REF269 ! + PARAMETER TC(BCC_A2,FE,V:VA;0) 2.98150E+02 -110; 6.00000E+03 N + REF111 ! + PARAMETER TC(BCC_A2,FE,V:VA;1) 2.98150E+02 3075; 6.00000E+03 N + REF111 ! + PARAMETER TC(BCC_A2,FE,V:VA;2) 2.98150E+02 808; 6.00000E+03 N + REF111 ! + PARAMETER TC(BCC_A2,FE,V:VA;3) 2.98150E+02 -2169; 6.00000E+03 N + REF111 ! + PARAMETER BMAGN(BCC_A2,FE,V:VA;0) 2.98150E+02 -2.26; 6.00000E+03 N + REF111 ! + + + TYPE_DEFINITION ' GES A_P_D CBCC_A12 MAGNETIC -3.0 2.80000E-01 ! + PHASE CBCC_A12 %' 2 1 1 ! + CONSTITUENT CBCC_A12 :CR,FE,SI,V : C,VA% : ! + + PARAMETER G(CBCC_A12,CR:C;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CBCC_A12,FE:C;0) 2.98150E+02 +80000+GHSERFE#+GHSERCC#; + 6.00000E+03 N REF267 ! + PARAMETER G(CBCC_A12,SI:C;0) 2.98150E+02 +1000000+566.0326*T + -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); + 3.00000E+03 N REF177 ! + PARAMETER G(CBCC_A12,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; + 6.00000E+03 N REF275 ! + PARAMETER G(CBCC_A12,CR:VA;0) 2.98150E+02 +11087+2.7196*T+GHSERCR#; + 6.00000E+03 N REF283 ! + PARAMETER G(CBCC_A12,FE:VA;0) 2.98150E+02 +4745+GHSERFE#; 6.00000E+03 + N REF283 ! + PARAMETER G(CBCC_A12,SI:VA;0) 2.98150E+02 +50208-20.377*T+GHSERSI#; + 3.60000E+03 N REF283 ! + PARAMETER G(CBCC_A12,V:VA;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CBCC_A12,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N + REF267 ! + PARAMETER G(CBCC_A12,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; + 6.00000E+03 N REF42 ! + PARAMETER G(CBCC_A12,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N + REF42 ! + PARAMETER G(CBCC_A12,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N + REF42 ! + PARAMETER G(CBCC_A12,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N + REF275 ! + + + PHASE CEMENTITE % 2 3 1 ! + CONSTITUENT CEMENTITE :CR,FE%,MO,V : C : ! + + PARAMETER G(CEMENTITE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#-48000 + -9.2888*T; 6.00000E+03 N REF322 ! + PARAMETER G(CEMENTITE,FE:C;0) 2.98150E+02 +GFECEM#; 6.00000E+03 N + REF190 ! + PARAMETER G(CEMENTITE,MO:C;0) 2.98150E+02 +3*GHSERMO#+GHSERCC#+77000 + -57.4*T; 6.00000E+03 N REF104 ! + PARAMETER G(CEMENTITE,V:C;0) 2.98150E+02 -156971+601.922*T + -100.438*T*LN(T)+765557*T**(-1); 6.00000E+03 N REF275 ! + PARAMETER G(CEMENTITE,CR,FE:C;0) 2.98150E+02 +25278-17.5*T; + 6.00000E+03 N REF322 ! + PARAMETER G(CEMENTITE,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N + REF316 ! + PARAMETER G(CEMENTITE,CR,V:C;0) 2.98150E+02 -29622-8.0892*T; + 6.00000E+03 N REF324 ! + PARAMETER G(CEMENTITE,CR,V:C;1) 2.98150E+02 -5160-7.5711*T; + 6.00000E+03 N REF324 ! + PARAMETER G(CEMENTITE,FE,V:C;0) 2.98150E+02 -45873-12.414*T; + 6.00000E+03 N REF270 ! + + + PHASE CHI_A12 % 3 24 10 24 ! + CONSTITUENT CHI_A12 :CR,FE : CR,MO : CR,FE,MO : ! + + PARAMETER G(CHI_A12,CR:CR:CR;0) 2.98150E+02 +48*GCRFCC#+10*GHSERCR# + +109000+123*T; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:CR:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR# + +24*GCRFCC#+18300-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(CHI_A12,CR:MO:CR;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# + +24*GCRFCC#-26000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:MO:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO# + +24*GCRFCC#+32555-385*T; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,CR:CR:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR# + +24*GFEFCC#+500000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:CR:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERCR# + +57300-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(CHI_A12,CR:MO:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# + +24*GFEFCC#+500000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:MO:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERMO# + +305210-270*T; 6.00000E+03 N REF115 ! + PARAMETER G(CHI_A12,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR# + +24*GMOFCC#+500000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:CR:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR# + +24*GMOFCC#+100000; 6.00000E+03 N REF115 ! + PARAMETER G(CHI_A12,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# + +24*GMOFCC#+500000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO# + +24*GMOFCC#+97300-100*T; 6.00000E+03 N REF115 ! + + + PHASE CR2VC2 % 3 2 1 2 ! + CONSTITUENT CR2VC2 :CR : V : C : ! + + PARAMETER G(CR2VC2,CR:V:C;0) 2.98150E+02 -105987-38.2069*T+2*GHSERCR# + +GHSERVV#+2*GHSERCC#; 6.00000E+03 N REF324 ! + + + PHASE CR3SI % 2 3 1 ! + CONSTITUENT CR3SI :CR%,SI : CR,SI% : ! + + PARAMETER G(CR3SI,CR:CR;0) 2.98150E+02 +17008.82+4*T+4*GHSERCR#; + 6.00000E+03 N REF90 ! + PARAMETER G(CR3SI,SI:CR;0) 2.98150E+02 +167008.8+4*T+GHSERCR# + +3*GHSERSI#; 6.00000E+03 N REF90 ! + PARAMETER G(CR3SI,CR:SI;0) 2.98150E+02 -125456.6+4*T+3*GHSERCR# + +GHSERSI#; 6.00000E+03 N REF90 ! + PARAMETER G(CR3SI,SI:SI;0) 2.98150E+02 +24543.3+4*T+4*GHSERSI#; + 6.00000E+03 N REF90 ! + + + PHASE CR5SI3 % 2 5 3 ! + CONSTITUENT CR5SI3 :CR : SI : ! + + PARAMETER G(CR5SI3,CR:SI;0) 2.98150E+02 -318953.76+1067.49776*T + -182.57818*T*LN(T)-.02391968*T**2-2.31728E-06*T**3; 6.00000E+03 N + REF90 ! + + + PHASE CRSI % 2 1 1 ! + CONSTITUENT CRSI :CR : SI : ! + + PARAMETER G(CRSI,CR:SI;0) 2.98150E+02 -79041.68+311.75228*T + -51.62865*T*LN(T)-.00447355*T**2+391330*T**(-1); 6.00000E+03 N REF90 ! + + + PHASE CRSI2 % 2 1 2 ! + CONSTITUENT CRSI2 :CR%,SI : CR,SI% : ! + + PARAMETER G(CRSI2,CR:CR;0) 2.98150E+02 +10000+10*T+3*GHSERCR#; + 6.00000E+03 N REF90 ! + PARAMETER G(CRSI2,SI:CR;0) 2.98150E+02 +150000-T+2*GHSERCR#+GHSERSI#; + 6.00000E+03 N REF90 ! + PARAMETER G(CRSI2,CR:SI;0) 2.98150E+02 -96793.65+333.25242*T + -57.85575*T*LN(T)-.01322769*T**2-4.3203E-07*T**3; 6.00000E+03 N REF90 ! + PARAMETER G(CRSI2,SI:SI;0) 2.98150E+02 +77711.85-15.05638*T+3*GHSERSI#; + 6.00000E+03 N REF90 ! + PARAMETER G(CRSI2,CR:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; + 6.00000E+03 N REF90 ! + PARAMETER G(CRSI2,SI:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; + 6.00000E+03 N REF90 ! + + + PHASE CUB_A13 % 2 1 1 ! + CONSTITUENT CUB_A13 :CR,FE,SI,V : C,VA% : ! + + PARAMETER G(CUB_A13,CR:C;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CUB_A13,FE:C;0) 2.98150E+02 +90000+GHSERFE#+GHSERCC#; + 6.00000E+03 N REF267 ! + PARAMETER G(CUB_A13,SI:C;0) 2.98150E+02 +1000000+566.0326*T + -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); + 3.00000E+03 N REF177 ! + PARAMETER G(CUB_A13,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; + 6.00000E+03 N REF275 ! + PARAMETER G(CUB_A13,CR:VA;0) 2.98150E+02 +15899+.6276*T+GHSERCR#; + 6.00000E+03 N REF283 ! + PARAMETER G(CUB_A13,FE:VA;0) 2.98150E+02 +3745+GHSERFE#; 6.00000E+03 + N REF283 ! + PARAMETER G(CUB_A13,SI:VA;0) 2.98150E+02 +47279-20.377*T+GHSERSI#; + 3.60000E+03 N REF283 ! + PARAMETER G(CUB_A13,V:VA;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CUB_A13,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N + REF267 ! + PARAMETER G(CUB_A13,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; + 6.00000E+03 N REF42 ! + PARAMETER G(CUB_A13,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N + REF42 ! + PARAMETER G(CUB_A13,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N + REF42 ! + PARAMETER G(CUB_A13,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N + REF275 ! + + + PHASE DIAMOND_A4 % 1 1.0 ! + CONSTITUENT DIAMOND_A4 :C,SI% : ! + + PARAMETER G(DIAMOND_A4,C;0) 2.98150E+02 -16359.441+175.61*T + -24.31*T*LN(T)-4.723E-04*T**2+2698000*T**(-1)-2.61E+08*T**(-2) + +1.11E+10*T**(-3)+GPCDIA#; 6.00000E+03 N REF283 ! + PARAMETER G(DIAMOND_A4,SI;0) 2.98150E+02 +GHSERSI#; 3.60000E+03 N + REF283 ! + + + TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! + PHASE FCC_A1 %( 2 1 1 ! + CONSTITUENT FCC_A1 :CR,FE%,MO,SI,V : C,VA% : ! + + PARAMETER G(FCC_A1,CR:C;0) 2.98150E+02 +GHSERCR#+GHSERCC#+1200-1.94*T; + 6.00000E+03 N REF322 ! + PARAMETER G(FCC_A1,FE:C;0) 2.98150E+02 +77207-15.877*T+GFEFCC#+GHSERCC# + +GPCFCC#; 6.00000E+03 N REF190 ! + PARAMETER TC(FCC_A1,FE:C;0) 2.98150E+02 -201; 6.00000E+03 N REF190 ! + PARAMETER BMAGN(FCC_A1,FE:C;0) 2.98150E+02 -2.1; 6.00000E+03 N + REF190 ! + PARAMETER G(FCC_A1,MO:C;0) 2.98150E+02 -7500-8.3*T-750000*T**(-1) + +GHSERMO#+GHSERCC#; 6.00000E+03 N REF104 ! + PARAMETER G(FCC_A1,SI:C;0) 2.98150E+02 +GHSERSI#+GHSERCC#-20510+38.7*T; + 6.00000E+03 N REF98 ! + PARAMETER G(FCC_A1,V:C;0) 2.98150E+02 -117302+262.57*T-41.756*T*LN(T) + -.00557101*T**2+590546*T**(-1); 6.00000E+03 N REF256 ! + PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; + 6.00000E+03 N REF281 ! + PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N + REF281 ! + PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N + REF281 ! + PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF281 ! + PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N + REF281 ! + PARAMETER G(FCC_A1,MO:VA;0) 2.98150E+02 +15200+.63*T+GHSERMO#+GPMOBCC#; + 5.00000E+03 N REF283 ! + PARAMETER G(FCC_A1,SI:VA;0) 2.98150E+02 +51000-21.8*T+GHSERSI#; + 3.60000E+03 N REF283 ! + PARAMETER G(FCC_A1,V:VA;0) 2.98150E+02 +7500+1.7*T+GHSERVZ#; + 4.00000E+03 N REF283 ! + PARAMETER G(FCC_A1,CR,FE:C;0) 2.98150E+02 -74319+3.2353*T; + 6.00000E+03 N REF322 ! + PARAMETER G(FCC_A1,CR,V:C;0) 2.98150E+02 +35698-50.0981*T; + 6.00000E+03 N REF324 ! + PARAMETER G(FCC_A1,CR:C,VA;0) 2.98150E+02 -11977+6.8194*T; + 6.00000E+03 N REF322 ! + PARAMETER G(FCC_A1,FE,MO:C;0) 2.98150E+02 6000; 6.00000E+03 N + REF113 ! + PARAMETER G(FCC_A1,FE,SI:C;0) 2.98150E+02 +143220+39.31*T; + 6.00000E+03 N REF99 ! + PARAMETER G(FCC_A1,FE,SI:C;1) 2.98150E+02 -216321; 6.00000E+03 N + REF99 ! + PARAMETER G(FCC_A1,FE,V:C;0) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 + N REF270 ! + PARAMETER G(FCC_A1,FE,V:C;1) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 + N REF270 ! + PARAMETER G(FCC_A1,FE,V:C,VA;0) 2.98150E+02 -40000; 6.00000E+03 N + REF270 ! + PARAMETER G(FCC_A1,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N + REF190 ! + PARAMETER G(FCC_A1,MO,V:C;0) 2.98150E+02 -18000; 6.00000E+03 N + REF220 ! + PARAMETER G(FCC_A1,MO:C,VA;0) 2.98150E+02 -41300; 6.00000E+03 N + REF104 ! + PARAMETER G(FCC_A1,V:C,VA;0) 2.98150E+02 -74811+10.201*T; 6.00000E+03 + N REF256 ! + PARAMETER G(FCC_A1,V:C,VA;1) 2.98150E+02 -30394; 6.00000E+03 N + REF256 ! + PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; + 6.00000E+03 N REF107 ! + PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N + REF107 ! + PARAMETER G(FCC_A1,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; + 6.00000E+03 N REF58 ! + PARAMETER G(FCC_A1,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 + N REF58 ! + PARAMETER G(FCC_A1,CR,SI:VA;0) 2.98150E+02 -122850+9.85457*T; + 6.00000E+03 N REF58 ! + PARAMETER G(FCC_A1,CR,SI:VA;1) 2.98150E+02 -49502+13.76967*T; + 6.00000E+03 N REF58 ! + PARAMETER G(FCC_A1,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 + N REF323 ! + PARAMETER G(FCC_A1,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 + N REF323 ! + PARAMETER G(FCC_A1,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; + 6.00000E+03 N REF10 ! + PARAMETER G(FCC_A1,FE,SI:VA;0) 2.98150E+02 -125248+41.116*T; + 6.00000E+03 N REF98 ! + PARAMETER G(FCC_A1,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N + REF98 ! + PARAMETER G(FCC_A1,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N + REF98 ! + PARAMETER G(FCC_A1,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 + N REF269 ! + + + PHASE FE1SI1 % 2 .5 .5 ! + CONSTITUENT FE1SI1 :FE : SI : ! + + PARAMETER G(FE1SI1,FE:SI;0) 2.98150E+02 +.5*GHSERFE#+.5*GHSERSI#-36381 + +2.22*T; 6.00000E+03 N REF98 ! + + + PHASE FE2SI % 2 .666667 .333333 ! + CONSTITUENT FE2SI :FE : SI : ! + + PARAMETER G(FE2SI,FE:SI;0) 2.98150E+02 +.6666667*GHSERFE# + +.3333333*GHSERSI#-23752-3.54*T; 6.00000E+03 N REF98 ! + + + PHASE FE4N % 2 4 1 ! + CONSTITUENT FE4N :FE : C,VA : ! + + PARAMETER G(FE4N,FE:C;0) 2.98150E+02 +15965+4*GHSERFE#+GHSERCC#; + 6.00000E+03 N REF319 ! + PARAMETER G(FE4N,FE:VA;0) 2.98150E+02 +4*GFEFCC#+10; 6.00000E+03 N + REF319 ! + + + PHASE FE5SI3 % 2 .625 .375 ! + CONSTITUENT FE5SI3 :FE : SI : ! + + PARAMETER G(FE5SI3,FE:SI;0) 2.98150E+02 +.625*GHSERFE#+.375*GHSERSI# + -30143+.27*T; 6.00000E+03 N REF98 ! + + + PHASE FE8SI2C % 3 8 2 1 ! + CONSTITUENT FE8SI2C :FE : SI : C : ! + + PARAMETER G(FE8SI2C,FE:SI:C;0) 2.98150E+02 +8*GHSERFE#+2*GHSERSI# + +GHSERCC#-231047+5.566*T; 6.00000E+03 N REF99 ! + + + PHASE FECN_CHI % 2 5 2 ! + CONSTITUENT FECN_CHI :FE : C : ! + + PARAMETER G(FECN_CHI,FE:C;0) 2.98150E+02 -11287.4+1013.78*T + -176.412*T*LN(T)+810869*T**(-1); 6.00000E+03 N REF319 ! + + + PHASE FESI2_H % 2 .3 .7 ! + CONSTITUENT FESI2_H :FE : SI : ! + + PARAMETER G(FESI2_H,FE:SI;0) 2.98150E+02 +.3*GHSERFE#+.7*GHSERSI#-19649 + -.92*T; 6.00000E+03 N REF98 ! + + + PHASE FESI2_L % 2 .333333 .666667 ! + CONSTITUENT FESI2_L :FE : SI : ! + + PARAMETER G(FESI2_L,FE:SI;0) 2.98150E+02 +.333333*GHSERFE# + +.666667*GHSERSI#-27383+3.48*T; 6.00000E+03 N REF98 ! + + + PHASE GRAPHITE % 1 1.0 ! + CONSTITUENT GRAPHITE :C : ! + + PARAMETER G(GRAPHITE,C;0) 2.98150E+02 +GHSERCC#+GPCGRA#; 6.00000E+03 + N REF283 ! + + + TYPE_DEFINITION ) GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 ! + PHASE HCP_A3 %) 2 1 .5 ! + CONSTITUENT HCP_A3 :CR,FE,MO,SI,V : C,VA% : ! + + PARAMETER G(HCP_A3,CR:C;0) 2.98150E+02 +GHSERCR#+.5*GHSERCC#-18504 + +9.4173*T-2.4997*T*LN(T)+.001386*T**2; 6.00000E+03 N REF322 ! + PARAMETER G(HCP_A3,FE:C;0) 2.98150E+02 +52905-11.9075*T+GFEFCC# + +.5*GHSERCC#+GPCFCC#; 6.00000E+03 N REF190 ! + PARAMETER G(HCP_A3,MO:C;0) 2.98150E+02 -24150-3.625*T-163000*T**(-1) + +GHSERMO#+.5*GHSERCC#; 6.00000E+03 N REF104 ! + PARAMETER G(HCP_A3,SI:C;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(HCP_A3,V:C;0) 2.98150E+02 -85473+182.441*T-30.551*T*LN(T) + -.00538998*T**2+229029*T**(-1); 6.00000E+03 N REF256 ! + PARAMETER G(HCP_A3,CR:VA;0) 2.98150E+02 +4438+GHSERCR#+GPCRBCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(HCP_A3,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N + REF281 ! + PARAMETER BMAGN(HCP_A3,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N + REF281 ! + PARAMETER G(HCP_A3,FE:VA;0) 2.98150E+02 -3705.78+12.591*T-1.15*T*LN(T) + +6.4E-04*T**2+GHSERFE#+GPFEHCP#; 1.81100E+03 Y + -3957.199+5.24951*T+4.9251E+30*T**(-9)+GHSERFE#+GPFEHCP#; 6.00000E+03 N + REF283 ! + PARAMETER G(HCP_A3,MO:VA;0) 2.98150E+02 +11550+GHSERMO#+GPMOBCC#; + 5.00000E+03 N REF283 ! + PARAMETER G(HCP_A3,SI:VA;0) 2.98150E+02 +49200-20.8*T+GHSERSI#; + 3.60000E+03 N REF283 ! + PARAMETER G(HCP_A3,V:VA;0) 2.98150E+02 +4000+2.4*T+GHSERVZ#; + 4.00000E+03 N REF283 ! + PARAMETER G(HCP_A3,CR,FE,MO:C;0) 2.98150E+02 -57062; 6.00000E+03 N + REF316 ! + PARAMETER G(HCP_A3,CR,MO:C;0) 2.98150E+02 -3905+18.5304*T; + 6.00000E+03 N REF316 ! + PARAMETER G(HCP_A3,CR,V:C;0) 2.98150E+02 +17165-9.9072*T; 6.00000E+03 + N REF323 ! + PARAMETER G(HCP_A3,CR:C,VA;0) 2.98150E+02 4165; 6.00000E+03 N + REF207 ! + PARAMETER G(HCP_A3,FE,MO:C;0) 2.98150E+02 +13030-33.8*T; 6.00000E+03 + N REF113 ! + PARAMETER G(HCP_A3,FE,V:C;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 + N REF270 ! + PARAMETER G(HCP_A3,FE:C,VA;0) 2.98150E+02 -22126; 6.00000E+03 N + REF319 ! + PARAMETER G(HCP_A3,MO:C,VA;0) 2.98150E+02 4150; 6.00000E+03 N + REF104 ! + PARAMETER G(HCP_A3,V:C,VA;0) 2.98150E+02 +12430-3.986*T; 6.00000E+03 + N REF256 ! + PARAMETER G(HCP_A3,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; + 6.00000E+03 N REF126 ! + PARAMETER G(HCP_A3,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; + 6.00000E+03 N REF117 ! + PARAMETER G(HCP_A3,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 + N REF117 ! + PARAMETER G(HCP_A3,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 + N REF323 ! + PARAMETER G(HCP_A3,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 + N REF323 ! + PARAMETER G(HCP_A3,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; + 6.00000E+03 N REF10 ! + PARAMETER G(HCP_A3,FE,SI:VA;0) 2.98150E+02 -123468+41.116*T; + 6.00000E+03 N REF42 ! + PARAMETER G(HCP_A3,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N + REF42 ! + PARAMETER G(HCP_A3,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N + REF42 ! + PARAMETER G(HCP_A3,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 + N REF270 ! + + + PHASE KSI_CARBIDE % 2 3 1 ! + CONSTITUENT KSI_CARBIDE :CR,FE,MO% : C : ! + + PARAMETER G(KSI_CARBIDE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#+114060 + -47.2519*T; 6.00000E+03 N REF316 ! + PARAMETER G(KSI_CARBIDE,FE:C;0) 2.98150E+02 +14540+20*T+3*GHSERFE# + +GHSERCC#; 6.00000E+03 N REF113 ! + PARAMETER G(KSI_CARBIDE,MO:C;0) 2.98150E+02 +167009-33*T+3*GHSERMO# + +GHSERCC#; 6.00000E+03 N REF113 ! + PARAMETER G(KSI_CARBIDE,CR,FE:C;0) 2.98150E+02 -139900; 6.00000E+03 + N REF316 ! + PARAMETER G(KSI_CARBIDE,CR,MO:C;0) 2.98150E+02 -348033; 6.00000E+03 + N REF316 ! + PARAMETER G(KSI_CARBIDE,FE,MO:C;0) 2.98150E+02 -380000; 6.00000E+03 + N REF113 ! + + + PHASE LAVES_PHASE % 2 2 1 ! + CONSTITUENT LAVES_PHASE :CR,FE : MO : ! + + PARAMETER G(LAVES_PHASE,CR:MO;0) 2.98150E+02 +2*GCRFCC#+GHSERMO#-8000 + -6*T; 6.00000E+03 N REF214 ! + PARAMETER G(LAVES_PHASE,FE:MO;0) 2.98150E+02 -10798-.132*T+2*GFEFCC# + +GHSERMO#; 6.00000E+03 N REF10 ! + + + PHASE M23C6 % 3 20 3 6 ! + CONSTITUENT M23C6 :CR%,FE%,V : CR%,FE%,MO%,V : C : ! + + PARAMETER G(M23C6,CR:CR:C;0) 2.98150E+02 +GCRM23C6#; 6.00000E+03 N + REF102 ! + PARAMETER G(M23C6,FE:CR:C;0) 2.98150E+02 +.1304348*GCRM23C6# + +.8695652*GFEM23C6#; 6.00000E+03 N REF102 ! + PARAMETER G(M23C6,V:CR:C;0) 2.98150E+02 +.869565*GVM23C6# + +.130435*GCRM23C6#; 6.00000E+03 N REF323 ! + PARAMETER G(M23C6,CR:FE:C;0) 2.98150E+02 +.8695652*GCRM23C6# + +.1304348*GFEM23C6#; 6.00000E+03 N REF102 ! + PARAMETER G(M23C6,FE:FE:C;0) 2.98150E+02 +GFEM23C6#; 6.00000E+03 N + REF102 ! + PARAMETER G(M23C6,V:FE:C;0) 2.98150E+02 +.869565*GVM23C6# + +.130435*GFEM23C6#; 6.00000E+03 N REF323 ! + PARAMETER G(M23C6,CR:MO:C;0) 2.98150E+02 +20*GHSERCR#+3*GHSERMO# + +6*GHSERCC#-439117-50.0535*T; 6.00000E+03 N REF316 ! + PARAMETER G(M23C6,FE:MO:C;0) 2.98150E+02 +20*GHSERFE#+3*GHSERMO# + +6*GHSERCC#-76351-5.095*T; 6.00000E+03 N REF316 ! + PARAMETER G(M23C6,V:MO:C;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(M23C6,CR:V:C;0) 2.98150E+02 +.869565*GCRM23C6# + +.130435*GVM23C6#; 6.00000E+03 N REF323 ! + PARAMETER G(M23C6,FE:V:C;0) 2.98150E+02 +.869565*GFEM23C6# + +.130435*GVM23C6#; 6.00000E+03 N REF323 ! + PARAMETER G(M23C6,V:V:C;0) 2.98150E+02 +GVM23C6#; 6.00000E+03 N + REF323 ! + PARAMETER G(M23C6,CR,FE:CR:C;0) 2.98150E+02 -205342+141.6667*T; + 6.00000E+03 N REF322 ! + PARAMETER G(M23C6,CR,FE,V:CR:C;0) 2.98150E+02 -1499585; 6.00000E+03 + N REF324 ! + PARAMETER G(M23C6,CR,V:CR:C;0) 2.98150E+02 -385502; 6.00000E+03 N + REF324 ! + PARAMETER G(M23C6,CR,FE:FE:C;0) 2.98150E+02 -205342+141.6667*T; + 6.00000E+03 N REF322 ! + PARAMETER G(M23C6,CR,FE,V:FE:C;0) 2.98150E+02 -1499585; 6.00000E+03 + N REF324 ! + PARAMETER G(M23C6,CR,V:FE:C;0) 2.98150E+02 -385502; 6.00000E+03 N + REF324 ! + PARAMETER G(M23C6,CR,FE:MO:C;0) 2.98150E+02 -177850+153.905*T; + 6.00000E+03 N REF316 ! + PARAMETER G(M23C6,CR,FE:V:C;0) 2.98150E+02 -205342+141.6667*T; + 6.00000E+03 N REF324 ! + PARAMETER G(M23C6,CR,FE,V:V:C;0) 2.98150E+02 -1499585; 6.00000E+03 + N REF324 ! + PARAMETER G(M23C6,CR,V:V:C;0) 2.98150E+02 -385502; 6.00000E+03 N + REF324 ! + + + PHASE M3C2 % 2 3 2 ! + CONSTITUENT M3C2 :CR,MO,V : C : ! + + PARAMETER G(M3C2,CR:C;0) 2.98150E+02 +GCRM3C2#; 6.00000E+03 N + REF322 ! + PARAMETER G(M3C2,MO:C;0) 2.98150E+02 +3*GHSERMO#+2*GHSERCC#+27183; + 6.00000E+03 N REF316 ! + PARAMETER G(M3C2,V:C;0) 2.98150E+02 -222500+16.6545*T+3*GHSERVV# + +2*GHSERCC#; 6.00000E+03 N REF324 ! + PARAMETER G(M3C2,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N REF316 ! + PARAMETER G(M3C2,CR,V:C;0) 2.98150E+02 21072; 6.00000E+03 N REF324 ! + + + PHASE M3SI % 2 3 1 ! + CONSTITUENT M3SI :FE : SI : ! + + PARAMETER G(M3SI,FE:SI;0) 2.98150E+02 +3*GHSERFE#+GHSERSI#-94274-3.56*T; + 6.00000E+03 N REF42 ! + + + PHASE M5C2 % 2 5 2 ! + CONSTITUENT M5C2 :FE,V : C : ! + + PARAMETER G(M5C2,FE:C;0) 2.98150E+02 +5*GHSERFE#+2*GHSERCC#+54852 + -33.7518*T; 6.00000E+03 N REF322 ! + PARAMETER G(M5C2,V:C;0) 2.98150E+02 -307123.3+1059.7*T-175.66*T*LN(T) + +1453274*T**(-1); 6.00000E+03 N REF275 ! + + + PHASE M6C % 4 2 2 2 1 ! + CONSTITUENT M6C :FE : MO : CR,FE,MO,V : C : ! + + PARAMETER G(M6C,FE:MO:CR:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERCR# + +2*GHSERMO#+GHSERCC#-25298-54.8698*T; 6.00000E+03 N REF316 ! + PARAMETER G(M6C,FE:MO:FE:C;0) 2.98150E+02 +4*GHSERFE#+2*GHSERMO# + +GHSERCC#+77705-101.5*T; 6.00000E+03 N REF113 ! + PARAMETER G(M6C,FE:MO:MO:C;0) 2.98150E+02 +2*GHSERFE#+4*GHSERMO# + +GHSERCC#-122410+30.25*T; 6.00000E+03 N REF113 ! + PARAMETER G(M6C,FE:MO:V:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERMO# + +2*GHSERVV#+GHSERCC#-173000; 6.00000E+03 N REF220 ! + PARAMETER G(M6C,FE:MO:FE,MO:C;0) 2.98150E+02 -37700; 6.00000E+03 N + REF113 ! + + + PHASE M7C3 % 2 7 3 ! + CONSTITUENT M7C3 :CR%,FE,MO,V : C : ! + + PARAMETER G(M7C3,CR:C;0) 2.98150E+02 +GCRM7C3#; 6.00000E+03 N + REF322 ! + PARAMETER G(M7C3,FE:C;0) 2.98150E+02 +7*GHSERFE#+3*GHSERCC#+75000 + -48.2168*T; 6.00000E+03 N REF322 ! + PARAMETER G(M7C3,MO:C;0) 2.98150E+02 +7*GHSERMO#+3*GHSERCC#-140415 + +24.24*T; 6.00000E+03 N REF316 ! + PARAMETER G(M7C3,V:C;0) 2.98150E+02 -454245+1518.48*T-250.981*T*LN(T) + +2148691*T**(-1); 6.00000E+03 N REF324 ! + PARAMETER G(M7C3,CR,FE:C;0) 2.98150E+02 -4520-10*T; 6.00000E+03 N + REF322 ! + PARAMETER G(M7C3,CR,FE,V:C;0) 2.98150E+02 -250158; 6.00000E+03 N + REF324 ! + PARAMETER G(M7C3,CR,MO:C;0) 2.98150E+02 165280; 6.00000E+03 N + REF316 ! + PARAMETER G(M7C3,CR,V:C;0) 2.98150E+02 -110271; 6.00000E+03 N + REF324 ! + + + PHASE MC_ETA % 2 1 1 ! + CONSTITUENT MC_ETA :MO% : C%,VA : ! + + PARAMETER G(MC_ETA,MO:C;0) 2.98150E+02 -9100-5.35*T-750000*T**(-1) + +GHSERMO#+GHSERCC#; 6.00000E+03 N REF113 ! + PARAMETER G(MC_ETA,MO:VA;0) 2.98150E+02 +GHSERMO#+15200+.63*T; + 6.00000E+03 N REF113 ! + PARAMETER G(MC_ETA,MO:C,VA;0) 2.98150E+02 -59500; 6.00000E+03 N + REF104 ! + + + PHASE MC_SHP % 2 1 1 ! + CONSTITUENT MC_SHP :MO : C : ! + + PARAMETER G(MC_SHP,MO:C;0) 2.98150E+02 -32983+2.5*T+GHSERMO#+GHSERCC#; + 6.00000E+03 N REF104 ! + + + PHASE MONI_DELTA % 3 24 20 12 ! + CONSTITUENT MONI_DELTA :CR,FE : CR,FE,MO : MO : ! + + PARAMETER G(MONI_DELTA,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR# + +12*GHSERMO#+50000; 6.00000E+03 N REF133 ! + PARAMETER G(MONI_DELTA,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(MONI_DELTA,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(MONI_DELTA,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE# + +12*GHSERMO#+100000; 6.00000E+03 N REF132 ! + PARAMETER G(MONI_DELTA,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO# + +100000; 6.00000E+03 N REF133 ! + PARAMETER G(MONI_DELTA,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO# + +100000; 6.00000E+03 N REF132 ! + + + PHASE MU_PHASE % 3 7 2 4 ! + CONSTITUENT MU_PHASE :CR,FE : MO : CR,FE,MO : ! + + PARAMETER G(MU_PHASE,CR:MO:CR;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# + +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(MU_PHASE,FE:MO:CR;0) 2.98150E+02 +7*GFEFCC#+2*GHSERMO# + +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(MU_PHASE,CR:MO:FE;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# + +4*GHSERFE#+130000-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(MU_PHASE,FE:MO:FE;0) 2.98150E+02 +39475-6.032*T+7*GFEFCC# + +2*GHSERMO#+4*GHSERFE#+GPMU1#; 6.00000E+03 N REF10 ! + PARAMETER G(MU_PHASE,CR:MO:MO;0) 2.98150E+02 +7*GCRFCC#+6*GHSERMO# + +130000-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(MU_PHASE,FE:MO:MO;0) 2.98150E+02 -46663-5.891*T+7*GFEFCC# + +6*GHSERMO#+GPMU2#; 6.00000E+03 N REF10 ! + PARAMETER G(MU_PHASE,CR,FE:MO:MO;0) 2.98150E+02 -45000; 6.00000E+03 + N REF115 ! + + + PHASE P_PHASE % 3 24 20 12 ! + CONSTITUENT P_PHASE :CR,FE : CR,FE,MO : MO : ! + + PARAMETER G(P_PHASE,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR# + +12*GHSERMO#+252300-100*T; 6.00000E+03 N REF133 ! + PARAMETER G(P_PHASE,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(P_PHASE,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(P_PHASE,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE# + +12*GHSERMO#+111361; 6.00000E+03 N REF132 ! + PARAMETER G(P_PHASE,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO# + +95573-200*T; 6.00000E+03 N REF133 ! + PARAMETER G(P_PHASE,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO# + +362525-332.7*T; 6.00000E+03 N REF132 ! + + + PHASE R_PHASE % 3 27 14 12 ! + CONSTITUENT R_PHASE :CR,FE : MO : CR,FE,MO : ! + + PARAMETER G(R_PHASE,CR:MO:CR;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO# + +12*GHSERCR#-20000; 6.00000E+03 N REF115 ! + PARAMETER G(R_PHASE,FE:MO:CR;0) 2.98150E+02 +27*GFEFCC#+14*GHSERMO# + +12*GHSERCR#+600260-620*T; 6.00000E+03 N REF115 ! + PARAMETER G(R_PHASE,CR:MO:FE;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO# + +12*GHSERFE#+645260-620*T; 6.00000E+03 N REF115 ! + PARAMETER G(R_PHASE,FE:MO:FE;0) 2.98150E+02 -77487-50.486*T+27*GFEFCC# + +14*GHSERMO#+12*GHSERFE#+GPR1#; 6.00000E+03 N REF10 ! + PARAMETER G(R_PHASE,CR:MO:MO;0) 2.98150E+02 +27*GCRFCC#+26*GHSERMO# + -20000; 6.00000E+03 N REF115 ! + PARAMETER G(R_PHASE,FE:MO:MO;0) 2.98150E+02 +313474-289.472*T + +27*GFEFCC#+26*GHSERMO#+GPR2#; 6.00000E+03 N REF10 ! + + + PHASE SIC % 2 1 1 ! + CONSTITUENT SIC :SI : C : ! + + PARAMETER G(SIC,SI:C;0) 2.98150E+02 -85572.2636+173.200518*T + -25.856*T*LN(T)-.02106825*T**2+3.2153E-06*T**3+438415*T**(-1); + 7.00000E+02 Y + -95145.9018+300.345769*T-45.093*T*LN(T)-.00366815*T**2 + +2.19983333E-07*T**3+1341065*T**(-1); 2.10000E+03 Y + -105007.971+360.308813*T-53.073*T*LN(T)-7.4525E-04*T**2 + +1.73166667E-08*T**3+3693345*T**(-1); 4.00000E+03 N REF286 ! + + + PHASE SIGMA % 3 8 4 18 ! + CONSTITUENT SIGMA :FE : CR,MO,V : CR,FE,MO,V : ! + + PARAMETER G(SIGMA,FE:CR:CR;0) 2.98150E+02 +8*GFEFCC#+22*GHSERCR#+92300 + -95.96*T+GPSIG1#; 6.00000E+03 N REF107 ! + PARAMETER G(SIGMA,FE:MO:CR;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO# + +18*GHSERCR#+488480-360*T; 6.00000E+03 N REF115 ! + PARAMETER G(SIGMA,FE:V:CR;0) 2.98150E+02 +155735-89.5976*T+8*GFEFCC# + +4*GHSERVV#+18*GHSERCR#; 6.00000E+03 N REF323 ! + PARAMETER G(SIGMA,FE:CR:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# + +18*GHSERFE#+117300-95.96*T+GPSIG2#; 6.00000E+03 N REF107 ! + PARAMETER G(SIGMA,FE:MO:FE;0) 2.98150E+02 -1813-27.272*T+8*GFEFCC# + +18*GHSERFE#+4*GHSERMO#; 6.00000E+03 N REF10 ! + PARAMETER G(SIGMA,FE:V:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV# + +18*GHSERFE#-157961+60.729*T; 6.00000E+03 N REF269 ! + PARAMETER G(SIGMA,FE:CR:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# + +18*GHSERMO#+312580-260*T; 6.00000E+03 N REF115 ! + PARAMETER G(SIGMA,FE:MO:MO;0) 2.98150E+02 +83326-69.618*T+8*GFEFCC# + +22*GHSERMO#; 6.00000E+03 N REF10 ! + PARAMETER G(SIGMA,FE:V:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV# + +18*GHSERMO#; 6.00000E+03 N REF136 ! + PARAMETER G(SIGMA,FE:CR:V;0) 2.98150E+02 -245761-67.3294*T+8*GFEFCC# + +4*GHSERCR#+18*GHSERVV#; 6.00000E+03 N REF323 ! + PARAMETER G(SIGMA,FE:MO:V;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO# + +18*GHSERVV#; 6.00000E+03 N REF136 ! + PARAMETER G(SIGMA,FE:V:V;0) 2.98150E+02 +8*GFEFCC#+22*GHSERVV#-205321 + -60.967*T; 6.00000E+03 N REF269 ! + PARAMETER G(SIGMA,FE:CR:CR,MO;0) 2.98150E+02 -148000; 6.00000E+03 N + REF115 ! + PARAMETER G(SIGMA,FE:MO:CR,MO;0) 2.98150E+02 121000; 6.00000E+03 N + REF115 ! + PARAMETER G(SIGMA,FE:CR:FE,MO;0) 2.98150E+02 570000; 6.00000E+03 N + REF115 ! + PARAMETER G(SIGMA,FE:CR:FE,V;0) 2.98150E+02 -235158; 6.00000E+03 N + REF323 ! + PARAMETER G(SIGMA,FE:MO:FE,MO;0) 2.98150E+02 222909; 6.00000E+03 N + REF10 ! + PARAMETER G(SIGMA,FE:V:FE,V;0) 2.98150E+02 -305784; 6.00000E+03 N + REF269 ! + + + PHASE V3C2 % 2 3 2 ! + CONSTITUENT V3C2 :FE,V : C : ! + + PARAMETER G(V3C2,FE:C;0) 2.98150E+02 +7250+741.566*T-125.833*T*LN(T) + +779485*T**(-1); 6.00000E+03 N REF275 ! + PARAMETER G(V3C2,V:C;0) 2.98150E+02 -260341+16.897*T+3*GHSERVV# + +2*GHSERCC#; 6.00000E+03 N REF256 ! + + LIST_OF_REFERENCES + NUMBER SOURCE + REF283 'Alan Dinsdale, SGTE Data for Pure Elements, + Calphad Vol 15(1991) p 317-425, + also in NPL Report DMA(A)195 Rev. August 1990' + REF101 'J-O Andersson, Calphad Vol 11 (1987) p 271-276, TRITA 0314; C-CR' + REF190 'P. Gustafson, Scan. J. Metall. vol 14, (1985) p 259-267 + TRITA 0237 (1984); C-FE' + REF104 'J-O Andersson, Calphad Vol 12 (1988) p 1-8 TRITA 0317 (1986); C + -MO' + REF98 'J. Lacaze and B. Sundman, provisional; Fe-Si' + REF256 'W. Huang, TRITA-MAC 431 (1990); C-V' + REF267 'W. Huang, Metall. Trans. Vol 21A(1990) p 2115-2123, + TRITA-MAC 411 (Rev 1989); C-FE-MN' + REF177 'NPL, unpublished work (1989); C-Mn-Si' + REF275 'W. Huang, TRITA-MAC 441 (1990), Fe-Mn-V-C *' + REF322 'Byeong-Joo Lee, unpublished revision (1991); C-Cr-Fe-Ni' + REF213 'P. Gustafson, TRITA-MAC 342, (1987); CR-FE-W' + REF115 'J-O Andersson, Met Trans A, Vol 19A, (1988) p 1385-1394 + TRITA 0322 (1986); CR-FE-MO' + REF324 'Byeong-Joo Lee, TRITA-MAC 475 (1991), C-Cr-Fe-V' + REF90 'I Ansara, unpublished work (1991); Cr-Si' + REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 + September 1989' + REF319 'H. Du and M. Hillert, revision; C-Fe-N' + REF99 'J. Lacaze and B. Sundman, Met. Trans A, Vol 22A (1991) + pp 2211-2223; C-Fe-Si' + REF316 'Caian Qui, Trita-MAC 482 (1992) Revision ; C-Cr-Fe-Mo' + REF113 'J-O Andersson, Calphad Vol 12 (1988), p 9-23 + TRITA 0321 (1986); C-FE-MO' + REF214 'P. Gustafson, TRITA-MAC 354 (1987); C-Cr-Fe-Mo-W' + REF10 'A. Fernandez Guillermet, CALPHAD Vol 6 (1982), p 127-140 + (sigma phase revised 1986), TRITA-MAC 200 (1982); FE-MO' + REF102 'J-O Andersson, Met. Trans A, Vol 19A, (1988) p 627-636 + TRITA 0207 (1986); C-CR-FE' + REF323 'Byeong-Joo Lee, TRITA-MAC 474 (1991), Cr-Fe-V' + REF42 'Annika Forsberg and John ]gren, TRITA-MAC 483 (1992); Fe-Mn-Si' + REF220 'P Gustafson, Inst. Met. Res. (Sweden) (1990); Estimations of + C-CR-FE-V, C-CR-FE-MO-V-W, FE-N-W, FE-MN-N, FE-N-SI, CR-N-V, C-CR + -N, + FE-MO-N, CR-N-W, CR-TI-N' + REF133 'K. Frisk, TRITA-MAC 429 (1990); CR-MO-NI' + REF132 'K. Frisk, TRITA-MAC 428 (1990); FE-MO-NI' + REF286 'SGTE Substance database, AUG 1989.' + REF107 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 + TRITA 0270 (1986); CR-FE' + REF269 'W. Huang, TRITA-MAC 432 (Rev 1989,1990); FE-V' + REF136 'Unassessed parameter, linear combination of unary data. (MU, + SIGMA)' + REF123 'K. Frisk, Report D 60, KTH, (1984); CR-MO' + REF325 'Byeong-Joo Lee, unpublished revision (1991), C-Cr-Fe-Mo-Ni' + REF270 'W. Huang, TRITA-MAC 432 (1990); C-Fe-V' + REF58 'B. Sundman, TEST' + REF207 'P. Gustafson, Metall. Trans. 19A(1988) p 2547-2554, + TRITA-MAC 348, (1987); C-CR-FE-W' + REF126 'K. Frisk, Metall. Trans. Vol 21A (1990) p 2477-2488, + TRITA 0409 (1989); CR-FE-N' + REF117 'J-O Andersson, TRITA-MAC 323 (1986); C-CR-FE-MO' + REF111 'J-O Andersson, CALPHAD Vol 7, (1983), p 305-315 (parameters + revised + 1986 due to new decription of V) TRITA 0201 (1982); FE-V' + ! + diff --git a/TQ3lib-clean/F90/test5/TQ5-crfemob.F90 b/TQ3lib-clean/F90/test5/TQ5-crfemob.F90 new file mode 100644 index 0000000..f00225c --- /dev/null +++ b/TQ3lib-clean/F90/test5/TQ5-crfemob.F90 @@ -0,0 +1,169 @@ +! +! TQ test program 5 calculating mobilites in Cr-Fe +! +program octq5 +! + use liboctq +! + implicit none +! maxel and maxph defined in pmod package +! integer, parameter :: maxel=10,maxph=20 + integer n,n1,n2,n3,n4,ip,cnum(maxel+3),mm,m2,nsel,lokres + integer stable1,ll,kk,nlat,nlatc(10),conlista(100) + character filename*60,phnames(maxph)*24 + character condition*60,line*80,statevar*60,quest*60,ch1*1 + character target*60,phcsname*36,selel(maxel)*2 + double precision value,dummy,tp(2),mel(maxel) + double precision xf(maxel),pxf(10*maxph),npf(maxph),mu(maxel) + double precision yfr(100),sites(10),extra(5) +! with 20 constituents dimension of d2gdy2 is 20*(20+1)/2, upper triangle + double precision gtp(6),dgdy(20),d2gdydt(20),d2gdydp(20),d2gdy2(210) + double precision d2gmat(20,20) + type(gtp_equilibrium_data), pointer :: ceq +! +! initiate + call tqini(n,ceq) + if(gx%bmperr.ne.0) goto 1000 +! write(*,*)'step 1 OK: ',ceq%eqname +! +! read data for Cr and Fe from larger database file + filename='crfe+mob ' +! element names MUST be in UPPER CASE + nsel=2 + selel(1)='CR' + selel(2)='FE' + call tqrpfil(filename,nsel,selel,ceq) + if(gx%bmperr.ne.0) goto 1000 +! write(*,*)'step 2A OK' +! write(*,*)'test ceq: ',ceq%complist(1)%mass +! write(*,*)'step 2B OK' +! tqrpfil also enters the number of elements in nel and the element names +! in cnam and the number of phases in ntup and all phase tuples in phcs +! + write(*,*) + write(*,110) +110 format('Example showing calculating other properties like mobilities'/& + 'These are the BCC phase parameters in the TDB file:'/& + 'PARAMETER G(BCC_A2,CR:VA;0) 298.15 +GHSERCR+GPCRBCC; 6000 N REF283 !'/& + 'PARAMETER TC(BCC_A2,CR:VA;0) 298.15 -311.5; 6000 N REF281 !'/& + 'PARAMETER BMAG(BCC_A2,CR:VA;0) 298.15 -.01; 6000 N REF281 !'/& + 'PARAMETER MQ&FE#1(BCC_A2,CR:VA;0) 298.15 +1E-13+1E-17*T; 6000 N BOSSE !'/& + 'PARAMETER MQ&CR#1(BCC_A2,CR:VA;0) 298.15 +1E-09+1E-10*T; 6000 N BOSSE !'/& + 'PARAMETER G(BCC_A2,FE:VA;0) 298.15 +GHSERFE+GPFEBCC; 6000 N REF283 !'/& + 'PARAMETER TC(BCC_A2,FE:VA;0) 298.15 +1043; 6000 N REF281 !'/& + 'PARAMETER BMAG(BCC_A2,FE:VA;0) 298.15 +2.22; 6000 N REF281 !'/& + 'PARAMETER MQ&FE#1(BCC_A2,FE:VA;0) 298.15 +1E-12+1E-15*T; 6000 N BOSSE !'/& + 'PARAMETER MQ&CR#1(BCC_A2,FE:VA;0) 298.15 +1E-08+1E-10*T; 6000 N BOSSE !'/& + 'PARAMETER G(BCC_A2,CR,FE:VA;0) 298.15 +20500-9.68*T; 6000 N REF107 !'/& + 'PARAMETER TC(BCC_A2,CR,FE:VA;0) 298.15 +1650; 6000 N REF107 !'/& + 'PARAMETER TC(BCC_A2,CR,FE:VA;1) 298.15 +550; 6000 N REF107 !'/& + 'PARAMETER BMAG(BCC_A2,CR,FE:VA;0) 298.15 -0.85; 6000 N REF107 !'/) +! This stores the phase names in the array phnames +! write(*,*)'test ceq: ',ceq%eqname + do n=1,ntup + call tqgpn(n,phnames(n),ceq) + if(gx%bmperr.ne.0) goto 1000 + enddo +! write(*,*)'step 3A OK' +! write(*,*)'test ceq: ',ceq%eqname +! +! list elements and phases + write(*,10)nel,(cnam(n)(1:2),n=1,nel) +10 format(/'System with ',i2,' elements: ',10(a,', ')) + write(*,20)ntup,(phnames(n)(1:len_trim(phnames(n))),n=1,ntup) +20 format('and ',i3,' phases: ',6(' ',a,',')) +! +! set values of temperature and pressure + tp(1)=1.2D3 + tp(2)=1.0D5 +! set value of element 1 (Cr) + xf(1)=0.3D0 +! +! ------------------------------------- +! set conditions +! write(*,*)'step 3B OK' + n1=0 + n2=0 + condition='T' + call tqsetc(condition,n1,n2,tp(1),cnum(1),ceq) + if(gx%bmperr.ne.0) goto 1000 +! write(*,*)'step 3C OK' + condition='P' + call tqsetc(condition,n1,n2,tp(2),cnum(2),ceq) + if(gx%bmperr.ne.0) goto 1000 + condition='N' + call tqsetc(condition,n1,n2,one,cnum(3),ceq) + if(gx%bmperr.ne.0) goto 1000 +! write(*,*)'step 4A OK' +! Mole fraction of first element + condition='X' + n=1 + call tqsetc(condition,n,n2,xf(1),cnum(4),ceq) + if(gx%bmperr.ne.0) goto 1000 +! write(*,*)'step 4B OK' +! +! calculate the equilibria +! n1=0 means call grid minimizer + target=' ' + n1=0 + n2=0 + call tqce(target,n1,n2,value,ceq) + if(gx%bmperr.ne.0) then + write(*,310)gx%bmperr,bmperrmess(gx%bmperr) +310 format('Calculation failed, error code: ',i5/a) + goto 1000 + else + write(*,320) +320 format(/'Successful calculation') + endif +! write(*,*)'step 5 OK: ',ceq%eqname +! +!------------------------------------------------ +! Up to here the same as TQ4, now extract mobilities +! phase tuple 2 is BCC + stable1=2 + call tqcph2(stable1,n1,n2,lokres,ceq) + if(gx%bmperr.ne.0) goto 1000 + write(*,*) + write(*,605)ceq%phase_varres(lokres)%listprop(1)-1,& + ceq%phase_varres(lokres)%gval(1,1) +605 format('List of ',i3,' properties calculated:'/& + 'listprop index Property Value'/& + ' 1 G/RT ',1pe21.8) + do mm=2,ceq%phase_varres(lokres)%listprop(1)-1 + write(*,610)mm,ceq%phase_varres(lokres)%listprop(mm),& + ceq%phase_varres(lokres)%gval(1,mm) +610 format(i9,i11,5x,1pe20.8) + enddo + write(*,650) +! +650 format(/'Properties are defined in gtp3A.F90, subroutine init_gtp'/& + 'Property meaning'/' 1 Gibbs energy'/& + ' 2 combined Curie/Neel T (TC)'/& + ' 3 Avr Bohr magneton number (BMAGN)'/& + ' 4 Curie T (CTA)'/' 5 Neel T (NTA)'/& + ' 6xx individual Bohr magneton number (IBM)'/& + ' 7 Debye/Einstein T (THET)'/& + ' 8xx mobility (MQ)'/& + ' 9 resistivity (RHO)'/' and some more'/& + 'They are listed by the command "list model_param_id" in ocmon'//& + 'For properties with xx the xx is the component number'/& + 'In such parameters use & between ID and component like MQ&FE(...)'/) + write(*,*)'Test finished' +! +!-------------------------------------------------------------------- +! end of program, possible error messages +1000 continue + if(gx%bmperr.ne.0) then + if(gx%bmperr.ge.4000 .and. gx%bmperr.le.4220) then + write(*,1010)gx%bmperr,bmperrmess(gx%bmperr) +1010 format(' *** Error ',i5/a) + else + write(*,1020)gx%bmperr +1020 format(' *** Error ',i5/'Unknown reason') + endif + endif + write(*,*) + write(*,*)'Auf wiedersehen' +end program octq5 + diff --git a/TQ3lib-clean/F90/test5/crfe+mob.TDB b/TQ3lib-clean/F90/test5/crfe+mob.TDB new file mode 100644 index 0000000..05ec15b --- /dev/null +++ b/TQ3lib-clean/F90/test5/crfe+mob.TDB @@ -0,0 +1,214 @@ +$ Database file written by Open Calphad 2015-05-25 + +ELEMENT /- Electron_gas 0.0000E+00 0.0000E+00 0.0000E+00 ! +ELEMENT VA Vaccum 0.0000E+00 0.0000E+00 0.0000E+00 ! +ELEMENT CR CC_A2 5.1996E+01 4.0500E+03 2.3560E+01 ! +ELEMENT FE CC_A2 5.5847E+01 4.4890E+03 2.7280E+01 ! + +$ ================= + + +$ ================= + +FUNCTION RTLNP 10 8.31451*R*LN(1.0D-5*P); 20000 N ! +FUNCTION GHSERCR 298.15 -8856.94+157.48*T-26.908*T*LN(+T)+.00189435*T**2 + -1.47721E-06*T**3+139250*T**(-1); 2180 Y -34869.344+344.18*T + -50*T*LN(+T)-2.88526E+32*T**(-9); 6000 N ! +FUNCTION GPCRLIQ 298.15 +YCRLIQ*EXP(+ZCRLIQ); 6000 N ! +FUNCTION GFELIQ 298.15 +12040.17-6.55843*T-3.6751551E-21*T**7+GHSERFE; 1811 + Y -10839.7+291.302*T-46*T*LN(+T); 6000 N ! +FUNCTION GPFELIQ 298.15 +YFELIQ*EXP(+ZFELIQ); 6000 N ! +FUNCTION GPCRBCC 298.15 +YCRBCC*EXP(+ZCRBCC); 6000 N ! +FUNCTION GHSERFE 298.15 +1225.7+124.134*T-23.5143*T*LN(+T)-.00439752*T**2 + -5.8927E-08*T**3+77359*T**(-1); 1811 Y -25383.581+299.31255*T + -46*T*LN(+T)+2.29603E+31*T**(-9); 6000 N ! +FUNCTION GPFEBCC 298.15 +YFEBCC*EXP(+ZFEBCC); 6000 N ! +FUNCTION GCRFCC 298.15 +7284+0.163*T+GHSERCR; 6000 N ! +FUNCTION GFEFCC 298.15 -1462.4+8.282*T-1.15*T*LN(+T)+.00064*T**2+GHSERFE; + 1811 Y -27098.266+300.25256*T-46*T*LN(+T)+2.78854E+31*T**(-9); 6000 N + ! +FUNCTION GPFEFCC 298.15 +YFEFCC*EXP(+ZFEFCC); 6000 N ! +FUNCTION GPFEHCP 298.15 +YFEHCP*EXP(+ZFEHCP); 6000 N ! +FUNCTION GPSIG1 298.15 +.000109*P; 6000 N ! +FUNCTION GPSIG2 298.15 +.0001117*P; 6000 N ! +FUNCTION YCRLIQ 298.15 +VCRLIQ*EXP(-ECRLIQ); 6000 N ! +FUNCTION ZCRLIQ 298.15 +LN(+XCRLIQ); 6000 N ! +FUNCTION YFELIQ 298.15 +VFELIQ*EXP(-EFELIQ); 6000 N ! +FUNCTION ZFELIQ 298.15 +LN(+XFELIQ); 6000 N ! +FUNCTION YCRBCC 298.15 +VCRBCC*EXP(-ECRBCC); 6000 N ! +FUNCTION ZCRBCC 298.15 +LN(+XCRBCC); 6000 N ! +FUNCTION YFEBCC 298.15 +VFEBCC*EXP(-EFEBCC); 6000 N ! +FUNCTION ZFEBCC 298.15 +LN(+XFEBCC); 6000 N ! +FUNCTION YFEFCC 298.15 +VFEFCC*EXP(-EFEFCC); 6000 N ! +FUNCTION ZFEFCC 298.15 +LN(+XFEFCC); 6000 N ! +FUNCTION YFEHCP 298.15 +VFEHCP*EXP(-EFEHCP); 6000 N ! +FUNCTION ZFEHCP 298.15 +LN(+XFEHCP); 6000 N ! +FUNCTION VCRLIQ 298.15 +7.653E-06*EXP(+ACRLIQ); 6000 N ! +FUNCTION ECRLIQ 298.15 +LN(+CCRLIQ); 6000 N ! +FUNCTION XCRLIQ 298.15 +EXP(+0.8*DCRLIQ)-1; 6000 N ! +FUNCTION VFELIQ 298.15 +6.46677E-06*EXP(+AFELIQ); 6000 N ! +FUNCTION EFELIQ 298.15 +LN(+CFELIQ); 6000 N ! +FUNCTION XFELIQ 298.15 +EXP(+0.8484467*DFELIQ)-1; 6000 N ! +FUNCTION VCRBCC 298.15 +7.188E-06*EXP(+ACRBCC); 6000 N ! +FUNCTION ECRBCC 298.15 +LN(+CCRBCC); 6000 N ! +FUNCTION XCRBCC 298.15 +EXP(+0.8*DCRBCC)-1; 6000 N ! +FUNCTION VFEBCC 298.15 +7.042095E-06*EXP(+AFEBCC); 6000 N ! +FUNCTION EFEBCC 298.15 +LN(+CFEBCC); 6000 N ! +FUNCTION XFEBCC 298.15 +EXP(+0.7874195*DFEBCC)-1; 6000 N ! +FUNCTION XFEFCC 298.15 +EXP(+0.8064454*DFEFCC)-1; 6000 N ! +FUNCTION VFEFCC 298.15 +6.688726E-06*EXP(+AFEFCC); 6000 N ! +FUNCTION EFEFCC 298.15 +LN(+CFEFCC); 6000 N ! +FUNCTION VFEHCP 298.15 +6.59121E-06*EXP(+AFEHCP); 6000 N ! +FUNCTION EFEHCP 298.15 +LN(+CFEHCP); 6000 N ! +FUNCTION XFEHCP 298.15 +EXP(+0.8064454*DFEHCP)-1; 6000 N ! +FUNCTION ACRLIQ 298.15 +1.7E-05*T+9.2E-09*T**2; 6000 N ! +FUNCTION CCRLIQ 298.15 +3.72E-11; 6000 N ! +FUNCTION DCRLIQ 298.15 +LN(+BCRLIQ); 6000 N ! +FUNCTION AFELIQ 298.15 +.0001135*T; 6000 N ! +FUNCTION CFELIQ 298.15 +4.22534787E-12+2.71569924E-14*T; 6000 N ! +FUNCTION DFELIQ 298.15 +LN(+BFELIQ); 6000 N ! +FUNCTION ACRBCC 298.15 +1.7E-05*T+9.2E-09*T**2; 6000 N ! +FUNCTION CCRBCC 298.15 +2.08E-11; 6000 N ! +FUNCTION DCRBCC 298.15 +LN(+BCRBCC); 6000 N ! +FUNCTION AFEBCC 298.15 +2.3987E-05*T+1.2845E-08*T**2; 6000 N ! +FUNCTION CFEBCC 298.15 +2.20949565E-11+2.41329523E-16*T; 6000 N ! +FUNCTION DFEBCC 298.15 +LN(+BFEBCC); 6000 N ! +FUNCTION CFEFCC 298.15 +2.62285341E-11+2.71455808E-16*T; 6000 N ! +FUNCTION DFEFCC 298.15 +LN(+BFEFCC); 6000 N ! +FUNCTION AFEFCC 298.15 +7.3097E-05*T; 6000 N ! +FUNCTION AFEHCP 298.15 +7.3646E-05*T; 6000 N ! +FUNCTION CFEHCP 298.15 +2.62285341E-11+2.71455808E-16*T; 6000 N ! +FUNCTION DFEHCP 298.15 +LN(+BFEHCP); 6000 N ! +FUNCTION BCRLIQ 298.15 1+4.65E-11*P; 6000 N ! +FUNCTION BFELIQ 298.15 1+4.98009787E-12*P+3.20078924E-14*T*P; 6000 N ! +FUNCTION BCRBCC 298.15 1+2.6E-11*P; 6000 N ! +FUNCTION BFEBCC 298.15 1+2.80599565E-11*P+3.06481523E-16*T*P; 6000 N ! +FUNCTION BFEFCC 298.15 1+3.25236341E-11*P+3.36607808E-16*T*P; 6000 N ! +FUNCTION BFEHCP 298.15 1+3.25236341E-11*P+3.36607808E-16*T*P; 6000 N ! + +$ ================= + + +TYPE_DEFINITION % SEQ * ! +DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! +DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! + + +$ ================= + + + PHASE LIQUID:L % 1 1.000 ! + CONSTITUENT LIQUID:L :CR FE:! + PARAMETER G(LIQUID,CR;0) 298.15 +24339.955-11.420225*T+2.37615E-21*T**7 + +GHSERCR+GPCRLIQ; 2180 Y +18409.36-8.563683*T+2.88526E+32*T**(-9) + +GHSERCR+GPCRLIQ; 6000 N REF283 ! + PARAMETER G(LIQUID,FE;0) 298.15 +GFELIQ+GPFELIQ; 6000 N REF283 ! + PARAMETER G(LIQUID,CR,FE;0) 298.15 -14550+6.65*T; 6000 N REF107 ! + + TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1 0.4000! + PHASE BCC_A2 %& 2 1.000 3.000 ! + CONSTITUENT BCC_A2 :CR FE: VA:! + PARAMETER G(BCC_A2,CR:VA;0) 298.15 +GHSERCR+GPCRBCC; 6000 N REF283 ! + PARAMETER TC(BCC_A2,CR:VA;0) 298.15 -311.5; 6000 N REF281 ! + PARAMETER BMAG(BCC_A2,CR:VA;0) 298.15 -.01; 6000 N REF281 ! + PARAMETER MQ&FE#1(BCC_A2,CR:VA;0) 298.15 +1E-13+1E-17*T; 6000 N BOSSE ! + PARAMETER MQ&CR#1(BCC_A2,CR:VA;0) 298.15 +1E-09+1E-10*T; 6000 N BOSSE ! + PARAMETER G(BCC_A2,FE:VA;0) 298.15 +GHSERFE+GPFEBCC; 6000 N REF283 ! + PARAMETER TC(BCC_A2,FE:VA;0) 298.15 +1043; 6000 N REF281 ! + PARAMETER BMAG(BCC_A2,FE:VA;0) 298.15 +2.22; 6000 N REF281 ! + PARAMETER MQ&FE#1(BCC_A2,FE:VA;0) 298.15 +1E-12+1E-15*T; 6000 N BOSSE ! + PARAMETER MQ&CR#1(BCC_A2,FE:VA;0) 298.15 +1E-08+1E-10*T; 6000 N BOSSE ! + PARAMETER G(BCC_A2,CR,FE:VA;0) 298.15 +20500-9.68*T; 6000 N REF107 ! + PARAMETER TC(BCC_A2,CR,FE:VA;0) 298.15 +1650; 6000 N REF107 ! + PARAMETER TC(BCC_A2,CR,FE:VA;1) 298.15 +550; 6000 N REF107 ! + PARAMETER BMAG(BCC_A2,CR,FE:VA;0) 298.15 -0.85; 6000 N REF107 ! + + TYPE_DEFINITION ' GES A_P_D CBCC_A12 MAGNETIC -3 0.2800! + PHASE CBCC_A12 %' 2 1.000 1.000 ! + CONSTITUENT CBCC_A12 :CR FE: VA:! + PARAMETER G(CBCC_A12,CR:VA;0) 298.15 +11087+2.7196*T+GHSERCR; 6000 N + REF283 ! + PARAMETER G(CBCC_A12,FE:VA;0) 298.15 +4745+GHSERFE; 6000 N REF283 ! + + PHASE CHI_A12 % 3 24.000 10.000 24.000 ! + CONSTITUENT CHI_A12 :CR FE: CR: CR FE:! + PARAMETER G(CHI_A12,CR:CR:CR;0) 298.15 +48*GCRFCC+10*GHSERCR+109000 + +123*T; 6000 N REF213 ! + PARAMETER G(CHI_A12,CR:CR:FE;0) 298.15 +24*GCRFCC+10*GHSERCR+24*GFEFCC + +500000; 6000 N REF213 ! + PARAMETER G(CHI_A12,FE:CR:CR;0) 298.15 +24*GFEFCC+10*GHSERCR+24*GCRFCC + +18300-100*T; 6000 N REF115 ! + PARAMETER G(CHI_A12,FE:CR:FE;0) 298.15 +48*GFEFCC+10*GHSERCR+57300 + -100*T; 6000 N REF115 ! + + PHASE CR3SI % 2 3.000 1.000 ! + CONSTITUENT CR3SI :CR: CR:! + PARAMETER G(CR3SI,CR:CR;0) 298.15 +17008.82+4*T+4*GHSERCR; 6000 N REF90 + ! + + PHASE CRSI2 % 2 1.000 2.000 ! + CONSTITUENT CRSI2 :CR: CR:! + PARAMETER G(CRSI2,CR:CR;0) 298.15 +10000+10*T+3*GHSERCR; 6000 N REF90 ! + + PHASE CUB_A13 % 2 1.000 1.000 ! + CONSTITUENT CUB_A13 :CR FE: VA:! + PARAMETER G(CUB_A13,CR:VA;0) 298.15 +15899+0.6276*T+GHSERCR; 6000 N + REF283 ! + PARAMETER G(CUB_A13,FE:VA;0) 298.15 +3745+GHSERFE; 6000 N REF283 ! + + TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3 0.2800! + PHASE FCC_A1 %( 2 1.000 1.000 ! + CONSTITUENT FCC_A1 :CR FE: VA:! + PARAMETER G(FCC_A1,CR:VA;0) 298.15 +GCRFCC+GPCRBCC; 6000 N REF281 ! + PARAMETER TC(FCC_A1,CR:VA;0) 298.15 -1109; 6000 N REF281 ! + PARAMETER BMAG(FCC_A1,CR:VA;0) 298.15 -2.46; 6000 N REF281 ! + PARAMETER G(FCC_A1,FE:VA;0) 298.15 +GFEFCC+GPFEFCC; 6000 N REF283 ! + PARAMETER TC(FCC_A1,FE:VA;0) 298.15 -201; 6000 N REF281 ! + PARAMETER BMAG(FCC_A1,FE:VA;0) 298.15 -2.1; 6000 N REF281 ! + PARAMETER G(FCC_A1,CR,FE:VA;0) 298.15 +10833-7.477*T; 6000 N REF107 ! + PARAMETER G(FCC_A1,CR,FE:VA;1) 298.15 +1410; 6000 N REF107 ! + + PHASE FE4N % 2 4.000 1.000 ! + CONSTITUENT FE4N :FE: VA:! + PARAMETER G(FE4N,FE:VA;0) 298.15 +4*GFEFCC+10; 6000 N REF319 ! + + TYPE_DEFINITION ) GES A_P_D HCP_A3 MAGNETIC -3 0.2800! + PHASE HCP_A3 %) 2 1.000 0.500 ! + CONSTITUENT HCP_A3 :CR FE: VA:! + PARAMETER G(HCP_A3,CR:VA;0) 298.15 +4438+GHSERCR+GPCRBCC; 6000 N REF283 + ! + PARAMETER TC(HCP_A3,CR:VA;0) 298.15 -1109; 6000 N REF281 ! + PARAMETER BMAG(HCP_A3,CR:VA;0) 298.15 -2.46; 6000 N REF281 ! + PARAMETER G(HCP_A3,FE:VA;0) 298.15 -3705.78+12.591*T-1.15*T*LN(+T) + +.00064*T**2+GHSERFE+GPFEHCP; 1811 Y -3957.199+5.24951*T + +4.9251E+30*T**(-9)+GHSERFE+GPFEHCP; 6000 N REF283 ! + PARAMETER G(HCP_A3,CR,FE:VA;0) 298.15 +10833-7.477*T; 6000 N REF126 ! + + PHASE SIGMA % 3 8.000 4.000 18.000 ! + CONSTITUENT SIGMA :FE: CR: CR FE:! + PARAMETER G(SIGMA,FE:CR:CR;0) 298.15 +8*GFEFCC+22*GHSERCR+92300-95.96*T + +GPSIG1; 6000 N REF107 ! + PARAMETER G(SIGMA,FE:CR:FE;0) 298.15 +8*GFEFCC+4*GHSERCR + +18*GHSERFE+117300-95.96*T+GPSIG2; 6000 N REF107 ! + +$ ================= + + + LIST_OF_REFERENCES + NUMBER SOURCE +REF283 'Alan Dinsdale, SGTE Data for Pure Elements, Calphad Vol + 15(1991) p 317-425, also in NPL Report DMA(A)195 Rev. August + 1990' +REF107 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 + TRITA 0270 (1986); CR-FE' +REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report + DMA(A)195 September 1989' +REF213 'P. Gustafson, TRITA-MAC 342, (1987); CR-FE-W' +REF115 'J-O Andersson, Met Trans A, Vol 19A, (1988) p 1385-1394 + TRITA 0322 (1986); CR-FE-MO' +REF90 'I Ansara, unpublished work (1991); Cr-Si' +REF319 'H. Du and M. Hillert, revision; C-Fe-N' +REF126 'K. Frisk, Metall. Trans. Vol 21A (1990) p 2477-2488, TRITA + 0409 (1989); CR-FE-N' +BOSSE 'B Sundman, fictitious mobility data' +! diff --git a/TQ3lib-clean/F90/test5/linktqex5.txt b/TQ3lib-clean/F90/test5/linktqex5.txt new file mode 100644 index 0000000..03fbcc4 --- /dev/null +++ b/TQ3lib-clean/F90/test5/linktqex5.txt @@ -0,0 +1,2 @@ +gfortran -o tqex5 TQ5-crfemob.F90 liboctq.o liboceq.a + diff --git a/TQ3lib-clean/F90/test5/readme.txt b/TQ3lib-clean/F90/test5/readme.txt new file mode 100644 index 0000000..ad52ed6 --- /dev/null +++ b/TQ3lib-clean/F90/test5/readme.txt @@ -0,0 +1,35 @@ +This test example shows how to extract mobility data + +in the TDB file crfe+mob.data we have mobility data for BCC + + TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1 0.4000! + PHASE BCC_A2 %& 2 1.000 3.000 ! + CONSTITUENT BCC_A2 :CR FE: VA:! + PARAMETER G(BCC_A2,CR:VA;0) 298.15 +GHSERCR+GPCRBCC; 6000 N REF283 ! + PARAMETER TC(BCC_A2,CR:VA;0) 298.15 -311.5; 6000 N REF281 ! + PARAMETER BMAG(BCC_A2,CR:VA;0) 298.15 -.01; 6000 N REF281 ! + PARAMETER MQ&FE#1(BCC_A2,CR:VA;0) 298.15 +1E-13+1E-17*T; 6000 N BOSSE ! + PARAMETER MQ&CR#1(BCC_A2,CR:VA;0) 298.15 +1E-09+1E-10*T; 6000 N BOSSE ! + PARAMETER G(BCC_A2,FE:VA;0) 298.15 +GHSERFE+GPFEBCC; 6000 N REF283 ! + PARAMETER TC(BCC_A2,FE:VA;0) 298.15 +1043; 6000 N REF281 ! + PARAMETER BMAG(BCC_A2,FE:VA;0) 298.15 +2.22; 6000 N REF281 ! + PARAMETER MQ&FE#1(BCC_A2,FE:VA;0) 298.15 +1E-12+1E-15*T; 6000 N BOSSE ! + PARAMETER MQ&CR#1(BCC_A2,FE:VA;0) 298.15 +1E-08+1E-10*T; 6000 N BOSSE ! + PARAMETER G(BCC_A2,CR,FE:VA;0) 298.15 +20500-9.68*T; 6000 N REF107 ! + PARAMETER TC(BCC_A2,CR,FE:VA;0) 298.15 +1650; 6000 N REF107 ! + PARAMETER TC(BCC_A2,CR,FE:VA;1) 298.15 +550; 6000 N REF107 ! + PARAMETER BMAG(BCC_A2,CR,FE:VA;0) 298.15 -0.85; 6000 N REF107 ! + +where +MQ&FE(BCC,FE:VA) is the tracer mobility(?) of Fe in pure Fe +MQ&FE(BCC,CE:VA) is the infinite dilute mobility(?) of Fe in pure Cr +MQ&CR(BCC,FE:VA) is the infinite dilute mobility(?) of Cr in pure Fe +MQ&CR(BCC,CR:VA) is the tracer mobility(?) of Cr in pure Fe + +We calculate an equilibrium at x(cr)=.3 and t?1200 (pure bcc) +and then extract the mobilites using tqcph2 + +Note we must use the array listprop to detect which property that is +mobilities, we have also two other properties, the Curie T and Bohr +mangeton numbers + diff --git a/TQ3lib-clean/isoC-Teslos/FENI.TDB b/TQ3lib-clean/isoC-Teslos/FENI.TDB new file mode 100644 index 0000000..c3133fa --- /dev/null +++ b/TQ3lib-clean/isoC-Teslos/FENI.TDB @@ -0,0 +1,105 @@ +$ Database file written 2014- 1-15 +$ From database: SSOL2 + ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! + ELEMENT NI FCC_A1 5.8690E+01 4.7870E+03 2.9796E+01! + + + FUNCTION GFELIQ 298.15 +12040.17-6.55843*T-3.6751551E-21*T**7 + +GHSERFE#; 1.81100E+03 Y + -10839.7+291.302*T-46*T*LN(T); 6000 N ! + FUNCTION GHSERFE 298.15 +1225.7+124.134*T-23.5143*T*LN(T) + -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y + -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6000 N ! + FUNCTION GNIBCC 298.15 +8715.084-3.556*T+GHSERNI#; 6000 N ! + FUNCTION GFEFCC 298.15 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 + +GHSERFE#; 1.81100E+03 Y + -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6000 N ! + FUNCTION GHSERNI 298.15 -5179.159+117.854*T-22.096*T*LN(T) + -.0048407*T**2; 1.72800E+03 Y + -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3.00000E+03 N ! + FUNCTION GPFELIQ 298.15 7E-6*P; 6000 N ! + FUNCTION GPFEFCC 298.15 5E-6*P; 6000 N ! + FUNCTION GPFEBCC 298.15 6E-6*P; 6000 N ! + FUNCTION GPNILIQ 298.15 8E-6*P; 6000 N ! + FUNCTION GPNIFCC 298.15 6E-6*P; 6000 N ! + FUNCTION GPNIBCC 298.15 7E-6*P; 6000 N ! +$ this is 1/RT + FUNCTION IQRT 298.15 0.12027167*T**(-1); 6000 N ! + + TYPE_DEFINITION % SEQ *! + DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! + DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! + + + PHASE LIQUID:L % 1 1.0 ! + CONSTITUENT LIQUID:L :FE,NI : ! + + PARAMETER G(LIQUID,FE;0) 298.15 +GFELIQ#+GPFELIQ#; 6000 N REF283 ! + PARAMETER G(LIQUID,NI;0) 298.15 +11235.527+108.457*T + -22.096*T*LN(T)-.0048407*T**2-3.82318E-21*T**7+GPNILIQ; 1.72800E+03 Y + -9549.775+268.598*T-43.1*T*LN(T)+GPNILIQ; 3.00000E+03 N REF283 ! + PARAMETER G(LIQUID,FE,NI;0) 298.15 -18378.86+6.03912*T; 6000 N REF158 ! + PARAMETER G(LIQUID,FE,NI;1) 298.15 +9228.1-3.54642*T; 6000 N REF158 ! +$ LN(mobilities) + PARAMETER MQ&FE(LIQUID,FE;0) 298.15 -10000*IQRT-18; 6000 N BOS ! + PARAMETER MQ&FE(LIQUID,NI;0) 298.15 -12000*IQRT-19; 6000 N BOS ! + PARAMETER MQ&NI(LIQUID,NI;0) 298.15 -11000*IQRT-18; 6000 N BOS ! + PARAMETER MQ&NI(LIQUID,FE;0) 298.15 -13000*IQRT-19; 6000 N BOS ! + + + TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! +$ PHASE BCC_A2 %& 2 1 3 ! +$ CONSTITUENT BCC_A2 :FE%,NI : VA% : ! + + PARAMETER G(BCC_A2,FE:VA;0) 298.15 +GHSERFE#+GPFEBCC#; 6000 N REF283 ! + PARAMETER TC(BCC_A2,FE:VA;0) 298.15 1043; 6000 N REF281 ! + PARAMETER BMAGN(BCC_A2,FE:VA;0) 298.15 2.22; 6000 N REF281 ! + PARAMETER G(BCC_A2,NI:VA;0) 298.15 +GNIBCC#+GPNIBCC; 3000 N REF283 ! + PARAMETER TC(BCC_A2,NI:VA;0) 298.15 575; 6000 N REF281 ! + PARAMETER BMAGN(BCC_A2,NI:VA;0) 298.15 .85; 6000 N REF281 ! + PARAMETER G(BCC_A2,FE,NI:VA;0) 298.15 -956.63-1.28726*T; 6000 N REF158 ! + PARAMETER G(BCC_A2,FE,NI:VA;1) 298.15 +1789.03-1.92912*T; 6000 N REF158 ! +$ LN(mobilities) + PARAMETER MQ&FE(BCC_A2,FE:VA;0) 298.15 -20000*IQRT-24; 6000 N BOS ! + PARAMETER MQ&FE(BCC_A2,NI:VA;0) 298.15 -22000*IQRT-24; 6000 N BOS ! + PARAMETER MQ&NI(BCC_A2,NI:VA;0) 298.15 -25000*IQRT-25; 6000 N BOS ! + PARAMETER MQ&NI(BCC_A2,FE:VA;0) 298.15 -28000*IQRT-25; 6000 N BOS ! + + TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! + PHASE FCC_A1 %' 2 1 1 ! + CONSTITUENT FCC_A1 :FE%,NI% : VA% : ! + + PARAMETER G(FCC_A1,FE:VA;0) 298.15 +GFEFCC#+GPFEFCC#; 6000 N REF283 ! + PARAMETER TC(FCC_A1,FE:VA;0) 298.15 -201; 6000 N REF281 ! + PARAMETER BMAGN(FCC_A1,FE:VA;0) 298.15 -2.1; 6000 N REF281 ! + PARAMETER G(FCC_A1,NI:VA;0) 298.15 +GHSERNI#+GPNIFCC; 3000 N REF283 ! + PARAMETER TC(FCC_A1,NI:VA;0) 298.15 633; 6000 N REF281 ! + PARAMETER BMAGN(FCC_A1,NI:VA;0) 298.15 .52; 6000 N REF281 ! + PARAMETER G(FCC_A1,FE,NI:VA;0) 298.15 -12054.355+3.27413*T; 6000 N REF158 ! + PARAMETER G(FCC_A1,FE,NI:VA;1) 298.15 +11082.1315-4.45077*T; 6000 N REF158 ! + PARAMETER G(FCC_A1,FE,NI:VA;2) 298.15 -725.805174; 6000 N REF158 ! + PARAMETER TC(FCC_A1,FE,NI:VA;0) 298.15 2133; 6000 N REF158 ! + PARAMETER TC(FCC_A1,FE,NI:VA;1) 298.15 -682; 6000 N REF158 ! + PARAMETER BMAGN(FCC_A1,FE,NI:VA;0) 298.15 9.55; 6000 N REF158 ! + PARAMETER BMAGN(FCC_A1,FE,NI:VA;1) 298.15 7.23; 6000 N REF158 ! + PARAMETER BMAGN(FCC_A1,FE,NI:VA;2) 298.15 5.93; 6000 N REF158 ! + PARAMETER BMAGN(FCC_A1,FE,NI:VA;3) 298.15 6.18; 6000 N REF158 ! +$ LN(mobilities) + PARAMETER MQ&FE(FCC_A1,FE:VA;0) 298.15 -30000*IQRT-30; 6000 N BOS ! + PARAMETER MQ&FE(FCC_A1,NI:VA;0) 298.15 -32000*IQRT-32; 6000 N BOS ! + PARAMETER MQ&NI(FCC_A1,NI:VA;0) 298.15 -33000*IQRT-32; 6000 N BOS ! + PARAMETER MQ&NI(FCC_A1,FE:VA;0) 298.15 -25000*IQRT-31; 6000 N BOS ! + + LIST_OF_REFERENCES + NUMBER SOURCE + REF283 'Alan Dinsdale, SGTE Data for Pure Elements, + Calphad Vol 15(1991) p 317-425, + also in NPL Report DMA(A)195 Rev. August 1990' + REF158 'A. Dinsdale, T. Chart, MTDS NPL, unpublished work (1986); FE-NI' + REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 + September 1989' + BOS 'Invented mobilities and molar volumes' + ! + diff --git a/TQ3lib-clean/isoC-Teslos/feni-tqiso.c b/TQ3lib-clean/isoC-Teslos/feni-tqiso.c new file mode 100644 index 0000000..0fe0d48 --- /dev/null +++ b/TQ3lib-clean/isoC-Teslos/feni-tqiso.c @@ -0,0 +1,151 @@ +#include "octqc.h" +#include +#include +#include +#define MAXEL 10 +#define MAXPH 10 + +extern void c_tqini(int, void **); +extern void c_tqrfil(char *, void **); +extern void c_tqgcom(int *, char[MAXEL][24], void **); +extern void c_tqrpfil(char *, int, char **, void **); +extern void c_tqgnp(int *, void **); +extern void c_tqgpn(int, char *, void **); +extern void c_tqgetv(char *, int, int, int *, double *, void **); +extern void examine_gtp_equilibrium_data(void *); +extern int c_ntup,c_nel,c_maxc; +extern char *c_cnam[]; +//extern void c_tqgnp(int, gtp_equilibrium_data **); + +int +main(int argc, char **argv) +{ + int i , k, n1, n2, n3, n4, nph, mm, ics, ip, phstable, + cnum [MAXEL + 3]; + void *ceq = 0; + //char **cmpname ; + char cmpname [MAXPH][24]; + char phnames [MAXPH][24]; + char target [60]; + char statevar [60]; + char quest [60]; + char condition [60]; + double one = 1.0; + double value , tp[2], dummy, mel[MAXEL], mf[MAXEL], volume; + double xf [MAXEL], pxf[10 * MAXPH], npf[MAXPH], mu[MAXEL]; + gtp_equilibrium_data *dceq; + //set some defaults + int n = 0; + char *filename = "FENI.TDB"; + char *selel[2] = {"FE", "NI"}; + + printf("\n*** Starting isoC test program for Fe-Ni \n\n"); + //initilize tq + c_tqini(n, &ceq); + c_tqrfil(filename, &ceq); + //c_tqrpfil(filename, nel, selel, &ceq); + //read database file + // examine_gtp_equilibrium_data(ceq); + + //find out about the system + // number of elements and their names + //c_tqgcom(&nel, cmpname, &ceq); + printf("System with %i elements: ", c_nel); + for (i = 0; i < c_nel; i++) + printf("%s, ",c_cnam[i]); + // number of phases and their names + //c_tqgnp(&nph, &ceq); + printf("\nand %i phases: ",c_ntup); + for (i = 1; i <= c_ntup; i++) { + c_tqgpn(i, phnames[i], &ceq); + printf(" %s,", phnames[i]); + } + //set default values + tp[0] = 2.0e3; + tp[1] = 1.0e5; + // this is the fraction of component 1! Fe + xf[1] = 0.3; + //for (i = 1; i <= c_nel; i++) + // xf[i] = 1.0 / (double)c_nel; + + // *************************************************************** + //ask for conditions + printf("\nGive conditions: \n"); + dummy = tp[0]; + + if (tp[0] < 1.0) { + printf("Temperature must be larger than 1K\n"); + tp[0] = 1.0; + } + dummy = tp[1]; + if (tp[1] < 1.0) { + printf("Pressure must be larger than 1Pa\n"); + tp[1] = 1.0; + } + for (i = 1; i <= c_nel - 1; i++) { + sprintf(quest, "Mole fraction of %s:", cmpname[i]); + dummy = xf[i]; + //call gparrd + if (xf[i] < 1.0e-6) { + printf("Fraction must be larger than 1.0E-6\n"); + xf[i] = 1.0e-6; + } + } + // *************************************************************** + //set conditions + n1 = 0; + n2 = 0; + strcpy(condition, "T"); + c_tqsetc(condition, n1, n2, tp[0], &(cnum[1]), &ceq); + strcpy(condition, "P"); + c_tqsetc(condition, n1, n2, tp[1], &(cnum[2]), &ceq); + strcpy(condition, "N"); + c_tqsetc(condition, n1, n2, one, &(cnum[3]), &ceq); + for (i = 1; i <= c_nel - 1; i++) { + strcpy(condition, "X"); + c_tqsetc(condition, i, n2, xf[i], &(cnum[3 + i]), &ceq); + } + // *************************************************************** + printf("\nConditions set: T= %1f, P= %1f, N= %1f", tp[0],tp[1],one); + printf("\nConditions set: x(fe)= %1f\n\n", xf[1]); + //calculate the equilibria + strcpy(target, " "); + n1 = 0; + n2 = 0; + + c_tqce(&target, n1, n2, &value, &ceq); + // *************************************************************** + //list some results + // amount of all phases, the number of phase tuples may have changed ... + printf("\nResults for %i phases:", c_ntup); + strcpy(statevar, "NP"); + n1 = -1; + n2 = 0; + n3 = sizeof(npf) / sizeof(npf[0]); + c_tqgetv(statevar, n1, n2, &n3, npf, &ceq); + // printf("Amount of %i phases: ", n3); + // for (i = 0; i < n3; i++) + // printf("%lf ", npf[i]); + + mm = 0; + for (i = 1; i <= c_ntup; i++) { + // if (npf[i] > 0.0) { + //the phase is stable if it + //has a positive amount...it can be stable with 0 + printf("\n\nPhase: %i, name %s, amount: %lf", i, phnames[i], npf[i-1]); + //composition of stable phase n2 = -1 means all fractions + strcpy(statevar, "X"); + n2 = -1; + //Use phase tupe index: i + n4 = sizeof(pxf)/sizeof(pxf[0]); + c_tqgetv(statevar, i, n2, &n4, pxf, &ceq); + printf(" mole fractions:"); + for (k = 0; k < n4; k++) + printf(" %s : %lf, ", c_cnam[k], pxf[k]); + //} + } + + printf("\n\n Finished! \n"); + + return 0; +} diff --git a/TQ3lib-clean/isoC-Teslos/liboctqisoc.F90 b/TQ3lib-clean/isoC-Teslos/liboctqisoc.F90 new file mode 100644 index 0000000..ccca0f8 --- /dev/null +++ b/TQ3lib-clean/isoC-Teslos/liboctqisoc.F90 @@ -0,0 +1,487 @@ +! +! Part of iso-C bining for OC TQlib from Teslos +! modified by Bo Sundman +! +MODULE cstr +! convert characters from Fortran to C and vice versa +contains + function c_to_f_string(s) result(str) + use iso_c_binding + implicit none + character(kind=c_char,len=1), intent(in) :: s(*) + character(len=:), allocatable :: str + integer i, nchars + i = 1 + do + if (s(i) == c_null_char) exit + i = i + 1 + end do + nchars = i - 1 ! Exclude null character from Fortran string + allocate(character(len=nchars) :: str) + str = transfer(s(1:nchars), str) + end function c_to_f_string + + subroutine f_to_c_string(fstring, cstr) + use iso_c_binding + implicit none + character(len=24) :: fstring + character(kind=c_char, len=1), intent(out) :: cstr(*) + integer i + do i = 1, len(fstring) + cstr(i) = fstring(i:i) + cstr(i+1) = c_null_char + end do + end subroutine f_to_c_string + +end module cstr + +module liboctqisoc +! +! OCTQlib with iso-C binding +! + use iso_c_binding + use cstr + use liboctq +! use general_thermodynamic_package + implicit none + + integer(c_int), bind(c) :: c_nel + integer(c_int), bind(c) :: c_maxc=20, c_maxp=100 + type(c_ptr), bind(c), dimension(maxc) :: c_cnam + character(len=25), dimension(maxc), target :: cnames + integer(c_int), bind(c) :: c_ntup + + TYPE, bind(c) :: c_gtp_equilibrium_data +! this contains all data specific to an equilibrium like conditions, +! status, constitution and calculated values of all phases etc +! Several equilibria may be calculated simultaneously in parallell threads +! so each equilibrium must be independent +! NOTE: the error code must be local to each equilibria!!!! +! During step and map these records with results are saved +! values of T and P, conditions etc. +! Values here are normally set by external conditions or calculated from model +! local list of components, phase_varres with amounts and constitution +! lists of element, species, phases and thermodynamic parameters are global +! tpval(1) is T, tpval(2) is P, rgas is R, rtn is R*T +! status: not used yet? +! multiuse: used for various things like direction in start equilibria +! eqno: sequential number assigned when created +! next: index of next equilibrium in a sequence during step/map calculation. +! eqname: name of equilibrium +! tpval: value of T and P +! rtn: value of R*T + integer(c_int) :: status,multiuse,eqno,next + character(c_char) :: eqname*24 + real(c_double) :: tpval(2),rtn +! svfunres: the values of state variable functions valid for this equilibrium + type(c_ptr) :: svfunres +! the experiments are used in assessments and stored like conditions +! lastcondition: link to condition list +! lastexperiment: link to experiment list + TYPE(c_ptr) :: lastcondition,lastexperiment +! components and conversion matrix from components to elements +! complist: array with components +! compstoi: stoichiometric matrix of compoents relative to elements +! invcompstoi: inverted stoichiometric matrix + TYPE(c_ptr) :: complist + real(c_double) :: compstoi + real(c_double) :: invcompstoi +! one record for each phase+composition set that can be calculated +! phase_varres: here all calculated data for the phase is stored + TYPE(c_ptr) :: phase_varres +! index to the tpfun_parres array is the same as in the global array tpres +! eq_tpres: here local calculated values of TP functions are stored + TYPE(c_ptr) :: eq_tpres +! current values of chemical potentials stored in component record but +! duplicated here for easy acces by application software + real(c_double) :: cmuval +! xconc: convergence criteria for constituent fractions and other things + real(c_double) :: xconv +! delta-G value for merging gridpoints in grid minimizer +! smaller value creates problem for test step3.BMM, MC and austenite merged + real(c_double) :: gmindif=-5.0D-2 +! maxiter: maximum number of iterations allowed + integer(c_int) :: maxiter +! this is to save a copy of the last calculated system matrix, needed +! to calculate dot derivatives, initiate to zero + integer(c_int) :: sysmatdim=0,nfixmu=0,nfixph=0 + integer(c_int) :: fixmu + integer(c_int) :: fixph + real(c_double) :: savesysmat + END TYPE c_gtp_equilibrium_data + +contains + +! functions + integer function c_noofcs(iph) bind(c, name='c_noofcs') + integer(c_int), value :: iph + c_noofcs = noofcs(iph) + return + end function c_noofcs + + subroutine examine_gtp_equilibrium_data(c_ceq) & + bind(c, name='examine_gtp_equilibrium_data') + type(c_ptr), intent(in), value :: c_ceq + type(gtp_equilibrium_data), pointer :: ceq + integer :: i,j + call c_f_pointer(c_ceq, ceq) + write(*,10) ceq%status, ceq%multiuse, ceq%eqno +10 format(/'gtp_equilibrium_data: status, multiuse, eqno, next'/, 3i4) + write(*,20) ceq%eqname +20 format(/'Name of equilibrium'/,a) + write(*,30) ceq%tpval, ceq%rtn +30 format(/'Value of T and P'/, 2f8.3, /'R*T'/, f8.4) + do i = 1, size(ceq%compstoi,1) + write(*,*) (ceq%compstoi(i,j), j=1,size(ceq%compstoi,2)) + end do + write(*,*) ceq%cmuval + write(*,*) ceq%xconv + write(*,*) ceq%gmindif + write(*,*) ceq%maxiter + write(*,*) ceq%sysmatdim, ceq%nfixmu, ceq%nfixph + write(*,*) ceq%fixmu, ceq%fixph, ceq%savesysmat + end subroutine examine_gtp_equilibrium_data + +!\begin{verbatim} + subroutine c_tqini(n, c_ceq) bind(c, name='c_tqini') + integer(c_int), intent(in) :: n + type(c_ptr), intent(out) :: c_ceq +!\end{verbatim} + type(gtp_equilibrium_data), pointer :: ceq + integer :: i1,i2 + + call tqini(n, ceq) + c_ceq = c_loc(ceq) + end subroutine c_tqini + +!\begin{verbatim} + subroutine c_tqrfil(filename,c_ceq) bind(c, name='c_tqrfil') + character(kind=c_char,len=1), intent(in) :: filename(*) + character(len=:), allocatable :: fstring + type(gtp_equilibrium_data), pointer :: ceq + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + integer :: i,j,l + character(kind=c_char, len=1),dimension(24), target :: f_pointers +! convert type(c_ptr) to fptr + call c_f_pointer(c_ceq, ceq) + fstring = c_to_f_string(filename) + call tqrfil(fstring, ceq) +! after tqrfil ntup variable is defined + c_ntup = ntup + c_nel = nel + do i = 1, nel + cnames(i) = trim(cnam(i)) // c_null_char + c_cnam(i) = c_loc(cnames(i)) + end do + c_ceq = c_loc(ceq) + end subroutine c_tqrfil + +!\begin{verbatim} + subroutine c_tqrpfil(filename,nel,c_selel,c_ceq) bind(c) + character(kind=c_char), intent(in) :: filename + integer(c_int), intent(in) :: nel + type(c_ptr), intent(in), dimension(nel), target :: c_selel + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + type(gtp_equilibrium_data), pointer :: ceq + character(len=:), allocatable :: fstring + character, pointer :: selel(:) + integer :: i + fstring = c_to_f_string(filename) + call c_f_pointer(c_ceq, ceq) +! convert the c type selel strings to f-selel strings +! note: additional character is for C terminated '\0' + do i = 1, nel + call c_f_pointer(c_selel(i), selel, [3]) + end do + call tqrpfil(fstring, nel,selel,ceq) + c_ceq = c_loc(ceq) + end subroutine c_tqrpfil + +!\begin{verbatim} + subroutine c_tqgcom(n,components,c_ceq) bind(c, name='c_tqgcom') +! get system components + integer(c_int), intent(inout) :: n + !character(kind=c_char, len=24), dimension(24), intent(out) :: c_components + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + integer, target :: nc + character(len=24) :: fcomponents(maxel) + character(kind=c_char, len=1), dimension(maxel*24) :: components + type(gtp_equilibrium_data), pointer :: ceq + integer :: i,j,l + call c_f_pointer(c_ceq, ceq) + call tqgcom(nc, fcomponents, ceq) +! convert the F components strings to C + l = len(fcomponents(1)) + do i = 1, nc + do j = 1, l + components((i-1)*l+j)(1:1) = fcomponents(i)(j:j) + end do +! null termination + components(i*l) = c_null_char + end do + c_ceq = c_loc(ceq) + n = nc + end subroutine c_tqgcom + +!\begin{verbatim} + subroutine c_tqgnp(n, c_ceq) bind(c, name='c_tqgnp') + integer(c_int), intent(inout) :: n + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + type(gtp_equilibrium_data), pointer :: ceq + call c_f_pointer(c_ceq, ceq) + call tqgnp(n, ceq) + c_ceq = c_loc(ceq) + end subroutine c_tqgnp + +!\begin{verbatim} + subroutine c_tqgpn(n,phasename, c_ceq) bind(c, name='c_tqgpn') +! get name of phase n, +! NOTE: n is phase number, not extended phase index + integer(c_int), intent(in), value :: n + character(kind=c_char, len=1), intent(inout) :: phasename(24) + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + type(gtp_equilibrium_data), pointer :: ceq + character(len=24) :: fstring + integer :: i + call c_f_pointer(c_ceq, ceq) +! fstring = c_to_f_string(phasename) + call tqgpn(n, fstring, ceq) +! copy the f-string to c-string and end with '\0' + do i=1,len(trim(fstring)) + phasename(i)(1:1) = fstring(i:i) + phasename(i+1)(1:1) = c_null_char + end do + c_ceq = c_loc(ceq) + end subroutine c_tqgpn + +!\begin{verbatim} + subroutine c_tqgpi(n,phasename,c_ceq) bind(c, name='c_tqgpi') +! get index of phase phasename + integer(c_int), intent(out) :: n + character(c_char), intent(in) :: phasename(24) + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + type(gtp_equilibrium_data), pointer :: ceq + character(len=24) :: fstring + call c_f_pointer(c_ceq, ceq) + fstring = c_to_f_string(phasename) + call tqgpi(n, fstring, ceq) + c_ceq = c_loc(ceq) + end subroutine c_tqgpi + +!\begin{verbatim} + subroutine c_tqgpcn(n, c, constituentname, c_ceq) bind(c, name='c_tqgpcn') +! get name of constitutent c in phase n + integer(c_int), intent(in) :: n ! phase number + integer(c_int), intent(in) :: c ! extended constituent index: +! 10*species_number + sublattice + character(c_char), intent(out) :: constituentname(24) + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + write(*,*) 'tqgpcn not implemented yet' + end subroutine c_tqgpcn + +!\begin{verbatim} + subroutine c_tqgpci(n,c, constituentname, c_ceq) bind(c, name='c_tqgpci') +! get index of constituent with name in phase n + integer(c_int), intent(in) :: n + integer(c_int), intent(out) :: c ! exit: extended constituent index: +! 10*species_number+sublattice + character(c_char), intent(in) :: constituentname(24) + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + type(gtp_equilibrium_data), pointer :: ceq + character(len=24) :: fstring + fstring = c_to_f_string(constituentname) + call c_f_pointer(c_ceq, ceq) + call tqgpci(n, c, fstring, ceq) + c_ceq = c_loc(ceq) + end subroutine c_tqgpci + +!\begin{verbatim} + subroutine c_tqgpcs(n, c, stoi, mass, c_ceq) bind(c, name='c_tqgpcs') +!get stoichiometry of constituent c in phase n +!? missing argument number of elements???? + integer(c_int), intent(in) :: n + integer(c_int), intent(in) :: c ! in: extended constituent index: +! 10*species_number + sublattice + real(c_double), intent(out) :: stoi(*) ! exit: stoichiometry of elements + real(c_double), intent(out) :: mass ! exit: total mass + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + type(gtp_equilibrium_data), pointer :: ceq + call c_f_pointer(c_ceq, ceq) + call tqgpcs(n,c,stoi,mass,ceq) + c_ceq=c_loc(ceq) + end subroutine c_tqgpcs + +!\begin{verbatim} + subroutine c_tqgccf(n1,n2,elnames,stoi,mass,c_ceq) +! get stoichiometry of component n1 +! n2 is number of elements ( dimension of elements and stoi ) + integer(c_int), intent(in) :: n1 ! in: component number + integer(c_int), intent(out) :: n2 ! exit: number of elements in component + character(c_char), intent(out) :: elnames(2) ! exit: element symbols + real(c_double), intent(out) :: stoi(*) ! exit: element stoichiometry + real(c_double), intent(out) :: mass ! exit: component mass +! (sum of element mass) + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + type(gtp_equilibrium_data), pointer :: ceq + call c_f_pointer(c_ceq, ceq) + call tqgccf(n1,n2,elnames,stoi, mass, ceq) + c_ceq = c_loc(ceq) + end subroutine c_tqgccf + +!\begin{verbatim} + subroutine c_tqgnpc(n,c,c_ceq) bind(c, name='c_tqgnpc') +! get number of constituents of phase n + integer(c_int), intent(in) :: n ! in: phase number + integer(c_int), intent(out) :: c ! exit: number of constituents + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + type(gtp_equilibrium_data), pointer :: ceq + call c_f_pointer(c_ceq,ceq) + call tqgnpc(n,c,ceq) + c_ceq = c_loc(ceq) + end subroutine c_tqgnpc + +!\begin{verbatim} + subroutine c_tqsetc(statvar, n1, n2, mvalue, cnum, c_ceq) & + bind(c, name='c_tqsetc') +! set condition +! stavar is state variable as text +! n1 and n2 are auxilliary indices +! value is the value of the condition +! cnum is returned as an index of the condition. +! to remove a condition the value sould be equial to RNONE ???? +! when a phase indesx is needed it should be 10*nph + ics +! SEE TQGETV for doucumentation of stavar etc. +!>>>> to be modified to use phase tuplets + integer(c_int), intent(in),value :: n1 !in: 0 or extended phase index: +! 10*phase_number+comp.set + ! or component set + integer(c_int), intent(in),value :: n2 ! + integer(c_int), intent(out) :: cnum !exit: +! sequential number of this condition + character(c_char), intent(in) :: statvar !in: character +! with state variable symbol + real(c_double), intent(in), value :: mvalue !in: value of condition + type(gtp_equilibrium_data), pointer :: ceq + type(c_ptr), intent(inout) :: c_ceq ! in: current equilibrium +!\end{verbatim} + call c_f_pointer(c_ceq, ceq) + call tqsetc(statvar, n1, n2, mvalue, cnum, ceq) + c_ceq = c_loc(ceq) + end subroutine c_tqsetc + +!\begin{verbatim} + subroutine c_tqce(mtarget,n1,n2,mvalue,c_ceq) bind(c,name='c_tqce') +! calculate equilibrium with possible target +! Target can be empty or a state variable with indicies n1 and n2 +! value is the calculated value of target + integer(c_int), intent(in),value :: n1 + integer(c_int), intent(in),value :: n2 + type(c_ptr), intent(inout) :: c_ceq + character(c_char), intent(inout) :: mtarget + real(c_double), intent(inout) :: mvalue + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + character(len=24) :: fstring + call c_f_pointer(c_ceq,ceq) + fstring = c_to_f_string(mtarget) + call tqce(fstring,n1,n2,mvalue,ceq) + c_ceq = c_loc(ceq) + end subroutine c_tqce + +!\begin{verbatim} + subroutine c_tqgetv(statvar,n1,n2,n3,values,c_ceq) bind(c,name='c_tqgetv') +! get equilibrium results using state variables +! stavar is the state variable IN CAPITAL LETTERS with indices n1 and n2 +! n3 at the call is the dimension of values, changed to number of values +! value is the calculated value, it can be an array with n3 values. + implicit none + integer(c_int), intent(in), value :: n1,n2 + integer(c_int), intent(inout) :: n3 + character(c_char), intent(in) :: statvar + real(c_double), intent(inout) :: values(*) + type(c_ptr), intent(inout) :: c_ceq !IN: current equilibrium +!======================================================== +! >>>> implement use of phase tuples +! stavar must be a symbol listed below +! IMPORTANT: some terms explained after the table +! Symbol index1,index2 Meaning (unit) +!.... potentials +! T 0,0 Temperature (K) +! P 0,0 Pressure (Pa) +! MU component,0 or phase-tuple*1,constituent*2 Chemical potential (J) +! AC component,0 or phase-tuple,constituent Activity = EXP(MU/RT) +! LNAC component,0 or phase-tuple,constituent LN(activity) = MU/RT +!...... extensive variables +! U 0,0 or phase-tuple,0 Internal energy (J) whole system or phase +! UM 0,0 or phase-tuple,0 same per mole components +! UW 0,0 or phase-tuple,0 same per kg +! UV 0,0 or phase-tuple,0 same per m3 +! UF phase-tuple,0 same per formula unit of phase +! S*3 0,0 or phase-tuple,0 Entropy (J/K) +! V 0,0 or phase-tuple,0 Volume (m3) +! H 0,0 or phase-tuple,0 Enthalpy (J) +! A 0,0 or phase-tuple,0 Helmholtz energy (J) +! G 0,0 or phase-tuple,0 Gibbs energy (J) +! ..... some extra state variables +! NP phase-tuple,0 Moles of phase +! BP phase-tuple,0 Mass of moles (kg) +! Q phase-tuple,0 Internal stability/RT (dimensionless) +! DG phase-tuple,0 Driving force/RT (dimensionless) +!....... amounts of components +! N 0,0 or component,0 or phase-tuple,component Moles of component +! X component,0 or phase-tuple,component Mole fraction of component +! B 0,0 or component,0 or phase-tuple,component Mass of component +! W component,0 or phase-tuple,component Mass fraction of component +! Y phase-tuple,constituent*1 Constituent fraction +!........ some parameter identifiers +! TC phase-tuple,0 Magnetic ordering temperature +! BMAG phase-tuple,0 Aver. Bohr magneton number +! MQ& phase-tuple,constituent Mobility +! THET phase-tuple,0 Debye temperature +! LNX phase-tuple,0 Lattice parameter +! EC11 phase-tuple,0 Elastic constant C11 +! EC12 phase-tuple,0 Elastic constant C12 +! EC44 phase-tuple,0 Elastic constant C44 +!........ NOTES: +! *1 The phase-tuple is is structure with 2 integers: phase and comp.set +! *2 The constituent index is 10*species_number + sublattice_number +! *3 S, V, H, A, G, NP, BP, N, B and DG can have suffixes M, W, V, F also +!-------------------------------------------------------------------- +! special addition for TQ interface: d2G/dyidyj +! D2G + extended phase index +!------------------------------------ + type(gtp_equilibrium_data), pointer :: ceq + character(len=24) :: fstring + integer :: n + integer :: i + call c_f_pointer(c_ceq, ceq) +! debug ... +! call list_conditions(6,ceq) +! call list_phase_results(1,1,0,6,ceq) +! write(*,*)'Phase and error code: ',1,gx%bmperr +! call list_phase_results(2,1,0,6,ceq) +! write(*,*)'Phase and error code: ',2,gx%bmperr +! write(*,*) +! end debug + fstring = c_to_f_string(statvar) + call tqgetv(fstring, n1, n2, n3, values, ceq) +! debug ... +! write(*,55)fstring(1:len_trim(fstring)),n1,n2,n3,(values(i),i=1,n3) +!55 format(/'From c_tqgetv: ',a,': ',3i3,6(1pe12.4)) +! write(*,*) +! end debug + c_ceq = c_loc(ceq) + end subroutine c_tqgetv + +end module liboctqisoc diff --git a/TQ3lib-clean/isoC-Teslos/linkiso1.txt b/TQ3lib-clean/isoC-Teslos/linkiso1.txt new file mode 100644 index 0000000..e552f9f --- /dev/null +++ b/TQ3lib-clean/isoC-Teslos/linkiso1.txt @@ -0,0 +1,4 @@ + +gcc -o feni-tqiso feni-tqiso.c liboctqisoc.o liboctq.o liboceq.a -lgfortran + + diff --git a/TQ3lib-clean/isoC-Teslos/octqc.h b/TQ3lib-clean/isoC-Teslos/octqc.h new file mode 100644 index 0000000..0148377 --- /dev/null +++ b/TQ3lib-clean/isoC-Teslos/octqc.h @@ -0,0 +1,92 @@ +#if !defined __OCTQC__ +#define __OCTQC__ + +typedef struct { + int statevarid, norm, unit, phref, argtyp; + int phase, compset, component, constituent; + double coeff; + int oldstv; +} gtp_state_variable; + +struct gtp_fraction_set; + +typedef struct { + int nextfree, phlink, status2, phstate; + double abnorm[2]; + char prefix[4], suffix[4]; + int *constat; + double *yfr; + double *mmyfr; + double *sites; + double *dpqdy; + double *d2pqdvay; + //struct gtp_fraction_set disfra; + double amfu, netcharge, dgm, amcom, damount; + int nprop, ncc; + int *listprop; + double **gval; + double ***dgval; + double **d2gval; + double curlat[3][3]; + double **cinvy; + double *cxmol; + double **cdxmol; +} gtp_phase_varres; + +typedef struct gtp_fraction_set { + int latd, ndd, tnoofxfr, tnoofyfr, varreslink, totdis; + char id; + double *dsites; + int *nooffr; + int *splink; + int *y2x; + double *dxidyj; + double fsites; + gtp_phase_varres *phdapointer; +} gtp_fraction_set; + +typedef struct { + int splink, phlink, status; + char refstate[16]; + int endmember; + double tpref[2]; + double chempot[2]; + double mass, molat; +} gtp_components; + +typedef struct gtp_condition { + int noofterms, statev, active, iunit, nid, iref, seqz; + int symlink1, symlink2; + int **indices; + double *condcoeff; + double *prescribed, current, uncertainity; + struct gtp_condition *next, *previous; + gtp_state_variable *statvar; +} gtp_condition; + +typedef struct { + double tpused[2]; + double results[6]; +} tpfun_parres; + +typedef struct { + int status, multiuse, eqno, next; + char eqname[24]; + double tpval[2], rtn; + double *svfunres; + gtp_condition *lastcondition, *lastexperiment; + gtp_components *complist, **compstoi, **invcompstoi; + gtp_phase_varres *phase_varres; + tpfun_parres *eq_tpres; + double *cmuval; + double xconv; + double gmindif; + int maxiter; + int sysmatdim, nfixmu, nfixph; + int *fixmu; + int *fixph; + double **savesysmat; +} gtp_equilibrium_data; + +#endif + diff --git a/TQ3lib-clean/isoC-matthias/FECRMNC.TDB b/TQ3lib-clean/isoC-matthias/FECRMNC.TDB new file mode 100644 index 0000000..bce7cb2 --- /dev/null +++ b/TQ3lib-clean/isoC-matthias/FECRMNC.TDB @@ -0,0 +1,647 @@ + +$ Database file written 14- 5-11 +$ + ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7400E+00! + ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01! + ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! + ELEMENT MN CBCC_A12 5.4938E+01 4.9960E+03 3.2008E+01! + + SPECIES CR+2 CR1/+2! + SPECIES CR+3 CR1/+3! + SPECIES FE+2 FE1/+2! + SPECIES FE+3 FE1/+3! + SPECIES FE+4 FE1/+4! + SPECIES MN+2 MN1/+2! + SPECIES MN+3 MN1/+3! + SPECIES MN+4 MN1/+4! + + FUNCTION GHSERCR 2.98140E+02 -8856.94+157.48*T-26.908*T*LN(T) + +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y + -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N ! + FUNCTION GHSERBB 2.98140E+02 -7735.284+107.111864*T-15.6641*T*LN(T) + -.006864515*T**2+6.18878E-07*T**3+370843*T**(-1); 1.10000E+03 Y + -16649.474+184.801744*T-26.6047*T*LN(T)-7.9809E-04*T**2-2.556E-08*T**3 + +1748270*T**(-1); 2.34800E+03 Y + -36667.582+231.336244*T-31.5957527*T*LN(T)-.00159488*T**2 + +1.34719E-07*T**3+11205883*T**(-1); 3.00000E+03 Y + -21530.653+222.396264*T-31.4*T*LN(T); 6.00000E+03 N ! + FUNCTION GCRM23B6 2.98150E+02 -460000+23*GHSERCR#+6*GHSERBB#; + 6.00000E+03 N ! + FUNCTION GHSERFE 2.98140E+02 +1225.7+124.134*T-23.5143*T*LN(T) + -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y + -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N + ! + FUNCTION GFEM23B6 2.98150E+02 -490000+134*T+23*GHSERFE#+6*GHSERBB#; + 6.00000E+03 N ! + FUNCTION GHSERMN 2.98140E+02 -8115.28+130.059*T-23.4582*T*LN(T) + -.00734768*T**2+69827*T**(-1); 1.51900E+03 Y + -28733.41+312.2648*T-48*T*LN(T)+1.656847E+30*T**(-9); 2.00000E+03 N ! + FUNCTION GMNM23B6 2.98150E+02 +23*GHSERMN#+6*GHSERBB#; 6.00000E+03 N + ! + FUNCTION GHSERNI 2.98140E+02 -5179.159+117.854*T-22.096*T*LN(T) + -.0048407*T**2; 1.72800E+03 Y + -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3.00000E+03 N + ! + FUNCTION GNIM23B6 2.98150E+02 +23*GHSERNI#+6*GHSERBB#; 6.00000E+03 N + ! + FUNCTION GBHCP 2.98150E+02 +50208-9.706*T+GHSERBB#; 6.00000E+03 N + ! + FUNCTION UALFE 2.98150E+02 -4000+T; 6.00000E+03 N ! + FUNCTION GALFE3 2.98150E+02 +3*UALFE#-4000; 6.00000E+03 N ! + FUNCTION GAL2FE2 2.98150E+02 +4*UALFE#; 6.00000E+03 N ! + FUNCTION GAL3FE 2.98150E+02 +3*UALFE#+9000; 6.00000E+03 N ! + FUNCTION SROALFE 2.98150E+02 +UALFE#; 6.00000E+03 N ! + FUNCTION LFALFE0 2.98150E+02 -104700+30.65*T; 6.00000E+03 N ! + FUNCTION LFALFE1 2.98150E+02 22600; 6.00000E+03 N ! + FUNCTION LFALFE2 2.98150E+02 +29100-13*T; 6.00000E+03 N ! + FUNCTION UKALFEC 2.98150E+02 -1600-16.8*T; 6.00000E+03 N ! + FUNCTION GKALFE3C 2.98150E+02 +3*UKALFEC#; 6.00000E+03 N ! + FUNCTION GKAL2FE2 2.98150E+02 +4*UKALFEC#-5200; 6.00000E+03 N ! + FUNCTION GKAL3FEC 2.98150E+02 +3*UKALFEC#; 6.00000E+03 N ! + FUNCTION SROKALFE 2.98150E+02 +UKALFEC#; 6.00000E+03 N ! + FUNCTION B2ALVA 2.98150E+02 +10000-T; 6.00000E+03 N ! + FUNCTION LB2ALVA 2.98150E+02 100000; 6.00000E+03 N ! + FUNCTION GB2ALFE 2.98150E+02 -10876+2.6*T; 6.00000E+03 N ! + FUNCTION DGBALFE 2.98150E+02 -4530+2.5*T; 6.00000E+03 N ! + FUNCTION DT0ALFE 2.98150E+02 -250; 6.00000E+03 N ! + FUNCTION DB0ALFE 2.98150E+02 -1.2; 6.00000E+03 N ! + FUNCTION ZERO 298.15 0.0; 6000.00 N ! + FUNCTION RTLN25 2.98150E+02 -.562335*R#*T; 6.00000E+03 N ! + FUNCTION GHSERCU 2.98140E+02 -7770.458+130.485235*T-24.112392*T*LN(T) + -.00265684*T**2+1.29223E-07*T**3+52478*T**(-1); 1.35777E+03 Y + -13542.026+183.803828*T-31.38*T*LN(T)+3.64167E+29*T**(-9); + 3.20000E+03 N ! + FUNCTION GHSERSS 2.98140E+02 -5228.956+55.417762*T-11.007*T*LN(T) + -.026529*T**2+7.754333E-06*T**3; 3.68300E+02 Y + -6513.769+94.692922*T-17.941839*T*LN(T)-.010895125*T**2 + +1.402558E-06*T**3+39910*T**(-1); 1.30000E+03 N ! + FUNCTION GDIGENIT 2.98150E+02 -62053-105.461*T+8.1715*T*LN(T)+2*GHSERCU# + +GHSERSS#; 6.00000E+03 N ! + FUNCTION F10383T 2.98150E+02 +211801.621+24.4989821*T-20.78611*T*LN(T); + 6.00000E+03 N ! + FUNCTION F10711T 2.98140E+02 +130854.682+30.5267876*T-34.25937*T*LN(T) + +.00583824*T**2-1.79746E-06*T**3-33304.895*T**(-1); 7.00000E+02 Y + +133769.365-23.7043906*T-25.65337*T*LN(T)-.0042003385*T**2 + +2.51694667E-07*T**3-174588.25*T**(-1); 2.20000E+03 Y + +140179.423-26.622816*T-25.86682*T*LN(T)-.00276017*T**2 + +9.24508333E-08*T**3-3805126*T**(-1); 6.00000E+03 N ! + FUNCTION F10784T 2.98140E+02 -9522.9741+78.5273879*T-31.35707*T*LN(T) + +.0027589925*T**2-7.46390667E-07*T**3+56582.3*T**(-1); 1.00000E+03 Y + +180.108664-15.6128256*T-17.84857*T*LN(T)-.00584168*T**2 + +3.14618667E-07*T**3-1280036*T**(-1); 2.10000E+03 Y + -18840.1663+92.3120255*T-32.05082*T*LN(T)-.0010728235*T**2 + +1.14281783E-08*T**3+3561002.5*T**(-1); 6.00000E+03 N ! + FUNCTION F11002T 2.98140E+02 -28637.4628-29.7124458*T-25.37431*T*LN(T) + -.012230205*T**2+6.62201E-07*T**3-86459.2*T**(-1); 9.00000E+02 Y + -38442.2654+51.1969052*T-36.54058*T*LN(T)-.007461545*T**2 + +4.40338167E-07*T**3+1395975*T**(-1); 2.20000E+03 Y + -65256.7666+203.938596*T-56.66161*T*LN(T)-6.40182E-04*T**2 + +2.14147833E-09*T**3+8250950*T**(-1); 6.00000E+03 N ! + FUNCTION F11007T 2.98140E+02 -1716.28163+84.8441289*T-51.37952*T*LN(T) + -.00808767*T**2+210246*T**(-1); 1.00000E+03 N ! + FUNCTION F14852T 2.98140E+02 +269797.373+2.2810296*T-25.70471*T*LN(T) + +.003751372*T**2-5.48887167E-07*T**3+3450.3165*T**(-1); 1.00000E+03 Y + +273925.002-38.4958652*T-19.81748*T*LN(T)-2.300353E-04*T**2 + -1.18709967E-08*T**3-570436.5*T**(-1); 3.40000E+03 Y + +257401.532-.943966729*T-24.05931*T*LN(T)-5.98546E-07*T**2 + +2.02961167E-09*T**3+9368165*T**(-1); 1.00000E+04 N ! + FUNCTION F14964T 2.98140E+02 +117374.548+2.98629624*T-34.09678*T*LN(T) + -.002325464*T**2+1.85480167E-07*T**3+128593.6*T**(-1); 1.00000E+03 Y + +117352.438+2.50383325*T-34.04744*T*LN(T)-.0021150245*T**2 + +9.16602333E-08*T**3+175718.45*T**(-1); 3.40000E+03 Y + +124361.091+14.5182901*T-36.1923*T*LN(T)-5.930925E-04*T**2 + -7.54259333E-09*T**3-7484105*T**(-1); 6.00000E+03 N ! + FUNCTION F15022T 2.98140E+02 +126744.315+83.8435689*T-52.94561*T*LN(T) + -.0043385055*T**2+6.68300333E-07*T**3+276938.3*T**(-1); 1.00000E+03 Y + +123958.871+118.720436*T-58.16242*T*LN(T)-7.29079E-06*T**2 + +2.42566833E-10*T**3+558805*T**(-1); 6.00000E+03 N ! + FUNCTION F15041T 2.98140E+02 +109847.438+203.904963*T-72.67966*T*LN(T) + -.009041155*T**2+1.47148883E-06*T**3+505278*T**(-1); 9.00000E+02 Y + +104526.08+272.793563*T-83.05028*T*LN(T)-1.828101E-05*T**2 + +6.19803333E-10*T**3+1023588.5*T**(-1); 6.00000E+03 N ! + FUNCTION F15047T 2.98140E+02 +106276.072+170.263399*T-74.99022*T*LN(T) + -.035336475*T**2+5.76872833E-06*T**3+227070.6*T**(-1); 9.00000E+02 Y + +75139.8847+544.891054*T-130.537*T*LN(T)+.007879015*T**2 + -4.32610333E-07*T**3+3425257*T**(-1); 2.80000E+03 Y + +114904.753+339.945759*T-103.9801*T*LN(T)+2.25877E-05*T**2 + -7.925025E-10*T**3-7832715*T**(-1); 6.00000E+03 N ! + FUNCTION F15052T 2.98140E+02 +57214.7948+523.24074*T-130.1838*T*LN(T) + -4.152356E-04*T**2-4.27131667E-07*T**3+779118.5*T**(-1); 1.60000E+03 Y + +8925.72335+728.509037*T-155.3363*T*LN(T)+.002031178*T**2 + -1.776135E-08*T**3+14908280*T**(-1); 4.20000E+03 Y + +43158.7838+657.511854*T-147.3935*T*LN(T)+.0015928905*T**2 + -3.34608333E-08*T**3-8046775*T**(-1); 6.00000E+03 N ! + FUNCTION F15057T 2.98140E+02 +59623.0027+634.182529*T-153.2939*T*LN(T) + -.003102847*T**2+3.66153167E-07*T**3+940068*T**(-1); 1.50000E+03 Y + +56671.3245+666.288106*T-157.9591*T*LN(T)-2.441417E-06*T**2 + +7.28532E-11*T**3+1284129.5*T**(-1); 6.00000E+03 N ! + FUNCTION F15061T 2.98140E+02 +45619.0277+695.996674*T-166.1987*T*LN(T) + -.0109886*T**2-1.38875683E-06*T**3+753634*T**(-1); 8.00000E+02 Y + +22301.584+822.41812*T-181.0091*T*LN(T)-.020252625*T**2 + +3.04543E-06*T**3+4785936*T**(-1); 1.50000E+03 Y + +28125.3352+992.470207*T-208.7199*T*LN(T)+.006139635*T**2 + -2.57977667E-07*T**3-2943090*T**(-1); 3.90000E+03 Y + +82396.4096+766.112131*T-180.3439*T*LN(T)-2.580219E-04*T**2 + +5.17172833E-09*T**3-21845450*T**(-1); 6.00000E+03 N ! + FUNCTION GCLIQ 2.98150E+02 +117369-24.63*T+GHSERCC#; 6.00000E+03 + N ! + FUNCTION GPCLIQ 2.98150E+02 +YCLIQ#*EXP(ZCLIQ#); 6.00000E+03 N ! + FUNCTION GCRLIQ 2.98140E+02 +24339.955-11.420225*T+2.37615E-21*T**7 + +GHSERCR#; 2.18000E+03 Y + -16459.984+335.616316*T-50*T*LN(T); 6.00000E+03 N ! + FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N ! + FUNCTION GFELIQ 2.98140E+02 +12040.17-6.55843*T-3.6751551E-21*T**7 + +GHSERFE#; 1.81100E+03 Y + -10838.83+291.302*T-46*T*LN(T); 6.00000E+03 N ! + FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N ! + FUNCTION GMNLIQ 2.98140E+02 +17859.91-12.6208*T-4.41929E-21*T**7 + +GHSERMN#; 1.51900E+03 Y + +18739.51-13.2288*T-1.656847E+30*T**(-9)+GHSERMN#; 2.00000E+03 N ! + FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N ! + FUNCTION GHSERCC 2.98150E+02 -17368.441+170.73*T-24.3*T*LN(T) + -4.723E-04*T**2+2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3); + 6.00000E+03 N ! + FUNCTION GPCGRA 2.98150E+02 +YCGRA#*EXP(ZCGRA#); 6.00000E+03 N ! + FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N ! + FUNCTION GMNBCC 2.98140E+02 -3235.3+127.85*T-23.7*T*LN(T) + -.00744271*T**2+60000*T**(-1); 1.51900E+03 Y + -23188.83+307.7043*T-48*T*LN(T)+1.265152E+30*T**(-9); 2.00000E+03 N ! + FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N ! + FUNCTION GFEFCC 2.98140E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 + +GHSERFE#; 1.81100E+03 Y + -1713.815+.94001*T+4.9251E+30*T**(-9)+GHSERFE#; 6.00000E+03 N ! + FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! + FUNCTION GPCFCC 2.98150E+02 +YCFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! + FUNCTION GMNFCC 2.98140E+02 -3439.3+131.884*T-24.5177*T*LN(T) + -.006*T**2+69600*T**(-1); 1.51900E+03 Y + -26070.1+309.6664*T-48*T*LN(T)+3.86196E+30*T**(-9); 2.00000E+03 N ! + FUNCTION GPFEHCP 2.98150E+02 +YFEHCP#*EXP(ZFEHCP#); 6.00000E+03 N ! + FUNCTION GFECEM 2.98150E+02 -10745+706.04*T-120.6*T*LN(T)+GPCEM1#; + 6.00000E+03 N ! + FUNCTION GCRM23C6 2.98150E+02 -521983+3622.24*T-620.965*T*LN(T) + -.126431*T**2; 6.00000E+03 N ! + FUNCTION GFEM23C6 2.98150E+02 +7.666667*GFECEM#-1.666667*GHSERCC#+66920 + -40*T; 6.00000E+03 N ! + FUNCTION GMNM23C6 2.98150E+02 -308065+50.966*T+23*GHSERMN#+6*GHSERCC#; + 6.00000E+03 N ! + FUNCTION GCRM3C2 2.98150E+02 -100823.8+530.66989*T-89.6694*T*LN(T) + -.0301188*T**2; 6.00000E+03 N ! + FUNCTION GCRM7C3 2.98150E+02 -201690+1103.128*T-190.177*T*LN(T) + -.0578207*T**2; 6.00000E+03 N ! + FUNCTION GS_NIVNI 2.98140E+02 -161645.05+3532.8443*T-671.032*T*LN(T) + -.1382502*T**2+4.87E-07*T**3+277840*T**(-1); 7.90000E+02 Y + -161794.7+3572.6245*T-678.096*T*LN(T)-.1256082*T**2-2.72E-06*T**3; + 1.72800E+03 N ! + FUNCTION GS_NIVV 2.98140E+02 -663330.65+4012.7719*T-707.716*T*LN(T) + -.1068816*T**2+2.6785E-06*T**3+1528120*T**(-1); 7.90000E+02 Y + -664153.72+4231.5628*T-746.568*T*LN(T)-.0373506*T**2-1.496E-05*T**3; + 1.72800E+03 N ! + FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N ! + FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N ! + FUNCTION YCLIQ 2.98150E+02 +VCLIQ#*EXP(-ECLIQ#); 6.00000E+03 N ! + FUNCTION ZCLIQ 2.98150E+02 +1*LN(XCLIQ#); 6.00000E+03 N ! + FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N ! + FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N ! + FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N ! + FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N ! + FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N ! + FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N ! + FUNCTION YCGRA 2.98150E+02 +VCGRA#*EXP(-ECGRA#); 6.00000E+03 N ! + FUNCTION ZCGRA 2.98150E+02 +1*LN(XCGRA#); 6.00000E+03 N ! + FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N ! + FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N ! + FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! + FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N ! + FUNCTION YCFCC 2.98150E+02 +VCFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! + FUNCTION YFEHCP 2.98150E+02 +VFEHCP#*EXP(-EFEHCP#); 6.00000E+03 N ! + FUNCTION ZFEHCP 2.98150E+02 +1*LN(XFEHCP#); 6.00000E+03 N ! + FUNCTION GPCEM1 2.98150E+02 +VCEM1#*P; 6.00000E+03 N ! + FUNCTION VCLIQ 2.98150E+02 +7.626E-06*EXP(ACLIQ#); 6.00000E+03 N ! + FUNCTION ECLIQ 2.98150E+02 +1*LN(CCLIQ#); 6.00000E+03 N ! + FUNCTION XCLIQ 2.98150E+02 +1*EXP(.5*DCLIQ#)-1; 6.00000E+03 N ! + FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N + ! + FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N ! + FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N ! + FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 + N ! + FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N ! + FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 + N ! + FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N + ! + FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N ! + FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N ! + FUNCTION VCGRA 2.98150E+02 +5.259E-06*EXP(ACGRA#); 6.00000E+03 N ! + FUNCTION ECGRA 2.98150E+02 +1*LN(CCGRA#); 6.00000E+03 N ! + FUNCTION XCGRA 2.98150E+02 +1*EXP(.9166667*DCGRA#)-1; 6.00000E+03 + N ! + FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 + N ! + FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N ! + FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 + N ! + FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 + N ! + FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N ! + FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 + N ! + FUNCTION VCFCC 2.98150E+02 +1.031E-05*EXP(ACFCC#); 6.00000E+03 N ! + FUNCTION VFEHCP 2.98150E+02 +6.59121E-06*EXP(AFEHCP#); 6.00000E+03 + N ! + FUNCTION EFEHCP 2.98150E+02 +1*LN(CFEHCP#); 6.00000E+03 N ! + FUNCTION XFEHCP 2.98150E+02 +1*EXP(.8064454*DFEHCP#)-1; 6.00000E+03 + N ! + FUNCTION VCEM1 2.98150E+02 +2.339E-05*EXP(ACEM1#); 6.00000E+03 N ! + FUNCTION ACLIQ 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 + N ! + FUNCTION CCLIQ 2.98150E+02 1.6E-10; 6.00000E+03 N ! + FUNCTION DCLIQ 2.98150E+02 +1*LN(BCLIQ#); 6.00000E+03 N ! + FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N + ! + FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N ! + FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N ! + FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N ! + FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; + 6.00000E+03 N ! + FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N ! + FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N + ! + FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N ! + FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N ! + FUNCTION ACGRA 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 + N ! + FUNCTION CCGRA 2.98150E+02 3.3E-10; 6.00000E+03 N ! + FUNCTION DCGRA 2.98150E+02 +1*LN(BCGRA#); 6.00000E+03 N ! + FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; + 6.00000E+03 N ! + FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; + 6.00000E+03 N ! + FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N ! + FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N ! + FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; + 6.00000E+03 N ! + FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N ! + FUNCTION ACFCC 2.98150E+02 +1.44E-04*T; 6.00000E+03 N ! + FUNCTION AFEHCP 2.98150E+02 +7.3646E-05*T; 6.00000E+03 N ! + FUNCTION CFEHCP 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; + 6.00000E+03 N ! + FUNCTION DFEHCP 2.98150E+02 +1*LN(BFEHCP#); 6.00000E+03 N ! + FUNCTION ACEM1 2.98150E+02 -1.36E-05*T+4E-08*T**2; 6.00000E+03 N ! + FUNCTION BCLIQ 2.98150E+02 +1+3.2E-10*P; 6.00000E+03 N ! + FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N ! + FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; + 6.00000E+03 N ! + FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N ! + FUNCTION BCGRA 2.98150E+02 +1+3.6E-10*P; 6.00000E+03 N ! + FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; + 6.00000E+03 N ! + FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; + 6.00000E+03 N ! + FUNCTION BFEHCP 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; + 6.00000E+03 N ! + FUNCTION UN_ASS 298.15 0; 300 N ! + + TYPE_DEFINITION % SEQ *! + DEFINE_SYSTEM_DEFAULT SPECIE 2 ! + DEFAULT_COMMAND DEF_SYS_ELEMENT VA ! + + + PHASE LIQUID:L % 1 1.0 ! + CONSTITUENT LIQUID:L :C,CR,FE,MN : ! + + PARAMETER G(LIQUID,C;0) 2.98150E+02 +GCLIQ#+GPCLIQ#; 6.00000E+03 N + REF:279 ! + PARAMETER G(LIQUID,CR;0) 2.98150E+02 +GCRLIQ#+GPCRLIQ#; 6.00000E+03 + N REF:279 ! + PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 + N REF:279 ! + PARAMETER G(LIQUID,MN;0) 2.98140E+02 +GMNLIQ#; 2.00000E+03 N REF:279 ! + PARAMETER G(LIQUID,C,CR;0) 2.98150E+02 -90526-25.9116*T; 6.00000E+03 + N REF:97 ! + PARAMETER G(LIQUID,C,CR;1) 2.98150E+02 80000; 6.00000E+03 N REF:97 ! + PARAMETER G(LIQUID,C,CR;2) 2.98150E+02 80000; 6.00000E+03 N REF:97 ! + PARAMETER G(LIQUID,C,CR,FE;0) 2.98150E+02 -514037; 6.00000E+03 N + REF:322 ! + PARAMETER G(LIQUID,C,CR,FE;1) 2.98150E+02 73286; 6.00000E+03 N + REF:322 ! + PARAMETER G(LIQUID,C,CR,FE;2) 2.98150E+02 66921; 6.00000E+03 N + REF:322 ! + PARAMETER G(LIQUID,C,FE;0) 2.98150E+02 -124320+28.5*T; 6.00000E+03 + N REF:186 ! + PARAMETER G(LIQUID,C,FE;1) 2.98150E+02 19300; 6.00000E+03 N REF:186 ! + PARAMETER G(LIQUID,C,FE;2) 2.98150E+02 +49260-19*T; 6.00000E+03 N + REF:186 ! + PARAMETER G(LIQUID,C,FE,MN;0) 2.98150E+02 -45675; 6.00000E+03 N + REF:263 ! + PARAMETER G(LIQUID,C,FE,MN;1) 2.98150E+02 -12379; 6.00000E+03 N + REF:263 ! + PARAMETER G(LIQUID,C,FE,MN;2) 2.98150E+02 -12379; 6.00000E+03 N + REF:263 ! + PARAMETER G(LIQUID,C,MN;0) 2.98150E+02 -168240+35.635*T; 6.00000E+03 + N REF:263 ! + PARAMETER G(LIQUID,C,MN;1) 2.98150E+02 -91760+50*T; 6.00000E+03 N + REF:263 ! + PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -17737+7.996546*T; + 6.00000E+03 N REF:322 ! + PARAMETER G(LIQUID,CR,FE;1) 2.98150E+02 -1331; 6.00000E+03 N + REF:322 ! + PARAMETER G(LIQUID,CR,FE,MN;0) 2.98150E+02 2378; 6.00000E+03 N + REF:323 ! + PARAMETER G(LIQUID,CR,MN;0) 2.98150E+02 -15009+13.6587*T; 6.00000E+03 + N REF:323 ! + PARAMETER G(LIQUID,CR,MN;1) 2.98150E+02 +504+.9479*T; 6.00000E+03 N + REF:323 ! + PARAMETER G(LIQUID,FE,MN;0) 2.98150E+02 -3950+.489*T; 6.00000E+03 N + REF:257 ! + PARAMETER G(LIQUID,FE,MN;1) 2.98150E+02 1145; 6.00000E+03 N REF:257 ! + + + TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! + PHASE BCC_A2 %& 2 1 3 ! + CONSTITUENT BCC_A2 :CR%,FE%,MN : C,VA% : ! + + PARAMETER G(BCC_A2,CR:C;0) 2.98150E+02 +GHSERCR#+3*GHSERCC#+GPCRBCC# + +3*GPCGRA#+416000; 6.00000E+03 N REF:97 ! + PARAMETER TC(BCC_A2,CR:C;0) 2.98150E+02 -311.5; 6.00000E+03 N + REF:97 ! + PARAMETER BMAGN(BCC_A2,CR:C;0) 2.98150E+02 -.008; 6.00000E+03 N + REF:97 ! + PARAMETER G(BCC_A2,FE:C;0) 2.98150E+02 +GHSERFE#+GPFEBCC#+3*GHSERCC# + +3*GPCGRA#+322050+75.667*T; 6.00000E+03 N REF:186 ! + PARAMETER TC(BCC_A2,FE:C;0) 2.98150E+02 1043; 6.00000E+03 N REF:186 ! + PARAMETER BMAGN(BCC_A2,FE:C;0) 2.98150E+02 2.22; 6.00000E+03 N + REF:186 ! + PARAMETER G(BCC_A2,MN:C;0) 2.98150E+02 +10000+30*T+GHSERMN#+3*GHSERCC#; + 6.00000E+03 N REF:263 ! + PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; + 6.00000E+03 N REF:279 ! + PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N + REF:277 ! + PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.008; 6.00000E+03 N + REF:277 ! + PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; + 6.00000E+03 N REF:279 ! + PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N + REF:277 ! + PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N + REF:277 ! + PARAMETER G(BCC_A2,MN:VA;0) 2.98150E+02 +GMNBCC#; 6.00000E+03 N + REF:279 ! + PARAMETER TC(BCC_A2,MN:VA;0) 2.98140E+02 -580; 2.00000E+03 N REF:277 ! + PARAMETER BMAGN(BCC_A2,MN:VA;0) 2.98140E+02 -.27; 2.00000E+03 N + REF:277 ! + PARAMETER G(BCC_A2,CR,FE:C;0) 2.98150E+02 -1250000+667.7*T; + 6.00000E+03 N REF:314 ! + PARAMETER BMAGN(BCC_A2,CR,FE:C;0) 2.98150E+02 -.85; 6.00000E+03 N + REF:98 ! + PARAMETER TC(BCC_A2,CR,FE:C;0) 2.98150E+02 1650; 6.00000E+03 N + REF:98 ! + PARAMETER TC(BCC_A2,CR,FE:C;1) 2.98150E+02 550; 6.00000E+03 N + REF:98 ! + PARAMETER G(BCC_A2,CR,MN:C;0) 2.98150E+02 -20328+18.7339*T; + 6.00000E+03 N REF:324 ! + PARAMETER G(BCC_A2,CR,MN:C;1) 2.98150E+02 -9162+4.4183*T; 6.00000E+03 + N REF:324 ! + PARAMETER G(BCC_A2,CR:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N + REF:97 ! + PARAMETER G(BCC_A2,FE,MN:C;0) 2.98150E+02 +34052-23.467*T; + 6.00000E+03 N REF:263 ! + PARAMETER G(BCC_A2,FE:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N + REF:186 ! + PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 + N REF:103 ! + PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N + REF:103 ! + PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N + REF:103 ! + PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N + REF:103 ! + PARAMETER G(BCC_A2,CR,FE,MN:VA;0) 2.98150E+02 -5996; 6.00000E+03 N + REF:323 ! + PARAMETER G(BCC_A2,CR,MN:VA;0) 2.98150E+02 -20328+18.7339*T; + 6.00000E+03 N REF:323 ! + PARAMETER G(BCC_A2,CR,MN:VA;1) 2.98150E+02 -9162+4.4183*T; + 6.00000E+03 N REF:323 ! + PARAMETER BMAGN(BCC_A2,CR,MN:VA;0) 2.98150E+02 .48643; 6.00000E+03 + N REF:323 ! + PARAMETER BMAGN(BCC_A2,CR,MN:VA;2) 2.98150E+02 -.72035; 6.00000E+03 + N REF:323 ! + PARAMETER BMAGN(BCC_A2,CR,MN:VA;4) 2.98150E+02 -1.93265; 6.00000E+03 + N REF:323 ! + PARAMETER TC(BCC_A2,CR,MN:VA;0) 2.98150E+02 -1325; 6.00000E+03 N + REF:323 ! + PARAMETER TC(BCC_A2,CR,MN:VA;2) 2.98150E+02 -1133; 6.00000E+03 N + REF:323 ! + PARAMETER TC(BCC_A2,CR,MN:VA;4) 2.98150E+02 -10294; 6.00000E+03 N + REF:323 ! + PARAMETER TC(BCC_A2,CR,MN:VA;6) 2.98150E+02 26706; 6.00000E+03 N + REF:323 ! + PARAMETER G(BCC_A2,FE,MN:VA;0) 2.98150E+02 -2759+1.237*T; 6.00000E+03 + N REF:257 ! + PARAMETER TC(BCC_A2,FE,MN:VA;0) 2.98150E+02 123; 6.00000E+03 N + REF:257 ! + + + PHASE CEMENTITE % 2 3 1 ! + CONSTITUENT CEMENTITE :CR,FE%,MN : C : ! + + PARAMETER G(CEMENTITE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#-48000 + -9.2888*T; 6.00000E+03 N REF:314 ! + PARAMETER G(CEMENTITE,FE:C;0) 2.98150E+02 +GFECEM#; 6.00000E+03 N + REF:186 ! + PARAMETER G(CEMENTITE,MN:C;0) 2.98150E+02 -40379+3.524*T+3*GHSERMN# + +GHSERCC#; 6.00000E+03 N REF:263 ! + PARAMETER G(CEMENTITE,CR,FE:C;0) 2.98150E+02 +25278-17.5*T; + 6.00000E+03 N REF:314 ! + PARAMETER G(CEMENTITE,CR,MN:C;0) 2.98150E+02 9000; 6.00000E+03 N + REF:324 ! + PARAMETER G(CEMENTITE,FE,MN:C;0) 2.98150E+02 +10434-14.281*T; + 6.00000E+03 N REF:263 ! + + + PHASE CR3MN5 % 2 3 5 ! + CONSTITUENT CR3MN5 :CR : MN : ! + + PARAMETER G(CR3MN5,CR:MN;0) 2.98150E+02 +3*GHSERCR#+5*GHSERMN#-72550 + +21.1732*T; 6.00000E+03 N REF:323 ! + + + TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! + PHASE FCC_A1 %( 2 1 1 ! + CONSTITUENT FCC_A1 :CR,FE%,MN : C,VA% : ! + + PARAMETER G(FCC_A1,CR:C;0) 2.98150E+02 +GHSERCR#+GHSERCC#+1200-1.94*T; + 6.00000E+03 N REF:314 ! + PARAMETER G(FCC_A1,FE:C;0) 2.98150E+02 +77207-15.877*T+GFEFCC#+GHSERCC# + +GPCFCC#; 6.00000E+03 N REF:186 ! + PARAMETER TC(FCC_A1,FE:C;0) 2.98150E+02 -201; 6.00000E+03 N REF:186 ! + PARAMETER BMAGN(FCC_A1,FE:C;0) 2.98150E+02 -2.1; 6.00000E+03 N + REF:186 ! + PARAMETER G(FCC_A1,MN:C;0) 2.98150E+02 +502+15.261*T+GHSERMN#+GHSERCC#; + 6.00000E+03 N REF:263 ! + PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; + 6.00000E+03 N REF:277 ! + PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N + REF:277 ! + PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N + REF:277 ! + PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; + 6.00000E+03 N REF:279 ! + PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N + REF:277 ! + PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N + REF:277 ! + PARAMETER G(FCC_A1,MN:VA;0) 2.98150E+02 +GMNFCC#; 6.00000E+03 N + REF:279 ! + PARAMETER TC(FCC_A1,MN:VA;0) 2.98140E+02 -1620; 2.00000E+03 N REF:277 ! + PARAMETER BMAGN(FCC_A1,MN:VA;0) 2.98140E+02 -1.86; 2.00000E+03 N + REF:277 ! + PARAMETER G(FCC_A1,CR,FE:C;0) 2.98150E+02 -74319+3.2353*T; + 6.00000E+03 N REF:314 ! + PARAMETER G(FCC_A1,CR,MN:C;0) 2.98150E+02 -19088+17.5423*T; + 6.00000E+03 N REF:324 ! + PARAMETER G(FCC_A1,CR:C,VA;0) 2.98150E+02 -11977+6.8194*T; + 6.00000E+03 N REF:314 ! + PARAMETER G(FCC_A1,FE,MN:C;0) 2.98150E+02 +34052-23.467*T; + 6.00000E+03 N REF:263 ! + PARAMETER G(FCC_A1,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N + REF:186 ! + PARAMETER G(FCC_A1,MN:C,VA;0) 2.98150E+02 -43433; 6.00000E+03 N + REF:263 ! + PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; + 6.00000E+03 N REF:103 ! + PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N + REF:103 ! + PARAMETER G(FCC_A1,CR,FE,MN:VA;0) 2.98150E+02 +6715-10.3933*T; + 6.00000E+03 N REF:323 ! + PARAMETER G(FCC_A1,CR,MN:VA;0) 2.98150E+02 -19088+17.5423*T; + 6.00000E+03 N REF:323 ! + PARAMETER G(FCC_A1,FE,MN:VA;0) 2.98150E+02 -7762+3.865*T; 6.00000E+03 + N REF:257 ! + PARAMETER G(FCC_A1,FE,MN:VA;1) 2.98150E+02 -259; 6.00000E+03 N + REF:257 ! + PARAMETER TC(FCC_A1,FE,MN:VA;0) 2.98150E+02 -2282; 6.00000E+03 N + REF:257 ! + PARAMETER TC(FCC_A1,FE,MN:VA;1) 2.98150E+02 -2068; 6.00000E+03 N + REF:257 ! + + + PHASE M23C6 % 3 20 3 6 ! + CONSTITUENT M23C6 :CR%,FE%,MN : CR%,FE%,MN : C : ! + + PARAMETER G(M23C6,CR:CR:C;0) 2.98150E+02 +GCRM23C6#; 6.00000E+03 N + REF:97 ! + PARAMETER G(M23C6,FE:CR:C;0) 2.98150E+02 +.130435*GCRM23C6# + +.869565*GFEM23C6#; 6.00000E+03 N REF:98 ! + PARAMETER G(M23C6,MN:CR:C;0) 2.98150E+02 +.869565*GMNM23C6# + +.130435*GCRM23C6#; 6.00000E+03 N REF:324 ! + PARAMETER G(M23C6,CR:FE:C;0) 2.98150E+02 +.869565*GCRM23C6# + +.130435*GFEM23C6#; 6.00000E+03 N REF:98 ! + PARAMETER G(M23C6,FE:FE:C;0) 2.98150E+02 +GFEM23C6#; 6.00000E+03 N + REF:98 ! + PARAMETER G(M23C6,MN:FE:C;0) 2.98150E+02 +.869565*GMNM23C6# + +.130435*GFEM23C6#; 6.00000E+03 N REF:263 ! + PARAMETER G(M23C6,CR:MN:C;0) 2.98150E+02 +.869565*GCRM23C6# + +.130435*GMNM23C6#; 6.00000E+03 N REF:324 ! + PARAMETER G(M23C6,FE:MN:C;0) 2.98150E+02 +.869565*GFEM23C6# + +.130435*GMNM23C6#; 6.00000E+03 N REF:263 ! + PARAMETER G(M23C6,MN:MN:C;0) 2.98150E+02 +GMNM23C6#; 6.00000E+03 N + REF:263 ! + PARAMETER G(M23C6,CR,FE:CR:C;0) 2.98150E+02 -205342+141.6667*T; + 6.00000E+03 N REF:314 ! + PARAMETER G(M23C6,CR,MN:CR:C;0) 2.98150E+02 -173680+160*T; + 6.00000E+03 N REF:324 ! + PARAMETER G(M23C6,CR,MN:CR:C;1) 2.98150E+02 -286614; 6.00000E+03 N + REF:324 ! + PARAMETER G(M23C6,FE,MN:CR,FE:C;0) 2.98150E+02 -100000; 6.00000E+03 + N REF:324 ! + PARAMETER G(M23C6,FE,MN:CR,MN:C;0) 2.98150E+02 -100000; 6.00000E+03 + N REF:324 ! + PARAMETER G(M23C6,CR,FE:FE:C;0) 2.98150E+02 -205342+141.6667*T; + 6.00000E+03 N REF:314 ! + PARAMETER G(M23C6,CR,MN:FE:C;0) 2.98150E+02 -173680+160*T; + 6.00000E+03 N REF:324 ! + PARAMETER G(M23C6,CR,MN:FE:C;1) 2.98150E+02 -286614; 6.00000E+03 N + REF:324 ! + PARAMETER G(M23C6,FE,MN:FE,MN:C;0) 2.98150E+02 -100000; 6.00000E+03 + N REF:263 ! + PARAMETER G(M23C6,CR,FE:MN:C;0) 2.98150E+02 -205342+141.6667*T; + 6.00000E+03 N REF:324 ! + PARAMETER G(M23C6,CR,MN:MN:C;0) 2.98150E+02 -173680+160*T; + 6.00000E+03 N REF:324 ! + PARAMETER G(M23C6,CR,MN:MN:C;1) 2.98150E+02 -286614; 6.00000E+03 N + REF:324 ! + + + PHASE M3C2 % 2 3 2 ! + CONSTITUENT M3C2 :CR : C : ! + + PARAMETER G(M3C2,CR:C;0) 2.98150E+02 +GCRM3C2#; 6.00000E+03 N + REF:314 ! + + + PHASE M5C2 % 2 5 2 ! + CONSTITUENT M5C2 :FE,MN : C : ! + + PARAMETER G(M5C2,FE:C;0) 2.98150E+02 +5*GHSERFE#+2*GHSERCC#+54852 + -33.7518*T; 6.00000E+03 N REF:314 ! + PARAMETER G(M5C2,MN:C;0) 2.98150E+02 -76849+8.517*T+5*GHSERMN# + +2*GHSERCC#; 6.00000E+03 N REF:263 ! + PARAMETER G(M5C2,FE,MN:C;0) 2.98150E+02 -42056+3.5*T; 6.00000E+03 N + REF:314 ! + + + PHASE M7C3 % 2 7 3 ! + CONSTITUENT M7C3 :CR%,FE,MN : C : ! + + PARAMETER G(M7C3,CR:C;0) 2.98150E+02 +GCRM7C3#; 6.00000E+03 N + REF:314 ! + PARAMETER G(M7C3,FE:C;0) 2.98150E+02 +7*GHSERFE#+3*GHSERCC#+75000 + -48.2168*T; 6.00000E+03 N REF:314 ! + PARAMETER G(M7C3,MN:C;0) 2.98150E+02 -111765+13.092*T+7*GHSERMN# + +3*GHSERCC#; 6.00000E+03 N REF:263 ! + PARAMETER G(M7C3,CR,FE:C;0) 2.98150E+02 -4520-10*T; 6.00000E+03 N + REF:314 ! + PARAMETER G(M7C3,CR,MN:C;0) 2.98150E+02 +72737-56.4964*T; 6.00000E+03 + N REF:324 ! + PARAMETER G(M7C3,FE,MN:C;0) 2.98150E+02 -43057+4.0625*T; 6.00000E+03 + N REF:314 ! + + LIST_OF_REFERENCES + NUMBER SOURCE + 279 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report + DMA(A)195 + Rev. August 1990' + 97 'J-O Andersson, Calphad Vol 11 (1987) p 271-276, TRITA 0314; C-CR' + 322 'Byeong-Joo Lee, Calphad (1993), revison of Fe-Cr + Fe-Ni liquid' + 186 'P. Gustafson, Scan. J. Metall. vol 14, (1985) p 259-267 + TRITA 0237 (1984); C-FE' + 263 'W. Huang, Metall. Trans. Vol 21A(1990) p 2115-2123, + TRITA-MAC 411 (Rev 1989); C-FE-MN' + 323 'Byeong-Joo Lee, Metall. Trans. 24A (1993) 1919-1933; Cr-Mn + Fe-Cr-Mn' + 257 'W. Huang, Calphad Vol 13 (1989) pp 243-252, + TRITA-MAC 388 (rev 1989); FE-MN' + 277 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report + DMA(A)195 + September 1989' + 314 'Byeong-Joo Lee, unpublished revision (1991); C-Cr-Fe-Ni' + 98 'J-O Andersson, Met. Trans A, Vol 19A, (1988) p 627-636 + TRITA 0207 (1986); C-CR-FE' + 324 'Byeong-Joo Lee, Metall. Trans. 24A (1993) 1017-1025; Fe-Cr-Mn-C' + 103 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 + TRITA 0270 (1986); CR-FE' + 338 'Caian Qiu, ISIJ International 32 (1992) 1117-1127; C-Cr-Fe-Mo' + 203 'P. Gustafson, Metall. Trans. 19A(1988) p 2547-2554, + TRITA-MAC 348, (1987); C-CR-FE-W' + 122 'K. Frisk, Metall. Trans. Vol 21A (1990) p 2477-2488, + TRITA 0409 (1989); CR-FE-N' + 341 'Caian Qiu, Metall. Trans. A, 24A (1993) 2393-2409; Cr-Fe-Mn-N' + 342 'K. Frisk, Calphad 17 (1993) 335-349; Cr-Mn-N' + 325 'Byeong-Joo Lee, KRISS, unpublished research, during 1993-1995' + ! + diff --git a/TQ3lib-clean/isoC-matthias/FENI.TDB b/TQ3lib-clean/isoC-matthias/FENI.TDB new file mode 100644 index 0000000..c3133fa --- /dev/null +++ b/TQ3lib-clean/isoC-matthias/FENI.TDB @@ -0,0 +1,105 @@ +$ Database file written 2014- 1-15 +$ From database: SSOL2 + ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! + ELEMENT NI FCC_A1 5.8690E+01 4.7870E+03 2.9796E+01! + + + FUNCTION GFELIQ 298.15 +12040.17-6.55843*T-3.6751551E-21*T**7 + +GHSERFE#; 1.81100E+03 Y + -10839.7+291.302*T-46*T*LN(T); 6000 N ! + FUNCTION GHSERFE 298.15 +1225.7+124.134*T-23.5143*T*LN(T) + -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y + -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6000 N ! + FUNCTION GNIBCC 298.15 +8715.084-3.556*T+GHSERNI#; 6000 N ! + FUNCTION GFEFCC 298.15 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 + +GHSERFE#; 1.81100E+03 Y + -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6000 N ! + FUNCTION GHSERNI 298.15 -5179.159+117.854*T-22.096*T*LN(T) + -.0048407*T**2; 1.72800E+03 Y + -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3.00000E+03 N ! + FUNCTION GPFELIQ 298.15 7E-6*P; 6000 N ! + FUNCTION GPFEFCC 298.15 5E-6*P; 6000 N ! + FUNCTION GPFEBCC 298.15 6E-6*P; 6000 N ! + FUNCTION GPNILIQ 298.15 8E-6*P; 6000 N ! + FUNCTION GPNIFCC 298.15 6E-6*P; 6000 N ! + FUNCTION GPNIBCC 298.15 7E-6*P; 6000 N ! +$ this is 1/RT + FUNCTION IQRT 298.15 0.12027167*T**(-1); 6000 N ! + + TYPE_DEFINITION % SEQ *! + DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! + DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! + + + PHASE LIQUID:L % 1 1.0 ! + CONSTITUENT LIQUID:L :FE,NI : ! + + PARAMETER G(LIQUID,FE;0) 298.15 +GFELIQ#+GPFELIQ#; 6000 N REF283 ! + PARAMETER G(LIQUID,NI;0) 298.15 +11235.527+108.457*T + -22.096*T*LN(T)-.0048407*T**2-3.82318E-21*T**7+GPNILIQ; 1.72800E+03 Y + -9549.775+268.598*T-43.1*T*LN(T)+GPNILIQ; 3.00000E+03 N REF283 ! + PARAMETER G(LIQUID,FE,NI;0) 298.15 -18378.86+6.03912*T; 6000 N REF158 ! + PARAMETER G(LIQUID,FE,NI;1) 298.15 +9228.1-3.54642*T; 6000 N REF158 ! +$ LN(mobilities) + PARAMETER MQ&FE(LIQUID,FE;0) 298.15 -10000*IQRT-18; 6000 N BOS ! + PARAMETER MQ&FE(LIQUID,NI;0) 298.15 -12000*IQRT-19; 6000 N BOS ! + PARAMETER MQ&NI(LIQUID,NI;0) 298.15 -11000*IQRT-18; 6000 N BOS ! + PARAMETER MQ&NI(LIQUID,FE;0) 298.15 -13000*IQRT-19; 6000 N BOS ! + + + TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! +$ PHASE BCC_A2 %& 2 1 3 ! +$ CONSTITUENT BCC_A2 :FE%,NI : VA% : ! + + PARAMETER G(BCC_A2,FE:VA;0) 298.15 +GHSERFE#+GPFEBCC#; 6000 N REF283 ! + PARAMETER TC(BCC_A2,FE:VA;0) 298.15 1043; 6000 N REF281 ! + PARAMETER BMAGN(BCC_A2,FE:VA;0) 298.15 2.22; 6000 N REF281 ! + PARAMETER G(BCC_A2,NI:VA;0) 298.15 +GNIBCC#+GPNIBCC; 3000 N REF283 ! + PARAMETER TC(BCC_A2,NI:VA;0) 298.15 575; 6000 N REF281 ! + PARAMETER BMAGN(BCC_A2,NI:VA;0) 298.15 .85; 6000 N REF281 ! + PARAMETER G(BCC_A2,FE,NI:VA;0) 298.15 -956.63-1.28726*T; 6000 N REF158 ! + PARAMETER G(BCC_A2,FE,NI:VA;1) 298.15 +1789.03-1.92912*T; 6000 N REF158 ! +$ LN(mobilities) + PARAMETER MQ&FE(BCC_A2,FE:VA;0) 298.15 -20000*IQRT-24; 6000 N BOS ! + PARAMETER MQ&FE(BCC_A2,NI:VA;0) 298.15 -22000*IQRT-24; 6000 N BOS ! + PARAMETER MQ&NI(BCC_A2,NI:VA;0) 298.15 -25000*IQRT-25; 6000 N BOS ! + PARAMETER MQ&NI(BCC_A2,FE:VA;0) 298.15 -28000*IQRT-25; 6000 N BOS ! + + TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! + PHASE FCC_A1 %' 2 1 1 ! + CONSTITUENT FCC_A1 :FE%,NI% : VA% : ! + + PARAMETER G(FCC_A1,FE:VA;0) 298.15 +GFEFCC#+GPFEFCC#; 6000 N REF283 ! + PARAMETER TC(FCC_A1,FE:VA;0) 298.15 -201; 6000 N REF281 ! + PARAMETER BMAGN(FCC_A1,FE:VA;0) 298.15 -2.1; 6000 N REF281 ! + PARAMETER G(FCC_A1,NI:VA;0) 298.15 +GHSERNI#+GPNIFCC; 3000 N REF283 ! + PARAMETER TC(FCC_A1,NI:VA;0) 298.15 633; 6000 N REF281 ! + PARAMETER BMAGN(FCC_A1,NI:VA;0) 298.15 .52; 6000 N REF281 ! + PARAMETER G(FCC_A1,FE,NI:VA;0) 298.15 -12054.355+3.27413*T; 6000 N REF158 ! + PARAMETER G(FCC_A1,FE,NI:VA;1) 298.15 +11082.1315-4.45077*T; 6000 N REF158 ! + PARAMETER G(FCC_A1,FE,NI:VA;2) 298.15 -725.805174; 6000 N REF158 ! + PARAMETER TC(FCC_A1,FE,NI:VA;0) 298.15 2133; 6000 N REF158 ! + PARAMETER TC(FCC_A1,FE,NI:VA;1) 298.15 -682; 6000 N REF158 ! + PARAMETER BMAGN(FCC_A1,FE,NI:VA;0) 298.15 9.55; 6000 N REF158 ! + PARAMETER BMAGN(FCC_A1,FE,NI:VA;1) 298.15 7.23; 6000 N REF158 ! + PARAMETER BMAGN(FCC_A1,FE,NI:VA;2) 298.15 5.93; 6000 N REF158 ! + PARAMETER BMAGN(FCC_A1,FE,NI:VA;3) 298.15 6.18; 6000 N REF158 ! +$ LN(mobilities) + PARAMETER MQ&FE(FCC_A1,FE:VA;0) 298.15 -30000*IQRT-30; 6000 N BOS ! + PARAMETER MQ&FE(FCC_A1,NI:VA;0) 298.15 -32000*IQRT-32; 6000 N BOS ! + PARAMETER MQ&NI(FCC_A1,NI:VA;0) 298.15 -33000*IQRT-32; 6000 N BOS ! + PARAMETER MQ&NI(FCC_A1,FE:VA;0) 298.15 -25000*IQRT-31; 6000 N BOS ! + + LIST_OF_REFERENCES + NUMBER SOURCE + REF283 'Alan Dinsdale, SGTE Data for Pure Elements, + Calphad Vol 15(1991) p 317-425, + also in NPL Report DMA(A)195 Rev. August 1990' + REF158 'A. Dinsdale, T. Chart, MTDS NPL, unpublished work (1986); FE-NI' + REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 + September 1989' + BOS 'Invented mobilities and molar volumes' + ! + diff --git a/TQ3lib-clean/isoC-matthias/Makefile b/TQ3lib-clean/isoC-matthias/Makefile new file mode 100644 index 0000000..3ab3cda --- /dev/null +++ b/TQ3lib-clean/isoC-matthias/Makefile @@ -0,0 +1,21 @@ +OBJS=liboctq.o liboctqisoc.o +EXE=tqintf +LIBS=../.. + +.PHONY : all clean + +all: + make $(EXE) + +clean: + rm -f *.o *.mod $(EXE) + +liboctq.o: ../liboctq.F90 + gfortran -c -g -fbounds-check -finit-local-zero -I$(LIBS) ../liboctq.F90 + +liboctqisoc.o: ../isoC/liboctqisoc.F90 + gfortran -c -g -fbounds-check -finit-local-zero -I$(LIBS) ../isoC/liboctqisoc.F90 + +$(EXE): $(OBJS) + gcc -o $(EXE) -lstdc++ $(EXE).cpp liboctqisoc.o liboctq.o ../../liboceq.a -lgfortran -lm + gcc -c -I../.. $(EXE).cpp diff --git a/TQ3lib-clean/isoC-matthias/liboctqisoc.F90 b/TQ3lib-clean/isoC-matthias/liboctqisoc.F90 new file mode 100644 index 0000000..a9431dc --- /dev/null +++ b/TQ3lib-clean/isoC-matthias/liboctqisoc.F90 @@ -0,0 +1,601 @@ +! +! Part of iso-C bining for OC TQlib from Teslos +! modified by Bo Sundman +! +MODULE cstr +! convert characters from Fortran to C and vice versa +contains + function c_to_f_string(s) result(str) + use iso_c_binding + implicit none + character(kind=c_char,len=1), intent(in) :: s(*) + character(len=:), allocatable :: str + integer i, nchars + i = 1 + do + if (s(i) == c_null_char) exit + i = i + 1 + end do + nchars = i - 1 ! Exclude null character from Fortran string + allocate(character(len=nchars) :: str) + str = transfer(s(1:nchars), str) + end function c_to_f_string + + subroutine f_to_c_string(fstring, cstr) + use iso_c_binding + implicit none + character(len=24) :: fstring + character(kind=c_char, len=1), intent(out) :: cstr(*) + integer i + do i = 1, len(fstring) + cstr(i) = fstring(i:i) + cstr(i+1) = c_null_char + end do + end subroutine f_to_c_string + +end module cstr + +module liboctqisoc +! +! OCTQlib with iso-C binding +! + use iso_c_binding + use cstr + use liboctq +! use general_thermodynamic_package + implicit none + + integer(c_int), bind(c) :: c_nel + integer(c_int), bind(c) :: c_maxc=20, c_maxp=100 + type(c_ptr), bind(c), dimension(maxc) :: c_cnam + character(len=25), dimension(maxc), target :: cnames + integer(c_int), bind(c) :: c_ntup + + TYPE, bind(c) :: c_gtp_equilibrium_data +! this contains all data specific to an equilibrium like conditions, +! status, constitution and calculated values of all phases etc +! Several equilibria may be calculated simultaneously in parallell threads +! so each equilibrium must be independent +! NOTE: the error code must be local to each equilibria!!!! +! During step and map these records with results are saved +! values of T and P, conditions etc. +! Values here are normally set by external conditions or calculated from model +! local list of components, phase_varres with amounts and constitution +! lists of element, species, phases and thermodynamic parameters are global +! tpval(1) is T, tpval(2) is P, rgas is R, rtn is R*T +! status: not used yet? +! multiuse: used for various things like direction in start equilibria +! eqno: sequential number assigned when created +! next: index of next equilibrium in a sequence during step/map calculation. +! eqname: name of equilibrium +! tpval: value of T and P +! rtn: value of R*T + integer(c_int) :: status,multiuse,eqno,next + character(c_char) :: eqname*24 + real(c_double) :: tpval(2),rtn +! svfunres: the values of state variable functions valid for this equilibrium + type(c_ptr) :: svfunres +! the experiments are used in assessments and stored like conditions +! lastcondition: link to condition list +! lastexperiment: link to experiment list + TYPE(c_ptr) :: lastcondition,lastexperiment +! components and conversion matrix from components to elements +! complist: array with components +! compstoi: stoichiometric matrix of compoents relative to elements +! invcompstoi: inverted stoichiometric matrix + TYPE(c_ptr) :: complist + real(c_double) :: compstoi + real(c_double) :: invcompstoi +! one record for each phase+composition set that can be calculated +! phase_varres: here all calculated data for the phase is stored + TYPE(c_ptr) :: phase_varres +! index to the tpfun_parres array is the same as in the global array tpres +! eq_tpres: here local calculated values of TP functions are stored + TYPE(c_ptr) :: eq_tpres +! current values of chemical potentials stored in component record but +! duplicated here for easy acces by application software + real(c_double) :: cmuval +! xconc: convergence criteria for constituent fractions and other things + real(c_double) :: xconv +! delta-G value for merging gridpoints in grid minimizer +! smaller value creates problem for test step3.BMM, MC and austenite merged + real(c_double) :: gmindif=-5.0D-2 +! maxiter: maximum number of iterations allowed + integer(c_int) :: maxiter +! this is to save a copy of the last calculated system matrix, needed +! to calculate dot derivatives, initiate to zero + integer(c_int) :: sysmatdim=0,nfixmu=0,nfixph=0 + integer(c_int) :: fixmu + integer(c_int) :: fixph + real(c_double) :: savesysmat + END TYPE c_gtp_equilibrium_data + +contains + +! functions + integer function c_noofcs(iph) bind(c, name='c_noofcs') + integer(c_int), value :: iph + c_noofcs = noofcs(iph) + return + end function c_noofcs + + subroutine examine_gtp_equilibrium_data(c_ceq) & + bind(c, name='examine_gtp_equilibrium_data') + type(c_ptr), intent(in), value :: c_ceq + type(gtp_equilibrium_data), pointer :: ceq + integer :: i,j + call c_f_pointer(c_ceq, ceq) + write(*,10) ceq%status, ceq%multiuse, ceq%eqno +10 format(/'gtp_equilibrium_data: status, multiuse, eqno, next'/, 3i4) + write(*,20) ceq%eqname +20 format(/'Name of equilibrium'/,a) + write(*,30) ceq%tpval, ceq%rtn +30 format(/'Value of T and P'/, 2f8.3, /'R*T'/, f8.4) + do i = 1, size(ceq%compstoi,1) + write(*,*) (ceq%compstoi(i,j), j=1,size(ceq%compstoi,2)) + end do + write(*,*) ceq%cmuval + write(*,*) ceq%xconv + write(*,*) ceq%gmindif + write(*,*) ceq%maxiter + write(*,*) ceq%sysmatdim, ceq%nfixmu, ceq%nfixph + write(*,*) ceq%fixmu, ceq%fixph, ceq%savesysmat + end subroutine examine_gtp_equilibrium_data + +!\begin{verbatim} + subroutine c_tqini(n, c_ceq) bind(c, name='c_tqini') + integer(c_int), intent(in) :: n + type(c_ptr), intent(out) :: c_ceq +!\end{verbatim} + type(gtp_equilibrium_data), pointer :: ceq + integer :: i1,i2 + + call tqini(n, ceq) + c_ceq = c_loc(ceq) + end subroutine c_tqini + +!\begin{verbatim} + subroutine c_tqrfil(filename,c_ceq) bind(c, name='c_tqrfil') + character(kind=c_char,len=1), intent(in) :: filename(*) + character(len=:), allocatable :: fstring + type(gtp_equilibrium_data), pointer :: ceq + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + integer :: i,j,l + character(kind=c_char, len=1),dimension(24), target :: f_pointers +! convert type(c_ptr) to fptr + call c_f_pointer(c_ceq, ceq) + fstring = c_to_f_string(filename) + call tqrfil(fstring, ceq) +! after tqrfil ntup variable is defined + c_ntup = ntup + c_nel = nel + do i = 1, nel + cnames(i) = trim(cnam(i)) // c_null_char + c_cnam(i) = c_loc(cnames(i)) + end do + c_ceq = c_loc(ceq) + end subroutine c_tqrfil + +!\begin{verbatim} + subroutine c_tqrpfil(filename,nel,c_selel,c_ceq) bind(c, name='c_tqrpfil') + character(kind=c_char), intent(in) :: filename + integer(c_int), intent(in), value :: nel + type(c_ptr), intent(in), dimension(nel), target :: c_selel + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + type(gtp_equilibrium_data), pointer :: ceq + character(len=:), allocatable :: fstring + character, pointer :: selel(:) + integer :: i + character elem(nel)*2 + fstring = c_to_f_string(filename) + call c_f_pointer(c_ceq, ceq) +! convert the c type selel strings to f-selel strings +! note: additional character is for C terminated '\0' + do i = 1, nel + call c_f_pointer(c_selel(i), selel, [3]) + elem(i) = c_to_f_string(selel) + end do + call tqrpfil(fstring, nel, elem, ceq) +! after tqrpfil ntup variable is defined + c_ntup = ntup + c_nel = nel + do i = 1, nel + cnames(i) = trim(cnam(i)) // c_null_char + c_cnam(i) = c_loc(cnames(i)) + end do + c_ceq = c_loc(ceq) + end subroutine c_tqrpfil + +!\begin{verbatim} + subroutine c_tqgcom(n,components,c_ceq) bind(c, name='c_tqgcom') +! get system components + integer(c_int), intent(inout) :: n + !character(kind=c_char, len=24), dimension(24), intent(out) :: c_components + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + integer, target :: nc + character(len=24) :: fcomponents(maxel) + character(kind=c_char, len=1), dimension(maxel*24) :: components + type(gtp_equilibrium_data), pointer :: ceq + integer :: i,j,l + call c_f_pointer(c_ceq, ceq) + call tqgcom(nc, fcomponents, ceq) +! convert the F components strings to C + l = len(fcomponents(1)) + do i = 1, nc + do j = 1, l + components((i-1)*l+j)(1:1) = fcomponents(i)(j:j) + end do +! null termination + components(i*l) = c_null_char + end do + c_ceq = c_loc(ceq) + n = nc + end subroutine c_tqgcom + +!\begin{verbatim} + subroutine c_tqgnp(n, c_ceq) bind(c, name='c_tqgnp') + integer(c_int), intent(inout) :: n + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + type(gtp_equilibrium_data), pointer :: ceq + call c_f_pointer(c_ceq, ceq) + call tqgnp(n, ceq) + c_ceq = c_loc(ceq) + end subroutine c_tqgnp + +!\begin{verbatim} + subroutine c_tqgpn(n,phasename, c_ceq) bind(c, name='c_tqgpn') +! get name of phase n, +! NOTE: n is phase number, not extended phase index + integer(c_int), intent(in), value :: n + character(kind=c_char, len=1), intent(inout) :: phasename(24) + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + type(gtp_equilibrium_data), pointer :: ceq + character(len=24) :: fstring + integer :: i + call c_f_pointer(c_ceq, ceq) +! fstring = c_to_f_string(phasename) + call tqgpn(n, fstring, ceq) +! copy the f-string to c-string and end with '\0' + do i=1,len(trim(fstring)) + phasename(i)(1:1) = fstring(i:i) + phasename(i+1)(1:1) = c_null_char + end do + c_ceq = c_loc(ceq) + end subroutine c_tqgpn + +!\begin{verbatim} + subroutine c_tqgpi(n,phasename,c_ceq) bind(c, name='c_tqgpi') +! get index of phase phasename + integer(c_int), intent(out) :: n + character(c_char), intent(in) :: phasename(24) + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + type(gtp_equilibrium_data), pointer :: ceq + character(len=24) :: fstring + call c_f_pointer(c_ceq, ceq) + fstring = c_to_f_string(phasename) + call tqgpi(n, fstring, ceq) + c_ceq = c_loc(ceq) + end subroutine c_tqgpi + +!\begin{verbatim} + subroutine c_tqgpcn(n, c, constituentname, c_ceq) bind(c, name='c_tqgpcn') +! get name of constitutent c in phase n + integer(c_int), intent(in) :: n ! phase number + integer(c_int), intent(in) :: c ! extended constituent index: +! 10*species_number + sublattice + character(c_char), intent(out) :: constituentname(24) + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + write(*,*) 'tqgpcn not implemented yet' + end subroutine c_tqgpcn + +!\begin{verbatim} + subroutine c_tqgpci(n,c, constituentname, c_ceq) bind(c, name='c_tqgpci') +! get index of constituent with name in phase n + integer(c_int), intent(in) :: n + integer(c_int), intent(out) :: c ! exit: extended constituent index: +! 10*species_number+sublattice + character(c_char), intent(in) :: constituentname(24) + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + type(gtp_equilibrium_data), pointer :: ceq + character(len=24) :: fstring + fstring = c_to_f_string(constituentname) + call c_f_pointer(c_ceq, ceq) + call tqgpci(n, c, fstring, ceq) + c_ceq = c_loc(ceq) + end subroutine c_tqgpci + +!\begin{verbatim} + subroutine c_tqgpcs(n, c, stoi, mass, c_ceq) bind(c, name='c_tqgpcs') +!get stoichiometry of constituent c in phase n +!? missing argument number of elements???? + integer(c_int), intent(in) :: n + integer(c_int), intent(in) :: c ! in: extended constituent index: +! 10*species_number + sublattice + real(c_double), intent(out) :: stoi(*) ! exit: stoichiometry of elements + real(c_double), intent(out) :: mass ! exit: total mass + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + type(gtp_equilibrium_data), pointer :: ceq + call c_f_pointer(c_ceq, ceq) + call tqgpcs(n,c,stoi,mass,ceq) + c_ceq=c_loc(ceq) + end subroutine c_tqgpcs + +!\begin{verbatim} + subroutine c_tqgccf(n1,n2,elnames,stoi,mass,c_ceq) +! get stoichiometry of component n1 +! n2 is number of elements ( dimension of elements and stoi ) + integer(c_int), intent(in) :: n1 ! in: component number + integer(c_int), intent(out) :: n2 ! exit: number of elements in component + character(c_char), intent(out) :: elnames(2) ! exit: element symbols + real(c_double), intent(out) :: stoi(*) ! exit: element stoichiometry + real(c_double), intent(out) :: mass ! exit: component mass +! (sum of element mass) + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + type(gtp_equilibrium_data), pointer :: ceq + call c_f_pointer(c_ceq, ceq) + call tqgccf(n1,n2,elnames,stoi, mass, ceq) + c_ceq = c_loc(ceq) + end subroutine c_tqgccf + +!\begin{verbatim} + subroutine c_tqgnpc(n,c,c_ceq) bind(c, name='c_tqgnpc') +! get number of constituents of phase n + integer(c_int), intent(in) :: n ! in: phase number + integer(c_int), intent(out) :: c ! exit: number of constituents + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + type(gtp_equilibrium_data), pointer :: ceq + call c_f_pointer(c_ceq,ceq) + call tqgnpc(n,c,ceq) + c_ceq = c_loc(ceq) + end subroutine c_tqgnpc + +!\begin{verbatim} + subroutine c_tqsetc(statvar, n1, n2, mvalue, cnum, c_ceq) & + bind(c, name='c_tqsetc') +! set condition +! stavar is state variable as text +! n1 and n2 are auxilliary indices +! value is the value of the condition +! cnum is returned as an index of the condition. +! to remove a condition the value sould be equial to RNONE ???? +! when a phase indesx is needed it should be 10*nph + ics +! SEE TQGETV for doucumentation of stavar etc. +!>>>> to be modified to use phase tuplets + integer(c_int), intent(in),value :: n1 !in: 0 or extended phase index: +! 10*phase_number+comp.set + ! or component set + integer(c_int), intent(in),value :: n2 ! + integer(c_int), intent(out) :: cnum !exit: +! sequential number of this condition + character(c_char), intent(in) :: statvar !in: character +! with state variable symbol + real(c_double), intent(in), value :: mvalue !in: value of condition + type(gtp_equilibrium_data), pointer :: ceq + type(c_ptr), intent(inout) :: c_ceq ! in: current equilibrium +!\end{verbatim} + call c_f_pointer(c_ceq, ceq) + call tqsetc(statvar, n1, n2, mvalue, cnum, ceq) + c_ceq = c_loc(ceq) + end subroutine c_tqsetc + +!\begin{verbatim} + subroutine c_tqce(mtarget,n1,n2,mvalue,c_ceq) bind(c,name='c_tqce') +! calculate equilibrium with possible target +! Target can be empty or a state variable with indicies n1 and n2 +! value is the calculated value of target + integer(c_int), intent(in),value :: n1 + integer(c_int), intent(in),value :: n2 + type(c_ptr), intent(inout) :: c_ceq + character(c_char), intent(inout) :: mtarget + real(c_double), intent(inout) :: mvalue + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + character(len=24) :: fstring + call c_f_pointer(c_ceq,ceq) + fstring = c_to_f_string(mtarget) + call tqce(fstring,n1,n2,mvalue,ceq) + c_ceq = c_loc(ceq) + end subroutine c_tqce + +!\begin{verbatim} + subroutine c_tqgetv(statvar,n1,n2,n3,values,c_ceq) bind(c,name='c_tqgetv') +! get equilibrium results using state variables +! stavar is the state variable IN CAPITAL LETTERS with indices n1 and n2 +! n3 at the call is the dimension of values, changed to number of values +! value is the calculated value, it can be an array with n3 values. + implicit none + integer(c_int), intent(in), value :: n1,n2 + integer(c_int), intent(inout) :: n3 + character(c_char), intent(in) :: statvar + real(c_double), intent(inout) :: values(*) + type(c_ptr), intent(inout) :: c_ceq !IN: current equilibrium +!======================================================== +! >>>> implement use of phase tuples +! stavar must be a symbol listed below +! IMPORTANT: some terms explained after the table +! Symbol index1,index2 Meaning (unit) +!.... potentials +! T 0,0 Temperature (K) +! P 0,0 Pressure (Pa) +! MU component,0 or phase-tuple*1,constituent*2 Chemical potential (J) +! AC component,0 or phase-tuple,constituent Activity = EXP(MU/RT) +! LNAC component,0 or phase-tuple,constituent LN(activity) = MU/RT +!...... extensive variables +! U 0,0 or phase-tuple,0 Internal energy (J) whole system or phase +! UM 0,0 or phase-tuple,0 same per mole components +! UW 0,0 or phase-tuple,0 same per kg +! UV 0,0 or phase-tuple,0 same per m3 +! UF phase-tuple,0 same per formula unit of phase +! S*3 0,0 or phase-tuple,0 Entropy (J/K) +! V 0,0 or phase-tuple,0 Volume (m3) +! H 0,0 or phase-tuple,0 Enthalpy (J) +! A 0,0 or phase-tuple,0 Helmholtz energy (J) +! G 0,0 or phase-tuple,0 Gibbs energy (J) +! ..... some extra state variables +! NP phase-tuple,0 Moles of phase +! BP phase-tuple,0 Mass of moles (kg) +! Q phase-tuple,0 Internal stability/RT (dimensionless) +! DG phase-tuple,0 Driving force/RT (dimensionless) +!....... amounts of components +! N 0,0 or component,0 or phase-tuple,component Moles of component +! X component,0 or phase-tuple,component Mole fraction of component +! B 0,0 or component,0 or phase-tuple,component Mass of component +! W component,0 or phase-tuple,component Mass fraction of component +! Y phase-tuple,constituent*1 Constituent fraction +!........ some parameter identifiers +! TC phase-tuple,0 Magnetic ordering temperature +! BMAG phase-tuple,0 Aver. Bohr magneton number +! MQ& phase-tuple,constituent Mobility +! THET phase-tuple,0 Debye temperature +! LNX phase-tuple,0 Lattice parameter +! EC11 phase-tuple,0 Elastic constant C11 +! EC12 phase-tuple,0 Elastic constant C12 +! EC44 phase-tuple,0 Elastic constant C44 +!........ NOTES: +! *1 The phase-tuple is is structure with 2 integers: phase and comp.set +! *2 The constituent index is 10*species_number + sublattice_number +! *3 S, V, H, A, G, NP, BP, N, B and DG can have suffixes M, W, V, F also +!-------------------------------------------------------------------- +! special addition for TQ interface: d2G/dyidyj +! D2G + extended phase index +!------------------------------------ + type(gtp_equilibrium_data), pointer :: ceq + character(len=24) :: fstring + integer :: n + integer :: i + call c_f_pointer(c_ceq, ceq) +! debug ... +! call list_conditions(6,ceq) +! call list_phase_results(1,1,0,6,ceq) +! write(*,*)'Phase and error code: ',1,gx%bmperr +! call list_phase_results(2,1,0,6,ceq) +! write(*,*)'Phase and error code: ',2,gx%bmperr +! write(*,*) +! end debug + fstring = c_to_f_string(statvar) + call tqgetv(fstring, n1, n2, n3, values, ceq) +! debug ... +! write(*,55)fstring(1:len_trim(fstring)),n1,n2,n3,(values(i),i=1,n3) +!55 format(/'From c_tqgetv: ',a,': ',3i3,6(1pe12.4)) +! write(*,*) +! end debug + c_ceq = c_loc(ceq) + end subroutine c_tqgetv + +!\begin{verbatim} + subroutine c_tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,c_ceq)& + bind(c,name='c_tqgphc1') +! tq_get_phase_constitution +! This subroutine returns the sublattices and constitution of a phase +! n1 is phase tuple index +! nsub is the number of sublattices (1 if no sublattices) +! cinsub is an array with the number of const\EDtuents in each sublattice +! spix is an array with the species index of the constituents in all sublattices +! sites is an array of the site ratios for all sublattices. +! yfrac is the constituent fractions in same order as in spix +! extra is an array with some extra values: +! extra(1) is the number of moles of components per formula unit +! extra(2) is the net charge of the phase + implicit none + !integer n1,nsub,cinsub(*),spix(*) + integer(c_int), intent(in), value :: n1 + integer(c_int), intent(out) :: nsub + integer(c_int), intent(out) :: cinsub(*) + integer(c_int), intent(in) :: spix(*) + !double precision sites(*),yfrac(*),extra(*) + real(c_double), intent(in) :: sites(*) + real(c_double), intent(in) :: yfrac(*) + real(c_double), intent(in) :: extra(*) + !type(gtp_equilibrium_data), pointer :: ceq + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + type(gtp_equilibrium_data), pointer :: ceq + call c_f_pointer(c_ceq, ceq) + !call tqgphc1(n1,nsub2,cinsub2,spix2,yfrac2,sites2,extra2,ceq) + call tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,ceq) + c_ceq = c_loc(ceq) + end subroutine c_tqgphc1 + +!\begin{verbatim} + subroutine c_tqsphc1(n1,yfra,extra,c_ceq) bind(c,name='c_tqsphc1') +! tq_set_phase_constitution +! To set the constitution of a phase +! n1 is phase tuple index +! yfra is an array with the constituent fractions in all sublattices +! in the same order as obtained by tqgphc1 +! extra is an array with returned values with the same meaning as in tqgphc1 +! NOTE The constituents fractions are normallized to sum to unity for each +! sublattice and extra is calculated by tqsphc1 +! T and P must be set as conditions. + implicit none + integer(c_int), intent(in), value :: n1 + real(c_double), intent(in) ::yfra(*) + real(c_double), intent(out) :: extra(*) + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + type(gtp_equilibrium_data), pointer :: ceq + call c_f_pointer(c_ceq, ceq) + call set_constitution(phcs(n1)%phase,phcs(n1)%compset,& + yfra,extra,ceq) + c_ceq = c_loc(ceq) + end subroutine c_tqsphc1 + +!\begin{verbatim} + subroutine c_tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,c_ceq) bind(c,name='c_tqcph1') +! tq_calculate_phase_properties +!vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +! WARNIG: this is not a subroutine to calculate chemical potentials +! those can only be made by an equilibrium calculation. +! The values returned are partial derivatives of G for the phase at the +! current T, P and phase constitution. The phase constitution has been +! obtained by a previous equilibrium calculation or +! set by the subroutine tqsphc +! It corresponds to the "calculate phase" command. +! +! NOTE that values are per formula unit divided by RT, +! divide also by extra(1) in subroutine tqsphc1 to get them per mole component +! +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! calculate G and some or all derivatives for a phase at current composition +! n1 is the phase tuple index +! n2 is 0 if only G and derivatves wrt T and P, 1 also first drivatives wrt +! compositions, 2 if also 2nd derivatives +! n3 is returned as number of constituents (dimension of returned arrays) +! gtp is an array with G, G.T, G:P, G.T.T, G.T.P and G.P.P +! dgdy is an array with G.Yi +! d2gdydt is an array with G.T.Yi +! d2gdydp is an array with G.P.Yi +! d2gdy2 is an array with the upper triangle of the symmetrix matrix G.Yi.Yj +! reurned in the order: 1,1; 1,2; 1,3; ... +! 2,2; 2,3; ... +! 3,3; ... +! for indexing one can use the integer function ixsym(i1,i2) + implicit none + integer(c_int), intent(in), value :: n1 + integer(c_int), intent(in), value :: n2 + integer(c_int), intent(out) :: n3 + real(c_double), intent(out) :: gtp(6) + real(c_double), intent(out) :: dgdy(*) + real(c_double), intent(out) :: d2gdydt(*) + real(c_double), intent(out) :: d2gdydp(*) + real(c_double), intent(out) :: d2gdy2(*) + type(c_ptr), intent(inout) :: c_ceq +!\end{verbatim} + type(gtp_equilibrium_data), pointer :: ceq + call c_f_pointer(c_ceq, ceq) + call tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,ceq) + c_ceq = c_loc(ceq) + end subroutine c_tqcph1 + +end module liboctqisoc diff --git a/TQ3lib-clean/isoC-matthias/linkmake.txt b/TQ3lib-clean/isoC-matthias/linkmake.txt new file mode 100644 index 0000000..84841a7 --- /dev/null +++ b/TQ3lib-clean/isoC-matthias/linkmake.txt @@ -0,0 +1,15 @@ +copy ..\..\liboceq.a . + +copy ..\..\liboceq.mod . + +copy ..\liboctq.F90 . + +gfortran -c liboctq.F90 + +gfortran -c liboctqisoc.F90 + +# gcc -o tqintf -lstdc++ tqintf.cpp liboctqisoc.o liboctq.o liboceq.a -lgfortran -lm +# gcc -c -I../.. $(EXE).cpp + +g++ -o tqintf -lstdc++ tqintf.cpp liboctqisoc.o liboctq.o liboceq.a -lgfortran -lm + diff --git a/TQ3lib-clean/isoC-matthias/octqc.h b/TQ3lib-clean/isoC-matthias/octqc.h new file mode 100644 index 0000000..0148377 --- /dev/null +++ b/TQ3lib-clean/isoC-matthias/octqc.h @@ -0,0 +1,92 @@ +#if !defined __OCTQC__ +#define __OCTQC__ + +typedef struct { + int statevarid, norm, unit, phref, argtyp; + int phase, compset, component, constituent; + double coeff; + int oldstv; +} gtp_state_variable; + +struct gtp_fraction_set; + +typedef struct { + int nextfree, phlink, status2, phstate; + double abnorm[2]; + char prefix[4], suffix[4]; + int *constat; + double *yfr; + double *mmyfr; + double *sites; + double *dpqdy; + double *d2pqdvay; + //struct gtp_fraction_set disfra; + double amfu, netcharge, dgm, amcom, damount; + int nprop, ncc; + int *listprop; + double **gval; + double ***dgval; + double **d2gval; + double curlat[3][3]; + double **cinvy; + double *cxmol; + double **cdxmol; +} gtp_phase_varres; + +typedef struct gtp_fraction_set { + int latd, ndd, tnoofxfr, tnoofyfr, varreslink, totdis; + char id; + double *dsites; + int *nooffr; + int *splink; + int *y2x; + double *dxidyj; + double fsites; + gtp_phase_varres *phdapointer; +} gtp_fraction_set; + +typedef struct { + int splink, phlink, status; + char refstate[16]; + int endmember; + double tpref[2]; + double chempot[2]; + double mass, molat; +} gtp_components; + +typedef struct gtp_condition { + int noofterms, statev, active, iunit, nid, iref, seqz; + int symlink1, symlink2; + int **indices; + double *condcoeff; + double *prescribed, current, uncertainity; + struct gtp_condition *next, *previous; + gtp_state_variable *statvar; +} gtp_condition; + +typedef struct { + double tpused[2]; + double results[6]; +} tpfun_parres; + +typedef struct { + int status, multiuse, eqno, next; + char eqname[24]; + double tpval[2], rtn; + double *svfunres; + gtp_condition *lastcondition, *lastexperiment; + gtp_components *complist, **compstoi, **invcompstoi; + gtp_phase_varres *phase_varres; + tpfun_parres *eq_tpres; + double *cmuval; + double xconv; + double gmindif; + int maxiter; + int sysmatdim, nfixmu, nfixph; + int *fixmu; + int *fixph; + double **savesysmat; +} gtp_equilibrium_data; + +#endif + diff --git a/TQ3lib-clean/isoC-matthias/readme.txt b/TQ3lib-clean/isoC-matthias/readme.txt new file mode 100644 index 0000000..b5e3486 --- /dev/null +++ b/TQ3lib-clean/isoC-matthias/readme.txt @@ -0,0 +1,18 @@ +This is an advanced C++ example using TQ with isoC binding to Fortran + +First copy the liboceq.a and liboceq.mov here + +Then copy liboctq.F90 here + +Then compile gfortran -c liboctq.F90 + +Then compile gfortran -c liboctqisoc.F90 + +Then link and compile + +g++ -o tqintf -lstdc++ tqintf.cpp liboctqiso.o liboctq.o liboceq.a -lgfortran -lm + +All this on linkmake.txt which should be renamed to linkmake.cmd + + + diff --git a/TQ3lib-clean/isoC-matthias/steel1.TDB b/TQ3lib-clean/isoC-matthias/steel1.TDB new file mode 100644 index 0000000..c820294 --- /dev/null +++ b/TQ3lib-clean/isoC-matthias/steel1.TDB @@ -0,0 +1,1210 @@ + +$ Database file written 2012- 2-11 +$ From database: SSOL2 + ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7400E+00! + ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01! + ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! + ELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01! + ELEMENT SI DIAMOND_A4 2.8085E+01 3.2175E+03 1.8820E+01! + ELEMENT V BCC_A2 5.0941E+01 4.5070E+03 3.0890E+01! + + SPECIES C1 C! + SPECIES C2 C2! + SPECIES C3 C3! + SPECIES C4 C4! + SPECIES C5 C5! + SPECIES C6 C6! + SPECIES C7 C7! + SPECIES V1C1 V1C1! + + FUNCTION GHSERCC 2.98150E+02 -17368.441+170.73*T-24.3*T*LN(T) + -4.723E-04*T**2+2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3); + 6.00000E+03 N ! + FUNCTION GPCLIQ 2.98150E+02 +YCLIQ#*EXP(ZCLIQ#); 6.00000E+03 N ! + FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) + +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y + -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N ! + FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N ! + FUNCTION GFELIQ 2.98150E+02 +12040.17-6.55843*T-3.6751551E-21*T**7 + +GHSERFE#; 1.81100E+03 Y + -10839.7+291.302*T-46*T*LN(T); 6.00000E+03 N ! + FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N ! + FUNCTION GHSERMO 2.98150E+02 -7746.302+131.9197*T-23.56414*T*LN(T) + -.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4; + 2.89600E+03 Y + -30556.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9); + 5.00000E+03 N ! + FUNCTION GPMOLIQ 2.98150E+02 +YMOLIQ#*EXP(ZMOLIQ#); 6.00000E+03 N ! + FUNCTION GHSERSI 2.98150E+02 -8162.609+137.227259*T-22.8317533*T*LN(T) + -.001912904*T**2-3.552E-09*T**3+176667*T**(-1); 1.68700E+03 Y + -9457.642+167.271767*T-27.196*T*LN(T)-4.20369E+30*T**(-9); + 3.60000E+03 N ! + FUNCTION GHSERVV 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T) + -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y + -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; + 2.18300E+03 Y + -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); + 4.00000E+03 N ! + FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N ! + FUNCTION GPCGRA 2.98150E+02 +YCGRA#*EXP(ZCGRA#); 6.00000E+03 N ! + FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T) + -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y + -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N + ! + FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N ! + FUNCTION GSIBCC 2.98150E+02 +47000-22.5*T+GHSERSI#; 6.00000E+03 N ! + FUNCTION GPMOBCC 2.98150E+02 +YMOBCC#*EXP(ZMOBCC#); 6.00000E+03 N ! + FUNCTION GFECEM 2.98150E+02 -10745+706.04*T-120.6*T*LN(T)+GPCEM1#; + 6.00000E+03 N ! + FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N ! + FUNCTION GFEFCC 2.98150E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 + +GHSERFE#; 1.81100E+03 Y + -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N + ! + FUNCTION GMOFCC 2.98150E+02 +15200+.63*T+GHSERMO#; 6.00000E+03 N ! + FUNCTION GPCDIA 2.98150E+02 +YCDIA#*EXP(ZCDIA#); 6.00000E+03 N ! + FUNCTION GPCFCC 2.98150E+02 +YCFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! + FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! + FUNCTION GHSERVZ 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T) + -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y + -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; + 4.00000E+03 Y + -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); + 6.00000E+03 N ! + FUNCTION GPFEHCP 2.98150E+02 +YFEHCP#*EXP(ZFEHCP#); 6.00000E+03 N ! + FUNCTION GCRM23C6 2.98150E+02 -521983+3622.24*T-620.965*T*LN(T) + -.126431*T**2; 6.00000E+03 N ! + FUNCTION GFEM23C6 2.98150E+02 +7.666667*GFECEM#-1.666667*GHSERCC#+66920 + -40*T; 6.00000E+03 N ! + FUNCTION GVM23C6 2.98150E+02 -990367+4330.63*T-728.829*T*LN(T) + +5003425*T**(-1); 6.00000E+03 N ! + FUNCTION GCRM3C2 2.98150E+02 -100823.8+530.66989*T-89.6694*T*LN(T) + -.0301188*T**2; 6.00000E+03 N ! + FUNCTION GCRM7C3 2.98150E+02 -201690+1103.128*T-190.177*T*LN(T) + -.0578207*T**2; 6.00000E+03 N ! + FUNCTION GPMU1 2.98150E+02 +8.72E-05*P; 6.00000E+03 N ! + FUNCTION GPMU2 2.98150E+02 +1.04E-04*P; 6.00000E+03 N ! + FUNCTION GPR1 2.98150E+02 +3.81E-04*P; 6.00000E+03 N ! + FUNCTION GPR2 2.98150E+02 +4.33E-04*P; 6.00000E+03 N ! + FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N ! + FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N ! + FUNCTION L0BCC 2.98150E+02 -27809+11.62*T; 6.00000E+03 N ! + FUNCTION FESIW1 2.98150E+02 +1260*R#; 6.00000E+03 N ! + FUNCTION L1BCC 2.98150E+02 -11544; 6.00000E+03 N ! + FUNCTION L2BCC 2.98150E+02 3890; 6.00000E+03 N ! + FUNCTION ETCFESI 2.98150E+02 63; 6.00000E+03 N ! + FUNCTION YCLIQ 2.98150E+02 +VCLIQ#*EXP(-ECLIQ#); 6.00000E+03 N ! + FUNCTION ZCLIQ 2.98150E+02 +1*LN(XCLIQ#); 6.00000E+03 N ! + FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N ! + FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N ! + FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N ! + FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N ! + FUNCTION YMOLIQ 2.98150E+02 +VMOLIQ#*EXP(-EMOLIQ#); 6.00000E+03 N ! + FUNCTION ZMOLIQ 2.98150E+02 +1*LN(XMOLIQ#); 6.00000E+03 N ! + FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N ! + FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N ! + FUNCTION YCGRA 2.98150E+02 +VCGRA#*EXP(-ECGRA#); 6.00000E+03 N ! + FUNCTION ZCGRA 2.98150E+02 +1*LN(XCGRA#); 6.00000E+03 N ! + FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N ! + FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N ! + FUNCTION YMOBCC 2.98150E+02 +VMOBCC#*EXP(-EMOBCC#); 6.00000E+03 N ! + FUNCTION ZMOBCC 2.98150E+02 +1*LN(XMOBCC#); 6.00000E+03 N ! + FUNCTION GPCEM1 2.98150E+02 +VCEM1#*P; 6.00000E+03 N ! + FUNCTION YCDIA 2.98150E+02 +VCDIA#*EXP(-ECDIA#); 6.00000E+03 N ! + FUNCTION ZCDIA 2.98150E+02 +1*LN(XCDIA#); 6.00000E+03 N ! + FUNCTION YCFCC 2.98150E+02 +VCFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! + FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N ! + FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! + FUNCTION YFEHCP 2.98150E+02 +VFEHCP#*EXP(-EFEHCP#); 6.00000E+03 N ! + FUNCTION ZFEHCP 2.98150E+02 +1*LN(XFEHCP#); 6.00000E+03 N ! + FUNCTION VCLIQ 2.98150E+02 +7.626E-06*EXP(ACLIQ#); 6.00000E+03 N ! + FUNCTION ECLIQ 2.98150E+02 +1*LN(CCLIQ#); 6.00000E+03 N ! + FUNCTION XCLIQ 2.98150E+02 +1*EXP(.5*DCLIQ#)-1; 6.00000E+03 N ! + FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N + ! + FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N ! + FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N ! + FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 + N ! + FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N ! + FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 + N ! + FUNCTION VMOLIQ 2.98150E+02 +9.75079E-06*EXP(AMOLIQ#); 6.00000E+03 + N ! + FUNCTION EMOLIQ 2.98150E+02 +1*LN(CMOLIQ#); 6.00000E+03 N ! + FUNCTION XMOLIQ 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 + N ! + FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N + ! + FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N ! + FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N ! + FUNCTION VCGRA 2.98150E+02 +5.259E-06*EXP(ACGRA#); 6.00000E+03 N ! + FUNCTION ECGRA 2.98150E+02 +1*LN(CCGRA#); 6.00000E+03 N ! + FUNCTION XCGRA 2.98150E+02 +1*EXP(.9166667*DCGRA#)-1; 6.00000E+03 + N ! + FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 + N ! + FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N ! + FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 + N ! + FUNCTION VMOBCC 2.98150E+02 +9.34372E-06*EXP(AMOBCC#); 6.00000E+03 + N ! + FUNCTION EMOBCC 2.98150E+02 +1*LN(CMOBCC#); 6.00000E+03 N ! + FUNCTION XMOBCC 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 + N ! + FUNCTION VCEM1 2.98150E+02 +2.339E-05*EXP(ACEM1#); 6.00000E+03 N ! + FUNCTION VCDIA 2.98150E+02 +3.412E-06*EXP(ACDIA#); 6.00000E+03 N ! + FUNCTION ECDIA 2.98150E+02 +1*LN(CCDIA#); 6.00000E+03 N ! + FUNCTION XCDIA 2.98150E+02 +1*EXP(.8*DCDIA#)-1; 6.00000E+03 N ! + FUNCTION VCFCC 2.98150E+02 +1.031E-05*EXP(ACFCC#); 6.00000E+03 N ! + FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N ! + FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 + N ! + FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 + N ! + FUNCTION VFEHCP 2.98150E+02 +6.59121E-06*EXP(AFEHCP#); 6.00000E+03 + N ! + FUNCTION EFEHCP 2.98150E+02 +1*LN(CFEHCP#); 6.00000E+03 N ! + FUNCTION XFEHCP 2.98150E+02 +1*EXP(.8064454*DFEHCP#)-1; 6.00000E+03 + N ! + FUNCTION ACLIQ 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 + N ! + FUNCTION CCLIQ 2.98150E+02 1.6E-10; 6.00000E+03 N ! + FUNCTION DCLIQ 2.98150E+02 +1*LN(BCLIQ#); 6.00000E+03 N ! + FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N + ! + FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N ! + FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N ! + FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N ! + FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; + 6.00000E+03 N ! + FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N ! + FUNCTION AMOLIQ 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2 + +1.14687E-12*T**3; 6.00000E+03 N ! + FUNCTION CMOLIQ 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; + 6.00000E+03 N ! + FUNCTION DMOBCC 2.98150E+02 +1*LN(BMOBCC#); 6.00000E+03 N ! + FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N + ! + FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N ! + FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N ! + FUNCTION ACGRA 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 + N ! + FUNCTION CCGRA 2.98150E+02 3.3E-10; 6.00000E+03 N ! + FUNCTION DCGRA 2.98150E+02 +1*LN(BCGRA#); 6.00000E+03 N ! + FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; + 6.00000E+03 N ! + FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; + 6.00000E+03 N ! + FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N ! + FUNCTION AMOBCC 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2 + +1.14687E-12*T**3; 6.00000E+03 N ! + FUNCTION CMOBCC 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; + 6.00000E+03 N ! + FUNCTION ACEM1 2.98150E+02 -1.36E-05*T+4E-08*T**2; 6.00000E+03 N ! + FUNCTION ACDIA 2.98150E+02 +2.43E-06*T+5E-09*T**2; 6.00000E+03 N ! + FUNCTION CCDIA 2.98150E+02 6.8E-12; 6.00000E+03 N ! + FUNCTION DCDIA 2.98150E+02 +1*LN(BCDIA#); 6.00000E+03 N ! + FUNCTION ACFCC 2.98150E+02 +1.44E-04*T; 6.00000E+03 N ! + FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; + 6.00000E+03 N ! + FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N ! + FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N ! + FUNCTION AFEHCP 2.98150E+02 +7.3646E-05*T; 6.00000E+03 N ! + FUNCTION CFEHCP 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; + 6.00000E+03 N ! + FUNCTION DFEHCP 2.98150E+02 +1*LN(BFEHCP#); 6.00000E+03 N ! + FUNCTION BCLIQ 2.98150E+02 +1+3.2E-10*P; 6.00000E+03 N ! + FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N ! + FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; + 6.00000E+03 N ! + FUNCTION BMOBCC 2.98150E+02 +1+1.13837E-11*P+4.875E-16*T*P + +1.2675E-19*T**2*P; 6.00000E+03 N ! + FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N ! + FUNCTION BCGRA 2.98150E+02 +1+3.6E-10*P; 6.00000E+03 N ! + FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; + 6.00000E+03 N ! + FUNCTION BCDIA 2.98150E+02 +1+8.5E-12*P; 6.00000E+03 N ! + FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; + 6.00000E+03 N ! + FUNCTION BFEHCP 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; + 6.00000E+03 N ! + FUNCTION UN_ASS 298.15 0; 300 N ! + + TYPE_DEFINITION % SEQ *! + DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! + DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! + + + PHASE LIQUID:L % 1 1.0 ! + CONSTITUENT LIQUID:L :C,CR,FE,MO,SI,V : ! + + PARAMETER G(LIQUID,C;0) 2.98150E+02 +117369-24.63*T+GHSERCC#+GPCLIQ#; + 6.00000E+03 N REF283 ! + PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T + +2.37615E-21*T**7+GHSERCR#+GPCRLIQ#; 2.18000E+03 Y + +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#+GPCRLIQ#; 6.00000E+03 + N REF283 ! + PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 + N REF283 ! + PARAMETER G(LIQUID,MO;0) 2.98150E+02 +41831.347-14.694912*T + +4.24519E-22*T**7+GHSERMO#+GPMOLIQ#; 2.89600E+03 Y + +34095.373-11.890046*T+4.849315E+33*T**(-9)+GHSERMO#+GPMOLIQ#; + 5.00000E+03 N REF283 ! + PARAMETER G(LIQUID,SI;0) 2.98150E+02 +50696.36-30.099439*T + +2.09307E-21*T**7+GHSERSI#; 1.68700E+03 Y + +49828.165-29.559069*T+4.20369E+30*T**(-9)+GHSERSI#; 3.60000E+03 N + REF283 ! + PARAMETER G(LIQUID,V;0) 2.98150E+02 +20764.117-9.455552*T + -5.19136E-22*T**7+GHSERVV#; 7.90000E+02 Y + +20764.117-9.455552*T-5.19136E-22*T**7+GHSERVV#; 2.18300E+03 Y + +22072.354-10.0848*T-6.44389E+31*T**(-9)+GHSERVV#; 4.00000E+03 N REF283 ! + PARAMETER G(LIQUID,C,CR;0) 2.98150E+02 -90526-25.9116*T; 6.00000E+03 + N REF101 ! + PARAMETER G(LIQUID,C,CR;1) 2.98150E+02 80000; 6.00000E+03 N REF101 ! + PARAMETER G(LIQUID,C,CR;2) 2.98150E+02 80000; 6.00000E+03 N REF101 ! + PARAMETER G(LIQUID,C,CR,FE;0) 2.98150E+02 -496063; 6.00000E+03 N + REF322 ! + PARAMETER G(LIQUID,C,CR,FE;1) 2.98150E+02 57990; 6.00000E+03 N + REF322 ! + PARAMETER G(LIQUID,C,CR,FE;2) 2.98150E+02 61404; 6.00000E+03 N + REF322 ! + PARAMETER G(LIQUID,C,CR,V;0) 2.98150E+02 -769497; 6.00000E+03 N + REF324 ! + PARAMETER G(LIQUID,C,CR,V;1) 2.98150E+02 263981; 6.00000E+03 N + REF324 ! + PARAMETER G(LIQUID,C,CR,V;2) 2.98150E+02 3599; 6.00000E+03 N REF324 ! + PARAMETER G(LIQUID,C,FE;0) 2.98150E+02 -124320+28.5*T; 6.00000E+03 + N REF190 ! + PARAMETER G(LIQUID,C,FE;1) 2.98150E+02 19300; 6.00000E+03 N REF190 ! + PARAMETER G(LIQUID,C,FE;2) 2.98150E+02 +49260-19*T; 6.00000E+03 N + REF190 ! + PARAMETER G(LIQUID,C,FE,SI;0) 2.98150E+02 445740; 6.00000E+03 N + REF99 ! + PARAMETER G(LIQUID,C,FE,SI;1) 2.98150E+02 -6065-35.33*T; 6.00000E+03 + N REF99 ! + PARAMETER G(LIQUID,C,FE,SI;2) 2.98150E+02 +2545792-1450.6*T; + 6.00000E+03 N REF99 ! + PARAMETER G(LIQUID,C,FE,V;0) 2.98150E+02 -60000; 6.00000E+03 N + REF270 ! + PARAMETER G(LIQUID,C,FE,V;1) 2.98150E+02 -60000; 6.00000E+03 N + REF270 ! + PARAMETER G(LIQUID,C,FE,V;2) 2.98150E+02 100000; 6.00000E+03 N + REF270 ! + PARAMETER G(LIQUID,C,FE,MO;0) 2.98150E+02 -37800; 6.00000E+03 N + REF113 ! + PARAMETER G(LIQUID,C,MO;0) 2.98150E+02 -217800+38.41*T; 6.00000E+03 + N REF104 ! + PARAMETER G(LIQUID,C,MO;1) 2.98150E+02 30000; 6.00000E+03 N REF104 ! + PARAMETER G(LIQUID,C,MO;2) 2.98150E+02 47000; 6.00000E+03 N REF104 ! + PARAMETER G(LIQUID,C,SI;0) 2.98150E+02 -133000+30.97*T; 6.00000E+03 + N REF99 ! + PARAMETER G(LIQUID,C,V;0) 2.98150E+02 -284196+38.952*T; 6.00000E+03 + N REF256 ! + PARAMETER G(LIQUID,C,V;1) 2.98150E+02 +96335-17.775*T; 6.00000E+03 + N REF256 ! + PARAMETER G(LIQUID,C,V;2) 2.98150E+02 102050; 6.00000E+03 N REF256 ! + PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -14550+6.65*T; 6.00000E+03 + N REF107 ! + PARAMETER G(LIQUID,CR,FE,V;0) 2.98150E+02 14881; 6.00000E+03 N + REF323 ! + PARAMETER G(LIQUID,CR,FE,V;1) 2.98150E+02 17968; 6.00000E+03 N + REF323 ! + PARAMETER G(LIQUID,CR,FE,V;2) 2.98150E+02 -7692; 6.00000E+03 N + REF323 ! + PARAMETER G(LIQUID,CR,MO;0) 2.98150E+02 +15810-6.714*T; 6.00000E+03 + N REF123 ! + PARAMETER G(LIQUID,CR,MO;1) 2.98150E+02 -6220; 6.00000E+03 N REF123 ! + PARAMETER G(LIQUID,CR,SI;0) 2.98150E+02 -120157.52+16.63891*T; + 6.00000E+03 N REF90 ! + PARAMETER G(LIQUID,CR,SI;1) 2.98150E+02 -49502.35+13.76967*T; + 6.00000E+03 N REF90 ! + PARAMETER G(LIQUID,CR,V;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 + N REF323 ! + PARAMETER G(LIQUID,CR,V;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 + N REF323 ! + PARAMETER G(LIQUID,FE,MO;0) 2.98150E+02 -6973-.37*T; 6.00000E+03 N + REF10 ! + PARAMETER G(LIQUID,FE,MO;1) 2.98150E+02 -9424+4.502*T; 6.00000E+03 + N REF10 ! + PARAMETER G(LIQUID,FE,SI;0) 2.98150E+02 -164435+41.977*T; 6.00000E+03 + N REF99 ! + PARAMETER G(LIQUID,FE,SI;1) 2.98150E+02 -21.523*T; 6.00000E+03 N + REF99 ! + PARAMETER G(LIQUID,FE,SI;2) 2.98150E+02 -18821+22.07*T; 6.00000E+03 + N REF99 ! + PARAMETER G(LIQUID,FE,SI;3) 2.98150E+02 9696; 6.00000E+03 N REF99 ! + PARAMETER G(LIQUID,FE,V;0) 2.98150E+02 -34679+1.895*T; 6.00000E+03 + N REF269 ! + PARAMETER G(LIQUID,FE,V;1) 2.98150E+02 10209; 6.00000E+03 N REF269 ! + + + TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! + PHASE BCC_A2 %& 2 1 3 ! + CONSTITUENT BCC_A2 :CR%,FE%,MO%,SI,V% : C,VA% : ! + + PARAMETER G(BCC_A2,CR:C;0) 2.98150E+02 +GHSERCR#+3*GHSERCC#+GPCRBCC# + +3*GPCGRA#+416000; 6.00000E+03 N REF101 ! + PARAMETER TC(BCC_A2,CR:C;0) 2.98150E+02 -311.5; 6.00000E+03 N + REF101 ! + PARAMETER BMAGN(BCC_A2,CR:C;0) 2.98150E+02 -.008; 6.00000E+03 N + REF101 ! + PARAMETER G(BCC_A2,FE:C;0) 2.98150E+02 +322050+75.667*T+GHSERFE# + +GPFEBCC#+3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF190 ! + PARAMETER TC(BCC_A2,FE:C;0) 2.98150E+02 1043; 6.00000E+03 N REF190 ! + PARAMETER BMAGN(BCC_A2,FE:C;0) 2.98150E+02 2.22; 6.00000E+03 N + REF190 ! + PARAMETER G(BCC_A2,MO:C;0) 2.98150E+02 +331000-75*T+GHSERMO#+3*GHSERCC#; + 6.00000E+03 N REF104 ! + PARAMETER G(BCC_A2,SI:C;0) 2.98150E+02 +322050-75.667*T+GSIBCC# + +3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF98 ! + PARAMETER G(BCC_A2,V:C;0) 2.98150E+02 +108449+GHSERVV#+3*GHSERCC#; + 6.00000E+03 N REF256 ! + PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N + REF281 ! + PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.01; 6.00000E+03 N + REF281 ! + PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF281 ! + PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N + REF281 ! + PARAMETER G(BCC_A2,MO:VA;0) 2.98150E+02 +GHSERMO#+GPMOBCC#; + 5.00000E+03 N REF283 ! + PARAMETER G(BCC_A2,SI:VA;0) 2.98150E+02 +GSIBCC#; 3.60000E+03 N + REF283 ! + PARAMETER G(BCC_A2,V:VA;0) 2.98150E+02 +GHSERVV#; 4.00000E+03 N + REF283 ! + PARAMETER G(BCC_A2,CR,FE:C;0) 2.98150E+02 -1250000+667.7*T; + 6.00000E+03 N REF322 ! + PARAMETER TC(BCC_A2,CR,FE:C;0) 2.98150E+02 1650; 6.00000E+03 N + REF102 ! + PARAMETER TC(BCC_A2,CR,FE:C;1) 2.98150E+02 550; 6.00000E+03 N + REF102 ! + PARAMETER BMAGN(BCC_A2,CR,FE:C;0) 2.98150E+02 -.85; 6.00000E+03 N + REF102 ! + PARAMETER G(BCC_A2,CR:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N + REF101 ! + PARAMETER G(BCC_A2,FE,MO:C;0) 2.98150E+02 -1250000+667.7*T; + 6.00000E+03 N REF325 ! + PARAMETER TC(BCC_A2,FE,MO:C;0) 2.98150E+02 335; 6.00000E+03 N + REF104 ! + PARAMETER TC(BCC_A2,FE,MO:C;1) 2.98150E+02 526; 6.00000E+03 N + REF104 ! + PARAMETER G(BCC_A2,FE,SI:C;0) 2.98150E+02 78866; 6.00000E+03 N + REF99 ! + PARAMETER G(BCC_A2,FE,V:C;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 + N REF270 ! + PARAMETER G(BCC_A2,FE,V:C;1) 2.98150E+02 8283; 6.00000E+03 N REF270 ! + PARAMETER G(BCC_A2,FE:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N + REF190 ! + PARAMETER G(BCC_A2,V:C,VA;0) 2.98150E+02 -297868; 6.00000E+03 N + REF256 ! + PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 + N REF107 ! + PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N + REF107 ! + PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N + REF107 ! + PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N + REF107 ! + PARAMETER G(BCC_A2,CR,FE,V:VA;0) 2.98150E+02 14881; 6.00000E+03 N + REF323 ! + PARAMETER G(BCC_A2,CR,FE,V:VA;1) 2.98150E+02 17968; 6.00000E+03 N + REF323 ! + PARAMETER G(BCC_A2,CR,FE,V:VA;2) 2.98150E+02 -7692; 6.00000E+03 N + REF323 ! + PARAMETER G(BCC_A2,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; + 6.00000E+03 N REF123 ! + PARAMETER G(BCC_A2,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 + N REF123 ! + PARAMETER G(BCC_A2,CR,SI:VA;0) 2.98150E+02 -102850.19+9.85457*T; + 6.00000E+03 N REF90 ! + PARAMETER G(BCC_A2,CR,SI:VA;1) 2.98150E+02 -49502.35+13.76967*T; + 6.00000E+03 N REF90 ! + PARAMETER G(BCC_A2,CR,V:VA;0) 2.98150E+02 -9875-2.6964*T; 6.00000E+03 + N REF323 ! + PARAMETER G(BCC_A2,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 + N REF323 ! + PARAMETER G(BCC_A2,FE,MO:VA;0) 2.98150E+02 +36818-9.141*T; + 6.00000E+03 N REF10 ! + PARAMETER G(BCC_A2,FE,MO:VA;1) 2.98150E+02 -362-5.724*T; 6.00000E+03 + N REF10 ! + PARAMETER TC(BCC_A2,FE,MO:VA;0) 2.98150E+02 335; 6.00000E+03 N + REF10 ! + PARAMETER TC(BCC_A2,FE,MO:VA;1) 2.98150E+02 526; 6.00000E+03 N + REF10 ! + PARAMETER G(BCC_A2,FE,SI:VA;0) 2.98150E+02 +4*L0BCC#-4*FESIW1#; + 6.00000E+03 N REF98 ! + PARAMETER G(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*L1BCC#; 6.00000E+03 N + REF98 ! + PARAMETER G(BCC_A2,FE,SI:VA;2) 2.98150E+02 +16*L2BCC#; 6.00000E+03 + N REF98 ! + PARAMETER TC(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*ETCFESI#; 6.00000E+03 + N REF98 ! + PARAMETER G(BCC_A2,FE,V:VA;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 + N REF269 ! + PARAMETER G(BCC_A2,FE,V:VA;1) 2.98150E+02 8283; 6.00000E+03 N + REF269 ! + PARAMETER TC(BCC_A2,FE,V:VA;0) 2.98150E+02 -110; 6.00000E+03 N + REF111 ! + PARAMETER TC(BCC_A2,FE,V:VA;1) 2.98150E+02 3075; 6.00000E+03 N + REF111 ! + PARAMETER TC(BCC_A2,FE,V:VA;2) 2.98150E+02 808; 6.00000E+03 N + REF111 ! + PARAMETER TC(BCC_A2,FE,V:VA;3) 2.98150E+02 -2169; 6.00000E+03 N + REF111 ! + PARAMETER BMAGN(BCC_A2,FE,V:VA;0) 2.98150E+02 -2.26; 6.00000E+03 N + REF111 ! + + + TYPE_DEFINITION ' GES A_P_D CBCC_A12 MAGNETIC -3.0 2.80000E-01 ! + PHASE CBCC_A12 %' 2 1 1 ! + CONSTITUENT CBCC_A12 :CR,FE,SI,V : C,VA% : ! + + PARAMETER G(CBCC_A12,CR:C;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CBCC_A12,FE:C;0) 2.98150E+02 +80000+GHSERFE#+GHSERCC#; + 6.00000E+03 N REF267 ! + PARAMETER G(CBCC_A12,SI:C;0) 2.98150E+02 +1000000+566.0326*T + -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); + 3.00000E+03 N REF177 ! + PARAMETER G(CBCC_A12,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; + 6.00000E+03 N REF275 ! + PARAMETER G(CBCC_A12,CR:VA;0) 2.98150E+02 +11087+2.7196*T+GHSERCR#; + 6.00000E+03 N REF283 ! + PARAMETER G(CBCC_A12,FE:VA;0) 2.98150E+02 +4745+GHSERFE#; 6.00000E+03 + N REF283 ! + PARAMETER G(CBCC_A12,SI:VA;0) 2.98150E+02 +50208-20.377*T+GHSERSI#; + 3.60000E+03 N REF283 ! + PARAMETER G(CBCC_A12,V:VA;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CBCC_A12,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N + REF267 ! + PARAMETER G(CBCC_A12,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; + 6.00000E+03 N REF42 ! + PARAMETER G(CBCC_A12,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N + REF42 ! + PARAMETER G(CBCC_A12,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N + REF42 ! + PARAMETER G(CBCC_A12,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N + REF275 ! + + + PHASE CEMENTITE % 2 3 1 ! + CONSTITUENT CEMENTITE :CR,FE%,MO,V : C : ! + + PARAMETER G(CEMENTITE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#-48000 + -9.2888*T; 6.00000E+03 N REF322 ! + PARAMETER G(CEMENTITE,FE:C;0) 2.98150E+02 +GFECEM#; 6.00000E+03 N + REF190 ! + PARAMETER G(CEMENTITE,MO:C;0) 2.98150E+02 +3*GHSERMO#+GHSERCC#+77000 + -57.4*T; 6.00000E+03 N REF104 ! + PARAMETER G(CEMENTITE,V:C;0) 2.98150E+02 -156971+601.922*T + -100.438*T*LN(T)+765557*T**(-1); 6.00000E+03 N REF275 ! + PARAMETER G(CEMENTITE,CR,FE:C;0) 2.98150E+02 +25278-17.5*T; + 6.00000E+03 N REF322 ! + PARAMETER G(CEMENTITE,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N + REF316 ! + PARAMETER G(CEMENTITE,CR,V:C;0) 2.98150E+02 -29622-8.0892*T; + 6.00000E+03 N REF324 ! + PARAMETER G(CEMENTITE,CR,V:C;1) 2.98150E+02 -5160-7.5711*T; + 6.00000E+03 N REF324 ! + PARAMETER G(CEMENTITE,FE,V:C;0) 2.98150E+02 -45873-12.414*T; + 6.00000E+03 N REF270 ! + + + PHASE CHI_A12 % 3 24 10 24 ! + CONSTITUENT CHI_A12 :CR,FE : CR,MO : CR,FE,MO : ! + + PARAMETER G(CHI_A12,CR:CR:CR;0) 2.98150E+02 +48*GCRFCC#+10*GHSERCR# + +109000+123*T; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:CR:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR# + +24*GCRFCC#+18300-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(CHI_A12,CR:MO:CR;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# + +24*GCRFCC#-26000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:MO:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO# + +24*GCRFCC#+32555-385*T; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,CR:CR:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR# + +24*GFEFCC#+500000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:CR:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERCR# + +57300-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(CHI_A12,CR:MO:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# + +24*GFEFCC#+500000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:MO:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERMO# + +305210-270*T; 6.00000E+03 N REF115 ! + PARAMETER G(CHI_A12,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR# + +24*GMOFCC#+500000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:CR:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR# + +24*GMOFCC#+100000; 6.00000E+03 N REF115 ! + PARAMETER G(CHI_A12,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# + +24*GMOFCC#+500000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO# + +24*GMOFCC#+97300-100*T; 6.00000E+03 N REF115 ! + + + PHASE CR2VC2 % 3 2 1 2 ! + CONSTITUENT CR2VC2 :CR : V : C : ! + + PARAMETER G(CR2VC2,CR:V:C;0) 2.98150E+02 -105987-38.2069*T+2*GHSERCR# + +GHSERVV#+2*GHSERCC#; 6.00000E+03 N REF324 ! + + + PHASE CR3SI % 2 3 1 ! + CONSTITUENT CR3SI :CR%,SI : CR,SI% : ! + + PARAMETER G(CR3SI,CR:CR;0) 2.98150E+02 +17008.82+4*T+4*GHSERCR#; + 6.00000E+03 N REF90 ! + PARAMETER G(CR3SI,SI:CR;0) 2.98150E+02 +167008.8+4*T+GHSERCR# + +3*GHSERSI#; 6.00000E+03 N REF90 ! + PARAMETER G(CR3SI,CR:SI;0) 2.98150E+02 -125456.6+4*T+3*GHSERCR# + +GHSERSI#; 6.00000E+03 N REF90 ! + PARAMETER G(CR3SI,SI:SI;0) 2.98150E+02 +24543.3+4*T+4*GHSERSI#; + 6.00000E+03 N REF90 ! + + + PHASE CR5SI3 % 2 5 3 ! + CONSTITUENT CR5SI3 :CR : SI : ! + + PARAMETER G(CR5SI3,CR:SI;0) 2.98150E+02 -318953.76+1067.49776*T + -182.57818*T*LN(T)-.02391968*T**2-2.31728E-06*T**3; 6.00000E+03 N + REF90 ! + + + PHASE CRSI % 2 1 1 ! + CONSTITUENT CRSI :CR : SI : ! + + PARAMETER G(CRSI,CR:SI;0) 2.98150E+02 -79041.68+311.75228*T + -51.62865*T*LN(T)-.00447355*T**2+391330*T**(-1); 6.00000E+03 N REF90 ! + + + PHASE CRSI2 % 2 1 2 ! + CONSTITUENT CRSI2 :CR%,SI : CR,SI% : ! + + PARAMETER G(CRSI2,CR:CR;0) 2.98150E+02 +10000+10*T+3*GHSERCR#; + 6.00000E+03 N REF90 ! + PARAMETER G(CRSI2,SI:CR;0) 2.98150E+02 +150000-T+2*GHSERCR#+GHSERSI#; + 6.00000E+03 N REF90 ! + PARAMETER G(CRSI2,CR:SI;0) 2.98150E+02 -96793.65+333.25242*T + -57.85575*T*LN(T)-.01322769*T**2-4.3203E-07*T**3; 6.00000E+03 N REF90 ! + PARAMETER G(CRSI2,SI:SI;0) 2.98150E+02 +77711.85-15.05638*T+3*GHSERSI#; + 6.00000E+03 N REF90 ! + PARAMETER G(CRSI2,CR:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; + 6.00000E+03 N REF90 ! + PARAMETER G(CRSI2,SI:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; + 6.00000E+03 N REF90 ! + + + PHASE CUB_A13 % 2 1 1 ! + CONSTITUENT CUB_A13 :CR,FE,SI,V : C,VA% : ! + + PARAMETER G(CUB_A13,CR:C;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CUB_A13,FE:C;0) 2.98150E+02 +90000+GHSERFE#+GHSERCC#; + 6.00000E+03 N REF267 ! + PARAMETER G(CUB_A13,SI:C;0) 2.98150E+02 +1000000+566.0326*T + -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); + 3.00000E+03 N REF177 ! + PARAMETER G(CUB_A13,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; + 6.00000E+03 N REF275 ! + PARAMETER G(CUB_A13,CR:VA;0) 2.98150E+02 +15899+.6276*T+GHSERCR#; + 6.00000E+03 N REF283 ! + PARAMETER G(CUB_A13,FE:VA;0) 2.98150E+02 +3745+GHSERFE#; 6.00000E+03 + N REF283 ! + PARAMETER G(CUB_A13,SI:VA;0) 2.98150E+02 +47279-20.377*T+GHSERSI#; + 3.60000E+03 N REF283 ! + PARAMETER G(CUB_A13,V:VA;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CUB_A13,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N + REF267 ! + PARAMETER G(CUB_A13,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; + 6.00000E+03 N REF42 ! + PARAMETER G(CUB_A13,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N + REF42 ! + PARAMETER G(CUB_A13,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N + REF42 ! + PARAMETER G(CUB_A13,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N + REF275 ! + + + PHASE DIAMOND_A4 % 1 1.0 ! + CONSTITUENT DIAMOND_A4 :C,SI% : ! + + PARAMETER G(DIAMOND_A4,C;0) 2.98150E+02 -16359.441+175.61*T + -24.31*T*LN(T)-4.723E-04*T**2+2698000*T**(-1)-2.61E+08*T**(-2) + +1.11E+10*T**(-3)+GPCDIA#; 6.00000E+03 N REF283 ! + PARAMETER G(DIAMOND_A4,SI;0) 2.98150E+02 +GHSERSI#; 3.60000E+03 N + REF283 ! + + + TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! + PHASE FCC_A1 %( 2 1 1 ! + CONSTITUENT FCC_A1 :CR,FE%,MO,SI,V : C,VA% : ! + + PARAMETER G(FCC_A1,CR:C;0) 2.98150E+02 +GHSERCR#+GHSERCC#+1200-1.94*T; + 6.00000E+03 N REF322 ! + PARAMETER G(FCC_A1,FE:C;0) 2.98150E+02 +77207-15.877*T+GFEFCC#+GHSERCC# + +GPCFCC#; 6.00000E+03 N REF190 ! + PARAMETER TC(FCC_A1,FE:C;0) 2.98150E+02 -201; 6.00000E+03 N REF190 ! + PARAMETER BMAGN(FCC_A1,FE:C;0) 2.98150E+02 -2.1; 6.00000E+03 N + REF190 ! + PARAMETER G(FCC_A1,MO:C;0) 2.98150E+02 -7500-8.3*T-750000*T**(-1) + +GHSERMO#+GHSERCC#; 6.00000E+03 N REF104 ! + PARAMETER G(FCC_A1,SI:C;0) 2.98150E+02 +GHSERSI#+GHSERCC#-20510+38.7*T; + 6.00000E+03 N REF98 ! + PARAMETER G(FCC_A1,V:C;0) 2.98150E+02 -117302+262.57*T-41.756*T*LN(T) + -.00557101*T**2+590546*T**(-1); 6.00000E+03 N REF256 ! + PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; + 6.00000E+03 N REF281 ! + PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N + REF281 ! + PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N + REF281 ! + PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF281 ! + PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N + REF281 ! + PARAMETER G(FCC_A1,MO:VA;0) 2.98150E+02 +15200+.63*T+GHSERMO#+GPMOBCC#; + 5.00000E+03 N REF283 ! + PARAMETER G(FCC_A1,SI:VA;0) 2.98150E+02 +51000-21.8*T+GHSERSI#; + 3.60000E+03 N REF283 ! + PARAMETER G(FCC_A1,V:VA;0) 2.98150E+02 +7500+1.7*T+GHSERVZ#; + 4.00000E+03 N REF283 ! + PARAMETER G(FCC_A1,CR,FE:C;0) 2.98150E+02 -74319+3.2353*T; + 6.00000E+03 N REF322 ! + PARAMETER G(FCC_A1,CR,V:C;0) 2.98150E+02 +35698-50.0981*T; + 6.00000E+03 N REF324 ! + PARAMETER G(FCC_A1,CR:C,VA;0) 2.98150E+02 -11977+6.8194*T; + 6.00000E+03 N REF322 ! + PARAMETER G(FCC_A1,FE,MO:C;0) 2.98150E+02 6000; 6.00000E+03 N + REF113 ! + PARAMETER G(FCC_A1,FE,SI:C;0) 2.98150E+02 +143220+39.31*T; + 6.00000E+03 N REF99 ! + PARAMETER G(FCC_A1,FE,SI:C;1) 2.98150E+02 -216321; 6.00000E+03 N + REF99 ! + PARAMETER G(FCC_A1,FE,V:C;0) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 + N REF270 ! + PARAMETER G(FCC_A1,FE,V:C;1) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 + N REF270 ! + PARAMETER G(FCC_A1,FE,V:C,VA;0) 2.98150E+02 -40000; 6.00000E+03 N + REF270 ! + PARAMETER G(FCC_A1,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N + REF190 ! + PARAMETER G(FCC_A1,MO,V:C;0) 2.98150E+02 -18000; 6.00000E+03 N + REF220 ! + PARAMETER G(FCC_A1,MO:C,VA;0) 2.98150E+02 -41300; 6.00000E+03 N + REF104 ! + PARAMETER G(FCC_A1,V:C,VA;0) 2.98150E+02 -74811+10.201*T; 6.00000E+03 + N REF256 ! + PARAMETER G(FCC_A1,V:C,VA;1) 2.98150E+02 -30394; 6.00000E+03 N + REF256 ! + PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; + 6.00000E+03 N REF107 ! + PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N + REF107 ! + PARAMETER G(FCC_A1,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; + 6.00000E+03 N REF58 ! + PARAMETER G(FCC_A1,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 + N REF58 ! + PARAMETER G(FCC_A1,CR,SI:VA;0) 2.98150E+02 -122850+9.85457*T; + 6.00000E+03 N REF58 ! + PARAMETER G(FCC_A1,CR,SI:VA;1) 2.98150E+02 -49502+13.76967*T; + 6.00000E+03 N REF58 ! + PARAMETER G(FCC_A1,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 + N REF323 ! + PARAMETER G(FCC_A1,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 + N REF323 ! + PARAMETER G(FCC_A1,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; + 6.00000E+03 N REF10 ! + PARAMETER G(FCC_A1,FE,SI:VA;0) 2.98150E+02 -125248+41.116*T; + 6.00000E+03 N REF98 ! + PARAMETER G(FCC_A1,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N + REF98 ! + PARAMETER G(FCC_A1,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N + REF98 ! + PARAMETER G(FCC_A1,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 + N REF269 ! + + + PHASE FE1SI1 % 2 .5 .5 ! + CONSTITUENT FE1SI1 :FE : SI : ! + + PARAMETER G(FE1SI1,FE:SI;0) 2.98150E+02 +.5*GHSERFE#+.5*GHSERSI#-36381 + +2.22*T; 6.00000E+03 N REF98 ! + + + PHASE FE2SI % 2 .666667 .333333 ! + CONSTITUENT FE2SI :FE : SI : ! + + PARAMETER G(FE2SI,FE:SI;0) 2.98150E+02 +.6666667*GHSERFE# + +.3333333*GHSERSI#-23752-3.54*T; 6.00000E+03 N REF98 ! + + + PHASE FE4N % 2 4 1 ! + CONSTITUENT FE4N :FE : C,VA : ! + + PARAMETER G(FE4N,FE:C;0) 2.98150E+02 +15965+4*GHSERFE#+GHSERCC#; + 6.00000E+03 N REF319 ! + PARAMETER G(FE4N,FE:VA;0) 2.98150E+02 +4*GFEFCC#+10; 6.00000E+03 N + REF319 ! + + + PHASE FE5SI3 % 2 .625 .375 ! + CONSTITUENT FE5SI3 :FE : SI : ! + + PARAMETER G(FE5SI3,FE:SI;0) 2.98150E+02 +.625*GHSERFE#+.375*GHSERSI# + -30143+.27*T; 6.00000E+03 N REF98 ! + + + PHASE FE8SI2C % 3 8 2 1 ! + CONSTITUENT FE8SI2C :FE : SI : C : ! + + PARAMETER G(FE8SI2C,FE:SI:C;0) 2.98150E+02 +8*GHSERFE#+2*GHSERSI# + +GHSERCC#-231047+5.566*T; 6.00000E+03 N REF99 ! + + + PHASE FECN_CHI % 2 5 2 ! + CONSTITUENT FECN_CHI :FE : C : ! + + PARAMETER G(FECN_CHI,FE:C;0) 2.98150E+02 -11287.4+1013.78*T + -176.412*T*LN(T)+810869*T**(-1); 6.00000E+03 N REF319 ! + + + PHASE FESI2_H % 2 .3 .7 ! + CONSTITUENT FESI2_H :FE : SI : ! + + PARAMETER G(FESI2_H,FE:SI;0) 2.98150E+02 +.3*GHSERFE#+.7*GHSERSI#-19649 + -.92*T; 6.00000E+03 N REF98 ! + + + PHASE FESI2_L % 2 .333333 .666667 ! + CONSTITUENT FESI2_L :FE : SI : ! + + PARAMETER G(FESI2_L,FE:SI;0) 2.98150E+02 +.333333*GHSERFE# + +.666667*GHSERSI#-27383+3.48*T; 6.00000E+03 N REF98 ! + + + PHASE GRAPHITE % 1 1.0 ! + CONSTITUENT GRAPHITE :C : ! + + PARAMETER G(GRAPHITE,C;0) 2.98150E+02 +GHSERCC#+GPCGRA#; 6.00000E+03 + N REF283 ! + + + TYPE_DEFINITION ) GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 ! + PHASE HCP_A3 %) 2 1 .5 ! + CONSTITUENT HCP_A3 :CR,FE,MO,SI,V : C,VA% : ! + + PARAMETER G(HCP_A3,CR:C;0) 2.98150E+02 +GHSERCR#+.5*GHSERCC#-18504 + +9.4173*T-2.4997*T*LN(T)+.001386*T**2; 6.00000E+03 N REF322 ! + PARAMETER G(HCP_A3,FE:C;0) 2.98150E+02 +52905-11.9075*T+GFEFCC# + +.5*GHSERCC#+GPCFCC#; 6.00000E+03 N REF190 ! + PARAMETER G(HCP_A3,MO:C;0) 2.98150E+02 -24150-3.625*T-163000*T**(-1) + +GHSERMO#+.5*GHSERCC#; 6.00000E+03 N REF104 ! + PARAMETER G(HCP_A3,SI:C;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(HCP_A3,V:C;0) 2.98150E+02 -85473+182.441*T-30.551*T*LN(T) + -.00538998*T**2+229029*T**(-1); 6.00000E+03 N REF256 ! + PARAMETER G(HCP_A3,CR:VA;0) 2.98150E+02 +4438+GHSERCR#+GPCRBCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(HCP_A3,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N + REF281 ! + PARAMETER BMAGN(HCP_A3,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N + REF281 ! + PARAMETER G(HCP_A3,FE:VA;0) 2.98150E+02 -3705.78+12.591*T-1.15*T*LN(T) + +6.4E-04*T**2+GHSERFE#+GPFEHCP#; 1.81100E+03 Y + -3957.199+5.24951*T+4.9251E+30*T**(-9)+GHSERFE#+GPFEHCP#; 6.00000E+03 N + REF283 ! + PARAMETER G(HCP_A3,MO:VA;0) 2.98150E+02 +11550+GHSERMO#+GPMOBCC#; + 5.00000E+03 N REF283 ! + PARAMETER G(HCP_A3,SI:VA;0) 2.98150E+02 +49200-20.8*T+GHSERSI#; + 3.60000E+03 N REF283 ! + PARAMETER G(HCP_A3,V:VA;0) 2.98150E+02 +4000+2.4*T+GHSERVZ#; + 4.00000E+03 N REF283 ! + PARAMETER G(HCP_A3,CR,FE,MO:C;0) 2.98150E+02 -57062; 6.00000E+03 N + REF316 ! + PARAMETER G(HCP_A3,CR,MO:C;0) 2.98150E+02 -3905+18.5304*T; + 6.00000E+03 N REF316 ! + PARAMETER G(HCP_A3,CR,V:C;0) 2.98150E+02 +17165-9.9072*T; 6.00000E+03 + N REF323 ! + PARAMETER G(HCP_A3,CR:C,VA;0) 2.98150E+02 4165; 6.00000E+03 N + REF207 ! + PARAMETER G(HCP_A3,FE,MO:C;0) 2.98150E+02 +13030-33.8*T; 6.00000E+03 + N REF113 ! + PARAMETER G(HCP_A3,FE,V:C;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 + N REF270 ! + PARAMETER G(HCP_A3,FE:C,VA;0) 2.98150E+02 -22126; 6.00000E+03 N + REF319 ! + PARAMETER G(HCP_A3,MO:C,VA;0) 2.98150E+02 4150; 6.00000E+03 N + REF104 ! + PARAMETER G(HCP_A3,V:C,VA;0) 2.98150E+02 +12430-3.986*T; 6.00000E+03 + N REF256 ! + PARAMETER G(HCP_A3,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; + 6.00000E+03 N REF126 ! + PARAMETER G(HCP_A3,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; + 6.00000E+03 N REF117 ! + PARAMETER G(HCP_A3,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 + N REF117 ! + PARAMETER G(HCP_A3,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 + N REF323 ! + PARAMETER G(HCP_A3,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 + N REF323 ! + PARAMETER G(HCP_A3,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; + 6.00000E+03 N REF10 ! + PARAMETER G(HCP_A3,FE,SI:VA;0) 2.98150E+02 -123468+41.116*T; + 6.00000E+03 N REF42 ! + PARAMETER G(HCP_A3,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N + REF42 ! + PARAMETER G(HCP_A3,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N + REF42 ! + PARAMETER G(HCP_A3,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 + N REF270 ! + + + PHASE KSI_CARBIDE % 2 3 1 ! + CONSTITUENT KSI_CARBIDE :CR,FE,MO% : C : ! + + PARAMETER G(KSI_CARBIDE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#+114060 + -47.2519*T; 6.00000E+03 N REF316 ! + PARAMETER G(KSI_CARBIDE,FE:C;0) 2.98150E+02 +14540+20*T+3*GHSERFE# + +GHSERCC#; 6.00000E+03 N REF113 ! + PARAMETER G(KSI_CARBIDE,MO:C;0) 2.98150E+02 +167009-33*T+3*GHSERMO# + +GHSERCC#; 6.00000E+03 N REF113 ! + PARAMETER G(KSI_CARBIDE,CR,FE:C;0) 2.98150E+02 -139900; 6.00000E+03 + N REF316 ! + PARAMETER G(KSI_CARBIDE,CR,MO:C;0) 2.98150E+02 -348033; 6.00000E+03 + N REF316 ! + PARAMETER G(KSI_CARBIDE,FE,MO:C;0) 2.98150E+02 -380000; 6.00000E+03 + N REF113 ! + + + PHASE LAVES_PHASE % 2 2 1 ! + CONSTITUENT LAVES_PHASE :CR,FE : MO : ! + + PARAMETER G(LAVES_PHASE,CR:MO;0) 2.98150E+02 +2*GCRFCC#+GHSERMO#-8000 + -6*T; 6.00000E+03 N REF214 ! + PARAMETER G(LAVES_PHASE,FE:MO;0) 2.98150E+02 -10798-.132*T+2*GFEFCC# + +GHSERMO#; 6.00000E+03 N REF10 ! + + + PHASE M23C6 % 3 20 3 6 ! + CONSTITUENT M23C6 :CR%,FE%,V : CR%,FE%,MO%,V : C : ! + + PARAMETER G(M23C6,CR:CR:C;0) 2.98150E+02 +GCRM23C6#; 6.00000E+03 N + REF102 ! + PARAMETER G(M23C6,FE:CR:C;0) 2.98150E+02 +.1304348*GCRM23C6# + +.8695652*GFEM23C6#; 6.00000E+03 N REF102 ! + PARAMETER G(M23C6,V:CR:C;0) 2.98150E+02 +.869565*GVM23C6# + +.130435*GCRM23C6#; 6.00000E+03 N REF323 ! + PARAMETER G(M23C6,CR:FE:C;0) 2.98150E+02 +.8695652*GCRM23C6# + +.1304348*GFEM23C6#; 6.00000E+03 N REF102 ! + PARAMETER G(M23C6,FE:FE:C;0) 2.98150E+02 +GFEM23C6#; 6.00000E+03 N + REF102 ! + PARAMETER G(M23C6,V:FE:C;0) 2.98150E+02 +.869565*GVM23C6# + +.130435*GFEM23C6#; 6.00000E+03 N REF323 ! + PARAMETER G(M23C6,CR:MO:C;0) 2.98150E+02 +20*GHSERCR#+3*GHSERMO# + +6*GHSERCC#-439117-50.0535*T; 6.00000E+03 N REF316 ! + PARAMETER G(M23C6,FE:MO:C;0) 2.98150E+02 +20*GHSERFE#+3*GHSERMO# + +6*GHSERCC#-76351-5.095*T; 6.00000E+03 N REF316 ! + PARAMETER G(M23C6,V:MO:C;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(M23C6,CR:V:C;0) 2.98150E+02 +.869565*GCRM23C6# + +.130435*GVM23C6#; 6.00000E+03 N REF323 ! + PARAMETER G(M23C6,FE:V:C;0) 2.98150E+02 +.869565*GFEM23C6# + +.130435*GVM23C6#; 6.00000E+03 N REF323 ! + PARAMETER G(M23C6,V:V:C;0) 2.98150E+02 +GVM23C6#; 6.00000E+03 N + REF323 ! + PARAMETER G(M23C6,CR,FE:CR:C;0) 2.98150E+02 -205342+141.6667*T; + 6.00000E+03 N REF322 ! + PARAMETER G(M23C6,CR,FE,V:CR:C;0) 2.98150E+02 -1499585; 6.00000E+03 + N REF324 ! + PARAMETER G(M23C6,CR,V:CR:C;0) 2.98150E+02 -385502; 6.00000E+03 N + REF324 ! + PARAMETER G(M23C6,CR,FE:FE:C;0) 2.98150E+02 -205342+141.6667*T; + 6.00000E+03 N REF322 ! + PARAMETER G(M23C6,CR,FE,V:FE:C;0) 2.98150E+02 -1499585; 6.00000E+03 + N REF324 ! + PARAMETER G(M23C6,CR,V:FE:C;0) 2.98150E+02 -385502; 6.00000E+03 N + REF324 ! + PARAMETER G(M23C6,CR,FE:MO:C;0) 2.98150E+02 -177850+153.905*T; + 6.00000E+03 N REF316 ! + PARAMETER G(M23C6,CR,FE:V:C;0) 2.98150E+02 -205342+141.6667*T; + 6.00000E+03 N REF324 ! + PARAMETER G(M23C6,CR,FE,V:V:C;0) 2.98150E+02 -1499585; 6.00000E+03 + N REF324 ! + PARAMETER G(M23C6,CR,V:V:C;0) 2.98150E+02 -385502; 6.00000E+03 N + REF324 ! + + + PHASE M3C2 % 2 3 2 ! + CONSTITUENT M3C2 :CR,MO,V : C : ! + + PARAMETER G(M3C2,CR:C;0) 2.98150E+02 +GCRM3C2#; 6.00000E+03 N + REF322 ! + PARAMETER G(M3C2,MO:C;0) 2.98150E+02 +3*GHSERMO#+2*GHSERCC#+27183; + 6.00000E+03 N REF316 ! + PARAMETER G(M3C2,V:C;0) 2.98150E+02 -222500+16.6545*T+3*GHSERVV# + +2*GHSERCC#; 6.00000E+03 N REF324 ! + PARAMETER G(M3C2,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N REF316 ! + PARAMETER G(M3C2,CR,V:C;0) 2.98150E+02 21072; 6.00000E+03 N REF324 ! + + + PHASE M3SI % 2 3 1 ! + CONSTITUENT M3SI :FE : SI : ! + + PARAMETER G(M3SI,FE:SI;0) 2.98150E+02 +3*GHSERFE#+GHSERSI#-94274-3.56*T; + 6.00000E+03 N REF42 ! + + + PHASE M5C2 % 2 5 2 ! + CONSTITUENT M5C2 :FE,V : C : ! + + PARAMETER G(M5C2,FE:C;0) 2.98150E+02 +5*GHSERFE#+2*GHSERCC#+54852 + -33.7518*T; 6.00000E+03 N REF322 ! + PARAMETER G(M5C2,V:C;0) 2.98150E+02 -307123.3+1059.7*T-175.66*T*LN(T) + +1453274*T**(-1); 6.00000E+03 N REF275 ! + + + PHASE M6C % 4 2 2 2 1 ! + CONSTITUENT M6C :FE : MO : CR,FE,MO,V : C : ! + + PARAMETER G(M6C,FE:MO:CR:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERCR# + +2*GHSERMO#+GHSERCC#-25298-54.8698*T; 6.00000E+03 N REF316 ! + PARAMETER G(M6C,FE:MO:FE:C;0) 2.98150E+02 +4*GHSERFE#+2*GHSERMO# + +GHSERCC#+77705-101.5*T; 6.00000E+03 N REF113 ! + PARAMETER G(M6C,FE:MO:MO:C;0) 2.98150E+02 +2*GHSERFE#+4*GHSERMO# + +GHSERCC#-122410+30.25*T; 6.00000E+03 N REF113 ! + PARAMETER G(M6C,FE:MO:V:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERMO# + +2*GHSERVV#+GHSERCC#-173000; 6.00000E+03 N REF220 ! + PARAMETER G(M6C,FE:MO:FE,MO:C;0) 2.98150E+02 -37700; 6.00000E+03 N + REF113 ! + + + PHASE M7C3 % 2 7 3 ! + CONSTITUENT M7C3 :CR%,FE,MO,V : C : ! + + PARAMETER G(M7C3,CR:C;0) 2.98150E+02 +GCRM7C3#; 6.00000E+03 N + REF322 ! + PARAMETER G(M7C3,FE:C;0) 2.98150E+02 +7*GHSERFE#+3*GHSERCC#+75000 + -48.2168*T; 6.00000E+03 N REF322 ! + PARAMETER G(M7C3,MO:C;0) 2.98150E+02 +7*GHSERMO#+3*GHSERCC#-140415 + +24.24*T; 6.00000E+03 N REF316 ! + PARAMETER G(M7C3,V:C;0) 2.98150E+02 -454245+1518.48*T-250.981*T*LN(T) + +2148691*T**(-1); 6.00000E+03 N REF324 ! + PARAMETER G(M7C3,CR,FE:C;0) 2.98150E+02 -4520-10*T; 6.00000E+03 N + REF322 ! + PARAMETER G(M7C3,CR,FE,V:C;0) 2.98150E+02 -250158; 6.00000E+03 N + REF324 ! + PARAMETER G(M7C3,CR,MO:C;0) 2.98150E+02 165280; 6.00000E+03 N + REF316 ! + PARAMETER G(M7C3,CR,V:C;0) 2.98150E+02 -110271; 6.00000E+03 N + REF324 ! + + + PHASE MC_ETA % 2 1 1 ! + CONSTITUENT MC_ETA :MO% : C%,VA : ! + + PARAMETER G(MC_ETA,MO:C;0) 2.98150E+02 -9100-5.35*T-750000*T**(-1) + +GHSERMO#+GHSERCC#; 6.00000E+03 N REF113 ! + PARAMETER G(MC_ETA,MO:VA;0) 2.98150E+02 +GHSERMO#+15200+.63*T; + 6.00000E+03 N REF113 ! + PARAMETER G(MC_ETA,MO:C,VA;0) 2.98150E+02 -59500; 6.00000E+03 N + REF104 ! + + + PHASE MC_SHP % 2 1 1 ! + CONSTITUENT MC_SHP :MO : C : ! + + PARAMETER G(MC_SHP,MO:C;0) 2.98150E+02 -32983+2.5*T+GHSERMO#+GHSERCC#; + 6.00000E+03 N REF104 ! + + + PHASE MONI_DELTA % 3 24 20 12 ! + CONSTITUENT MONI_DELTA :CR,FE : CR,FE,MO : MO : ! + + PARAMETER G(MONI_DELTA,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR# + +12*GHSERMO#+50000; 6.00000E+03 N REF133 ! + PARAMETER G(MONI_DELTA,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(MONI_DELTA,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(MONI_DELTA,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE# + +12*GHSERMO#+100000; 6.00000E+03 N REF132 ! + PARAMETER G(MONI_DELTA,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO# + +100000; 6.00000E+03 N REF133 ! + PARAMETER G(MONI_DELTA,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO# + +100000; 6.00000E+03 N REF132 ! + + + PHASE MU_PHASE % 3 7 2 4 ! + CONSTITUENT MU_PHASE :CR,FE : MO : CR,FE,MO : ! + + PARAMETER G(MU_PHASE,CR:MO:CR;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# + +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(MU_PHASE,FE:MO:CR;0) 2.98150E+02 +7*GFEFCC#+2*GHSERMO# + +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(MU_PHASE,CR:MO:FE;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# + +4*GHSERFE#+130000-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(MU_PHASE,FE:MO:FE;0) 2.98150E+02 +39475-6.032*T+7*GFEFCC# + +2*GHSERMO#+4*GHSERFE#+GPMU1#; 6.00000E+03 N REF10 ! + PARAMETER G(MU_PHASE,CR:MO:MO;0) 2.98150E+02 +7*GCRFCC#+6*GHSERMO# + +130000-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(MU_PHASE,FE:MO:MO;0) 2.98150E+02 -46663-5.891*T+7*GFEFCC# + +6*GHSERMO#+GPMU2#; 6.00000E+03 N REF10 ! + PARAMETER G(MU_PHASE,CR,FE:MO:MO;0) 2.98150E+02 -45000; 6.00000E+03 + N REF115 ! + + + PHASE P_PHASE % 3 24 20 12 ! + CONSTITUENT P_PHASE :CR,FE : CR,FE,MO : MO : ! + + PARAMETER G(P_PHASE,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR# + +12*GHSERMO#+252300-100*T; 6.00000E+03 N REF133 ! + PARAMETER G(P_PHASE,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(P_PHASE,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(P_PHASE,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE# + +12*GHSERMO#+111361; 6.00000E+03 N REF132 ! + PARAMETER G(P_PHASE,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO# + +95573-200*T; 6.00000E+03 N REF133 ! + PARAMETER G(P_PHASE,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO# + +362525-332.7*T; 6.00000E+03 N REF132 ! + + + PHASE R_PHASE % 3 27 14 12 ! + CONSTITUENT R_PHASE :CR,FE : MO : CR,FE,MO : ! + + PARAMETER G(R_PHASE,CR:MO:CR;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO# + +12*GHSERCR#-20000; 6.00000E+03 N REF115 ! + PARAMETER G(R_PHASE,FE:MO:CR;0) 2.98150E+02 +27*GFEFCC#+14*GHSERMO# + +12*GHSERCR#+600260-620*T; 6.00000E+03 N REF115 ! + PARAMETER G(R_PHASE,CR:MO:FE;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO# + +12*GHSERFE#+645260-620*T; 6.00000E+03 N REF115 ! + PARAMETER G(R_PHASE,FE:MO:FE;0) 2.98150E+02 -77487-50.486*T+27*GFEFCC# + +14*GHSERMO#+12*GHSERFE#+GPR1#; 6.00000E+03 N REF10 ! + PARAMETER G(R_PHASE,CR:MO:MO;0) 2.98150E+02 +27*GCRFCC#+26*GHSERMO# + -20000; 6.00000E+03 N REF115 ! + PARAMETER G(R_PHASE,FE:MO:MO;0) 2.98150E+02 +313474-289.472*T + +27*GFEFCC#+26*GHSERMO#+GPR2#; 6.00000E+03 N REF10 ! + + + PHASE SIC % 2 1 1 ! + CONSTITUENT SIC :SI : C : ! + + PARAMETER G(SIC,SI:C;0) 2.98150E+02 -85572.2636+173.200518*T + -25.856*T*LN(T)-.02106825*T**2+3.2153E-06*T**3+438415*T**(-1); + 7.00000E+02 Y + -95145.9018+300.345769*T-45.093*T*LN(T)-.00366815*T**2 + +2.19983333E-07*T**3+1341065*T**(-1); 2.10000E+03 Y + -105007.971+360.308813*T-53.073*T*LN(T)-7.4525E-04*T**2 + +1.73166667E-08*T**3+3693345*T**(-1); 4.00000E+03 N REF286 ! + + + PHASE SIGMA % 3 8 4 18 ! + CONSTITUENT SIGMA :FE : CR,MO,V : CR,FE,MO,V : ! + + PARAMETER G(SIGMA,FE:CR:CR;0) 2.98150E+02 +8*GFEFCC#+22*GHSERCR#+92300 + -95.96*T+GPSIG1#; 6.00000E+03 N REF107 ! + PARAMETER G(SIGMA,FE:MO:CR;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO# + +18*GHSERCR#+488480-360*T; 6.00000E+03 N REF115 ! + PARAMETER G(SIGMA,FE:V:CR;0) 2.98150E+02 +155735-89.5976*T+8*GFEFCC# + +4*GHSERVV#+18*GHSERCR#; 6.00000E+03 N REF323 ! + PARAMETER G(SIGMA,FE:CR:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# + +18*GHSERFE#+117300-95.96*T+GPSIG2#; 6.00000E+03 N REF107 ! + PARAMETER G(SIGMA,FE:MO:FE;0) 2.98150E+02 -1813-27.272*T+8*GFEFCC# + +18*GHSERFE#+4*GHSERMO#; 6.00000E+03 N REF10 ! + PARAMETER G(SIGMA,FE:V:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV# + +18*GHSERFE#-157961+60.729*T; 6.00000E+03 N REF269 ! + PARAMETER G(SIGMA,FE:CR:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# + +18*GHSERMO#+312580-260*T; 6.00000E+03 N REF115 ! + PARAMETER G(SIGMA,FE:MO:MO;0) 2.98150E+02 +83326-69.618*T+8*GFEFCC# + +22*GHSERMO#; 6.00000E+03 N REF10 ! + PARAMETER G(SIGMA,FE:V:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV# + +18*GHSERMO#; 6.00000E+03 N REF136 ! + PARAMETER G(SIGMA,FE:CR:V;0) 2.98150E+02 -245761-67.3294*T+8*GFEFCC# + +4*GHSERCR#+18*GHSERVV#; 6.00000E+03 N REF323 ! + PARAMETER G(SIGMA,FE:MO:V;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO# + +18*GHSERVV#; 6.00000E+03 N REF136 ! + PARAMETER G(SIGMA,FE:V:V;0) 2.98150E+02 +8*GFEFCC#+22*GHSERVV#-205321 + -60.967*T; 6.00000E+03 N REF269 ! + PARAMETER G(SIGMA,FE:CR:CR,MO;0) 2.98150E+02 -148000; 6.00000E+03 N + REF115 ! + PARAMETER G(SIGMA,FE:MO:CR,MO;0) 2.98150E+02 121000; 6.00000E+03 N + REF115 ! + PARAMETER G(SIGMA,FE:CR:FE,MO;0) 2.98150E+02 570000; 6.00000E+03 N + REF115 ! + PARAMETER G(SIGMA,FE:CR:FE,V;0) 2.98150E+02 -235158; 6.00000E+03 N + REF323 ! + PARAMETER G(SIGMA,FE:MO:FE,MO;0) 2.98150E+02 222909; 6.00000E+03 N + REF10 ! + PARAMETER G(SIGMA,FE:V:FE,V;0) 2.98150E+02 -305784; 6.00000E+03 N + REF269 ! + + + PHASE V3C2 % 2 3 2 ! + CONSTITUENT V3C2 :FE,V : C : ! + + PARAMETER G(V3C2,FE:C;0) 2.98150E+02 +7250+741.566*T-125.833*T*LN(T) + +779485*T**(-1); 6.00000E+03 N REF275 ! + PARAMETER G(V3C2,V:C;0) 2.98150E+02 -260341+16.897*T+3*GHSERVV# + +2*GHSERCC#; 6.00000E+03 N REF256 ! + + LIST_OF_REFERENCES + NUMBER SOURCE + REF283 'Alan Dinsdale, SGTE Data for Pure Elements, + Calphad Vol 15(1991) p 317-425, + also in NPL Report DMA(A)195 Rev. August 1990' + REF101 'J-O Andersson, Calphad Vol 11 (1987) p 271-276, TRITA 0314; C-CR' + REF190 'P. Gustafson, Scan. J. Metall. vol 14, (1985) p 259-267 + TRITA 0237 (1984); C-FE' + REF104 'J-O Andersson, Calphad Vol 12 (1988) p 1-8 TRITA 0317 (1986); C + -MO' + REF98 'J. Lacaze and B. Sundman, provisional; Fe-Si' + REF256 'W. Huang, TRITA-MAC 431 (1990); C-V' + REF267 'W. Huang, Metall. Trans. Vol 21A(1990) p 2115-2123, + TRITA-MAC 411 (Rev 1989); C-FE-MN' + REF177 'NPL, unpublished work (1989); C-Mn-Si' + REF275 'W. Huang, TRITA-MAC 441 (1990), Fe-Mn-V-C *' + REF322 'Byeong-Joo Lee, unpublished revision (1991); C-Cr-Fe-Ni' + REF213 'P. Gustafson, TRITA-MAC 342, (1987); CR-FE-W' + REF115 'J-O Andersson, Met Trans A, Vol 19A, (1988) p 1385-1394 + TRITA 0322 (1986); CR-FE-MO' + REF324 'Byeong-Joo Lee, TRITA-MAC 475 (1991), C-Cr-Fe-V' + REF90 'I Ansara, unpublished work (1991); Cr-Si' + REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 + September 1989' + REF319 'H. Du and M. Hillert, revision; C-Fe-N' + REF99 'J. Lacaze and B. Sundman, Met. Trans A, Vol 22A (1991) + pp 2211-2223; C-Fe-Si' + REF316 'Caian Qui, Trita-MAC 482 (1992) Revision ; C-Cr-Fe-Mo' + REF113 'J-O Andersson, Calphad Vol 12 (1988), p 9-23 + TRITA 0321 (1986); C-FE-MO' + REF214 'P. Gustafson, TRITA-MAC 354 (1987); C-Cr-Fe-Mo-W' + REF10 'A. Fernandez Guillermet, CALPHAD Vol 6 (1982), p 127-140 + (sigma phase revised 1986), TRITA-MAC 200 (1982); FE-MO' + REF102 'J-O Andersson, Met. Trans A, Vol 19A, (1988) p 627-636 + TRITA 0207 (1986); C-CR-FE' + REF323 'Byeong-Joo Lee, TRITA-MAC 474 (1991), Cr-Fe-V' + REF42 'Annika Forsberg and John ]gren, TRITA-MAC 483 (1992); Fe-Mn-Si' + REF220 'P Gustafson, Inst. Met. Res. (Sweden) (1990); Estimations of + C-CR-FE-V, C-CR-FE-MO-V-W, FE-N-W, FE-MN-N, FE-N-SI, CR-N-V, C-CR + -N, + FE-MO-N, CR-N-W, CR-TI-N' + REF133 'K. Frisk, TRITA-MAC 429 (1990); CR-MO-NI' + REF132 'K. Frisk, TRITA-MAC 428 (1990); FE-MO-NI' + REF286 'SGTE Substance database, AUG 1989.' + REF107 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 + TRITA 0270 (1986); CR-FE' + REF269 'W. Huang, TRITA-MAC 432 (Rev 1989,1990); FE-V' + REF136 'Unassessed parameter, linear combination of unary data. (MU, + SIGMA)' + REF123 'K. Frisk, Report D 60, KTH, (1984); CR-MO' + REF325 'Byeong-Joo Lee, unpublished revision (1991), C-Cr-Fe-Mo-Ni' + REF270 'W. Huang, TRITA-MAC 432 (1990); C-Fe-V' + REF58 'B. Sundman, TEST' + REF207 'P. Gustafson, Metall. Trans. 19A(1988) p 2547-2554, + TRITA-MAC 348, (1987); C-CR-FE-W' + REF126 'K. Frisk, Metall. Trans. Vol 21A (1990) p 2477-2488, + TRITA 0409 (1989); CR-FE-N' + REF117 'J-O Andersson, TRITA-MAC 323 (1986); C-CR-FE-MO' + REF111 'J-O Andersson, CALPHAD Vol 7, (1983), p 305-315 (parameters + revised + 1986 due to new decription of V) TRITA 0201 (1982); FE-V' + ! + diff --git a/TQ3lib-clean/isoC-matthias/tqintf.cpp b/TQ3lib-clean/isoC-matthias/tqintf.cpp new file mode 100644 index 0000000..acb3769 --- /dev/null +++ b/TQ3lib-clean/isoC-matthias/tqintf.cpp @@ -0,0 +1,213 @@ +#include "tqintf.h" + +void example_1(string fname, double t, double p, double n, vector x); +void example_2(string fname, int phidx, double t, double p, double n, + vector x, vector y); +void example_3(string fname, int phidx, double t, double p, double n, + vector y); + + +int main(int argc, char **argv) +{ + + /******************* EXAMPLE 1 ******************* + + Similar to /C/cexample1: + calls the TQ-Interface for any given thermodynamic + database file {FILENAME}, sets conditions specified + in this function {T}, {P}, {N} and {X[*]} and prints + the output of the thermodynamic equilibrium calculation. + + string FILENAME = "FENI.TDB"; // Name of the thermodynamic database file (*.TDB, *.tdb) + int I = 1; // Number of Phase + double T = 778.0; // Temperature in K + double P = 1.0e5; // Pressure in Pa + double N = 1.0; // Number of moles + vector X; // Concentration array for phase I + X.push_back(0.6); // manual override of X[0] + X.push_back(0.4); // manual override of X[1] + //X.push_back(0.3); // .. and so on .. X[2] + + example_1(FILENAME, T, P, N, X); // Call to Example 1 + + /**************************************************/ + + + + + /******************* EXAMPLE 2 ******************* + + Similar to /F90/test4:: + calls the TQ-Interface for any given thermodynamic + database file {FILENAME}, suspends all phases except + phase {I}, sets conditions for this single phase as + specified in this function {T}, {P}, {N} and {X[*]} + and prints the output of the thermodynamic values + like the Gibbs energy, the partial derivative of the + Gibbs energy with respect to every single site fraction + without doing a thermodyamic equilibrium calculation.*/ + + string FILENAME = "steel1.TDB"; // Name of the thermodynamic database file (*.TDB, *.tdb) + int I = 2; // Number of Phase + double T = 8.0e2; // Temperature in K + double P = 1.0e5; // Pressure in Pa + double N = 1.0; // Number of moles + vector X; // Concentration array for the system + X.push_back(0.3); // manual override of X[0] + vector Y; // Constituents array for phase I + Y.push_back(0.197577); // manual override of Y[0] + Y.push_back(0.802423); // manual override of Y[1] + Y.push_back(1); // manual override of Y[2] + + example_2(FILENAME, I, T, P, N, X, Y); // Call to Example 2 + + /**************************************************/ + + + + + + /******************* EXAMPLE 3 ******************* + + experimental - work in progress + + ************************************************* + + string FILENAME = "steel1.TDB"; // Name of the thermodynamic database file (*.TDB, *.tdb) + int I = 2; // Number of Phase + double T = 8.0e2; // Temperature in K + double P = 1.0e5; // Pressure in Pa + double N = 1.0; // Number of moles + vector X; // Concentration array for the system + X.push_back(0.3); // manual override of X[0] + + example_3(FILENAME, I, T, P, N, X); // Call to Example 3 + + /**************************************************/ + + return 0; +} + +/********************************** EXAMPLE 1 *********************************/ + +void example_1(string fname, double t, double p, double n, vector x) +{ + void *ceq = 0; // Pointer to the OpenCalphad storage + vector > elfract; // Array including all equilibrium compositions + vector phnames; // Array including all phase names + vector phfract; // Array including all phase fractions + + //-----------------------Initialize and read TDB data----------------------- + + Initialize(&ceq); // Initialize OpenCalphad and allocate memory + ReadDatabase(fname, &ceq); // Define TDB-file and read elements + ReadPhases(phnames, &ceq); // Read Phases data + SetTemperature(t, &ceq); // Set Temperature + SetPressure(p, &ceq); // Set Pressure + SetMoles(n, &ceq); // Set Number of moles + SetComposition(x, &ceq); // Set Composition of the system + + //---------------------------Calculate Equilibrium-------------------------- + + CalculateEquilibrium(&ceq); // Calculate a phase equilibrium + + //-------------------------------List Results------------------------------- + + ListPhaseFractions(phnames, phfract, &ceq); // Write output of the amount of stable phases + ListConstituentFractions(phnames, phfract, elfract, &ceq); // Write output of the composition of each stable phase + +} + +/********************************** EXAMPLE 2 *********************************/ + +void example_2(string fname, int phidx, double t, double p, double n, + vector x, vector y) +{ + void *ceq = 0; // Pointer to the OpenCalphad storage + vector elnames; // Array including selected elements + elnames.push_back("CR"); + elnames.push_back("FE"); + vector phnames; // Array including all phase names + vector phfract; // Array including all phase fractions + vector > elfract; // Array including all equilibrium compositions + + //-----------------------Initialize and read TDB data----------------------- + + Initialize(&ceq); // Initialize OpenCalphad and allocate memory + ReadDatabaseLimited(fname, elnames, &ceq); // Define TDB-file and read only selected elements + ReadPhases(phnames, &ceq); // Read Phases data + SetTemperature(t, &ceq); // Set Temperature + SetPressure(p, &ceq); // Set Pressure + SetMoles(n, &ceq); // Set Number of moles + SetComposition(x, &ceq); // Set Composition of the system + + //---------------------------Calculate Equilibrium-------------------------- + + CalculateEquilibrium(&ceq); + + //-------------------------------List Results------------------------------- + + ListPhaseFractions(phnames, phfract, &ceq); // Write output of the amount of stable phases + ListConstituentFractions(phnames, phfract, elfract, &ceq); // Write output of the composition of each stable phase + ListExtConstituentFractions(phidx, phnames, &ceq); // Write output of the constituents of a given phase + + //----------------------------Change Parameters----------------------------- + + SetConstituents(phidx, y, &ceq); // Set Constituents of the phase + + //-------------------------------List Results------------------------------- + + GetGibbsData(phidx, &ceq); // Write output of the thermodynamic values of the given parameters +}; + +/********************************** EXAMPLE 3 *********************************/ + +void example_3(string fname, int phidx, double t, double p, double n, + vector x) +{ + void *ceq = 0; // Pointer to the OpenCalphad storage + vector elnames; // Array including selected elements + elnames.push_back("CR"); + elnames.push_back("FE"); + vector phnames; // Array including all phase names + vector phfract; // Array including all phase fractions + vector > elfract; // Array including all equilibrium compositions + + //-----------------------Initialize and read TDB data----------------------- + + Initialize(&ceq); // Initialize OpenCalphad and allocate memory + ReadDatabaseLimited(fname, elnames, &ceq); // Define TDB-file and read only selected elements + ReadPhases(phnames, &ceq); // Read Phases data + SetTemperature(t, &ceq); // Set Temperature + SetPressure(p, &ceq); // Set Pressure + SetMoles(n, &ceq); // Set Number of moles + SetComposition(x, &ceq); // Set Composition of the system + + //---------------------------Calculate Equilibrium-------------------------- + + CalculateEquilibrium(&ceq); + + //-------------------------------List Results------------------------------- + + ListPhaseFractions(phnames, phfract, &ceq); // Write output of the amount of stable phases + ListConstituentFractions(phnames, phfract, elfract, &ceq); // Write output of the composition of each stable phase + ListExtConstituentFractions(phidx, phnames, &ceq); // Write output of the constituents of a given phase + + for(int i = 0; i < 10; i++) + { + cout << "========== " << i << " / 10 ==========" << endl; + double constit = i/10.0; + vector y; // Constituents array for phase I + y.push_back(constit); // manual override of Y[0] + y.push_back(1-constit); // manual override of Y[1] + y.push_back(1); // manual override of Y[2] + + //--------------------------Change Parameters--------------------------- + + SetConstituents(phidx, y, &ceq); // Set Constituents of the phase + + //-----------------------------List Results----------------------------- + + GetGibbsData(phidx, &ceq); // Write output of the thermodynamic values of the given parameters + } +}; diff --git a/TQ3lib-clean/isoC-matthias/tqintf.h b/TQ3lib-clean/isoC-matthias/tqintf.h new file mode 100644 index 0000000..ba4588d --- /dev/null +++ b/TQ3lib-clean/isoC-matthias/tqintf.h @@ -0,0 +1,434 @@ +#define MAXEL 10 +#define MAXPH 20 +#include "octqc.h" +#include +#include +#include +#include +#include + +extern"C" +{ + void c_tqini(int, void *); // initiates the OC package + void c_tqrfil(char *, void *); // read all elements from a TDB file + //void c_tqgcom(int *, char[MAXEL][24], void **); // get system component names. At present the elements + void c_tqrpfil(char *, int, char **, void *); // read TDB file with selection of elements + //void c_tqgnp(int *, void **); // get total number of phases and composition sets + void c_tqgpn(int, char *, void *); // get name of phase+compset tuple with index phcsx + void c_tqgetv(char *, int, int, int *, double *, void *); // get equilibrium results using state variables + void c_tqsetc(char *, int, int, double, int *, void *); // set condition + void c_tqce(char *, int, int, double *, void *); // calculate quilibrium with possible target + //void c_tqgnp(int, gtp_equilibrium_data **); // get total number of phases and composition sets + void examine_gtp_equilibrium_data(void *); // + //void c_getG(int, void *); + //void c_calcg(int, int, int, int, void *); + void c_tqgphc1(int, int * , int *, int *, double *, double *, double *, + void *); + void c_tqsphc1(int, double *, double *, void *); + void c_tqcph1(int, int, int *, double *, double *, double *, double *, double *, void *); +} + +extern"C" int c_ntup; // +extern"C" int c_nel; // number of elements +extern"C" int c_maxc; // +extern"C" char *c_cnam[24]; // character array with all element names +extern"C" double c_gval[24]; +extern"C" int c_noofcs(int); + +using namespace std; + +void Initialize(void *ceq) +{ + int n = 0; + + //=============== + c_tqini(n, ceq); + //=============== + + cout << "-> Adress of ceq-Storage: [" << &ceq << "]" << + endl; +}; + +void ReadDatabase(string fname, void *ceq) +{ + char *filename = strcpy((char*)malloc(fname.length()+1), fname.c_str()); + + //====================== + c_tqrfil(filename, ceq); + //====================== + + cout << "-> Element Data: ["; + for(int i = 0; i < c_nel; i++) + { + cout << c_cnam[i]; + if(i < c_nel-1) + { + cout << ", "; + } + } + cout << "]" << " [" << &ceq << "]" << + endl; +}; + +void ReadDatabaseLimited(string fname, vector elnames, void *ceq) +{ + char *filename = strcpy((char*)malloc(fname.length()+1), fname.c_str()); + char *selel[elnames.size()]; + for(int i = 0; i < elnames.size(); i++) + { + char *tempchar + = strcpy((char*)malloc(elnames[i].length()+1), elnames[i].c_str()); + selel[i] = tempchar; + } + + //============================================== + c_tqrpfil(filename, elnames.size(), selel, ceq); + //============================================== + + cout << "-> Element Data: ["; + for(int i = 0; i < c_nel; i++) + { + cout << c_cnam[i]; + if(i < c_nel-1) + { + cout << ", "; + } + } + cout << "]" << " [" << &ceq << "]" << + endl; + + +}; + +void ReadPhases(vector &phnames, void *ceq) +{ + phnames.clear(); + + for(int i = 1; i < c_ntup+1; i++) + { + char phn[24]; + + //========================== + c_tqgpn(i, phn, ceq); + //========================== + + phnames.push_back(phn); + } + + cout << "-> Phase Data: ["; + for(int i = 0; i < phnames.size(); i++) + { + cout << phnames[i]; + if(i < phnames.size()-1) + { + cout << ", "; + } + } + cout << "]" << " [" << &ceq << "]" << + endl; +}; + +void SetTemperature(double T, void *ceq) +{ + int cnum; + int n1 = 0; + int n2 = 0; + char par[60] = "T"; + if (T < 1.0) T = 1.0; + + //========================================= + c_tqsetc(par, n1, n2, T, &cnum, ceq); + //========================================= + + cout << "-> Set Temperature to: [" << T << "]" << " [" << &ceq << "]" << + endl; +}; + +void SetPressure(double P, void *ceq) +{ + int cnum; + int n1 = 0; + int n2 = 0; + char par[60] = "P"; + if (P < 1.0) P = 1.0; + + //========================================= + c_tqsetc(par, n1, n2, P, &cnum, ceq); + //========================================= + + cout << "-> Set Pressure to: [" << P << "]" << " [" << &ceq << "]" << + endl; +}; + +void SetMoles(double N, void *ceq) +{ + int cnum; + int n1 = 0; + int n2 = 0; + char par[60] = "N"; + + //========================================= + c_tqsetc(par, n1, n2, N, &cnum, ceq); + //========================================= + + cout << "-> Set Moles to: [" << N << "]" << " [" << &ceq << "]" << + endl; +}; + +void SetComposition(vector X, void *ceq) +{ + int cnum; + int n1 = 0; + int n2 = 0; + char par[60] = "X"; + + for (int i = 0; i < c_nel; i++) + { + if (X[i] < 1.0e-6) X[i] = 1.0e-6; // Check and fix, if composition is below treshold + + if(i < c_nel - 1) + { // Set and print composition, if element 'i' is not the reference/(last) element + //================================================== + c_tqsetc(par, i+1, n2, X[i], &cnum, ceq); + //================================================== + + cout << "-> Set Composition of " << c_cnam[i] << " to: [" << + X[i] << "]" << " [" << &ceq << "]" << + endl; + } + else + { // Print composition, if element 'i' is the reference/(last) element + double X_ref = 1; + for(int j = 0; j < i; j++) + { + X_ref -= X[j]; + } + + cout << "-> Set Composition of " << c_cnam[i] << " to: [" << + X_ref << "]" << " [" << &ceq << "]" << + endl; + } + } +}; + +void SetConstituents(int phidx, vector y, void *ceq) +{ + int stable1 = phidx; + double extra[MAXPH]; + double yfr[y.size()]; + for(int i = 0; i < y.size(); i++) + { + yfr[i] = y[i]; + } + + //=============================== + c_tqsphc1(stable1,yfr,extra,ceq); + //=============================== + + cout << "-> Set Constituents to: ["; + for(int i = 0; i < y.size(); i++) + { + cout << i << ": " << yfr[i]; + if(i < y.size()-1) + { + cout << ", "; + } + } + cout << "]" << endl; +}; + + +void SelectSinglePhase(int PhIdx, void *ceq) +{ + // +}; + +void CalculateEquilibrium(void *ceq) +{ + char target[60] = " "; + int null1 = 0; + int null2 = 0; + double val; + + //====================================== + c_tqce(target, null1, null2, &val, ceq); + //====================================== + + cout << "-> Calculated Equilibrium [" << ceq << "]" + << endl; +}; + +void GetGibbsData(int phidx, void *ceq) +{ + int n2 = 2; + int n3; + double gtp[6]; + double dgdy[100]; + double d2gdydt[100]; + double d2gdydp[100]; + double d2gdy2[100]; + + //================================================================= + c_tqcph1(phidx, n2, &n3, gtp, dgdy, d2gdydt, d2gdydp, d2gdy2, ceq); + //================================================================= + + cout << "-> Read Gibbs Data G: ["; + for(int i = 0; i < 6; i++) + { + cout << gtp[i]; + if(i < 5) + { + cout << ", "; + } + } + cout << "]" << endl; + + cout << "-> Read Gibbs Data dGdY: ["; + for(int i = 0; i < n3; i++) + { + cout << dgdy[i]; + if(i < n3-1) + { + cout << ", "; + } + } + cout << "]" << endl; + + cout << "-> Read Gibbs Data d2GdYdT: ["; + for(int i = 0; i < n3; i++) + { + cout << d2gdydt[i]; + if(i < n3-1) + { + cout << ", "; + } + } + cout << "]" << endl; + + cout << "-> Read Gibbs Data d2GdYdP: ["; + for(int i = 0; i < n3; i++) + { + cout << d2gdydp[i]; + if(i < n3-1) + { + cout << ", "; + } + } + cout << "]" << endl; + + int kk=n2*(n2+1)/2; + + cout << "-> Read Gibbs Data d2GdY2: ["; + for(int i = 0; i < kk; i++) + { + cout << d2gdy2[i]; + if(i < kk-1) + { + cout << ", "; + } + } + cout << "]" << endl; +}; + +void ListPhaseFractions(vector phnames, vector& phfract, + void *ceq) +{ + double npf[MAXPH]; + char statevar[60] = "NP"; + int n1 = -1; + int n2 = 0; + int n3 = MAXPH;//sizeof(npf) / sizeof(npf[0]); + + //======================================== + c_tqgetv(statevar, n1, n2, &n3, npf, ceq); + //======================================== + + for(int i = 0; i < n3; i++) + phfract.push_back(npf[i]); + + cout << "-> Phase Fractions: ["; + for (int i = 0; i < n3; i++) + { + cout << phnames[i] << ": " << phfract[i]; + if(i < n3-1) + { + cout << ", "; + } + } + cout << "]" << " [" << &ceq << "]" << + endl; +}; + +void ListConstituentFractions(vector phnames, vector phfract, + vector > elfract, void *ceq) +{ + elfract.clear(); + elfract.resize(phnames.size()); + double pxf[10*MAXPH]; + for (int i = 1; i < c_ntup+1; i++) + { + if (phfract[i-1] > 0.0) + { + char* statevar = "X"; + int n1 = 0; + int n2 = -1; //composition of stable phase n2 = -1 means all fractions + int n4 = sizeof(pxf)/sizeof(pxf[0]); + + //======================================= + c_tqgetv(statevar, i, n2, &n4, pxf, ceq); + //======================================= + + for (int k = 0; k < n4; k++) + { + elfract[i-1].push_back(pxf[k]); + } + cout << "-> Constituent Fractions for " << phnames[i-1] << + " ["; + + for (int k = 0; k < n4; k++) + { + cout << c_cnam[k] << ": " << elfract[i-1][k]; + if(k < n4-1) + { + cout << ", "; + } + } + cout << "]" << " [" << &ceq << "]" << + endl; + } + } +}; + +void ListExtConstituentFractions(int phidx, vector phnames, void *ceq) +{ + int stable1 = phidx; + int nlat; + int nlatc[MAXPH]; + int conlista[MAXPH]; + double yfr[MAXPH]; + double sites[MAXPH]; + double extra[MAXPH]; + + //====================================================================== + c_tqgphc1(stable1, &nlat, nlatc, conlista, yfr, sites, extra, ceq); + //====================================================================== + + cout << "-> Extended Constituent Fractions for " << phnames[stable1-1] + << " [" << extra[0] << " moles of atoms/formula unit]"; + int consti = 0; + for(int i = 0; i < nlat; i++) + { + cout << " ["; + for(int j = 0; j < nlatc[i]; j++) + { + cout << "Const. " << consti << ": " << yfr[consti]; + if(j < nlatc[i]-1) + { + cout << ", "; + } + consti += 1; + } + cout << "]_(" << sites[i] << ")"; + } + cout << endl; +}; diff --git a/TQlib/liboctq.F90 b/TQ3lib-clean/liboctq.F90 similarity index 70% rename from TQlib/liboctq.F90 rename to TQ3lib-clean/liboctq.F90 index 3f70f37..44a0620 100644 --- a/TQlib/liboctq.F90 +++ b/TQ3lib-clean/liboctq.F90 @@ -1,759 +1,1040 @@ -! -! Minimal TQ interface. -! -! To compile and link this with an application one must first compile -! and form a library with of the most OC subroutines (oclib.a) -! and to copy this and the corresponding "mov" files from this compilation -! to the folder with this library -! -! NOTE that for the identification of phase and composition sets this -! TQ interface use a Fortran TYPE called gtp_phasetuple containing two -! integers, "phase" with the phase number and "compset" with the -! comp.set The number of phase tuples is initially equal to the number -! of phases and have the same index. This represent comp.set 1 of the -! phases. A phase may have several comp.sets created by calculations -! or by commands and these will have phase tuple index higher than the -! number of phases and they are in the order they were created. This -! may cause some problems as internally in OC all comp.sets are -! ordered sequantially for each phase. If a comp.set is removed those -! with higher index will be moved down so there are no gaps. So do -! not delete comp.sets or at least be very careful when deleting -! comp.sets. -! -! When not using Fortran 95 (or later) one can probably replace this -! with a 2-dimensional array with first index phase number and second -! the comp.set number. -! -! For constituents an EXTENDED CONSTITUENT INDEX is sometimes used -! and equal to 10*species_number + sublattice -! -! 141210 BOS changed to use phase tuples -! 140128 BOS added D2G and phase specific V and G -! 140128 BOS added possibility to calculate without invoking grid minimizer -! 140125 BOS Changed name to liboctq -! 140123 BOS Added ouput of MQ G, V and normalized -! -! The name of this librqry -module liboctq -! -! access to main OC library for equilibrium calculations and models - use liboceq -! - implicit none -! - integer, parameter :: maxc=20,maxp=100 -! -! This is for storage and use of components - integer nel - character, dimension(maxc) :: cnam*24 -! This is for storage and use of phase+composition tuples - integer ntup - type(gtp_phasetuple), dimension(maxp) :: phcs -! -contains -! -!\begin{verbatim} - subroutine tqini(n,ceq) -! initiate workspace - implicit none - integer n ! Not nused, could be used for some initial allocation - type(gtp_equilibrium_data), pointer :: ceq ! EXIT: current equilibrium -!\end{verbatim} -! these should be provide linits and defaults - integer intv(10) - double precision dblv(10) - intv(1)=-1 -! This call initiates the OC package - call init_gtp(intv,dblv) -1000 continue - return - end subroutine tqini - -!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ - -!\begin{verbatim} - subroutine tqrfil(filename,ceq) -! read all elements from a TDB file - implicit none - character*(*) filename ! IN: database filename - character ellista(10)*2 ! dummy - type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium -!\end{verbatim} - integer iz - character elname*2,name*24,refs*24 - double precision a1,a2,a3 -! second argument 0 means ellista is ignored, all element read - call readtdb(filename,0,ellista) - ceq=>firsteq - nel=noel() - do iz=1,nel -! store element name in module array components - call get_element_data(iz,elname,name,refs,a1,a2,a3) - cnam(iz)=elname - enddo -! store phase tuples and indices - ntup=get_phtuplearray(phcs) -1000 continue - return - end subroutine tqrfil - -!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ - -!\begin{verbatim} - subroutine tqrpfil(filename,nsel,selel,ceq) -! read TDB file with selection of elements - implicit none - character*(*) filename ! IN: database filename - integer nsel,i - character selel(*)*2 ! IN: elements to be read from the database - type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium -!\end{verbatim} - integer iz - character elname*2,name*24,refs*24 - double precision a1,a2,a3 -! - call readtdb(filename,nsel,selel) - if(gx%bmperr.ne.0) goto 1000 - ceq=>firsteq - nel=noel() - do iz=1,nel -! store element name in module array components - call get_element_data(iz,elname,name,refs,a1,a2,a3) - cnam(iz)=elname - enddo -! store phase tuples and indices - ntup=get_phtuplearray(phcs) -1000 continue - return - end subroutine tqrpfil - -!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ - -!\begin{verbatim} - subroutine tqgcom(n,compnames,ceq) -! get system component names. At present the elements - implicit none - integer n ! EXIT: number of components - character*24, dimension(*) :: compnames ! EXIT: names of components - type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium -!\end{verbatim} - integer iz - character elname*24,refs*24 - double precision a1,a2,a3 - do iz=1,nel - compnames(iz)=' ' - call get_element_data(iz,compnames(iz),elname,refs,a1,a2,a3) -! store name in module array components also (already done when reading TDB) - cnam(iz)=compnames(iz) - enddo -1000 continue - return - end subroutine tqgcom - -!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ - -!\begin{verbatim} - subroutine tqgnp(n,ceq) -! get total number of phases and composition sets -! A second composition set of a phase is normally placed after all other -! phases with one composition set - implicit none - integer n !EXIT: n is number of phases - type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium -!\end{verbatim} -! This call fills the module array phcs with phase and composition set indices -! NOTE the number composition sets may change at a calculation or if new -! composition sets are added or deleted explicitly - ntup=get_phtuplearray(phcs) - n=ntup -1000 continue - return - end subroutine tqgnp - -!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ - -!\begin{verbatim} - subroutine tqgpn(phcsx,phasename,ceq) -! get name of phase+compset tuple with index phcsx - implicit none - integer phcsx ! IN: index in phase tuple array -! TYPE(gtp_phasetuple), pointer :: phcs !IN: phase number and comp.set - character phasename*(*) !EXIT: phase name, max 24+8 for pre/suffix - type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium -!\end{verbatim} - call get_phase_name(phcs(phcsx)%phase,phcs(phcsx)%compset,phasename) -1000 continue - return - end subroutine tqgpn - -!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ - -!\begin{verbatim} - subroutine tqgpi(phcsx,phasename,ceq) -! get index of phase phasename (including comp.set, ceq not needed ... - implicit none - integer phcsx !EXIT: phase tuple index - character phasename*(*) !IN: phase name - type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium -!\end{verbatim} - call find_phasetuple_by_name(phasename,phcsx) -1000 continue - return - end subroutine tqgpi - -!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ - -!\begin{verbatim} - subroutine tqgpcn(n,c,constituentname,ceq) -! get name of consitutent c in phase n - implicit none - integer n !IN: phase number - integer c !IN: extended constituent index: 10*species_number+sublattice - character constituentname*(24) !EXIT: costituent name - type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium -!\end{verbatim} - write(*,*)'tqgpcn not implemented yet' - gx%bmperr=8888 -1000 continue - return - end subroutine tqgpcn - -!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ - -!\begin{verbatim} - subroutine tqgpci(n,c,constituentname,ceq) -! get index of constituent with name in phase n - implicit none - integer n !IN: phase index - integer c !EXIT: extended constituent index: 10*species_number+sublattice - character constituentname*(*) - type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium -!\end{verbatim} - write(*,*)'tqgpci not implemented yet' - gx%bmperr=8888 -1000 continue - return - end subroutine tqgpci - -!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ - -!\begin{verbatim} - subroutine tqgpcs(n,c,stoi,mass,ceq) -! get stoichiometry of constituent c in phase n -!? missing argument number of elements???? - implicit none - integer n !IN: phase number - integer c !IN: extended constituent index: 10*species_number+sublattice - double precision stoi(*) !EXIT: stoichiometry of elements - double precision mass !EXIT: total mass - type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium -!\end{verbatim} - write(*,*)'tqgpcs not implemented yet' - gx%bmperr=8888 -1000 continue - return - end subroutine tqgpcs - -!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ - -!\begin{verbatim} - subroutine tqgccf(n1,n2,elnames,stoi,mass,ceq) -! get stoichiometry of component n1 -! n2 is number of elements (dimension of elnames and stoi) - implicit none - integer n1 !IN: component number - integer n2 !EXIT: number of elements in component - character elnames(*)*(2) ! EXIT: element symbols - double precision stoi(*) ! EXIT: element stoichiometry - double precision mass ! EXIT: component mass (sum of element mass) - type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium -!\end{verbatim} - write(*,*)'tqgccf not implemented yet' - gx%bmperr=8888 -1000 continue - return - end subroutine tqgccf - -!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ - -!\begin{verbatim} - subroutine tqgnpc(n,c,ceq) -! get number of constituents of phase n - implicit none - integer n !IN: Phase number - integer c !EXIT: number of constituents - type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium -!\end{verbatim} - write(*,*)'tqgnpc not implemented yet' - gx%bmperr=8888 -1000 continue - return - end subroutine tqgnpc - -!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ - -!\begin{verbatim} - subroutine tqphsts(tup,newstat,val,ceq) -! set status of phase tuple, - integer tup,newstat - double precision val - type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium -!\end{verbatim} - integer n - if(tup.le.0) then - do n=1,ntup - call change_phase_status(phcs(n)%phase,phcs(n)%compset,& - newstat,val,ceq) - if(gx%bmperr.ne.0) goto 1000 - enddo - elseif(tup.le.ntup) then - call change_phase_status(phcs(tup)%phase,phcs(tup)%compset,& - newstat,val,ceq) - else - write(*,*)'Illegal phase tuple index' - gx%bmperr=5001 - endif -1000 continue - return - end subroutine tqphsts - -!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ - -!\begin{verbatim} - subroutine tqsetc(stavar,n1,n2,value,cnum,ceq) -! set condition -! stavar is state variable as text -! n1 and n2 are auxilliary indices -! value is the value of the condition -! cnum is returned as an index of the condition. -! to remove a condition the value sould be equial to RNONE ???? -! when a phase indesx is needed it should be 10*nph + ics -! SEE TQGETV for doucumentation of stavar etc. - implicit none - integer n1 ! IN: 0 or phase tuple index or component number - integer n2 ! IN: 0 or component number - integer cnum ! EXIT: sequential number of this condition - character stavar*(*) ! IN: character with state variable symbol - double precision value ! IN: value of condition - type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium -!\end{verbatim} - integer ip - character cline*60,selvar*4 -! -! write(*,11)'In tqsetc ',stavar(1:len_trim(stavar)),n1,n2,value -11 format(a,a,2i5,1pe14.6) - cline=' ' - selvar=stavar - call capson(selvar) - select case(selvar) - case default - write(*,*)'Condition wrong, not implemented or illegal: ',stavar - gx%bmperr=8888; goto 1000 -! Potentials T and P - case('T ','P ') - write(cline,110)selvar(1:1),value -110 format(' ',a,'=',E15.8) -! Total amount or amount of a component in moles - case('N ') - if(n1.gt.0) then -! call get_component_name(n1,name,ceq) -! if(gx%bmperr.ne.0) goto 1000 - write(cline,112)selvar(1:1),cnam(n1)(1:len_trim(cnam(n1))),value -112 format(' ',a,'(',a,')=',E15.8) - else - write(cline,110)selvar(1:1),value - endif -! Overall fraction of a component - case('X ','W ') -! ?? fraction of phase component not implemented, n1 must be component number -! call get_component_name(n1,cnam,ceq) -! if(gx%bmperr.ne.0) goto 1000 - write(cline,120)selvar(1:1),cnam(n1)(1:len_trim(cnam(n1))),value -120 format(1x,a,'(',a,')=',1pE15.8) -! ?? MORE CONDITIONS WILL BE ADDED ... - end select -! write(*,*)'tqsetc: ',cline(1:len_trim(cline)) - ip=1 - call set_condition(cline,ip,ceq) -1000 continue - return - end subroutine tqsetc - -!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ - -!\begin{verbatim} - subroutine tqce(target,n1,n2,value,ceq) -! calculate quilibrium with possible target -! Target can be empty or a state variable with indices n1 and n2 -! value is the calculated value of target - implicit none - integer n1,n2,mode - character target*(*) - double precision value - type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium -!\end{verbatim} -! mode=1 means start values using global gridminimization - mode=1 - if(n1.lt.0) then -! this means calculate without grid minimuzer - write(*,*)'No grid minimizer' - mode=0 - endif - call calceq2(mode,ceq) - if(gx%bmperr.ne.0) goto 1000 -! there may be new composition sets, update tup and phcs -! this call updates both the number of tuples and the phcs array - ntup=get_phtuplearray(phcs) -1000 continue - return - end subroutine tqce - -!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ - -!\begin{verbatim} - subroutine tqgetv(stavar,n1,n2,n3,values,ceq) -! get equilibrium results using state variables -! stavar is the state variable IN CAPITAL LETTERS with indices n1 and n2 -! n1 can be a phase tuple index, n2 a component index -! n3 at the call is the dimension of the array values, -! changed to number of values on exit -! value is an array with the calculated value(s), n3 set to number of values. - implicit none - integer n1,n2,n3 - character stavar*(*) - double precision values(*) - type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium -!======================================================== -! stavar must be a symbol listed below -! IMPORTANT: some terms explained after the table -! Symbol index1,index2 Meaning (unit) -!.... potentials -! T 0,0 Temperature (K) -! P 0,0 Pressure (Pa) -! MU component,0 or ext.phase.index*1,constituent*2 Chemical potential (J) -! AC component,0 or ext.phase.index,constituent Activity = EXP(MU/RT) -! LNAC component,0 or ext.phase.index,constituent LN(activity) = MU/RT -!...... extensive variables -! U 0,0 or ext.phase.index,0 Internal energy (J) whole system or phase -! UM 0,0 or ext.phase.index,0 same per mole components -! UW 0,0 or ext.phase.index,0 same per kg -! UV 0,0 or ext.phase.index,0 same per m3 -! UF ext.phase.index,0 same per formula unit of phase -! S*3 0,0 or ext.phase.index,0 Entropy (J/K) -! V 0,0 or ext.phase.index,0 Volume (m3) -! H 0,0 or ext.phase.index,0 Enthalpy (J) -! A 0,0 or ext.phase.index,0 Helmholtz energy (J) -! G 0,0 or ext.phase.index,0 Gibbs energy (J) -! ..... some extra state variables -! NP ext.phase.index,0 Moles of phase -! BP ext.phase.index,0 Mass of moles (kg) -! Q ext.phase.index,0 Internal stability/RT (dimensionless) -! DG ext.phase.index,0 Driving force/RT (dimensionless) -!....... amounts of components -! N 0,0 or component,0 or ext.phase.index,component Moles of component -! X component,0 or ext.phase.index,component Mole fraction of component -! B 0,0 or component,0 or ext.phase.index,component Mass of component -! W component,0 or ext.phase.index,component Mass fraction of component -! Y ext.phase.index,constituent*1 Constituent fraction -!........ some parameter identifiers -! TC ext.phase.index,0 Magnetic ordering temperature -! BMAG ext.phase.index,0 Aver. Bohr magneton number -! MQ& ext.phase.index,constituent Mobility -! THET ext.phase.index,0 Debye temperature -! LNX ext.phase.index,0 Lattice parameter -! EC11 ext.phase.index,0 Elastic constant C11 -! EC12 ext.phase.index,0 Elastic constant C12 -! EC44 ext.phase.index,0 Elastic constant C44 -!........ NOTES: -! *1 The ext.phase.index is 10*phase_number+comp.set_number -! *2 The constituent index is 10*species_number + sublattice_number -! *3 S, V, H, A, G, NP, BP, N, B and DG can have suffixes M, W, V, F also -!-------------------------------------------------------------------- -! special addition for TQ interface: d2G/dyidyj -! D2G + extended phase index -!-------------------------------------------------------------------- -!\end{verbatim} - integer ics,mjj,nph,ki,kj,lp,lokph,lokcs - character statevar*60,encoded*60,name*24,selvar*4,norm*4 -! mjj should be the dimension of the array values ... - mjj=n3 - selvar=stavar - call capson(selvar) -! for state variables like MQ&FE remove the part from & before the select -! write(*,11)'In tqgetv: ',selvar,n1,n2,n3 -11 format(a,a,3i5) - norm=' ' - lp=index(selvar,'&') - if(lp.gt.0) then - selvar(lp:)=' ' - else -! check if variable is normallized - ki=len_trim(selvar) - if(ki.ge.2) then - if(selvar(ki:ki).eq.'M') then - norm='M' - selvar(ki:)=' ' - ki=ki-1 - endif - endif - endif -!======================================================================= - kj=index(selvar,'(') - if(kj.gt.0) then - selvar=selvar(1:kj-1) - endif -! write(*,*)'tqgetv 0: ',kj,selvar,'>',stavar,'<' - select case(selvar) - case default - write(*,*)'Unknown state variable: ',stavar(1:20),'>:<',selvar - gx%bmperr=8888; goto 1000 -!-------------------------------------------------------------------- -! chemical potential for a component - case('MU ') - if(n1.le.0) then - write(*,*)'tqgetv 17: component number must be positive' - gx%bmperr=8888; goto 1000 - endif -! call get_component_name(n1,name,ceq) -! if(gx%bmperr.ne.0) goto 1000 - statevar=stavar(1:2)//'('//cnam(n1)(1:len_trim(cnam(n1)))//') ' -! write(*,*)'tqgetv 4: ',statevar(1:len_trim(statevar)) -! we must use index value(1) as the subroutine expect a single variable - call get_state_var_value(statevar,values(1),encoded,ceq) -!-------------------------------------------------------------------- -! Amount of moles of components in a phaase - case('NP ') - if(n1.lt.0) then -! all phases - statevar='NP(*)' -! write(*,*)'tqgetv 1: ',mjj,statevar(1:len_trim(statevar)) -! hopefully this returns all composition sets for all phases ... YES! - call get_many_svar(statevar,values,mjj,n3,encoded,ceq) -! this output gives the amounts for all compsets of a phase sequentially -! but here we want them in phase tuple order -! the second argument is the number of values for each phase, here is 1 but -! it can be for example compositions, then it should be number of components - call sortinphtup(n3,1,values) - else -! NOTE in this case n1 is a phase tuple index -! ics=mod(n1,10) -! nph=n1/10 -! if(nph.eq.0 .or. ics.eq.0) then -! write(*,*)'You must use extended phase index' -! gx%bmperr=8887; goto 1000 -! endif -! call get_phase_name(nph,ics,name) - call get_phase_name(phcs(n1)%phase,phcs(n1)%compset,name) - if(gx%bmperr.ne.0) goto 1000 - statevar='NP('//name(1:len_trim(name))//') ' - call get_state_var_value(statevar,values(1),encoded,ceq) - n3=1 - endif -!-------------------------------------------------------------------- -! Mole or mass fractions - case('X ','W ') -! write(*,*)'tqgetv: ',n1,n2,n3 - if(n2.eq.0) then - if(n1.lt.0) then -! mole ´fraction of all components, no phase specification - statevar=stavar(1:1)//'(*) ' -! write(*,*)'tqgetv 3: ',mjj,statevar(1:len_trim(statevar)) - call get_many_svar(statevar,values,mjj,n3,encoded,ceq) - elseif(n1.eq.0) then -! mole fraction for the state variable written as X(FE) -! n1 and n2 not used, just check for wildcard -! write(*,*)'tqgetv 20: ',stavar(1:len_trim(stavar)) - if(index(stavar,'*').gt.0) then - call get_many_svar(stavar,values,mjj,n3,encoded,ceq) - else - call get_state_var_value(stavar,values(1),encoded,ceq) - endif - else -! mole fraction of a single component, no phase specification - n3=1 - ics=1 -! call get_component_name(n1,name,ceq) -! if(gx%bmperr.ne.0) goto 1000 - statevar=stavar(1:1)//'('//cnam(n1)(1:len_trim(cnam(n1)))//')' -! write(*,*)'tqgetv 4: ',statevar(1:len_trim(statevar)) - call get_state_var_value(statevar,values(1),encoded,ceq) - endif - elseif(n1.lt.0) then -!........................................................ -! for all phases one or several components - if(n2.lt.0) then -! this means all components all phases - statevar=stavar(1:1)//'(*,*) ' -! write(*,*)'tqgetv 5: ',mjj,statevar(1:len_trim(statevar)) - call get_many_svar(statevar,values,mjj,n3,encoded,ceq) -! this output gives the composition for all compsets of a phase sequentially -! but we want them in phase tuple order -! ?? call sortinphtup(n3,,values) - else -! a single component in all phases. n2 must not be zero -! call get_component_name(n2,name,ceq) -! if(gx%bmperr.ne.0) goto 1000 - if(n2.le.0 .or. n2.ge.noel()) then - write(*,*)'No such component' - goto 1000 - endif - statevar=stavar(1:1)//'(*,'//cnam(n2)(1:len_trim(cnam(n2)))//')' -! write(*,*)'tqgetv 6: ',mjj,statevar(1:len_trim(statevar)) - call get_many_svar(statevar,values,mjj,n3,encoded,ceq) -! this output gives the composition for all compsets of a phase sequentially -! but we want them in phase tuple order - ics=noel() - call sortinphtup(n3,ics,values) - endif - elseif(n2.lt.0) then -! this means all components in one phase -! NOTE in this case n1 is a phasetuple index -! ics=mod(n1,10) -! nph=n1/10 -! if(nph.eq.0 .or. ics.eq.0) then -! write(*,*)'You must use extended phase index' -! gx%bmperr=8887; goto 1000 -! endif -! call get_phase_name(nph,ics,name) - write(*,*)'Phase : ',phcs(n1)%phase,phcs(n1)%compset - call get_phase_name(phcs(n1)%phase,phcs(n1)%compset,name) - if(gx%bmperr.ne.0) goto 1000 -! added for composition sets -! if(ics.gt.1) then -! name=name//'#'//char(ichar('0')+ics) -! endif - statevar=stavar(1:1)//'('//name(1:len_trim(name))//',*) ' -! write(*,*)'tqgetv 7: ',mjj,statevar(1:len_trim(statevar)) - call get_many_svar(statevar,values,mjj,n3,encoded,ceq) - else -! one component (n2) of one phase (n1) -! NOTE in this case n1 is 10*phase number + composition set number -! ics=mod(n1,10) -! nph=n1/10 -! if(nph.eq.0 .or. ics.eq.0) then -! write(*,*)'You must use extended phase index' -! gx%bmperr=8887; goto 1000 -! endif -! call get_phase_name(nph,ics,name) - call get_phase_name(phcs(n1)%phase,phcs(n1)%compset,name) - if(gx%bmperr.ne.0) goto 1000 - statevar=stavar(1:1)//'('//name(1:len_trim(name))//',' - call get_component_name(n2,name,ceq) - if(gx%bmperr.ne.0) goto 1000 - statevar(len_trim(statevar)+1:)=name(1:len_trim(name))//') ' -! write(*,*)'tqgetv 8: ',statevar - call get_state_var_value(statevar,values(1),encoded,ceq) - endif -!-------------------------------------------------------------------- -! volume - case('V ') - if(norm(1:1).ne.' ') then - statevar='V'//norm - ki=2 - else - statevar='V ' - ki=1 - endif - if(n1.gt.0) then -! Volume for a specific phase -! NOTE in this case n1 is 10*phase number + composition set number -! ics=mod(n1,10) -! nph=n1/10 -! if(nph.eq.0 .or. ics.eq.0) then -! write(*,*)'You must use extended phase index' -! gx%bmperr=8887; goto 1000 -! endif -! call get_phase_name(nph,ics,name) - call get_phase_name(phcs(n1)%phase,phcs(n1)%compset,name) - if(gx%bmperr.ne.0) goto 1000 - statevar=statevar(1:ki)//'('//name(1:len_trim(name))//') ' -! call get_state_var_value(statevar,values(ics),encoded,ceq) - call get_state_var_value(statevar,values(1),encoded,ceq) - n3=1 - else -! Total volume - call get_state_var_value(statevar,values(1),encoded,ceq) - n3=1 - endif -!-------------------------------------------------------------------- -! Gibbs energy - case('G ') -! phase specifier not allowed - if(norm(1:1).ne.' ') then - statevar='G'//norm - ki=2 - else - statevar='G ' - ki=1 - endif -! write(*,*)'tqgetv 1: ',n1,ki - if(n1.gt.0) then -! Gibbs energy for a specific phase -! NOTE in this case n1 is 10*phase number + composition set number -! ics=mod(n1,10) -! nph=n1/10 -! if(nph.eq.0 .or. ics.eq.0) then -! write(*,*)'You must use extended phase index' -! gx%bmperr=8887; goto 1000 -! endif -! write(*,*)'tqgetv 2: ',nph,ics -! call get_phase_name(nph,ics,name) - call get_phase_name(phcs(n1)%phase,phcs(n1)%compset,name) - if(gx%bmperr.ne.0) goto 1000 - statevar=statevar(1:ki)//'('//name(1:len_trim(name))//') ' -! write(*,*)'tqgetv 3: ',statevar - call get_state_var_value(statevar,values(1),encoded,ceq) - n3=1 - else -! Total Gibbs energy - call get_state_var_value(statevar,values(1),encoded,ceq) - n3=1 - endif -!-------------------------------------------------------------------- -! Mobilities - case('MQ ') -! ics=mod(n1,10) -! nph=n1/10 -! if(nph.eq.0 .or. ics.eq.0) then -! write(*,*)'You must use extended phase index: 10*phase+compset' -! gx%bmperr=8887; goto 1000 -! endif -! call get_phase_name(nph,ics,name) - call get_phase_name(phcs(n1)%phase,phcs(n1)%compset,name) - if(gx%bmperr.ne.0) goto 1000 - statevar=stavar(1:len_trim(stavar))//'('//name(1:len_trim(name))//')' -! write(*,*)'statevar: ',statevar - call get_state_var_value(statevar,values(1),encoded,ceq) -!-------------------------------------------------------------------- -! Second derivatives of the Gibbs energy of a phase - case('D2G ') -! ics=mod(n1,10) -! nph=n1/10 -! if(nph.eq.0 .or. ics.eq.0) then -! write(*,*)'You must use extended phase index: 10*phase+compset' -! gx%bmperr=8887; goto 1000 -! endif -! write(*,*)'D2G 1: ',nph,ics -! call get_phase_compset(nph,ics,lokph,lokcs) - call get_phase_compset(phcs(n1)%phase,phcs(n1)%compset,lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 -! write(*,*)'D2G 2: ',lokph,lokcs -! this gives wrong value!! -! n3=ceq%phase_varres(lokcs)%ncc - n3=size(ceq%phase_varres(lokcs)%yfr) -! write(*,*)'D2G 3: ',n3 - kj=(n3*(n3+1))/2 -! write(*,*)'D2G 3: ',kj - do ki=1,kj - values(ki)=ceq%phase_varres(lokcs)%d2gval(ki,1) - enddo - end select -!=========================================================================== -1000 continue - return - end subroutine tqgetv - -!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ - -end MODULE LIBOCTQ - +! +! Minimal TQ interface. +! +! To compile and link this with an application one must first compile +! and form a library with of the most OC subroutines (oclib.a) +! and to copy this and the corresponding "mov" files from this compilation +! to the folder with this library +! +! NOTE that for the identification of phase and composition sets this +! TQ interface use a Fortran TYPE called gtp_phasetuple containing two +! integers, "phase" with the phase number and "compset" with the +! comp.set The number of phase tuples is initially equal to the number +! of phases and have the same index. This represent comp.set 1 of the +! phases as each phase has just one composition set. A phase may have +! several comp.sets created by calculations or by commands and these will +! have phase tuple index higher than the number of phases and their index +! is in the order of which they were created. +! This may cause some problems if composition sets are deleted because that +! will change the phase tuple index for those with higher index. So do not +! delete comp.sets or at least be very careful when deleting comp.sets +! +! When not using Fortran 95 (or later) one can probably replace this +! with a 2-dimensional array with first index phase number and second +! the comp.set number. +! +! For constituents an EXTENDED CONSTITUENT INDEX is sometimes used +! and equal to 10*species_number + sublattice +! +! 150520 BOS added a few subroutines for single phase data and calculations +! 141210 BOS changed to use phase tuples +! 140128 BOS added D2G and phase specific V and G +! 140128 BOS added possibility to calculate without invoking grid minimizer +! 140125 BOS Changed name to liboctq +! 140123 BOS Added ouput of MQ G, V and normalized +!------------------------------------------------------------ +! subroutines and functions +! tqini ok initiate +! tqrfil ok read a database file +! tqrpfil ok read specified elements from database file +! ------------------------- +! tqgcom ok get system component names +! tqgnp ok get number of phase tuples (phases and comp. sets +! tqgpn ok get name of phase tuple +! tqgpi ok get phase tuple index of phase using its name +! tqgpcn - get name of constituent of a phase using index +! tqgpci - get index of constituent of a phase using name +! tqgpcs - get stoichiometry of species as system components +! tqgccf - get stoichiometry of system component as elements +! tqgnpc - get number of constituents in phase +! ------------------------- +! tqphsts ok set status of phase tuple +! tqsetc ok set condition +! tqce ok calculate equilibrium +! tqgetv ok get equilibrium results as state variable values +! ------------------------- +! tqgphc1 ok get phase constitution +! tqsphc1 ok set phase constitution +! tqcph1 ok calculate phase properties and return arrays +! tqcph2 ok calculate phase properties and return index +! tqdceq ok delete equilibrium record +! tqcceq ok copy current equilibrium to a new one +! tqselceq ok select new current equilibrium +! +!------------------------------------------------------------ +! +! The name of this library +module liboctq +! +! access to main OC library for equilibrium calculations and models + use liboceq +! + implicit none +! + integer, parameter :: maxc=20,maxp=100 +! +! This is for storage and use of components + integer nel + character, dimension(maxc) :: cnam*24 +! This is for storage and use of phase+composition tuples + integer ntup + type(gtp_phasetuple), dimension(maxp) :: phcs +! +contains +! +!\begin{verbatim} + subroutine tqini(n,ceq) +! initiate workspace + implicit none + integer n ! Not nused, could be used for some initial allocation + type(gtp_equilibrium_data), pointer :: ceq ! EXIT: current equilibrium +!\end{verbatim} +! these should be provide linits and defaults + integer intv(10) + double precision dblv(10) + intv(1)=-1 +! This call initiates the OC package + call init_gtp(intv,dblv) + ceq=>firsteq + write(*,*)'tqini created: ',ceq%eqname +1000 continue + return + end subroutine tqini + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqrfil(filename,ceq) +! read all elements from a TDB file + implicit none + character*(*) filename ! IN: database filename + character ellista(10)*2 ! dummy + type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium +!\end{verbatim} + integer iz + character elname*2,name*24,refs*24 + double precision a1,a2,a3 +! second argument 0 means ellista is ignored, all element read + call readtdb(filename,0,ellista) +! ceq=>firsteq + nel=noel() + do iz=1,nel +! store element name in module array components + call get_element_data(iz,elname,name,refs,a1,a2,a3) + cnam(iz)=elname + enddo +! store phase tuples and indices + ntup=get_phtuplearray(phcs) +1000 continue + return + end subroutine tqrfil + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqrpfil(filename,nsel,selel,ceq) +! read TDB file with selection of elements + implicit none + character*(*) filename ! IN: database filename + integer nsel + character selel(*)*2 ! IN: elements to be read from the database + type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium +!\end{verbatim} + integer iz + character elname*2,name*24,refs*24 + double precision a1,a2,a3 +! + call readtdb(filename,nsel,selel) + if(gx%bmperr.ne.0) goto 1000 +! is this really necessary?? +! ceq=>firsteq + nel=noel() + do iz=1,nel +! store element name in module array components + call get_element_data(iz,elname,name,refs,a1,a2,a3) + cnam(iz)=elname + enddo +! store phase tuples and indices + ntup=get_phtuplearray(phcs) +1000 continue + return + end subroutine tqrpfil + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqgcom(n,compnames,ceq) +! get system component names. At present the elements + implicit none + integer n ! EXIT: number of components + character*24, dimension(*) :: compnames ! EXIT: names of components + type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium +!\end{verbatim} + integer iz + character elname*24,refs*24 + double precision a1,a2,a3 + do iz=1,nel + compnames(iz)=' ' + call get_element_data(iz,compnames(iz),elname,refs,a1,a2,a3) +! store name in module array components also (already done when reading TDB) + cnam(iz)=compnames(iz) + enddo +1000 continue + return + end subroutine tqgcom + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqgnp(n,ceq) +! get total number of phases and composition sets +! A second composition set of a phase is normally placed after all other +! phases with one composition set + implicit none + integer n !EXIT: n is number of phases + type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium +!\end{verbatim} +! This call fills the module array phcs with phase and composition set indices +! NOTE the number composition sets may change at a calculation or if new +! composition sets are added or deleted explicitly + ntup=get_phtuplearray(phcs) + n=ntup +1000 continue + return + end subroutine tqgnp + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqgpn(phcsx,phasename,ceq) +! get name of phase+compset tuple with index phcsx + implicit none + integer phcsx ! IN: index in phase tuple array +! TYPE(gtp_phasetuple), pointer :: phcs !IN: phase number and comp.set + character phasename*(*) !EXIT: phase name, max 24+8 for pre/suffix + type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium +!\end{verbatim} + call get_phase_name(phcs(phcsx)%phase,phcs(phcsx)%compset,phasename) +1000 continue + return + end subroutine tqgpn + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqgpi(phcsx,phasename,ceq) +! get index of phase phasename (including comp.set, ceq not needed ... + implicit none + integer phcsx !EXIT: phase tuple index + character phasename*(*) !IN: phase name + type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium +!\end{verbatim} + call find_phasetuple_by_name(phasename,phcsx) +1000 continue + return + end subroutine tqgpi + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqgpcn(n,c,constituentname,ceq) +! get name of consitutent c in phase n + implicit none + integer n !IN: phase number + integer c !IN: extended constituent index: 10*species_number+sublattice + character constituentname*(24) !EXIT: costituent name + type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium +!\end{verbatim} + write(*,*)'tqgpcn not implemented yet' + gx%bmperr=8888 +1000 continue + return + end subroutine tqgpcn + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqgpci(n,c,constituentname,ceq) +! get index of constituent with name in phase n + implicit none + integer n !IN: phase index + integer c !EXIT: extended constituent index: 10*species_number+sublattice + character constituentname*(*) + type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium +!\end{verbatim} + write(*,*)'tqgpci not implemented yet' + gx%bmperr=8888 +1000 continue + return + end subroutine tqgpci + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqgpcs(n,c,stoi,mass,ceq) +! get stoichiometry of constituent c in phase n +!? missing argument number of elements???? + implicit none + integer n !IN: phase number + integer c !IN: extended constituent index: 10*species_number+sublattice + double precision stoi(*) !EXIT: stoichiometry of elements + double precision mass !EXIT: total mass + type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium +!\end{verbatim} + write(*,*)'tqgpcs not implemented yet' + gx%bmperr=8888 +1000 continue + return + end subroutine tqgpcs + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqgccf(n1,n2,elnames,stoi,mass,ceq) +! get stoichiometry of component n1 +! n2 is number of elements (dimension of elnames and stoi) + implicit none + integer n1 !IN: component number + integer n2 !EXIT: number of elements in component + character elnames(*)*(2) ! EXIT: element symbols + double precision stoi(*) ! EXIT: element stoichiometry + double precision mass ! EXIT: component mass (sum of element mass) + type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium +!\end{verbatim} + write(*,*)'tqgccf not implemented yet' + gx%bmperr=8888 +1000 continue + return + end subroutine tqgccf + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqgnpc(n,c,ceq) +! get number of constituents of phase n + implicit none + integer n !IN: Phase number + integer c !EXIT: number of constituents + type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium +!\end{verbatim} + write(*,*)'tqgnpc not implemented yet' + gx%bmperr=8888 +1000 continue + return + end subroutine tqgnpc + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqphsts(tup,newstat,val,ceq) +! set status of phase tuple, + integer tup,newstat + double precision val + type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium +!\end{verbatim} + integer n + if(tup.le.0) then + do n=1,ntup + call change_phase_status(phcs(n)%phase,phcs(n)%compset,& + newstat,val,ceq) + if(gx%bmperr.ne.0) goto 1000 + enddo + elseif(tup.le.ntup) then + call change_phase_status(phcs(tup)%phase,phcs(tup)%compset,& + newstat,val,ceq) + else + write(*,*)'Illegal phase tuple index' + gx%bmperr=5001 + endif +1000 continue + return + end subroutine tqphsts + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqsetc(stavar,n1,n2,value,cnum,ceq) +! set condition +! stavar is state variable as text +! n1 and n2 are auxilliary indices +! value is the value of the condition +! cnum is returned as an index of the condition. +! to remove a condition the value sould be equial to RNONE ???? +! when a phase indesx is needed it should be 10*nph + ics +! SEE TQGETV for doucumentation of stavar etc. + implicit none + integer n1 ! IN: 0 or phase tuple index or component number + integer n2 ! IN: 0 or component number + integer cnum ! EXIT: sequential number of this condition + character stavar*(*) ! IN: character with state variable symbol + double precision value ! IN: value of condition + type(gtp_equilibrium_data), pointer :: ceq ! IN: current equilibrium +!\end{verbatim} + integer ip + character cline*60,selvar*4 +! +! write(*,11)'In tqsetc ',stavar(1:len_trim(stavar)),n1,n2,value +11 format(a,a,2i5,1pe14.6) + cline=' ' + selvar=stavar + call capson(selvar) + select case(selvar) + case default + write(*,*)'Condition wrong, not implemented or illegal: ',stavar + gx%bmperr=8888; goto 1000 +! Potentials T and P + case('T ','P ') + write(cline,110)selvar(1:1),value +110 format(' ',a,'=',E15.8) +! Total amount or amount of a component in moles + case('N ') + if(n1.gt.0) then +! call get_component_name(n1,name,ceq) +! if(gx%bmperr.ne.0) goto 1000 + write(cline,112)selvar(1:1),cnam(n1)(1:len_trim(cnam(n1))),value +112 format(' ',a,'(',a,')=',E15.8) + else + write(cline,110)selvar(1:1),value + endif +! Overall fraction of a component + case('X ','W ') +! ?? fraction of phase component not implemented, n1 must be component number +! call get_component_name(n1,cnam,ceq) +! if(gx%bmperr.ne.0) goto 1000 + write(cline,120)selvar(1:1),cnam(n1)(1:len_trim(cnam(n1))),value +120 format(1x,a,'(',a,')=',1pE15.8) +! ?? MORE CONDITIONS WILL BE ADDED ... + end select +! write(*,*)'tqsetc condition: ',cline(1:len_trim(cline)) + ip=1 + call set_condition(cline,ip,ceq) +1000 continue + return + end subroutine tqsetc + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqce(target,n1,n2,value,ceq) +! calculate quilibrium with possible target +! Target can be empty or a state variable with indices n1 and n2 +! value is the calculated value of target + implicit none + integer n1,n2,mode + character target*(*) + double precision value + type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium +!\end{verbatim} +! mode=1 means start values using global gridminimization + mode=1 + if(n1.lt.0) then +! this means calculate without grid minimuzer + write(*,*)'No grid minimizer' + mode=0 + endif + call calceq2(mode,ceq) + if(gx%bmperr.ne.0) goto 1000 +! there may be new composition sets, update tup and phcs +! this call updates both the number of tuples and the phcs array + ntup=get_phtuplearray(phcs) +1000 continue + return + end subroutine tqce + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqgetv(stavar,n1,n2,n3,values,ceq) +! get equilibrium results using state variables +! stavar is the state variable IN CAPITAL LETTERS with indices n1 and n2 +! n1 can be a phase tuple index, n2 a component index +! n3 at the call is the dimension of the array values, +! changed to number of values on exit +! value is an array with the calculated value(s), n3 set to number of values. + implicit none + integer n1,n2,n3 + character stavar*(*) + double precision values(*) + type(gtp_equilibrium_data), pointer :: ceq !IN: current equilibrium +!======================================================== +! stavar must be a symbol listed below +! IMPORTANT: some terms explained after the table +! Symbol index1,index2 Meaning (unit) +!.... potentials +! T 0,0 Temperature (K) +! P 0,0 Pressure (Pa) +! MU component,0 or ext.phase.index*1,constituent*2 Chemical potential (J) +! AC component,0 or ext.phase.index,constituent Activity = EXP(MU/RT) +! LNAC component,0 or ext.phase.index,constituent LN(activity) = MU/RT +!...... extensive variables +! U 0,0 or ext.phase.index,0 Internal energy (J) whole system or phase +! UM 0,0 or ext.phase.index,0 same per mole components +! UW 0,0 or ext.phase.index,0 same per kg +! UV 0,0 or ext.phase.index,0 same per m3 +! UF ext.phase.index,0 same per formula unit of phase +! S*3 0,0 or ext.phase.index,0 Entropy (J/K) +! V 0,0 or ext.phase.index,0 Volume (m3) +! H 0,0 or ext.phase.index,0 Enthalpy (J) +! A 0,0 or ext.phase.index,0 Helmholtz energy (J) +! G 0,0 or ext.phase.index,0 Gibbs energy (J) +! ..... some extra state variables +! NP ext.phase.index,0 Moles of phase +! BP ext.phase.index,0 Mass of moles (kg) +! Q ext.phase.index,0 Internal stability/RT (dimensionless) +! DG ext.phase.index,0 Driving force/RT (dimensionless) +!....... amounts of components +! N 0,0 or component,0 or ext.phase.index,component Moles of component +! X component,0 or ext.phase.index,component Mole fraction of component +! B 0,0 or component,0 or ext.phase.index,component Mass of component +! W component,0 or ext.phase.index,component Mass fraction of component +! Y ext.phase.index,constituent*1 Constituent fraction +!........ some parameter identifiers +! TC ext.phase.index,0 Magnetic ordering temperature +! BMAG ext.phase.index,0 Aver. Bohr magneton number +! MQ& ext.phase.index,constituent Mobility +! THET ext.phase.index,0 Debye temperature +! LNX ext.phase.index,0 Lattice parameter +! EC11 ext.phase.index,0 Elastic constant C11 +! EC12 ext.phase.index,0 Elastic constant C12 +! EC44 ext.phase.index,0 Elastic constant C44 +!........ NOTES: +! *1 The ext.phase.index is 10*phase_number+comp.set_number +! *2 The constituent index is 10*species_number + sublattice_number +! *3 S, V, H, A, G, NP, BP, N, B and DG can have suffixes M, W, V, F also +!-------------------------------------------------------------------- +! special addition for TQ interface: d2G/dyidyj +! D2G + extended phase index +!-------------------------------------------------------------------- +!\end{verbatim} + integer ics,mjj,nph,ki,kj,lp,lokph,lokcs + character statevar*60,encoded*1024,name*24,selvar*4,norm*4 +! mjj should be the dimension of the array values ... + mjj=n3 + selvar=stavar + call capson(selvar) +! for state variables like MQ&FE remove the part from & before the select +! write(*,11)'In tqgetv: ',selvar,n1,n2,n3 +11 format(a,a,3i5) + norm=' ' + lp=index(selvar,'&') + if(lp.gt.0) then + selvar(lp:)=' ' + else +! check if variable is normallized + ki=len_trim(selvar) + if(ki.ge.2) then + if(selvar(ki:ki).eq.'M') then + norm='M' + selvar(ki:)=' ' + ki=ki-1 + endif + endif + endif +!======================================================================= + kj=index(selvar,'(') + if(kj.gt.0) then + selvar=selvar(1:kj-1) + endif +! write(*,*)'tqgetv 0: ',kj,selvar,'>',stavar,'<' + select case(selvar) + case default + write(*,*)'Unknown state variable: ',stavar(1:20),'>:<',selvar + gx%bmperr=8888; goto 1000 +!-------------------------------------------------------------------- +! chemical potential for a component + case('MU ') + if(n1.le.0) then + write(*,*)'tqgetv 17: component number must be positive' + gx%bmperr=8888; goto 1000 + endif +! call get_component_name(n1,name,ceq) +! if(gx%bmperr.ne.0) goto 1000 + statevar=stavar(1:2)//'('//cnam(n1)(1:len_trim(cnam(n1)))//') ' +! write(*,*)'tqgetv 4: ',statevar(1:len_trim(statevar)) +! we must use index value(1) as the subroutine expect a single variable + call get_state_var_value(statevar,values(1),encoded,ceq) +!-------------------------------------------------------------------- +! Amount of moles of components in a phaase + case('NP ') + if(n1.lt.0) then +! all phases + statevar='NP(*)' +! write(*,*)'tqgetv 1: ',mjj,statevar(1:len_trim(statevar)) +! hopefully this returns all composition sets for all phases ... YES! + call get_many_svar(statevar,values,mjj,n3,encoded,ceq) +! this output gives the amounts for all compsets of a phase sequentially +! but here we want them in phase tuple order +! the second argument is the number of values for each phase, here is 1 but +! it can be for example compositions, then it should be number of components + call sortinphtup(n3,1,values) + else +! NOTE in this case n1 is a phase tuple index +! ics=mod(n1,10) +! nph=n1/10 +! if(nph.eq.0 .or. ics.eq.0) then +! write(*,*)'You must use extended phase index' +! gx%bmperr=8887; goto 1000 +! endif +! call get_phase_name(nph,ics,name) + call get_phase_name(phcs(n1)%phase,phcs(n1)%compset,name) + if(gx%bmperr.ne.0) goto 1000 + statevar='NP('//name(1:len_trim(name))//') ' + call get_state_var_value(statevar,values(1),encoded,ceq) + n3=1 + endif +!-------------------------------------------------------------------- +! Mole or mass fractions + case('X ','W ') +! write(*,*)'tqgetv: ',n1,n2,n3 + if(n2.eq.0) then + if(n1.lt.0) then +! mole ´fraction of all components, no phase specification + statevar=stavar(1:1)//'(*) ' +! write(*,*)'tqgetv 3: ',mjj,statevar(1:len_trim(statevar)) + call get_many_svar(statevar,values,mjj,n3,encoded,ceq) + elseif(n1.eq.0) then +! mole fraction for the state variable written as X(FE) +! n1 and n2 not used, just check for wildcard +! write(*,*)'tqgetv 20: ',stavar(1:len_trim(stavar)) + if(index(stavar,'*').gt.0) then + call get_many_svar(stavar,values,mjj,n3,encoded,ceq) + else + call get_state_var_value(stavar,values(1),encoded,ceq) + endif + else +! mole fraction of a single component, no phase specification + n3=1 + ics=1 +! call get_component_name(n1,name,ceq) +! if(gx%bmperr.ne.0) goto 1000 + statevar=stavar(1:1)//'('//cnam(n1)(1:len_trim(cnam(n1)))//')' +! write(*,*)'tqgetv 4: ',statevar(1:len_trim(statevar)) + call get_state_var_value(statevar,values(1),encoded,ceq) + endif + elseif(n1.lt.0) then +!........................................................ +! for all phases one or several components + if(n2.lt.0) then +! this means all components all phases + statevar=stavar(1:1)//'(*,*) ' +! write(*,*)'tqgetv 5: ',mjj,statevar(1:len_trim(statevar)) + call get_many_svar(statevar,values,mjj,n3,encoded,ceq) +! this output gives the composition for all compsets of a phase sequentially +! but we want them in phase tuple order +! ?? call sortinphtup(n3,,values) + else +! a single component in all phases. n2 must not be zero +! call get_component_name(n2,name,ceq) +! if(gx%bmperr.ne.0) goto 1000 + if(n2.le.0 .or. n2.ge.noel()) then + write(*,*)'No such component' + goto 1000 + endif + statevar=stavar(1:1)//'(*,'//cnam(n2)(1:len_trim(cnam(n2)))//')' +! write(*,*)'tqgetv 6: ',mjj,statevar(1:len_trim(statevar)) + call get_many_svar(statevar,values,mjj,n3,encoded,ceq) +! this output gives the composition for all compsets of a phase sequentially +! but we want them in phase tuple order + ics=noel() + call sortinphtup(n3,ics,values) + endif + elseif(n2.lt.0) then +! this means all components in one phase +! NOTE in this case n1 is a phasetuple index +! ics=mod(n1,10) +! nph=n1/10 +! if(nph.eq.0 .or. ics.eq.0) then +! write(*,*)'You must use extended phase index' +! gx%bmperr=8887; goto 1000 +! endif +! call get_phase_name(nph,ics,name) +! write(*,*)'Phase: ',phcs(n1)%phase,phcs(n1)%compset + call get_phase_name(phcs(n1)%phase,phcs(n1)%compset,name) + if(gx%bmperr.ne.0) goto 1000 +! added for composition sets +! if(ics.gt.1) then +! name=name//'#'//char(ichar('0')+ics) +! endif + statevar=stavar(1:1)//'('//name(1:len_trim(name))//',*) ' +! write(*,*)'tqgetv 7: ',mjj,statevar(1:len_trim(statevar)) + call get_many_svar(statevar,values,mjj,n3,encoded,ceq) + else +! one component (n2) of one phase (n1) +! NOTE in this case n1 is 10*phase number + composition set number +! ics=mod(n1,10) +! nph=n1/10 +! if(nph.eq.0 .or. ics.eq.0) then +! write(*,*)'You must use extended phase index' +! gx%bmperr=8887; goto 1000 +! endif +! call get_phase_name(nph,ics,name) + call get_phase_name(phcs(n1)%phase,phcs(n1)%compset,name) + if(gx%bmperr.ne.0) goto 1000 + statevar=stavar(1:1)//'('//name(1:len_trim(name))//',' + call get_component_name(n2,name,ceq) + if(gx%bmperr.ne.0) goto 1000 + statevar(len_trim(statevar)+1:)=name(1:len_trim(name))//') ' +! write(*,*)'tqgetv 8: ',statevar + call get_state_var_value(statevar,values(1),encoded,ceq) + endif +!-------------------------------------------------------------------- +! volume + case('V ') + if(norm(1:1).ne.' ') then + statevar='V'//norm + ki=2 + else + statevar='V ' + ki=1 + endif + if(n1.gt.0) then +! Volume for a specific phase +! NOTE in this case n1 is 10*phase number + composition set number +! ics=mod(n1,10) +! nph=n1/10 +! if(nph.eq.0 .or. ics.eq.0) then +! write(*,*)'You must use extended phase index' +! gx%bmperr=8887; goto 1000 +! endif +! call get_phase_name(nph,ics,name) + call get_phase_name(phcs(n1)%phase,phcs(n1)%compset,name) + if(gx%bmperr.ne.0) goto 1000 + statevar=statevar(1:ki)//'('//name(1:len_trim(name))//') ' +! call get_state_var_value(statevar,values(ics),encoded,ceq) + call get_state_var_value(statevar,values(1),encoded,ceq) + n3=1 + else +! Total volume + call get_state_var_value(statevar,values(1),encoded,ceq) + n3=1 + endif +!-------------------------------------------------------------------- +! Gibbs energy + case('G ') +! phase specifier not allowed + if(norm(1:1).ne.' ') then + statevar='G'//norm + ki=2 + else + statevar='G ' + ki=1 + endif +! write(*,*)'tqgetv 1: ',n1,ki + if(n1.gt.0) then +! Gibbs energy for a specific phase +! NOTE in this case n1 is 10*phase number + composition set number +! ics=mod(n1,10) +! nph=n1/10 +! if(nph.eq.0 .or. ics.eq.0) then +! write(*,*)'You must use extended phase index' +! gx%bmperr=8887; goto 1000 +! endif +! write(*,*)'tqgetv 2: ',nph,ics +! call get_phase_name(nph,ics,name) + call get_phase_name(phcs(n1)%phase,phcs(n1)%compset,name) + if(gx%bmperr.ne.0) goto 1000 + statevar=statevar(1:ki)//'('//name(1:len_trim(name))//') ' +! write(*,*)'tqgetv 3: ',statevar + call get_state_var_value(statevar,values(1),encoded,ceq) + n3=1 + else +! Total Gibbs energy + call get_state_var_value(statevar,values(1),encoded,ceq) + n3=1 + endif +!-------------------------------------------------------------------- +! Mobilities + case('MQ ') +! ics=mod(n1,10) +! nph=n1/10 +! if(nph.eq.0 .or. ics.eq.0) then +! write(*,*)'You must use extended phase index: 10*phase+compset' +! gx%bmperr=8887; goto 1000 +! endif +! call get_phase_name(nph,ics,name) + call get_phase_name(phcs(n1)%phase,phcs(n1)%compset,name) + if(gx%bmperr.ne.0) goto 1000 + statevar=stavar(1:len_trim(stavar))//'('//name(1:len_trim(name))//')' +! write(*,*)'statevar: ',statevar + call get_state_var_value(statevar,values(1),encoded,ceq) +!-------------------------------------------------------------------- +! Second derivatives of the Gibbs energy of a phase + case('D2G ') +! ics=mod(n1,10) +! nph=n1/10 +! if(nph.eq.0 .or. ics.eq.0) then +! write(*,*)'You must use extended phase index: 10*phase+compset' +! gx%bmperr=8887; goto 1000 +! endif +! write(*,*)'D2G 1: ',nph,ics +! call get_phase_compset(nph,ics,lokph,lokcs) + call get_phase_compset(phcs(n1)%phase,phcs(n1)%compset,lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 +! write(*,*)'D2G 2: ',lokph,lokcs +! this gives wrong value!! +! n3=ceq%phase_varres(lokcs)%ncc + n3=size(ceq%phase_varres(lokcs)%yfr) +! write(*,*)'D2G 3: ',n3 + kj=(n3*(n3+1))/2 +! write(*,*)'D2G 3: ',kj + do ki=1,kj + values(ki)=ceq%phase_varres(lokcs)%d2gval(ki,1) + enddo + end select +!=========================================================================== +1000 continue + return + end subroutine tqgetv + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqgphc1(n1,nsub,cinsub,spix,yfrac,sites,extra,ceq) +! tq_get_phase_constitution +! This subroutine returns the sublattices and constitution of a phase +! n1 is phase tuple index +! nsub is the number of sublattices (1 if no sublattices) +! cinsub is an array with the number of constítuents in each sublattice +! spix is an array with the species index of the constituents in all sublattices +! sites is an array of the site ratios for all sublattices. +! yfrac is the constituent fractions in same order as in spix +! extra is an array with some extra values: +! extra(1) is the number of moles of components per formula unit +! extra(2) is the net charge of the phase + implicit none + integer n1,nsub,cinsub(*),spix(*) + double precision sites(*),yfrac(*),extra(*) + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + call get_phase_data(phcs(n1)%phase,phcs(n1)%compset,& + nsub,cinsub,spix,yfrac,sites,extra,ceq) +1000 continue + return + end subroutine tqgphc1 + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqsphc1(n1,yfra,extra,ceq) +! tq_set_phase_constitution +! To set the constitution of a phase +! n1 is phase tuple index +! yfra is an array with the constituent fractions in all sublattices +! in the same order as obtained by tqgphc1 +! extra is an array with returned values with the same meaning as in tqgphc1 +! NOTE The constituents fractions are normallized to sum to unity for each +! sublattice and extra is calculated by tqsphc1 +! T and P must be set as conditions. + implicit none + integer n1 + double precision yfra(*),extra(*) + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + call set_constitution(phcs(n1)%phase,phcs(n1)%compset,& + yfra,extra,ceq) +1000 continue + return + end subroutine tqsphc1 + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqcph1(n1,n2,n3,gtp,dgdy,d2gdydt,d2gdydp,d2gdy2,ceq) +! tq_calculate_phase_properties +!vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +! WARNIG: this is not a subroutine to calculate chemical potentials +! those can only be made by an equilibrium calculation. +! The values returned are partial derivatives of G for the phase at the +! current T, P and phase constitution. The phase constitution has been +! obtained by a previous equilibrium calculation or +! set by the subroutine tqsphc +! It corresponds to the "calculate phase" command. +! +! NOTE that values are per formula unit divided by RT, +! divide also by extra(1) in subroutine tqsphc1 to get them per mole component +! +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! calculate G and some or all derivatives for a phase at current composition +! n1 is the phase tuple index +! n2 is 0 if only G and derivatves wrt T and P, 1 also first drivatives wrt +! compositions, 2 if also 2nd derivatives +! n3 is returned as number of constituents (dimension of returned arrays) +! gtp is an array with G, G.T, G:P, G.T.T, G.T.P and G.P.P +! dgdy is an array with G.Yi +! d2gdydt is an array with G.T.Yi +! d2gdydp is an array with G.P.Yi +! d2gdy2 is an array with the upper triangle of the symmetrix matrix G.Yi.Yj +! reurned in the order: 1,1; 1,2; 1,3; ... +! 2,2; 2,3; ... +! 3,3; ... +! for indexing one can use the integer function ixsym(i1,i2) + implicit none + integer n1,n2,n3 + double precision gtp(6),dgdy(*),d2gdydt(*),d2gdydp(*),d2gdy2(*) + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer ij,lokres,nofc +! write(*,*)'tqcph1 1: ',ceq%eqname +! write(*,*)'tqcph1 2',phcs(n1)%phase,phcs(n1)%compset +!---------------------------------------------------------------------- +! THIS IS NO EQUILIBRIUM, JUST G AND DERIVATIVES FOR CURRENT T, P AND Y + call calcg(phcs(n1)%phase,phcs(n1)%compset,n2,lokres,ceq) +!---------------------------------------------------------------------- +! write(*,*)'tqcph1 3A',lokres,gx%bmperr +! this should work but gave segmentation fault, find this a more cumbersum way + n3=size(ceq%phase_varres(lokres)%yfr) +! write(*,*)'tqcph1 3C',n3 +! gval last index is the property, other properties can also be extracted +! t.ex. mobilites +! The application program can also access these data directly ... + if(gx%bmperr.eq.0) then + do ij=1,6 + gtp(ij)=ceq%phase_varres(lokres)%gval(ij,1) + enddo + do ij=1,n3 + dgdy(ij)=ceq%phase_varres(lokres)%dgval(1,ij,1) + d2gdydt(ij)=ceq%phase_varres(lokres)%dgval(2,ij,1) + d2gdydp(ij)=ceq%phase_varres(lokres)%dgval(3,ij,1) + enddo +! size of upper triangle of symetrix matrix + nofc=n3*(n3+1)/2 + do ij=1,nofc + d2gdy2(ij)=ceq%phase_varres(lokres)%d2gval(ij,1) + enddo + else + gtp=zero + do ij=1,nofc + dgdy(ij)=zero + d2gdydt(ij)=zero + d2gdydp(ij)=zero + enddo + nofc=nofc*(nofc+1)/2 + do ij=1,nofc + d2gdy2(ij)=zero + enddo + endif +1000 continue + return + end subroutine tqcph1 + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqcph2(n1,n2,n3,n4,ceq) +! tq_calculate_phase_properties +!vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +! WARNIG: this is not a subroutine to calculate chemical potentials +! those can only be made by an equilibrium calculation. +! The values returned are partial derivatives of G for the phase at the +! current T, P and phase constitution. The phase constitution has been +! obtained by a previous equilibrium calculation or +! set by the subroutine tqsphc +! It corresponds to the "calculate phase" command. +! +! NOTE that values are per formula unit divided by RT, +! divide also by extra(1) in subroutine tqsphc1 to get them per mole component +! +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! calculate G and some or all derivatives for a phase at current composition +! n1 is the phase tuple index +! n2 is type of calculation (0, 1 or 2) +! n3 is returned as number of constituents +! n4 is index to ceq%phase_varres(lokres)% with all results +! for indexing one can use the integer function ixsym(i1,i2) + implicit none + integer n1,n2,n3,n4 + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer ij,lokres,nofc +! write(*,*)'tqcph1 1: ',ceq%eqname +! write(*,*)'tqcph1 2',phcs(n1)%phase,phcs(n1)%compset +!---------------------------------------------------------------------- +! THIS IS NO EQUILIBRIUM, JUST G AND DERIVATIVES FOR CURRENT T, P AND Y + call calcg(phcs(n1)%phase,phcs(n1)%compset,n2,lokres,ceq) +!---------------------------------------------------------------------- +! write(*,*)'tqcph1 3A',lokres,gx%bmperr +! this should work but gave segmentation fault, find this a more cumbersum way + n3=size(ceq%phase_varres(lokres)%yfr) + n4=lokres +! Uer can access results like +! ceq%phase_varres(n4)%gval(1..6,1..prop) +! prop=1 is G, other can be t.ex. Curie T, mobilites etc +! ceq%phase_varres(lokres)%dgval(1,ij,1) are dG/dy(ij) +! ceq%phase_varres(lokres)%dgval(2,ij,1) are d2G/dy(ij)dT +! ceq%phase_varres(lokres)%dgval(3,ij,1) are d2G/dy(ij)dP +! ceq%phase_varres(lokres)%d2gval(ij,1) are d2G/dy(i)dy(j) +! arranged as a single dimenion array indexed by ixsym(i,j) +! +! NEVER CHANGE THE CONSTITUTION DIRECTLY, using n4, ALWAYS CALL tqsph1(...) +! +1000 continue + return + end subroutine tqcph2 + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqdceq(name) +! delete equilibrium with name + implicit none + character name*24 +! integer n1 + type(gtp_equilibrium_data), pointer :: newceq,ceq +!\end{verbatim} + integer n1 + call findeq(name,n1) + if(gx%bmperr.ne.0) goto 1000 +! do not allow delete equilibrium 1 + if(n1.eq.1) then + write(*,*)'No allowed to delete default equilibrium' + gx%bmperr=4333 + goto 1000 + endif + ceq=>eqlista(n1) + call delete_equilibrium(name,ceq) +1000 continue + return + end subroutine tqdceq + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqcceq(name,n1,newceq,ceq) +! copy_current_equilibrium to newceq +! creates a new equilibrium record with name with values same as ceq +! n1 is returned as index + implicit none + character name*24 + integer n1 + type(gtp_equilibrium_data), pointer :: newceq,ceq +!\end{verbatim} + call enter_equilibrium(name,n1) + if(gx%bmperr.ne.0) goto 1000 + newceq=>eqlista(n1) + call copy_equilibrium(newceq,name,ceq) +1000 continue + return + end subroutine tqcceq + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +!\begin{verbatim} + subroutine tqselceq(name,ceq) +! select current equilibrium to be that with name. +! Note that equilibria can be deleted and change number but not name + implicit none + character name + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer n1 + call findeq(name,n1) + if(gx%bmperr.ne.0) goto 1000 + call selecteq(n1,ceq) +1000 continue + return + end subroutine tqselceq + +!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\!/!!\ + +end MODULE LIBOCTQ + diff --git a/TQ3lib-clean/readme.txt b/TQ3lib-clean/readme.txt new file mode 100644 index 0000000..a18cc4b --- /dev/null +++ b/TQ3lib-clean/readme.txt @@ -0,0 +1,47 @@ +The TQ library is to access Open Calphad from application software + +Bo Sundman 20 May 2015 + +There is a Fortran version and a tentative iso-C version + +The main library is liboctq.F90, this should be compiled using +liboceq.mov created when compiling the mian OC library liboceq.F90 For +linking application one also need liboceq.a. Both of these are +generated when compiling and linking the main OC program. + +The initial iso-C version of the library is provided by Teslos and it +has been extended to handle more calls. + +Content: + +Directoties: + +- C has a very primitive C connection to OC + +- F90 has 4 Fortran examples. The 4th is new showing the use of some +additional features. + +- isoC-Teslos example with liboctqisoc.F90 library with connection to C++ + +- isoC-Matthias example with liboctqisoc.F90 library with connection to C++ + +Files: + +liboctq.F90 is the Fortran TQ interface + +readme.txt is this file + +To use the examples you must copy liboceq.a and liboceq.mod from the +main OC directory to this directory. Then compile liboctq.F90 with +gfortran -c liboctq.F90. You must then move the liboceq.a, liboctq.o +and liboctq.mod to the directory with the example programs and use the +linkexj.txt files found there (on Windows rename the file to .cmd to +execute them as batch files). + +For the isoC examples you must also compile the liboctqisoc.F90 module. + + + + + + diff --git a/TQlib/readme.txt b/TQlib/readme.txt deleted file mode 100644 index e3902f4..0000000 --- a/TQlib/readme.txt +++ /dev/null @@ -1,21 +0,0 @@ -Using the TQ library - -Bo Sundman 22 December 2014 - -From F90 one can use the liboctc.F90 library directly. Only a few -subroutines are implemented at present. There are 3 test cases in the -F90 folder. - -From C or C++ I do not know how to handle the F90 modules and -structures. So I have created a single F90 function - -liboctqc1 - -which calls the liboctq.F90 module. Inside this subroutine the F90 -structures and various tq subroutines can be accessed. - -In the call to liboctqc1 an integer variable selects with F90 -subroutine to call and values are returned as arguments. - -The function value returned is 0 if no error, otherwise the error -code. diff --git a/documentationupdate/figs/femo-gp+convexhull.ps b/documentation/figs/femo-gp+convexhull.ps similarity index 100% rename from documentationupdate/figs/femo-gp+convexhull.ps rename to documentation/figs/femo-gp+convexhull.ps diff --git a/documentationupdate/figs/femo-gp+curves.ps b/documentation/figs/femo-gp+curves.ps similarity index 100% rename from documentationupdate/figs/femo-gp+curves.ps rename to documentation/figs/femo-gp+curves.ps diff --git a/documentationupdate/figs/g1.ps b/documentation/figs/g1.ps similarity index 100% rename from documentationupdate/figs/g1.ps rename to documentation/figs/g1.ps diff --git a/documentationupdate/figs/g2.ps b/documentation/figs/g2.ps similarity index 100% rename from documentationupdate/figs/g2.ps rename to documentation/figs/g2.ps diff --git a/documentationupdate/figs/g3.ps b/documentation/figs/g3.ps similarity index 100% rename from documentationupdate/figs/g3.ps rename to documentation/figs/g3.ps diff --git a/documentationupdate/figs/g4.ps b/documentation/figs/g4.ps similarity index 100% rename from documentationupdate/figs/g4.ps rename to documentation/figs/g4.ps diff --git a/documentationupdate/figs/g5.ps b/documentation/figs/g5.ps similarity index 100% rename from documentationupdate/figs/g5.ps rename to documentation/figs/g5.ps diff --git a/documentationupdate/figs/g6.ps b/documentation/figs/g6.ps similarity index 100% rename from documentationupdate/figs/g6.ps rename to documentation/figs/g6.ps diff --git a/documentationupdate/figs/g7.ps b/documentation/figs/g7.ps similarity index 100% rename from documentationupdate/figs/g7.ps rename to documentation/figs/g7.ps diff --git a/documentation/figs/oc-hss-140513.ps b/documentation/figs/oc-hss-140513.ps new file mode 100644 index 0000000..4c65e3e Binary files /dev/null and b/documentation/figs/oc-hss-140513.ps differ diff --git a/documentation/figs/oc-hss-141002.ps b/documentation/figs/oc-hss-141002.ps new file mode 100644 index 0000000..35a89d8 Binary files /dev/null and b/documentation/figs/oc-hss-141002.ps differ diff --git a/documentationupdate/modelpack6.tex b/documentation/gtp3.tex similarity index 95% rename from documentationupdate/modelpack6.tex rename to documentation/gtp3.tex index 3206dc8..b5937ea 100644 --- a/documentationupdate/modelpack6.tex +++ b/documentation/gtp3.tex @@ -37,7 +37,7 @@ should be revised when all major parts have been implemented and tested. -\vspace{5mm} +\bigskip {\bf Documentation updating software} @@ -106,7 +106,7 @@ \section{The Gibbs energy function} \subsection{New features in version 2} The release of version 2 of OC was scheduled for June 2014 but has of -corse been delayed. The new release date is expected in January 2015. +course been delayed. The new release date is expected in January 2015. The main change in the GTP module is implementing the ionic liquid model. This does not really change much in this documentation, the code for handling the variable ratio of sublattices has been @@ -705,13 +705,13 @@ \subsection{State variables} X & 111 & phase\#set/comp & -/comp & 0 & Mole fraction\\ X\% & 111 & phase\#set/comp & -/comp & 100 & Mole per cent\\ Bz & 12z & -/phase\#set/comp & -/comp & - & Mass of component\\ -W & 122 & phase\#set/comp & -/comp & 0 & Mass per cent\\ +W & 122 & phase\#set/comp & -/comp & 0 & Mass fraction\\ W\% & 122 & phase\#set/comp & -/comp & 100 & Mass per cent\\ Y & 130 & phase\#set & const\#subl & -& Constituent fraction\\\hline \multicolumn{6}{|c|}{Some model parameter identifiers}\\\hline TC & - & phase\#set & - & - & Curie temperature\\ BMAG & - & phase\#set & - & - & Aver. Bohr magneton number\\ -MQ\& & - & phase\#set & constituent & - & Mobility\\ +MQ\&X & - & phase\#set & constituent & - & Mobility of X\\ THET & - & phase\#set & - & - & Debye temperature\\\hline \end{tabular} \end{table} @@ -724,7 +724,7 @@ \section{Fortran Data Structures} more flexible way by allocating the arrays in a special subroutine for initiation. -As I am learning Fortran08 by this programming I discover new +As I am learning Fortran08 by this programming project I discover new possibilities now and again. It seems possible to allow the initialization subroutine to do this dimensioning which means one may tailor the dimensioning of the arrays depending on the kind of @@ -803,15 +803,19 @@ \subsection{Bits of information} ! NOSAVE: data changed after last save command ! VERBOSE: maximum of listing ! SETVERB: explicit setting of verbose +! SILENT: as little output as possible +! NOAFTEREQ: no manipulations of results after equilirum calculation ! >>>> some of these should be moved to the gtp_equilibrium_data record integer, parameter :: & GSBEG=0, GSOCC=1, GSADV=2, GSNOGLOB=3, & GSNOMERGE=4, GSNODATA=5, GSNOPHASE=6, GSNOACS=7, & GSNOREMCS=8, GSNOSAVE=9, GSVERBOSE=10, GSSETVERB=11,& - GSSILENT=12 + GSSILENT=12, GSNOAFTEREQ=13 +!---------------------------------------------------------------- !-Bits in element record integer, parameter :: & ELSUS=0 +!---------------------------------------------------------------- !-Bits in species record ! Suspended, implicitly suspended, species is element, species is vacancy ! species have charge, species is (system) component @@ -853,12 +857,12 @@ \subsubsection{Phase record bits}\label{sec:phasebits} PHFACTCE=16, PHNOCS=17, PHHELM=18, PHNODGDY2=19,& PHELMA=20, PHEXCB=21 ! +!---------------------------------------------------------------- !-Bits in constituent fraction (phase_varres) record STATUS2 ! CSDFS is set if record is for disordred fraction set, then one must use ! sublattices from fraction_set record ! CSDLNK: a disordred fraction set in this phase_varres record -! CSSUS: set if comp. set if must not be stable, -! CSFIXDORM: set if fix or dormant, +! CSDUM2 and CSDUM3 not used ! CSCONSUS set if one or more constituents suspended (status array constat ! specify constituent status) ! CSORDER: set if fractions are ordered (only used for BCC/FCC ordering @@ -866,9 +870,8 @@ \subsubsection{Phase record bits}\label{sec:phasebits} ! CSSTABLE: set if phase is stable after an equilibrium calculation ! CSAUTO set if composition set created during calculations ! CSDEFCON set if there is a default constitution -! NOTE phase_status ENTERED means both CSSUS and CSFIXDORM are sero (not set) integer, parameter :: & - CSDFS=0, CSDLNK=1, CSSUS=2, CSFIXDORM=3, & + CSDFS=0, CSDLNK=1, CSDUM2=2, CSDUM3=3, & CSCONSUS=4, CSORDER=5, CSSTABLE=6, CSAUTO=7, & CSDEFCON=8 \end{verbatim} @@ -891,10 +894,12 @@ \subsubsection{Some more bits} ! For each constituent: is suspended, is implicitly suspended, is vacancy integer, parameter :: & CONSUS=0,CONIMSUS=1,CONVA=2 +!---------------------------------------------------------------- !-Bits in state variable functions (svflista) ! SVFVAL symbol evaluated only explicitly (mode=1 in call) integer, parameter :: & SVFVAL=0,SVFEXT=1 +!---------------------------------------------------------------- !-Bits in gtp_equilibrium_data record ! EQNOTHREAD set if equilibrium must be calculated before threading ! (in assessment) for example if a symbol must be evaluated in this @@ -908,11 +913,13 @@ \subsubsection{Some more bits} integer, parameter :: & EQNOTHREAD=0, EQNOGLOB=1, EQNOEQCAL=2, EQINCON=3, & EQFAIL=4, EQNOACS=5, EQGRIDTEST=6 +!---------------------------------------------------------------- !-Bits in parameter property type record (gtp_propid) ! constant (no T or P dependence), only P, property has an element suffix ! (like mobility), property has a constituent suffix integer, parameter :: & IDNOTP=0, IDONLYP=1, IDELSUFFIX=2, IDCONSUFFIX=3 +!---------------------------------------------------------------- !- Bits in condition status word (some set in onther ways??) ! singlevar means T=, x(el)= etc, singlevalue means value is a number ! phase means the condition is a fix phase @@ -933,13 +940,13 @@ \subsubsection{Phase status revision} {\small \begin{verbatim} ! some constants, phase status - integer, parameter :: phhidden=-4 - integer, parameter :: phsus=-3 - integer, parameter :: phdorm=-2 - integer, parameter :: phentunst=-1 - integer, parameter :: phentered=0 - integer, parameter :: phentstab=1 - integer, parameter :: phfixed=2 + integer, parameter :: PHHIDDEN=-4 + integer, parameter :: PHSUS=-3 + integer, parameter :: PHDORM=-2 + integer, parameter :: PHENTUNST=-1 + integer, parameter :: PHENTERED=0 + integer, parameter :: PHENTSTAB=1 + integer, parameter :: PHFIXED=2 character (len=12), dimension(-4:2), parameter :: phstate=& (/'HIDDEN ','SUSPENDED ','DORMANT ','ENTERED UNST',& 'ENTERED ','ENTERED STBL','FIXED '/) @@ -968,7 +975,7 @@ \subsection{Dimensioning} \begin{verbatim} ! Parameters defining the size of arrays etc. ! max elements, species, phases, sublattices, constituents (ideal phase) - integer, parameter :: maxel=100,maxsp=1000,maxph=400,maxsubl=10,maxconst=1000 + integer, parameter :: maxel=100,maxsp=1000,maxph=800,maxsubl=10,maxconst=1000 ! maximum number of consitutents in non-ideal phase integer, parameter :: maxcons2=100 ! maximum number of elsements in a species @@ -990,8 +997,8 @@ \subsection{Dimensioning} integer, private, parameter :: maxsvfun=500 ! version number ! changes in last 2 digits means no change in SAVE/READ format - character*8, parameter :: gtpversion='GTP-2.00' - character*8, parameter :: savefile='OCF-2.00' + character*8, parameter :: gtpversion='GTP-3.00' + character*8, parameter :: savefile='OCF-3.00' \end{verbatim} } @@ -1012,8 +1019,8 @@ \subsubsection{User defined additions} integer, public, parameter :: einsteincp=4 integer, public, parameter :: elasticmodela=5 integer, public, parameter :: glastransmodela=6 -! Note that additions often use parameters like Curie or Debye temperatures -! defined by parameter identifiers stored in gtp_propid +! Note that additions often use extra parameters like Curie or Debye +! temperatures defined by parameter identifiers stored in gtp_propid \end{verbatim} } @@ -1072,10 +1079,10 @@ \subsection{The ELEMENT data type} real elements have numbers from 1 and higher. The OC software is case insensitive, UPPER and lower case letters are -treated identically. Thus Va and VA is the same. Elements with a +treated identically. Thus Va, va and VA is the same. Elements with a single letter symbol must be follwed by a space or a non-alphabetic -characterstoichiometric number, for example a stoichiometric factor, -to separate it from a following letter. +character, for example a stoichiometric factor, to separate it from a +following letter. The advantage with ELLISTA is that the element is stored at an index which never change, it does not change when other elements are entered @@ -1206,12 +1213,13 @@ \subsection{Components} ! the endmember array is for the reference phase to calculate GREF ! The last calculated values of the chemical potentials (for user defined ! and default reference states) should be stored here. +! molat is the number of moles of components in the defined reference state integer :: splink,phlink,status character*16 :: refstate integer, dimension(:), allocatable :: endmember double precision, dimension(2) :: tpref double precision, dimension(2) :: chempot - double precision mass + double precision mass,molat END TYPE gtp_components ! allocated in gtp_equilibrium_data \end{verbatim} @@ -1752,7 +1760,7 @@ \subsubsection{The elastic model} \end{verbatim} } -\subsubsection{The phase and composition set indices} +\subsubsection{The phase and composition set indices}\label{sc:phtup} In many cases one must specify both a phase and a composition set and this is done by separate indices in most subroutine calls. As this is @@ -1846,21 +1854,17 @@ \subsubsection{The phase record} ! To allow parallel processing of endmembers, store a pointer to each here integer noemr,ndemr TYPE(endmemrecarray), dimension(:), allocatable :: oendmemarr,dendmemarr -!----------------------------------------------------------------- -! this used to be sublista but is now incorporated in gtp_phaserecord !!! -! static data, contains pointers to constituent record and sites ! noofsubl: number if sublattices -! cslink: is index to first composition set (deleted) -! linktocs: array with indices to phase_varres records (to replace clink) ! tnooffr: total number of fractions (constituents) +! linktocs: array with indices to phase_varres records ! nooffr: array with number of constituents in each sublattice -! sites: array with site rations (? dynamic for ionic liquid) +! Note that sites are stored in phase_varres as they may vary with the +! constituion for ionic liquid) ! constitlist: indices of species that are constituents (in all soblattices) integer noofsubl,tnooffr integer, dimension(9) :: linktocs integer, dimension(:), allocatable :: nooffr ! number of sites in phase_varres record as it can vary with composition -! double precision, dimension(:), allocatable :: sites integer, dimension(:), allocatable :: constitlist ! used in ionic liquid: ! i2slx(1) is index of Va, i2slx(2) is index if last anion (both can be zero) @@ -1868,7 +1872,6 @@ \subsubsection{The phase record} ! allocated in init_gtp. END TYPE gtp_phaserecord ! NOTE phase with index 0 is the reference phase for the elements -! The array sublista is now merged into phlista ! allocated in init_gtp TYPE(gtp_phaserecord), private, allocatable :: phlista(:) INTEGER, private, allocatable :: PHASES(:) @@ -2123,18 +2126,17 @@ \subsection{The phase\_varres record for composition sets} ! status2: has phase status bits like ENT/FIX/SUS/DORM ! phstate: indicate state: fix/stable/entered/unknown/dormant/suspended/hidden ! 2 1 0 -1 -2 -3 -4 -! constat: array with status word for each constituent, any can be suspended -! yfr: the site fraction array -! mmyfr: min/max fractions +! phtupx: phase tuple index + integer nextfree,phlink,status2,phstate,phtupx ! abnorm(1): amount moles of atoms for a formula unit of the composition set ! abnorm(2): mass/formula unit (both set by call to set_constitution) -! sites: site ratios (which can vary for ionic liquids) ! prefix and suffix are added to the name for composition sets 2 and higher -! disfra: a structure describing the disordered fraction set (if any) - integer nextfree,phlink,status2,phstate double precision, dimension(2) :: abnorm character*4 prefix,suffix -! changed to allocatable +! constat: array with status word for each constituent, any can be suspended +! yfr: the site fraction array +! mmyfr: min/max fractions, negative is a minumum +! sites: site ratios (which can vary for ionic liquids) integer, dimension(:), allocatable :: constat double precision, dimension(:), allocatable :: yfr real, dimension(:), allocatable :: mmyfr @@ -2145,22 +2147,17 @@ \subsection{The phase\_varres record for composition sets} ! 2nd sublattice Q=\sum_i v_i*y_i double precision, dimension(:), allocatable :: dpqdy double precision, dimension(:), allocatable :: d2pqdvay +! disfra: a structure describing the disordered fraction set (if any) ! for extra fraction sets, better to go via phase record index above ! this TYPE(gtp_fraction_set) variable is a bit messy. Declaring it in this ! way means the record is stored inside this record. type(gtp_fraction_set) :: disfra -! It seems difficult to get the phdapointer in disfra record to work ! --- ! arrays for storing calculated results for each phase (composition set) ! amfu: is amount formula units of the composition set (calculated result) ! netcharge: is net charge of phase -! dgm: driving force (calculated result) -! amcom: not used -! damount: set to last change of phase amount in equilibrium calculations -! qqsave: values of qq calculated in set_constitution -! double precision amount(2),dgm,amcom,damount,qqsave(3) -! double precision amfu,netcharge,dgm,amcom,damount,qqsave(3) - double precision amfu,netcharge,dgm,amcom,damount +! dgm: driving force + double precision amfu,netcharge,dgm ! Other properties may be that: gval(*,2) is TC, (*,3) is BMAG, see listprop ! nprop: the number of different properties (set in allocate) ! ncc: total number of site fractions (redundant but used in some subroutines) @@ -2181,8 +2178,7 @@ \subsection{The phase\_varres record for composition sets} double precision, dimension(:,:), allocatable :: d2gval ! added for strain/stress, current values of lattice parameters double precision, dimension(3,3) :: curlat -! saved values from last equilibrium calculation -! double precision, dimension(:), allocatable :: dsf +! saved values from last equilibrium for dot derivative calculations double precision, dimension(:,:), allocatable :: cinvy double precision, dimension(:), allocatable :: cxmol double precision, dimension(:,:), allocatable :: cdxmol @@ -2209,18 +2205,17 @@ \subsection{The equilibrium record}\label{sec:equilibriumrec} ! Several equilibria may be calculated simultaneously in parallell threads ! so each equilibrium must be independent ! NOTE: the error code must be local to each equilibria!!!! -! During step and map thses records with results are saved +! During step and map each equilibrium record with results is saved ! values of T and P, conditions etc. ! Values here are normally set by external conditions or calculated from model ! local list of components, phase_varres with amounts and constitution ! lists of element, species, phases and thermodynamic parameters are global -! tpval(1) is T, tpval(2) is P, rgas is R, rtn is R*T ! status: not used yet? ! multiuse: used for various things like direction in start equilibria ! eqno: sequential number assigned when created ! next: index of next equilibrium in a sequence during step/map calculation. ! eqname: name of equilibrium -! tpval: value of T and P +! tpval(1) is T, tpval(2) is P, rgas is R, rtn is R*T ! rtn: value of R*T integer status,multiuse,eqno,next character eqname*24 @@ -2304,8 +2299,6 @@ \subsection{Parsing data} integer :: intlat(maxinter),intcon(maxinter),endcon(maxsubl) ! interaction level and number of fraction variables integer :: intlevel,nofc -! explained above, to be used for FCC and BCC permutations ?? -! integer, dimension(permstacklimit) :: lastperm,permlimit ! interacting constituents (max 4) for composition dependent interaction ! iq(j) indicate interacting constituents ! for binary RK+Muggianu iq(3)=iq(4)=iq(5)=0 @@ -2440,7 +2433,7 @@ \section{Global variables} ! counters for elements, species and phases initiated to zero integer, private :: noofel=0,noofsp=0,noofph=0 ! counter for phase tuples (combination of phase+compset) - integer :: nooftuples=0 + integer, private :: nooftuples=0 ! counters for property and interaction records, just for fun integer, private :: noofprop,noofint,noofem ! free lists in phase_varres records and addition records @@ -2460,8 +2453,6 @@ \section{Global variables} \end{verbatim} } -%%%%%%%%%%%%%%%%%% here starts pmod25A.F90 - \section{Subroutines and functions} It is not self evident how to organise the description of the @@ -2494,6 +2485,8 @@ \subsection{Variable names} \subsection{Initiallization} +%!> here starts gtp3A.F90 -------------------------------------------- + This subroutine must be called before any other in the GTP pacjage. It dimensions arrays and creates some initial data structures. The arguments are presently not used but should be used to dimension @@ -2505,7 +2498,7 @@ \subsection{Initiallization} ! initiate the data structure ! create element and species record for electrons and vacancies ! the allocation of many arrays should be provided calling this routne -! these will eventually be used for allocations and defaults +! intvar and dblvar will eventually be used for allocations and defaults implicit none integer intvar(*) double precision dblvar(*) @@ -2539,6 +2532,8 @@ \subsection{Functions to know how many} implicit none integer iph,ics TYPE(gtp_equilibrium_data), pointer :: ceq + integer function nooftup() +! number of phase tuples \end{verbatim} } @@ -2568,12 +2563,13 @@ \subsubsection{How many equilibria} \subsubsection{Total number of phases and composition sets} -This is used when dimensioning arrays for phases for calculations. +This is needed when dimensioning arrays for phases and composition +sets for calculations. {\small \begin{verbatim} - integer function totalphcs(ceq) -! returns the total number of unhidden and unsuspended phases+composition sets + integer function nonsusphcs(ceq) +! returns the total number of unhidden phases+composition sets ! in the system. Used for dimensioning work arrays and in loops implicit none TYPE(gtp_equilibrium_data), pointer :: ceq @@ -2621,13 +2617,27 @@ \subsection{Find things} implicit none integer loksp character name*(*) + subroutine find_phasetuple_by_name(name,phcsx) +! finds a phase with name "name", returns phase tuple index +! handles composition sets either with prefix/suffix or #digit +! When no pre/suffix nor # always return first composition set + implicit none + character name*(*) + integer phcsx subroutine find_phase_by_name(name,iph,ics) ! finds a phase with name "name", returns address of phase, first fit accepted ! handles composition sets either with prefix/suffix or #digit -! no pre/suffix nor # gives first composition set +! When no pre/suffix nor # always return first composition set implicit none character name*(*) integer iph,ics + subroutine find_phasex_by_name(name,phcsx,iph,ics) +! finds a phase with name "name", returns address of phase, first fit accepted +! handles composition sets either with prefix/suffix or #digit +! no pre/suffix nor # always return first composition set + implicit none + character name*(*) + integer phcsx,iph,ics subroutine find_phase_by_name_exact(name,iph,ics) ! finds a phase with name "name", returns address of phase. exact match req. ! handles composition sets either with prefix/suffix or #digit @@ -2825,7 +2835,7 @@ \subsubsection{Mass of component} \subsubsection{Get phase name} The title says all but there are two variants of this, one using -phase tuplets, the other integer variables as arguments. +phase tuples, the other integer variables as arguments. {\small \begin{verbatim} @@ -2887,6 +2897,21 @@ \subsubsection{Get phase data}\label{sec:getphasedata} \end{verbatim} } +\subsubsection{Phase tuple array} + +Mainly for application software this subroutine returns an array with +all phase tuples. A phase tuple is an two dimentional record with the +first index \%phase is the phase number and the second \%compset the +composition set number, , see section~\ref{sc:phtup}. + +\begin{verbatim} + integer function get_phtuplearray(phcs) +! copies the internal phase tuple array to external software +! function value set to number of tuples + type(gtp_phasetuple), dimension(*) :: phcs +\end{verbatim} + + \subsection{Set things} Many things can be set but most of the ways to set them are described @@ -2925,810 +2950,976 @@ \subsubsection{Set constitution}\label{sec:setconst} \end{verbatim} } -\subsubsection{Set condition} - -See section~\ref{sec:setcondition}. - -\subsection{Calculation} - -There are many subroutines involved in calculating the Gibbs energy -for a system and to retrieve values afterwards. Some are explained in -connection with what they calculate, for example the magnetic -contribution in \ref{sec:calculateinden}. - -%%%%%%%%%%%%%%%%%%%%%%% here starts pmod25b.F90 - -\subsubsection{Calculate for one phase}\label{sec:calcg} - -This subroutine calculates the Gibbs energy and all first and second -derivaties with respect to $T, P$ and constituents for the specified -phase and composition set using the current values of $T, P$ and -constitution of the phase (set by set\_constitution, -see~\ref{sec:setconst}). It also calculates all other properties -stored in the property records. +\subsubsection{Set reference state for a component}\label{sc:setrefstate} -It is possible to calculate only G my setting moded=0, only G and -first derivatives if moded=1 and also second derivatives with moded=2. -This routine calls calcg\_internal to do the calculations after some -checks. +For each component the user can select a phase, temperatue and +pressure as reference state. If a * is given as temperature and +pressure the current value of $T$ and $P$ will be used. The reference +state is used in calculate\_reference\_state in +section~\ref{sc:calrefstate}. {\small \begin{verbatim} - subroutine calcg(iph,ics,moded,lokres,ceq) -! calculates G for phase iph and composition set ics in equilibrium ceq -! checks first that phase and composition set exists -! Data taken and stored in equilibrium record ceq -! lokres is set to the phase_varres record with all fractions and results -! moded is 0, 1 or 2 depending on calculating no, first or 2nd derivarives + subroutine set_reference_state(icomp,iph,tpval,ceq) +! set the reference state of a component to be "iph" at tpval implicit none + integer icomp,iph + double precision, dimension(2) :: tpval TYPE(gtp_equilibrium_data), pointer :: ceq - integer iph,ics,moded,lokres \end{verbatim} } -\subsubsection{Model independent routine for one phase calculation} +\subsubsection{Set condition} -This is the central subroutine to calculate G and derivatives for all -kinds of phases. At present only the CEF model is implemented. It -calls many other calculating subroutines, some are described in -connection with the property they calculate, like magnetic -contribution. +See section~\ref{sec:setcondition}. -{\small -\begin{verbatim} - subroutine calcg_internal(lokph,moded,cps,ceq) -! Central calculating routine calculating G and everyting else for a phase -! ceq is the equilibrium record, cps is the phase_varres record for lokph -! moded is type of calculation, 0=only G, 1 G and first derivatives -! 2=G and all second derivatives -! Can also handle the ionic liquid model now .... - implicit none - integer lokph,moded - TYPE(gtp_equilibrium_data), pointer :: ceq - TYPE(gtp_phase_varres), target :: cps -\end{verbatim} -} +%!> here starts gtp3B.F90 -------------------------------------------- -\subsubsection{A utility routine} +\subsection{Enter data} -This is used when a phase has permutations, see~\ref{sec:permutations} +The subroutines for entering data and other things can be named as +new, enter, add, create etc. according to the mind of the programmer +when the subroutine was written. In all cases the data is provided as +arguments in the call, there is no interactions with the user. + +\subsubsection{Enter element data} + +All data for an element. Some checks are made. The elements are +automatically eneterd also as species so they can be constituents of +phases. {\small \begin{verbatim} - subroutine setendmemarr(lokph,ceq) -! stores the pointers to all ordered and disordered endmemners in arrays + subroutine enter_element(symb,name,refstate,mass,h298,s298) +! Creates an element record after checks. +! symb: character*2, symbol (it can be a single character like H or V) +! name: character, free text name of the element +! refstate: character, free text name of reference state. +! mass: double, mass of element in g/mol +! h298: double, enthalpy difference between 0 and 298.14 K +! s298: double, entropy at 298.15 K implicit none - integer lokph - TYPE(gtp_equilibrium_data), pointer :: ceq + CHARACTER*(*) symb,name,refstate + DOUBLE PRECISION mass,h298,s298 \end{verbatim} } -\subsubsection{Calculate and list results for one phase} +\subsubsection{Enter species data} -This is mainly a debugging rotine that calculates and lists for a -specific phase the Gibbs energy and all first and second derivatives -by calling calcg using the current values of $T, P$ and constitution. -It does not iterate and can thus not calculate an equilibrium. +All data for an element. Some checks are made. The elements +constituting the species must have been entered before. A species can +have a positive or negative charge using the element index -1 with a +stoichiometic factor. {\small \begin{verbatim} - subroutine tabder(iph,ics,ceq) -! tabulate derivatives of phase iph with current constitution and T and P + subroutine enter_species(symb,noelx,ellist,stoik) +! creates a new species +! symb: character*24, name of species, often equal to stoichimoetric formula +! noelx: integer, number of elements in stoichiometric formula (incl charge) +! ellist: character array, element names (electron is /-) +! stoik: double array, must be positive except for electron. implicit none - integer iph,ics - TYPE(gtp_equilibrium_data), pointer :: ceq + character symb*(*),ellist(*)*(*) + integer noelx + double precision stoik(*) \end{verbatim} } -\subsubsection{Calculate an interaction parameter} +\subsubsection{Enter phase and model} -This is called by calcg\_internal to calculate the value of an -interaction parameter and its derivatives and add this to all property -arrays. +This subroutine is called with the model data needed to create the +data structure for a phase (no parameter data). The model variable is +just a text, phtype is used to arrange gas (G) and liquids (L) before +the alphabetical list of the other phases. {\small \begin{verbatim} - subroutine cgint(lokph,lokpty,moded,vals,dvals,d2vals,gz,ceq) -! calculates an excess parameter that can be composition dependent -! gz%yfrem are the site fractions in the end member record -! gz%yfrint are the site fractions in the interaction record(s) -! lokpty is the property index, lokph is the phase record -! moded=0 means only G, =1 G and dG/dy, =2 all + subroutine enter_phase(name,nsl,knr,const,sites,model,phtype) +! creates the data structure for a new phase +! name: character*24, name of phase +! nsl: integer, number of sublattices (range 1-9) +! knr: integer array, number of constituents in each sublattice +! const: character array, constituent (species) names in sequential order +! sites: double array, number of sites on the sublattices +! model: character, free text +! phtype: character*1, specifies G for gas, L for liquid implicit none - integer moded,lokph - TYPE(gtp_property), pointer :: lokpty - TYPE(gtp_parcalc) :: gz - double precision vals(6),dvals(3,gz%nofc) - TYPE(gtp_equilibrium_data) :: ceq + character name*(*),model*(*),phtype*(*) + integer nsl + integer, dimension(*) :: knr + double precision, dimension(*) :: sites + character, dimension(*) :: const*(*) \end{verbatim} } -\subsubsection{Calculate ideal configurational entropy} +\subsubsection{Sorting constituents in ionic liquids} -This calculates the ideal configurational entropy summed over all -sublattices. +The ionic liquid model requires all cations (with positive charge) on +the first sublattice in alphabetcal order. On the second sublattice +the anions (with negative charge) should be first (in alphabetical +order), the the hypothetical vacancy (if any), then any neutrals in +alphabetical order. This subroutine takes care of that {\small \begin{verbatim} - subroutine config_entropy(moded,nsl,nkl,phvar,tval) -! calculates configurational entropy/R for phase lokph + subroutine sort_ionliqconst(lokph,mode,knr,kconlok,klok) +! sorts constituents in ionic liquid, both when entering phase +! and decoding parameter constituents +! order: 1st sublattice only cations +! 2nd: anions, VA, neutrals +! mode=0 at enter phase, wildcard ok in 1st sublattice if neiher anions nor Va +! mode=1 at enter parameter (wildcard allowed, i.e. some kconlok(i)=-1) +! some parameters not allowed, L(ion,A+:B,C), must be L(ion,*:B,C), check! implicit none - integer moded,nsl - integer, dimension(nsl) :: nkl - TYPE(gtp_phase_varres), pointer :: phvar + integer lokph,knr(*),kconlok(*),klok(*),mode \end{verbatim} } -\subsubsection{Calculate ionic liquid configurational entropy} +\subsubsection{Enter composition set} -The ionic liquid model assumes ideal mixing on each sublattice but the -site ratios are not constant. +As explained in section~\ref{sec:compsets} a phase may exist +simultaneously with several different composition sets. This can be +due to miscibility gaps or ordering. Some carbides like cubic TiC is +modelled as the same phase as the metallic FCC and it may be stable at +the same time as the austenite phase in steels. This subroutine +creates a new composition set for a phase. {\small \begin{verbatim} - subroutine config_entropy_i2sl(moded,nsl,nkl,phvar,i2slx,tval) -! calculates configurational entropy/R for ionic liquid model -! Always 2 sublattices, the sites depend on composition -! P = \sum_j (-v_j) y_j + Q y_Va -! Q = \sum_i v_i y_i -! where v is the charge on the ions. P and Q calculated by set_constitution + subroutine enter_composition_set(iph,prefix,suffix,icsno) +! adds a composition set to a phase. +! iph: integer, phase index +! prefix: character*4, optional prefix to original phase name +! suffix: character*4, optional suffix to original phase name +! icsno: integer, returned composition set index (value 2-9) +! ceq: pointer, to current gtp_equilibrium_data +! +! BEWARE this must be done in all equilibria (also during parallel processes) +! There may still be problems with equilibria saved during STEP and MAP +! implicit none - integer moded,nsl,i2slx(2) - integer, dimension(nsl) :: nkl - TYPE(gtp_phase_varres), pointer :: phvar + integer iph,icsno + character*(*) prefix,suffix +! TYPE(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } -\subsubsection{Push/pop constituent fraction product on stack} +\subsubsection{Remove composition set} -These subroutines are used to push/pop current values of the product -of constituent fractions and its derivatives before calculating an -interaction parameter. +Sometimes the grid minimizer creates too many composition sets and +the furter calculations may be easier if these are removed. {\small \begin{verbatim} - subroutine push_pyval(pystack,intrec,pmq,pyq,dpyq,d2pyq,moded,iz) -! push data when entering an interaction record - implicit none - integer pmq,moded,iz - double precision pyq,dpyq(iz),d2pyq(iz*(iz+1)/2) - type(gtp_pystack), pointer :: pystack - type(gtp_interaction), pointer :: intrec - subroutine pop_pyval(pystack,intrec,pmq,pyq,dpyq,d2pyq,moded,iz) -! pop data when entering an interaction record + subroutine remove_composition_set(iph,force) +! the last composition set is deleted +! +! >>>>>>>>>>>>>>>>>>>>>>>>>>>> NOTE <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ! +! Not safe to remove composition sets when more than one equilibrium ! +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ! +! +! If force is TRUE delete anyway ... very dangerous ... +! implicit none - integer iz,pmq,moded - double precision pyq,dpyq(iz),d2pyq(iz*(iz+1)/2) - type(gtp_pystack), pointer :: pystack - type(gtp_interaction), pointer :: intrec +! +! BEWARE must be for all equilibria but maybe not allowed when threaded +! + integer iph,jl,tuple + logical force \end{verbatim} } -\subsubsection{Calculate disordered fractions from constituent fractions} +\subsubsection{Enter parameter} -This is used when there are several fraction sets of a phase. The -values of the second fraction set (also called the disordered fraction -set) is calculated by this subroutine. These disordered fractions can -be used to calculate a ``disordered'' part of the Gibbs energy with -its own set of parameters. +All kind of parameters are entered by this subroutine. Called when +reading a TDB file or entered interactivly, +see~\ref{sec:enterparinter}. {\small \begin{verbatim} - subroutine calc_disfrac(lokph,lokcs,ceq) -! calculate and set disordered set of fractions from sitefractions -! The first derivatives are dxidyj. There are no second derivatives -! TYPE(gtp_fraction_set), pointer :: disrec + subroutine enter_parameter(lokph,typty,fractyp,nsl,endm,nint,lint,ideg,& + lfun,refx) +! enter a parameter for a phase from database or interactivly +! typty is the type of property, 1=G, 2=TC, ... , n*100+icon MQ&const#subl +! fractyp is fraction type, 1 is site fractions, 2 disordered fractions +! nsl is number of sublattices +! endm has one constituent index for each sublattice +! constituents in endm and lint should be ordered so endm has lowest +! (done by decode_constarr) +! nint is number of interacting constituents (can be zero) +! lint is array of sublattice+constituent indices for interactions +! ideg is degree +! lfun is link to function (integer index) +! refx is reference (text) +! if this is a phase with permutations all interactions should be in +! the first or the first two identical sublattices (except interstitals) +! a value in endm can be negative to indicate wildcard +! for ionic liquid constituents must be sorted specially implicit none - integer lokph,lokcs - TYPE(gtp_equilibrium_data), pointer :: ceq + integer, dimension(*) :: endm + character refx*(*) + integer lokph,fractyp,typty,nsl,nint,ideg,lfun + integer, dimension(2,*) :: lint \end{verbatim} } -\subsubsection{Disorder constituent fractions} - -This subroutine is now redundant. Previously the Gibbs energy for the -``partitioned'' phases, like FCC and BCC which can have order/disorder -transformations, see \ref{sec:partitioning}, the ``ordered part'' was -calculated twice, once with the original constituent fractions and -once with these set equal to their disordered value. The reason for -this was that the ``disordered part'' should be complete i.e. include -also the disordered part of the ``ordered part'' as the disordered -partitions was sometimes included in a larger disordered phase without -the ordered part. +\subsubsection{Subroutines handling fcc permutations} -This is no longer made, the Gibbs energy is simply added from the two -fraction sets. This subroutne sets the fractions to their disordered -values. +These subroutines creates all possible permutations of parameters for +a 4 sublattice fcc phase. The 4 ordering sublattices must be the +first and they represent the tetrahedron in the lattice. The number +of sites must be the same and the constituents also. There can be +additional sublattices for interstitials. {\small \begin{verbatim} - subroutine disordery(phvar,ceq) -! sets the ordered site fractions in FCC and other order/disordered phases -! equal to their disordered value in order to calculate and subtract this part -! phvar is index to phase_varres for ordered fractions + subroutine fccpermuts(lokph,nsl,iord,noperm,elinks,nint,jord,intperm,intlinks) +! finds all fcc/hcp permutations needed for this parameter +! The order of elements in the sublattices is irrelevant when one has F or B +! ordering as all permutations are stored in one place (with some exceptions) +! Thus the endmembers are ordered alphabetically in the sublattices and also +! the interaction parameters. Max 2 levels of interactions allowed. implicit none - TYPE(gtp_phase_varres), pointer :: phvar - TYPE(gtp_equilibrium_data) :: ceq + integer, dimension(*) :: iord,intperm + integer, dimension(2,*) :: jord + integer lokph,nsl,noperm,nint + subroutine fccip2A(lokph,jord,intperm,intlinks) +! 2nd level interaction permutations for fcc + implicit none + integer, dimension(*) :: intperm + integer, dimension(2,*) :: jord,intlinks + integer lokph + subroutine fccip2B(lq,lokph,lshift,jord,intperm,intlinks) +! 2nd level interaction permutations for fcc + implicit none + integer lq,lokph,lshift + integer, dimension(*) :: intperm + integer, dimension(2,*) :: jord,intlinks + subroutine fccint31(jord,lshift,intperm,intlinks) +! 1st level interaction in sublattice l1 with endmember A:A:A:B or A:B:B:B +! set the sublattice and link to constituent for each endmember permutation +! 1st permutation of endmember: AX:A:A:B; A:AX:A:B; A:A:AX;B 4 0 1 2 +! 2nd permutation of endmember: AX:A:B:A; A:AX:B:A; A:A:B:AX 3 0 1 3 +! 3rd permutation of endmember: AX:B:A:A; A:B:AX:A; A:B:A:AX 3 0 2 3 +! 4th permutation of endmember: B:AX:A:A; B:A:AX:A; B:A:A:AX 1 or 1 2 3 +! 1st permutation of endmember: A:BX:B:B; A:B:BX:B; A:B:B:BX 4 0 1 2 +! 2nd permutation of endmember: BX:A:B:B; B:A:BX:B; B:A:B:BX 1 etc -1 1 2 +! 3rd -1 0 2 ; -1 0 1 +! suck + implicit none + integer lshift + integer, dimension(2,*) :: jord,intlinks + integer, dimension(*) :: intperm + subroutine fccint22(jord,lshift,intperm,intlinks) +! 1st level for endmember A:A:B:B with interaction in sublattice jord(1,1) +! 6 permutations of endmember, 2 permutations of interactions, 12 in total +! 1st endmemperm: AX:A:B:B; A:AX:B:B 0 1 +! 2nd endmemperm: AX:B:A:B; A:B:AX:B 0 2 +! 3rd endmemperm: AX:B:B:A; A:B:B:AX 0 3 +! 4th endmemperm: B:AX:B:A; B:A:B:AX 1 3 +! 5th endmemperm: B:B:AX:A; B:B:A:AX 2 3 +! 6th endmemperm: B:AX:A:B; B:A:AX:B or 1 2 +! 1th endmemperm: A:A:BX:B; A:A:B:BX 0 1 +! 2nd endmemperm: A:BX:A:B; A:B:A:BX -1 1 +! 3rd endmemperm: A:BX:B:A; A:B:BX:A -1 0 +! 4th endmemperm: BX:A:B:A; B:A:BX:A -2 0 +! 5th endmemperm: BX:B:A:A; B:BX:A:A -2 -1 +! 6th endmemperm: BX:A:A:B; B:A:A:BX -2 1 + implicit none + integer lshift + integer, dimension(2,*) :: jord,intlinks + integer, dimension(*) :: intperm + subroutine fccint211(a211,jord,lshift,intperm,intlinks) +! 1st level interaction in sublattice l1 with endmember like A:A:B:C +! 12 endmember permutations of AABC; ABBC; or ABCC +! 2 interaction permutations for each, 24 in total + implicit none + integer a211,lshift + integer, dimension(2,*) :: jord,intlinks + integer, dimension(*) :: intperm + subroutine fccpe211(l1,elinks,nsl,lshift,iord) +! sets appropriate links to constituents for the 12 perumations of +! A:A:B:C (l1=1), A:B:B:C (l1=2) and A:B:C:C (l1=3) + implicit none + integer, dimension(nsl,*) :: elinks + integer, dimension(*) :: iord + integer l1,nsl,lshift + subroutine fccpe1111(elinks,nsl,lshift,iord) +! sets appropriate links to 24 permutations when all 4 constituents different +! A:B:C:D +! The do loop keeps the same constituent in first sublattice 6 times, changing +! the other 3 sublattice, then changes the constituent in the first sublattice +! and goes on changing in the other 3 until all configurations done + implicit none + integer, dimension(nsl,*) :: elinks + integer, dimension(*) :: iord + integer nsl,lshift \end{verbatim} } -\subsubsection{Set driving force for a phase explicitly} +\subsubsection{Subroutines handling bcc permutations} -Another failed attempt to handle convergence problems. +Not implemented yet {\small \begin{verbatim} - subroutine set_driving_force(iph,ics,dgm,ceq) -! set the driving force of a phase explicitly + subroutine bccpermuts(lokph,nsl,iord,noperm,elinks,nint,jord,intperm,intlinks) +! finds all bcc permutations needed for this parameter implicit none - type(gtp_equilibrium_data), pointer :: ceq - integer iph,ics - double precision dgm + integer lokph,nsl,noperm,nint + integer, dimension(*) :: iord,intperm + integer, dimension(2,*) :: jord + integer, dimension(:,:), allocatable :: elinks + integer, dimension(:,:), allocatable :: intlinks \end{verbatim} } -\subsubsection{Extract massbalance conditions} - -This is used in global grid minimization to extract the set of mass -balance conditions. If the current conditions are not all mass -balance there is an error return, otherwise the conditions of T and P, -the total number of moles and the mole fractions of all components are -returned. +\subsubsection{Find constituent} {\small \begin{verbatim} - subroutine extract_massbalcond(tpval,xknown,antot,ceq) -! extract T, P, mol fractions of all components and total number of moles -! for use when minimizing G for a closed system. Probably redundant + subroutine findconst(lokph,ll,spix,constix) +! locates the constituent index of species with index spix in sublattice ll +! and returns it in constix. For wildcards spix is -99; return -99 +! THERE MAY ALREADY BE A SIMULAR SUBROUTINE ... CHECK implicit none - double precision, dimension(*) :: tpval,xknown - double precision antot - TYPE(gtp_equilibrium_data), pointer :: ceq + integer lokph,ll,spix,constix \end{verbatim} } -%%%%%%%%%%%% here starts pmod25C.F90 - -\subsection{State variable stuff} - -State variables are important for the setting and extracting results -of a calculation. State variables are treated very similarly to -Thermo-Calc using symbols like $T, ~P, ~N,$ $x({\rm )$ -etc. - -The internal syntax of state variables is rather complicated, perhaps -it should be revised and defined as a structure? If there are errors -or one wants to make modifications it is not easy. - -Things like Curie temperature, Debye temperature, mobilities etc are -alse defined as ``state variables'' altough one cannot use them in -conditions. Adding more things like elastic constants will be a -bit complicated. +\subsubsection{Enter references for parameter data} -The subroutines for manipulations is also a bit complicated and could -do with a clean up and renaming. +{\small +\begin{verbatim} + subroutine tdbrefs(refid,line,mode,iref) +! store a reference from a TDB file or given interactivly +! If refid already exist and mode=1 then amend the reference text + implicit none + character*(*) refid,line + integer mode,iref +\end{verbatim} +} -\subsubsection{Get state variable value given its symbol} +\subsubsection{Enter equilibrium}\label{sc:entereq} -By providing a state variable as a character variable like $T$ or -$x({\rm liquid,cr})$ this routine returns its current value. -Wildcards, ``*'', are not allowed, see \ref{sec:getmany}. +The equilibrium record as explained in +section~\ref{sec:equilibriumrec} has all data necessary for specifying +an equilibrium: conditions, compoenets, phases etc. One may have +several equilibria with different sets of conditions but normally they +have the same set of phases (the set of stable phases may differ). +This can be used to interactivly compare different states or used in +parallel processing where each thread is connected with an equilibrium +record. When assessing model parameter each experimental datum can be +described by an equilibrium record. {\small \begin{verbatim} - subroutine get_state_var_value(statevar,value,encoded,ceq) -! called with a state varaiable character + subroutine enter_equilibrium(name,number) +! creates a new equilibrium. Allocates arrayes for conditions, +! components, phase data and results etc. +! returns index to new equilibrium record +! THIS CAN PROBABLY BE SIMPLIFIED, especially phase_varres array can be +! copied as a whole, not each record structure separately ... ??? implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq - character statevar*(*),encoded*(*) - double precision value + character name*(*) + integer number \end{verbatim} } -\subsubsection{Get many state variable values}\label{sec:getmany} +\subsubsection{Delete equilibrium} -This routine can be called with wildcard, ``*'', as argument in state -variables like $NP(*), ~x(*,CR)$ etc. It is fragile and currently -only available when defining plot axis. +This is needed after STEP or MAP to clean up the structure as all +equilibria along the lines are saved as equilibrium records. {\small \begin{verbatim} - subroutine get_many_svar(statevar,values,mjj,kjj,encoded,ceq) -! called with a state varaiable name with woldcards allowed like X(*,CR) -! mjj is dimension of values, kjj is number of values returned -! encoded not used yet -! >>>> BIG problem: How to do with phases that are note stable? -! If I ask for w(*,Cr) I only want the fraction in stable phases -! but whenthis is used for GNUPLOT the values are written in a matix -! and the same column in that phase must be the same phase ... -! so I have to have the same number of phases from each equilibria. -! + subroutine delete_equilibria(name,ceq) +! deletes an equilibrium (needed when repeated step/map) +! name can be an abbreviation line "_MAP*" +! deallocates all data. Minimal checks ... one cannot delete "ceq" implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq - character statevar*(*),encoded*(*) - double precision values(*) - integer mjj,kjj + character name*(*) + type(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } -\subsubsection{Decode a state variable symbol}\label{sec:svdecode} - -This subroutine takes as input a character with a state variable and -returns a state variable record with its specification. It can also -handle decoding of property parameters symbols like the Curie -temeprature. The main routine calls the older version of this -subroutine with a more complex handling of state variables. This -second subroutine will eventually dissappear and should not be used. - -The new version of this subroutine calls the old but this will be -removed in a future release. If there are any changes in the state -variables struvture several subroutines must be changed like this one, -\ref{sec:svencode} and \ref{sec:svcalculate}. +\subsubsection{Copy equilibrium} -The subroutine also handle property symbols used in the parameters, -see \ref{sec:paramid}, to make it possible to obtain the value of such -a propery after an equilibrium calculation. The value returned in -svr%statev or istv for such properties is the negative of the property -index. +As part of STEP and MAP equilibrium records are copied between +different lists. {\small \begin{verbatim} - subroutine decode_state_variable(statevar,svr,ceq) -! converts a state variable character to state variable record - character statevar*(*) - type(gtp_state_variable), pointer :: svr - type(gtp_equilibrium_data), pointer :: ceq -! this subroutine using state variable records is a front end of the next: - subroutine decode_state_variable3(statevar,istv,indices,iref,iunit,svr,ceq) -! converts an old state variable character to indices -! Typically: T, x(fe), x(fcc,fe), np(fcc), y(fcc,c#2), ac(h2,bcc), ac(fe) -! NOTE! model properties like TC(FCC),MQ&FE(FCC,CR) must be detected -! NOTE: added storing information in a gtp_state_variable record svrec !! -! -! this routine became as messy as I tried to avoid -! but I leave it to someone else to clean it up ... -! -! state variable and indices -! Symbol no index1 index2 index3 index4 -! T 1 - -! P 2 - -! MU 3 component or phase,constituent -! AC 4 component or phase,constituent -! LNAC 5 component or phase,constituent -! index (in svid array) -! U 10 (phase#set) 6 Internal energy (J) -! UM 11 " 6 per mole components -! UW 12 " 6 per kg -! UV 13 " 6 per m3 -! UF 14 " 6 per formula unit -! S 2x " 7 entropy -! V 3x " 8 volume -! H 4x " 9 enthalpy -! A 5x " 10 Helmholtz energy -! G 6x " 11 Gibbs energy -! NP 7x " 12 moles of phase -! BP 8x " 13 mass of moles -! DG 9x " 15 Driving force -! Q 10x " 14 Internal stability -! N 11x (component/phase#set,component) 16 moles of components -! X 111 " 17 mole fraction of components -! B 12x " 18 mass of components -! W 122 " 19 mass fraction of components -! Y 13 phase#set,constituent#subl 20 constituent fraction -!----- model variables <<<< these now treated differently -! TC - phase#set - Magnetic ordering T -! BMAG - phase#set - Aver. Bohr magneton number -! MQ& - element, phase#set - Mobility -! THET - phase#set - Debye temperature -! + subroutine copy_equilibrium(neweq,name,ceq) +! creates a new equilibrium which is a copy of ceq. +! Allocates arrayes for conditions, +! components, phase data and results etc. from equilibrium ceq +! returns a pointer to the new equilibrium record +! THIS CAN PROBABLY BE SIMPLIFIED, especially phase_varres array can be +! copied as a whole, not each record structure separately ... ??? implicit none - integer, parameter :: noos=20 - character*4, dimension(noos), parameter :: svid = & - ['T ','P ','MU ','AC ','LNAC','U ','S ','V ',& - 'H ','A ','G ','NP ','BP ','DG ','Q ','N ',& - 'X ','B ','W ','Y '] -! 1 2 3 4 4 6 7 8 - character statevar*(*) - integer istv,iref,iunit - integer, dimension(4) :: indices - type(gtp_equilibrium_data), pointer :: ceq -! I shall try to use this record type instead of separate arguments: !! -! type(gtp_state_variable), pointer :: svrec - type(gtp_state_variable), pointer :: svr + character name*(*) + integer number + type(gtp_equilibrium_data), pointer ::neweq,ceq \end{verbatim} } -\subsubsection{Calculate molar and mass properties for a phase}\label{sec:mmph} +\subsubsection{Copy condition} -This subroutine calculates mole and massfractions of all components -for a phase (mole fractions of components not dissolved is zero). It -also returns the total number of moles of compoinets and the mass. In -amount the number of moles per formula unit is returned (same as qq(1) -in get\_phase\_data and set\_constitution). +This is also a utility used in MAP and STEP {\small \begin{verbatim} - subroutine calc_phase_molmass(iph,ics,xmol,wmass,totmol,totmass,amount,ceq) -! calculates mole fractions and mass fractions for a phase#set -! xmol and wmass are fractions of components in mol or mass -! totmol is total number of moles and totmass total mass of components. -! amount is number of moles of components per formula unit. + subroutine copy_condition(newrec,oldrec) +! Creates a copy of the condition record "oldrec" and returns a link +! to the copy in newrec. The links to "next/previous" are nullified implicit none - TYPE(gtp_equilibrium_data) :: ceq - integer iph,ics - double precision, dimension(*) :: xmol,wmass - double precision amount,totmol,totmass + type(gtp_condition), pointer :: oldrec + type(gtp_condition), pointer :: newrec \end{verbatim} } -\subsubsection{Calculate molar amounts for a phase} +\subsubsection{Check that a phase is allowed to have fcc permutations} -Specially used for grid minimization. +Some minimal checks made. {\small \begin{verbatim} - subroutine calc_phase_mol(iph,xmol,ceq) -! calculates mole fractions for phase iph, compset 1 in equilibrium ceq -! used for grid generation and some other things -! returns current constitution in xmol equal to mole fractions of components + logical function check_minimal_ford(lokph) +! some tests if the fcc/bcc permutation model can be applied to this phase +! The function returns FALSE if the user may set the FORD or BORD bit of lokph implicit none - integer iph - double precision xmol(*) - TYPE(gtp_equilibrium_data) :: ceq + integer lokph \end{verbatim} } -\subsubsection{Sum molar and mass properties for all phases} +%!> here starts gtp3C.F90 -------------------------------------------- -Sums the mole and mass fractions for all components and also total -number of moles and mass over all stable phases using \ref{sec:mmph}. +\subsection{List things} + +The routines in this section are intended for the line oriented user +interface of GTP. It lists data assuming 80 column width of the +screen. In some cases a character variable is retured but in most +case the list unit is provided in the call. This can be the screen, +a file or a device. + +Some listings are described in connection with the objects that are +listed, see \ref{sec:listadditions}. + +\subsubsection{List data for all elements} + +The element data is listed. Second version for TDB files. {\small \begin{verbatim} - subroutine calc_molmass(xmol,wmass,totmol,totmass,ceq) -! summing up N and B for each component over all phases with positive amount -! Check that totmol and totmass are correct .... + subroutine list_all_elements(unit) +! lists elements implicit none - double precision, dimension(*) :: xmol,wmass - double precision totmol,totmass - TYPE(gtp_equilibrium_data) :: ceq + integer unit + subroutine list_all_elements2(unit) +! lists elements + implicit none + integer unit \end{verbatim} } -\subsubsection{Sum all normalizing property values} +\subsubsection{List data for all components} -Used to calculate normallizing propertes like V, N and B but also G -and S for the whole system. Used when calculating state variable -values. +The components may be different in each equilibrium. {\small \begin{verbatim} - subroutine sumprops(props,ceq) -! summing up G, S, V, N and B for all phases with positive amount -! Check if this is correct + subroutine list_all_components(unit,ceq) +! lists the components for an equilibrium implicit none - TYPE(gtp_equilibrium_data) :: ceq - double precision props(5) + integer unit + TYPE(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } -\subsubsection{Encode state variable}\label{sec:svencode} +\subsubsection{List data for one element} -This converts the internal coding of a state variable into a character -variable text starting at position ip. ip is updated inside. +The data for element ``elno'' in written to the character variable text from +position ipos. -The subroutine also handle property symbols used in the parameters, -see \ref{sec:paramid}, to make it possible to list the symbol of such -a propery after an equilibrium calculation. See \ref{sec:svdecode} +{\small +\begin{verbatim} + subroutine list_element_data(text,ipos,elno) + implicit none + character text*(*) + integer ipos,elno +\end{verbatim} +} -The new version of this subroutine uses state variable records, the -previous one using individual arguments should not be used as it will -eventually disappear. +\subsubsection{List data for one species} + +The data for species ``spno'' in written to the character variable text from +position ipos. The second version is suitable for TDB files. {\small \begin{verbatim} - subroutine encode_state_variable(text,ip,svr,ceq) -! writes a state variable in text form position ip. ip is updated + subroutine list_species_data(text,ipos,spno) + implicit none character text*(*) - integer ip - type(gtp_state_variable), pointer :: svr - type(gtp_equilibrium_data), pointer :: ceq - subroutine encode_state_variable3(text,ip,istv,indices,iunit,iref,ceq) -! writes a state variable in text form position ip. ip is updated -! the internal coding provides in istv, indices, iunit and iref -! ceq is needed as compopnents can be different in different equilibria ?? -! >>>> unfinished as iunit and iref not really cared for + integer ipos,spno + subroutine list_species_data2(text,ipos,spno) implicit none - integer, parameter :: noos=20 - character*4, dimension(noos), parameter :: svid = & - ['T ','P ','MU ','AC ','LNAC','U ','S ','V ',& - 'H ','A ','G ','NP ','BP ','DG ','Q ','N ',& - 'X ','B ','W ','Y '] - character*(*) text - integer, dimension(4) :: indices - integer istv,ip,iunit,iref - type(gtp_equilibrium_data), pointer :: ceq + character text*(*) + integer ipos,spno \end{verbatim} } -\subsubsection{Encode a state variable record} +\subsubsection{List data for all species} -This is provided to convert a single state variable record to a text. +One line for each species is listed on device unit. {\small \begin{verbatim} - subroutine encode_state_variable_record(text,ip,svr,ceq) -! writes a state variable in text form position ip. ip is updated -! the svr record provide istv, indices, iunit and iref -! ceq is needed as compopnents can be different in different equilibria ?? -! >>>> unfinished as iunit and iref not really cared for + subroutine list_all_species(unit) implicit none - integer, parameter :: noos=20 - character*4, dimension(noos), parameter :: svid = & - ['T ','P ','MU ','AC ','LNAC','U ','S ','V ',& - 'H ','A ','G ','NP ','BP ','DG ','Q ','N ',& - 'X ','B ','W ','Y '] - character*(*) text - type(gtp_state_variable) :: svr - type(gtp_equilibrium_data), pointer :: ceq + integer unit \end{verbatim} } -\subsubsection{Calculate state variable value}\label{sec:svcalculate} - -This is the subroutine that actually calculates the value of a state -variable. The state variable is indentified using the internal -coding. +\subsubsection{List a little data for all phases} -The subroutine also handle properties used in the parameters, see -\ref{sec:paramid}, to make it possible to obtain the value of such -a propery after an equilibrium calculation. The values of istv etc -must be as returned from decode\_state\_variable, see -\ref{sec:svdecode}. +One line for each phase is listed on device unit for equilibrium ceq. {\small \begin{verbatim} - subroutine state_variable_val(svr,value,ceq) -! calculate the value of a state variable in equilibrium record ceq -! It transforms svr data to old format and calls state_variable_val3 - type(gtp_state_variable), pointer :: svr - double precision value - TYPE(gtp_equilibrium_data), pointer :: ceq - subroutine state_variable_val3(istv,indices,iref,iunit,value,ceq) -! calculate the value of a state variable in equilibrium record ceq -! istv is state variable type (integer) -! indices are possible specifiers -! iref idicates use of possible reference state -! iunit is unit, (K, oC, J, cal etc). For % it is 100 -! value is the calculated values. for state variables with wildcards use -! get_many_svar + subroutine list_all_phases(unit,ceq) +! short list with one line for each phase implicit none - integer, dimension(4) :: indices + integer unit TYPE(gtp_equilibrium_data), pointer :: ceq - integer istv,iref,iunit - double precision value \end{verbatim} } -\subsection{State variable functions} - -This section is separated from the state variables itself to make it a -little simpler. State variable function can contain any combination -of state variables using normal operators like +, -, *, / but also -EXP, LN, LOG10, ERF etc. The PUTFUN subroutine in the METLIB package -is used. No derivatives can be calculated. A state variable function -can refer to another state variable function. +\subsubsection{List global results} -An extention planned but not yet implemented is to allow formal -arguments when defining a state variable function, for example -CP(@P)=HM(@P).T where the formal argument @P means a phase. @S would -stand for a species and @C for a component. When calling the function -an actual argument must be supplied. +This is part of the ``list\_result'' command in the GTP user i/f. -Another extention that has been partially implemented is the ``dot -derivatives'' meaning the drivative of a state variable with respect -to another. This required several changes of the subroutines for -state variable functions and several of them have been moved to the -minimizer package and are described there. +{\small +\begin{verbatim} + subroutine list_global_results(lut,ceq) +! list G, T, P, V and some other things + implicit none + integer lut + TYPE(gtp_equilibrium_data), pointer :: ceq +\end{verbatim} +} -\subsubsection{Enter a state variable function} +\subsubsection{List components result} -The first stubroyine enters a state variable function and the other -stores it in the SVFLISTA array. The old version will eventually -dissapear. +This is part of the ``list\_result'' command in the GTP user i/f. {\small \begin{verbatim} - subroutine enter_svfun(cline,last,ceq) -! enter a state variable function - implicit none - integer last - character cline*(*) - type(gtp_equilibrium_data), pointer :: ceq - subroutine store_putfun(name,lrot,nsymb,iarr) -! enter an expression of state variables with name name with address lrot -! nsymb is number of formal arguments -! iarr identifies these -! idot if derivative - implicit none - character name*(*) - type(putfun_node), pointer :: lrot - integer nsymb,idot - integer iarr(10,*) - subroutine store_putfun_old(name,lrot,nsymb,& - istv,indstv,iref,iunit,idot) -! enter an expression of state variables -! name: character, name of state variable function -! lrot: pointer, to a putfun_node that is the root of the stored expression -! nsymb: integer, number of formal arguments -! istv: integer array, formal argument state variables typ -! indstv: 2D integer array, indices for the formal state variables -! iref: integer array, reference for the formal state variables -! iunit: integer array, unit of the formal state variables + subroutine list_components_result(lut,mode,ceq) +! list one line per component (name, moles, x/w-frac, chem.pot. reference state +! mode 1=mole fractions, 2=mass fractions implicit none - type(putfun_node), pointer :: lrot - integer nsymb - integer, dimension(*) :: istv,iref,iunit,idot - integer, dimension(4,*) :: indstv - character name*(*) + integer lut,mode + TYPE(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } -\subsubsection{List a state variable function} +\subsubsection{List all phases with positive dgm} -These two subroutines can find a state variable function and list its -name in a character respectivly. +This is part of the ``list\_result'' command in the GTP user i/f. If +a phase has positive dgm it should either be dormant or there has been +an error calculating the equilibrium. {\small \begin{verbatim} - subroutine find_svfun(name,lrot,ceq) -! finds a state variable function called name (no abbreviations) - implicit none - character name*(*) - integer lrot - type(gtp_equilibrium_data), pointer :: ceq - subroutine list_svfun(text,ipos,lrot,ceq) -! list a state variable function + subroutine list_phases_with_positive_dgm(mode,lut,ceq) +! list one line for each phase+comp.set with positive dgm on device lut +! The phases must be dormant or the result is in error. mode is not used implicit none - character text*(*) - integer ipos,lrot - type(gtp_equilibrium_data), pointer :: ceq + integer mode,lut + TYPE(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } -\subsubsection{Utility subroutine for state variable functions} +\subsubsection{List results for one phase} -Utility to store state variable identification for a function. +This is part of the ``list\_result'' command in the GTP user i/f. It +lists normally only the stable phases with their amounts and +compositions. With different values of mode units and listing can be +changed. {\small \begin{verbatim} - subroutine make_stvrec(svr,iarr) -! stores appropriate values from a formal argument list to a state variable -! function in a state variable record + subroutine list_phase_results(iph,jcs,mode,lut,ceq) +! list results for a phase+comp.set on lut +! mode specifies the type and amount of results, +! unit digit: 0=mole fraction, othewise mass fractions +! 10th digit: 0=only composition, 10=also constitution +! 100th digit: 0=value order, 100=alphabetical order +! 1000th digit: 0=only stable phases, 1000=all phases implicit none - type(gtp_state_variable), pointer :: svr - integer iarr(10) + integer iph,jcs,mode,lut + TYPE(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } -\subsubsection{List all state variable functions} +\subsubsection{Format output for constitution} -Lists all state variables functions on device kou. +This subroutine formatts the output of composition or constitution in +nice columns trying to use as few lines as possible. {\small \begin{verbatim} - subroutine list_all_svfun(kou,ceq) -! list all state variable funtions + subroutine format_phase_composition(mode,nv,consts,vals,lut) +! list composition/constitution in alphabetical or value order +! entalsiffra 0 mole fraction, 1 mass fraction, 3 mole percent, 4 mass percent +! tiotalsiffra ? +! mode >100 else alphanetical order +! nv is number of components/constitunents (in alphabetical order in consts) +! components/constituents in consts, fractions in vals implicit none - integer kou - type(gtp_equilibrium_data), pointer :: ceq + integer nv,mode,lut + character consts(nv)*(*) + double precision vals(nv) \end{verbatim} } -\subsubsection{Some depreciated routines} +\subsubsection{List data on SCREEN or TDB, LaTeX or macro format} -The double precision function -evaluate\_svfun\_old(lrot,actual\_arg,mode,ceq) is now in the -minimizer package. +This subroutines output all model parameters in different formats. +{\small \begin{verbatim} - subroutine evaluate_all_svfun_old(kou,ceq) -! THIS SUBROUTINE MOVED TO MINIMIZER -! evaluate and list values of all functions - implicit none - integer kou - TYPE(gtp_equilibrium_data), pointer :: ceq - double precision function evaluate_svfun_old(lrot,actual_arg,mode,ceq) -! THIS SUBROUTINE MOVED TO MINIMIZER -! but needed in some cases in this module ... ??? -! envaluate all funtions as they may depend on each other -! actual_arg are names of phases, components or species as @Pi, @Ci and @Si -! needed in some deferred formal parameters (NOT IMPLEMENTED YET) + subroutine list_many_formats(ftyp,unit) +! lists all data in different formats +! unfinished implicit none - integer lrot,mode - character actual_arg(*)*(*) - TYPE(gtp_equilibrium_data), pointer :: ceq + integer unit,ftyp \end{verbatim} +} -\subsection{Interactive things} - -The current user interface to OC and GTP is command oriented and there -are subroutines provided in GTP to enter, set, list and get many -things. Most subroutines where the user is expected to provide -information is collected in this section. - -\subsubsection{Ask for phase constitution} +\subsubsection{List some phase model stuff} -The used can provide the default constitution or enter a constitution -specificly for a phase and composition set. +This is probably redundant but can be used to check the conversion from +site fractions to disordered fractions for phases with several +fraction sets. {\small \begin{verbatim} - subroutine ask_phase_constitution(cline,last,iph,ics,lokcs,ceq) -! interactive input constitution of phase iph + subroutine list_phase_model(iph,ics,lut,ceq) +! list model (no parameters) for a phase on lut implicit none - integer last,iph,ics,lokcs - character cline*(*) + integer iph,ics,lut + TYPE(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } -\subsubsection{Ask for parameter}\label{sec:enterparinter} +\subsubsection{List all parameter data for a phase} -The user can enter a model parameter with this subroutine. +This is the big listing of the model and data for a phase. It lists +the sublattices, sites, constituents. Then all endmembers and +all interaction parameters. + +The second version is suitable for TDB files. {\small \begin{verbatim} - subroutine enter_parameter_interactivly(cline,ip) -! enter a parameter from terminal or macro -! NOTE both for ordered and disordered fraction set !! + subroutine list_phase_data(iph,lut) +! list parameter data for a phase on unit lut implicit none - integer ip - character cline*(*) + integer iph,lut + subroutine list_phase_data2(iph,lut) +! list parameter data for a phase on unit lut in TDB format + implicit none + integer iph,lut \end{verbatim} } -\subsubsection{Amend global bits} +\subsubsection{Format expression of references for endmembers} -There are a number of global bits that can be set by this subroutine. +When listing an endmember parameter for the Gibbs energy this +subroutine subtracts the H298 expression. {\small \begin{verbatim} - subroutine amend_global_data(cline,ipos) + subroutine subrefstates(funexpr,jp,lokph,parlist,endm,noelin1) +! list a sum of reference states for a G parameter +! like "-H298(BCC_A2,FE)-3*H298(GRAPITE,C)" implicit none - character cline*(*) - integer ipos + integer jp,lokph,parlist,endm(*) + character funexpr*(*) + logical noelin1 \end{verbatim} } -\subsubsection{Ask for reference of parameter data} +\subsubsection{Encode stoichiometry of species} -Each parameter in a model can have a data reference, preferably a -published paper. When a parameters is entered by calling -enter\_parameter\_interactivly the refernce is asked for but with this -routine it is possible to enter such a reference separately. +This subroutine generate a stoichiometric formula for a species +including a charge. {\small \begin{verbatim} - subroutine enter_reference_interactivly(cline,last,mode,iref) -! enter a reference for a parameter interactivly -! this should be modified to allow amending an existing reference + subroutine encode_stoik(text,ipos,spno) +! generate a stoichiometric formula of species from element list implicit none - character cline*(*) - integer last,mode,iref + integer ipos,spno + character text*(*) \end{verbatim} } -\subsubsection{Set a condition}\label{sec:setcondition} +\subsubsection{Decode stoichiometry of species} -This is the central routine to set a condition for an equilibrium -calculation. Anther alternative is the set\_input\_amount. When -setting the status of a phase as fixed this subroutine is called -automatically to add this as condition. +This subroutine can translate a stoichiometric formula to elements and +stoichimetric factors including a charge. {\small \begin{verbatim} - subroutine set_condition(cline,ip,ceq) -! decode an equilibrium condition, can be an expression with + and - + subroutine decode_stoik(name,noelx,elsyms,stoik) +! decode a species stoichiometry in name to element index and stoichiometry +! all in upper case + implicit none + character name*(*),elsyms(*)*2 + double precision stoik(*) + integer noelx +\end{verbatim} +} + +\subsubsection{Encode constituent array for parameters} + +This subroutine generates a constituent array for a parameter. +Constituents are species. Constituents in different sublattices are +separated by ``:'', interacting constituents in same sublattice are +separated by ``,''. The degree is written after a ``;''. + +{\small +\begin{verbatim} + subroutine encode_constarr(constarr,nsl,endm,nint,lint,ideg) +! creates a constituent array + implicit none + character constarr*(*) + integer, dimension(*) :: endm + integer nsl,nint,ideg + integer, dimension(2,*) :: lint +\end{verbatim} +} + +\subsubsection{Decode constituent array for parameters} + +By providing the indices of constituent in the endmember and possible +interaction constituents and the degree a text with the constitent +array is generated. + +{\small +\begin{verbatim} + subroutine decode_constarr(lokph,constarr,nsl,endm,nint,lint,ideg) +! deconde a text string with a constituent array +! a constituent array has separated by , or : and ; before degree + implicit none + character constarr*(*) + integer endm(*),lint(2,*) + integer nsl,nint,ideg,lokph,lord +\end{verbatim} +} + +\subsubsection{List parameter data references} + +This subroutine lists the bibliographic references for the parameters. + +{\small +\begin{verbatim} +! changed from list_references(lut) + subroutine list_bibliography(lut) +! list bibliographic references + implicit none + integer lut +\end{verbatim} +} + +\subsubsection{List conditions on a file or screen} + +The heading says all. + +{\small +\begin{verbatim} + subroutine list_conditions(lut,ceq) +! lists conditions on lut + implicit none + integer lut + type(gtp_equilibrium_data), pointer :: ceq +\end{verbatim} +} + +\subsubsection{Extract one conditions in a character veriable} + +A single condition is written in a character variable + +{\small +\begin{verbatim} + subroutine get_one_condition(ip,text,seqz,ceq) +! list the condition with the index seqz into text +! It lists also fix phases and conditions that are not active + implicit none + integer ip,seqz + character text*(*) + TYPE(gtp_equilibrium_data), pointer :: ceq +\end{verbatim} +} + +\subsubsection{List condition in character variable} + +All current active conditions in equilibrium ceq is written to the +character variable text. This can be written on the screen or used +for other purposes. It can also be used for experiments (not +implemented yet). + +{\small +\begin{verbatim} + subroutine get_all_conditions(text,mode,ceq) +! list all conditions if mode=0, experiments if mode=1 + implicit none + integer mode + character text*(*) + TYPE(gtp_equilibrium_data), pointer :: ceq +\end{verbatim} +} + +\subsubsection{List available parameter identifiers}\label{sec:listavailprop} + +The GTP package allows definition of new properties that can be +modelled as dependent on the constitution of each phase. Such +properties must be defined in the software and they can be listed with +this subroutine. Many additions depend on such parameter properties +like the Curie temperature and the Debye temperature. + +On can also add properties that does not affect the Gibbs energy but +which depend on the constitution of the phase like the mobility, +resistivity, lattice parameter etc. + +{\small +\begin{verbatim} + subroutine list_defined_properties(lut) +! lists all parameter identifiers allowed + implicit none + integer lut +\end{verbatim} +} + +\subsubsection{Find defined properties}\label{sec:listpropval} + +Although properties like TC (Curie temperature) and BMAG (Average Bohr +magneton number) are not state variables they can be listed using the +command LIST STATE\_VARIABLEs and their values can be obtained by the +same subroutines that are used for state variables like +get\_state\_variable. They use the following subroutine to find +the properties defined in the gtp\_propid structure. + +{\small +\begin{verbatim} + subroutine find_defined_property(symbol,mode,typty,iph,ics) +! searches the propid list for one with symbol or identifiction typty +! if mode=0 then symbol given, if mode=1 then typty given +! symbol can be TC(BCC), BM(FCC), MQ&FE(HCP) etc, the phase must be +! given in symbol as otherwise it is impossible to find the consititent!!! +! A constituent may have a sublattice specifier, MQ&FE#3(SIGMA) + implicit none + integer mode,typty,iph,ics + character symbol*(*) +\end{verbatim} +} + +\subsubsection{List some odd details} + +{\small +\begin{verbatim} + subroutine list_equilibria_details(mode,teq) + implicit none + TYPE(gtp_equilibrium_data), pointer :: teq + integer mode +\end{verbatim} +} + +%!> here starts gtp3D.F90 -------------------------------------------- + +\subsection{Interactive subroutines} + +The current user interface to OC and GTP is command oriented and there +are subroutines provided in GTP to enter, set, list and get many +things. Most subroutines where the user is expected to provide +information is collected in this section. + +\subsubsection{Ask for phase constitution} + +The used can provide the default constitution or enter a constitution +specificly for a phase and composition set. + +{\small +\begin{verbatim} + subroutine ask_phase_constitution(cline,last,iph,ics,lokcs,ceq) +! interactive input constitution of phase iph + implicit none + integer last,iph,ics,lokcs + character cline*(*) +\end{verbatim} +} + +\subsubsection{Ask for parameter}\label{sec:enterparinter} + +The user can enter a model parameter with this subroutine. + +{\small +\begin{verbatim} + subroutine enter_parameter_interactivly(cline,ip) +! enter a parameter from terminal or macro +! NOTE both for ordered and disordered fraction set !! + implicit none + integer ip + character cline*(*) +\end{verbatim} +} + +\subsubsection{Amend global bits} + +There are a number of global bits that can be set by this subroutine. + +{\small +\begin{verbatim} + subroutine amend_global_data(cline,ipos) + implicit none + character cline*(*) + integer ipos +\end{verbatim} +} + +\subsubsection{Ask for reference of parameter data} + +Each parameter in a model can have a data reference, preferably a +published paper. When a parameters is entered by calling +enter\_parameter\_interactivly the refernce is asked for but with this +routine it is possible to enter such a reference separately. + +{\small +\begin{verbatim} + subroutine enter_reference_interactivly(cline,last,mode,iref) +! enter a reference for a parameter interactivly +! this should be modified to allow amending an existing reference + implicit none + character cline*(*) + integer last,mode,iref +\end{verbatim} +} + +\subsubsection{Set a condition}\label{sec:setcondition} + +This is the central routine to set a condition for an equilibrium +calculation. Anther alternative is the set\_input\_amount. When +setting the status of a phase as fixed this subroutine is called +automatically to add this as condition. + +{\small +\begin{verbatim} + subroutine set_condition(cline,ip,ceq) +! decode an equilibrium condition, can be an expression with + and - ! the expression should be terminated with an = or value supplied on next line ! like "T=1000", "x(liq,s)-x(pyrrh,s)=0", "2*mu(cr)-3*mu(o)=muval" ! It can also be a "NOFIX=" or "FIX= value" @@ -3777,6 +3968,7 @@ \subsubsection{Get condition record} \begin{verbatim} subroutine get_condition(nterm,svr,pcond) ! finds a condition record with the given state variable expression +! If nterm<0 the absolute value of nterm is condition number, svr is irrelevant implicit none integer nterm type(gtp_state_variable), pointer :: svr @@ -3840,7 +4032,7 @@ \subsubsection{A utility routine to get the current value of a condition} \begin{verbatim} subroutine apply_condition_value(current,what,value,cmix,ceq) ! This is called when calculating an equilibrium. -! It returns a condition at each call, at first call current must be nullified +! It returns a condition at each call, at first call current must be nullified? ! When all conditions done the current is nullified again ! If what=-1 then return degrees of freedoms and maybe something more ! what=0 means calculate current values of conditions @@ -3941,1161 +4133,793 @@ \subsubsection{Utility to decode a parameter identifier} \end{verbatim} } -%%%%%%%%%%%%% here starts pmod25E.F90 - -\subsection{List things} +%!> here starts gtp3E.F90 -------------------------------------------- -The routines in this section are intended for the line oriented user -interface of GTP. It lists data assuming 80 column width of the -screen. In some cases a character variable is retured but in most -case the list unit is provided in the call. This can be the screen, -a file or a device. +\subsection{Save and read data from files} -Some listings are described in connection with the objects that are -listed, see \ref{sec:listadditions}. +Most of the subroutines in this section are unfinished. The only +thing that can be read is a simple TDB file. -\subsubsection{List data for all elements} - -The element data is listed. Second version for TDB files. +The problem is that whenever a change is made in the data structure +these routines must be modified accordingly. And the data structure +is still undergoing big changes. -{\small -\begin{verbatim} - subroutine list_all_elements(unit) -! lists elements - implicit none - integer unit - subroutine list_all_elements2(unit) -! lists elements - implicit none - integer unit -\end{verbatim} -} +These subroutines are in total disorder -\subsubsection{List data for all components} +\subsubsection{Save all data} -The components may be different in each equilibrium. +Not implemented yet. {\small \begin{verbatim} - subroutine list_all_components(unit,ceq) -! lists the components for an equilibrium + subroutine gtpsave(filename,str) +! save all data on file, unformatted, TDB or macro +! header +! element list +! species list +! phase list with sublattices, endmembers, interactions and parameters etc +! tpfuns +! state variable functions +! references +! implicit none - integer unit - TYPE(gtp_equilibrium_data), pointer :: ceq + character*(*) filename,str \end{verbatim} } -\subsubsection{List data for one element} - -The data for element ``elno'' in written to the character variable text from -position ipos. +\subsubsection{Save all data again} {\small \begin{verbatim} - subroutine list_element_data(text,ipos,elno) + subroutine gtpsaveu(filename,specification) +! save all data unformatted on an file +! header +! element list +! species list +! phase list with sublattices, endmembers, interactions and parameters etc +! tpfuns +! state variable functions +! references +! equilibrium record(s) with conditions, componenets, phase_varres records etc +! anything else? implicit none - character text*(*) - integer ipos,elno + character*(*) filename,specification \end{verbatim} } -\subsubsection{List data for one species} +\subsubsection{Save data for a phase} -The data for species ``spno'' in written to the character variable text from -position ipos. The second version is suitable for TDB files. +The title says all {\small \begin{verbatim} - subroutine list_species_data(text,ipos,spno) - implicit none - character text*(*) - integer ipos,spno - subroutine list_species_data2(text,ipos,spno) + subroutine savephase(lut,lokph) +! save data for phase at location lokph (except data in the equilibrium record) +! For phases with disordered set of parameters we must access the number of +! sublattices via firsteq implicit none - character text*(*) - integer ipos,spno + integer lut,lokph \end{verbatim} } -\subsubsection{List data for all species} +\subsubsection{Save data for an equilibrium record} -One line for each species is listed on device unit. +The titile says all {\small \begin{verbatim} - subroutine list_all_species(unit) + subroutine saveequil(lut,ceq) +! save data for an equilibrium record implicit none - integer unit + integer lut + type(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } -\subsubsection{List a little data for all phases} - -One line for each phase is listed on device unit for equilibrium ceq. +\subsubsection{Save the state variable functions on file} {\small \begin{verbatim} - subroutine list_all_phases(unit,ceq) -! list one line for each phase + subroutine svfunsave(lut,ceq) +! saves all state variable functions on a file implicit none - integer unit - TYPE(gtp_equilibrium_data), pointer :: ceq + integer lut + type(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } -\subsubsection{List global results} - -This is part of the ``list\_result'' command in the GTP user i/f. +\subsubsection{Save the bibliographic references on file} {\small \begin{verbatim} - subroutine list_global_results(lut,ceq) -! list G, T, P, V and some other things + subroutine bibliosave(lut) +! saves references on a file implicit none integer lut - TYPE(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } -\subsubsection{List components result} +\subsubsection{Read data from a saved file} -This is part of the ``list\_result'' command in the GTP user i/f. +Not implemented yet. {\small \begin{verbatim} - subroutine list_components_result(lut,mode,ceq) -! list one line per component (name, fraction, x/w, chem.pot. reference state -! mode 1=mole fractions, 2=mass fractions + subroutine gtpread(filename,str) +! read unformatted all data in the following order +! header +! element list +! species list +! phase list with sublattices, endmembers, interactions and parameters etc +! tpfuns +! state variable functions +! references +! equilibrium record(s) with conditions, componenets, phase_varres records etc +! implicit none - integer lut,mode - TYPE(gtp_equilibrium_data), pointer :: ceq + character*(*) filename,str \end{verbatim} } -\subsubsection{List all phases with positive dgm} - -This is part of the ``list\_result'' command in the GTP user i/f. If -a phase has positive dgm it should either be dormant or there has been -an error calculating the equilibrium. +\subsubsection{Reading unformatted data for a phase} {\small \begin{verbatim} - subroutine list_phases_with_positive_dgm(mode,lut,ceq) -! list one line for each phase+comp.set with positive dgm on device lut -! The phases must be dormant or the result is in error. mode is not used + subroutine readphase(lin,jdum) +! read data for phlista and all endmembers etc +! works for test case without disordered fraction test implicit none - integer mode,lut - TYPE(gtp_equilibrium_data), pointer :: ceq + integer lin,jdum \end{verbatim} } -\subsubsection{List results for one phase} - -This is part of the ``list\_result'' command in the GTP user i/f. It -lists normally only the stable phases with their amounts and -compositions. With different values of mode units and listing can be -changed. +\subsubsection{Read unformatted data for an endmember} {\small \begin{verbatim} - subroutine list_phase_results(iph,jcs,mode,lut,ceq) -! list results for a phase+comp.set on lut -! mode specifies the type and amount of results, -! unit digit: 0=mole fraction, othewise mass fractions -! 10th digit: 0=only composition, 10=also constitution -! 100th digit: 0=value order, 100=alphabetical order -! 1000th digit: 0=only stable phases, 1000=all phases + subroutine readendmem(lin,nsl,emrec,nop,noi,nem) +! allocates and reads an endmember record implicit none - integer iph,jcs,mode,lut - TYPE(gtp_equilibrium_data), pointer :: ceq + integer lin,nsl,nop,noi,nem + type(gtp_endmember), pointer :: emrec \end{verbatim} } -\subsubsection{Format output for constitution} - -This subroutine formatts the output of composition or constitution in -nice columns trying to use as few lines as possible. +\subsubsection{Read unformatted data for a property} {\small \begin{verbatim} - subroutine format_phase_composition(mode,nv,consts,vals,lut) -! list composition/constitution in alphabetical or value order -! entalsiffra 0 mole fraction, 1 mass fraction, 3 mole percent, 4 mass percent -! tiotalsiffra ? -! mode >100 else alphanetical order -! nv is number of components/constitunents (in alphabetical order in consts) -! components/constituents in consts, fractions in vals + subroutine readproprec(lin,proprec,nox) +! allocates and reads a property record implicit none - integer nv,mode,lut - character consts(nv)*(*) - double precision vals(nv) + integer lin,nox + type(gtp_property), pointer :: proprec \end{verbatim} } -\subsubsection{List data on SCREEN or TDB, LaTeX or macro format} - -This subroutines output all model parameters in different formats. +\subsubsection{Read unformatted data for an interaction} {\small \begin{verbatim} - subroutine list_many_formats(ftyp,unit) -! lists all data in different formats -! unfinished + subroutine readintrec(lin,intrec,mult,noi,nup,nop) +! allocates and reads an interaction record UNFINISHED implicit none - integer unit,ftyp + integer lin,mult,noi,nup,nop + type(gtp_interaction), pointer :: intrec \end{verbatim} } -\subsubsection{List some phase model stuff} - -This is probably redundant but can be used to check the conversion from -site fractions to disordered fractions for phases with several -fraction sets. +\subsubsection{Read unformatted data for an equilibrium} {\small \begin{verbatim} - subroutine list_phase_model(iph,ics,lut,ceq) -! list model (no parameters) for a phase on lut + subroutine readequil(lin,ceq) +! Read equilibria records from a file implicit none - integer iph,ics,lut - TYPE(gtp_equilibrium_data), pointer :: ceq + integer lin + type(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } -\subsubsection{List all parameter data for a phase} - -This is the big listing of the model and data for a phase. It lists -the sublattices, sites, constituents. Then all endmembers and -all interaction parameters. - -The second version is suitable for TDB files. +\subsubsection{Read state variable functions} {\small \begin{verbatim} - subroutine list_phase_data(iph,lut) -! list parameter data for a phase on unit lut - implicit none - integer iph,lut - subroutine list_phase_data2(iph,lut) -! list parameter data for a phase on unit lut in TDB format + subroutine svfunread(lin) +! read a state variable function from save file and store it. +! by default there are some state variable functions, make sure +! they are deleted. Done here just by setting nsvfun=0 implicit none - integer iph,lut + integer lin \end{verbatim} } -\subsubsection{Format expression of references for endmembers} - -When listing an endmember parameter for the Gibbs energy this -subroutine subtracts the H298 expression. +\subsubsection{Read reference records} {\small \begin{verbatim} - subroutine subrefstates(funexpr,jp,lokph,parlist,endm,noelin1) -! list a sum of reference states for a G parameter -! like "-H298(BCC_A2,FE)-3*H298(GRAPITE,C)" + subroutine biblioread(lin) +! read references from save file implicit none - integer jp,lokph,parlist,endm(*) - character funexpr*(*) - logical noelin1 + integer lin \end{verbatim} } -\subsubsection{Encode stoichiometry of species} +\subsubsection{Erase all data} -This subroutine generate a stoichiometric formula for a species -including a charge. +This is necessary before reading a new saved file. Not implemented yet. {\small \begin{verbatim} - subroutine encode_stoik(text,ipos,spno) -! generate a stoichiometric formula of species from element list + subroutine new_gtp +! +! DELETES ALL DATA so a new TDB file can be read +! +! this is needed before reading a new unformatted file (or same file again) +! we must go through all records and delete and deallocate each +! separately. Very similar to gtpread implicit none - integer ipos,spno - character text*(*) \end{verbatim} } -\subsubsection{Decode stoichiometry of species} - -This subroutine can translate a stoichiometric formula to elements and -stoichimetric factors including a charge. +\subsubsection{Delete a phase} {\small \begin{verbatim} - subroutine decode_stoik(name,noelx,elsyms,stoik) -! decode a species stoichiometry in name to element index and stoichiometry -! all in upper case + subroutine delphase(lokph) +! save data for phase at location lokph (except data in the equilibrium record) +! For phases with disordered set of parameters we must access the number of +! sublattices via firsteq implicit none - character name*(*),elsyms(*)*2 - double precision stoik(*) - integer noelx + integer lokph \end{verbatim} } -\subsubsection{Encode constituent array for parameters} - -This subroutine generates a constituent array for a parameter. -Constituents are species. Constituents in different sublattices are -separated by ``:'', interacting constituents in same sublattice are -separated by ``,''. The degree is written after a ``;''. +\subsubsection{Yet another utility routine} {\small \begin{verbatim} - subroutine encode_constarr(constarr,nsl,endm,nint,lint,ideg) -! creates a constituent array + logical function iskeyword(text,keyword,nextc) +! compare a text with a given keyword. Abbreviations allowed +! but the keyword and abbreviation must be surrounded by spaces +! nextc set to space character in text after the (abbreviated) keyword implicit none - character constarr*(*) - integer, dimension(*) :: endm - integer nsl,nint,ideg - integer, dimension(2,*) :: lint + character text*(*),keyword*(*),key*64 + integer nextc \end{verbatim} } -\subsubsection{Decode constituent array for parameters} - -By providing the indices of constituent in the endmember and possible -interaction constituents and the degree a text with the constitent -array is generated. +\subsubsection{And another utility routine} {\small \begin{verbatim} - subroutine decode_constarr(lokph,constarr,nsl,endm,nint,lint,ideg) -! deconde a text string with a constituent array -! a constituent array has separated by , or : and ; before degree + integer function istdbkeyword(text,nextc) +! compare a text with a given keyword. Abbreviations allowed (not within _) +! but the keyword and abbreviation must be surrounded by spaces +! nextc set to space character in text after the (abbreviated) keyword implicit none - character constarr*(*) - integer endm(*),lint(2,*) - integer nsl,nint,ideg,lokph,lord + character text*(*) + integer nextc \end{verbatim} } -\subsubsection{List parameter data references} +\subsubsection{Read a TDB file} -This subroutine lists the bibliographic references for the parameters. +This subroutine can read a TDB file that is not too fancily edited +manually. Best is to read as written from Thermo-Calc. Some +TYPE\_DEFINITIONS are not handelled, especially the DISORDERED\_PART as +this has been implemented differently in GTP. {\small \begin{verbatim} -! changed from list_references(lut) - subroutine list_bibliography(lut) -! list bibliographic references + subroutine readtdb(filename,nel,selel) +! reading data from a TDB file with selection of elements +!------------------------------------------------------- +! Not all TYPE_DEFS implemented +!------------------------------------------------------- implicit none - integer lut + integer nel + character filename*(*),selel(*)*2 \end{verbatim} } -\subsubsection{List conditions on a file or screen} +\subsubsection{Check a TDB file exists and extract elements} -The heading says all. +This is used to check a user typed a correct TDB file name and +extracts the elements so the user can select which he wants. -{\small \begin{verbatim} - subroutine list_conditions(lut,ceq) -! lists conditions on lut + subroutine checktdb(filename,nel,selel) +! checking a TDB file exists and return the elements implicit none - integer lut - type(gtp_equilibrium_data), pointer :: ceq + integer nel + character filename*(*),selel(*)*2 \end{verbatim} -} -\subsubsection{Extract one conditions in a character veriable} +%!> here starts gtp3F.F90 ------------------------------------------------- -A single condition is written in a character variable +\subsection{State variable stuff} + +State variables are important for the setting and extracting results +of a calculation. State variables are treated very similarly to +Thermo-Calc using symbols like $T, ~P, ~N,$ $x({\rm )$ +etc. + +The internal syntax of state variables is rather complicated, perhaps +it should be revised and defined as a structure? If there are errors +or one wants to make modifications it is not easy. + +Things like Curie temperature, Debye temperature, mobilities etc are +alse defined as ``state variables'' altough one cannot use them in +conditions. Adding more things like elastic constants will be a +bit complicated. + +The subroutines for manipulations is also a bit complicated and could +do with a clean up and renaming. + +\subsubsection{Get state variable value given its symbol} + +By providing a state variable as a character variable like $T$ or +$x({\rm liquid,cr})$ this routine returns its current value. +Wildcards, ``*'', are not allowed, see \ref{sec:getmany}. {\small \begin{verbatim} - subroutine get_one_condition(ip,text,seqz,ceq) -! list the condition with the index seqz into text -! It lists also fix phases and conditions that are not active + subroutine get_state_var_value(statevar,value,encoded,ceq) +! called with a state variable character implicit none - integer ip,seqz - character text*(*) TYPE(gtp_equilibrium_data), pointer :: ceq + character statevar*(*),encoded*(*) + double precision value \end{verbatim} } -\subsubsection{List condition in character variable} +\subsubsection{Get many state variable values}\label{sec:getmany} -All current active conditions in equilibrium ceq is written to the -character variable text. This can be written on the screen or used -for other purposes. It can also be used for experiments (not -implemented yet). +This routine can be called with wildcard, ``*'', as argument in state +variables like $NP(*), ~x(*,CR)$ etc. It is fragile and currently +only available when defining plot axis. {\small \begin{verbatim} - subroutine get_all_conditions(text,mode,ceq) -! list all conditions if mode=0, experiments if mode=1 + subroutine get_many_svar(statevar,values,mjj,kjj,encoded,ceq) +! called with a state variable name with woldcards allowed like NP(*), X(*,CR) +! mjj is dimension of values, kjj is number of values returned +! encoded used to specify if phase data in phasetuple order ('Z') +! >>>> BIG problem: How to do with phases that are note stable? +! If I ask for w(*,Cr) I only want the fraction in stable phases +! but whenthis is used for GNUPLOT the values are written in a matix +! and the same column in that phase must be the same phase ... +! so I have to have the same number of phases from each equilibria. +! implicit none - integer mode - character text*(*) TYPE(gtp_equilibrium_data), pointer :: ceq + character statevar*(*),encoded*(*) + double precision values(*) + integer mjj,kjj \end{verbatim} } -\subsubsection{List available parameter identifiers}\label{sec:listavailprop} +\subsubsection{Decode a state variable symbol}\label{sec:svdecode} -The GTP package allows definition of new properties that can be -modelled as dependent on the constitution of each phase. Such -properties must be defined in the software and they can be listed with -this subroutine. Many additions depend on such parameter properties -like the Curie temperature and the Debye temperature. +This subroutine takes as input a character with a state variable and +returns a state variable record with its specification. It can also +handle decoding of property parameters symbols like the Curie +temeprature. The main routine calls the older version of this +subroutine with a more complex handling of state variables. This +second subroutine will eventually dissappear and should not be used. -On can also add properties that does not affect the Gibbs energy but -which depend on the constitution of the phase like the mobility, -resistivity, lattice parameter etc. +The new version of this subroutine calls the old but this will be +removed in a future release. If there are any changes in the state +variables struvture several subroutines must be changed like this one, +\ref{sec:svencode} and \ref{sec:svcalculate}. + +The subroutine also handle property symbols used in the parameters, +see \ref{sec:paramid}, to make it possible to obtain the value of such +a propery after an equilibrium calculation. The value returned in +svr%statev or istv for such properties is the negative of the property +index. {\small \begin{verbatim} - subroutine list_defined_properties(lut) -! lists all parameter identifiers allowed + subroutine decode_state_variable(statevar,svr,ceq) +! converts a state variable character to state variable record + character statevar*(*) + type(gtp_state_variable), pointer :: svr + type(gtp_equilibrium_data), pointer :: ceq +! this subroutine using state variable records is a front end of the next: + subroutine decode_state_variable3(statevar,istv,indices,iref,iunit,svr,ceq) +! converts an old state variable character to indices +! Typically: T, x(fe), x(fcc,fe), np(fcc), y(fcc,c#2), ac(h2,bcc), ac(fe) +! NOTE! model properties like TC(FCC),MQ&FE(FCC,CR) must be detected +! NOTE: added storing information in a gtp_state_variable record svrec !! +! +! this routine became as messy as I tried to avoid +! but I leave it to someone else to clean it up ... +! +! state variable and indices +! Symbol no index1 index2 index3 index4 +! T 1 - +! P 2 - +! MU 3 component or phase,constituent +! AC 4 component or phase,constituent +! LNAC 5 component or phase,constituent +! index (in svid array) +! U 10 (phase#set) 6 Internal energy (J) +! UM 11 " 6 per mole components +! UW 12 " 6 per kg +! UV 13 " 6 per m3 +! UF 14 " 6 per formula unit +! S 2x " 7 entropy +! V 3x " 8 volume +! H 4x " 9 enthalpy +! A 5x " 10 Helmholtz energy +! G 6x " 11 Gibbs energy +! NP 7x " 12 moles of phase +! BP 8x " 13 mass of moles +! DG 9x " 15 Driving force +! Q 10x " 14 Internal stability +! N 11x (component/phase#set,component) 16 moles of components +! X 111 " 17 mole fraction of components +! B 12x " 18 mass of components +! W 122 " 19 mass fraction of components +! Y 13 phase#set,constituent#subl 20 constituent fraction +!----- model variables <<<< these now treated differently +! TC - phase#set - Magnetic ordering T +! BMAG - phase#set - Aver. Bohr magneton number +! MQ& - element, phase#set - Mobility +! THET - phase#set - Debye temperature +! implicit none - integer lut + integer, parameter :: noos=20 + character*4, dimension(noos), parameter :: svid = & + ['T ','P ','MU ','AC ','LNAC','U ','S ','V ',& + 'H ','A ','G ','NP ','BP ','DG ','Q ','N ',& + 'X ','B ','W ','Y '] +! 1 2 3 4 4 6 7 8 + character statevar*(*) + integer istv,iref,iunit + integer, dimension(4) :: indices + type(gtp_equilibrium_data), pointer :: ceq +! I shall try to use this record type instead of separate arguments: !! +! type(gtp_state_variable), pointer :: svrec + type(gtp_state_variable), pointer :: svr \end{verbatim} } -\subsubsection{Find defined properties}\label{sec:listpropval} +\subsubsection{Calculate molar and mass properties for a phase}\label{sec:mmph} -Although properties like TC (Curie temperature) and BMAG (Average Bohr -magneton number) are not state variables they can be listed using the -command LIST STATE\_VARIABLEs and their values can be obtained by the -same subroutines that are used for state variables like -get\_state\_variable. They use the following subroutine to find -the properties defined in the gtp\_propid structure. +This subroutine calculates mole and massfractions of all components +for a phase (mole fractions of components not dissolved is zero). It +also returns the total number of moles of compoinets and the mass. In +amount the number of moles per formula unit is returned (same as qq(1) +in get\_phase\_data and set\_constitution). {\small \begin{verbatim} - subroutine find_defined_property(symbol,mode,typty,iph,ics) -! searches the propid list for one with symbol or identifiction typty -! if mode=0 then symbol given, if mode=1 then typty given -! symbol can be TC(BCC), BM(FCC), MQ&FE(HCP) etc, the phase must be -! given in symbol as otherwise it is impossible to find the consititent!!! -! A constituent may have a sublattice specifier, MQ&FE#3(SIGMA) + subroutine calc_phase_molmass(iph,ics,xmol,wmass,totmol,totmass,amount,ceq) +! calculates mole fractions and mass fractions for a phase#set +! xmol and wmass are fractions of components in mol or mass +! totmol is total number of moles and totmass total mass of components. +! amount is number of moles of components per formula unit. implicit none - integer mode,typty,iph,ics - character symbol*(*) + TYPE(gtp_equilibrium_data) :: ceq + integer iph,ics + double precision, dimension(*) :: xmol,wmass + double precision amount,totmol,totmass \end{verbatim} } -\subsubsection{List some odd details} - -{\small -\begin{verbatim} - subroutine list_equilibria_details(mode,teq) - implicit none - TYPE(gtp_equilibrium_data), pointer :: teq - integer mode -\end{verbatim} -} - -%%%%%%%%%%%%%%%%% here starts pmod25F.F90 - -\subsection{Save and read data from files} - -Most of the subroutines in this section are unfinished. The only -thing that can be read is a simple TDB file. - -The problem is that whenever a change is made in the data structure -these routines must be modified accordingly. And the data structure -is still undergoing big changes. - -These subroutines are in total disorder - -\subsubsection{Save all data} - -Not implemented yet. - -{\small -\begin{verbatim} - subroutine gtpsave(filename,str) -! save all data on file, unformatted, TDB or macro -! header -! element list -! species list -! phase list with sublattices, endmembers, interactions and parameters etc -! tpfuns -! state variable functions -! references -! - implicit none - character*(*) filename,str -\end{verbatim} -} - -\subsubsection{Save all data again} - -{\small -\begin{verbatim} - subroutine gtpsaveu(filename,specification) -! save all data unformatted on an file -! header -! element list -! species list -! phase list with sublattices, endmembers, interactions and parameters etc -! tpfuns -! state variable functions -! references -! equilibrium record(s) with conditions, componenets, phase_varres records etc -! anything else? - implicit none - character*(*) filename,specification -\end{verbatim} -} - -\subsubsection{Save data for a phase} - -The title says all - -{\small -\begin{verbatim} - subroutine savephase(lut,lokph) -! save data for phase at location lokph (except data in the equilibrium record) -! For phases with disordered set of parameters we must access the number of -! sublattices via firsteq - implicit none - integer lut,lokph -\end{verbatim} -} - -\subsubsection{Save data for an equilibrium record} - -The titile says all - -{\small -\begin{verbatim} - subroutine saveequil(lut,ceq) -! save data for an equilibrium record - implicit none - integer lut - type(gtp_equilibrium_data), pointer :: ceq -\end{verbatim} -} - -\subsubsection{Save the state variable functions on file} - -{\small -\begin{verbatim} - subroutine svfunsave(lut,ceq) -! saves all state variable functions on a file - implicit none - integer lut - type(gtp_equilibrium_data), pointer :: ceq -\end{verbatim} -} - -\subsubsection{Save the bibliographic references on file} - -{\small -\begin{verbatim} - subroutine bibliosave(lut) -! saves references on a file - implicit none - integer lut -\end{verbatim} -} - -\subsubsection{Read data from a saved file} - -Not implemented yet. - -{\small -\begin{verbatim} - subroutine gtpread(filename,str) -! read unformatted all data in the following order -! header -! element list -! species list -! phase list with sublattices, endmembers, interactions and parameters etc -! tpfuns -! state variable functions -! references -! equilibrium record(s) with conditions, componenets, phase_varres records etc -! - implicit none - character*(*) filename,str -\end{verbatim} -} - -\subsubsection{Reading unformatted data for a phase} - -{\small -\begin{verbatim} - subroutine readphase(lin,jdum) -! read data for phlista and all endmembers etc -! works for test case without disordered fraction test - implicit none - integer lin,jdum -\end{verbatim} -} - -\subsubsection{Read unformatted data for an endmember} - -{\small -\begin{verbatim} - subroutine readendmem(lin,nsl,emrec,nop,noi,nem) -! allocates and reads an endmember record - implicit none - integer lin,nsl,nop,noi,nem - type(gtp_endmember), pointer :: emrec -\end{verbatim} -} - -\subsubsection{Read unformatted data for a property} - -{\small -\begin{verbatim} - subroutine readproprec(lin,proprec,nox) -! allocates and reads a property record - implicit none - integer lin,nox - type(gtp_property), pointer :: proprec -\end{verbatim} -} - -\subsubsection{Read unformatted data for an interaction} - -{\small -\begin{verbatim} - subroutine readintrec(lin,intrec,mult,noi,nup,nop) -! allocates and reads an interaction record UNFINISHED - integer none - integer lin,mult,noi,nup,nop - type(gtp_interaction), pointer :: intrec -\end{verbatim} -} - -\subsubsection{Read unformatted data for an equilibrium} - -{\small -\begin{verbatim} - subroutine readequil(lin,ceq) -! Read equilibria records from a file - implicit none - integer lin - type(gtp_equilibrium_data), pointer :: ceq -\end{verbatim} -} - -\subsubsection{Read state variable functions} - -{\small -\begin{verbatim} - subroutine svfunread(lin) -! read a state variable function from save file and store it. -! by default there are some state variable functions, make sure -! they are deleted. Done here just by setting nsvfun=0 - implicit none - integer lin -\end{verbatim} -} - -\subsubsection{Read reference records} - -{\small -\begin{verbatim} - subroutine biblioread(lin) -! read references from save file - implicit none - integer lin -\end{verbatim} -} - -\subsubsection{Erase all data} - -This is necessary before reading a new saved file. Not implemented yet. - -{\small -\begin{verbatim} - subroutine new_gtp -! -! DELETES ALL DATA so a new TDB file can be read -! -! this is needed before reading a new unformatted file (or same file again) -! we must go through all records and delete and deallocate each -! separately. Very similar to gtpread - implicit none -\end{verbatim} -} - -\subsubsection{Delete a phase} - -{\small -\begin{verbatim} - subroutine delphase(lokph) -! save data for phase at location lokph (except data in the equilibrium record) -! For phases with disordered set of parameters we must access the number of -! sublattices via firsteq - implicit none - integer lokph -\end{verbatim} -} - -\subsubsection{Yet another utility routine} - -{\small -\begin{verbatim} - logical function iskeyword(text,keyword,nextc) -! compare a text with a given keyword. Abbreviations allowed -! but the keyword and abbreviation must be surrounded by spaces -! nextc set to space character in text after the (abbreviated) keyword - implicit none - character text*(*),keyword*(*) - integer nextc -\end{verbatim} -} - -\subsubsection{And another utility routine} - -{\small -\begin{verbatim} - integer function istdbkeyword(text,nextc) -! compare a text with a given keyword. Abbreviations allowed (not within _) -! but the keyword and abbreviation must be surrounded by spaces -! nextc set to space character in text after the (abbreviated) keyword - implicit none - character text*(*) - integer nextc -\end{verbatim} -} - -\subsubsection{Read a TDB file} - -This subroutine can read a TDB file that is not too fancily edited -manually. Best is to read as written from Thermo-Calc. Some -TYPE\_DEFINITIONS are not handelled, especially the DISORDERED\_PART as -this has been implemented differently in GTP. - -{\small -\begin{verbatim} - subroutine readtdb(filename,nel,selel) -! reading data from a TDB file with selection of elements -!------------------------------------------------------- -! Not all TYPE_DEFS implemented -!------------------------------------------------------- - implicit none - integer nel - character filename*(*),selel(*)*2 -\end{verbatim} -} - -\subsection{Enter data} - -The subroutines for entering data and other things can be named as -new, enter, add, create etc. according to the mind of the programmer -when the subroutine was written. In all cases the data is provided as -arguments in the call, there is no interactions with the user. - -\subsubsection{Enter element data} - -All data for an element. Some checks are made. The elements are -automatically eneterd also as species so they can be constituents of -phases. - -{\small -\begin{verbatim} - subroutine new_element(symb,name,refstate,mass,h298,s298) -! Creates an element record after checks. -! symb: character*2, symbol (it can be a single character like H or V) -! name: character, free text name of the element -! refstate: character, free text name of reference state. -! mass: double, mass of element in g/mol -! h298: double, enthalpy difference between 0 and 298.14 K -! s298: double, entropy at 298.15 K - implicit none - CHARACTER*(*) symb,name,refstate - DOUBLE PRECISION mass,h298,s298 -\end{verbatim} -} - -\subsubsection{Enter species data} - -All data for an element. Some checks are made. The elements -constituting the species must have been entered before. A species can -have a positive or negative charge using the element index -1 with a -stoichiometic factor. - -{\small -\begin{verbatim} - subroutine new_species(symb,noelx,ellist,stoik) -! creates a new species -! symb: character*24, name of species, often equal to stoichimoetric formula -! noelx: integer, number of elements in stoichiometric formula (incl charge) -! ellist: character array, element names (electron is /-) -! stoik: double array, must be positive except for electron. - implicit none - character symb*(*),ellist(*)*(*) - integer noelx - double precision stoik(*) -\end{verbatim} -} - -\subsubsection{Enter phase and model} - -This subroutine is called with the model data needed to create the -data structure for a phase (no parameter data). The model variable is -just a text, phtype is used to arrange gas (G) and liquids (L) before -the alphabetical list of the other phases. - -{\small -\begin{verbatim} - subroutine new_phase(name,nsl,knr,const,sites,model,phtype) -! creates the data structure for a new phase -! name: character*24, name of phase -! nsl: integer, number of sublattices (range 1-9) -! knr: integer array, number of constituents in each sublattice -! const: character array, constituent (species) names in sequential order -! sites: double array, number of sites on the sublattices -! model: character, free text -! phtype: character*1, specifies G for gas, L for liquid - implicit none - character name*(*),model*(*),phtype*(*) - integer nsl - integer, dimension(*) :: knr - double precision, dimension(*) :: sites - character, dimension(*) :: const*(*) -\end{verbatim} -} - -\subsubsection{Sorting constituents in ionic liquids} +\subsubsection{Calculate molar amounts for a phase} -The ionic liquid model requires all cations (with positive charge) on -the first sublattice in alphabetcal order. On the second sublattice -the anions (with negative charge) should be first (in alphabetical -order), the the hypothetical vacancy (if any), then any neutrals in -alphabetical order. This subroutine takes care of that +Specially used for grid minimization. {\small \begin{verbatim} - subroutine sort_ionliqconst(lokph,mode,knr,kconlok,klok) -! sorts constituents in ionic liquid, both when entering phase -! and decoding parameter constituents -! order: 1st sublattice only cations -! 2nd: anions, VA, neutrals -! mode=0 at enter phase, wildcard ok in 1st sublattice if neiher anions nor Va -! mode=1 at enter parameter (wildcard allowed, i.e. some kconlok(i)=-1) -! some parameters not allowed, L(ion,A+:B,C), must be L(ion,*:B,C), check! + subroutine calc_phase_mol(iph,xmol,ceq) +! calculates mole fractions for phase iph, compset 1 in equilibrium ceq +! used for grid generation and some other things +! returns current constitution in xmol equal to mole fractions of components implicit none - integer lokph,knr(*),kconlok(*),klok(*),mode + integer iph + double precision xmol(*) + TYPE(gtp_equilibrium_data) :: ceq \end{verbatim} } -\subsubsection{Enter composition set} +\subsubsection{Sum molar and mass properties for all phases} -As explained in section~\ref{sec:compsets} a phase may exist -simultaneously with several different composition sets. This can be -due to miscibility gaps or ordering. Some carbides like cubic TiC is -modelled as the same phase as the metallic FCC and it may be stable at -the same time as the austenite phase in steels. This subroutine -creates a new composition set for a phase. +Sums the mole and mass fractions for all components and also total +number of moles and mass over all stable phases using \ref{sec:mmph}. {\small \begin{verbatim} - subroutine add_composition_set(iph,prefix,suffix,icsno) -! adds a composition set to a phase. -! iph: integer, phase index -! prefix: character*4, optional prefix to original phase name -! suffix: character*4, optional suffix to original phase name -! icsno: integer, returned composition set index (value 2-9) -! ceq: pointer, to current gtp_equilibrium_data -! -! BEWARE this must be done in all equilibria (also during parallel processes) -! There may still be problems with equilibria saved during STEP and MAP -! + subroutine calc_molmass(xmol,wmass,totmol,totmass,ceq) +! summing up N and B for each component over all phases with positive amount +! Check that totmol and totmass are correct .... implicit none - integer iph,icsno - character*(*) prefix,suffix -! TYPE(gtp_equilibrium_data), pointer :: ceq + double precision, dimension(*) :: xmol,wmass + double precision totmol,totmass + TYPE(gtp_equilibrium_data) :: ceq \end{verbatim} } -\subsubsection{Remove composition set} +\subsubsection{Sum all normalizing property values} -Sometimes the grid minimizer creates too many composition sets and -the furter calculations may be easier if these are removed. +Used to calculate normallizing propertes like V, N and B but also G +and S for the whole system. Used when calculating state variable +values. {\small \begin{verbatim} - subroutine remove_composition_set(iph,force) -! the last composition set is deleted -! -! >>>>>>>>>>>>>>>>>>>>>>>>>>>> NOTE <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ! -! Not safe to remove composition sets when more than one equilibrium ! -! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ! -! -! If force is TRUE delete anyway ... very dangerous ... -! + subroutine sumprops(props,ceq) +! summing up G, S, V, N and B for all phases with positive amount +! Check if this is correct implicit none -! -! BEWARE must be for all equilibria but maybe not allowed when threaded -! - integer iph,jl,tuple - logical force + TYPE(gtp_equilibrium_data) :: ceq + double precision props(5) \end{verbatim} } -\subsubsection{Enter parameter} - -All kind of parameters are entered by this subroutine. Called when -reading a TDB file or entered interactivly, -see~\ref{sec:enterparinter}. +\subsubsection{Encode state variable}\label{sec:svencode} -{\small -\begin{verbatim} - subroutine enter_parameter(lokph,typty,fractyp,nsl,endm,nint,lint,ideg,& - lfun,refx) -! enter a parameter for a phase from database or interactivly -! typty is the type of property, 1=G, 2=TC, ... , n*100+icon MQ&const#subl -! fractyp is fraction type, 1 is site fractions, 2 disordered fractions -! nsl is number of sublattices -! endm has one constituent index for each sublattice -! constituents in endm and lint should be ordered so endm has lowest -! (done by decode_constarr) -! nint is number of interacting constituents (can be zero) -! lint is array of sublattice+constituent indices for interactions -! ideg is degree -! lfun is link to function (integer index) -! refx is reference (text) -! if this is a phase with permutations all interactions should be in -! the first or the first two identical sublattices (except interstitals) -! a value in endm can be negative to indicate wildcard -! for ionic liquid constituents must be sorted specially - implicit none - integer, dimension(*) :: endm - character refx*(*) - integer lokph,fractyp,typty,nsl,nint,ideg,lfun - integer, dimension(2,*) :: lint -\end{verbatim} -} +This converts the internal coding of a state variable into a character +variable text starting at position ip. ip is updated inside. -\subsubsection{Subroutines handling fcc permutatations} +The subroutine also handle property symbols used in the parameters, +see \ref{sec:paramid}, to make it possible to list the symbol of such +a propery after an equilibrium calculation. See \ref{sec:svdecode} -These subroutines creates all possible permutations of parameters for -a 4 sublattice fcc phase. The 4 ordering sublattices must be the -first and they represent the tetrahedron in the lattice. The number -of sites must be the same and the constituents also. There can be -additional sublattices for interstitials. +The new version of this subroutine uses state variable records, the +previous one using individual arguments should not be used as it will +eventually disappear. {\small \begin{verbatim} - subroutine fccpermuts(lokph,nsl,iord,noperm,elinks,nint,jord,intperm,intlinks) -! finds all fcc/hcp permutations needed for this parameter -! The order of elements in the sublattices is irrelevant when one has F or B -! ordering as all permutations are stored in one place (with some exceptions) -! Thus the endmembers are ordered alphabetically in the sublattices and also -! the interaction parameters. Max 2 levels of interactions allowed. - implicit none - integer, dimension(*) :: iord,intperm - integer, dimension(2,*) :: jord - integer lokph,nsl,noperm,nint - subroutine fccip2A(lokph,jord,intperm,intlinks) -! 2nd level interaction permutations for fcc - implicit none - integer, dimension(*) :: intperm - integer, dimension(2,*) :: jord,intlinks - integer lokph - subroutine fccip2B(lq,lokph,lshift,jord,intperm,intlinks) -! 2nd level interaction permutations for fcc - implicit none - integer lq,lokph,lshift - integer, dimension(*) :: intperm - integer, dimension(2,*) :: jord,intlinks - subroutine fccint31(jord,lshift,intperm,intlinks) -! 1st level interaction in sublattice l1 with endmember A:A:A:B or A:B:B:B -! set the sublattice and link to constituent for each endmember permutation -! 1st permutation of endmember: AX:A:A:B; A:AX:A:B; A:A:AX;B 4 0 1 2 -! 2nd permutation of endmember: AX:A:B:A; A:AX:B:A; A:A:B:AX 3 0 1 3 -! 3rd permutation of endmember: AX:B:A:A; A:B:AX:A; A:B:A:AX 3 0 2 3 -! 4th permutation of endmember: B:AX:A:A; B:A:AX:A; B:A:A:AX 1 or 1 2 3 -! 1st permutation of endmember: A:BX:B:B; A:B:BX:B; A:B:B:BX 4 0 1 2 -! 2nd permutation of endmember: BX:A:B:B; B:A:BX:B; B:A:B:BX 1 etc -1 1 2 -! 3rd -1 0 2 ; -1 0 1 -! suck - implicit none - integer lshift - integer, dimension(2,*) :: jord,intlinks - integer, dimension(*) :: intperm - subroutine fccint22(jord,lshift,intperm,intlinks) -! 1st level for endmember A:A:B:B with interaction in sublattice jord(1,1) -! 6 permutations of endmember, 2 permutations of interactions, 12 in total -! 1st endmemperm: AX:A:B:B; A:AX:B:B 0 1 -! 2nd endmemperm: AX:B:A:B; A:B:AX:B 0 2 -! 3rd endmemperm: AX:B:B:A; A:B:B:AX 0 3 -! 4th endmemperm: B:AX:B:A; B:A:B:AX 1 3 -! 5th endmemperm: B:B:AX:A; B:B:A:AX 2 3 -! 6th endmemperm: B:AX:A:B; B:A:AX:B or 1 2 -! 1th endmemperm: A:A:BX:B; A:A:B:BX 0 1 -! 2nd endmemperm: A:BX:A:B; A:B:A:BX -1 1 -! 3rd endmemperm: A:BX:B:A; A:B:BX:A -1 0 -! 4th endmemperm: BX:A:B:A; B:A:BX:A -2 0 -! 5th endmemperm: BX:B:A:A; B:BX:A:A -2 -1 -! 6th endmemperm: BX:A:A:B; B:A:A:BX -2 1 - implicit none - integer lshift - integer, dimension(2,*) :: jord,intlinks - integer, dimension(*) :: intperm - subroutine fccint211(a211,jord,lshift,intperm,intlinks) -! 1st level interaction in sublattice l1 with endmember like A:A:B:C -! 12 endmember permutations of AABC; ABBC; or ABCC -! 2 interaction permutations for each, 24 in total - implicit none - integer a211,lshift - integer, dimension(2,*) :: jord,intlinks - integer, dimension(*) :: intperm - subroutine fccpe211(l1,elinks,nsl,lshift,iord) -! sets appropriate links to constituents for the 12 perumations of -! A:A:B:C (l1=1), A:B:B:C (l1=2) and A:B:C:C (l1=3) - implicit none - integer, dimension(nsl,*) :: elinks - integer, dimension(*) :: iord - integer l1,nsl,lshift - subroutine fccpe1111(elinks,nsl,lshift,iord) -! sets appropriate links to 24 permutations when all 4 constituents different -! A:B:C:D -! The do loop keeps the same constituent in first sublattice 6 times, changing -! the other 3 sublattice, then changes the constituent in the first sublattice -! and goes on changing in the other 3 until all configurations done + subroutine encode_state_variable(text,ip,svr,ceq) +! writes a state variable in text form position ip. ip is updated + character text*(*) + integer ip + type(gtp_state_variable), pointer :: svr + type(gtp_equilibrium_data), pointer :: ceq + subroutine encode_state_variable3(text,ip,istv,indices,iunit,iref,ceq) +! writes a state variable in text form position ip. ip is updated +! the internal coding provides in istv, indices, iunit and iref +! ceq is needed as compopnents can be different in different equilibria ?? +! >>>> unfinished as iunit and iref not really cared for implicit none - integer, dimension(nsl,*) :: elinks - integer, dimension(*) :: iord - integer nsl,lshift + integer, parameter :: noos=20 + character*4, dimension(noos), parameter :: svid = & + ['T ','P ','MU ','AC ','LNAC','U ','S ','V ',& + 'H ','A ','G ','NP ','BP ','DG ','Q ','N ',& + 'X ','B ','W ','Y '] + character*(*) text + integer, dimension(4) :: indices + integer istv,ip,iunit,iref + type(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } -\subsubsection{Subroutines handling bcc permutatations} +\subsubsection{Encode a state variable record} -Not implemented yet +This is provided to convert a single state variable record to a text. {\small \begin{verbatim} - subroutine bccpermuts(lokph,nsl,iord,noperm,elinks,nint,jord,intperm,intlinks) -! finds all bcc permutations needed for this parameter + subroutine encode_state_variable_record(text,ip,svr,ceq) +! writes a state variable in text form position ip. ip is updated +! the svr record provide istv, indices, iunit and iref +! ceq is needed as compopnents can be different in different equilibria ?? +! >>>> unfinished as iunit and iref not really cared for implicit none - integer lokph,nsl,noperm,nint - integer, dimension(*) :: iord,intperm - integer, dimension(2,*) :: jord - integer, dimension(:,:), allocatable :: elinks - integer, dimension(:,:), allocatable :: intlinks + integer, parameter :: noos=20 + character*4, dimension(noos), parameter :: svid = & + ['T ','P ','MU ','AC ','LNAC','U ','S ','V ',& + 'H ','A ','G ','NP ','BP ','DG ','Q ','N ',& + 'X ','B ','W ','Y '] + character*(*) text + type(gtp_state_variable) :: svr + type(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } -\subsubsection{Find constituent} +\subsubsection{Calculate state variable value}\label{sec:svcalculate} + +This is the subroutine that actually calculates the value of a state +variable. The state variable is indentified using the internal +coding. + +The subroutine also handle properties used in the parameters, see +\ref{sec:paramid}, to make it possible to obtain the value of such +a propery after an equilibrium calculation. The values of istv etc +must be as returned from decode\_state\_variable, see +\ref{sec:svdecode}. {\small \begin{verbatim} - subroutine findconst(lokph,ll,spix,constix) -! locates the constituent index of species with index spix in sublattice ll -! and returns it in constix. For wildcards spix is -99; return -99 -! THERE MAY ALREADY BE A SIMULAR SUBROUTINE ... CHECK + subroutine state_variable_val(svr,value,ceq) +! calculate the value of a state variable in equilibrium record ceq +! It transforms svr data to old format and calls state_variable_val3 + type(gtp_state_variable), pointer :: svr + double precision value + TYPE(gtp_equilibrium_data), pointer :: ceq + subroutine state_variable_val3(istv,indices,iref,iunit,value,ceq) +! calculate the value of a state variable in equilibrium record ceq +! istv is state variable type (integer) +! indices are possible specifiers +! iref indicates use of possible reference state, 0 current, -1 SER +! iunit is unit, (K, oC, J, cal etc). For % it is 100 +! value is the calculated values. for state variables with wildcards use +! get_many_svar implicit none - integer lokph,ll,spix,constix + integer, dimension(4) :: indices + TYPE(gtp_equilibrium_data), pointer :: ceq + integer istv,iref,iunit + double precision value \end{verbatim} } -\subsubsection{Enter references for parameter data} +\subsubsection{The value of the user defined reference state}\label{sc:calrefstate} + +The value of many state variables depend on the selected reference +state. By default that is the value at 298.15~K and 1 bar for the +stable phase of the pure elements, this is called SER. If the user +defines another reference state this subroutine calculates that value. +The reference state is set calling the routine in +section~\ref{sc:setrefstate}. -{\small \begin{verbatim} - subroutine tdbrefs(refid,line,mode,iref) -! store a reference from a TDB file or given interactivly -! If refid already exist and mode=1 then amend the reference text + subroutine calculate_reference_state(kstv,iph,ics,aref,ceq) +! Calculate the user defined reference state for extensive properties +! kstv is the typde of property: 1 U, 2 S, 3 V, 4 H, 5 A, 6 G +! It can be phase specific (iph.ne.0) or global (iph=0) implicit none - character*(*) refid,line - integer mode,iref + integer kstv,iph,ics + double precision aref + type(gtp_equilibrium_data), pointer :: ceq \end{verbatim} -} -\subsubsection{Enter equilibrium}\label{sc:entereq} +\subsection{State variable functions} -The equilibrium record as explained in -section~\ref{sec:equilibriumrec} has all data necessary for specifying -an equilibrium: conditions, compoenets, phases etc. One may have -several equilibria with different sets of conditions but normally they -have the same set of phases (the set of stable phases may differ). -This can be used to interactivly compare different states or used in -parallel processing where each thread is connected with an equilibrium -record. When assessing model parameter each experimental datum can be -described by an equilibrium record. +This section is separated from the state variables itself to make it a +little simpler. State variable function can contain any combination +of state variables using normal operators like +, -, *, / but also +EXP, LN, LOG10, ERF etc. The PUTFUN subroutine in the METLIB package +is used. No derivatives can be calculated. A state variable function +can refer to another state variable function. + +An extention planned but not yet implemented is to allow formal +arguments when defining a state variable function, for example +CP(@P)=HM(@P).T where the formal argument @P means a phase. @S would +stand for a species and @C for a component. When calling the function +an actual argument must be supplied. + +Another extention that has been partially implemented is the ``dot +derivatives'' meaning the drivative of a state variable with respect +to another. This required several changes of the subroutines for +state variable functions and some of them have been moved to the +minimizer package and are described there. + +\subsubsection{Enter a state variable function} + +The first stubroyine enters a state variable function and the other +stores it in the SVFLISTA array. The old version will eventually +dissapear. {\small \begin{verbatim} - subroutine enter_equilibrium(name,number) -! creates a new equilibrium. Allocates arrayes for conditions, -! components, phase data and results etc. -! returns index to new equilibrium record -! THIS CAN PROBABLY BE SIMPLIFIED, especially phase_varres array can be -! copied as a whole, not each record structure separately ... ??? + subroutine enter_svfun(cline,last,ceq) +! enter a state variable function + implicit none + integer last + character cline*(*) + type(gtp_equilibrium_data), pointer :: ceq + subroutine store_putfun(name,lrot,nsymb,iarr) +! enter an expression of state variables with name name with address lrot +! nsymb is number of formal arguments +! iarr identifies these +! idot if derivative implicit none character name*(*) - integer number + type(putfun_node), pointer :: lrot + integer nsymb,idot + integer iarr(10,*) + subroutine store_putfun_old(name,lrot,nsymb,& + istv,indstv,iref,iunit,idot) +! enter an expression of state variables +! name: character, name of state variable function +! lrot: pointer, to a putfun_node that is the root of the stored expression +! nsymb: integer, number of formal arguments +! istv: integer array, formal argument state variables typ +! indstv: 2D integer array, indices for the formal state variables +! iref: integer array, reference for the formal state variables +! iunit: integer array, unit of the formal state variables + implicit none + type(putfun_node), pointer :: lrot + integer nsymb + integer, dimension(*) :: istv,iref,iunit,idot + integer, dimension(4,*) :: indstv + character name*(*) \end{verbatim} } -\subsubsection{Delete equilibrium} +\subsubsection{List a state variable function} -This is needed after STEP or MAP to clean up the structure as all -equilibria along the lines are saved as equilibrium records. +These two subroutines can find a state variable function and list its +name in a character respectivly. {\small \begin{verbatim} - subroutine delete_equilibria(name,ceq) -! deletes an equilibrium (needed when repeated step/map) -! name can be an abbreviation line "_MAP*" -! deallocates all data. Minimal checks ... one cannot delete "ceq" + subroutine find_svfun(name,lrot,ceq) +! finds a state variable function called name (no abbreviations) implicit none character name*(*) - type(gtp_equilibrium_data), pointer ::neweq,ceq + integer lrot + type(gtp_equilibrium_data), pointer :: ceq + subroutine list_svfun(text,ipos,lrot,ceq) +! list a state variable function + implicit none + character text*(*) + integer ipos,lrot + type(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } -\subsubsection{Copy equilibrium} +\subsubsection{Utility subroutine for state variable functions} -As part of STEP and MAP equilibrium records are copied between -different lists. +Utility to store state variable identification for a function. {\small \begin{verbatim} - subroutine copy_equilibrium(neweq,name,ceq) -! creates a new equilibrium which is a copy of ceq. -! Allocates arrayes for conditions, -! components, phase data and results etc. from equilibrium ceq -! returns a pointer to the new equilibrium record -! THIS CAN PROBABLY BE SIMPLIFIED, especially phase_varres array can be -! copied as a whole, not each record structure separately ... ??? + subroutine make_stvrec(svr,iarr) +! stores appropriate values from a formal argument list to a state variable +! function in a state variable record implicit none - character name*(*) - integer number - type(gtp_equilibrium_data), pointer ::neweq,ceq + type(gtp_state_variable), pointer :: svr + integer iarr(10) \end{verbatim} } -\subsubsection{Copy condition} +\subsubsection{List all state variable functions} -This is also a utility used in MAP and STEP +Lists all state variables functions on device kou. {\small \begin{verbatim} - subroutine copy_condition(newrec,oldrec) -! Creates a copy of the condition record "oldrec" and returns a link -! to the copy in newrec. The links to "next/previous" are nullified + subroutine list_all_svfun(kou,ceq) +! list all state variable funtions implicit none - type(gtp_condition), pointer :: oldrec - type(gtp_condition), pointer :: newrec + integer kou + type(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } -\subsubsection{Check that a phase is allowed to have fcc permutations} +\subsubsection{Some depreciated routines} -Some minimal checks made. +The double precision function +evaluate\_svfun\_old(lrot,actual\_arg,mode,ceq) is now in the +minimizer package. -{\small \begin{verbatim} - logical function check_minimal_ford(lokph) -! some tests if the fcc/bcc permutation model can be applied to this phase -! The function returns FALSE if the user may set the FORD or BORD bit of lokph + subroutine evaluate_all_svfun_old(kou,ceq) +! THIS SUBROUTINE MOVED TO MINIMIZER +! evaluate and list values of all functions implicit none - integer lokph + integer kou + TYPE(gtp_equilibrium_data), pointer :: ceq + double precision function evaluate_svfun_old(lrot,actual_arg,mode,ceq) +! THIS SUBROUTINE MOVED TO MINIMIZER +! but needed in some cases in this module ... ??? +! envaluate all funtions as they may depend on each other +! actual_arg are names of phases, components or species as @Pi, @Ci and @Si +! needed in some deferred formal parameters (NOT IMPLEMENTED YET) + implicit none + integer lrot,mode + character actual_arg(*)*(*) + TYPE(gtp_equilibrium_data), pointer :: ceq \end{verbatim} -} -%%%%%%%%%%%%%%%%% here starts pmod25H.F90 +%!> here starts gtp3G.F90 -------------------------------------------- \subsection{Status for things} @@ -5180,7 +5004,7 @@ \subsubsection{Get and test status for phase} integer function get_phase_status(iph,ics,text,ip,val,ceq) ! return phase status as text and amount formula units in val ! for entered and fix phases also phase amounts. -! Function value: 1=entered, 2=fix, 3=dormant, 4=suspended, 5=hidden +! OLD Function value: 1=entered, 2=fix, 3=dormant, 4=suspended, 5=hidden implicit none character text*(*) integer iph,ics,ip @@ -5188,7 +5012,8 @@ \subsubsection{Get and test status for phase} double precision val integer function test_phase_status(iph,ics,val,ceq) ! Almost same as get_..., returns phase status as function value but no text -! 1=entered, 2=fix, 3=dormant, 4=suspended, 5=hidden +! old: 1=entered, 2=fix, 3=dormant, 4=suspended, 5=hidden +! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix ! this is different from in change_phase .... one has to make up one's mind implicit none TYPE(gtp_equilibrium_data), pointer :: ceq @@ -5239,23 +5064,16 @@ \subsubsection{Change status for phase} ! qph can be -1 meaning all or a specifix phase index. ics compset ! implicit none - integer qph,ics,nystat - double precision val - TYPE(gtp_equilibrium_data), pointer :: ceq -\end{verbatim} -} - -\subsubsection{Set reference state for a component} - -Setting the reference state of a component. - -{\small -\begin{verbatim} - subroutine set_reference_state(icomp,iph,tpval,ceq) -! set the reference state of a component to be "iph" at tpval - implicit none - integer icomp,iph - double precision, dimension(2) :: tpval + integer qph,ics,nystat + double precision val + TYPE(gtp_equilibrium_data), pointer :: ceq + subroutine mark_stable_phase(iph,ics,ceq) +! change the status of a phase. Does not change fix status +! called from meq_sameset to indicate stable phases (nystat=1) +! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix +! + implicit none + integer iph,ics TYPE(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } @@ -5302,7 +5120,7 @@ \subsubsection{Set reference state for constituent} \end{verbatim} } -\subsubsection{calculate conversion matrix for new components} +\subsubsection{Calculate conversion matrix for new components} {\small \begin{verbatim} @@ -5337,544 +5155,826 @@ \subsubsection{Alphabetical ordering} ! arrange new species in alphabetical order ! also make alphaindex give alphabetical order implicit none - subroutine alphaphorder -! arrange last added phase in alphabetical order -! also make alphaindex give alphabetical order -! phletter G and L and I have priority + subroutine alphaphorder(tuple) +! arrange last added phase in alphabetical order +! also make alphaindex give alphabetical order +! phletter G and L and I have priority +! tuple is returned as position in phase tuple + implicit none + integer tuple +\end{verbatim} +} + +\subsubsection{Check alphaindex} + +Just for testing. + +{\small +\begin{verbatim} + subroutine check_alphaindex +! just for debugging, check that ellist(i)%alphaindex etc is correct + implicit none +\end{verbatim} +} + +\subsubsection{Creates a list of constituents of a phase} + +Not much to discuss. + +\begin{verbatim} + subroutine create_constitlist(constitlist,nc,klist) +! creates a constituent list ... + implicit none + integer, dimension(*) :: klist + integer, dimension(:), allocatable :: constitlist + integer nc +\end{verbatim} + +\subsubsection{Creates a new parrecord for a phase} + +Not much to discuss. + +\begin{verbatim} + subroutine create_parrecords(lokph,lokcs,nsl,nc,nprop,iva,ceq) +! fractions and results arrays for a phase for parallell calculations +! location is returned in lokcs +! nsl is sublattices, nc number of constituents, nprop max number if propert, +! iva is an array which is set as constituent status word (to indicate VA) +! ceq is always firsteq ??? +! +! BEWARE not adopted for threads +! +! >>> changed all firsteq below to ceq???? +! + implicit none + TYPE(gtp_equilibrium_data), pointer :: ceq + integer, dimension(*) :: iva + integer lokph,lokcs, nsl, nc, nprop +\end{verbatim} + +\subsubsection{Create interaction record} + +Finds the correct place to add an interaction parameter. It should +always be linked from the first possible endmember (with the +alphabetically first constituents) and then in alphabetical order of +the interaction elements. + +{\small +\begin{verbatim} + subroutine create_interaction(intrec,mint,lint,intperm,intlinks) +! creates a parameter interaction record +! with permutations if intperm(1)>0 + implicit none + type(gtp_interaction), pointer :: intrec + integer, dimension(2,*) :: lint,intlinks + integer, dimension(*) :: intperm + integer mint +\end{verbatim} +} + +\subsubsection{Create endmember record} + +Creates a record for an endmember. Sometimes endmembers have +no property records if there are interaction parameters must be +linked from this endmember. + +{\small +\begin{verbatim} + subroutine create_endmember(lokph,newem,noperm,nsl,endm,elinks) +! create endmember record with nsl sublattices with endm as constituents +! noperm is number of permutations +! endm is the basic endmember +! elinks are the links to constituents for all permutations + implicit none + integer endm(*) + type(gtp_endmember), pointer :: newem + integer, dimension(nsl,noperm) ::elinks + integer lokph,noperm,nsl +\end{verbatim} +} + +\subsubsection{Create property record} + +All parameter values for an endmember or interaction record are +stored in property records. An endmember or interaction parameter +may have several property records linked in a list. + +{\small +\begin{verbatim} + subroutine create_proprec(proprec,proptype,degree,lfun,refx) +! reservs a property record from free list and insert data + implicit none + TYPE(gtp_property), pointer :: proprec + integer proptype,degree,lfun + character refx*(*) +\end{verbatim} +} + +\subsubsection{Extend property record} + +An interaction record can have a degree and each degree a function. +When entering a funtion for a higher degree than in the current +property record it must be extended. + +{\small +\begin{verbatim} + subroutine extend_proprec(current,degree,lfun) +! extends a property record and insert new data + implicit none + integer degree,lfun + type(gtp_property), pointer :: current +\end{verbatim} +} + +\subsubsection{Create a new phase\_varres record} + +The phase\_varres record belog to the dynamic dataset in the +equilibrium record. When creating new equilibrium records or +composition sets new phase\_varres records are needed. + +{\small +\begin{verbatim} + subroutine new_phase_varres_record(iph,phvar,ceq) +! this subroutine returnes a copy of the phase variable structure for iph +! >>>>>>>>>>>>> +! this subroutine is probably redundant since the structure +! gtp_equilibrium_data was introduced. Each parallell tread should have +! its own gtp_equilibrium_data record. +! >>>>>>>>>>>>>>>>>>>>>>>>>> +! The programmer can enter fraction in this structure and use it in calls +! to parcalcg should be suitable for parallel processing (NOT TESTED) +! when the same phase is calculated in several threads (like when separate +! threads calculate different lines suring mapping) + implicit none +! >>>> unfinished +! >>>> for calculation of the same phase in separate threads + integer iph + TYPE(gtp_equilibrium_data) :: ceq + TYPE(gtp_phase_varres) :: phvar +\end{verbatim} +} + +\subsubsection{Add a disordered fraction set record} + +A phase with sublattices for long range ordering may have a fraction +set representing the disordered phase. That can be for an fcc phase +where the disordered fractions represent the disordered state or for a +sigma phase where the disordered fractions represent some kind of +hypothetical state. A disordered fraction set can have its own set of +parameters, + +{\small +\begin{verbatim} + subroutine new_disordered_phase_variable_record(lokdis,phvar,phdis,ceq) +! Does this really work???? +! creates a copy of the disordered phase variable record lokdis +! and set links from ordered phvar +! ?????????????? does this work ?????????? is it necessary ???? +! can one just make an assignment ???? + implicit none + TYPE(gtp_equilibrium_data) :: ceq + TYPE(gtp_phase_varres) :: phvar + TYPE(gtp_phase_varres), target :: phdis + integer lokdis +\end{verbatim} +} + +\subsubsection{Add a fraction set record} + +{\small +\begin{verbatim} + subroutine add_fraction_set(iph,id,ndl,totdis) +! add a new set of fractions to a phase, usually to describe a disordered state +! like the "partitioning" in old TC +! +! BEWARE this is only done for firsteq, illegal when having more equilibria +! +! id is a letter used as suffix to identify the parameters of this set +! ndl is the last original sublattice included in the (first) disordered set +! ndl can be 1 meaning sublattice 2..nsl are disordered, or nsl meaning all are +! disordered +! totdis=0 if phase never disorder totally (like sigma) +! +! For a phase like (Al,Fe,Ni)3(Al,Fe,Ni)1(C,Va)4 to add (Al,Fe,Ni)4(C,Va)4 +! icon=1 2 3 1 2 3 4 5 with ndl=2 +! For a phase like (Fe,Ni)10(Cr,Mo)4(Cr,Fe,Mo,Ni)16 then +! icon=2 4 1 3 1 2 3 4 with ndl=3 +! This subroutine will create the necessary data to calculate the +! disordered fraction set from the site fractions. +! +! IMPORTANT (done): for each composition set this must be repeated +! if new composition sets are created it must be repeated for these +! +! IMPORTANT (not done): order the constituents alphabetically in each disorderd +! sublattice otherwise it will not be possible to enter parameters correctly +! + implicit none + integer iph,ndl,totdis + character id*1 +\end{verbatim} +} + +\subsubsection{Copy record for fraction sets} + +{\small +\begin{verbatim} + subroutine copy_fracset_record(lokcs,disrec,ceq) +! attempt to create a new disordered record ??? this can probably be done +! with just one statement .. but as it works I am not changing right now + implicit none + TYPE(gtp_equilibrium_data) :: ceq + TYPE(gtp_fraction_set) :: disrec + integer lokcs +\end{verbatim} +} + +\subsubsection{Implicit suspend and restore} + +If an element is suspended some species may have to be suspended too +and if a species is suspended some phases may have to be suspended. +This routine does that. + +{\small +\begin{verbatim} + subroutine suspend_species_implicitly(ceq) +! loop through all entered species and suspend those with an element suspended + implicit none + TYPE(gtp_equilibrium_data), pointer :: ceq + subroutine suspend_phases_implicitly(ceq) +! loop through all entered phases and suspend constituents and +! SUSPEND phases with all constituents in a sublattice suspended +! dimension lokcs(9) + implicit none + TYPE(gtp_equilibrium_data) :: ceq + subroutine restore_species_implicitly_suspended +! loop through all implicitly suspended species and restore those with +! all elements enteded + implicit none + subroutine restore_phases_implicitly_suspended +! loop through all implicitly suspended phases and restore those with +! at least one constituent entered in each sublattice implicit none \end{verbatim} } -\subsubsection{Check alphaindex} +\subsubsection{Add to reference phase} -Just for testing. +There is a reference phase that should have parameters for each +element it its stable state at all temperatures and 1 bar. For each +element eneterd this subroutine adds it to the reference phase. This +phase can never be used in calculations. It represent different +phases for each element, gas for H, bcc for Cr etc. {\small \begin{verbatim} - subroutine check_alphaindex -! just for debugging, check that ellist(i)%alphaindex etc is correct + subroutine add_to_reference_phase(loksp) +! add this element to the reference phase +! loksp: species index of new element implicit none + integer loksp \end{verbatim} } -\subsubsection{Creates a list of constituents of a phase} - -Not much to discuss. - -\begin{verbatim} - subroutine create_constitlist(constitlist,nc,klist) -! creates a constituent list ... - implicit none - integer, dimension(*) :: klist - integer, dimension(:), allocatable :: constitlist - integer nc -\end{verbatim} +%!> here starts gtp3H.F90 -------------------------------------------- -\subsubsection{Creates a new parrecord for a phase} +\subsection{Additions} -Not much to discuss. +Creating, handling and calculations of additions to the Gibbs energy. +This is a section that will probably be extended with several new +subroutines for different kinds of additions. +{\small \begin{verbatim} - subroutine create_parrecords(lokph,lokcs,nsl,nc,nprop,iva,ceq) -! fractions and results arrays for a phase for parallell calculations -! location is returned in lokcs -! nsl is sublattices, nc number of constituents, nprop max number if propert, -! iva is an array which is set as constituent status word (to indicate VA) -! ceq is always firsteq ??? -! -! BEWARE not adopted for threads -! -! >>> changed all firsteq below to ceq???? -! + subroutine addition_selector(addrec,moded,phres,lokph,mc,ceq) +! called when finding an addtion record while calculating G for a phase +! addrec is addition record +! moded is 0, 1 or 2 if no, first or 2nd order derivatives should be calculated +! phres is ? +! lokph is phase location +! mc is number of constitution fractions +! ceq is current equilibrium record implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq - integer, dimension(*) :: iva - integer lokph,lokcs, nsl, nc, nprop + type(gtp_phase_add), pointer :: addrec + integer moded,lokph,mc + TYPE(gtp_phase_varres), pointer :: phres + type(gtp_equilibrium_data), pointer :: ceq \end{verbatim} +} -\subsubsection{Create interaction record} +\subsubsection{Generic subroutine to add an addition} -Finds the correct place to add an interaction parameter. It should -always be linked from the first possible endmember (with the -alphabetically first constituents) and then in alphabetical order of -the interaction elements. +Not well structured here. {\small \begin{verbatim} - subroutine create_interaction(intrec,mint,lint,intperm,intlinks) -! creates a parameter interaction record -! with permutations if intperm(1)>0 + subroutine add_addrecord(iph,addtyp) +! generic subroutine to add an addition typ addtyp (Except Inden) implicit none - type(gtp_interaction), pointer :: intrec - integer, dimension(2,*) :: lint,intlinks - integer, dimension(*) :: intperm - integer mint + integer iph,addtyp \end{verbatim} } -\subsubsection{Create endmember record} +\subsubsection{Utility routine for addition} -Creates a record for an endmember. Sometimes endmembers have -no property records if there are interaction parameters must be -linked from this endmember. +Searches for the composition dependent properties for a specific +addition. {\small \begin{verbatim} - subroutine create_endmember(lokph,newem,noperm,nsl,endm,elinks) -! create endmember record with nsl sublattices with endm as constituents -! noperm is number of permutations -! endm is the basic endmember -! elinks are the links to constituents for all permutations + subroutine need_propertyid(id,typty) +! get the index of the property needed implicit none - integer endm(*) - type(gtp_endmember), pointer :: newem - integer, dimension(nsl,noperm) ::elinks - integer lokph,noperm,nsl + integer typty + character*4 id \end{verbatim} } -\subsubsection{Create property record} +\subsubsection{Enter and calculate Inden magnetic +model}\label{sec:calculateinden} -All parameter values for an endmember or interaction record are -stored in property records. An endmember or interaction parameter -may have several property records linked in a list. +The first two subroutines create the ferromagnetic addition due to +Inden model and store all necessary data inside this. The last +subroutine is called when calculating the Gibbs energy for a phase if +there is a magnetic addition linked to the phase. It must calculate +the contribution to G and all first and second derivates of G. + +In the call the pointer to the phase\_varres record is provided where +current values of G and derivatives can be found. Values of the +ferromagnetic temperature and its derivatives with respect to +constititution is also stored there. The chain rule for derivatives +must be applied. {\small \begin{verbatim} - subroutine create_proprec(proprec,proptype,degree,lfun,refx) -! reservs a property record from free list and insert data + subroutine add_magrec_inden(lokph,addtyp,aff) +! adds a magnetic record to lokph +! lokph is phase location +! addtyp should be 1 of Inden model +! aff is antiferromagnic factor, -1 for bcc and -3 for fcc and hcp implicit none - TYPE(gtp_property), pointer :: proprec - integer proptype,degree,lfun - character refx*(*) + integer lokph,addtyp,aff + subroutine create_magrec_inden(addrec,aff) +! enters the magnetic model + implicit none + type(gtp_phase_add), pointer :: addrec + integer aff + subroutine calc_magnetic_inden(moded,phres,lokadd,lokph,mc,ceq) +! calculates Indens magnetic contribution +! NOTE: values for function not saved, should be done to save time. +! Gmagn = RT*f(T/Tc)*ln(beta+1) +! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2 +! phres: pointer, to phase\_varres record +! lokadd: pointer, to addition record +! lokph: integer, phase record +! mc: integer, number of constituents +! ceq: pointer, to gtp_equilibrium_data + implicit none + integer moded,lokph,mc + TYPE(gtp_phase_varres) :: phres + TYPE(gtp_phase_add), pointer :: lokadd + TYPE(gtp_equilibrium_data) :: ceq \end{verbatim} } -\subsubsection{Extend property record} +\subsubsection{Create new magnetic model}\label{sec:addewei} -An interaction record can have a degree and each degree a function. -When entering a funtion for a higher degree than in the current -property record it must be extended. +Wei Xiagong has proposed a simplified magnetic model. It is +not yet implemented. {\small \begin{verbatim} - subroutine extend_proprec(current,degree,lfun) -! extends a property record and insert new data + subroutine create_weimagnetic(addrec,bcc) +! adds a wei type magnetic record, we must separate fcc and bcc but no aff!! +! copied from Inden magnetic model +! The difference is that it uses TCA for Curie temperature and TNA for Neel +! and individual Bohr magneton numbers implicit none - integer degree,lfun - type(gtp_property), pointer :: current + logical bcc + type(gtp_phase_add), pointer :: addrec + subroutine calc_weimagnetic(moded,phres,lokadd,lokph,mc,ceq) +! calculates Wei-Indens magnetic contribution +! +! NOTE this is just copied from Inden subroutine, must be changed +! +! Gmagn = RT*f(T/Tc)*ln(beta+1) +! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2 +! phres: pointer, to phase\_varres record +! lokadd: pointer, to addition record +! lokph: integer, phase record +! mc: integer, number of constituents +! ceq: pointer, to gtp_equilibrium_data + implicit none + integer moded,lokph,mc +! phres points to result record with gval etc for this phase + TYPE(gtp_phase_varres) :: phres + TYPE(gtp_phase_add), pointer :: lokadd + TYPE(gtp_equilibrium_data) :: ceq \end{verbatim} } -\subsubsection{Create a new phase\_varres record} +\subsubsection{Calculate and calculate elastic +contribution}\label{sec:add elast} -The phase\_varres record belog to the dynamic dataset in the -equilibrium record. When creating new equilibrium records or -composition sets new phase\_varres records are needed. +This creates and calculates the elastic record. {\small \begin{verbatim} - subroutine new_phase_varres_record(iph,phvar,ceq) -! this subroutine returnes a copy of the phase variable structure for iph -! >>>>>>>>>>>>> -! this subroutine is probably redundant since the structure -! gtp_equilibrium_data was introduced. Each parallell tread should have -! its own gtp_equilibrium_data record. -! >>>>>>>>>>>>>>>>>>>>>>>>>> -! The programmer can enter fraction in this structure and use it in calls -! to parcalcg should be suitable for parallel processing (NOT TESTED) -! when the same phase is calculated in several threads (like when separate -! threads calculate different lines suring mapping) + subroutine create_elastic_model_a(newadd) +! addition record to calculate the elastic energy contribution implicit none -! >>>> unfinished -! >>>> for calculation of the same phase in separate threads - integer iph - TYPE(gtp_equilibrium_data) :: ceq - TYPE(gtp_phase_varres) :: phvar + type(gtp_phase_add), pointer :: newadd + subroutine calc_elastica(moded,phres,addrec,lokph,mc,ceq) +! calculates elastic contribution and adds to G and derivatives + implicit none + integer moded,lokph,mc + type(gtp_phase_varres), pointer :: phres + type(gtp_phase_add), pointer :: addrec + type(gtp_equilibrium_data), pointer :: ceq + subroutine set_lattice_parameters(iph,ics,xxx,ceq) +! temporary way to set current lattice parameters for use with elastic model a + implicit none + integer iph,ics + double precision, dimension(3,3) :: xxx + type(gtp_equilibrium_data) :: ceq \end{verbatim} } -\subsubsection{Add a disordered fraction set record} +\subsubsection{Heat capacity model for Einstein solids} -A phase with sublattices for long range ordering may have a fraction -set representing the disordered phase. That can be for an fcc phase -where the disordered fractions represent the disordered state or for a -sigma phase where the disordered fractions represent some kind of -hypothetical state. A disordered fraction set can have its own set of -parameters, +Unfinished {\small \begin{verbatim} - subroutine new_disordered_phase_variable_record(lokdis,phvar,phdis,ceq) -! Does this really work???? -! creates a copy of the disordered phase variable record lokdis -! and set links from ordered phvar -! ?????????????? does this work ?????????? is it necessary ???? -! can one just make an assignment ???? + subroutine create_einsteincp(newadd) + implicit none + type(gtp_phase_add), pointer :: newadd + subroutine calc_einsteincp(moded,phres,addrec,lokph,mc,ceq) +! Calculate the contibution due to Einste Cp model for low T +! moded 0, 1 or 2 +! phres all results +! addrec pointer to addition record +! lokph phase record +! mc number of variable fractions +! ceq equilibrum record +! +! G = 3*R*T*ln( 1 - exp( THET/T ) ) +! This is easier to handle inside the calc routine without TPFUN +! implicit none - TYPE(gtp_equilibrium_data) :: ceq - TYPE(gtp_phase_varres) :: phvar - TYPE(gtp_phase_varres), target :: phdis - integer lokdis + integer moded,lokph,mc + type(gtp_phase_varres), pointer :: phres + type(gtp_phase_add), pointer :: addrec + type(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } -\subsubsection{Add a fraction set record} +\subsubsection{Glas addition} + +Unfinished {\small \begin{verbatim} - subroutine add_fraction_set(iph,id,ndl,totdis) -! add a new set of fractions to a phase, usually to describe a disordered state -! like the "partitioning" in old TC -! -! BEWARE this is only done for firsteq, illegal when having more equilibria -! -! id is a letter used as suffix to identify the parameters of this set -! ndl is the last original sublattice included in the (first) disordered set -! ndl can be 1 meaning sublattice 2..nsl are disordered, or nsl meaning all are -! disordered -! totdis=0 if phase never disorder totally (like sigma) -! -! For a phase like (Al,Fe,Ni)3(Al,Fe,Ni)1(C,Va)4 to add (Al,Fe,Ni)4(C,Va)4 -! icon=1 2 3 1 2 3 4 5 with ndl=2 -! For a phase like (Fe,Ni)10(Cr,Mo)4(Cr,Fe,Mo,Ni)16 then -! icon=2 4 1 3 1 2 3 4 with ndl=3 -! This subroutine will create the necessary data to calculate the -! disordered fraction set from the site fractions. -! -! IMPORTANT (done): for each composition set this must be repeated -! if new composition sets are created it must be repeated for these -! -! IMPORTANT (not done): order the constituents alphabetically in each disorderd -! sublattice otherwise it will not be possible to enter parameters correctly -! + subroutine create_glas_transition_modela(newadd) +! not implemented implicit none - integer iph,ndl,totdis - character id*1 + type(gtp_phase_add), pointer :: newadd \end{verbatim} } -\subsubsection{Copy record for fraction sets} +\subsubsection{Debye heat capacity model} + +These subroutines are called to create and calculate the Gibbs energy +contribution for a phase if there is a Debye model addition linked to +the phase. It must calculate the contribution to G and all first and +second derivates of G. Careful study of the Inden magnetic model +record is recommended. + +In the call the pointer to the phase\_varres record is provided where +current values of G and derivatives can be found. Values of the Debye +temperature and its derivatives with respect to constititution is also +stored there. The chain rule for derivatives must be applied. + +Unfinished. {\small \begin{verbatim} - subroutine copy_fracset_record(lokcs,disrec,ceq) -! attempt to create a new disordered record ??? this can probably be done -! with just one statement .. but as it works I am not changing right now + subroutine create_debyecp(addrec) +! enters a record for the debye model + implicit none + type(gtp_phase_add), pointer :: addrec + subroutine calc_debyecp(moded,phres,lokadd,lokph,mc,ceq) +! calculates Mauro Debye contribution +! NOTE: values for function not saved, should be done to save calculation time. +! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2 +! phres: pointer, to phase\_varres record +! lokadd: pointer, to addition record +! lokph: integer, phase record +! mc: integer, number of constituents +! ceq: pointer, to gtp_equilibrium_data implicit none + integer moded,lokph,mc TYPE(gtp_equilibrium_data) :: ceq - TYPE(gtp_fraction_set) :: disrec - integer lokcs + TYPE(gtp_phase_add), pointer :: lokadd + TYPE(gtp_phase_varres) :: phres \end{verbatim} } -\subsubsection{Implicit suspend and restore} +\subsubsection{List additions}\label{sec:listadditions} -If an element is suspended some species may have to be suspended too -and if a species is suspended some phases may have to be suspended. -This routine does that. +When listing data for a phase with addition the relevant information +must be listed also for additions. {\small \begin{verbatim} - subroutine suspend_species_implicitly(ceq) -! loop through all entered species and suspend those with an element suspended - implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq - subroutine suspend_phases_implicitly(ceq) -! loop through all entered phases and suspend constituents and -! SUSPEND phases with all constituents in a sublattice suspended -! dimension lokcs(9) - implicit none - TYPE(gtp_equilibrium_data) :: ceq - subroutine restore_species_implicitly_suspended -! loop through all implicitly suspended species and restore those with -! all elements enteded - implicit none - subroutine restore_phases_implicitly_suspended -! loop through all implicitly suspended phases and restore those with -! at least one constituent entered in each sublattice + subroutine list_addition(unit,lokph,lokadd) +! list description of an addition for a phase on unit implicit none + integer unit,lokph + TYPE(gtp_phase_add), pointer :: lokadd \end{verbatim} } -\subsubsection{Add to reference phase} +\subsection{Calculation} -There is a reference phase that should have parameters for each -element it its stable state at all temperatures and 1 bar. For each -element eneterd this subroutine adds it to the reference phase. This -phase can never be used in calculations. It represent different -phases for each element, gas for H, bcc for Cr etc. +There are many subroutines involved in calculating the Gibbs energy +for a system and to retrieve values afterwards. Some are explained in +connection with what they calculate, for example the magnetic +contribution in \ref{sec:calculateinden}. + +%!> here starts gtp3X.F90 -------------------------------------------- + +\subsubsection{Calculate for one phase}\label{sec:calcg} + +This subroutine calculates the Gibbs energy and all first and second +derivaties with respect to $T, P$ and constituents for the specified +phase and composition set using the current values of $T, P$ and +constitution of the phase (set by set\_constitution, +see~\ref{sec:setconst}). It also calculates all other properties +stored in the property records. + +It is possible to calculate only G my setting moded=0, only G and +first derivatives if moded=1 and also second derivatives with moded=2. +This routine calls calcg\_internal to do the calculations after some +checks. {\small \begin{verbatim} - subroutine add_to_reference_phase(loksp) -! add this element to the reference phase -! loksp: species index of new element + subroutine calcg(iph,ics,moded,lokres,ceq) +! calculates G for phase iph and composition set ics in equilibrium ceq +! checks first that phase and composition set exists +! Data taken and stored in equilibrium record ceq +! lokres is set to the phase_varres record with all fractions and results +! moded is 0, 1 or 2 depending on calculating no, first or 2nd derivarives implicit none - integer loksp + TYPE(gtp_equilibrium_data), pointer :: ceq + integer iph,ics,moded,lokres \end{verbatim} } -%%%%%%%%%%%%%%%%%%%%%% here starts pmod25I.F90 - -\subsection{Additions} +\subsubsection{Model independent routine for one phase calculation} -Creating, handling and calculations of additions to the Gibbs energy. -This is a section that will probably be extended with several new -subroutines for different kinds of additions. +This is the central subroutine to calculate G and derivatives for all +kinds of phases. At present only the CEF model is implemented. It +calls many other calculating subroutines, some are described in +connection with the property they calculate, like magnetic +contribution. {\small \begin{verbatim} - subroutine addition_selector(addrec,moded,phres,lokph,mc,ceq) -! called when finding an addtion record while calculating G for a phase -! addrec is addition record -! moded is 0, 1 or 2 if no, first or 2nd order derivatives should be calculated -! phres is ? -! lokph is phase location -! mc is number of constitution fractions -! ceq is current equilibrium record + subroutine calcg_internal(lokph,moded,cps,ceq) +! Central calculating routine calculating G and everyting else for a phase +! ceq is the equilibrium record, cps is the phase_varres record for lokph +! moded is type of calculation, 0=only G, 1 G and first derivatives +! 2=G and all second derivatives +! Can also handle the ionic liquid model now .... implicit none - type(gtp_phase_add), pointer :: addrec - integer moded,lokph,mc - TYPE(gtp_phase_varres), pointer :: phres - type(gtp_equilibrium_data), pointer :: ceq + integer lokph,moded + TYPE(gtp_equilibrium_data), pointer :: ceq + TYPE(gtp_phase_varres), target :: cps \end{verbatim} } -\subsubsection{Generic subroutine to add an addition} +\subsubsection{A utility routine} -Not well structured here. +This is used when a phase has permutations, see~\ref{sec:permutations} {\small \begin{verbatim} - subroutine add_addrecord(iph,addtyp) -! generic subroutine to add an addition typ addtyp (Except Inden) + subroutine setendmemarr(lokph,ceq) +! stores the pointers to all ordered and disordered endmemners in arrays implicit none - integer iph,addtyp + integer lokph + TYPE(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } -\subsubsection{Utility routine for addition} +\subsubsection{Calculate and list results for one phase} -Searches for the composition dependent properties for a specific -addition. +This is mainly a debugging rotine that calculates and lists for a +specific phase the Gibbs energy and all first and second derivatives +by calling calcg using the current values of $T, P$ and constitution. +It does not iterate and can thus not calculate an equilibrium. {\small \begin{verbatim} - subroutine need_propertyid(id,typty) -! get the index of the property needed + subroutine tabder(iph,ics,ceq) +! tabulate derivatives of phase iph with current constitution and T and P implicit none - integer typty - character*4 id + integer iph,ics + TYPE(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } -\subsubsection{Enter and calculate Inden magnetic -model}\label{sec:calculateinden} - -The first two subroutines create the ferromagnetic addition due to -Inden model and store all necessary data inside this. The last -subroutine is called when calculating the Gibbs energy for a phase if -there is a magnetic addition linked to the phase. It must calculate -the contribution to G and all first and second derivates of G. +\subsubsection{Calculate an interaction parameter} -In the call the pointer to the phase\_varres record is provided where -current values of G and derivatives can be found. Values of the -ferromagnetic temperature and its derivatives with respect to -constititution is also stored there. The chain rule for derivatives -must be applied. +This is called by calcg\_internal to calculate the value of an +interaction parameter and its derivatives and add this to all property +arrays. {\small \begin{verbatim} - subroutine add_magrec_inden(lokph,addtyp,aff) -! adds a magnetic record to lokph -! lokph is phase location -! addtyp should be 1 of Inden model -! aff is antiferromagnic factor, -1 for bcc and -3 for fcc and hcp - implicit none - integer lokph,addtyp,aff - subroutine create_magrec_inden(addrec,aff) -! enters the magnetic model - implicit none - type(gtp_phase_add), pointer :: addrec - integer aff - subroutine calc_magnetic_inden(moded,phres,lokadd,lokph,mc,ceq) -! calculates Indens magnetic contribution -! NOTE: values for function not saved, should be done to save time. -! Gmagn = RT*f(T/Tc)*ln(beta+1) -! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2 -! phres: pointer, to phase\_varres record -! lokadd: pointer, to addition record -! lokph: integer, phase record -! mc: integer, number of constituents -! ceq: pointer, to gtp_equilibrium_data - implicit none - integer moded,lokph,mc - TYPE(gtp_phase_varres) :: phres - TYPE(gtp_phase_add), pointer :: lokadd + subroutine cgint(lokph,lokpty,moded,vals,dvals,d2vals,gz,ceq) +! calculates an excess parameter that can be composition dependent +! gz%yfrem are the site fractions in the end member record +! gz%yfrint are the site fractions in the interaction record(s) +! lokpty is the property index, lokph is the phase record +! moded=0 means only G, =1 G and dG/dy, =2 all + implicit none + integer moded,lokph + TYPE(gtp_property), pointer :: lokpty + TYPE(gtp_parcalc) :: gz + double precision vals(6),dvals(3,gz%nofc) TYPE(gtp_equilibrium_data) :: ceq \end{verbatim} } -\subsubsection{Create new magnetic model}\label{sec:addewei} +\subsubsection{Calculate ideal configurational entropy} -Wei Xiagong has proposed a simplified magnetic model. It is -not yet implemented. +This calculates the ideal configurational entropy summed over all +sublattices. {\small \begin{verbatim} - subroutine create_weimagnetic(addrec,bcc) -! adds a wei type magnetic record, we must separate fcc and bcc but no aff!! -! copied from Inden magnetic model -! The difference is that it uses TCA for Curie temperature and TNA for Neel -! and individual Bohr magneton numbers - implicit none - logical bcc - type(gtp_phase_add), pointer :: addrec - subroutine calc_weimagnetic(moded,phres,lokadd,lokph,mc,ceq) -! calculates Wei-Indens magnetic contribution -! -! NOTE this is just copied from Inden subroutine, must be changed -! -! Gmagn = RT*f(T/Tc)*ln(beta+1) -! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2 -! phres: pointer, to phase\_varres record -! lokadd: pointer, to addition record -! lokph: integer, phase record -! mc: integer, number of constituents -! ceq: pointer, to gtp_equilibrium_data + subroutine config_entropy(moded,nsl,nkl,phvar,tval) +! calculates configurational entropy/R for phase lokph implicit none - integer moded,lokph,mc -! phres points to result record with gval etc for this phase - TYPE(gtp_phase_varres) :: phres - TYPE(gtp_phase_add), pointer :: lokadd - TYPE(gtp_equilibrium_data) :: ceq + integer moded,nsl + integer, dimension(nsl) :: nkl + TYPE(gtp_phase_varres), pointer :: phvar \end{verbatim} } -\subsubsection{Calculate and calculate elastic -contribution}\label{sec:add elast} +\subsubsection{Calculate ionic liquid configurational entropy} -This creates and calculates the elastic record. +The ionic liquid model assumes ideal mixing on each sublattice but the +site ratios are not constant. {\small \begin{verbatim} - subroutine create_elastic_model_a(newadd) -! addition record to calculate the elastic energy contribution - implicit none - type(gtp_phase_add), pointer :: newadd - subroutine calc_elastica(moded,phres,addrec,lokph,mc,ceq) -! calculates elastic contribution and adds to G and derivatives - implicit none - integer moded,lokph,mc - type(gtp_phase_varres), pointer :: phres - type(gtp_phase_add), pointer :: addrec - type(gtp_equilibrium_data), pointer :: ceq - subroutine set_lattice_parameters(iph,ics,xxx,ceq) -! temporary way to set current lattice parameters for use with elastic model a + subroutine config_entropy_i2sl(moded,nsl,nkl,phvar,i2slx,tval) +! calculates configurational entropy/R for ionic liquid model +! Always 2 sublattices, the sites depend on composition +! P = \sum_j (-v_j) y_j + Q y_Va +! Q = \sum_i v_i y_i +! where v is the charge on the ions. P and Q calculated by set_constitution implicit none - integer iph,ics - double precision, dimension(3,3) :: xxx - type(gtp_equilibrium_data) :: ceq + integer moded,nsl,i2slx(2) + integer, dimension(nsl) :: nkl + TYPE(gtp_phase_varres), pointer :: phvar \end{verbatim} } -\subsubsection{Heat capacity model for Einstein solids} +\subsubsection{Push/pop constituent fraction product on stack} -Unfinished +These subroutines are used to push/pop current values of the product +of constituent fractions and its derivatives before calculating an +interaction parameter. {\small \begin{verbatim} - subroutine create_einsteincp(newadd) + subroutine push_pyval(pystack,intrec,pmq,pyq,dpyq,d2pyq,moded,iz) +! push data when entering an interaction record implicit none - type(gtp_phase_add), pointer :: newadd - subroutine calc_einsteincp(moded,phres,addrec,lokph,mc,ceq) -! Calculate the contibution due to Einste Cp model for low T -! moded 0, 1 or 2 -! phres all results -! addrec pointer to addition record -! lokph phase record -! mc number of variable fractions -! ceq equilibrum record -! -! G = 3*R*T*ln( 1 - exp( THET/T ) ) -! This is easier to handle inside the calc routine without TPFUN -! + integer pmq,moded,iz + double precision pyq,dpyq(iz),d2pyq(iz*(iz+1)/2) + type(gtp_pystack), pointer :: pystack + type(gtp_interaction), pointer :: intrec + subroutine pop_pyval(pystack,intrec,pmq,pyq,dpyq,d2pyq,moded,iz) +! pop data when entering an interaction record implicit none - integer moded,lokph,mc - type(gtp_phase_varres), pointer :: phres - type(gtp_phase_add), pointer :: addrec - type(gtp_equilibrium_data), pointer :: ceq + integer iz,pmq,moded + double precision pyq,dpyq(iz),d2pyq(iz*(iz+1)/2) + type(gtp_pystack), pointer :: pystack + type(gtp_interaction), pointer :: intrec \end{verbatim} } -\subsubsection{Glas addition} +\subsubsection{Calculate disordered fractions from constituent fractions} -Unfinished +This is used when there are several fraction sets of a phase. The +values of the second fraction set (also called the disordered fraction +set) is calculated by this subroutine. These disordered fractions can +be used to calculate a ``disordered'' part of the Gibbs energy with +its own set of parameters. {\small \begin{verbatim} - subroutine create_glas_transition_modela(newadd) -! not implemented + subroutine calc_disfrac(lokph,lokcs,ceq) +! calculate and set disordered set of fractions from sitefractions +! The first derivatives are dxidyj. There are no second derivatives +! TYPE(gtp_fraction_set), pointer :: disrec implicit none - type(gtp_phase_add), pointer :: newadd + integer lokph,lokcs + TYPE(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } -\subsubsection{Debye heat capacity model} - -These subroutines are called to create and calculate the Gibbs energy -contribution for a phase if there is a Debye model addition linked to -the phase. It must calculate the contribution to G and all first and -second derivates of G. Careful study of the Inden magnetic model -record is recommended. +\subsubsection{Disorder constituent fractions} -In the call the pointer to the phase\_varres record is provided where -current values of G and derivatives can be found. Values of the Debye -temperature and its derivatives with respect to constititution is also -stored there. The chain rule for derivatives must be applied. +This subroutine is now redundant. Previously the Gibbs energy for the +``partitioned'' phases, like FCC and BCC which can have order/disorder +transformations, see \ref{sec:partitioning}, the ``ordered part'' was +calculated twice, once with the original constituent fractions and +once with these set equal to their disordered value. The reason for +this was that the ``disordered part'' should be complete i.e. include +also the disordered part of the ``ordered part'' as the disordered +partitions was sometimes included in a larger disordered phase without +the ordered part. -Unfinished. +This is no longer made, the Gibbs energy is simply added from the two +fraction sets. This subroutne sets the fractions to their disordered +values. {\small \begin{verbatim} - subroutine create_debyecp(addrec) -! enters a record for the debye model - implicit none - type(gtp_phase_add), pointer :: addrec - subroutine calc_debyecp(moded,phres,lokadd,lokph,mc,ceq) -! calculates Mauro Debye contribution -! NOTE: values for function not saved, should be done to save calculation time. -! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2 -! phres: pointer, to phase\_varres record -! lokadd: pointer, to addition record -! lokph: integer, phase record -! mc: integer, number of constituents -! ceq: pointer, to gtp_equilibrium_data + subroutine disordery(phvar,ceq) +! sets the ordered site fractions in FCC and other order/disordered phases +! equal to their disordered value in order to calculate and subtract this part +! phvar is index to phase_varres for ordered fractions implicit none - integer moded,lokph,mc + TYPE(gtp_phase_varres), pointer :: phvar TYPE(gtp_equilibrium_data) :: ceq - TYPE(gtp_phase_add), pointer :: lokadd - TYPE(gtp_phase_varres) :: phres \end{verbatim} } -\subsubsection{List additions}\label{sec:listadditions} +\subsubsection{Set driving force for a phase explicitly} -When listing data for a phase with addition the relevant information -must be listed also for additions. +Another failed attempt to handle convergence problems. {\small \begin{verbatim} - subroutine list_addition(unit,lokph,lokadd) -! list description of an addition for a phase on unit + subroutine set_driving_force(iph,ics,dgm,ceq) +! set the driving force of a phase explicitly implicit none - integer unit,lokph - TYPE(gtp_phase_add), pointer :: lokadd + type(gtp_equilibrium_data), pointer :: ceq + integer iph,ics + double precision dgm +\end{verbatim} +} + +\subsubsection{Extract massbalance conditions} + +This is used in global grid minimization to extract the set of mass +balance conditions. If the current conditions are not all mass +balance there is an error return, otherwise the conditions of T and P, +the total number of moles and the mole fractions of all components are +returned. + +{\small +\begin{verbatim} + subroutine extract_massbalcond(tpval,xknown,antot,ceq) +! extract T, P, mol fractions of all components and total number of moles +! for use when minimizing G for a closed system. Probably redundant + implicit none + double precision, dimension(*) :: tpval,xknown + double precision antot + TYPE(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } -%%%%%%%%%%%%%%%%%%%% here starts pmod25J.F90 +\subsubsection{Saving and restoring a phase constitution} + +These are used during step and map to help handling convergence problems + +\begin{verbatim} + subroutine save_constitutions(ceq,copyofconst) +! copy the current phase amounts and constituitions to be restored +! if calculations fails during step/map +! DANGEROUS IF NEW COMPOSITION SETS CREATED + implicit none + TYPE(gtp_equilibrium_data), pointer :: ceq + double precision, allocatable, dimension(:) :: copyofconst + subroutine restore_constitutions(ceq,copyofconst) +! restore the phase amounts and constituitions from copyofconst +! if calculations fails during step/map +! DANGEROUS IF NEW COMPOSITION SETS CREATED + implicit none + TYPE(gtp_equilibrium_data), pointer :: ceq + double precision copyofconst(*) +\end{verbatim} + + +%!> here starts gtp3Y.F90 -------------------------------------------- \subsection{Grid minimizer} @@ -5990,11 +6090,23 @@ \subsubsection{Calculate endmember} ! calculates G for one mole of real atoms for a single end member ! used for reference states. Restores current composition (but not G or deriv) ! endmember contains indices in the constituent array, not species index +! one for each sublattice implicit none integer iph double precision gval integer endmember(maxsubl) TYPE(gtp_equilibrium_data), pointer :: ceq + subroutine calcg_endmember6(iph,endmember,gval,ceq) +! calculates G and all derivatevs wrt T and P for one mole of real atoms +! for a single end member, used for reference states. +! Restores current composition (but not G or deriv) +! endmember contains indices in the constituent array, not species index +! one for each sublattice + implicit none + integer iph + double precision gval(6) + integer endmember(maxsubl) + TYPE(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } @@ -6179,7 +6291,7 @@ \subsubsection{Set default constitution} {\small \begin{verbatim} subroutine enter_default_constitution(iph,ics,mmyfr,ceq) -! set values of default constitution +! user specification of default constitution for a composition set implicit none TYPE(gtp_equilibrium_data), pointer :: ceq integer iph,ics @@ -6209,7 +6321,7 @@ \subsubsection{Set the default constitution of a phase} {\small \begin{verbatim} - subroutine set_default_constitution(jph,ics,all,ceq) + subroutine set_as_default_constitution(jph,ics,all,ceq) ! set the current constitution of jph to its default constitution ! jph can be -1 meaning all phases, all composition sets ! if all=-1 then change constitution of all phases, else just those not stable @@ -6217,6 +6329,12 @@ \subsubsection{Set the default constitution of a phase} implicit none integer all,jph,ics TYPE(gtp_equilibrium_data), pointer :: ceq + subroutine set_default_constitution(iph,ics,ceq) +! set the current constitution of iph composition set ics to its +! default constitution. Do not change the amounts of the phases + implicit none + integer iph,ics + TYPE(gtp_equilibrium_data), pointer :: ceq \end{verbatim} } @@ -6228,7 +6346,7 @@ \subsubsection{Subroutine to prepare for an equilibrium calculation} \begin{verbatim} subroutine todo_before(mode,ceq) ! this could be called before an equilibrium calculation -! It removes any phase amounts and clears CSSTABLE +! It should remove any phase amounts and clears CSSTABLE ! DUMMY ! implicit none @@ -6239,7 +6357,17 @@ \subsubsection{Subroutine to prepare for an equilibrium calculation} \subsubsection{Subroutine to clean up after an equilibrium calculation} -Unfinished +This now checks if there are any composition sets with the AUTO bit +set meaning that they have been created by the grid minimizer in this +equilibrium calculation. If so it tries to move the stable phases to +the lowest possible composition set, taking care that user defined +composition sets with a given default constitution is honoured, i.e a +fcc carbide is not set as composition set 1 if the user has defined a +metallic fcc phase with low carbon as the first. + +It then removed unstable composition sets with the AUTO bit set and +any stable composition sets with the AUTO bit set have this bit +cleared. {\small \begin{verbatim} @@ -6258,7 +6386,7 @@ \subsubsection{Subroutine to clean up after an equilibrium calculation} ! step and map. Then metallic-FCC and MC-carbides may shift composition sets. ! Such shifts should be avoided by manual entering of comp.sets with ! default constitutions, but comparing a stable constitution with a -! default has not been implemented yet. +! default is not trivial ... ! implicit none TYPE(gtp_equilibrium_data), pointer :: ceq @@ -6268,15 +6396,45 @@ \subsubsection{Subroutine to clean up after an equilibrium calculation} \subsubsection{Select composition set for stable phase} -This has not yet been written. It is part of the global gridminimizer -but also useful in other cases when one has two or more composition -sets with user defined default consititutions, like fcc\#1 with little -C and fcc\#2 with a lot of C. Then a carbide rich fcc phase should be -fcc\#2 and not fcc\#1 even if fcc\#1 is not stable. - -This routine should handle such thing but it is not implemented. +After an equilibrium calculation there may be automatically created +composition sets by the gridminimizer that are not needed. These +routines tries to remove unneeded sets andl also shift the used ones +to the lowest composition set. It trie sto take into account the +default constitutions for user defined composition sets for example an +fcc\#1 with a small amount of C and fcc\#2 with a large amount of C. +Then a carbide rich fcc phase should be fcc\#2 and not fcc\#1 even if +fcc\#1 is not stable. {\small +\begin{verbatim} + logical function checkdefcon(lokics,lokjcs,fit,ceq) +! check if composition of lokics fits default constitution in lokjcs +! return TRUE if lokics moved to lokjcs +! If not moved fit returns a value how close the constitition is +! If 1 very close, 2 less etc. + integer lokics,lokjcs,fit + type(gtp_equilibrium_data), pointer :: ceq + subroutine shiftcompsets(ceq) +! check phase with several composition sets if they should be shifted +! to fit the default constitution better + type(gtp_equilibrium_data), pointer :: ceq + subroutine copycompsets(iph,ics1,ics2,ceq) +! copy constitution and results from ic2 to ic1 and vice versa + integer iph,ics1,ics2 + type(gtp_equilibrium_data), pointer :: ceq + subroutine copycompsets2(lokph,ics1,ics2,ceq) +! copy constitution and results from ic2 to ic1 and vice versa + integer lokph,ics1,ics2 + type(gtp_equilibrium_data), pointer :: ceq + subroutine shiftcompsets2(lokph,ceq) +! check if the composition sets of phase lokph +! should be shifted to fit the default constitution better + integer lokph + type(gtp_equilibrium_data), pointer :: ceq +\end{verbatim} + +\subsubsection{Select composition set for stable phase, maybe not used} + \begin{verbatim} subroutine select_composition_set(iph,ics,yarr,ceq) ! if phase iph wants to become stable and there are several composition sets @@ -6292,29 +6450,12 @@ \subsubsection{Select composition set for stable phase} \end{verbatim} } -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pmod25G - \subsection{Unfinished things} There are many unfinished parts among the other sections, in particular the save/read section. -\subsubsection{Set reference state for a component} - -This is not yet implemented. - -{\small -\begin{verbatim} - subroutine set_reference_state(comp,phase,tpval,ceq) -! set the reference state of a component to be phase at tpval - implicit none - integer icomp,iph - double precision, dimension(2) :: tpval - TYPE(gtp_equilibrium_data), pointer :: ceq -\end{verbatim} -} - -%%%%%%%%%%%%%%%%%%%%%% this in the tpfun.F90 file +%!> this in the tpfun.F90 file -------------------------------------------- \section{TP functions} @@ -6432,3 +6573,9 @@ \section{Summary} \end{document} \end{document} \end{document} +\end{document} +\end{document} +\end{document} +\end{document} +\end{document} +\end{document} diff --git a/documentation/gtp3.toc b/documentation/gtp3.toc new file mode 100644 index 0000000..ef34b93 --- /dev/null +++ b/documentation/gtp3.toc @@ -0,0 +1,254 @@ +\contentsline {section}{\numberline {1}The Gibbs energy function}{11} +\contentsline {subsection}{\numberline {1.1}New features in version 2}{11} +\contentsline {subsection}{\numberline {1.2}The Gibbs energy function}{11} +\contentsline {section}{\numberline {2}Basis}{12} +\contentsline {subsection}{\numberline {2.1}Elements}{12} +\contentsline {subsection}{\numberline {2.2}Species}{13} +\contentsline {subsection}{\numberline {2.3}Phases}{14} +\contentsline {subsubsection}{\numberline {2.3.1}Phase specification}{15} +\contentsline {subsubsection}{\numberline {2.3.2}Interaction parameters}{15} +\contentsline {subsubsection}{\numberline {2.3.3}Model parameters identifiers}{16} +\contentsline {subsubsection}{\numberline {2.3.4}Physical models}{17} +\contentsline {subsubsection}{\numberline {2.3.5}Other properties than the Gibbs energy}{17} +\contentsline {subsection}{\numberline {2.4}Components}{18} +\contentsline {subsection}{\numberline {2.5}Fraction sets}{19} +\contentsline {subsection}{\numberline {2.6}Composition sets and miscibility gaps}{20} +\contentsline {subsection}{\numberline {2.7}State variables}{21} +\contentsline {section}{\numberline {3}Fortran Data Structures}{23} +\contentsline {subsection}{\numberline {3.1}User defined data types}{23} +\contentsline {subsection}{\numberline {3.2}Bits of information}{24} +\contentsline {subsubsection}{\numberline {3.2.1}Phase record bits}{25} +\contentsline {subsubsection}{\numberline {3.2.2}Some more bits}{26} +\contentsline {subsubsection}{\numberline {3.2.3}Phase status revision}{27} +\contentsline {subsection}{\numberline {3.3}Dimensioning}{27} +\contentsline {subsubsection}{\numberline {3.3.1}User defined additions}{28} +\contentsline {section}{\numberline {4}Data structures declared in GTP}{29} +\contentsline {subsection}{\numberline {4.1}Global data}{29} +\contentsline {subsection}{\numberline {4.2}Version identification of the data structure}{29} +\contentsline {subsection}{\numberline {4.3}The ELEMENT data type}{29} +\contentsline {subsection}{\numberline {4.4}Species}{31} +\contentsline {subsection}{\numberline {4.5}Components}{32} +\contentsline {subsection}{\numberline {4.6}Phase datatypes}{32} +\contentsline {subsubsection}{\numberline {4.6.1}Permutations of constituents}{34} +\contentsline {subsubsection}{\numberline {4.6.2}Property types for different fraction sets}{35} +\contentsline {subsubsection}{\numberline {4.6.3}Selected\_element\_reference}{36} +\contentsline {subsubsection}{\numberline {4.6.4}The endmember record}{36} +\contentsline {subsubsection}{\numberline {4.6.5}The interaction record}{38} +\contentsline {subsubsection}{\numberline {4.6.6}The property record}{39} +\contentsline {subsubsection}{\numberline {4.6.7}Bibliographic references}{40} +\contentsline {subsubsection}{\numberline {4.6.8}Parameter property identification}{40} +\contentsline {subsubsection}{\numberline {4.6.9}Additions to the Gibbs energy}{41} +\contentsline {subsubsection}{\numberline {4.6.10}The elastic model}{42} +\contentsline {subsubsection}{\numberline {4.6.11}The phase and composition set indices}{42} +\contentsline {subsubsection}{\numberline {4.6.12}The phase record}{43} +\contentsline {subsection}{\numberline {4.7}State variables and the state variable record}{45} +\contentsline {section}{\numberline {5}Error handling}{46} +\contentsline {section}{\numberline {6}Calculations}{46} +\contentsline {subsection}{\numberline {6.1}Conditions}{46} +\contentsline {subsection}{\numberline {6.2}State variable functions}{47} +\contentsline {subsection}{\numberline {6.3}Fraction sets}{48} +\contentsline {subsection}{\numberline {6.4}The phase\_varres record for composition sets}{49} +\contentsline {subsection}{\numberline {6.5}The equilibrium record}{51} +\contentsline {section}{\numberline {7}Records with data shared by several subroutines}{53} +\contentsline {subsection}{\numberline {7.1}Parsing data}{53} +\contentsline {subsection}{\numberline {7.2}Fraction product stack}{54} +\contentsline {subsection}{\numberline {7.3}STEP and MAP results data structures}{54} +\contentsline {subsubsection}{\numberline {7.3.1}The node point record}{54} +\contentsline {subsubsection}{\numberline {7.3.2}The head record}{55} +\contentsline {section}{\numberline {8}Global variables}{56} +\contentsline {section}{\numberline {9}Subroutines and functions}{56} +\contentsline {subsection}{\numberline {9.1}Variable names}{57} +\contentsline {subsection}{\numberline {9.2}Initiallization}{57} +\contentsline {subsection}{\numberline {9.3}Functions to know how many}{57} +\contentsline {subsubsection}{\numberline {9.3.1}How many state variable functions}{58} +\contentsline {subsubsection}{\numberline {9.3.2}How many equilibria}{58} +\contentsline {subsubsection}{\numberline {9.3.3}Total number of phases and composition sets}{58} +\contentsline {subsection}{\numberline {9.4}Find things}{58} +\contentsline {subsubsection}{\numberline {9.4.1}Find constituent name}{60} +\contentsline {subsubsection}{\numberline {9.4.2}Find and select equilibrium}{60} +\contentsline {subsection}{\numberline {9.5}Get things}{61} +\contentsline {subsubsection}{\numberline {9.5.1}Get phase constituent name}{61} +\contentsline {subsubsection}{\numberline {9.5.2}Get element data}{62} +\contentsline {subsubsection}{\numberline {9.5.3}Get component or species name}{62} +\contentsline {subsubsection}{\numberline {9.5.4}Get species data}{62} +\contentsline {subsubsection}{\numberline {9.5.5}Mass of component}{63} +\contentsline {subsubsection}{\numberline {9.5.6}Get phase name}{63} +\contentsline {subsubsection}{\numberline {9.5.7}Get phase data}{64} +\contentsline {subsubsection}{\numberline {9.5.8}Phase tuple array}{64} +\contentsline {subsection}{\numberline {9.6}Set things}{65} +\contentsline {subsubsection}{\numberline {9.6.1}Set constitution}{65} +\contentsline {subsubsection}{\numberline {9.6.2}Set reference state for a component}{65} +\contentsline {subsubsection}{\numberline {9.6.3}Set condition}{65} +\contentsline {subsection}{\numberline {9.7}Enter data}{66} +\contentsline {subsubsection}{\numberline {9.7.1}Enter element data}{66} +\contentsline {subsubsection}{\numberline {9.7.2}Enter species data}{66} +\contentsline {subsubsection}{\numberline {9.7.3}Enter phase and model}{66} +\contentsline {subsubsection}{\numberline {9.7.4}Sorting constituents in ionic liquids}{67} +\contentsline {subsubsection}{\numberline {9.7.5}Enter composition set}{67} +\contentsline {subsubsection}{\numberline {9.7.6}Remove composition set}{68} +\contentsline {subsubsection}{\numberline {9.7.7}Enter parameter}{68} +\contentsline {subsubsection}{\numberline {9.7.8}Subroutines handling fcc permutations}{69} +\contentsline {subsubsection}{\numberline {9.7.9}Subroutines handling bcc permutations}{71} +\contentsline {subsubsection}{\numberline {9.7.10}Find constituent}{71} +\contentsline {subsubsection}{\numberline {9.7.11}Enter references for parameter data}{71} +\contentsline {subsubsection}{\numberline {9.7.12}Enter equilibrium}{72} +\contentsline {subsubsection}{\numberline {9.7.13}Delete equilibrium}{72} +\contentsline {subsubsection}{\numberline {9.7.14}Copy equilibrium}{72} +\contentsline {subsubsection}{\numberline {9.7.15}Copy condition}{73} +\contentsline {subsubsection}{\numberline {9.7.16}Check that a phase is allowed to have fcc permutations}{73} +\contentsline {subsection}{\numberline {9.8}List things}{73} +\contentsline {subsubsection}{\numberline {9.8.1}List data for all elements}{73} +\contentsline {subsubsection}{\numberline {9.8.2}List data for all components}{74} +\contentsline {subsubsection}{\numberline {9.8.3}List data for one element}{74} +\contentsline {subsubsection}{\numberline {9.8.4}List data for one species}{74} +\contentsline {subsubsection}{\numberline {9.8.5}List data for all species}{75} +\contentsline {subsubsection}{\numberline {9.8.6}List a little data for all phases}{75} +\contentsline {subsubsection}{\numberline {9.8.7}List global results}{75} +\contentsline {subsubsection}{\numberline {9.8.8}List components result}{75} +\contentsline {subsubsection}{\numberline {9.8.9}List all phases with positive dgm}{75} +\contentsline {subsubsection}{\numberline {9.8.10}List results for one phase}{76} +\contentsline {subsubsection}{\numberline {9.8.11}Format output for constitution}{76} +\contentsline {subsubsection}{\numberline {9.8.12}List data on SCREEN or TDB, LaTeX or macro format}{76} +\contentsline {subsubsection}{\numberline {9.8.13}List some phase model stuff}{77} +\contentsline {subsubsection}{\numberline {9.8.14}List all parameter data for a phase}{77} +\contentsline {subsubsection}{\numberline {9.8.15}Format expression of references for endmembers}{77} +\contentsline {subsubsection}{\numberline {9.8.16}Encode stoichiometry of species}{78} +\contentsline {subsubsection}{\numberline {9.8.17}Decode stoichiometry of species}{78} +\contentsline {subsubsection}{\numberline {9.8.18}Encode constituent array for parameters}{78} +\contentsline {subsubsection}{\numberline {9.8.19}Decode constituent array for parameters}{78} +\contentsline {subsubsection}{\numberline {9.8.20}List parameter data references}{79} +\contentsline {subsubsection}{\numberline {9.8.21}List conditions on a file or screen}{79} +\contentsline {subsubsection}{\numberline {9.8.22}Extract one conditions in a character veriable}{79} +\contentsline {subsubsection}{\numberline {9.8.23}List condition in character variable}{79} +\contentsline {subsubsection}{\numberline {9.8.24}List available parameter identifiers}{80} +\contentsline {subsubsection}{\numberline {9.8.25}Find defined properties}{80} +\contentsline {subsubsection}{\numberline {9.8.26}List some odd details}{80} +\contentsline {subsection}{\numberline {9.9}Interactive subroutines}{81} +\contentsline {subsubsection}{\numberline {9.9.1}Ask for phase constitution}{81} +\contentsline {subsubsection}{\numberline {9.9.2}Ask for parameter}{81} +\contentsline {subsubsection}{\numberline {9.9.3}Amend global bits}{81} +\contentsline {subsubsection}{\numberline {9.9.4}Ask for reference of parameter data}{82} +\contentsline {subsubsection}{\numberline {9.9.5}Set a condition}{82} +\contentsline {subsubsection}{\numberline {9.9.6}Get condition record}{82} +\contentsline {subsubsection}{\numberline {9.9.7}A utility routine to locate a condition record}{84} +\contentsline {subsubsection}{\numberline {9.9.8}A utility routine to get the current value of a condition}{84} +\contentsline {subsubsection}{\numberline {9.9.9}Ask for new set of components}{84} +\contentsline {subsubsection}{\numberline {9.9.10}Ask for default phase constitution}{85} +\contentsline {subsubsection}{\numberline {9.9.11}Interactive set input amounts}{85} +\contentsline {subsubsection}{\numberline {9.9.12}Utility to decode a parameter identifier}{85} +\contentsline {subsection}{\numberline {9.10}Save and read data from files}{86} +\contentsline {subsubsection}{\numberline {9.10.1}Save all data}{86} +\contentsline {subsubsection}{\numberline {9.10.2}Save all data again}{86} +\contentsline {subsubsection}{\numberline {9.10.3}Save data for a phase}{87} +\contentsline {subsubsection}{\numberline {9.10.4}Save data for an equilibrium record}{87} +\contentsline {subsubsection}{\numberline {9.10.5}Save the state variable functions on file}{87} +\contentsline {subsubsection}{\numberline {9.10.6}Save the bibliographic references on file}{87} +\contentsline {subsubsection}{\numberline {9.10.7}Read data from a saved file}{87} +\contentsline {subsubsection}{\numberline {9.10.8}Reading unformatted data for a phase}{88} +\contentsline {subsubsection}{\numberline {9.10.9}Read unformatted data for an endmember}{88} +\contentsline {subsubsection}{\numberline {9.10.10}Read unformatted data for a property}{88} +\contentsline {subsubsection}{\numberline {9.10.11}Read unformatted data for an interaction}{88} +\contentsline {subsubsection}{\numberline {9.10.12}Read unformatted data for an equilibrium}{89} +\contentsline {subsubsection}{\numberline {9.10.13}Read state variable functions}{89} +\contentsline {subsubsection}{\numberline {9.10.14}Read reference records}{89} +\contentsline {subsubsection}{\numberline {9.10.15}Erase all data}{89} +\contentsline {subsubsection}{\numberline {9.10.16}Delete a phase}{89} +\contentsline {subsubsection}{\numberline {9.10.17}Yet another utility routine}{90} +\contentsline {subsubsection}{\numberline {9.10.18}And another utility routine}{90} +\contentsline {subsubsection}{\numberline {9.10.19}Read a TDB file}{90} +\contentsline {subsubsection}{\numberline {9.10.20}Check a TDB file exists and extract elements}{90} +\contentsline {subsection}{\numberline {9.11}State variable stuff}{91} +\contentsline {subsubsection}{\numberline {9.11.1}Get state variable value given its symbol}{91} +\contentsline {subsubsection}{\numberline {9.11.2}Get many state variable values}{91} +\contentsline {subsubsection}{\numberline {9.11.3}Decode a state variable symbol}{92} +\contentsline {subsubsection}{\numberline {9.11.4}Calculate molar and mass properties for a phase}{94} +\contentsline {subsubsection}{\numberline {9.11.5}Calculate molar amounts for a phase}{94} +\contentsline {subsubsection}{\numberline {9.11.6}Sum molar and mass properties for all phases}{94} +\contentsline {subsubsection}{\numberline {9.11.7}Sum all normalizing property values}{95} +\contentsline {subsubsection}{\numberline {9.11.8}Encode state variable}{95} +\contentsline {subsubsection}{\numberline {9.11.9}Encode a state variable record}{96} +\contentsline {subsubsection}{\numberline {9.11.10}Calculate state variable value}{96} +\contentsline {subsubsection}{\numberline {9.11.11}The value of the user defined reference state}{97} +\contentsline {subsection}{\numberline {9.12}State variable functions}{97} +\contentsline {subsubsection}{\numberline {9.12.1}Enter a state variable function}{97} +\contentsline {subsubsection}{\numberline {9.12.2}List a state variable function}{98} +\contentsline {subsubsection}{\numberline {9.12.3}Utility subroutine for state variable functions}{99} +\contentsline {subsubsection}{\numberline {9.12.4}List all state variable functions}{99} +\contentsline {subsubsection}{\numberline {9.12.5}Some depreciated routines}{99} +\contentsline {subsection}{\numberline {9.13}Status for things}{100} +\contentsline {subsubsection}{\numberline {9.13.1}Set status for elements}{100} +\contentsline {subsubsection}{\numberline {9.13.2}Test status for element}{100} +\contentsline {subsubsection}{\numberline {9.13.3}Set status for species}{100} +\contentsline {subsubsection}{\numberline {9.13.4}Test status for species}{101} +\contentsline {subsubsection}{\numberline {9.13.5}Get and test status for phase}{101} +\contentsline {subsubsection}{\numberline {9.13.6}Set/unset/test phase model bit}{101} +\contentsline {subsubsection}{\numberline {9.13.7}Change status for phase}{102} +\contentsline {subsubsection}{\numberline {9.13.8}Set unit for energy etc.}{102} +\contentsline {subsubsection}{\numberline {9.13.9}Save results for a phase}{103} +\contentsline {subsubsection}{\numberline {9.13.10}Set reference state for constituent}{103} +\contentsline {subsubsection}{\numberline {9.13.11}Calculate conversion matrix for new components}{103} +\contentsline {subsection}{\numberline {9.14}Internal stuff}{103} +\contentsline {subsubsection}{\numberline {9.14.1}Alphabetical ordering}{103} +\contentsline {subsubsection}{\numberline {9.14.2}Check alphaindex}{104} +\contentsline {subsubsection}{\numberline {9.14.3}Creates a list of constituents of a phase}{104} +\contentsline {subsubsection}{\numberline {9.14.4}Creates a new parrecord for a phase}{104} +\contentsline {subsubsection}{\numberline {9.14.5}Create interaction record}{105} +\contentsline {subsubsection}{\numberline {9.14.6}Create endmember record}{105} +\contentsline {subsubsection}{\numberline {9.14.7}Create property record}{105} +\contentsline {subsubsection}{\numberline {9.14.8}Extend property record}{106} +\contentsline {subsubsection}{\numberline {9.14.9}Create a new phase\_varres record}{106} +\contentsline {subsubsection}{\numberline {9.14.10}Add a disordered fraction set record}{106} +\contentsline {subsubsection}{\numberline {9.14.11}Add a fraction set record}{107} +\contentsline {subsubsection}{\numberline {9.14.12}Copy record for fraction sets}{108} +\contentsline {subsubsection}{\numberline {9.14.13}Implicit suspend and restore}{108} +\contentsline {subsubsection}{\numberline {9.14.14}Add to reference phase}{108} +\contentsline {subsection}{\numberline {9.15}Additions}{109} +\contentsline {subsubsection}{\numberline {9.15.1}Generic subroutine to add an addition}{109} +\contentsline {subsubsection}{\numberline {9.15.2}Utility routine for addition}{109} +\contentsline {subsubsection}{\numberline {9.15.3}Enter and calculate Inden magnetic model}{110} +\contentsline {subsubsection}{\numberline {9.15.4}Create new magnetic model}{110} +\contentsline {subsubsection}{\numberline {9.15.5}Calculate and calculate elastic contribution}{111} +\contentsline {subsubsection}{\numberline {9.15.6}Heat capacity model for Einstein solids}{112} +\contentsline {subsubsection}{\numberline {9.15.7}Glas addition}{112} +\contentsline {subsubsection}{\numberline {9.15.8}Debye heat capacity model}{112} +\contentsline {subsubsection}{\numberline {9.15.9}List additions}{113} +\contentsline {subsection}{\numberline {9.16}Calculation}{113} +\contentsline {subsubsection}{\numberline {9.16.1}Calculate for one phase}{114} +\contentsline {subsubsection}{\numberline {9.16.2}Model independent routine for one phase calculation}{114} +\contentsline {subsubsection}{\numberline {9.16.3}A utility routine}{114} +\contentsline {subsubsection}{\numberline {9.16.4}Calculate and list results for one phase}{115} +\contentsline {subsubsection}{\numberline {9.16.5}Calculate an interaction parameter}{115} +\contentsline {subsubsection}{\numberline {9.16.6}Calculate ideal configurational entropy}{115} +\contentsline {subsubsection}{\numberline {9.16.7}Calculate ionic liquid configurational entropy}{116} +\contentsline {subsubsection}{\numberline {9.16.8}Push/pop constituent fraction product on stack}{116} +\contentsline {subsubsection}{\numberline {9.16.9}Calculate disordered fractions from constituent fractions}{116} +\contentsline {subsubsection}{\numberline {9.16.10}Disorder constituent fractions}{117} +\contentsline {subsubsection}{\numberline {9.16.11}Set driving force for a phase explicitly}{117} +\contentsline {subsubsection}{\numberline {9.16.12}Extract massbalance conditions}{117} +\contentsline {subsubsection}{\numberline {9.16.13}Saving and restoring a phase constitution}{118} +\contentsline {subsection}{\numberline {9.17}Grid minimizer}{118} +\contentsline {subsubsection}{\numberline {9.17.1}Global Gridminimizer}{119} +\contentsline {subsubsection}{\numberline {9.17.2}Generate grid}{119} +\contentsline {subsubsection}{\numberline {9.17.3}Calculate gridpoint}{120} +\contentsline {subsubsection}{\numberline {9.17.4}Calculate endmember}{120} +\contentsline {subsubsection}{\numberline {9.17.5}Calculate minimum of grid}{121} +\contentsline {subsubsection}{\numberline {9.17.6}Merge gridpoints in same phase}{121} +\contentsline {subsubsection}{\numberline {9.17.7}Set constitution of metastable phases}{122} +\contentsline {subsection}{\numberline {9.18}Miscellaneous things}{123} +\contentsline {subsubsection}{\numberline {9.18.1}Phase record location}{123} +\contentsline {subsubsection}{\numberline {9.18.2}Numbers an interaction tree for permutations}{123} +\contentsline {subsubsection}{\numberline {9.18.3}Check that certain things are allowed}{123} +\contentsline {subsubsection}{\numberline {9.18.4}Check proper symbol}{123} +\contentsline {subsubsection}{\numberline {9.18.5}Set default constitution}{124} +\contentsline {subsubsection}{\numberline {9.18.6}The amount of a phase is set to a value}{124} +\contentsline {subsubsection}{\numberline {9.18.7}Set the default constitution of a phase}{124} +\contentsline {subsubsection}{\numberline {9.18.8}Subroutine to prepare for an equilibrium calculation}{125} +\contentsline {subsubsection}{\numberline {9.18.9}Subroutine to clean up after an equilibrium calculation}{125} +\contentsline {subsubsection}{\numberline {9.18.10}Select composition set for stable phase}{126} +\contentsline {subsubsection}{\numberline {9.18.11}Select composition set for stable phase, maybe not used}{126} +\contentsline {subsection}{\numberline {9.19}Unfinished things}{127} +\contentsline {section}{\numberline {10}TP functions}{127} +\contentsline {subsection}{\numberline {10.1}Function root record type}{127} +\contentsline {subsection}{\numberline {10.2}Structure to store expressions of TP functions}{128} +\contentsline {subsection}{\numberline {10.3}Structure for calculated results of TP functions}{128} +\contentsline {section}{\numberline {11}Summary}{129} diff --git a/documentationupdate/minpack5.tex b/documentation/minpack5.tex similarity index 79% rename from documentationupdate/minpack5.tex rename to documentation/minpack5.tex index 815592a..e0e72e3 100644 --- a/documentationupdate/minpack5.tex +++ b/documentation/minpack5.tex @@ -20,7 +20,7 @@ multi-component systems with -many different models for non-ideal Phases. +many different models for non-ideal phases. } @@ -84,10 +84,12 @@ \section{Introduction} in a paper by Lukas~\cite{82Luk}. These papers give the theoretical background of the algorithm but they are very dense and difficult to understand. In this paper the algorithm and its implementation is -explained in more detail. +explained in more detail, see also Sundman et al.\cite{15Sun2}. Some +corrections and extentions comparated to the published version are +included in this text. The implementation is done as part of the Open Calphad -initiative~\cite{11Kat} to provide a free software for thermodynamic +initiative~\cite{15Sun1} to provide a free software for thermodynamic calculations. This software will provide a useful link between experimental work, first principle calculations and applications like simulatons of phase transformations and microstructures using phase @@ -128,7 +130,7 @@ \section{The thermodynamic model} Each phase can be described with a different model but the explanations in this paper will mainly concern phases modelled with -the compound energy formalism (CEF)~\cite{81Sun,90Hil}. This include +the compound energy formalism (CEF)~\cite{81Sun,01Hil}. This include as special gases ideal gases, substitutional regular soultions, interstitial solutions, sublattice models etc. Some additional explanations will be given for the ionic liquid model~\cite{84Hil}. @@ -174,7 +176,7 @@ \subsection{The formula unit of a phase} The total number of moles of components in a formula unit of the phase is thus: \begin{equation} -M^{\alpha} = \sum_{\rm A} M_{\rm A}^{\alpha} +M^{\alpha} = \sum_{\rm A} M_{\rm A}^{\alpha} \label{eq:molesperfu} \end{equation} and the mole fraction is \begin{equation} @@ -527,10 +529,10 @@ \subsection{The constraints} and the thermodynamic parameters in the second case must be 4 times larger than those in the first. -\subsection{The Lagrangian} +\subsection{The Lagrangian equation} To minimize the Gibbs energy of a system with constraints we can use a -Lagrangian as +Lagrangian equation as: \begin{equation} L = G + \sum_{\rm A} f_{\rm A} \mu_{\rm A} + @@ -1045,13 +1047,13 @@ \subsection{Step 2, the external conditions} these. For each stable phase $\alpha$ we will have an equation: - \begin{equation} G_M^{\alpha} = \sum_{\rm A} M^{\alpha}_{\rm A}\mu_{\rm A} \label{eq:gmalpha} \end{equation} -For equilibrium calculations with variable $T$ and $P$ we must take -into account any changes in these: +This ensures that all stable phases are on the same hyperplane of +chemical potentials. For equilibrium calculations with variable $T$ +and $P$ we must take into account any changes in these: \begin{equation} G_M^{\alpha} = \sum_{\rm A} M^{\alpha}_{\rm A}\mu_{\rm A} @@ -1111,6 +1113,18 @@ \subsubsection{Condition on the amount of the components}\label{sc:step2} \label{eq:diffmnoTP} \end{eqnarray} +Inserting the expression for $c_{i\rm X}$ gives +\begin{eqnarray} +\Delta M_{\rm A} = +\sum_{\rm B} \mu_{\rm B} +\sum_i \frac{\partial M_{\rm A}}{\partial y_i}\sum_j\frac{\partial M_{\rm B}}{\partial y_j}e_{ij} - +\sum_i \frac{\partial M_{\rm A}}{\partial y_i}\sum_j\frac{\partial G_M}{\partial y_j}e_{ij}\nonumber\\ +\Delta M_{\rm A} = +\sum_{\rm B} \left(\sum_i \sum_j e_{ij}\frac{\partial M_{\rm A}}{\partial y_i}\frac{\partial M_{\rm B}}{\partial y_j}\right)\mu_{\rm B}- +\sum_i\sum_j e_{ij}\frac{\partial M_{\rm A}}{\partial y_i}\sum_j\frac{\partial G_M}{\partial y_j} +\label{eq:diffmnoTP2} +\end{eqnarray} + \subsubsection{Example: a binary system with a single stable phasse} If apply this to a binary A-B system with just one stable phase the @@ -1118,19 +1132,22 @@ \subsubsection{Example: a binary system with a single stable phasse} for each component we can insert this in eq.~\ref{eq:diffN1}: \begin{eqnarray} -\Delta N_{\rm A}&=&\aleph \left( +\Delta N_{\rm A}=\aleph \left( \sum_{\rm B} \mu_{\rm B} \sum_i \frac{\partial M_{\rm A}}{\partial y_i} c_{i{\rm B}} - \sum_i \frac{\partial M_{\rm A}}{\partial y_i} c_{iG}\right) + -\Delta \aleph M_{\rm A} = 0 +\Delta \aleph M_{\rm A} &=& N_{\rm A} - \tilde N_{\rm A} = 0 \end{eqnarray} -and rearranging the terms we have for each element: +In the published paper, \cite{15Sun2}, the difference $N_{\rm + A}-\tilde N_{\rm A}$ was forgotten. Rearranging the terms we have +for each element: \begin{eqnarray} -\aleph \sum_i \frac{\partial M_{\rm A}}{\partial y_i} c_{iG} &=& \aleph \sum_{\rm B} \mu_{\rm B} \sum_i \frac{\partial M_{\rm A}}{\partial y_i} c_{i{\rm B}}+ -\Delta \aleph M_{\rm A}\label{eq:diffN2} +\Delta \aleph M_{\rm A} &=& +\aleph \sum_i \frac{\partial M_{\rm A}}{\partial y_i} c_{iG} + N_{\rm A}-\tilde N_{\rm A} +\label{eq:diffN2} \end{eqnarray} Again, the sum over $i$ should be for all constituents in all @@ -1162,8 +1179,8 @@ \subsubsection{Example: a binary system with a single stable phasse} \left( \begin{tabular}{c} $G_M$\\ -$\aleph \sum_i \frac{\partial M_{\rm A}}{\partial y_i} c_{iG}$\\ -$\aleph \sum_i \frac{\partial M_{\rm B}}{\partial y_i} c_{iG}$\\ +$\aleph \sum_i \frac{\partial M_{\rm A}}{\partial y_i} c_{iG}+N_{\rm A}-\tilde N_{\rm A}$\\ +$\aleph \sum_i \frac{\partial M_{\rm B}}{\partial y_i} c_{iG}+N_{\rm B}-\tilde N_{\rm B}$\\ \end{tabular} \right) \\ (\ref{eq:systemmatrix1}) @@ -1232,14 +1249,16 @@ \subsubsection{Example: a binary system with two stable phases} $\Delta \aleph^{\beta}$ \end{tabular} \right) -= +=\] + +\[ \left( \begin{tabular}{c} $G_M^{\alpha}$\\ $G_M^{\beta}$\\ -$\sum_{\varphi}\aleph^{\varphi} \sum_i \frac{\partial M^{\varphi}_{\rm A}}{\partial y_i^{\varphi}} c^{\varphi}_{iG}$\\ +$\sum_{\varphi}\aleph^{\varphi} \sum_i \frac{\partial M^{\varphi}_{\rm A}}{\partial y_i^{\varphi}} c^{\varphi}_{iG}+N_{\rm A}-\tilde N_{\rm A}$\\ $\sum_{\varphi}\aleph^{\varphi} \sum_i -\frac{\partial M^{\varphi}_{\rm B}}{\partial y_i^{\varphi}} c^{\varphi}_{iG}$\\ +\frac{\partial M^{\varphi}_{\rm B}}{\partial y_i^{\varphi}} c^{\varphi}_{iG}+N_{\rm B}-\tilde N_{\rm B}$\\ \end{tabular} \right) \\ (\ref{eq:systemmatrix2}) @@ -1309,13 +1328,15 @@ \subsubsection{Example: a binary system with unknown $T$ and one $\Delta T$ \end{tabular} \right) -= +=\] + +\[ \left( \begin{tabular}{c} $G_M^{\alpha}$\\ $G_M^{\beta}$\\ -$\aleph^{\alpha} \sum_i \frac{\partial M^{\alpha}_{\rm A}}{\partial y_i^{\alpha}} c^{\alpha}_{iG}$\\ -$\aleph^{\alpha} \sum_i \frac{\partial M^{\alpha}_{\rm B}}{\partial y_i^{\alpha}} c^{\alpha}_{iG}$\\ +$\aleph^{\alpha} \sum_i \frac{\partial M^{\alpha}_{\rm A}}{\partial y_i^{\alpha}} c^{\alpha}_{iG}+N_{\rm A}-\tilde N_{\rm A}$\\ +$\aleph^{\alpha} \sum_i \frac{\partial M^{\alpha}_{\rm B}}{\partial y_i^{\alpha}} c^{\alpha}_{iG}+N_{\rm B}-\tilde N_{\rm B}$\\ \end{tabular} \right) \\ (\ref{eq:systemmatrix3}) @@ -1362,7 +1383,7 @@ \subsubsection{Example: a binary system with one condition of $G^{\beta}_M - M^{\beta}_{\rm B}\mu_{\rm B}$\\ $\sum_{\varphi}\aleph^{\varphi} \sum_i \frac{\partial M^{\varphi}_{\rm A}}{\partial y_i^{\varphi}} -( c^{\varphi}_{iG} - c^{\varphi}_{iB}\mu_{\rm B})$ +( c^{\varphi}_{iG} - c^{\varphi}_{iB}\mu_{\rm B})+N_{\rm A}-\tilde N_{\rm A}$ \end{tabular} \right) \\ (\ref{eq:systemmatrix4}) @@ -1370,55 +1391,258 @@ \subsubsection{Example: a binary system with one condition of The summation over $\varphi$ is over all stable phases. -\subsection{Changing the set of stable phases}\label{sc:changeps} +\subsection{Condition on volume} -When the amount of a stable phase becomes negative at an iteration it -means this phase should be removed from the set of stable phases. And -if the driving force for an unstable phase according to -eq.~\ref{eq:dgm1} becomes positive that phase should be added. +If the volume is prescribed as constant, $\tilde V$, we have an +equation: +\begin{eqnarray} +dV &=& V - \tilde V= 0 +\end{eqnarray} +where +\begin{eqnarray} +V &=& \sum_{\alpha} \aleph^{\alpha} V_M^{\alpha}\\ +V^{\alpha}_M &=& \left(\frac{\partial G^{\alpha}_M}{\partial P}\right)_{T,Y} +\end{eqnarray} -\begin{equation} -\gamma^{\psi} = \sum_{\rm A} \mu_{\rm A} M_{\rm A}^{\psi_i} - G^{\psi}_M \label{eq:dgm2} -\end{equation} -where the sum over A is for all components. If $T$ and $P$ are -variable the $\Delta T$ and $\Delta P$ are also included in this -equation as in eq.~\ref{eq:gmalpha2}. +It is not necessary to have variable $P$, we may be able to change the +volume even at constant $P$, for example by varying the amount of +phases with different molar volumes or having a condition on a +chemical potential which can change the amount of material in the +system. We expand the differential of $dV = \Delta V$ as: +\begin{eqnarray} +\Delta V &=& \sum_{\alpha} \aleph^{\alpha} \left(\frac{\partial^2 G^{\alpha}_M}{\partial P\partial T} \Delta T + +\frac{\partial^2 G^{\alpha}_M}{\partial P^2} \Delta P + +\sum_i\frac{\partial^2 G^{\alpha}_M}{\partial P\partial y^{\alpha}_{i}} \Delta y^{\alpha}_i\right) + +\sum_{\alpha} \frac{\partial G^{\alpha}_M}{\partial P} \Delta\aleph^{\alpha}\nonumber\\&=& +\sum_{\alpha} \aleph^{\alpha} \left( +\sum_{\rm A}\sum_i\frac{\partial^2 G^{\alpha}_M}{\partial P\partial y^{\alpha}_{i}}c_{iA}\mu_{\rm A}+ +\left[\frac{\partial^2 G^{\alpha}_M}{\partial P\partial T}+ +\sum_i\frac{\partial^2 G^{\alpha}_M}{\partial P\partial y^{\alpha}_{i}}c_{iT}\right]\Delta T+\right.\nonumber\\&& +\left.\left[\frac{\partial^2 G^{\alpha}_M}{\partial P^2} \Delta P+ +\sum_i\frac{\partial^2 G^{\alpha}_M}{\partial P\partial y^{\alpha}_{i}}c_{iP}\right]\Delta P + \sum_i\frac{\partial^2 G^{\alpha}_M}{\partial P\partial y^{\alpha}_{i}}c_{iG}\right) ++\sum_{\alpha} \frac{\partial G^{\alpha}_M}{\partial P} \Delta\aleph^{\alpha}\nonumber\\&=& +V - \tilde V = 0\label{eq:vcond} +\end{eqnarray} +where $\Delta y_i$ can be expressed as a function of $\Delta T, \Delta +P$ and $\mu_{\rm A}$ using eq. \ref{eq:deltay}. Rearranging the equation +for the equilibrium matrix for the unknown $\Delta T, \Delta P$ +and $\mu_{\rm A}$ gives: +\begin{eqnarray} +\sum_{\alpha} \aleph^{\alpha} +\sum_{\rm A}\sum_i\frac{\partial^2 G^{\alpha}_M}{\partial P\partial y^{\alpha}_{i}}c_{iA}\mu_{\rm A}+ +\sum_{\alpha} \aleph^{\alpha} +\left(\frac{\partial^2 G^{\alpha}_M}{\partial P\partial T}+ +\sum_i\frac{\partial^2 G^{\alpha}_M}{\partial P\partial y^{\alpha}_{i}}c_{iT}\right)\Delta T&+&\nonumber\\ +\sum_{\alpha} \aleph^{\alpha} +\left(\frac{\partial^2 G^{\alpha}_M}{\partial P^2} + +\sum_i\frac{\partial^2 G^{\alpha}_M}{\partial P\partial y^{\alpha}_{i}}c_{iP}\right)\Delta P ++\sum_{\alpha} \frac{\partial G^{\alpha}_M}{\partial P} \Delta\aleph^{\alpha}&=&\nonumber\\ +-\sum_{\alpha}\aleph^{\alpha}\sum_i\frac{\partial^2 G^{\alpha}_M}{\partial P\partial y^{\alpha}_{i}}c_{iG} ++V - \tilde V\label{eq:vcond2} +\end{eqnarray} -This is basically a trivial operation but we should take care that -the same phase is removed and added at every second iteration. -Normally we should allow a few iterations after a change in the -set of stable phases before another change is allowed. +In the next sections we will not specify the phase when obvious. -It can also happen that the amount of the single stable phase becomes -negative and it is clearly impossible to have a system without a -single stable phase. This may indicate that the set of external -conditions are unreasonable or that the model parameters are wrong. +\subsection{Constant Gibbs energy or entropy} -A third case that may case problem is when more phases become stable -than allowed by the Gibbs phase rule: +It would be rare to have a condition on the Gibbs energy or entropy of +the system but as preparetion for a heat balance equation I will start +by that. In the same way as for the volume the equation is: +\begin{eqnarray} +dG &=& G-\tilde G = 0 +\end{eqnarray} +where +\begin{eqnarray} +G &=& \sum_{\alpha} \aleph^{\alpha} G_M^{\alpha}\\ +G^{\alpha}_M &=& \sum_{\rm A} M^{\alpha}_{\rm A} \mu_{\rm A}\\ +dG^{\alpha}_M &=& \sum_{\rm A} dM^{\alpha}_{\rm A} \mu_{\rm A} +\end{eqnarray} +where we can approximate $dM^{\alpha}_{\rm A} = \Delta M^{\alpha}_{\rm + A}$ as in eq.~\ref{eq:diffm2}. As we are only dealing with linear +changes all terms multiplied with two potentials or potential +differences are ignored and in the equation we keep only: +\begin{eqnarray} +dG = \sum_{\alpha} \aleph^{\alpha}\sum_{\rm A} \sum_i \frac{\partial M^{\alpha}_{\rm A}}{\partial y_i}c_{iG}\mu_{\rm A} &=& G - \tilde G = 0\label{eq:gcond1} +\end{eqnarray} -\begin{equation} -f = n - p + 2 -\end{equation} -where $f$ is the degrees of freedom, $n$ number of components, $p$ -number of stable phases and 2 represent variable $T$ and $P$. In -order to calculate an equilibrium we must have set so many conditions -that $f$ is zero. For a binary system that means 4 conditions. If -one condition is constant $P$, we can at most have 3 phases stable. +This looks nice and simple but maybe not so useful. For a condition +on the entropy we have +\begin{eqnarray} +dS &=& S-\tilde S = 0 +\end{eqnarray} +where +\begin{eqnarray} +S &=& \sum_{\alpha} \aleph^{\alpha} S_M^{\alpha}\\ +S^{\alpha}_M &=& -\left(\frac{\partial G^{\alpha}_M}{\partial T}\right)_{P,Y} = +-\frac{\partial }{\partial T}\left(\sum_{\rm A} M^{\alpha}_{\rm A} \mu_{\rm A}\right)= +-\sum_{\rm A} M^{\alpha}_{\rm A} \frac{\partial \mu_{\rm A}}{\partial T}\\ +dS^{\alpha}_M &=& -\sum_{\rm A} dM^{\alpha}_{\rm A} \frac{\partial \mu_{\rm A}}{\partial T} +\end{eqnarray} +but I have no idea how to calculate $\frac{\partial \mu_{\rm A}}{\partial T}$. +This must be the wrong track. If we do not introduce the chemical +potentials we can write +\begin{eqnarray} +dS_M^{\alpha} = -\frac{\partial^2 G^{\alpha}_M}{\partial T^2}\Delta T- +\frac{\partial^2 G^{\alpha}_M}{\partial T\partial P}\Delta P- +\sum_i\frac{\partial^2 G^{\alpha}_M}{\partial T\partial y_i}\Delta y_i +\end{eqnarray} +and we can formulate an equation as we did for the volume in +eq.~\ref{eq:vcond}: +\begin{eqnarray} +dS &=& -\sum_{\alpha} \aleph^{\alpha} \left(\frac{\partial^2 G^{\alpha}_M}{\partial T^2} \Delta T + +\frac{\partial^2 G^{\alpha}_M}{\partial T\partial P} \Delta P + +\sum_i\frac{\partial^2 G^{\alpha}_M}{\partial T\partial y_{i}} \Delta y_i\right) - +\sum_{\alpha} \frac{\partial G^{\alpha}_M}{\partial T} \Delta\aleph^{\alpha} +\nonumber\\&=& S - \tilde S = 0\label{eq:scond} +\end{eqnarray} +where $\Delta y_i$ can be expressed as a function of $\Delta T, \Delta +P$ and $\mu_{\rm A}$ using equation \ref{eq:deltay}. +\begin{eqnarray} +-\sum_{\alpha} \aleph^{\alpha} +\frac{\partial^2 G^{\alpha}_M}{\partial T^2} \Delta T +-\sum_{\alpha} \aleph^{\alpha} +\frac{\partial^2 G^{\alpha}_M}{\partial T\partial P} \Delta P +-\sum_{\alpha} \aleph^{\alpha} +\sum_i\frac{\partial^2 G^{\alpha}_M}{\partial T\partial y_{i}} \Delta y_i - +\sum_{\alpha} \frac{\partial G^{\alpha}_M}{\partial T} \Delta\aleph^{\alpha} +&=& S - \tilde S\nonumber\\ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%5 +-\sum_{\alpha} \aleph^{\alpha} +\frac{\partial^2 G^{\alpha}_M}{\partial T^2} \Delta T +-\sum_{\alpha} \aleph^{\alpha} +\frac{\partial^2 G^{\alpha}_M}{\partial T\partial P} \Delta P +-\sum_{\alpha} \frac{\partial G^{\alpha}_M}{\partial T} \Delta\aleph^{\alpha} \nonumber\\ +-\sum_{\alpha} \aleph^{\alpha} +\sum_i\frac{\partial^2 G^{\alpha}_M}{\partial T\partial y_{i}} +\left(\sum_{\rm A}c_{i\rm A}\mu_{\rm A}+c_{iT}\Delta T+c_{iP}\Delta P+c_{iG}\right) +&=& S - \tilde S\nonumber\\ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%5 +-\sum_{\alpha} \aleph^{\alpha} +(\frac{\partial^2 G^{\alpha}_M}{\partial T^2}+ +\sum_i\frac{\partial^2 G^{\alpha}_M}{\partial T\partial y_{i}} c_{iT})\Delta T +-\sum_{\alpha} \aleph^{\alpha} +(\frac{\partial^2 G^{\alpha}_M}{\partial T\partial P}+ +\sum_i\frac{\partial^2 G^{\alpha}_M}{\partial T\partial y_{i}} c_{iP})\Delta P \nonumber\\ +-\sum_{\alpha} \aleph^{\alpha} +\sum_{\rm A}\sum_i\frac{\partial^2 G^{\alpha}_M}{\partial T\partial y_{i}} c_{i\rm A}\mu_{\rm A} +-\sum_{\alpha} \frac{\partial G^{\alpha}_M}{\partial T} \Delta\aleph^{\alpha} += \sum_{\alpha} \aleph^{\alpha} +\sum_i\frac{\partial^2 G^{\alpha}_M}{\partial T\partial y_{i}} c_{iG} +&+&S - \tilde S\nonumber\\ +\end{eqnarray} -For a calculation in a binary system with fixed $T$ and $P$ cannot -have more than 2 stable phases. If a third phase wants to become -stable this one must replace one of the already stable phases. +This means we should not use eq.~\ref{eq:gcond1} for a condition on G, +but write such an equation as: +\begin{eqnarray} +dG &=& \sum_{\alpha} \aleph^{\alpha} (\frac{\partial G^{\alpha}_M}{\partial T} \Delta T + +\frac{\partial G^{\alpha}_M}{\partial P} \Delta P + +\sum_i\frac{\partial G^{\alpha}_M}{\partial y_{i}} \Delta y_i) + +\sum_{\alpha} G^{\alpha}_M \Delta\aleph^{\alpha}\nonumber\\&=& G - \tilde G = 0\label{eq:gcond2} +\end{eqnarray} +or written as an equation of the variables $\Delta \aleph, \Delta T, +\Delta P$ and $\mu$: +\begin{eqnarray} +\sum_{\alpha} \aleph^{\alpha} +(\frac{\partial G^{\alpha}_M}{\partial T}+ +\sum_i\frac{\partial G^{\alpha}_M}{\partial y_{i}} c_{iT})\Delta T ++\sum_{\alpha} \aleph^{\alpha} +(\frac{\partial G^{\alpha}_M}{\partial P}+ +\sum_i\frac{\partial G^{\alpha}_M}{\partial y_{i}} c_{iP})\Delta P \nonumber\\ ++\sum_{\alpha} \aleph^{\alpha} +\sum_{\rm A}\sum_i\frac{\partial G^{\alpha}_M}{\partial y_{i}} c_{i\rm A}\mu_{\rm A} ++\sum_{\alpha} G^{\alpha}_M \Delta\aleph^{\alpha} += -\sum_{\alpha} \aleph^{\alpha} +\sum_i\frac{\partial G^{\alpha}_M}{\partial y_{i}} c_{iG} +&+&G - \tilde G\nonumber\\\label{eq:scond2} +\end{eqnarray} -\subsection{Potentials as conditions} +Just to remind you +\begin{eqnarray} +c_{i\rm A} &=& \sum_j e_{ij}\frac{\partial M_{\rm A}}{\partial y_j} +\end{eqnarray} +where $e_{ij}$ is the inverted phase matrix. The subroutine {\bf + calc\_dgdytermsh} calculates +\begin{eqnarray} +mamu({\rm A}) &=& \sum_i F_i c_{i\rm A} = \sum_i\sum_j F_i e_{ij}\frac{\partial M_{\rm A}}{\partial y_j}\\ +maT &=& \sum_i F_i c_{iT} = \sum_i\sum_j F_i e_{ij}\frac{\partial^2 G_M}{\partial T\partial y_j}\\ +maP &=& \sum_i F_i c_{iT} = \sum_i\sum_j F_I e_{ij}\frac{\partial^2 G_M}{\partial P\partial y_j}\\ +maG &=& \sum_i F_i c_{iG} = \sum_i\sum_j F_i e_{ij}\frac{\partial G_M}{\partial y_j} +\end{eqnarray} +where $F_i$ is an array passed to this subroutine and $mamu(A)$ is an +array with one value for each component. For a condition on $G$ we +have $F_i = \frac{\partial G_M}{\partial y_i}$. -In most cases above $T$ and $P$ have been fixed and in one example a -chemical potential is fixed. We cannot have all conditions as -potentials becuase then we are trying to minimize the Gibbs-Duhem -relation which is always zero. At keast one condition must be an -extensive property. +For the heat balance explained below it is $F_i = \frac{\partial + G_M}{\partial y_i}-T\frac{\partial^2 G_M}{\partial T\partial y_i}$ +and for a mass balance equation on the amount of component B, $N_{\rm + B}$, it is $F_i = \frac{\partial M_{\rm B}}{\partial y_i}$. + +\subsection{Heat balance calculation} -\subsection{Normallized state variables as conditions} +The enthalpy is $H=G+TS$ and conditions on $H$ are quite frequent. We +have as before the equation: +\begin{eqnarray} +dH &=& H - \tilde H = 0 +\end{eqnarray} +where +\begin{eqnarray} +H &=& \sum_{\alpha}\aleph^{\alpha} H^{\alpha}_M\\ +H^{\alpha}_M &=&G^{\alpha}_M + TS^{\alpha}_M\\ +dH^{\alpha}_M &=&dG^{\alpha}_M + TdS^{\alpha}_M \label{eq:deltah1} +\end{eqnarray} + +Thermodynamics is confusing, maybe we should use? +\begin{eqnarray} +dH^{\alpha}_M &=&dG^{\alpha}_M + TdS^{\alpha}_M + S^{\alpha}_M dT \label{eq:deltah2} +\end{eqnarray} +but this cannot be correct. Why? Because $H=H(S,P)$ is a function +of $S$ but of $T$? + +In eq.~\ref{eq:deltah1} the differentials for $G_M$ and $S_M$ are +given by eqs~\ref{eq:gcond2} and \ref{eq:scond} respectivly. +Combining there we have: +\begin{eqnarray} +dH &=& \sum_{\alpha}\aleph^{\alpha}\left[ +\left(\frac{\partial G_M}{\partial T}-T\frac{\partial^2 G_M}{\partial T^2}\right)\Delta T+ +\left(\frac{\partial G_M}{\partial P}-T\frac{\partial^2 G_M}{\partial T\partial P}\right)\Delta P+ +\sum_i\left(\frac{\partial G_M}{\partial y_i}-T\frac{\partial^2 G_M}{\partial T\partial y_i}\right)\Delta y_i\right]+\nonumber\\&& +\sum_{\alpha}\left(G_M - T \frac{\partial G_M}{\partial T}\right) \Delta\aleph^{\alpha} = H - \tilde H = 0 \label{eq:hcond} +\end{eqnarray} + +This must be the equation! If we insert eq.~\ref{eq:deltay} we get +\begin{eqnarray} +\sum_{\alpha}\aleph^{\alpha}\left[ +\left(\frac{\partial G_M}{\partial T}-T\frac{\partial^2 G_M}{\partial T^2}\right)\Delta T+ +\left(\frac{\partial G_M}{\partial P}-T\frac{\partial^2 G_M}{\partial T\partial P}\right)\Delta P+ \right.\nonumber&&\\ +\left.\sum_i\left(\frac{\partial G_M}{\partial y_i}-T\frac{\partial^2 G_M}{\partial T\partial y_i}\right)(c_{iG} + c_{iT}\Delta T + c_{iP}\Delta P + \sum_{\rm A}c_{iA}\mu_{\rm A})\right]+\nonumber&&\\ +\sum_{\alpha}\left(G_M - T \frac{\partial G_M}{\partial T}\right) \Delta\aleph^{\alpha} &=& H - \tilde H \nonumber\\\label{eq:hcond2} +\end{eqnarray} + +More rearrangements to have the coefficients in the equilibrium matrix +for the independent variables $\Delta T, \Delta P, \mu_{\rm A}$ and +$\Delta \aleph^{\alpha}$ in the equation for fixed $H$: +\begin{eqnarray} +\sum_{\alpha}\aleph^{\alpha} +\left(\frac{\partial G_M}{\partial T}-T\frac{\partial^2 G_M}{\partial T^2}+ +\sum_i(\frac{\partial G_M}{\partial y_i}-T\frac{\partial^2 G_M}{\partial T\partial y_i}) c_{iT}\right)\Delta T&+&\nonumber\\ +\sum_{\alpha}\aleph^{\alpha} +\left(\frac{\partial G_M}{\partial P}-T\frac{\partial^2 G_M}{\partial T\partial P}+ +\sum_i(\frac{\partial G_M}{\partial y_i}-T\frac{\partial^2 G_M}{\partial T\partial y_i})c_{iP}\right)\Delta P&+&\nonumber\\ +\sum_{\alpha}\aleph^{\alpha} +\sum_{\rm A}\sum_i\left(\frac{\partial G_M}{\partial y_i}-T\frac{\partial^2 G_M}{\partial T\partial y_i}\right)c_{iA}\mu_{\rm A}+ +\sum_{\alpha}\left(G_M - T \frac{\partial G_M}{\partial T}\right) \Delta\aleph^{\alpha} &=&\nonumber\\ +-\sum_{\alpha}\aleph^{\alpha} +\sum_i\left(\frac{\partial G_M}{\partial y_i}-T\frac{\partial^2 G_M}{\partial T\partial y_i}\right)c_{iG}+ H - \tilde H \label{eq:hcond3} +\end{eqnarray} + +We see again how useful it is to have expressed $\Delta y_i$ as a +function of the potentials and that all second derivatives are +calculated analytically in the model package. See +section~\ref{sc:norm} how to handle normallized state variables as +conditions. + + +\subsection{Normallized state variables as conditions}\label{sc:norm} In the examples above the total amounts of the components has been fixed. This simplifies the equations because if we use normallized @@ -1444,8 +1668,9 @@ \subsection{Normallized state variables as conditions} If the prescribed value is $\widetilde z^{\alpha}$ we have \begin{equation} -\Delta z^{\alpha} = \tilde z^{\alpha} - z^{\alpha} = +\Delta z^{\alpha} = \frac{\Delta Z^{\alpha}_M - z^{\alpha} \Delta K^{\alpha}_M}{K^{\alpha}_M} += z^{\alpha} - \tilde z^{\alpha} = 0 \end{equation} where the subscript $m$ means per mole formula unit of the phase. The finite difference $\Delta Z^{\alpha}$ can be expressed in the model @@ -1493,6 +1718,133 @@ \subsection{Normallized state variables as conditions} A typical use of eq.~\ref{eq:deltaoz} is when there is a condition on the mole or mass fractions of a component. +Thermodynamic properties like $V$ and $H$ can also be normallized with +respect to the amount of components $N$ or the mass $B$ with suffix +$M$ and $W$ respectivly. The enthalpy, $H$, can also be normallized +with respect to the volume with suffix $V$. A property with a phase +index can also be normallized with respect to the formula unit using +the suffix $F$. Without suffix and phase index the value of the +property is for the current size of the system. With a phase index +and without suffix the value if for the current amount of the phase +and if the phase is not stable that is zero. + +As an example take the equation for normallizing the enthalpy per +moles of component, $H_m$, where as before lower case $m$ means per +mole of components and upper case $M$ means per mole formula unit: + +\begin{eqnarray} +z = \frac{Z}{K} = H_m = \frac{H}{N} &=& \frac{\sum_{\alpha}\aleph^{\alpha} H^{\alpha}}{\sum_{\alpha}\aleph^{\alpha}M^{\alpha}}\\ +Z = H &=& \sum_{\alpha}\aleph^{\alpha} H^{\alpha}_M\\ +K = N &=& \sum_{\alpha}\aleph^{\alpha}M^{\alpha}\\ +H^{\alpha}_M &=& G^{\alpha}_M - T\left(\frac{\partial G^{\alpha}_M}{\partial T}\right)_{P,y_i} +\end{eqnarray} +where $G^{\alpha}_M$ is the Gibbs energy and $M^{\alpha}$ (according +to eq.~\ref{eq:molesperfu}) is the amount of moles of components, in +both cases per mole formula unit of phase $\alpha$. + +When used as condition we need the differential of this and for $dH$ we +use eq.~\ref{eq:hcond3}: +\begin{eqnarray} +dH = \Delta H &=& \sum_{\alpha}\aleph^{\alpha}\sum_{\rm A}\sum_i\frac{\partial H^{\alpha}_M}{\partial y_i}c_{i\rm A}\mu_{\rm A}+ +\sum_{\alpha}\aleph^{\alpha}\left(\frac{\partial H^{\alpha}_M}{\partial T}+\sum_i\frac{\partial H^{\alpha}_M}{\partial y_i}c_{iT}\right)\Delta T+\nonumber\\&& +\sum_{\alpha}\aleph^{\alpha}\left(\frac{\partial H^{\alpha}_M}{\partial P}+\sum_i\frac{\partial H^{\alpha}_M}{\partial y_i}c_{iP}\right)\Delta P+ +\sum_{\alpha}\aleph^{\alpha}\sum_i\frac{\partial H^{\alpha}_M}{\partial y_i}c_{iG}+ +\sum_{\alpha}H^{\alpha}_M \Delta \aleph^{\alpha}\nonumber\\ +\end{eqnarray} +and for $dM$ we follow eq.~\ref{eq:diffm2}: +\begin{eqnarray} +dN= \Delta N &=& \sum_{\alpha}\aleph^{\alpha}\Delta M^{\alpha}= +\sum_{\alpha}\sum_{\rm A}M^{\alpha}_{\rm A}\Delta\aleph^{\alpha}+\nonumber\\&& +\sum_{\alpha}\aleph^{\alpha}(\sum_{\rm A}\sum_i\frac{\partial M_{\rm A}^{\alpha}}{\partial y_i}c_{i\rm A}\mu_{\rm A}+ +\sum_i\frac{\partial M_{\rm A}^{\alpha}}{\partial y_i}c_{iT}\Delta T+ +\sum_i\frac{\partial M_{\rm A}^{\alpha}}{\partial y_i}c_{iP}\Delta P+ +\sum_i\frac{\partial M_{\rm A}^{\alpha}}{\partial y_i}c_{iG})\nonumber\\ +\end{eqnarray} +Note that $c_{i\rm A}, c_{iT}$ etc. are of course different for each +phase even if that is not indicated. + +This should be inserted in: +\begin{eqnarray} +\Delta z &=& \frac{1}{N}(\Delta H^{\alpha}_M - z \Delta N) = z-\tilde z = 0 +\end{eqnarray} +which gives +\begin{eqnarray} +\frac{1}{N}\sum_{\alpha}\aleph^{\alpha}\left(\sum_{\rm A}\sum_i\frac{\partial H^{\alpha}_M}{\partial y_i}c_{i\rm A}\mu_{\rm A}+ +(\frac{\partial H^{\alpha}_M}{\partial T}+\sum_i\frac{\partial H^{\alpha}_M}{\partial y_i}c_{iT})\Delta T+ +(\frac{\partial H^{\alpha}_M}{\partial P}+\sum_i\frac{\partial H^{\alpha}_M}{\partial y_i}c_{iP})\Delta P+\right.\nonumber\\ +\left.\sum_i\frac{\partial H^{\alpha}_M}{\partial y_i}c_{iG}\right)+ +\frac{1}{N}\sum_{\alpha}H^{\alpha}_M \Delta \aleph^{\alpha}- +\frac{H}{N^2}\sum_{\alpha}\sum_{\rm A}M^{\alpha}_{\rm A}\Delta\aleph^{\alpha}+\nonumber\\ +\frac{H}{N^2}\sum_{\alpha}\aleph^{\alpha}(\sum_{\rm A}\sum_i\frac{\partial M_{\rm A}^{\alpha}}{\partial y_i}c_{i\rm A}\mu_{\rm A}+ +\sum_i\frac{\partial M_{\rm A}^{\alpha}}{\partial y_i}c_{iT}\Delta T+ +\sum_i\frac{\partial M_{\rm A}^{\alpha}}{\partial y_i}c_{iP}\Delta P+ +\sum_i\frac{\partial M_{\rm A}^{\alpha}}{\partial y_i}c_{iG})&=&z-\tilde z\nonumber\\ +\end{eqnarray} + +Rearranging for the independent variables: +\begin{eqnarray} +\frac{1}{N}\sum_{\alpha}\aleph^{\alpha}\left[\sum_{\rm A}\sum_i(\frac{\partial H^{\alpha}_M}{\partial y_i}- +\frac{H}{N}\frac{\partial M_{\rm A}^{\alpha}}{\partial y_i})c_{i\rm A}\mu_{\rm A}+\right.\nonumber\\ +\left.\left(\frac{\partial H^{\alpha}_M}{\partial T}+\sum_i(\frac{\partial H^{\alpha}_M}{\partial y_i}-\frac{H}{N}\frac{\partial M_{\rm A}^{\alpha}}{\partial y_i})c_{iT}\right)\Delta T+\right.\nonumber\\ +\left.\left(\frac{\partial H^{\alpha}_M}{\partial P}+\sum_i(\frac{\partial H^{\alpha}_M}{\partial y_i}-\frac{H}{N}\frac{\partial M_{\rm A}^{\alpha}}{\partial y_i})c_{iP}\right)\Delta P\right]+\nonumber\\ +\frac{1}{N}\sum_{\alpha} (H^{\alpha}_M - +\frac{H}{N}\sum_{\rm A}M^{\alpha}_{\rm A})\Delta\aleph^{\alpha}&=& +- \frac{1}{N}\sum_{\alpha}\aleph^{\alpha}\sum_i(\frac{\partial H^{\alpha}_M}{\partial y_i}-\frac{H}{N}\frac{\partial M_{\rm A}^{\alpha}}{\partial y_i})c_{iG} + z-\tilde z\nonumber\\ +\end{eqnarray} + +Similar equation can be derived for other normalizing properties. All +of this may seem quite complicated but the coding can be generallized +and it is an advantage that these equations make each condition +independent of any other condition. + +\subsection{Changing the set of stable phases}\label{sc:changeps} + +When the amount of a stable phase becomes negative at an iteration it +means this phase should be removed from the set of stable phases. And +if the driving force for an unstable phase according to +eq.~\ref{eq:dgm1} becomes positive that phase should be added. + +\begin{equation} +\gamma^{\psi} = \sum_{\rm A} \mu_{\rm A} M_{\rm A}^{\psi_i} - G^{\psi}_M \label{eq:dgm2} +\end{equation} +where the sum over A is for all components. If $T$ and $P$ are +variable the $\Delta T$ and $\Delta P$ are also included in this +equation as in eq.~\ref{eq:gmalpha2}. + +This is basically a trivial operation but we should take care that +the same phase is removed and added at every second iteration. +Normally we should allow a few iterations after a change in the +set of stable phases before another change is allowed. + +It can also happen that the amount of the single stable phase becomes +negative and it is clearly impossible to have a system without a +single stable phase. This may indicate that the set of external +conditions are unreasonable or that the model parameters are wrong. + +A third case that may case problem is when more phases become stable +than allowed by the Gibbs phase rule: + +\begin{equation} +f = n - p + 2 +\end{equation} +where $f$ is the degrees of freedom, $n$ number of components, $p$ +number of stable phases and 2 represent variable $T$ and $P$. In +order to calculate an equilibrium we must have set so many conditions +that $f$ is zero. For a binary system that means 4 conditions. If +one condition is constant $P$, we can at most have 3 phases stable. + +For a calculation in a binary system with fixed $T$ and $P$ cannot +have more than 2 stable phases. If a third phase wants to become +stable this one must replace one of the already stable phases. + +\subsection{Potentials as conditions} + +In most cases above $T$ and $P$ have been fixed and in one example a +chemical potential is fixed. We cannot have all conditions as +potentials becuase then we are trying to minimize the Gibbs-Duhem +relation which is always zero. At keast one condition must be an +extensive property. + \subsection{Generallizing the equilibrium matrix} All examples shown above has been for binary cases. For the phase @@ -1548,17 +1900,18 @@ \subsection{Special treatment of the ionic liquid model} The mass balance equation is like for the CEF model: \begin{eqnarray} -M_{\rm A} = P\sum_i b_{Ai}y_i+Q(\sum_j b_{Aj} y_j+\sum_k b_{Ak}y_k) +M_{\rm A} = P\sum_i b_{i\rm A}y_i+Q(\sum_j b_{j\rm A} y_j+\sum_k b_{k\rm A}y_k) \end{eqnarray} -where all $b_{Ai}$ represent the stoichiometric factor of element A in -any cation, anion or neutral and all $y_i$ the fraction of the -constituent $i$. The derivative of this slightly more complicated -than for the CEF model as $P$ and $Q$ are nort constant: +where the $b_{i\rm A}, b_{j\rm A}$ and $b_{k\rm A}$ represent the +stoichiometric factor of element A in cations, anions and neutrals +respectivly and all $y_i$ the fraction of the constituent $i$. The +derivative of this is slightly more complicated than for the CEF model +as $P$ and $Q$ are not constant: \begin{eqnarray} dM_{\rm A} = dP\sum_i b_{Ai}y_i+P\sum_i b_{Ai}dy_i+ dQ(\sum_j b_{Aj}y_j+\sum_k b_{Ak}y_k)+ -Q(\sum_k b_{Ak}dy_k +\sum_j b_{Aj}dy_j) +Q(\sum_k b_{Ak}dy_k +\sum_j b_{Aj}dy_j)\nonumber\\ \end{eqnarray} where @@ -1676,7 +2029,7 @@ \subsection{Calculating heat capacity} \sum_j\left(\frac{\partial^2 G_M^{\alpha}}{\partial T\partial y_{j}}\right)_{P,y_{k\ne j}}\Delta y_{j}\right]\nonumber\\ \label{eq:cpfinal2} \end{eqnarray} -In order to fins the appropriate values for $\Delta\aleph$ and $\Delta +In order to find the appropriate values for $\Delta\aleph$ and $\Delta y_j$ we have to calculate one iteration of the equilibrium matrix with an extra equation for $\Delta T$ as an additional variable. In order to be able to add such an equation the $T$ must be a condition in the @@ -1725,7 +2078,7 @@ \subsection{Calculating heat capacity} \right) \\ (\ref{eq:dhdt1}) \] -with the terms in 4'th coulm calculated as: +with the terms in 4'th column calculated as: \begin{eqnarray} s_{14} &=& \frac{\partial G_M}{\partial T}\\ s_{24} &=& \aleph\sum_i\frac{\partial M_{\rm A}}{\partial y_i}c_{iT}\\ @@ -1766,12 +2119,15 @@ \subsection{The liquidus slope} \bibitem[09Flo]{09Flo} C A Floudas and C E Gounaris, J of Global Optimization {\bf 45} (2009) 3-38 \bibitem[75Eri]{75Eri} G Eriksson (1974) -\bibitem[81Sun]{81Sun} B Sundman and J Ågren (1981) +\bibitem[81Sun]{81Sun} B Sundman and J �gren (1981) \bibitem[81Hil]{81Hil} M Hillert, Physica (1981) \bibitem[82Luk]{82Luk} H L Lukas et al, Calphad (1982) \bibitem[84Jan]{84Jan} B Jansson, Thesis, KTH (1984) \bibitem[84Hil]{84Hil} M Hillert et al, Ionic liquid model (1984) -\bibitem[11Kat]{11Kat} U Kattner et al, (2011) Calphad meeting in Rio +\bibitem[01Hil]{01Hil} M Hillert, CEF +\bibitem[15Sun1]{15Sun1} B Sundman, U R Kattner, M Palumbo, S G Fries, +IMMI journal (2015) 4:1 +\bibitem[15Sun2]{15Sun2} B Sundman, X-G Lu, H Ohtani, Comp Mat. Sci (2015) \end{thebibliography} \newpage @@ -2272,3 +2628,20 @@ \section{Summary} \end{document} +If the correct equation is eq.~\ref{eq:deltah2} we will have an +additional term $-\sum_{\alpha}\aleph^{\alpha}\frac{\partial + G_M}{\partial T} \Delta T$: +\begin{eqnarray} +\sum_{\alpha}\aleph^{\alpha} +\left(-T\frac{\partial^2 G_M}{\partial T^2}+ +\sum_i(\frac{\partial G_M}{\partial y_i}-T\frac{\partial^2 G_M}{\partial T\partial y_i}) c_{iT}\right)\Delta T&+&\nonumber\\ +\sum_{\alpha}\aleph^{\alpha} +\left(\frac{\partial G_M}{\partial P}-T\frac{\partial^2 G_M}{\partial T\partial P}+ +\sum_i(\frac{\partial G_M}{\partial y_i}-T\frac{\partial^2 G_M}{\partial T\partial y_i})c_{iP}\right)\Delta P&+&\nonumber\\ +\sum_{\alpha}\aleph^{\alpha} +\sum_{\rm A}\sum_i\left(\frac{\partial G_M}{\partial y_i}-T\frac{\partial^2 G_M}{\partial T\partial y_i}\right)c_{iA}\mu_{\rm A}+ +\sum_{\alpha}\left(G_M - T \frac{\partial G_M}{\partial T}\right) \Delta\aleph^{\alpha} &=&\nonumber\\ +-\sum_{\alpha}\aleph^{\alpha} +\sum_i\left(\frac{\partial G_M}{\partial y_i}-T\frac{\partial^2 G_M}{\partial T\partial y_i}\right)c_{iG}+ H - \tilde H \label{eq:hcond4} +\end{eqnarray} + diff --git a/documentation/minpack5.toc b/documentation/minpack5.toc new file mode 100644 index 0000000..95b1eeb --- /dev/null +++ b/documentation/minpack5.toc @@ -0,0 +1,65 @@ +\contentsline {section}{\numberline {1}Introduction}{4} +\contentsline {section}{\numberline {2}The thermodynamic model}{4} +\contentsline {subsection}{\numberline {2.1}The formula unit of a phase}{5} +\contentsline {subsection}{\numberline {2.2}Differentials}{6} +\contentsline {subsection}{\numberline {2.3}Examples}{6} +\contentsline {subsubsection}{\numberline {2.3.1}A gas phase with H and O}{6} +\contentsline {subsubsection}{\numberline {2.3.2}A crystalline phase with substitutional and interstitial constituents}{7} +\contentsline {subsubsection}{\numberline {2.3.3}A crystalline phase with long range ordering}{7} +\contentsline {subsection}{\numberline {2.4}End-members of models}{8} +\contentsline {section}{\numberline {3}The Gibbs energy}{8} +\contentsline {subsection}{\numberline {3.1}The differential of the Gibbs energy}{9} +\contentsline {subsection}{\numberline {3.2}The partial Gibbs energy with for an end-member}{9} +\contentsline {subsection}{\numberline {3.3}The Gibbs-Duhem relation}{10} +\contentsline {section}{\numberline {4}Minimization with constraints}{11} +\contentsline {subsection}{\numberline {4.1}The constraints}{11} +\contentsline {subsection}{\numberline {4.2}The Lagrangian equation}{11} +\contentsline {subsection}{\numberline {4.3}The derivative of the Lagrangian with respect to phase amounts}{12} +\contentsline {subsection}{\numberline {4.4}The derivative of the Lagrangian with respect to constituent fractions}{12} +\contentsline {section}{\numberline {5}Calculating the equilibrium}{13} +\contentsline {subsection}{\numberline {5.1}Step 0, Obtaining start values by grid minimizer}{13} +\contentsline {subsection}{\numberline {5.2}Step 1, the phase matrix}{15} +\contentsline {subsubsection}{\numberline {5.2.1}The phase matrix for a binary system}{16} +\contentsline {subsubsection}{\numberline {5.2.2}The general equation for the correction of constituent fractions}{17} +\contentsline {subsection}{\numberline {5.3}Charge balance}{17} +\contentsline {subsection}{\numberline {5.4}Step 2, the external conditions}{18} +\contentsline {subsubsection}{\numberline {5.4.1}Condition on the amount of the components}{18} +\contentsline {subsubsection}{\numberline {5.4.2}Example: a binary system with a single stable phasse}{19} +\contentsline {subsubsection}{\numberline {5.4.3}Example: a binary system with two stable phases}{20} +\contentsline {subsubsection}{\numberline {5.4.4}Example: a binary system with unknown $T$ and one stable phase prescribed.}{20} +\contentsline {subsubsection}{\numberline {5.4.5}Example: a binary system with one condition of a chemical potential}{21} +\contentsline {subsection}{\numberline {5.5}Condition on volume}{21} +\contentsline {subsection}{\numberline {5.6}Constant Gibbs energy or entropy}{22} +\contentsline {subsection}{\numberline {5.7}Heat balance calculation}{24} +\contentsline {subsection}{\numberline {5.8}Normallized state variables as conditions}{25} +\contentsline {subsection}{\numberline {5.9}Changing the set of stable phases}{28} +\contentsline {subsection}{\numberline {5.10}Potentials as conditions}{29} +\contentsline {subsection}{\numberline {5.11}Generallizing the equilibrium matrix}{29} +\contentsline {subsection}{\numberline {5.12}Special treatment of the ionic liquid model}{29} +\contentsline {section}{\numberline {6}Calculating derivatives using the result of an equilibrium calculation, the dot derivative}{30} +\contentsline {subsection}{\numberline {6.1}Calculating heat capacity}{30} +\contentsline {subsection}{\numberline {6.2}The liquidus slope}{33} +\contentsline {section}{\numberline {7}Software documentation}{34} +\contentsline {subsection}{\numberline {7.1}Data structures}{34} +\contentsline {subsubsection}{\numberline {7.1.1}Data for each phase}{34} +\contentsline {subsubsection}{\numberline {7.1.2}Data for the system}{35} +\contentsline {subsubsection}{\numberline {7.1.3}Data needed for applications like STEP and MAP}{36} +\contentsline {subsection}{\numberline {7.2}Top level calculation routines}{36} +\contentsline {subsubsection}{\numberline {7.2.1}The simplest one, for single equilibrium calculation}{36} +\contentsline {subsubsection}{\numberline {7.2.2}Equilibrium calculatins during step/map calculations}{36} +\contentsline {subsection}{\numberline {7.3}Subroutine to change the set of stable phases}{37} +\contentsline {subsection}{\numberline {7.4}Iterations with same set of stable phases}{37} +\contentsline {subsection}{\numberline {7.5}Formulating the equilibrium matrix}{38} +\contentsline {subsection}{\numberline {7.6}Routine to calculate the inverse phase matrix}{38} +\contentsline {subsection}{\numberline {7.7}Some utility routines}{38} +\contentsline {subsubsection}{\numberline {7.7.1}Correction of of second derivatives for the ionic liquid model}{38} +\contentsline {subsubsection}{\numberline {7.7.2}Test of same composition}{39} +\contentsline {subsection}{\numberline {7.8}The coefficients in the $\Delta y$ equation}{39} +\contentsline {subsection}{\numberline {7.9}The remaining subroutines deals with state variable function and in particular dot derivatives}{40} +\contentsline {subsubsection}{\numberline {7.9.1}Evaluate all state variable functions}{40} +\contentsline {subsubsection}{\numberline {7.9.2}Get the value of one or more state variable or function}{40} +\contentsline {subsubsection}{\numberline {7.9.3}Evaluate a state variable function}{41} +\contentsline {subsubsection}{\numberline {7.9.4}Initiate the equilibrium matrix for a derivative calculation}{41} +\contentsline {subsubsection}{\numberline {7.9.5}Calculate the value of a state variable derivative}{41} +\contentsline {subsubsection}{\numberline {7.9.6}Calculate the value of a state variable derivative for a single phase}{42} +\contentsline {section}{\numberline {8}Summary}{42} diff --git a/ochelp.tex b/documentation/ochelp2.tex similarity index 100% rename from ochelp.tex rename to documentation/ochelp2.tex diff --git a/documentation/stepmapplot.tex b/documentation/stepmapplot.tex new file mode 100644 index 0000000..95c9ab9 --- /dev/null +++ b/documentation/stepmapplot.tex @@ -0,0 +1,48 @@ +\documentclass[12pt]{article} +\usepackage[latin1]{inputenc} +\usepackage{graphicx,subfigure} +\topmargin -1mm +\oddsidemargin -1mm +\evensidemargin -1mm +\textwidth 155mm +\textheight 220mm +\parskip 2mm +\parindent 3mm +%\pagestyle{empty} + + +\begin{document} + +\begin{center} + +{\Large \bf Step Map and Plot (SMP) in Open Calphad (OC)} + +{\large Basic description and documentation} + +Bo Sundman, \today + +\end{center} + +The work on the step, map and plot procedures is progressing slowly. +The main work started late in 2013 and we are now at the end of +September 2014. Serious errors in the other parts of the software +have also been found and corrected. So it is interesting to show that +even if the software as a whole becomes better, some calculations were +better without all the bugfixes. In Fig.~\ref{fg:hss} two isopleths +of a high speed steel (I think the composition is slightly different) +are shown, one calculated in May 2014 and the other in October. The +one from May is clearly better but at that time there were many bugs +that had been eliminated in October. So evidently some bugs +compensate each other. +\begin{figure}[!h] +\includegraphics[width=50mm,angle=-90]{figs/oc-hss-140513.ps} +\includegraphics[width=50mm,angle=-90]{figs/oc-hss-141002.ps} +\caption{Figures showing progress sometimes goes backwards. The left + hand figure was calculated in May 2014 (before there was a date on + the diagrams) and the right in October with several missing lines. + Considering all the errors that has been found in the minimizer and + other parts of the OC software it is remarkable it was possible to + calculate anything in May.}\label{fg:hss} +\end{figure} + +\end{document} diff --git a/documentationupdate/ocdok.tex b/documentationupdate/ocdok.tex deleted file mode 100644 index d7d70a4..0000000 --- a/documentationupdate/ocdok.tex +++ /dev/null @@ -1,211 +0,0 @@ -\documentclass[12pt]{article} -\usepackage[latin1]{inputenc} -\usepackage{graphicx,subfigure} -\topmargin -1mm -\oddsidemargin -1mm -\evensidemargin -1mm -\textwidth 165mm -\textheight 220mm -\parskip 2mm -\parindent 3mm -%\pagestyle{empty} - -\begin{document} - -\begin{center} -{\Large \bf An overview of the Open Calphad software} - -\bigskip - -Bo Sundman \today - -\end{center} - -\section{Introdution} - -The aim of the Open Calphad (OC) initiative\cite{14Sun} is to provide -a high quality multicomponent thermodynamic software for scientific -applications as well as for research and developments. It has a GNU -license and the hope is this will make it interesting for the -development of new thermodynamic models, new algorithms for -minimization as well as many new applications of thermodynamic -calculations in materials science and process developments. - -The two basic parts are: - -\begin{itemize} -\item the General Thermodynamic Package (GTP) which include the - Compound Energy Formalism (CEF)\cite{01Hil,07Luk} and the partially - ionic two-sublattice liquid model (I2SL)\cite{85Hil,07Luk}. The CEF - includes a large range of models from the gas with molcules, liquid - with associates, crystalline phases with sublattices, ions etc. The - magnetic contribution to the Gibbs energy is described withe the - empirical model proposed by Inden\cite{81Ind}. In CEF the - configurational entropy is bases on the assumpton that the - constituents on each set of sites are rsndomly distributed. -\item the Hillert Mimimizer by Sundman (HMS) package with an - implementation of the algorithm proposed by - Hillert~\cite{81Hil,15Sun} to find the equilibrium for kinds of - external conditions by using Lagrangian multipliers. The user can - also prescribed some or all stable phases and the software can - handle changes of the set of stable phases during iterations. It - requires that the model package provides the Gibbs energy and first - and second derivatives of the Gibbs energy with respect to $T, P$ - and all constituents for each phase. -\end{itemize} - -These two packages have separate documention of their data structure -and subroutines. - -OC has a simple command user interface and can read thermodynamic data -from files with the TDB format\cite{TDB}. There is a rudimentary user -guide also available online. Data can be entered and amended -interactivly and there is a log and macro facility. There are also -three untility packages, the METLIB package for general utilities, the -TPFUN package for handling functions of temperature and pressure and -NUMLIB, a numerics package for inverting matricies and solving systems -of linear equations. It is all written in or converted to the new -Fortran standard (1995/2008). - -The first application package using the GTP and HMS is the -step/map/plot (SMP) package for calculation property and phase -diagrams and the OC-TQ software interface for general applications, -for example simulations of phase transformations also requiring -kinetic data. The OC initiative will continue at least until there is -an assessment module for evaluating thermodynamic model -parameters from experimental data. - -The development of a Graphical User Interface (GUI) is invited but not -part of the OC initiatve. - -\section{Implementation of new models and minimization algorithms} - -Models based on CEF and the I2SL model are described in detail in the -book by Lukas\cite{07Luk}. There is a very general data structure -defined in the GTP package for handling model parameters including -sublattices and various aditional contributions like magnetic -transitions. The data structure can also handle other types of data -that may depend on the phase and $T, P$ and the phase constitition, -for example mobilities, elastic constants, Curie temperature etc. It -may be useful also for the development of new models. The GTP -contains a routine to calculate the Gibbs energy and the first and -second derivatives with respect to $R, P$ and all constituents for the -implemented models. State variables and conditions on state variables -are also part of the model package and are used by the HMS package -when calculating the equilibrium. On the list of models to be added -there are: - -\begin{itemize} -\item the corrected quaichemical model\cite{08Hil} -\item the tetrahedron model of the Cluster Variation Method\cite{51Kik} -\end{itemize} - -The hope is that the availability of OC will simplify and encourage -the development of new models based of better physics including strain -and stress and also for high pressure applications. - -It would also be interesing to implement other minimization procedures -that may be adopted for special models. - -\section{The step/map/plot package} - -There is no separate documentation for this package at present so the -priciples are briefly explained here. - -\subsection{The step procedure} - -For a property diagram the user specifies conditions for a single -equilibrium calculation and then selects one of the conditions as axis -variable. With the STEP command the software will calculate -equilibria between a maximum and minimum value at fixed intervals. -Whenever there is a change of the set of stable phases the axis value -for this change is calculated exactly. The complete results are saved -for each calculated equilibrium and the user can later plot any -property or derived function from the stored equilibria. - -There is a special version of the STEP command allowing each phase to -be calculated separately. This is useful for plotting the Gibbs -energy or enthalpy curves, along the axis. - -Other special STEP commands may be implemented in the future, for -example to simulate a Scheil-Gulliver solidification process. - -\subsection{The map procedure} - -In the map procedure the user first specifies all conditions needed -for calculating a single equilibrium. Then two of these conditions -are selected as axis variables and with the MAP commad the software -calculates two-dimensional sections or projections with lines with -different sets of stable phases. At present only two axis are -allowed. The map software replaces all axis conditions except one -with a phase prescribed to be stable with zero amount and then follows -this line by incrementing the remaining axis with an active condition. -If the curvature is line requires it may change the axis with active -condition. If there is a phase change the software generates a node -point and three or more lines with different set of prescribed stable -phases will exit from each mode point. If a node point is reached -that has already been calculated an exit from that node point is -eliminated. - -During the step and map calculation all equilibria are saved and any -state variable can be used to plot the stored result. It is possible -to start mapping from different equilibra and overlay the results. -But it is not yet possible to save the results on a file. - -\subsection{The plot procedure} - -The plot procedure at present can only plot diagram with a single -variable on one axis, for example a potential like $T$ or an overall -composition. This means isothernal sections cannot be plotted but -that will be implemented in the next release. The plot routine -generates a table that is plotted by calling GNUPLOT. - -\section{Application software interface, OC-TQ} - -Application programs using OC should not use directly the -datastructures and subroutines inside GTP or HMS to avoid that they -need to be modified whenever there is a change. Instead there is an -application interface called OC-TQ (Thermodynamic Query system) which -will (eventually) give access to all necessary facilities, also -callable from other languages like C or Phyton. - -As the OC-TQ interface is in the development stage the use of the -current OC-TQ interface is not stable and may need modifications in -the future. And many facilities are still not implemented. There -will be a separate documentation of OC-TQ. - -\section{Summary} - -A general multicomponent software has been developed that can -calculate single equilibria and property diagrams. The phase diagram -module can calculate most binary phase diagram but fails in most cases -when dealing with ternary or higher systems. A revision of the data -structure will be made in the next relase to improve the phase diagram -calculation. - -The first version of the software was released in March 2013 and the -most resecent version is available on the wed\cite{ocweb}. A -development version of the furure relase is available from a -repository \cite{github}. - -\begin{thebibliography}{XXyyy} -\bibitem[51Kik]{51Kik} Kikuchi (1951) -\bibitem[81Hil]{81Hil} Hillert, Physica (1981) -\bibitem[81Ind]{81Ind} Inden, Physica (1981) -\bibitem[85Hil]{85Hil} Hillert et al, (1985) ionic liquid model -\bibitem[01Hil]{01Hil} Hillert, (2001) CEF -\bibitem[07Luk]{07Luk} Lukas et al (2007) -\bibitem[08Hil]{08Hil} Hillert et al, (2009) corrected quasichemical model -\bibitem[TDB]{TDB} TDB format, see Thermo-Calc guide -\bibitem[14Sun]{14Sun} Sundman et al, to be published in IMMI, (2015) -\bibitem[15Sun]{15Sun} Sundman et al, to be published in Comp.Mat.Sci, (2015) -\bibitem[ocweb]{ocweb} http://www.opencalcalphad.org -\bibitem[github]{github} opencalphad at http://www.github.com -\end{thebibliography} - -\end{document} - - -\begin{eqnarray} -\end{eqnarray} - diff --git a/linkmake.txt b/linkmake.txt index e8548e1..36af06e 100644 --- a/linkmake.txt +++ b/linkmake.txt @@ -11,9 +11,9 @@ copy numlib\lukasnum.F90 . gfortran -c -fbounds-check -finit-local-zero lukasnum.F90 del lukasnum.F90 -copy models\pmod25*.F90 . -gfortran -c -fbounds-check -finit-local-zero pmod25.F90 -del pmod25*.F90 +copy models\gtp3*.F90 . +gfortran -c -fbounds-check -finit-local-zero gtp3.F90 +del gtp3*.F90 copy minimizer\matsmin.F90 . gfortran -c -fbounds-check -finit-local-zero matsmin.F90 @@ -30,8 +30,8 @@ del pmon6.F90 gfortran -o linkoc linkocdate.F90 linkoc -ar sq liboceq.a metlib3.o tpfun4.o lukasnum.o pmod25.o matsmin.o +ar sq liboceq.a metlib3.o tpfun4.o lukasnum.o gtp3.o matsmin.o -gfortran -o oc2A -fbounds-check pmain1.F90 pmon6.o smp1.o liboceq.a +gfortran -o oc3A -fbounds-check pmain1.F90 pmon6.o smp1.o liboceq.a diff --git a/macros/all.OCM b/macros/all.OCM deleted file mode 100644 index a2a67a9..0000000 --- a/macros/all.OCM +++ /dev/null @@ -1,140 +0,0 @@ -@$ running all version 2 test macros - -set echo - -@$ After plotting a diagram -@$ click on the window with the plot to contiue - -@$ Some macros may fail in this supermacro -@$ but work when calculated separately - -@& - -mac unary - -@$ *********************************** -@& *********************************** - -new Y -mac melting - -@$ *********************************** -@& *********************************** - -new Y -mac step1-hss - -@$ *********************************** -@& *********************************** - - -new Y -mac step2-agcu - -@$ *********************************** -@& *********************************** - - -new Y -mac step3-hogas - -@$ *********************************** -@& *********************************** - - -new Y -mac step4-feni - -@$ *********************************** -@& *********************************** - - -new Y -mac step5-feni - -@$ *********************************** -@& *********************************** - - -new Y -mac step6-femo - -@$ *********************************** -@& *********************************** - - -new Y -mac step7-saf - -@$ *********************************** -@& *********************************** - - -new Y -mac map1-agcu - -@$ *********************************** -@& *********************************** - - -new Y -mac map2-crmo - -@$ *********************************** -@& *********************************** - - -new Y -mac map3-cfe - -@$ *********************************** -@& *********************************** - - -new Y -mac map4-ou - -@$ *********************************** -@& *********************************** - - -new Y -mac map5-femo - -@$ *********************************** -@& *********************************** - - -new Y -mac map6-ss - -@$ *********************************** -@& *********************************** - - -new Y -mac map8-feni - -@$ *********************************** -@& *********************************** - - -new Y -mac map9-rew - -@$ *********************************** -@& *********************************** - -new Y -mac map7-hss - -@$ *********************************** -@& *********************************** - -@$ that is all - -set inter - - - - diff --git a/macros/melting.OCM b/macros/melting.OCM deleted file mode 100644 index 115a067..0000000 --- a/macros/melting.OCM +++ /dev/null @@ -1,23 +0,0 @@ -@$ Calculating a single equilibrium and a melting temperature -@& -set echo - -r t steel1 - -set c t=1200 p=1e5 n=1 x(c)=.05 x(cr)=.05, x(mo)=.05 x(si)=.003 x(v)=.01 - -c e - -l ,,,, - -@& - -c tran -liq -1 - -list,,,,, - -@& -set inter - diff --git a/macros/ocv1-0/alcrni-nodis.TDB b/macros/ocv1/alcrni-nodis.TDB similarity index 100% rename from macros/ocv1-0/alcrni-nodis.TDB rename to macros/ocv1/alcrni-nodis.TDB diff --git a/macros/ocv1-0/all.OCM b/macros/ocv1/all.OCM similarity index 100% rename from macros/ocv1-0/all.OCM rename to macros/ocv1/all.OCM diff --git a/macros/ocv1-0/hogas.TDB b/macros/ocv1/hogas.TDB similarity index 100% rename from macros/ocv1-0/hogas.TDB rename to macros/ocv1/hogas.TDB diff --git a/macros/ocv1-0/oc1ex01A.OCM b/macros/ocv1/oc1ex01A.OCM similarity index 100% rename from macros/ocv1-0/oc1ex01A.OCM rename to macros/ocv1/oc1ex01A.OCM diff --git a/macros/ocv1-0/oc1ex01B.OCM b/macros/ocv1/oc1ex01B.OCM similarity index 100% rename from macros/ocv1-0/oc1ex01B.OCM rename to macros/ocv1/oc1ex01B.OCM diff --git a/macros/ocv1-0/oc1ex01C.OCM b/macros/ocv1/oc1ex01C.OCM similarity index 100% rename from macros/ocv1-0/oc1ex01C.OCM rename to macros/ocv1/oc1ex01C.OCM diff --git a/macros/ocv1-0/oc1ex02A.OCM b/macros/ocv1/oc1ex02A.OCM similarity index 100% rename from macros/ocv1-0/oc1ex02A.OCM rename to macros/ocv1/oc1ex02A.OCM diff --git a/macros/ocv1-0/oc1ex02B.OCM b/macros/ocv1/oc1ex02B.OCM similarity index 100% rename from macros/ocv1-0/oc1ex02B.OCM rename to macros/ocv1/oc1ex02B.OCM diff --git a/macros/ocv1-0/oc1ex02C.OCM b/macros/ocv1/oc1ex02C.OCM similarity index 100% rename from macros/ocv1-0/oc1ex02C.OCM rename to macros/ocv1/oc1ex02C.OCM diff --git a/macros/ocv1-0/steel1.TDB b/macros/ocv1/steel1.TDB similarity index 100% rename from macros/ocv1-0/steel1.TDB rename to macros/ocv1/steel1.TDB diff --git a/macros/OU.TDB b/macros/ocv2/OU.TDB similarity index 97% rename from macros/OU.TDB rename to macros/ocv2/OU.TDB index 146bc88..ebfdcec 100644 --- a/macros/OU.TDB +++ b/macros/ocv2/OU.TDB @@ -1,279 +1,279 @@ - -$ Database file written 2013- 3-10 -$ From database: USER - ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! - ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! - ELEMENT O GAS_1/2_MOLE_O2 1.5999E+01 4.3410E+03 1.0252E+02! - ELEMENT U ORTHORHOMBIC_A20 2.3803E+02 6.3640E+03 5.0200E+01! - - SPECIES O-2 O1/-2! - SPECIES O2 O2! - SPECIES O3 O3! - SPECIES U+3 U1/+3! - SPECIES U+4 U1/+4! - SPECIES U+5 U1/+5! - SPECIES UO O1U1! - SPECIES UO2 O2U1! - SPECIES UO3 O3U1! - - FUNCTION OGAS 298.15 +243206.494-20.8612587*T-21.01555*T*LN(T) - +1.2687055E-04*T**2-1.23131283E-08*T**3-42897.09*T**(-1); 2950 Y - +252301.423-52.0847285*T-17.21188*T*LN(T)-5.413565E-04*T**2 - +7.64520667E-09*T**3-3973170.5*T**(-1); 6000 N ! - FUNCTION O2GAS 298.15 -6960.69252-51.1831473*T-22.25862*T*LN(T) - -.01023867*T**2+1.339947E-06*T**3-76749.55*T**(-1); 9.00000E+02 Y - -13136.0172+24.743296*T-33.55726*T*LN(T)-.0012348985*T**2 - +1.66943333E-08*T**3+539886*T**(-1); 3.70000E+03 Y - +14154.6461-51.4854586*T-24.47978*T*LN(T)-.002634759*T**2 - +6.01544333E-08*T**3-15120935*T**(-1); 9.60000E+03 Y - -314316.628+515.068037*T-87.56143*T*LN(T)+.0025787245*T**2 - -1.878765E-08*T**3+2.9052515E+08*T**(-1); 1.85000E+04 Y - -108797.175+288.483019*T-63.737*T*LN(T)+.0014375*T**2-9E-09*T**3 - +.25153895*T**(-1); 2.00000E+04 N ! - FUNCTION O3GAS 298.15 +130696.944-37.9096651*T-27.58118*T*LN(T) - -.02763076*T**2+4.60539333E-06*T**3+99530.45*T**(-1); 4.00000E+02 Y - +114760.623+176.626736*T-60.10286*T*LN(T)+.00206456*T**2 - -5.17486667E-07*T**3+1572175*T**(-1); 1.30000E+03 Y - +49468.3958+710.094819*T-134.3696*T*LN(T)+.039707355*T**2 - -4.10457667E-06*T**3+12362250*T**(-1); 2.10000E+03 Y - +866367.075-3566.80563*T+421.2001*T*LN(T)-.1284109*T**2 - +5.44768833E-06*T**3-2.1304835E+08*T**(-1); 2.80000E+03 Y - +409416.384-1950.70834*T+223.4437*T*LN(T)-.0922361*T**2 - +4.306855E-06*T**3-21589870*T**(-1); 3.50000E+03 Y - -1866338.6+6101.13383*T-764.8435*T*LN(T)+.09852775*T**2 - -2.59784667E-06*T**3+9.610855E+08*T**(-1); 4.90000E+03 Y - +97590.0432+890.79836*T-149.9608*T*LN(T)+.01283575*T**2 - -3.555105E-07*T**3-2.1699975E+08*T**(-1); 6000 N ! - FUNCTION GHSEROO 298.15 -3480.87-25.503038*T-11.136*T*LN(T) - -.005098888*T**2+6.61846E-07*T**3-38365*T**(-1); 1.00000E+03 Y - -6568.763+12.65988*T-16.8138*T*LN(T)-5.95798E-04*T**2+6.781E-09*T**3 - +262905*T**(-1); 3.30000E+03 Y - -13986.728+31.259625*T-18.9536*T*LN(T)-4.25243E-04*T**2 - +1.0721E-08*T**3+4383200*T**(-1); 6000 N ! - FUNCTION GASU 298.15 +523164.925+13.603288*T-32.513*T*LN(T) - +.01126565*T**2-2.43328E-06*T**3+151130*T**(-1); 9.00000E+02 Y - +541065.13-173.693179*T-5.336*T*LN(T)-.00723615*T**2-4.306E-08*T**3 - -2072960*T**(-1); 2.10000E+03 Y - +605452.662-512.542339*T+38.748*T*LN(T)-.0208079*T**2+7.5045E-07*T**3 - -19886375*T**(-1); 4.50000E+03 Y - -41328.1657+1300.29089*T-176.856*T*LN(T)+.0113664*T**2 - -1.56178333E-07*T**3+3.4654725E+08*T**(-1); 9.20000E+03 Y - +410972.67+537.324611*T-92.012*T*LN(T)+.0043702*T**2 - -4.90033333E-08*T**3-99572850*T**(-1); 1.20000E+04 N ! - FUNCTION GLIQUU 298.15 +3947.766+120.631251*T-26.9182*T*LN(T) - +.00125156*T**2-4.42605E-06*T**3+38568*T**(-1); 9.55000E+02 Y - -10166.3+281.797193*T-48.66*T*LN(T); 3.00000E+03 N ! - FUNCTION GFCCUU 298.15 -3407.734+130.955151*T-26.9182*T*LN(T) - +.00125156*T**2-4.42605E-06*T**3+38568*T**(-1); 9.55000E+02 Y - -17521.8+292.121093*T-48.66*T*LN(T); 3.00000E+03 N ! - FUNCTION GBCCUU 298.15 -752.767+131.5381*T-27.5152*T*LN(T) - -.00835595*T**2+9.67907E-07*T**3+204611*T**(-1); 1.04900E+03 Y - -4698.365+202.685635*T-38.2836*T*LN(T); 3.00000E+03 N ! - FUNCTION GHSERUU 298.15 -8407.734+130.955151*T-26.9182*T*LN(T) - +.00125156*T**2-4.42605E-06*T**3+38568*T**(-1); 9.55000E+02 Y - -22521.8+292.121093*T-48.66*T*LN(T); 3.00000E+03 N ! - FUNCTION GTETUU 298.15 -5156.136+106.976316*T-22.841*T*LN(T) - -.01084475*T**2+2.7889E-08*T**3+81944*T**(-1); 9.41500E+02 Y - -14327.309+244.16802*T-42.9278*T*LN(T); 3.00000E+03 N ! - FUNCTION UOGAS 298.15 +7058.467+16.66929*T-38.48092*T*LN(T) - -.01650935*T**2+6.74198333E-06*T**3-1.22913333E-09*T**4+257767*T**(-1); - 1.30000E+03 Y - +10617.823+76.4054808*T-50.04939*T*LN(T)+.0090553*T**2 - -2.0628666E-06*T**3+1.42865E-10*T**4-1254735*T**(-1); 4.00000E+03 N ! - FUNCTION UO2GAS 298.15 -477055.313+30.72281*T-44.35744*T*LN(T) - -.018817925*T**2+3.85927167E-06*T**3-4.58556667E-10*T**4 - +37425.465*T**(-1); 1.50000E+03 Y - -483042.479+128.845816*T-59.57586*T*LN(T)-.0026962*T**2 - -1.57719683E-08*T**3+8.57269167E-12*T**4+315972.55*T**(-1); 4000 N ! - FUNCTION UO3GAS 298.15 -813296.059+27.9636972*T-46.69199*T*LN(T) - -.047347135*T**2+1.58195017E-05*T**3-2.84654167E-09*T**4 - +139692.15*T**(-1); 9.00000E+02 Y - -827058.826+248.932783*T-81.70962*T*LN(T)-.001004739*T**2 - +1.85084167E-07*T**3-1.8022825E-11*T**4+1290177.5*T**(-1); 4000 N ! - FUNCTION LOWLIQ 298.15 +G4OV#+79775-25.0114*T-2.62269566E-21*T**7; - 2.60000E+03 N ! - FUNCTION O2ULIQ 298.15 -1590418+3618.8*T-480*T*LN(T)+.07*T**2 - -1E-06*T**3; 6000 N ! - FUNCTION G3OO 298.15 +G3OV#+GHSEROO#; 6000 N ! - FUNCTION G4OO 298.15 +G4OV#+GHSEROO#; 6000 N ! - FUNCTION G5OO 298.15 +G5OV#+GHSEROO#; 6000 N ! - FUNCTION G3OV 298.15 +G4OV#-G4VV#+G3VV#; 6000 N ! - FUNCTION G4OV 298.15 +GUO2#; 6000 N ! - FUNCTION G5OV 298.15 +GUO25#-.5*GHSEROO#+.69315*R#*T; 6000 N ! - FUNCTION G3VV 298.15 +GUO15#-1.5*GHSEROO#+1.12467*R#*T; 6000 N ! - FUNCTION G4VV 298.15 +G4OV#-2*GHSEROO#+545210.5; 6000 N ! - FUNCTION G5VV 298.15 +G5OV#-2*GHSEROO#+700000; 6000 N ! - FUNCTION GU3O8 298.15 -3674804.49+1600.50059*T - -276.747749*T*LN(T)-.0136644165*T**2+2036667.44*T**(-1); 2000 N ! - FUNCTION GU4O9 298.15 -4621329.3+1786.83274*T-311.20912*T*LN(T) - -.0311301013*T**2+1741269.49*T**(-1); 2.00000E+03 N ! - FUNCTION GUO15 298.15 +GUO2#-.5*GHSEROO#+747127-70.22618*T; 6000 N ! - FUNCTION GUO2 298.15 -1118940.2+554.00559*T-93.268*T*LN(T) - +.0101704254*T**2-2.03335671E-06*T**3+1091073.7*T**(-1); 6000 N ! - FUNCTION GUO25 298.15 +GUO2#+.5*GHSEROO#-58351.62+39.67611*T; 6000 N ! - FUNCTION UN_ASS 298.15 0; 300 N ! - - TYPE_DEFINITION % SEQ *! - DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! - DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! - - - PHASE GAS:G % 1 1.0 ! - CONSTITUENT GAS:G :O,O2,O3,U,UO,UO2,UO3 : ! - - PARAMETER G(GAS,O;0) 298.15 +OGAS#+RTLNP#; 6000 N REF174 ! - PARAMETER G(GAS,O2;0) 298.15 +O2GAS#+RTLNP#; 6000 N REF175 ! - PARAMETER G(GAS,O3;0) 298.15 +O3GAS#+RTLNP#; 6000 N REF176 ! - PARAMETER G(GAS,U;0) 298.15 +GASU#+RTLNP#; 6000 N REF160 ! - PARAMETER G(GAS,UO;0) 298.15 +UOGAS#+RTLNP#; 6000 N REF208 ! - PARAMETER G(GAS,UO2;0) 298.15 +UO2GAS#+RTLNP#; 6000 N REF209 ! - PARAMETER G(GAS,UO3;0) 298.15 +UO3GAS#+RTLNP#; 6000 N REF210 ! - - - PHASE IONIC_LIQUID:Y % 2 6 4 ! - CONSTITUENT IONIC_LIQUID:Y :U+4 : O-2,VA,O : ! - - PARAMETER G(IONIC_LIQUID,U+4:O-2;0) 298.15 +2*LOWLIQ#; 2.60000E+03 Y - +2*O2ULIQ#; 6000 N REF425 ! - PARAMETER G(IONIC_LIQUID,U+4:VA;0) 298.15 +GLIQUU#; 6000 N REF10 ! - PARAMETER G(IONIC_LIQUID,O;0) 298.15 +GHSEROO#-2648.9+31.44*T; - 6000 N REF10 ! - PARAMETER G(IONIC_LIQUID,U+4:O-2,VA;0) 298.15 +1773475.9-516*T; - 6000 N REF425 ! - PARAMETER G(IONIC_LIQUID,U+4:O-2,VA;1) 298.15 +46774.9-120.37888*T; - 6000 N REF425 ! - PARAMETER G(IONIC_LIQUID,U+4:O-2,VA;2) 298.15 -500000; 6000 N REF425 ! - PARAMETER G(IONIC_LIQUID,U+4:O-2,O;0) 298.15 -370000; 6000 N REF425 ! - - - TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! - PHASE BCC_A2 %& 2 1 3 ! - CONSTITUENT BCC_A2 :U : O,VA% : ! - - PARAMETER G(BCC_A2,U:O;0) 298.15 +GBCCUU#+GHSEROO#+100000; 6000 N REF70 ! - PARAMETER G(BCC_A2,U:VA;0) 298.15 +GBCCUU#; 6000 N REF10 ! - - - PHASE C1_MO2 % 3 1 2 1 ! - CONSTITUENT C1_MO2 :U+3,U+4%,U+5 : O-2%,VA : O-2,VA% : ! - - PARAMETER G(C1_MO2,U+3:O-2:O-2;0) 298.15 +G3OO#; 6000 N REF425 ! - PARAMETER G(C1_MO2,U+4:O-2:O-2;0) 298.15 +G4OO#; 6000 N REF425 ! - PARAMETER G(C1_MO2,U+5:O-2:O-2;0) 298.15 +G5OO#; 6000 N REF425 ! - PARAMETER G(C1_MO2,U+3:VA:O-2;0) 298.15 100000; 6000 N REF425 ! - PARAMETER G(C1_MO2,U+4:VA:O-2;0) 298.15 100000; 6000 N REF425 ! - PARAMETER G(C1_MO2,U+5:VA:O-2;0) 298.15 100000; 6000 N REF425 ! - PARAMETER G(C1_MO2,U+3:O-2:VA;0) 298.15 +G3OV#; 6000 N REF425 ! - PARAMETER G(C1_MO2,U+4:O-2:VA;0) 298.15 +G4OV#; 6000 N REF425 ! - PARAMETER G(C1_MO2,U+5:O-2:VA;0) 298.15 +G5OV#; 6000 N REF425 ! - PARAMETER G(C1_MO2,U+3:VA:VA;0) 298.15 +G3VV#; 6000 N REF425 ! - PARAMETER G(C1_MO2,U+4:VA:VA;0) 298.15 +G4VV#; 6000 N REF425 ! - PARAMETER G(C1_MO2,U+5:VA:VA;0) 298.15 +G5VV#; 6000 N REF425 ! - PARAMETER G(C1_MO2,U+4,U+5:O-2:O-2;0) 298.15 -124936.9-21.6838*T; - 6000 N REF425 ! - PARAMETER G(C1_MO2,U+3,U+4:O-2:VA;0) 298.15 40133.7; 6000 N REF425 ! - PARAMETER G(C1_MO2,U+3,U+4:O-2:VA;1) 298.15 1076.4; 6000 N REF425 ! - - - TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! - PHASE FCC_A1 %' 2 1 1 ! - CONSTITUENT FCC_A1 :U : O,VA : ! - - PARAMETER G(FCC_A1,U:O;0) 298.15 -504526+100*T+GHSEROO#+GHSERUU#; - 6000 N REF0 ! - PARAMETER G(FCC_A1,U:VA;0) 298.15 +GFCCUU#; 3.00000E+03 N REF10 ! - - - PHASE ORTHORHOMBIC_A20 % 1 1.0 ! - CONSTITUENT ORTHORHOMBIC_A20 :U% : ! - - PARAMETER G(ORTHORHOMBIC_A20,U;0) 298.15 +GHSERUU#; 4.00000E+03 N REF10 ! - - - PHASE TETRAGONAL_U % 1 1.0 ! - CONSTITUENT TETRAGONAL_U :U% : ! - - PARAMETER G(TETRAGONAL_U,U;0) 298.15 +GTETUU#; 3.00000E+03 N REF10 ! - - - PHASE U3O8_S % 2 8 3 ! - CONSTITUENT U3O8_S :O : U : ! - - PARAMETER G(U3O8_S,O:U;0) 298.15 +GU3O8#; 6000 N REF425 ! - - - PHASE U3O8_S2 % 2 8 3 ! - CONSTITUENT U3O8_S2 :O : U : ! - - PARAMETER G(U3O8_S2,O:U;0) 298.15 +GU3O8#+135-.279503106*T; 6000 N REF212 ! - - - PHASE U3O8_S3 % 2 8 3 ! - CONSTITUENT U3O8_S3 :O : U : ! - - PARAMETER G(U3O8_S3,O:U;0) 298.15 +GU3O8#+283-.540066486*T; 6000 N REF212 ! - - - PHASE U3O8_S4 % 2 8 3 ! - CONSTITUENT U3O8_S4 :O : U : ! - - PARAMETER G(U3O8_S4,O:U;0) 298.15 +GU3O8#+597-.918379739*T; 6000 N REF212 ! - - - PHASE U4O9_S % 2 9 4 ! - CONSTITUENT U4O9_S :O : U : ! - - PARAMETER G(U4O9_S,O:U;0) 298.15 +GU4O9#; 6000 N REF425 ! - - - PHASE U4O9_S2 % 2 9 4 ! - CONSTITUENT U4O9_S2 :O : U : ! - - PARAMETER G(U4O9_S2,O:U;0) 298.15 +GU4O9#+2594-7.45402299*T; 6000 N REF213 ! - - - PHASE U4O9_S3 % 2 9 4 ! - CONSTITUENT U4O9_S3 :O : U : ! - - PARAMETER G(U4O9_S3,O:U;0) 298.15 +GU4O9#+2684.25-7.5602*T; 6000 N REF213 ! - - - PHASE UO3 % 2 3 1 ! - CONSTITUENT UO3 :O : U : ! - - PARAMETER G(UO3,O:U;0) 298.15 -1260394.62+616.475675*T - -105.7368*T*LN(T)+.0104274*T**2-3.18099167E-06*T**3+868736*T**(-1); - 3.00000E+03 N REF211 ! - - - LIST_OF_REFERENCES - NUMBER SOURCE - REF174 'O1 JANAF 1982; ASSESSMENT DATED 3/77 SGTE OXYGEN , from SSUB' - REF175 'O2 T.C.R.A.S. Class: 1 OXYGEN , from SSUB' - REF176 'O3 T.C.R.A.S. Class: 4 OZONE , from SSUB' - REF10 'A T Dinsdale, SGTE Data for Pure Elements, Calphad 15(1991)4 p - 317-425; also in NPL Report DMA(A)195 Rev. August 1990' - REF160 'U1 T.C.R.A.S Class: 4 Data provided by T.C.R.A.S. in 2000, - from SSUB' - REF208 'O1U1 T.C.R.A.S Class: 6 Data provided by T.C.R.A.S. in 2000, - from SSUB, different of Tbase' - REF209 'O2U1 T.C.R.A.S. Class: 6 URANIUM DIOXIDE , from SSUB, - slightly different of Tbase' - REF210 'O3U1 T.C.R.A.S Class: 6 Data provided by T.C.R.A.S. in 2000, - from SSUB, different of Tbase' - REF425 'C. Guéneau, N. Dupin, B. Sundman, C. Martial, J.-C. Dumas, S. - Gossé,2 S. Chatain, F. De Bruycker, D. Manara, R.J.M. Konings, J. - Nucl. Mat. 419 (1-3), 145-167 (2011); C-O-Pu-U' - REF70 'fixing some parameters of low importance' - REF211 'O3U1 T.C.R.A.S. Class: 7 URANIUM TRIOXIDE, from SSUB' - REF212 'SSUB 3-URANIUM 8-OXIDE : M.H.Rand March 1994, taken from - Cordfunke. In the fuelbase, the expression relative to the alpha - form has been kept identical to SSUB for the higher temperatures - forms but the alpha form expression has been modified in 11GUE' - REF213 'SSUB 4-URANIUM 9-OXIDE : M.H.Rand March 1994, taken from - Cordfunke. In the fuelbase, the expression relative to the alpha - form has been kept identical to SSUB for beta and to 08GUE for - gamma but the alpha form expression has been modified in 11GUE' - ! - + +$ Database file written 2013- 3-10 +$ From database: USER + ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT O GAS_1/2_MOLE_O2 1.5999E+01 4.3410E+03 1.0252E+02! + ELEMENT U ORTHORHOMBIC_A20 2.3803E+02 6.3640E+03 5.0200E+01! + + SPECIES O-2 O1/-2! + SPECIES O2 O2! + SPECIES O3 O3! + SPECIES U+3 U1/+3! + SPECIES U+4 U1/+4! + SPECIES U+5 U1/+5! + SPECIES UO O1U1! + SPECIES UO2 O2U1! + SPECIES UO3 O3U1! + + FUNCTION OGAS 298.15 +243206.494-20.8612587*T-21.01555*T*LN(T) + +1.2687055E-04*T**2-1.23131283E-08*T**3-42897.09*T**(-1); 2950 Y + +252301.423-52.0847285*T-17.21188*T*LN(T)-5.413565E-04*T**2 + +7.64520667E-09*T**3-3973170.5*T**(-1); 6000 N ! + FUNCTION O2GAS 298.15 -6960.69252-51.1831473*T-22.25862*T*LN(T) + -.01023867*T**2+1.339947E-06*T**3-76749.55*T**(-1); 9.00000E+02 Y + -13136.0172+24.743296*T-33.55726*T*LN(T)-.0012348985*T**2 + +1.66943333E-08*T**3+539886*T**(-1); 3.70000E+03 Y + +14154.6461-51.4854586*T-24.47978*T*LN(T)-.002634759*T**2 + +6.01544333E-08*T**3-15120935*T**(-1); 9.60000E+03 Y + -314316.628+515.068037*T-87.56143*T*LN(T)+.0025787245*T**2 + -1.878765E-08*T**3+2.9052515E+08*T**(-1); 1.85000E+04 Y + -108797.175+288.483019*T-63.737*T*LN(T)+.0014375*T**2-9E-09*T**3 + +.25153895*T**(-1); 2.00000E+04 N ! + FUNCTION O3GAS 298.15 +130696.944-37.9096651*T-27.58118*T*LN(T) + -.02763076*T**2+4.60539333E-06*T**3+99530.45*T**(-1); 4.00000E+02 Y + +114760.623+176.626736*T-60.10286*T*LN(T)+.00206456*T**2 + -5.17486667E-07*T**3+1572175*T**(-1); 1.30000E+03 Y + +49468.3958+710.094819*T-134.3696*T*LN(T)+.039707355*T**2 + -4.10457667E-06*T**3+12362250*T**(-1); 2.10000E+03 Y + +866367.075-3566.80563*T+421.2001*T*LN(T)-.1284109*T**2 + +5.44768833E-06*T**3-2.1304835E+08*T**(-1); 2.80000E+03 Y + +409416.384-1950.70834*T+223.4437*T*LN(T)-.0922361*T**2 + +4.306855E-06*T**3-21589870*T**(-1); 3.50000E+03 Y + -1866338.6+6101.13383*T-764.8435*T*LN(T)+.09852775*T**2 + -2.59784667E-06*T**3+9.610855E+08*T**(-1); 4.90000E+03 Y + +97590.0432+890.79836*T-149.9608*T*LN(T)+.01283575*T**2 + -3.555105E-07*T**3-2.1699975E+08*T**(-1); 6000 N ! + FUNCTION GHSEROO 298.15 -3480.87-25.503038*T-11.136*T*LN(T) + -.005098888*T**2+6.61846E-07*T**3-38365*T**(-1); 1.00000E+03 Y + -6568.763+12.65988*T-16.8138*T*LN(T)-5.95798E-04*T**2+6.781E-09*T**3 + +262905*T**(-1); 3.30000E+03 Y + -13986.728+31.259625*T-18.9536*T*LN(T)-4.25243E-04*T**2 + +1.0721E-08*T**3+4383200*T**(-1); 6000 N ! + FUNCTION GASU 298.15 +523164.925+13.603288*T-32.513*T*LN(T) + +.01126565*T**2-2.43328E-06*T**3+151130*T**(-1); 9.00000E+02 Y + +541065.13-173.693179*T-5.336*T*LN(T)-.00723615*T**2-4.306E-08*T**3 + -2072960*T**(-1); 2.10000E+03 Y + +605452.662-512.542339*T+38.748*T*LN(T)-.0208079*T**2+7.5045E-07*T**3 + -19886375*T**(-1); 4.50000E+03 Y + -41328.1657+1300.29089*T-176.856*T*LN(T)+.0113664*T**2 + -1.56178333E-07*T**3+3.4654725E+08*T**(-1); 9.20000E+03 Y + +410972.67+537.324611*T-92.012*T*LN(T)+.0043702*T**2 + -4.90033333E-08*T**3-99572850*T**(-1); 1.20000E+04 N ! + FUNCTION GLIQUU 298.15 +3947.766+120.631251*T-26.9182*T*LN(T) + +.00125156*T**2-4.42605E-06*T**3+38568*T**(-1); 9.55000E+02 Y + -10166.3+281.797193*T-48.66*T*LN(T); 3.00000E+03 N ! + FUNCTION GFCCUU 298.15 -3407.734+130.955151*T-26.9182*T*LN(T) + +.00125156*T**2-4.42605E-06*T**3+38568*T**(-1); 9.55000E+02 Y + -17521.8+292.121093*T-48.66*T*LN(T); 3.00000E+03 N ! + FUNCTION GBCCUU 298.15 -752.767+131.5381*T-27.5152*T*LN(T) + -.00835595*T**2+9.67907E-07*T**3+204611*T**(-1); 1.04900E+03 Y + -4698.365+202.685635*T-38.2836*T*LN(T); 3.00000E+03 N ! + FUNCTION GHSERUU 298.15 -8407.734+130.955151*T-26.9182*T*LN(T) + +.00125156*T**2-4.42605E-06*T**3+38568*T**(-1); 9.55000E+02 Y + -22521.8+292.121093*T-48.66*T*LN(T); 3.00000E+03 N ! + FUNCTION GTETUU 298.15 -5156.136+106.976316*T-22.841*T*LN(T) + -.01084475*T**2+2.7889E-08*T**3+81944*T**(-1); 9.41500E+02 Y + -14327.309+244.16802*T-42.9278*T*LN(T); 3.00000E+03 N ! + FUNCTION UOGAS 298.15 +7058.467+16.66929*T-38.48092*T*LN(T) + -.01650935*T**2+6.74198333E-06*T**3-1.22913333E-09*T**4+257767*T**(-1); + 1.30000E+03 Y + +10617.823+76.4054808*T-50.04939*T*LN(T)+.0090553*T**2 + -2.0628666E-06*T**3+1.42865E-10*T**4-1254735*T**(-1); 4.00000E+03 N ! + FUNCTION UO2GAS 298.15 -477055.313+30.72281*T-44.35744*T*LN(T) + -.018817925*T**2+3.85927167E-06*T**3-4.58556667E-10*T**4 + +37425.465*T**(-1); 1.50000E+03 Y + -483042.479+128.845816*T-59.57586*T*LN(T)-.0026962*T**2 + -1.57719683E-08*T**3+8.57269167E-12*T**4+315972.55*T**(-1); 4000 N ! + FUNCTION UO3GAS 298.15 -813296.059+27.9636972*T-46.69199*T*LN(T) + -.047347135*T**2+1.58195017E-05*T**3-2.84654167E-09*T**4 + +139692.15*T**(-1); 9.00000E+02 Y + -827058.826+248.932783*T-81.70962*T*LN(T)-.001004739*T**2 + +1.85084167E-07*T**3-1.8022825E-11*T**4+1290177.5*T**(-1); 4000 N ! + FUNCTION LOWLIQ 298.15 +G4OV#+79775-25.0114*T-2.62269566E-21*T**7; + 2.60000E+03 N ! + FUNCTION O2ULIQ 298.15 -1590418+3618.8*T-480*T*LN(T)+.07*T**2 + -1E-06*T**3; 6000 N ! + FUNCTION G3OO 298.15 +G3OV#+GHSEROO#; 6000 N ! + FUNCTION G4OO 298.15 +G4OV#+GHSEROO#; 6000 N ! + FUNCTION G5OO 298.15 +G5OV#+GHSEROO#; 6000 N ! + FUNCTION G3OV 298.15 +G4OV#-G4VV#+G3VV#; 6000 N ! + FUNCTION G4OV 298.15 +GUO2#; 6000 N ! + FUNCTION G5OV 298.15 +GUO25#-.5*GHSEROO#+.69315*R#*T; 6000 N ! + FUNCTION G3VV 298.15 +GUO15#-1.5*GHSEROO#+1.12467*R#*T; 6000 N ! + FUNCTION G4VV 298.15 +G4OV#-2*GHSEROO#+545210.5; 6000 N ! + FUNCTION G5VV 298.15 +G5OV#-2*GHSEROO#+700000; 6000 N ! + FUNCTION GU3O8 298.15 -3674804.49+1600.50059*T + -276.747749*T*LN(T)-.0136644165*T**2+2036667.44*T**(-1); 2000 N ! + FUNCTION GU4O9 298.15 -4621329.3+1786.83274*T-311.20912*T*LN(T) + -.0311301013*T**2+1741269.49*T**(-1); 2.00000E+03 N ! + FUNCTION GUO15 298.15 +GUO2#-.5*GHSEROO#+747127-70.22618*T; 6000 N ! + FUNCTION GUO2 298.15 -1118940.2+554.00559*T-93.268*T*LN(T) + +.0101704254*T**2-2.03335671E-06*T**3+1091073.7*T**(-1); 6000 N ! + FUNCTION GUO25 298.15 +GUO2#+.5*GHSEROO#-58351.62+39.67611*T; 6000 N ! + FUNCTION UN_ASS 298.15 0; 300 N ! + + TYPE_DEFINITION % SEQ *! + DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! + DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! + + + PHASE GAS:G % 1 1.0 ! + CONSTITUENT GAS:G :O,O2,O3,U,UO,UO2,UO3 : ! + + PARAMETER G(GAS,O;0) 298.15 +OGAS#+RTLNP#; 6000 N REF174 ! + PARAMETER G(GAS,O2;0) 298.15 +O2GAS#+RTLNP#; 6000 N REF175 ! + PARAMETER G(GAS,O3;0) 298.15 +O3GAS#+RTLNP#; 6000 N REF176 ! + PARAMETER G(GAS,U;0) 298.15 +GASU#+RTLNP#; 6000 N REF160 ! + PARAMETER G(GAS,UO;0) 298.15 +UOGAS#+RTLNP#; 6000 N REF208 ! + PARAMETER G(GAS,UO2;0) 298.15 +UO2GAS#+RTLNP#; 6000 N REF209 ! + PARAMETER G(GAS,UO3;0) 298.15 +UO3GAS#+RTLNP#; 6000 N REF210 ! + + + PHASE IONIC_LIQUID:Y % 2 6 4 ! + CONSTITUENT IONIC_LIQUID:Y :U+4 : O-2,VA,O : ! + + PARAMETER G(IONIC_LIQUID,U+4:O-2;0) 298.15 +2*LOWLIQ#; 2.60000E+03 Y + +2*O2ULIQ#; 6000 N REF425 ! + PARAMETER G(IONIC_LIQUID,U+4:VA;0) 298.15 +GLIQUU#; 6000 N REF10 ! + PARAMETER G(IONIC_LIQUID,O;0) 298.15 +GHSEROO#-2648.9+31.44*T; + 6000 N REF10 ! + PARAMETER G(IONIC_LIQUID,U+4:O-2,VA;0) 298.15 +1773475.9-516*T; + 6000 N REF425 ! + PARAMETER G(IONIC_LIQUID,U+4:O-2,VA;1) 298.15 +46774.9-120.37888*T; + 6000 N REF425 ! + PARAMETER G(IONIC_LIQUID,U+4:O-2,VA;2) 298.15 -500000; 6000 N REF425 ! + PARAMETER G(IONIC_LIQUID,U+4:O-2,O;0) 298.15 -370000; 6000 N REF425 ! + + + TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! + PHASE BCC_A2 %& 2 1 3 ! + CONSTITUENT BCC_A2 :U : O,VA% : ! + + PARAMETER G(BCC_A2,U:O;0) 298.15 +GBCCUU#+GHSEROO#+100000; 6000 N REF70 ! + PARAMETER G(BCC_A2,U:VA;0) 298.15 +GBCCUU#; 6000 N REF10 ! + + + PHASE C1_MO2 % 3 1 2 1 ! + CONSTITUENT C1_MO2 :U+3,U+4%,U+5 : O-2%,VA : O-2,VA% : ! + + PARAMETER G(C1_MO2,U+3:O-2:O-2;0) 298.15 +G3OO#; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+4:O-2:O-2;0) 298.15 +G4OO#; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+5:O-2:O-2;0) 298.15 +G5OO#; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+3:VA:O-2;0) 298.15 100000; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+4:VA:O-2;0) 298.15 100000; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+5:VA:O-2;0) 298.15 100000; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+3:O-2:VA;0) 298.15 +G3OV#; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+4:O-2:VA;0) 298.15 +G4OV#; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+5:O-2:VA;0) 298.15 +G5OV#; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+3:VA:VA;0) 298.15 +G3VV#; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+4:VA:VA;0) 298.15 +G4VV#; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+5:VA:VA;0) 298.15 +G5VV#; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+4,U+5:O-2:O-2;0) 298.15 -124936.9-21.6838*T; + 6000 N REF425 ! + PARAMETER G(C1_MO2,U+3,U+4:O-2:VA;0) 298.15 40133.7; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+3,U+4:O-2:VA;1) 298.15 1076.4; 6000 N REF425 ! + + + TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! + PHASE FCC_A1 %' 2 1 1 ! + CONSTITUENT FCC_A1 :U : O,VA : ! + + PARAMETER G(FCC_A1,U:O;0) 298.15 -504526+100*T+GHSEROO#+GHSERUU#; + 6000 N REF0 ! + PARAMETER G(FCC_A1,U:VA;0) 298.15 +GFCCUU#; 3.00000E+03 N REF10 ! + + + PHASE ORTHORHOMBIC_A20 % 1 1.0 ! + CONSTITUENT ORTHORHOMBIC_A20 :U% : ! + + PARAMETER G(ORTHORHOMBIC_A20,U;0) 298.15 +GHSERUU#; 4.00000E+03 N REF10 ! + + + PHASE TETRAGONAL_U % 1 1.0 ! + CONSTITUENT TETRAGONAL_U :U% : ! + + PARAMETER G(TETRAGONAL_U,U;0) 298.15 +GTETUU#; 3.00000E+03 N REF10 ! + + + PHASE U3O8_S % 2 8 3 ! + CONSTITUENT U3O8_S :O : U : ! + + PARAMETER G(U3O8_S,O:U;0) 298.15 +GU3O8#; 6000 N REF425 ! + + + PHASE U3O8_S2 % 2 8 3 ! + CONSTITUENT U3O8_S2 :O : U : ! + + PARAMETER G(U3O8_S2,O:U;0) 298.15 +GU3O8#+135-.279503106*T; 6000 N REF212 ! + + + PHASE U3O8_S3 % 2 8 3 ! + CONSTITUENT U3O8_S3 :O : U : ! + + PARAMETER G(U3O8_S3,O:U;0) 298.15 +GU3O8#+283-.540066486*T; 6000 N REF212 ! + + + PHASE U3O8_S4 % 2 8 3 ! + CONSTITUENT U3O8_S4 :O : U : ! + + PARAMETER G(U3O8_S4,O:U;0) 298.15 +GU3O8#+597-.918379739*T; 6000 N REF212 ! + + + PHASE U4O9_S % 2 9 4 ! + CONSTITUENT U4O9_S :O : U : ! + + PARAMETER G(U4O9_S,O:U;0) 298.15 +GU4O9#; 6000 N REF425 ! + + + PHASE U4O9_S2 % 2 9 4 ! + CONSTITUENT U4O9_S2 :O : U : ! + + PARAMETER G(U4O9_S2,O:U;0) 298.15 +GU4O9#+2594-7.45402299*T; 6000 N REF213 ! + + + PHASE U4O9_S3 % 2 9 4 ! + CONSTITUENT U4O9_S3 :O : U : ! + + PARAMETER G(U4O9_S3,O:U;0) 298.15 +GU4O9#+2684.25-7.5602*T; 6000 N REF213 ! + + + PHASE UO3 % 2 3 1 ! + CONSTITUENT UO3 :O : U : ! + + PARAMETER G(UO3,O:U;0) 298.15 -1260394.62+616.475675*T + -105.7368*T*LN(T)+.0104274*T**2-3.18099167E-06*T**3+868736*T**(-1); + 3.00000E+03 N REF211 ! + + + LIST_OF_REFERENCES + NUMBER SOURCE + REF174 'O1 JANAF 1982; ASSESSMENT DATED 3/77 SGTE OXYGEN , from SSUB' + REF175 'O2 T.C.R.A.S. Class: 1 OXYGEN , from SSUB' + REF176 'O3 T.C.R.A.S. Class: 4 OZONE , from SSUB' + REF10 'A T Dinsdale, SGTE Data for Pure Elements, Calphad 15(1991)4 p + 317-425; also in NPL Report DMA(A)195 Rev. August 1990' + REF160 'U1 T.C.R.A.S Class: 4 Data provided by T.C.R.A.S. in 2000, + from SSUB' + REF208 'O1U1 T.C.R.A.S Class: 6 Data provided by T.C.R.A.S. in 2000, + from SSUB, different of Tbase' + REF209 'O2U1 T.C.R.A.S. Class: 6 URANIUM DIOXIDE , from SSUB, + slightly different of Tbase' + REF210 'O3U1 T.C.R.A.S Class: 6 Data provided by T.C.R.A.S. in 2000, + from SSUB, different of Tbase' + REF425 'C. Guéneau, N. Dupin, B. Sundman, C. Martial, J.-C. Dumas, S. + Gossé,2 S. Chatain, F. De Bruycker, D. Manara, R.J.M. Konings, J. + Nucl. Mat. 419 (1-3), 145-167 (2011); C-O-Pu-U' + REF70 'fixing some parameters of low importance' + REF211 'O3U1 T.C.R.A.S. Class: 7 URANIUM TRIOXIDE, from SSUB' + REF212 'SSUB 3-URANIUM 8-OXIDE : M.H.Rand March 1994, taken from + Cordfunke. In the fuelbase, the expression relative to the alpha + form has been kept identical to SSUB for the higher temperatures + forms but the alpha form expression has been modified in 11GUE' + REF213 'SSUB 4-URANIUM 9-OXIDE : M.H.Rand March 1994, taken from + Cordfunke. In the fuelbase, the expression relative to the alpha + form has been kept identical to SSUB for beta and to 08GUE for + gamma but the alpha form expression has been modified in 11GUE' + ! + diff --git a/macros/agcu.TDB b/macros/ocv2/agcu.TDB similarity index 97% rename from macros/agcu.TDB rename to macros/ocv2/agcu.TDB index 7af147e..5189058 100644 --- a/macros/agcu.TDB +++ b/macros/ocv2/agcu.TDB @@ -1,72 +1,72 @@ -$ Database file written 2014- 2-22 -$ From database: SSOL2 - ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! - ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! - ELEMENT AG FCC_A1 1.0787E+02 5.7446E+03 4.2551E+01! - ELEMENT CU FCC_A1 6.3546E+01 5.0041E+03 3.3150E+01! - - - FUNCTION GHSERAG 298.15 -7209.512+118.200733*T-23.8463314*T*LN(T) - -.001790585*T**2-3.98587E-07*T**3-12011*T**(-1); 1.23508E+03 Y - -15095.314+190.265169*T-33.472*T*LN(T)+1.412186E+29*T**(-9); 3000 N ! - FUNCTION GHSERCU 298.15 -7770.458+130.485403*T-24.112392*T*LN(T) - -.00265684*T**2+1.29223E-07*T**3+52478*T**(-1); 1.35802E+03 Y - -13542.33+183.804197*T-31.38*T*LN(T)+3.64643E+29*T**(-9); 3200 N ! - FUNCTION UN_ASS 298.15 0; 300 N ! - - TYPE_DEFINITION % SEQ *! - DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! - DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! - - - PHASE LIQUID:L % 1 1.0 ! - CONSTITUENT LIQUID:L :AG,CU : ! - - PARAMETER G(LIQUID,AG;0) 298.15 +11025.293-8.890146*T - -1.0322E-20*T**7+GHSERAG#; 1.23508E+03 Y - +11507.972-9.300495*T-1.412186E+29*T**(-9)+GHSERAG#; 3000 N REF283 ! - PARAMETER G(LIQUID,CU;0) 298.15 +12964.84-9.510243*T - -5.83932E-21*T**7+GHSERCU#; 1.35802E+03 Y - +13495.4-9.920463*T-3.64643E+29*T**(-9)+GHSERCU#; 3.20000E+03 N REF283 ! - PARAMETER G(LIQUID,AG,CU;0) 298.15 +17534.6-4.45479*T; 6000 N REF137 ! - PARAMETER G(LIQUID,AG,CU;1) 298.15 +2251.3-2.6733*T; 6000 N REF137 ! - PARAMETER G(LIQUID,AG,CU;2) 298.15 492.7; 6000 N REF137 ! - - - TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! - PHASE BCC_A2 %& 2 1 3 ! - CONSTITUENT BCC_A2 :AG,CU : VA% : ! - - PARAMETER G(BCC_A2,AG:VA;0) 298.15 +3400-1.05*T+GHSERAG#; 3000 N REF283 ! - PARAMETER G(BCC_A2,CU:VA;0) 298.15 +4017-1.255*T+GHSERCU#; 3200 N REF283 ! - PARAMETER G(BCC_A2,AG,CU:VA;0) 298.15 +35000-8*T; 6000 N REF135 ! - - - TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! - PHASE FCC_A1 %' 2 1 1 ! - CONSTITUENT FCC_A1 :AG%,CU% : VA% : ! - - PARAMETER G(FCC_A1,AG:VA;0) 298.15 +GHSERAG#; 3.00000E+03 N REF283 ! - PARAMETER G(FCC_A1,CU:VA;0) 298.15 +GHSERCU#; 3.20000E+03 N REF283 ! - PARAMETER G(FCC_A1,AG,CU:VA;0) 298.15 +33819.1-8.1236*T; 6000 N REF137 ! - PARAMETER G(FCC_A1,AG,CU:VA;1) 298.15 -5601.9+1.32997*T; 6000 N REF137 ! - - - TYPE_DEFINITION ( GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 ! - PHASE HCP_A3 %( 2 1 .5 ! - CONSTITUENT HCP_A3 :AG,CU : VA% : ! - - PARAMETER G(HCP_A3,AG:VA;0) 298.15 +300+.3*T+GHSERAG#; 3000 N REF283 ! - PARAMETER G(HCP_A3,CU:VA;0) 298.15 +600+.2*T+GHSERCU#; 3200 N REF283 ! - PARAMETER G(HCP_A3,AG,CU:VA;0) 298.15 +35000-8*T; 6000 N REF135 ! - - LIST_OF_REFERENCES - NUMBER SOURCE - REF283 'Alan Dinsdale, SGTE Data for Pure Elements, - Calphad Vol 15(1991) p 317-425, - also in NPL Report DMA(A)195 Rev. August 1990' - REF137 'F.H. Hayes, H.L. Lukas, G. Effenberg, G. Petzow,' - Z. fur Metallkde, Vol 77 (1986), No 11, p 749-754; AG-CU-PB' - REF135 'Unassessed parameter, inserted to make this phase less stable.' - ! - +$ Database file written 2014- 2-22 +$ From database: SSOL2 + ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT AG FCC_A1 1.0787E+02 5.7446E+03 4.2551E+01! + ELEMENT CU FCC_A1 6.3546E+01 5.0041E+03 3.3150E+01! + + + FUNCTION GHSERAG 298.15 -7209.512+118.200733*T-23.8463314*T*LN(T) + -.001790585*T**2-3.98587E-07*T**3-12011*T**(-1); 1.23508E+03 Y + -15095.314+190.265169*T-33.472*T*LN(T)+1.412186E+29*T**(-9); 3000 N ! + FUNCTION GHSERCU 298.15 -7770.458+130.485403*T-24.112392*T*LN(T) + -.00265684*T**2+1.29223E-07*T**3+52478*T**(-1); 1.35802E+03 Y + -13542.33+183.804197*T-31.38*T*LN(T)+3.64643E+29*T**(-9); 3200 N ! + FUNCTION UN_ASS 298.15 0; 300 N ! + + TYPE_DEFINITION % SEQ *! + DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! + DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! + + + PHASE LIQUID:L % 1 1.0 ! + CONSTITUENT LIQUID:L :AG,CU : ! + + PARAMETER G(LIQUID,AG;0) 298.15 +11025.293-8.890146*T + -1.0322E-20*T**7+GHSERAG#; 1.23508E+03 Y + +11507.972-9.300495*T-1.412186E+29*T**(-9)+GHSERAG#; 3000 N REF283 ! + PARAMETER G(LIQUID,CU;0) 298.15 +12964.84-9.510243*T + -5.83932E-21*T**7+GHSERCU#; 1.35802E+03 Y + +13495.4-9.920463*T-3.64643E+29*T**(-9)+GHSERCU#; 3.20000E+03 N REF283 ! + PARAMETER G(LIQUID,AG,CU;0) 298.15 +17534.6-4.45479*T; 6000 N REF137 ! + PARAMETER G(LIQUID,AG,CU;1) 298.15 +2251.3-2.6733*T; 6000 N REF137 ! + PARAMETER G(LIQUID,AG,CU;2) 298.15 492.7; 6000 N REF137 ! + + + TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! + PHASE BCC_A2 %& 2 1 3 ! + CONSTITUENT BCC_A2 :AG,CU : VA% : ! + + PARAMETER G(BCC_A2,AG:VA;0) 298.15 +3400-1.05*T+GHSERAG#; 3000 N REF283 ! + PARAMETER G(BCC_A2,CU:VA;0) 298.15 +4017-1.255*T+GHSERCU#; 3200 N REF283 ! + PARAMETER G(BCC_A2,AG,CU:VA;0) 298.15 +35000-8*T; 6000 N REF135 ! + + + TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! + PHASE FCC_A1 %' 2 1 1 ! + CONSTITUENT FCC_A1 :AG%,CU% : VA% : ! + + PARAMETER G(FCC_A1,AG:VA;0) 298.15 +GHSERAG#; 3.00000E+03 N REF283 ! + PARAMETER G(FCC_A1,CU:VA;0) 298.15 +GHSERCU#; 3.20000E+03 N REF283 ! + PARAMETER G(FCC_A1,AG,CU:VA;0) 298.15 +33819.1-8.1236*T; 6000 N REF137 ! + PARAMETER G(FCC_A1,AG,CU:VA;1) 298.15 -5601.9+1.32997*T; 6000 N REF137 ! + + + TYPE_DEFINITION ( GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 ! + PHASE HCP_A3 %( 2 1 .5 ! + CONSTITUENT HCP_A3 :AG,CU : VA% : ! + + PARAMETER G(HCP_A3,AG:VA;0) 298.15 +300+.3*T+GHSERAG#; 3000 N REF283 ! + PARAMETER G(HCP_A3,CU:VA;0) 298.15 +600+.2*T+GHSERCU#; 3200 N REF283 ! + PARAMETER G(HCP_A3,AG,CU:VA;0) 298.15 +35000-8*T; 6000 N REF135 ! + + LIST_OF_REFERENCES + NUMBER SOURCE + REF283 'Alan Dinsdale, SGTE Data for Pure Elements, + Calphad Vol 15(1991) p 317-425, + also in NPL Report DMA(A)195 Rev. August 1990' + REF137 'F.H. Hayes, H.L. Lukas, G. Effenberg, G. Petzow,' + Z. fur Metallkde, Vol 77 (1986), No 11, p 749-754; AG-CU-PB' + REF135 'Unassessed parameter, inserted to make this phase less stable.' + ! + diff --git a/macros/ocv2/all.OCM b/macros/ocv2/all.OCM new file mode 100644 index 0000000..2f0bce2 --- /dev/null +++ b/macros/ocv2/all.OCM @@ -0,0 +1,122 @@ +@$ running all test macros +set echo + +mac unary + +@$ ********************************************************* +@& ********************************************************* + +new Y +mac melting + +@$ ********************************************************* +@& ********************************************************* + +new Y +mac step1 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac step2 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac step3 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac step4 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac step5 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac step6 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac step7 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac map1 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac map2 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac map3 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac map4 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac map5 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac map6 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac map8 + +@$ ********************************************************* +@& ********************************************************* + +new Y +mac map7 + +@$ ********************************************************* +@& ********************************************************* + + +@$ that is all + +set inter + diff --git a/macros/hogas.TDB b/macros/ocv2/hogas.TDB similarity index 98% rename from macros/hogas.TDB rename to macros/ocv2/hogas.TDB index c6b4dd2..d0614c8 100644 --- a/macros/hogas.TDB +++ b/macros/ocv2/hogas.TDB @@ -1,142 +1,142 @@ - -$ Database file written 2012- 5-31 -$ From database: USER - ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! - ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! - ELEMENT H 1/2_MOLE_H2(GAS) 1.0079E+00 4.2340E+03 6.5285E+01! - ELEMENT O 1/2_MOLE_O2(GAS) 1.5999E+01 4.3410E+03 1.0252E+02! - - SPECIES H1O1 H1O1! - SPECIES H1O2 H1O2! - SPECIES H2 H2! - SPECIES H2O1 H2O1! - SPECIES H2O2 H2O2! - SPECIES O2 O2! - SPECIES O3 O3! - - FUNCTION F10447T 2.98150E+02 +211801.621+24.4989816*T-20.78611*T*LN(T); - 6.00000E+03 N ! - FUNCTION F10666T 2.98150E+02 +30698.6898+15.9096451*T-29.97699*T*LN(T) - +.001713168*T**2-6.799205E-07*T**3-25503.82*T**(-1); 1.00000E+03 Y - +31735.5127-12.686636*T-25.42186*T*LN(T)-.003149545*T**2 - +1.34404917E-07*T**3+116618.65*T**(-1); 3.00000E+03 Y - +41016.0783-20.7343256*T-24.94216*T*LN(T)-.0023107985*T**2 - +5.91863E-08*T**3-6415210*T**(-1); 8.60000E+03 Y - -154907.953+370.326117*T-69.24542*T*LN(T)+.0019361405*T**2 - -1.47539017E-08*T**3+1.4391015E+08*T**(-1); 1.80000E+04 Y - +326722.277-65.0792741*T-24.2768*T*LN(T)+6.42189E-05*T**2 - -1.30298483E-10*T**3-8.292415E+08*T**(-1); 2.00000E+04 N ! - FUNCTION F10729T 2.98150E+02 +1075.64106-55.242048*T-24.45435*T*LN(T) - -.018507875*T**2+2.36297E-06*T**3-29469.05*T**(-1); 8.00000E+02 Y - -7932.99164+54.2016233*T-40.775*T*LN(T)-.00501027*T**2 - +2.122915E-07*T**3+925845*T**(-1); 3.60000E+03 Y - -67875.8961+275.406716*T-68.1173*T*LN(T)+6.12331E-04*T**2 - -6.573855E-09*T**3+26048030*T**(-1); 6.00000E+03 N ! - FUNCTION F10854T 2.98150E+02 -9522.97393+78.5273873*T-31.35707*T*LN(T) - +.0027589925*T**2-7.46390667E-07*T**3+56582.3*T**(-1); 1.00000E+03 Y - +180.10884-15.6128262*T-17.84857*T*LN(T)-.00584168*T**2 - +3.14618667E-07*T**3-1280036*T**(-1); 2.10000E+03 Y - -18840.1661+92.3120249*T-32.05082*T*LN(T)-.0010728235*T**2 - +1.14281783E-08*T**3+3561002.5*T**(-1); 6.00000E+03 N ! - FUNCTION F10963T 2.98150E+02 -250423.434+4.45470312*T-28.40916*T*LN(T) - -.00623741*T**2-6.01526167E-08*T**3-64163.45*T**(-1); 1.10000E+03 Y - -256145.879+30.1894682*T-31.43044*T*LN(T)-.007055445*T**2 - +3.05535833E-07*T**3+1246309.5*T**(-1); 2.80000E+03 Y - -268423.418+116.690197*T-42.96842*T*LN(T)-.003069987*T**2 - +6.97594167E-08*T**3+2458230.5*T**(-1); 8.40000E+03 Y - -489068.882+553.259882*T-92.4077*T*LN(T)+.0016703495*T**2 - -1.32333233E-08*T**3+1.765625E+08*T**(-1); 1.80000E+04 Y - -165728.771+239.645643*T-59.77872*T*LN(T)+2.213599E-04*T**2 - -1.2921095E-09*T**3-4.1931655E+08*T**(-1); 2.00000E+04 N ! - FUNCTION F10983T 2.98150E+02 -147258.971-37.1497212*T-26.10636*T*LN(T) - -.036948065*T**2+6.659505E-06*T**3+65357.65*T**(-1); 7.00000E+02 Y - -156470.505+120.191295*T-50.94271*T*LN(T)-.007931945*T**2 - +4.29733833E-07*T**3+684985.5*T**(-1); 1.50000E+03 N ! - FUNCTION F13469T 2.98150E+02 +243206.494-20.8612587*T-21.01555*T*LN(T) - +1.2687055E-04*T**2-1.23131283E-08*T**3-42897.09*T**(-1); 2.95000E+03 - Y - +252301.423-52.0847285*T-17.21188*T*LN(T)-5.413565E-04*T**2 - +7.64520667E-09*T**3-3973170.5*T**(-1); 6.00000E+03 N ! - FUNCTION F13839T 2.98150E+02 -6960.69252-51.1831473*T-22.25862*T*LN(T) - -.01023867*T**2+1.339947E-06*T**3-76749.55*T**(-1); 9.00000E+02 Y - -13136.0172+24.743296*T-33.55726*T*LN(T)-.0012348985*T**2 - +1.66943333E-08*T**3+539886*T**(-1); 3.70000E+03 Y - +14154.6461-51.4854586*T-24.47978*T*LN(T)-.002634759*T**2 - +6.01544333E-08*T**3-15120935*T**(-1); 9.60000E+03 Y - -314316.628+515.068037*T-87.56143*T*LN(T)+.0025787245*T**2 - -1.878765E-08*T**3+2.9052515E+08*T**(-1); 1.85000E+04 Y - -108797.175+288.483019*T-63.737*T*LN(T)+.0014375*T**2-9E-09*T**3 - +.25153895*T**(-1); 2.00000E+04 N ! - FUNCTION F14145T 2.98150E+02 +130696.944-37.9096651*T-27.58118*T*LN(T) - -.02763076*T**2+4.60539333E-06*T**3+99530.45*T**(-1); 7.00000E+02 Y - +114760.623+176.626736*T-60.10286*T*LN(T)+.00206456*T**2 - -5.17486667E-07*T**3+1572175*T**(-1); 1.30000E+03 Y - +49468.3958+710.094819*T-134.3696*T*LN(T)+.039707355*T**2 - -4.10457667E-06*T**3+12362250*T**(-1); 2.10000E+03 Y - +866367.075-3566.80563*T+421.2001*T*LN(T)-.1284109*T**2 - +5.44768833E-06*T**3-2.1304835E+08*T**(-1); 2.80000E+03 Y - +409416.384-1950.70834*T+223.4437*T*LN(T)-.0922361*T**2 - +4.306855E-06*T**3-21589870*T**(-1); 3.50000E+03 Y - -1866338.6+6101.13383*T-764.8435*T*LN(T)+.09852775*T**2 - -2.59784667E-06*T**3+9.610855E+08*T**(-1); 4.90000E+03 Y - +97590.0432+890.79836*T-149.9608*T*LN(T)+.01283575*T**2 - -3.555105E-07*T**3-2.1699975E+08*T**(-1); 6.00000E+03 N ! - FUNCTION F10952T 2.98150E+02 -332319.671+1078.59563*T-186.8669*T*LN(T) - +.2320948*T**2-9.14296167E-05*T**3+978019*T**(-1); 5.00000E+02 Y - -62418.8788-3288.18729*T+495.1304*T*LN(T)-.504926*T**2 - +4.917665E-05*T**3-18523425*T**(-1); 5.40000E+02 Y - -8528143.9+142414.45*T-22596.19*T*LN(T)+27.48508*T**2 - -.00631160667*T**3+5.63356E+08*T**(-1); 6.00000E+02 Y - -331037.282+741.178604*T-117.41*T*LN(T); 6.01000E+02 N ! - FUNCTION F10981T 2.98150E+02 -214494.862+488.664597*T-89.3284*T*LN(T); - 1.50000E+03 N ! - FUNCTION UN_ASS 298.15 0; 300 N ! - - TYPE_DEFINITION % SEQ *! - DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! - DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! - - - PHASE GAS:G % 1 1.0 ! - CONSTITUENT GAS:G :H,H2,H2O1,O,O2,O3 : ! -$ CONSTITUENT GAS:G :H,H1O1,H1O2,H2,H2O1,H2O2,O,O2,O3 : ! - - PARAMETER G(GAS,H;0) 2.98150E+02 +F10447T#+R#*T*LN(1E-05*P); - 6.00000E+03 N REF86 ! - PARAMETER G(GAS,H1O1;0) 2.98150E+02 +F10666T#+R#*T*LN(1E-05*P); - 6.00000E+03 N REF93 ! - PARAMETER G(GAS,H1O2;0) 2.98150E+02 +F10729T#+R#*T*LN(1E-05*P); - 6.00000E+03 N REF94 ! - PARAMETER G(GAS,H2;0) 2.98150E+02 +F10854T#+R#*T*LN(1E-05*P); - 6.00000E+03 N REF95 ! - PARAMETER G(GAS,H2O1;0) 2.98150E+02 +F10963T#+R#*T*LN(1E-05*P); - 6.00000E+03 N REF101 ! - PARAMETER G(GAS,H2O2;0) 2.98150E+02 +F10983T#+R#*T*LN(1E-05*P); - 6.00000E+03 N REF102 ! - PARAMETER G(GAS,O;0) 2.98150E+02 +F13469T#+R#*T*LN(1E-05*P); - 6.00000E+03 N REF116 ! - PARAMETER G(GAS,O2;0) 2.98150E+02 +F13839T#+R#*T*LN(1E-05*P); - 6.00000E+03 N REF117 ! - PARAMETER G(GAS,O3;0) 2.98150E+02 +F14145T#+R#*T*LN(1E-05*P); - 6.00000E+03 N REF118 ! - - - LIST_OF_REFERENCES - NUMBER SOURCE - REF86 'H1 JANAF 1982; ASSESSMENT DATED 3/77 SGTE ** HYDROGEN < - MONATOMIC GAS>' - REF93 'H1O1 T.C.R.A.S. Class: 1' - REF94 'H1O2 T.C.R.A.S. Class: 4' - REF95 'H2 JANAF THERMOCHEMICAL TABLES SGTE ** HYDROGEN STANDARD - STATE FROM CODATA KEY VALUES. CP FROM JANAF PUB. 3/61' - REF101 'H2O1 T.C.R.A.S. Class: 1 WATER ' - REF102 'H2O2 JANAF SECOND EDIT SGTE HYDROGEN PEROXIDE ' - REF116 'O1 JANAF 1982; ASSESSMENT DATED 3/77 SGTE OXYGEN ' - REF117 'O2 T.C.R.A.S. Class: 1 OXYGEN ' - REF118 'O3 T.C.R.A.S. Class: 4 OZONE ' - REF128 'H2O1 T.C.R.A.S. Class: 4 WATER T.C.R.A.S. Class: 4 modified by - atd 12/9/94' - REF129 'H2O2 THERMODATA 01/93 HYDROGEN PEROXIDE 28/01/93' - ! - + +$ Database file written 2012- 5-31 +$ From database: USER + ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT H 1/2_MOLE_H2(GAS) 1.0079E+00 4.2340E+03 6.5285E+01! + ELEMENT O 1/2_MOLE_O2(GAS) 1.5999E+01 4.3410E+03 1.0252E+02! + + SPECIES H1O1 H1O1! + SPECIES H1O2 H1O2! + SPECIES H2 H2! + SPECIES H2O1 H2O1! + SPECIES H2O2 H2O2! + SPECIES O2 O2! + SPECIES O3 O3! + + FUNCTION F10447T 2.98150E+02 +211801.621+24.4989816*T-20.78611*T*LN(T); + 6.00000E+03 N ! + FUNCTION F10666T 2.98150E+02 +30698.6898+15.9096451*T-29.97699*T*LN(T) + +.001713168*T**2-6.799205E-07*T**3-25503.82*T**(-1); 1.00000E+03 Y + +31735.5127-12.686636*T-25.42186*T*LN(T)-.003149545*T**2 + +1.34404917E-07*T**3+116618.65*T**(-1); 3.00000E+03 Y + +41016.0783-20.7343256*T-24.94216*T*LN(T)-.0023107985*T**2 + +5.91863E-08*T**3-6415210*T**(-1); 8.60000E+03 Y + -154907.953+370.326117*T-69.24542*T*LN(T)+.0019361405*T**2 + -1.47539017E-08*T**3+1.4391015E+08*T**(-1); 1.80000E+04 Y + +326722.277-65.0792741*T-24.2768*T*LN(T)+6.42189E-05*T**2 + -1.30298483E-10*T**3-8.292415E+08*T**(-1); 2.00000E+04 N ! + FUNCTION F10729T 2.98150E+02 +1075.64106-55.242048*T-24.45435*T*LN(T) + -.018507875*T**2+2.36297E-06*T**3-29469.05*T**(-1); 8.00000E+02 Y + -7932.99164+54.2016233*T-40.775*T*LN(T)-.00501027*T**2 + +2.122915E-07*T**3+925845*T**(-1); 3.60000E+03 Y + -67875.8961+275.406716*T-68.1173*T*LN(T)+6.12331E-04*T**2 + -6.573855E-09*T**3+26048030*T**(-1); 6.00000E+03 N ! + FUNCTION F10854T 2.98150E+02 -9522.97393+78.5273873*T-31.35707*T*LN(T) + +.0027589925*T**2-7.46390667E-07*T**3+56582.3*T**(-1); 1.00000E+03 Y + +180.10884-15.6128262*T-17.84857*T*LN(T)-.00584168*T**2 + +3.14618667E-07*T**3-1280036*T**(-1); 2.10000E+03 Y + -18840.1661+92.3120249*T-32.05082*T*LN(T)-.0010728235*T**2 + +1.14281783E-08*T**3+3561002.5*T**(-1); 6.00000E+03 N ! + FUNCTION F10963T 2.98150E+02 -250423.434+4.45470312*T-28.40916*T*LN(T) + -.00623741*T**2-6.01526167E-08*T**3-64163.45*T**(-1); 1.10000E+03 Y + -256145.879+30.1894682*T-31.43044*T*LN(T)-.007055445*T**2 + +3.05535833E-07*T**3+1246309.5*T**(-1); 2.80000E+03 Y + -268423.418+116.690197*T-42.96842*T*LN(T)-.003069987*T**2 + +6.97594167E-08*T**3+2458230.5*T**(-1); 8.40000E+03 Y + -489068.882+553.259882*T-92.4077*T*LN(T)+.0016703495*T**2 + -1.32333233E-08*T**3+1.765625E+08*T**(-1); 1.80000E+04 Y + -165728.771+239.645643*T-59.77872*T*LN(T)+2.213599E-04*T**2 + -1.2921095E-09*T**3-4.1931655E+08*T**(-1); 2.00000E+04 N ! + FUNCTION F10983T 2.98150E+02 -147258.971-37.1497212*T-26.10636*T*LN(T) + -.036948065*T**2+6.659505E-06*T**3+65357.65*T**(-1); 7.00000E+02 Y + -156470.505+120.191295*T-50.94271*T*LN(T)-.007931945*T**2 + +4.29733833E-07*T**3+684985.5*T**(-1); 1.50000E+03 N ! + FUNCTION F13469T 2.98150E+02 +243206.494-20.8612587*T-21.01555*T*LN(T) + +1.2687055E-04*T**2-1.23131283E-08*T**3-42897.09*T**(-1); 2.95000E+03 + Y + +252301.423-52.0847285*T-17.21188*T*LN(T)-5.413565E-04*T**2 + +7.64520667E-09*T**3-3973170.5*T**(-1); 6.00000E+03 N ! + FUNCTION F13839T 2.98150E+02 -6960.69252-51.1831473*T-22.25862*T*LN(T) + -.01023867*T**2+1.339947E-06*T**3-76749.55*T**(-1); 9.00000E+02 Y + -13136.0172+24.743296*T-33.55726*T*LN(T)-.0012348985*T**2 + +1.66943333E-08*T**3+539886*T**(-1); 3.70000E+03 Y + +14154.6461-51.4854586*T-24.47978*T*LN(T)-.002634759*T**2 + +6.01544333E-08*T**3-15120935*T**(-1); 9.60000E+03 Y + -314316.628+515.068037*T-87.56143*T*LN(T)+.0025787245*T**2 + -1.878765E-08*T**3+2.9052515E+08*T**(-1); 1.85000E+04 Y + -108797.175+288.483019*T-63.737*T*LN(T)+.0014375*T**2-9E-09*T**3 + +.25153895*T**(-1); 2.00000E+04 N ! + FUNCTION F14145T 2.98150E+02 +130696.944-37.9096651*T-27.58118*T*LN(T) + -.02763076*T**2+4.60539333E-06*T**3+99530.45*T**(-1); 7.00000E+02 Y + +114760.623+176.626736*T-60.10286*T*LN(T)+.00206456*T**2 + -5.17486667E-07*T**3+1572175*T**(-1); 1.30000E+03 Y + +49468.3958+710.094819*T-134.3696*T*LN(T)+.039707355*T**2 + -4.10457667E-06*T**3+12362250*T**(-1); 2.10000E+03 Y + +866367.075-3566.80563*T+421.2001*T*LN(T)-.1284109*T**2 + +5.44768833E-06*T**3-2.1304835E+08*T**(-1); 2.80000E+03 Y + +409416.384-1950.70834*T+223.4437*T*LN(T)-.0922361*T**2 + +4.306855E-06*T**3-21589870*T**(-1); 3.50000E+03 Y + -1866338.6+6101.13383*T-764.8435*T*LN(T)+.09852775*T**2 + -2.59784667E-06*T**3+9.610855E+08*T**(-1); 4.90000E+03 Y + +97590.0432+890.79836*T-149.9608*T*LN(T)+.01283575*T**2 + -3.555105E-07*T**3-2.1699975E+08*T**(-1); 6.00000E+03 N ! + FUNCTION F10952T 2.98150E+02 -332319.671+1078.59563*T-186.8669*T*LN(T) + +.2320948*T**2-9.14296167E-05*T**3+978019*T**(-1); 5.00000E+02 Y + -62418.8788-3288.18729*T+495.1304*T*LN(T)-.504926*T**2 + +4.917665E-05*T**3-18523425*T**(-1); 5.40000E+02 Y + -8528143.9+142414.45*T-22596.19*T*LN(T)+27.48508*T**2 + -.00631160667*T**3+5.63356E+08*T**(-1); 6.00000E+02 Y + -331037.282+741.178604*T-117.41*T*LN(T); 6.01000E+02 N ! + FUNCTION F10981T 2.98150E+02 -214494.862+488.664597*T-89.3284*T*LN(T); + 1.50000E+03 N ! + FUNCTION UN_ASS 298.15 0; 300 N ! + + TYPE_DEFINITION % SEQ *! + DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! + DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! + + + PHASE GAS:G % 1 1.0 ! + CONSTITUENT GAS:G :H,H2,H2O1,O,O2,O3 : ! +$ CONSTITUENT GAS:G :H,H1O1,H1O2,H2,H2O1,H2O2,O,O2,O3 : ! + + PARAMETER G(GAS,H;0) 2.98150E+02 +F10447T#+R#*T*LN(1E-05*P); + 6.00000E+03 N REF86 ! + PARAMETER G(GAS,H1O1;0) 2.98150E+02 +F10666T#+R#*T*LN(1E-05*P); + 6.00000E+03 N REF93 ! + PARAMETER G(GAS,H1O2;0) 2.98150E+02 +F10729T#+R#*T*LN(1E-05*P); + 6.00000E+03 N REF94 ! + PARAMETER G(GAS,H2;0) 2.98150E+02 +F10854T#+R#*T*LN(1E-05*P); + 6.00000E+03 N REF95 ! + PARAMETER G(GAS,H2O1;0) 2.98150E+02 +F10963T#+R#*T*LN(1E-05*P); + 6.00000E+03 N REF101 ! + PARAMETER G(GAS,H2O2;0) 2.98150E+02 +F10983T#+R#*T*LN(1E-05*P); + 6.00000E+03 N REF102 ! + PARAMETER G(GAS,O;0) 2.98150E+02 +F13469T#+R#*T*LN(1E-05*P); + 6.00000E+03 N REF116 ! + PARAMETER G(GAS,O2;0) 2.98150E+02 +F13839T#+R#*T*LN(1E-05*P); + 6.00000E+03 N REF117 ! + PARAMETER G(GAS,O3;0) 2.98150E+02 +F14145T#+R#*T*LN(1E-05*P); + 6.00000E+03 N REF118 ! + + + LIST_OF_REFERENCES + NUMBER SOURCE + REF86 'H1 JANAF 1982; ASSESSMENT DATED 3/77 SGTE ** HYDROGEN < + MONATOMIC GAS>' + REF93 'H1O1 T.C.R.A.S. Class: 1' + REF94 'H1O2 T.C.R.A.S. Class: 4' + REF95 'H2 JANAF THERMOCHEMICAL TABLES SGTE ** HYDROGEN STANDARD + STATE FROM CODATA KEY VALUES. CP FROM JANAF PUB. 3/61' + REF101 'H2O1 T.C.R.A.S. Class: 1 WATER ' + REF102 'H2O2 JANAF SECOND EDIT SGTE HYDROGEN PEROXIDE ' + REF116 'O1 JANAF 1982; ASSESSMENT DATED 3/77 SGTE OXYGEN ' + REF117 'O2 T.C.R.A.S. Class: 1 OXYGEN ' + REF118 'O3 T.C.R.A.S. Class: 4 OZONE ' + REF128 'H2O1 T.C.R.A.S. Class: 4 WATER T.C.R.A.S. Class: 4 modified by + atd 12/9/94' + REF129 'H2O2 THERMODATA 01/93 HYDROGEN PEROXIDE 28/01/93' + ! + diff --git a/macros/map1-agcu.OCM b/macros/ocv2/map1.OCM similarity index 86% rename from macros/map1-agcu.OCM rename to macros/ocv2/map1.OCM index 3816a36..9c37203 100644 --- a/macros/map1-agcu.OCM +++ b/macros/ocv2/map1.OCM @@ -1,57 +1,57 @@ -@$ Calculate the phase diagram for Ag-Cu -@& - -set echo - -r t agcu - - -set cond t=1000 p=1e5 n=1 x(cu)=.2 - -c e - -l r 1 - -@& - -set ax 1 x(cu) 0 1 ,,, -set ax 2 t 800 1500 10 - -l ax - -l sh - -set ref ag fcc,,,,, -set ref cu fcc,,,,, - -@& - -map - -@& - -plot -x(*,cu) -T -plot - - -plot -x(*,cu) -T -xr -N -0 -0.2 -plot - - -plot -T -x(*,cu),,,,,,,,,,, -plot -ac(cu) -T,,,,,,,,,,,,,,,, - - -set inter +@$ Calculate the phase diagram for Ag-Cu +@& + +set echo + +r t agcu + + +set cond t=1000 p=1e5 n=1 x(cu)=.2 + +c e + +l r 1 + +@& + +set ax 1 x(cu) 0 1 ,,, +set ax 2 t 800 1500 10 + +l ax + +l sh + +set ref ag fcc,,,,, +set ref cu fcc,,,,, + +@& + +map + +@& + +plot +x(*,cu) +T +plot + + +plot +x(*,cu) +T +xr +N +0 +0.2 +plot + + +plot +T +x(*,cu),,,,,,,,,,, +plot +ac(cu) +T,,,,,,,,,,,,,,,, + + +set inter diff --git a/macros/map2-crmo.OCM b/macros/ocv2/map2.OCM similarity index 85% rename from macros/map2-crmo.OCM rename to macros/ocv2/map2.OCM index 182cc29..6fb4074 100644 --- a/macros/map2-crmo.OCM +++ b/macros/ocv2/map2.OCM @@ -1,49 +1,49 @@ -@$ Calculate the miscibility gap and liquidus for Cr-Mo -@& - -set echo - -r t steel1 -cr mo - -set cond t=800 p=1e5 n=1 x(mo)=.5 - -c e - -l r 1 - -@& - -set ax 1 x(mo) 0 1 ,, -set ax 2 t 500 3000 25 - -l ax - -l sh - -@& - -map - - -@& - -plot -x(*,cr) -T -plot - - - -set cond t=2500 x(mo)=.4 -c e - -map -N - - -plot,,,,,,,,, - - - -set inter +@$ Calculate the miscibility gap and liquidus for Cr-Mo +@& + +set echo + +r t steel1 +cr mo + +set cond t=800 p=1e5 n=1 x(mo)=.5 + +c e + +l r 1 + +@& + +set ax 1 x(mo) 0 1 ,, +set ax 2 t 500 3000 25 + +l ax + +l sh + +@& + +map + + +@& + +plot +x(*,cr) +T +plot + + + +set cond t=2500 x(mo)=.4 +c e + +map +N + + +plot,,,,,,,,, + + + +set inter diff --git a/macros/map3-cfe.OCM b/macros/ocv2/map3.OCM similarity index 85% rename from macros/map3-cfe.OCM rename to macros/ocv2/map3.OCM index cbc8d8b..3254e68 100644 --- a/macros/map3-cfe.OCM +++ b/macros/ocv2/map3.OCM @@ -1,51 +1,51 @@ -@$ Calculate the stable C-Fe phase diagram -@& - -set echo - -r t steel1 -fe c - - -set cond t=1000 p=1e5 n=1 x(c)=.2 - -c e - -l r 1 - -@& - -set ax 1 x(c) 0 1 ,,, -set ax 2 t 500 2000 25 - -l ax - -l sh - - -@& - -map - - -@& - -plot -x(*,c) -T -plot,,,,,,,,,,,,,, - - - -plot -x(*,c) -T -xr -n -0 -.2 -plot,,,,,,,,,,,,,,,,,, - - - -set inter +@$ Calculate the stable C-Fe phase diagram +@& + +set echo + +r t steel1 +fe c + + +set cond t=1000 p=1e5 n=1 x(c)=.2 + +c e + +l r 1 + +@& + +set ax 1 x(c) 0 1 ,,, +set ax 2 t 500 2000 25 + +l ax + +l sh + + +@& + +map + + +@& + +plot +x(*,c) +T +plot,,,,,,,,,,,,,, + + + +plot +x(*,c) +T +xr +n +0 +.2 +plot,,,,,,,,,,,,,,,,,, + + + +set inter diff --git a/macros/map4-ou.OCM b/macros/ocv2/map4.OCM similarity index 85% rename from macros/map4-ou.OCM rename to macros/ocv2/map4.OCM index 7bf13cd..a794324 100644 --- a/macros/map4-ou.OCM +++ b/macros/ocv2/map4.OCM @@ -1,46 +1,46 @@ -@$ Calculate the phase diagram for O-U -@& - -set echo - -r t ou - - -set c t=3200 p=1e5 n=1 x(o)=.5 - -c e - -l r 2 - -@& - -set ax 1 x(o) 0 1 ,, - -set ax 2 t 500 3500 25 - -map - -plot -x(*,o) -T -plot,,,,,,,,,,,,,,,,, - - - -set c t=2000 x(o)=.8 - -c e - -map -N - - - -plot,,,,,,,,,,,,,,,,, - - - - - -set interactive - +@$ Calculate the phase diagram for O-U +@& + +set echo + +r t ou + + +set c t=3200 p=1e5 n=1 x(o)=.5 + +c e + +l r 2 + +@& + +set ax 1 x(o) 0 1 ,, + +set ax 2 t 500 3500 25 + +map + +plot +x(*,o) +T +plot,,,,,,,,,,,,,,,,, + + + +set c t=2000 x(o)=.8 + +c e + +map +N + + + +plot,,,,,,,,,,,,,,,,, + + + + + +set interactive + diff --git a/macros/map5-femo.OCM b/macros/ocv2/map5.OCM similarity index 85% rename from macros/map5-femo.OCM rename to macros/ocv2/map5.OCM index b4e172c..f9e457e 100644 --- a/macros/map5-femo.OCM +++ b/macros/ocv2/map5.OCM @@ -1,87 +1,87 @@ -@$ Calculate the phase diagram for Fe-Mo -@& - -set echo - -r t steel1 -fe mo - - -amend phase -bcc -comp -Y -FE - ->.5 -<.1 - -amend phase -bcc -def -<.1 ->.5 - - -@& - - -set cond t=2000 p=1e5 n=1 x(mo)=.7 - -c e - -l r 1 - -@& - -set ax 1 x(mo) 0 1 ,, -set ax 2 t 300 3000 25 - -l ax - -l sh - - -@& - -map - - -@& - -plot -x(*,mo) -T -plot,,,,,,,,,,,,,,,, - - -@$ we must calculate the gamma loop separately - -set c t=1400 x(mo)=.02 - -c n - -l,,,,, - -@& - -map -N - - -plot -x(*,mo) -T -plot,,,,,,,,,,,,,,,,,,, - - - -plot -x(*,mo) -T -yr -1600 -1800 -plot,,,,,, - -set inter +@$ Calculate the phase diagram for Fe-Mo +@& + +set echo + +r t steel1 +fe mo + + +amend phase +bcc +comp +Y +FE + +>.5 +<.1 + +amend phase +bcc +def +<.1 +>.5 + + +@& + + +set cond t=2000 p=1e5 n=1 x(mo)=.7 + +c e + +l r 1 + +@& + +set ax 1 x(mo) 0 1 ,, +set ax 2 t 300 3000 25 + +l ax + +l sh + + +@& + +map + + +@& + +plot +x(*,mo) +T +plot,,,,,,,,,,,,,,,, + + +@$ we must calculate the gamma loop separately + +set c t=1400 x(mo)=.02 + +c n + +l,,,,, + +@& + +map +N + + +plot +x(*,mo) +T +plot,,,,,,,,,,,,,,,,,,, + + + +plot +x(*,mo) +T +yr +1600 +1800 +plot,,,,,, + +set inter diff --git a/macros/map6-ss.OCM b/macros/ocv2/map6.OCM similarity index 100% rename from macros/map6-ss.OCM rename to macros/ocv2/map6.OCM diff --git a/macros/map7-hss.OCM b/macros/ocv2/map7.OCM similarity index 88% rename from macros/map7-hss.OCM rename to macros/ocv2/map7.OCM index 5b3a0d5..572ea5a 100644 --- a/macros/map7-hss.OCM +++ b/macros/ocv2/map7.OCM @@ -1,44 +1,44 @@ -@$ Calculate an (incomplete) isopleth for a HSS -@& - -set echo - -r t steel1 - -@& calculate at 1200 to create two fcc phases - -set c t=1200 p=1e5 n=1 w(c)=.008 w(cr)=.05, w(mo)=.08 w(v)=.01 w(si)=.003 - -c e - -l r 1 - -@& - -set axis 1 w(c) 0 0.02 ,,, -set axis 2 T 800 1800 25 - -l ax - -@& - -map - - - - - -l l - -@& - -l eq - - - -plot,,,,,,,, - - - -set inter - +@$ Calculate an (incomplete) isopleth for a HSS +@& + +set echo + +r t steel1 + +@& calculate at 1200 to create two fcc phases + +set c t=1200 p=1e5 n=1 w(c)=.008 w(cr)=.05, w(mo)=.08 w(v)=.01 w(si)=.003 + +c e + +l r 1 + +@& + +set axis 1 w(c) 0 0.02 ,,, +set axis 2 T 800 1800 25 + +l ax + +@& + +map + + + + + +l l + +@& + +l eq + + + +plot,,,,,,,, + + + +set inter + diff --git a/macros/map8-feni.OCM b/macros/ocv2/map8.OCM similarity index 100% rename from macros/map8-feni.OCM rename to macros/ocv2/map8.OCM diff --git a/macros/map9-rew.OCM b/macros/ocv2/map9.OCM similarity index 100% rename from macros/map9-rew.OCM rename to macros/ocv2/map9.OCM diff --git a/macros/ocv2/melting.OCM b/macros/ocv2/melting.OCM new file mode 100644 index 0000000..0bfa576 --- /dev/null +++ b/macros/ocv2/melting.OCM @@ -0,0 +1,24 @@ +@$ Calculating a multicomponent single equilibrium +@$ Including the melting point of the alloy +@& + +set echo + +r t steel1 + +set c t=1200 p=1e5 n=1 x(c)=.01 x(cr)=.05, x(mo)=.05 x(si)=.003 x(v)=.01 + +c e + +l ,,,, + +@& + +c tran +liq +1 + +list,,,,, + +set inter + diff --git a/macros/saf2507.TDB b/macros/ocv2/saf2507.TDB similarity index 100% rename from macros/saf2507.TDB rename to macros/ocv2/saf2507.TDB diff --git a/macros/ocv2/steel1.TDB b/macros/ocv2/steel1.TDB new file mode 100644 index 0000000..c820294 --- /dev/null +++ b/macros/ocv2/steel1.TDB @@ -0,0 +1,1210 @@ + +$ Database file written 2012- 2-11 +$ From database: SSOL2 + ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7400E+00! + ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01! + ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! + ELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01! + ELEMENT SI DIAMOND_A4 2.8085E+01 3.2175E+03 1.8820E+01! + ELEMENT V BCC_A2 5.0941E+01 4.5070E+03 3.0890E+01! + + SPECIES C1 C! + SPECIES C2 C2! + SPECIES C3 C3! + SPECIES C4 C4! + SPECIES C5 C5! + SPECIES C6 C6! + SPECIES C7 C7! + SPECIES V1C1 V1C1! + + FUNCTION GHSERCC 2.98150E+02 -17368.441+170.73*T-24.3*T*LN(T) + -4.723E-04*T**2+2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3); + 6.00000E+03 N ! + FUNCTION GPCLIQ 2.98150E+02 +YCLIQ#*EXP(ZCLIQ#); 6.00000E+03 N ! + FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) + +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y + -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N ! + FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N ! + FUNCTION GFELIQ 2.98150E+02 +12040.17-6.55843*T-3.6751551E-21*T**7 + +GHSERFE#; 1.81100E+03 Y + -10839.7+291.302*T-46*T*LN(T); 6.00000E+03 N ! + FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N ! + FUNCTION GHSERMO 2.98150E+02 -7746.302+131.9197*T-23.56414*T*LN(T) + -.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4; + 2.89600E+03 Y + -30556.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9); + 5.00000E+03 N ! + FUNCTION GPMOLIQ 2.98150E+02 +YMOLIQ#*EXP(ZMOLIQ#); 6.00000E+03 N ! + FUNCTION GHSERSI 2.98150E+02 -8162.609+137.227259*T-22.8317533*T*LN(T) + -.001912904*T**2-3.552E-09*T**3+176667*T**(-1); 1.68700E+03 Y + -9457.642+167.271767*T-27.196*T*LN(T)-4.20369E+30*T**(-9); + 3.60000E+03 N ! + FUNCTION GHSERVV 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T) + -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y + -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; + 2.18300E+03 Y + -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); + 4.00000E+03 N ! + FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N ! + FUNCTION GPCGRA 2.98150E+02 +YCGRA#*EXP(ZCGRA#); 6.00000E+03 N ! + FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T) + -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y + -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N + ! + FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N ! + FUNCTION GSIBCC 2.98150E+02 +47000-22.5*T+GHSERSI#; 6.00000E+03 N ! + FUNCTION GPMOBCC 2.98150E+02 +YMOBCC#*EXP(ZMOBCC#); 6.00000E+03 N ! + FUNCTION GFECEM 2.98150E+02 -10745+706.04*T-120.6*T*LN(T)+GPCEM1#; + 6.00000E+03 N ! + FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N ! + FUNCTION GFEFCC 2.98150E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 + +GHSERFE#; 1.81100E+03 Y + -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N + ! + FUNCTION GMOFCC 2.98150E+02 +15200+.63*T+GHSERMO#; 6.00000E+03 N ! + FUNCTION GPCDIA 2.98150E+02 +YCDIA#*EXP(ZCDIA#); 6.00000E+03 N ! + FUNCTION GPCFCC 2.98150E+02 +YCFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! + FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! + FUNCTION GHSERVZ 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T) + -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y + -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; + 4.00000E+03 Y + -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); + 6.00000E+03 N ! + FUNCTION GPFEHCP 2.98150E+02 +YFEHCP#*EXP(ZFEHCP#); 6.00000E+03 N ! + FUNCTION GCRM23C6 2.98150E+02 -521983+3622.24*T-620.965*T*LN(T) + -.126431*T**2; 6.00000E+03 N ! + FUNCTION GFEM23C6 2.98150E+02 +7.666667*GFECEM#-1.666667*GHSERCC#+66920 + -40*T; 6.00000E+03 N ! + FUNCTION GVM23C6 2.98150E+02 -990367+4330.63*T-728.829*T*LN(T) + +5003425*T**(-1); 6.00000E+03 N ! + FUNCTION GCRM3C2 2.98150E+02 -100823.8+530.66989*T-89.6694*T*LN(T) + -.0301188*T**2; 6.00000E+03 N ! + FUNCTION GCRM7C3 2.98150E+02 -201690+1103.128*T-190.177*T*LN(T) + -.0578207*T**2; 6.00000E+03 N ! + FUNCTION GPMU1 2.98150E+02 +8.72E-05*P; 6.00000E+03 N ! + FUNCTION GPMU2 2.98150E+02 +1.04E-04*P; 6.00000E+03 N ! + FUNCTION GPR1 2.98150E+02 +3.81E-04*P; 6.00000E+03 N ! + FUNCTION GPR2 2.98150E+02 +4.33E-04*P; 6.00000E+03 N ! + FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N ! + FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N ! + FUNCTION L0BCC 2.98150E+02 -27809+11.62*T; 6.00000E+03 N ! + FUNCTION FESIW1 2.98150E+02 +1260*R#; 6.00000E+03 N ! + FUNCTION L1BCC 2.98150E+02 -11544; 6.00000E+03 N ! + FUNCTION L2BCC 2.98150E+02 3890; 6.00000E+03 N ! + FUNCTION ETCFESI 2.98150E+02 63; 6.00000E+03 N ! + FUNCTION YCLIQ 2.98150E+02 +VCLIQ#*EXP(-ECLIQ#); 6.00000E+03 N ! + FUNCTION ZCLIQ 2.98150E+02 +1*LN(XCLIQ#); 6.00000E+03 N ! + FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N ! + FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N ! + FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N ! + FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N ! + FUNCTION YMOLIQ 2.98150E+02 +VMOLIQ#*EXP(-EMOLIQ#); 6.00000E+03 N ! + FUNCTION ZMOLIQ 2.98150E+02 +1*LN(XMOLIQ#); 6.00000E+03 N ! + FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N ! + FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N ! + FUNCTION YCGRA 2.98150E+02 +VCGRA#*EXP(-ECGRA#); 6.00000E+03 N ! + FUNCTION ZCGRA 2.98150E+02 +1*LN(XCGRA#); 6.00000E+03 N ! + FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N ! + FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N ! + FUNCTION YMOBCC 2.98150E+02 +VMOBCC#*EXP(-EMOBCC#); 6.00000E+03 N ! + FUNCTION ZMOBCC 2.98150E+02 +1*LN(XMOBCC#); 6.00000E+03 N ! + FUNCTION GPCEM1 2.98150E+02 +VCEM1#*P; 6.00000E+03 N ! + FUNCTION YCDIA 2.98150E+02 +VCDIA#*EXP(-ECDIA#); 6.00000E+03 N ! + FUNCTION ZCDIA 2.98150E+02 +1*LN(XCDIA#); 6.00000E+03 N ! + FUNCTION YCFCC 2.98150E+02 +VCFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! + FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N ! + FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! + FUNCTION YFEHCP 2.98150E+02 +VFEHCP#*EXP(-EFEHCP#); 6.00000E+03 N ! + FUNCTION ZFEHCP 2.98150E+02 +1*LN(XFEHCP#); 6.00000E+03 N ! + FUNCTION VCLIQ 2.98150E+02 +7.626E-06*EXP(ACLIQ#); 6.00000E+03 N ! + FUNCTION ECLIQ 2.98150E+02 +1*LN(CCLIQ#); 6.00000E+03 N ! + FUNCTION XCLIQ 2.98150E+02 +1*EXP(.5*DCLIQ#)-1; 6.00000E+03 N ! + FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N + ! + FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N ! + FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N ! + FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 + N ! + FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N ! + FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 + N ! + FUNCTION VMOLIQ 2.98150E+02 +9.75079E-06*EXP(AMOLIQ#); 6.00000E+03 + N ! + FUNCTION EMOLIQ 2.98150E+02 +1*LN(CMOLIQ#); 6.00000E+03 N ! + FUNCTION XMOLIQ 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 + N ! + FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N + ! + FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N ! + FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N ! + FUNCTION VCGRA 2.98150E+02 +5.259E-06*EXP(ACGRA#); 6.00000E+03 N ! + FUNCTION ECGRA 2.98150E+02 +1*LN(CCGRA#); 6.00000E+03 N ! + FUNCTION XCGRA 2.98150E+02 +1*EXP(.9166667*DCGRA#)-1; 6.00000E+03 + N ! + FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 + N ! + FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N ! + FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 + N ! + FUNCTION VMOBCC 2.98150E+02 +9.34372E-06*EXP(AMOBCC#); 6.00000E+03 + N ! + FUNCTION EMOBCC 2.98150E+02 +1*LN(CMOBCC#); 6.00000E+03 N ! + FUNCTION XMOBCC 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 + N ! + FUNCTION VCEM1 2.98150E+02 +2.339E-05*EXP(ACEM1#); 6.00000E+03 N ! + FUNCTION VCDIA 2.98150E+02 +3.412E-06*EXP(ACDIA#); 6.00000E+03 N ! + FUNCTION ECDIA 2.98150E+02 +1*LN(CCDIA#); 6.00000E+03 N ! + FUNCTION XCDIA 2.98150E+02 +1*EXP(.8*DCDIA#)-1; 6.00000E+03 N ! + FUNCTION VCFCC 2.98150E+02 +1.031E-05*EXP(ACFCC#); 6.00000E+03 N ! + FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N ! + FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 + N ! + FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 + N ! + FUNCTION VFEHCP 2.98150E+02 +6.59121E-06*EXP(AFEHCP#); 6.00000E+03 + N ! + FUNCTION EFEHCP 2.98150E+02 +1*LN(CFEHCP#); 6.00000E+03 N ! + FUNCTION XFEHCP 2.98150E+02 +1*EXP(.8064454*DFEHCP#)-1; 6.00000E+03 + N ! + FUNCTION ACLIQ 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 + N ! + FUNCTION CCLIQ 2.98150E+02 1.6E-10; 6.00000E+03 N ! + FUNCTION DCLIQ 2.98150E+02 +1*LN(BCLIQ#); 6.00000E+03 N ! + FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N + ! + FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N ! + FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N ! + FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N ! + FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; + 6.00000E+03 N ! + FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N ! + FUNCTION AMOLIQ 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2 + +1.14687E-12*T**3; 6.00000E+03 N ! + FUNCTION CMOLIQ 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; + 6.00000E+03 N ! + FUNCTION DMOBCC 2.98150E+02 +1*LN(BMOBCC#); 6.00000E+03 N ! + FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N + ! + FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N ! + FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N ! + FUNCTION ACGRA 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 + N ! + FUNCTION CCGRA 2.98150E+02 3.3E-10; 6.00000E+03 N ! + FUNCTION DCGRA 2.98150E+02 +1*LN(BCGRA#); 6.00000E+03 N ! + FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; + 6.00000E+03 N ! + FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; + 6.00000E+03 N ! + FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N ! + FUNCTION AMOBCC 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2 + +1.14687E-12*T**3; 6.00000E+03 N ! + FUNCTION CMOBCC 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; + 6.00000E+03 N ! + FUNCTION ACEM1 2.98150E+02 -1.36E-05*T+4E-08*T**2; 6.00000E+03 N ! + FUNCTION ACDIA 2.98150E+02 +2.43E-06*T+5E-09*T**2; 6.00000E+03 N ! + FUNCTION CCDIA 2.98150E+02 6.8E-12; 6.00000E+03 N ! + FUNCTION DCDIA 2.98150E+02 +1*LN(BCDIA#); 6.00000E+03 N ! + FUNCTION ACFCC 2.98150E+02 +1.44E-04*T; 6.00000E+03 N ! + FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; + 6.00000E+03 N ! + FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N ! + FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N ! + FUNCTION AFEHCP 2.98150E+02 +7.3646E-05*T; 6.00000E+03 N ! + FUNCTION CFEHCP 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; + 6.00000E+03 N ! + FUNCTION DFEHCP 2.98150E+02 +1*LN(BFEHCP#); 6.00000E+03 N ! + FUNCTION BCLIQ 2.98150E+02 +1+3.2E-10*P; 6.00000E+03 N ! + FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N ! + FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; + 6.00000E+03 N ! + FUNCTION BMOBCC 2.98150E+02 +1+1.13837E-11*P+4.875E-16*T*P + +1.2675E-19*T**2*P; 6.00000E+03 N ! + FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N ! + FUNCTION BCGRA 2.98150E+02 +1+3.6E-10*P; 6.00000E+03 N ! + FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; + 6.00000E+03 N ! + FUNCTION BCDIA 2.98150E+02 +1+8.5E-12*P; 6.00000E+03 N ! + FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; + 6.00000E+03 N ! + FUNCTION BFEHCP 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; + 6.00000E+03 N ! + FUNCTION UN_ASS 298.15 0; 300 N ! + + TYPE_DEFINITION % SEQ *! + DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! + DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! + + + PHASE LIQUID:L % 1 1.0 ! + CONSTITUENT LIQUID:L :C,CR,FE,MO,SI,V : ! + + PARAMETER G(LIQUID,C;0) 2.98150E+02 +117369-24.63*T+GHSERCC#+GPCLIQ#; + 6.00000E+03 N REF283 ! + PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T + +2.37615E-21*T**7+GHSERCR#+GPCRLIQ#; 2.18000E+03 Y + +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#+GPCRLIQ#; 6.00000E+03 + N REF283 ! + PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 + N REF283 ! + PARAMETER G(LIQUID,MO;0) 2.98150E+02 +41831.347-14.694912*T + +4.24519E-22*T**7+GHSERMO#+GPMOLIQ#; 2.89600E+03 Y + +34095.373-11.890046*T+4.849315E+33*T**(-9)+GHSERMO#+GPMOLIQ#; + 5.00000E+03 N REF283 ! + PARAMETER G(LIQUID,SI;0) 2.98150E+02 +50696.36-30.099439*T + +2.09307E-21*T**7+GHSERSI#; 1.68700E+03 Y + +49828.165-29.559069*T+4.20369E+30*T**(-9)+GHSERSI#; 3.60000E+03 N + REF283 ! + PARAMETER G(LIQUID,V;0) 2.98150E+02 +20764.117-9.455552*T + -5.19136E-22*T**7+GHSERVV#; 7.90000E+02 Y + +20764.117-9.455552*T-5.19136E-22*T**7+GHSERVV#; 2.18300E+03 Y + +22072.354-10.0848*T-6.44389E+31*T**(-9)+GHSERVV#; 4.00000E+03 N REF283 ! + PARAMETER G(LIQUID,C,CR;0) 2.98150E+02 -90526-25.9116*T; 6.00000E+03 + N REF101 ! + PARAMETER G(LIQUID,C,CR;1) 2.98150E+02 80000; 6.00000E+03 N REF101 ! + PARAMETER G(LIQUID,C,CR;2) 2.98150E+02 80000; 6.00000E+03 N REF101 ! + PARAMETER G(LIQUID,C,CR,FE;0) 2.98150E+02 -496063; 6.00000E+03 N + REF322 ! + PARAMETER G(LIQUID,C,CR,FE;1) 2.98150E+02 57990; 6.00000E+03 N + REF322 ! + PARAMETER G(LIQUID,C,CR,FE;2) 2.98150E+02 61404; 6.00000E+03 N + REF322 ! + PARAMETER G(LIQUID,C,CR,V;0) 2.98150E+02 -769497; 6.00000E+03 N + REF324 ! + PARAMETER G(LIQUID,C,CR,V;1) 2.98150E+02 263981; 6.00000E+03 N + REF324 ! + PARAMETER G(LIQUID,C,CR,V;2) 2.98150E+02 3599; 6.00000E+03 N REF324 ! + PARAMETER G(LIQUID,C,FE;0) 2.98150E+02 -124320+28.5*T; 6.00000E+03 + N REF190 ! + PARAMETER G(LIQUID,C,FE;1) 2.98150E+02 19300; 6.00000E+03 N REF190 ! + PARAMETER G(LIQUID,C,FE;2) 2.98150E+02 +49260-19*T; 6.00000E+03 N + REF190 ! + PARAMETER G(LIQUID,C,FE,SI;0) 2.98150E+02 445740; 6.00000E+03 N + REF99 ! + PARAMETER G(LIQUID,C,FE,SI;1) 2.98150E+02 -6065-35.33*T; 6.00000E+03 + N REF99 ! + PARAMETER G(LIQUID,C,FE,SI;2) 2.98150E+02 +2545792-1450.6*T; + 6.00000E+03 N REF99 ! + PARAMETER G(LIQUID,C,FE,V;0) 2.98150E+02 -60000; 6.00000E+03 N + REF270 ! + PARAMETER G(LIQUID,C,FE,V;1) 2.98150E+02 -60000; 6.00000E+03 N + REF270 ! + PARAMETER G(LIQUID,C,FE,V;2) 2.98150E+02 100000; 6.00000E+03 N + REF270 ! + PARAMETER G(LIQUID,C,FE,MO;0) 2.98150E+02 -37800; 6.00000E+03 N + REF113 ! + PARAMETER G(LIQUID,C,MO;0) 2.98150E+02 -217800+38.41*T; 6.00000E+03 + N REF104 ! + PARAMETER G(LIQUID,C,MO;1) 2.98150E+02 30000; 6.00000E+03 N REF104 ! + PARAMETER G(LIQUID,C,MO;2) 2.98150E+02 47000; 6.00000E+03 N REF104 ! + PARAMETER G(LIQUID,C,SI;0) 2.98150E+02 -133000+30.97*T; 6.00000E+03 + N REF99 ! + PARAMETER G(LIQUID,C,V;0) 2.98150E+02 -284196+38.952*T; 6.00000E+03 + N REF256 ! + PARAMETER G(LIQUID,C,V;1) 2.98150E+02 +96335-17.775*T; 6.00000E+03 + N REF256 ! + PARAMETER G(LIQUID,C,V;2) 2.98150E+02 102050; 6.00000E+03 N REF256 ! + PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -14550+6.65*T; 6.00000E+03 + N REF107 ! + PARAMETER G(LIQUID,CR,FE,V;0) 2.98150E+02 14881; 6.00000E+03 N + REF323 ! + PARAMETER G(LIQUID,CR,FE,V;1) 2.98150E+02 17968; 6.00000E+03 N + REF323 ! + PARAMETER G(LIQUID,CR,FE,V;2) 2.98150E+02 -7692; 6.00000E+03 N + REF323 ! + PARAMETER G(LIQUID,CR,MO;0) 2.98150E+02 +15810-6.714*T; 6.00000E+03 + N REF123 ! + PARAMETER G(LIQUID,CR,MO;1) 2.98150E+02 -6220; 6.00000E+03 N REF123 ! + PARAMETER G(LIQUID,CR,SI;0) 2.98150E+02 -120157.52+16.63891*T; + 6.00000E+03 N REF90 ! + PARAMETER G(LIQUID,CR,SI;1) 2.98150E+02 -49502.35+13.76967*T; + 6.00000E+03 N REF90 ! + PARAMETER G(LIQUID,CR,V;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 + N REF323 ! + PARAMETER G(LIQUID,CR,V;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 + N REF323 ! + PARAMETER G(LIQUID,FE,MO;0) 2.98150E+02 -6973-.37*T; 6.00000E+03 N + REF10 ! + PARAMETER G(LIQUID,FE,MO;1) 2.98150E+02 -9424+4.502*T; 6.00000E+03 + N REF10 ! + PARAMETER G(LIQUID,FE,SI;0) 2.98150E+02 -164435+41.977*T; 6.00000E+03 + N REF99 ! + PARAMETER G(LIQUID,FE,SI;1) 2.98150E+02 -21.523*T; 6.00000E+03 N + REF99 ! + PARAMETER G(LIQUID,FE,SI;2) 2.98150E+02 -18821+22.07*T; 6.00000E+03 + N REF99 ! + PARAMETER G(LIQUID,FE,SI;3) 2.98150E+02 9696; 6.00000E+03 N REF99 ! + PARAMETER G(LIQUID,FE,V;0) 2.98150E+02 -34679+1.895*T; 6.00000E+03 + N REF269 ! + PARAMETER G(LIQUID,FE,V;1) 2.98150E+02 10209; 6.00000E+03 N REF269 ! + + + TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! + PHASE BCC_A2 %& 2 1 3 ! + CONSTITUENT BCC_A2 :CR%,FE%,MO%,SI,V% : C,VA% : ! + + PARAMETER G(BCC_A2,CR:C;0) 2.98150E+02 +GHSERCR#+3*GHSERCC#+GPCRBCC# + +3*GPCGRA#+416000; 6.00000E+03 N REF101 ! + PARAMETER TC(BCC_A2,CR:C;0) 2.98150E+02 -311.5; 6.00000E+03 N + REF101 ! + PARAMETER BMAGN(BCC_A2,CR:C;0) 2.98150E+02 -.008; 6.00000E+03 N + REF101 ! + PARAMETER G(BCC_A2,FE:C;0) 2.98150E+02 +322050+75.667*T+GHSERFE# + +GPFEBCC#+3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF190 ! + PARAMETER TC(BCC_A2,FE:C;0) 2.98150E+02 1043; 6.00000E+03 N REF190 ! + PARAMETER BMAGN(BCC_A2,FE:C;0) 2.98150E+02 2.22; 6.00000E+03 N + REF190 ! + PARAMETER G(BCC_A2,MO:C;0) 2.98150E+02 +331000-75*T+GHSERMO#+3*GHSERCC#; + 6.00000E+03 N REF104 ! + PARAMETER G(BCC_A2,SI:C;0) 2.98150E+02 +322050-75.667*T+GSIBCC# + +3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF98 ! + PARAMETER G(BCC_A2,V:C;0) 2.98150E+02 +108449+GHSERVV#+3*GHSERCC#; + 6.00000E+03 N REF256 ! + PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N + REF281 ! + PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.01; 6.00000E+03 N + REF281 ! + PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF281 ! + PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N + REF281 ! + PARAMETER G(BCC_A2,MO:VA;0) 2.98150E+02 +GHSERMO#+GPMOBCC#; + 5.00000E+03 N REF283 ! + PARAMETER G(BCC_A2,SI:VA;0) 2.98150E+02 +GSIBCC#; 3.60000E+03 N + REF283 ! + PARAMETER G(BCC_A2,V:VA;0) 2.98150E+02 +GHSERVV#; 4.00000E+03 N + REF283 ! + PARAMETER G(BCC_A2,CR,FE:C;0) 2.98150E+02 -1250000+667.7*T; + 6.00000E+03 N REF322 ! + PARAMETER TC(BCC_A2,CR,FE:C;0) 2.98150E+02 1650; 6.00000E+03 N + REF102 ! + PARAMETER TC(BCC_A2,CR,FE:C;1) 2.98150E+02 550; 6.00000E+03 N + REF102 ! + PARAMETER BMAGN(BCC_A2,CR,FE:C;0) 2.98150E+02 -.85; 6.00000E+03 N + REF102 ! + PARAMETER G(BCC_A2,CR:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N + REF101 ! + PARAMETER G(BCC_A2,FE,MO:C;0) 2.98150E+02 -1250000+667.7*T; + 6.00000E+03 N REF325 ! + PARAMETER TC(BCC_A2,FE,MO:C;0) 2.98150E+02 335; 6.00000E+03 N + REF104 ! + PARAMETER TC(BCC_A2,FE,MO:C;1) 2.98150E+02 526; 6.00000E+03 N + REF104 ! + PARAMETER G(BCC_A2,FE,SI:C;0) 2.98150E+02 78866; 6.00000E+03 N + REF99 ! + PARAMETER G(BCC_A2,FE,V:C;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 + N REF270 ! + PARAMETER G(BCC_A2,FE,V:C;1) 2.98150E+02 8283; 6.00000E+03 N REF270 ! + PARAMETER G(BCC_A2,FE:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N + REF190 ! + PARAMETER G(BCC_A2,V:C,VA;0) 2.98150E+02 -297868; 6.00000E+03 N + REF256 ! + PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 + N REF107 ! + PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N + REF107 ! + PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N + REF107 ! + PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N + REF107 ! + PARAMETER G(BCC_A2,CR,FE,V:VA;0) 2.98150E+02 14881; 6.00000E+03 N + REF323 ! + PARAMETER G(BCC_A2,CR,FE,V:VA;1) 2.98150E+02 17968; 6.00000E+03 N + REF323 ! + PARAMETER G(BCC_A2,CR,FE,V:VA;2) 2.98150E+02 -7692; 6.00000E+03 N + REF323 ! + PARAMETER G(BCC_A2,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; + 6.00000E+03 N REF123 ! + PARAMETER G(BCC_A2,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 + N REF123 ! + PARAMETER G(BCC_A2,CR,SI:VA;0) 2.98150E+02 -102850.19+9.85457*T; + 6.00000E+03 N REF90 ! + PARAMETER G(BCC_A2,CR,SI:VA;1) 2.98150E+02 -49502.35+13.76967*T; + 6.00000E+03 N REF90 ! + PARAMETER G(BCC_A2,CR,V:VA;0) 2.98150E+02 -9875-2.6964*T; 6.00000E+03 + N REF323 ! + PARAMETER G(BCC_A2,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 + N REF323 ! + PARAMETER G(BCC_A2,FE,MO:VA;0) 2.98150E+02 +36818-9.141*T; + 6.00000E+03 N REF10 ! + PARAMETER G(BCC_A2,FE,MO:VA;1) 2.98150E+02 -362-5.724*T; 6.00000E+03 + N REF10 ! + PARAMETER TC(BCC_A2,FE,MO:VA;0) 2.98150E+02 335; 6.00000E+03 N + REF10 ! + PARAMETER TC(BCC_A2,FE,MO:VA;1) 2.98150E+02 526; 6.00000E+03 N + REF10 ! + PARAMETER G(BCC_A2,FE,SI:VA;0) 2.98150E+02 +4*L0BCC#-4*FESIW1#; + 6.00000E+03 N REF98 ! + PARAMETER G(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*L1BCC#; 6.00000E+03 N + REF98 ! + PARAMETER G(BCC_A2,FE,SI:VA;2) 2.98150E+02 +16*L2BCC#; 6.00000E+03 + N REF98 ! + PARAMETER TC(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*ETCFESI#; 6.00000E+03 + N REF98 ! + PARAMETER G(BCC_A2,FE,V:VA;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 + N REF269 ! + PARAMETER G(BCC_A2,FE,V:VA;1) 2.98150E+02 8283; 6.00000E+03 N + REF269 ! + PARAMETER TC(BCC_A2,FE,V:VA;0) 2.98150E+02 -110; 6.00000E+03 N + REF111 ! + PARAMETER TC(BCC_A2,FE,V:VA;1) 2.98150E+02 3075; 6.00000E+03 N + REF111 ! + PARAMETER TC(BCC_A2,FE,V:VA;2) 2.98150E+02 808; 6.00000E+03 N + REF111 ! + PARAMETER TC(BCC_A2,FE,V:VA;3) 2.98150E+02 -2169; 6.00000E+03 N + REF111 ! + PARAMETER BMAGN(BCC_A2,FE,V:VA;0) 2.98150E+02 -2.26; 6.00000E+03 N + REF111 ! + + + TYPE_DEFINITION ' GES A_P_D CBCC_A12 MAGNETIC -3.0 2.80000E-01 ! + PHASE CBCC_A12 %' 2 1 1 ! + CONSTITUENT CBCC_A12 :CR,FE,SI,V : C,VA% : ! + + PARAMETER G(CBCC_A12,CR:C;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CBCC_A12,FE:C;0) 2.98150E+02 +80000+GHSERFE#+GHSERCC#; + 6.00000E+03 N REF267 ! + PARAMETER G(CBCC_A12,SI:C;0) 2.98150E+02 +1000000+566.0326*T + -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); + 3.00000E+03 N REF177 ! + PARAMETER G(CBCC_A12,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; + 6.00000E+03 N REF275 ! + PARAMETER G(CBCC_A12,CR:VA;0) 2.98150E+02 +11087+2.7196*T+GHSERCR#; + 6.00000E+03 N REF283 ! + PARAMETER G(CBCC_A12,FE:VA;0) 2.98150E+02 +4745+GHSERFE#; 6.00000E+03 + N REF283 ! + PARAMETER G(CBCC_A12,SI:VA;0) 2.98150E+02 +50208-20.377*T+GHSERSI#; + 3.60000E+03 N REF283 ! + PARAMETER G(CBCC_A12,V:VA;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CBCC_A12,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N + REF267 ! + PARAMETER G(CBCC_A12,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; + 6.00000E+03 N REF42 ! + PARAMETER G(CBCC_A12,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N + REF42 ! + PARAMETER G(CBCC_A12,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N + REF42 ! + PARAMETER G(CBCC_A12,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N + REF275 ! + + + PHASE CEMENTITE % 2 3 1 ! + CONSTITUENT CEMENTITE :CR,FE%,MO,V : C : ! + + PARAMETER G(CEMENTITE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#-48000 + -9.2888*T; 6.00000E+03 N REF322 ! + PARAMETER G(CEMENTITE,FE:C;0) 2.98150E+02 +GFECEM#; 6.00000E+03 N + REF190 ! + PARAMETER G(CEMENTITE,MO:C;0) 2.98150E+02 +3*GHSERMO#+GHSERCC#+77000 + -57.4*T; 6.00000E+03 N REF104 ! + PARAMETER G(CEMENTITE,V:C;0) 2.98150E+02 -156971+601.922*T + -100.438*T*LN(T)+765557*T**(-1); 6.00000E+03 N REF275 ! + PARAMETER G(CEMENTITE,CR,FE:C;0) 2.98150E+02 +25278-17.5*T; + 6.00000E+03 N REF322 ! + PARAMETER G(CEMENTITE,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N + REF316 ! + PARAMETER G(CEMENTITE,CR,V:C;0) 2.98150E+02 -29622-8.0892*T; + 6.00000E+03 N REF324 ! + PARAMETER G(CEMENTITE,CR,V:C;1) 2.98150E+02 -5160-7.5711*T; + 6.00000E+03 N REF324 ! + PARAMETER G(CEMENTITE,FE,V:C;0) 2.98150E+02 -45873-12.414*T; + 6.00000E+03 N REF270 ! + + + PHASE CHI_A12 % 3 24 10 24 ! + CONSTITUENT CHI_A12 :CR,FE : CR,MO : CR,FE,MO : ! + + PARAMETER G(CHI_A12,CR:CR:CR;0) 2.98150E+02 +48*GCRFCC#+10*GHSERCR# + +109000+123*T; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:CR:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR# + +24*GCRFCC#+18300-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(CHI_A12,CR:MO:CR;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# + +24*GCRFCC#-26000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:MO:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO# + +24*GCRFCC#+32555-385*T; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,CR:CR:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR# + +24*GFEFCC#+500000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:CR:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERCR# + +57300-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(CHI_A12,CR:MO:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# + +24*GFEFCC#+500000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:MO:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERMO# + +305210-270*T; 6.00000E+03 N REF115 ! + PARAMETER G(CHI_A12,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR# + +24*GMOFCC#+500000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:CR:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR# + +24*GMOFCC#+100000; 6.00000E+03 N REF115 ! + PARAMETER G(CHI_A12,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# + +24*GMOFCC#+500000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO# + +24*GMOFCC#+97300-100*T; 6.00000E+03 N REF115 ! + + + PHASE CR2VC2 % 3 2 1 2 ! + CONSTITUENT CR2VC2 :CR : V : C : ! + + PARAMETER G(CR2VC2,CR:V:C;0) 2.98150E+02 -105987-38.2069*T+2*GHSERCR# + +GHSERVV#+2*GHSERCC#; 6.00000E+03 N REF324 ! + + + PHASE CR3SI % 2 3 1 ! + CONSTITUENT CR3SI :CR%,SI : CR,SI% : ! + + PARAMETER G(CR3SI,CR:CR;0) 2.98150E+02 +17008.82+4*T+4*GHSERCR#; + 6.00000E+03 N REF90 ! + PARAMETER G(CR3SI,SI:CR;0) 2.98150E+02 +167008.8+4*T+GHSERCR# + +3*GHSERSI#; 6.00000E+03 N REF90 ! + PARAMETER G(CR3SI,CR:SI;0) 2.98150E+02 -125456.6+4*T+3*GHSERCR# + +GHSERSI#; 6.00000E+03 N REF90 ! + PARAMETER G(CR3SI,SI:SI;0) 2.98150E+02 +24543.3+4*T+4*GHSERSI#; + 6.00000E+03 N REF90 ! + + + PHASE CR5SI3 % 2 5 3 ! + CONSTITUENT CR5SI3 :CR : SI : ! + + PARAMETER G(CR5SI3,CR:SI;0) 2.98150E+02 -318953.76+1067.49776*T + -182.57818*T*LN(T)-.02391968*T**2-2.31728E-06*T**3; 6.00000E+03 N + REF90 ! + + + PHASE CRSI % 2 1 1 ! + CONSTITUENT CRSI :CR : SI : ! + + PARAMETER G(CRSI,CR:SI;0) 2.98150E+02 -79041.68+311.75228*T + -51.62865*T*LN(T)-.00447355*T**2+391330*T**(-1); 6.00000E+03 N REF90 ! + + + PHASE CRSI2 % 2 1 2 ! + CONSTITUENT CRSI2 :CR%,SI : CR,SI% : ! + + PARAMETER G(CRSI2,CR:CR;0) 2.98150E+02 +10000+10*T+3*GHSERCR#; + 6.00000E+03 N REF90 ! + PARAMETER G(CRSI2,SI:CR;0) 2.98150E+02 +150000-T+2*GHSERCR#+GHSERSI#; + 6.00000E+03 N REF90 ! + PARAMETER G(CRSI2,CR:SI;0) 2.98150E+02 -96793.65+333.25242*T + -57.85575*T*LN(T)-.01322769*T**2-4.3203E-07*T**3; 6.00000E+03 N REF90 ! + PARAMETER G(CRSI2,SI:SI;0) 2.98150E+02 +77711.85-15.05638*T+3*GHSERSI#; + 6.00000E+03 N REF90 ! + PARAMETER G(CRSI2,CR:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; + 6.00000E+03 N REF90 ! + PARAMETER G(CRSI2,SI:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; + 6.00000E+03 N REF90 ! + + + PHASE CUB_A13 % 2 1 1 ! + CONSTITUENT CUB_A13 :CR,FE,SI,V : C,VA% : ! + + PARAMETER G(CUB_A13,CR:C;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CUB_A13,FE:C;0) 2.98150E+02 +90000+GHSERFE#+GHSERCC#; + 6.00000E+03 N REF267 ! + PARAMETER G(CUB_A13,SI:C;0) 2.98150E+02 +1000000+566.0326*T + -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); + 3.00000E+03 N REF177 ! + PARAMETER G(CUB_A13,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; + 6.00000E+03 N REF275 ! + PARAMETER G(CUB_A13,CR:VA;0) 2.98150E+02 +15899+.6276*T+GHSERCR#; + 6.00000E+03 N REF283 ! + PARAMETER G(CUB_A13,FE:VA;0) 2.98150E+02 +3745+GHSERFE#; 6.00000E+03 + N REF283 ! + PARAMETER G(CUB_A13,SI:VA;0) 2.98150E+02 +47279-20.377*T+GHSERSI#; + 3.60000E+03 N REF283 ! + PARAMETER G(CUB_A13,V:VA;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CUB_A13,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N + REF267 ! + PARAMETER G(CUB_A13,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; + 6.00000E+03 N REF42 ! + PARAMETER G(CUB_A13,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N + REF42 ! + PARAMETER G(CUB_A13,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N + REF42 ! + PARAMETER G(CUB_A13,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N + REF275 ! + + + PHASE DIAMOND_A4 % 1 1.0 ! + CONSTITUENT DIAMOND_A4 :C,SI% : ! + + PARAMETER G(DIAMOND_A4,C;0) 2.98150E+02 -16359.441+175.61*T + -24.31*T*LN(T)-4.723E-04*T**2+2698000*T**(-1)-2.61E+08*T**(-2) + +1.11E+10*T**(-3)+GPCDIA#; 6.00000E+03 N REF283 ! + PARAMETER G(DIAMOND_A4,SI;0) 2.98150E+02 +GHSERSI#; 3.60000E+03 N + REF283 ! + + + TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! + PHASE FCC_A1 %( 2 1 1 ! + CONSTITUENT FCC_A1 :CR,FE%,MO,SI,V : C,VA% : ! + + PARAMETER G(FCC_A1,CR:C;0) 2.98150E+02 +GHSERCR#+GHSERCC#+1200-1.94*T; + 6.00000E+03 N REF322 ! + PARAMETER G(FCC_A1,FE:C;0) 2.98150E+02 +77207-15.877*T+GFEFCC#+GHSERCC# + +GPCFCC#; 6.00000E+03 N REF190 ! + PARAMETER TC(FCC_A1,FE:C;0) 2.98150E+02 -201; 6.00000E+03 N REF190 ! + PARAMETER BMAGN(FCC_A1,FE:C;0) 2.98150E+02 -2.1; 6.00000E+03 N + REF190 ! + PARAMETER G(FCC_A1,MO:C;0) 2.98150E+02 -7500-8.3*T-750000*T**(-1) + +GHSERMO#+GHSERCC#; 6.00000E+03 N REF104 ! + PARAMETER G(FCC_A1,SI:C;0) 2.98150E+02 +GHSERSI#+GHSERCC#-20510+38.7*T; + 6.00000E+03 N REF98 ! + PARAMETER G(FCC_A1,V:C;0) 2.98150E+02 -117302+262.57*T-41.756*T*LN(T) + -.00557101*T**2+590546*T**(-1); 6.00000E+03 N REF256 ! + PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; + 6.00000E+03 N REF281 ! + PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N + REF281 ! + PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N + REF281 ! + PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF281 ! + PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N + REF281 ! + PARAMETER G(FCC_A1,MO:VA;0) 2.98150E+02 +15200+.63*T+GHSERMO#+GPMOBCC#; + 5.00000E+03 N REF283 ! + PARAMETER G(FCC_A1,SI:VA;0) 2.98150E+02 +51000-21.8*T+GHSERSI#; + 3.60000E+03 N REF283 ! + PARAMETER G(FCC_A1,V:VA;0) 2.98150E+02 +7500+1.7*T+GHSERVZ#; + 4.00000E+03 N REF283 ! + PARAMETER G(FCC_A1,CR,FE:C;0) 2.98150E+02 -74319+3.2353*T; + 6.00000E+03 N REF322 ! + PARAMETER G(FCC_A1,CR,V:C;0) 2.98150E+02 +35698-50.0981*T; + 6.00000E+03 N REF324 ! + PARAMETER G(FCC_A1,CR:C,VA;0) 2.98150E+02 -11977+6.8194*T; + 6.00000E+03 N REF322 ! + PARAMETER G(FCC_A1,FE,MO:C;0) 2.98150E+02 6000; 6.00000E+03 N + REF113 ! + PARAMETER G(FCC_A1,FE,SI:C;0) 2.98150E+02 +143220+39.31*T; + 6.00000E+03 N REF99 ! + PARAMETER G(FCC_A1,FE,SI:C;1) 2.98150E+02 -216321; 6.00000E+03 N + REF99 ! + PARAMETER G(FCC_A1,FE,V:C;0) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 + N REF270 ! + PARAMETER G(FCC_A1,FE,V:C;1) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 + N REF270 ! + PARAMETER G(FCC_A1,FE,V:C,VA;0) 2.98150E+02 -40000; 6.00000E+03 N + REF270 ! + PARAMETER G(FCC_A1,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N + REF190 ! + PARAMETER G(FCC_A1,MO,V:C;0) 2.98150E+02 -18000; 6.00000E+03 N + REF220 ! + PARAMETER G(FCC_A1,MO:C,VA;0) 2.98150E+02 -41300; 6.00000E+03 N + REF104 ! + PARAMETER G(FCC_A1,V:C,VA;0) 2.98150E+02 -74811+10.201*T; 6.00000E+03 + N REF256 ! + PARAMETER G(FCC_A1,V:C,VA;1) 2.98150E+02 -30394; 6.00000E+03 N + REF256 ! + PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; + 6.00000E+03 N REF107 ! + PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N + REF107 ! + PARAMETER G(FCC_A1,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; + 6.00000E+03 N REF58 ! + PARAMETER G(FCC_A1,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 + N REF58 ! + PARAMETER G(FCC_A1,CR,SI:VA;0) 2.98150E+02 -122850+9.85457*T; + 6.00000E+03 N REF58 ! + PARAMETER G(FCC_A1,CR,SI:VA;1) 2.98150E+02 -49502+13.76967*T; + 6.00000E+03 N REF58 ! + PARAMETER G(FCC_A1,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 + N REF323 ! + PARAMETER G(FCC_A1,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 + N REF323 ! + PARAMETER G(FCC_A1,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; + 6.00000E+03 N REF10 ! + PARAMETER G(FCC_A1,FE,SI:VA;0) 2.98150E+02 -125248+41.116*T; + 6.00000E+03 N REF98 ! + PARAMETER G(FCC_A1,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N + REF98 ! + PARAMETER G(FCC_A1,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N + REF98 ! + PARAMETER G(FCC_A1,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 + N REF269 ! + + + PHASE FE1SI1 % 2 .5 .5 ! + CONSTITUENT FE1SI1 :FE : SI : ! + + PARAMETER G(FE1SI1,FE:SI;0) 2.98150E+02 +.5*GHSERFE#+.5*GHSERSI#-36381 + +2.22*T; 6.00000E+03 N REF98 ! + + + PHASE FE2SI % 2 .666667 .333333 ! + CONSTITUENT FE2SI :FE : SI : ! + + PARAMETER G(FE2SI,FE:SI;0) 2.98150E+02 +.6666667*GHSERFE# + +.3333333*GHSERSI#-23752-3.54*T; 6.00000E+03 N REF98 ! + + + PHASE FE4N % 2 4 1 ! + CONSTITUENT FE4N :FE : C,VA : ! + + PARAMETER G(FE4N,FE:C;0) 2.98150E+02 +15965+4*GHSERFE#+GHSERCC#; + 6.00000E+03 N REF319 ! + PARAMETER G(FE4N,FE:VA;0) 2.98150E+02 +4*GFEFCC#+10; 6.00000E+03 N + REF319 ! + + + PHASE FE5SI3 % 2 .625 .375 ! + CONSTITUENT FE5SI3 :FE : SI : ! + + PARAMETER G(FE5SI3,FE:SI;0) 2.98150E+02 +.625*GHSERFE#+.375*GHSERSI# + -30143+.27*T; 6.00000E+03 N REF98 ! + + + PHASE FE8SI2C % 3 8 2 1 ! + CONSTITUENT FE8SI2C :FE : SI : C : ! + + PARAMETER G(FE8SI2C,FE:SI:C;0) 2.98150E+02 +8*GHSERFE#+2*GHSERSI# + +GHSERCC#-231047+5.566*T; 6.00000E+03 N REF99 ! + + + PHASE FECN_CHI % 2 5 2 ! + CONSTITUENT FECN_CHI :FE : C : ! + + PARAMETER G(FECN_CHI,FE:C;0) 2.98150E+02 -11287.4+1013.78*T + -176.412*T*LN(T)+810869*T**(-1); 6.00000E+03 N REF319 ! + + + PHASE FESI2_H % 2 .3 .7 ! + CONSTITUENT FESI2_H :FE : SI : ! + + PARAMETER G(FESI2_H,FE:SI;0) 2.98150E+02 +.3*GHSERFE#+.7*GHSERSI#-19649 + -.92*T; 6.00000E+03 N REF98 ! + + + PHASE FESI2_L % 2 .333333 .666667 ! + CONSTITUENT FESI2_L :FE : SI : ! + + PARAMETER G(FESI2_L,FE:SI;0) 2.98150E+02 +.333333*GHSERFE# + +.666667*GHSERSI#-27383+3.48*T; 6.00000E+03 N REF98 ! + + + PHASE GRAPHITE % 1 1.0 ! + CONSTITUENT GRAPHITE :C : ! + + PARAMETER G(GRAPHITE,C;0) 2.98150E+02 +GHSERCC#+GPCGRA#; 6.00000E+03 + N REF283 ! + + + TYPE_DEFINITION ) GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 ! + PHASE HCP_A3 %) 2 1 .5 ! + CONSTITUENT HCP_A3 :CR,FE,MO,SI,V : C,VA% : ! + + PARAMETER G(HCP_A3,CR:C;0) 2.98150E+02 +GHSERCR#+.5*GHSERCC#-18504 + +9.4173*T-2.4997*T*LN(T)+.001386*T**2; 6.00000E+03 N REF322 ! + PARAMETER G(HCP_A3,FE:C;0) 2.98150E+02 +52905-11.9075*T+GFEFCC# + +.5*GHSERCC#+GPCFCC#; 6.00000E+03 N REF190 ! + PARAMETER G(HCP_A3,MO:C;0) 2.98150E+02 -24150-3.625*T-163000*T**(-1) + +GHSERMO#+.5*GHSERCC#; 6.00000E+03 N REF104 ! + PARAMETER G(HCP_A3,SI:C;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(HCP_A3,V:C;0) 2.98150E+02 -85473+182.441*T-30.551*T*LN(T) + -.00538998*T**2+229029*T**(-1); 6.00000E+03 N REF256 ! + PARAMETER G(HCP_A3,CR:VA;0) 2.98150E+02 +4438+GHSERCR#+GPCRBCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(HCP_A3,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N + REF281 ! + PARAMETER BMAGN(HCP_A3,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N + REF281 ! + PARAMETER G(HCP_A3,FE:VA;0) 2.98150E+02 -3705.78+12.591*T-1.15*T*LN(T) + +6.4E-04*T**2+GHSERFE#+GPFEHCP#; 1.81100E+03 Y + -3957.199+5.24951*T+4.9251E+30*T**(-9)+GHSERFE#+GPFEHCP#; 6.00000E+03 N + REF283 ! + PARAMETER G(HCP_A3,MO:VA;0) 2.98150E+02 +11550+GHSERMO#+GPMOBCC#; + 5.00000E+03 N REF283 ! + PARAMETER G(HCP_A3,SI:VA;0) 2.98150E+02 +49200-20.8*T+GHSERSI#; + 3.60000E+03 N REF283 ! + PARAMETER G(HCP_A3,V:VA;0) 2.98150E+02 +4000+2.4*T+GHSERVZ#; + 4.00000E+03 N REF283 ! + PARAMETER G(HCP_A3,CR,FE,MO:C;0) 2.98150E+02 -57062; 6.00000E+03 N + REF316 ! + PARAMETER G(HCP_A3,CR,MO:C;0) 2.98150E+02 -3905+18.5304*T; + 6.00000E+03 N REF316 ! + PARAMETER G(HCP_A3,CR,V:C;0) 2.98150E+02 +17165-9.9072*T; 6.00000E+03 + N REF323 ! + PARAMETER G(HCP_A3,CR:C,VA;0) 2.98150E+02 4165; 6.00000E+03 N + REF207 ! + PARAMETER G(HCP_A3,FE,MO:C;0) 2.98150E+02 +13030-33.8*T; 6.00000E+03 + N REF113 ! + PARAMETER G(HCP_A3,FE,V:C;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 + N REF270 ! + PARAMETER G(HCP_A3,FE:C,VA;0) 2.98150E+02 -22126; 6.00000E+03 N + REF319 ! + PARAMETER G(HCP_A3,MO:C,VA;0) 2.98150E+02 4150; 6.00000E+03 N + REF104 ! + PARAMETER G(HCP_A3,V:C,VA;0) 2.98150E+02 +12430-3.986*T; 6.00000E+03 + N REF256 ! + PARAMETER G(HCP_A3,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; + 6.00000E+03 N REF126 ! + PARAMETER G(HCP_A3,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; + 6.00000E+03 N REF117 ! + PARAMETER G(HCP_A3,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 + N REF117 ! + PARAMETER G(HCP_A3,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 + N REF323 ! + PARAMETER G(HCP_A3,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 + N REF323 ! + PARAMETER G(HCP_A3,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; + 6.00000E+03 N REF10 ! + PARAMETER G(HCP_A3,FE,SI:VA;0) 2.98150E+02 -123468+41.116*T; + 6.00000E+03 N REF42 ! + PARAMETER G(HCP_A3,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N + REF42 ! + PARAMETER G(HCP_A3,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N + REF42 ! + PARAMETER G(HCP_A3,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 + N REF270 ! + + + PHASE KSI_CARBIDE % 2 3 1 ! + CONSTITUENT KSI_CARBIDE :CR,FE,MO% : C : ! + + PARAMETER G(KSI_CARBIDE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#+114060 + -47.2519*T; 6.00000E+03 N REF316 ! + PARAMETER G(KSI_CARBIDE,FE:C;0) 2.98150E+02 +14540+20*T+3*GHSERFE# + +GHSERCC#; 6.00000E+03 N REF113 ! + PARAMETER G(KSI_CARBIDE,MO:C;0) 2.98150E+02 +167009-33*T+3*GHSERMO# + +GHSERCC#; 6.00000E+03 N REF113 ! + PARAMETER G(KSI_CARBIDE,CR,FE:C;0) 2.98150E+02 -139900; 6.00000E+03 + N REF316 ! + PARAMETER G(KSI_CARBIDE,CR,MO:C;0) 2.98150E+02 -348033; 6.00000E+03 + N REF316 ! + PARAMETER G(KSI_CARBIDE,FE,MO:C;0) 2.98150E+02 -380000; 6.00000E+03 + N REF113 ! + + + PHASE LAVES_PHASE % 2 2 1 ! + CONSTITUENT LAVES_PHASE :CR,FE : MO : ! + + PARAMETER G(LAVES_PHASE,CR:MO;0) 2.98150E+02 +2*GCRFCC#+GHSERMO#-8000 + -6*T; 6.00000E+03 N REF214 ! + PARAMETER G(LAVES_PHASE,FE:MO;0) 2.98150E+02 -10798-.132*T+2*GFEFCC# + +GHSERMO#; 6.00000E+03 N REF10 ! + + + PHASE M23C6 % 3 20 3 6 ! + CONSTITUENT M23C6 :CR%,FE%,V : CR%,FE%,MO%,V : C : ! + + PARAMETER G(M23C6,CR:CR:C;0) 2.98150E+02 +GCRM23C6#; 6.00000E+03 N + REF102 ! + PARAMETER G(M23C6,FE:CR:C;0) 2.98150E+02 +.1304348*GCRM23C6# + +.8695652*GFEM23C6#; 6.00000E+03 N REF102 ! + PARAMETER G(M23C6,V:CR:C;0) 2.98150E+02 +.869565*GVM23C6# + +.130435*GCRM23C6#; 6.00000E+03 N REF323 ! + PARAMETER G(M23C6,CR:FE:C;0) 2.98150E+02 +.8695652*GCRM23C6# + +.1304348*GFEM23C6#; 6.00000E+03 N REF102 ! + PARAMETER G(M23C6,FE:FE:C;0) 2.98150E+02 +GFEM23C6#; 6.00000E+03 N + REF102 ! + PARAMETER G(M23C6,V:FE:C;0) 2.98150E+02 +.869565*GVM23C6# + +.130435*GFEM23C6#; 6.00000E+03 N REF323 ! + PARAMETER G(M23C6,CR:MO:C;0) 2.98150E+02 +20*GHSERCR#+3*GHSERMO# + +6*GHSERCC#-439117-50.0535*T; 6.00000E+03 N REF316 ! + PARAMETER G(M23C6,FE:MO:C;0) 2.98150E+02 +20*GHSERFE#+3*GHSERMO# + +6*GHSERCC#-76351-5.095*T; 6.00000E+03 N REF316 ! + PARAMETER G(M23C6,V:MO:C;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(M23C6,CR:V:C;0) 2.98150E+02 +.869565*GCRM23C6# + +.130435*GVM23C6#; 6.00000E+03 N REF323 ! + PARAMETER G(M23C6,FE:V:C;0) 2.98150E+02 +.869565*GFEM23C6# + +.130435*GVM23C6#; 6.00000E+03 N REF323 ! + PARAMETER G(M23C6,V:V:C;0) 2.98150E+02 +GVM23C6#; 6.00000E+03 N + REF323 ! + PARAMETER G(M23C6,CR,FE:CR:C;0) 2.98150E+02 -205342+141.6667*T; + 6.00000E+03 N REF322 ! + PARAMETER G(M23C6,CR,FE,V:CR:C;0) 2.98150E+02 -1499585; 6.00000E+03 + N REF324 ! + PARAMETER G(M23C6,CR,V:CR:C;0) 2.98150E+02 -385502; 6.00000E+03 N + REF324 ! + PARAMETER G(M23C6,CR,FE:FE:C;0) 2.98150E+02 -205342+141.6667*T; + 6.00000E+03 N REF322 ! + PARAMETER G(M23C6,CR,FE,V:FE:C;0) 2.98150E+02 -1499585; 6.00000E+03 + N REF324 ! + PARAMETER G(M23C6,CR,V:FE:C;0) 2.98150E+02 -385502; 6.00000E+03 N + REF324 ! + PARAMETER G(M23C6,CR,FE:MO:C;0) 2.98150E+02 -177850+153.905*T; + 6.00000E+03 N REF316 ! + PARAMETER G(M23C6,CR,FE:V:C;0) 2.98150E+02 -205342+141.6667*T; + 6.00000E+03 N REF324 ! + PARAMETER G(M23C6,CR,FE,V:V:C;0) 2.98150E+02 -1499585; 6.00000E+03 + N REF324 ! + PARAMETER G(M23C6,CR,V:V:C;0) 2.98150E+02 -385502; 6.00000E+03 N + REF324 ! + + + PHASE M3C2 % 2 3 2 ! + CONSTITUENT M3C2 :CR,MO,V : C : ! + + PARAMETER G(M3C2,CR:C;0) 2.98150E+02 +GCRM3C2#; 6.00000E+03 N + REF322 ! + PARAMETER G(M3C2,MO:C;0) 2.98150E+02 +3*GHSERMO#+2*GHSERCC#+27183; + 6.00000E+03 N REF316 ! + PARAMETER G(M3C2,V:C;0) 2.98150E+02 -222500+16.6545*T+3*GHSERVV# + +2*GHSERCC#; 6.00000E+03 N REF324 ! + PARAMETER G(M3C2,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N REF316 ! + PARAMETER G(M3C2,CR,V:C;0) 2.98150E+02 21072; 6.00000E+03 N REF324 ! + + + PHASE M3SI % 2 3 1 ! + CONSTITUENT M3SI :FE : SI : ! + + PARAMETER G(M3SI,FE:SI;0) 2.98150E+02 +3*GHSERFE#+GHSERSI#-94274-3.56*T; + 6.00000E+03 N REF42 ! + + + PHASE M5C2 % 2 5 2 ! + CONSTITUENT M5C2 :FE,V : C : ! + + PARAMETER G(M5C2,FE:C;0) 2.98150E+02 +5*GHSERFE#+2*GHSERCC#+54852 + -33.7518*T; 6.00000E+03 N REF322 ! + PARAMETER G(M5C2,V:C;0) 2.98150E+02 -307123.3+1059.7*T-175.66*T*LN(T) + +1453274*T**(-1); 6.00000E+03 N REF275 ! + + + PHASE M6C % 4 2 2 2 1 ! + CONSTITUENT M6C :FE : MO : CR,FE,MO,V : C : ! + + PARAMETER G(M6C,FE:MO:CR:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERCR# + +2*GHSERMO#+GHSERCC#-25298-54.8698*T; 6.00000E+03 N REF316 ! + PARAMETER G(M6C,FE:MO:FE:C;0) 2.98150E+02 +4*GHSERFE#+2*GHSERMO# + +GHSERCC#+77705-101.5*T; 6.00000E+03 N REF113 ! + PARAMETER G(M6C,FE:MO:MO:C;0) 2.98150E+02 +2*GHSERFE#+4*GHSERMO# + +GHSERCC#-122410+30.25*T; 6.00000E+03 N REF113 ! + PARAMETER G(M6C,FE:MO:V:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERMO# + +2*GHSERVV#+GHSERCC#-173000; 6.00000E+03 N REF220 ! + PARAMETER G(M6C,FE:MO:FE,MO:C;0) 2.98150E+02 -37700; 6.00000E+03 N + REF113 ! + + + PHASE M7C3 % 2 7 3 ! + CONSTITUENT M7C3 :CR%,FE,MO,V : C : ! + + PARAMETER G(M7C3,CR:C;0) 2.98150E+02 +GCRM7C3#; 6.00000E+03 N + REF322 ! + PARAMETER G(M7C3,FE:C;0) 2.98150E+02 +7*GHSERFE#+3*GHSERCC#+75000 + -48.2168*T; 6.00000E+03 N REF322 ! + PARAMETER G(M7C3,MO:C;0) 2.98150E+02 +7*GHSERMO#+3*GHSERCC#-140415 + +24.24*T; 6.00000E+03 N REF316 ! + PARAMETER G(M7C3,V:C;0) 2.98150E+02 -454245+1518.48*T-250.981*T*LN(T) + +2148691*T**(-1); 6.00000E+03 N REF324 ! + PARAMETER G(M7C3,CR,FE:C;0) 2.98150E+02 -4520-10*T; 6.00000E+03 N + REF322 ! + PARAMETER G(M7C3,CR,FE,V:C;0) 2.98150E+02 -250158; 6.00000E+03 N + REF324 ! + PARAMETER G(M7C3,CR,MO:C;0) 2.98150E+02 165280; 6.00000E+03 N + REF316 ! + PARAMETER G(M7C3,CR,V:C;0) 2.98150E+02 -110271; 6.00000E+03 N + REF324 ! + + + PHASE MC_ETA % 2 1 1 ! + CONSTITUENT MC_ETA :MO% : C%,VA : ! + + PARAMETER G(MC_ETA,MO:C;0) 2.98150E+02 -9100-5.35*T-750000*T**(-1) + +GHSERMO#+GHSERCC#; 6.00000E+03 N REF113 ! + PARAMETER G(MC_ETA,MO:VA;0) 2.98150E+02 +GHSERMO#+15200+.63*T; + 6.00000E+03 N REF113 ! + PARAMETER G(MC_ETA,MO:C,VA;0) 2.98150E+02 -59500; 6.00000E+03 N + REF104 ! + + + PHASE MC_SHP % 2 1 1 ! + CONSTITUENT MC_SHP :MO : C : ! + + PARAMETER G(MC_SHP,MO:C;0) 2.98150E+02 -32983+2.5*T+GHSERMO#+GHSERCC#; + 6.00000E+03 N REF104 ! + + + PHASE MONI_DELTA % 3 24 20 12 ! + CONSTITUENT MONI_DELTA :CR,FE : CR,FE,MO : MO : ! + + PARAMETER G(MONI_DELTA,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR# + +12*GHSERMO#+50000; 6.00000E+03 N REF133 ! + PARAMETER G(MONI_DELTA,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(MONI_DELTA,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(MONI_DELTA,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE# + +12*GHSERMO#+100000; 6.00000E+03 N REF132 ! + PARAMETER G(MONI_DELTA,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO# + +100000; 6.00000E+03 N REF133 ! + PARAMETER G(MONI_DELTA,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO# + +100000; 6.00000E+03 N REF132 ! + + + PHASE MU_PHASE % 3 7 2 4 ! + CONSTITUENT MU_PHASE :CR,FE : MO : CR,FE,MO : ! + + PARAMETER G(MU_PHASE,CR:MO:CR;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# + +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(MU_PHASE,FE:MO:CR;0) 2.98150E+02 +7*GFEFCC#+2*GHSERMO# + +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(MU_PHASE,CR:MO:FE;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# + +4*GHSERFE#+130000-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(MU_PHASE,FE:MO:FE;0) 2.98150E+02 +39475-6.032*T+7*GFEFCC# + +2*GHSERMO#+4*GHSERFE#+GPMU1#; 6.00000E+03 N REF10 ! + PARAMETER G(MU_PHASE,CR:MO:MO;0) 2.98150E+02 +7*GCRFCC#+6*GHSERMO# + +130000-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(MU_PHASE,FE:MO:MO;0) 2.98150E+02 -46663-5.891*T+7*GFEFCC# + +6*GHSERMO#+GPMU2#; 6.00000E+03 N REF10 ! + PARAMETER G(MU_PHASE,CR,FE:MO:MO;0) 2.98150E+02 -45000; 6.00000E+03 + N REF115 ! + + + PHASE P_PHASE % 3 24 20 12 ! + CONSTITUENT P_PHASE :CR,FE : CR,FE,MO : MO : ! + + PARAMETER G(P_PHASE,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR# + +12*GHSERMO#+252300-100*T; 6.00000E+03 N REF133 ! + PARAMETER G(P_PHASE,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(P_PHASE,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(P_PHASE,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE# + +12*GHSERMO#+111361; 6.00000E+03 N REF132 ! + PARAMETER G(P_PHASE,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO# + +95573-200*T; 6.00000E+03 N REF133 ! + PARAMETER G(P_PHASE,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO# + +362525-332.7*T; 6.00000E+03 N REF132 ! + + + PHASE R_PHASE % 3 27 14 12 ! + CONSTITUENT R_PHASE :CR,FE : MO : CR,FE,MO : ! + + PARAMETER G(R_PHASE,CR:MO:CR;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO# + +12*GHSERCR#-20000; 6.00000E+03 N REF115 ! + PARAMETER G(R_PHASE,FE:MO:CR;0) 2.98150E+02 +27*GFEFCC#+14*GHSERMO# + +12*GHSERCR#+600260-620*T; 6.00000E+03 N REF115 ! + PARAMETER G(R_PHASE,CR:MO:FE;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO# + +12*GHSERFE#+645260-620*T; 6.00000E+03 N REF115 ! + PARAMETER G(R_PHASE,FE:MO:FE;0) 2.98150E+02 -77487-50.486*T+27*GFEFCC# + +14*GHSERMO#+12*GHSERFE#+GPR1#; 6.00000E+03 N REF10 ! + PARAMETER G(R_PHASE,CR:MO:MO;0) 2.98150E+02 +27*GCRFCC#+26*GHSERMO# + -20000; 6.00000E+03 N REF115 ! + PARAMETER G(R_PHASE,FE:MO:MO;0) 2.98150E+02 +313474-289.472*T + +27*GFEFCC#+26*GHSERMO#+GPR2#; 6.00000E+03 N REF10 ! + + + PHASE SIC % 2 1 1 ! + CONSTITUENT SIC :SI : C : ! + + PARAMETER G(SIC,SI:C;0) 2.98150E+02 -85572.2636+173.200518*T + -25.856*T*LN(T)-.02106825*T**2+3.2153E-06*T**3+438415*T**(-1); + 7.00000E+02 Y + -95145.9018+300.345769*T-45.093*T*LN(T)-.00366815*T**2 + +2.19983333E-07*T**3+1341065*T**(-1); 2.10000E+03 Y + -105007.971+360.308813*T-53.073*T*LN(T)-7.4525E-04*T**2 + +1.73166667E-08*T**3+3693345*T**(-1); 4.00000E+03 N REF286 ! + + + PHASE SIGMA % 3 8 4 18 ! + CONSTITUENT SIGMA :FE : CR,MO,V : CR,FE,MO,V : ! + + PARAMETER G(SIGMA,FE:CR:CR;0) 2.98150E+02 +8*GFEFCC#+22*GHSERCR#+92300 + -95.96*T+GPSIG1#; 6.00000E+03 N REF107 ! + PARAMETER G(SIGMA,FE:MO:CR;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO# + +18*GHSERCR#+488480-360*T; 6.00000E+03 N REF115 ! + PARAMETER G(SIGMA,FE:V:CR;0) 2.98150E+02 +155735-89.5976*T+8*GFEFCC# + +4*GHSERVV#+18*GHSERCR#; 6.00000E+03 N REF323 ! + PARAMETER G(SIGMA,FE:CR:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# + +18*GHSERFE#+117300-95.96*T+GPSIG2#; 6.00000E+03 N REF107 ! + PARAMETER G(SIGMA,FE:MO:FE;0) 2.98150E+02 -1813-27.272*T+8*GFEFCC# + +18*GHSERFE#+4*GHSERMO#; 6.00000E+03 N REF10 ! + PARAMETER G(SIGMA,FE:V:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV# + +18*GHSERFE#-157961+60.729*T; 6.00000E+03 N REF269 ! + PARAMETER G(SIGMA,FE:CR:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# + +18*GHSERMO#+312580-260*T; 6.00000E+03 N REF115 ! + PARAMETER G(SIGMA,FE:MO:MO;0) 2.98150E+02 +83326-69.618*T+8*GFEFCC# + +22*GHSERMO#; 6.00000E+03 N REF10 ! + PARAMETER G(SIGMA,FE:V:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV# + +18*GHSERMO#; 6.00000E+03 N REF136 ! + PARAMETER G(SIGMA,FE:CR:V;0) 2.98150E+02 -245761-67.3294*T+8*GFEFCC# + +4*GHSERCR#+18*GHSERVV#; 6.00000E+03 N REF323 ! + PARAMETER G(SIGMA,FE:MO:V;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO# + +18*GHSERVV#; 6.00000E+03 N REF136 ! + PARAMETER G(SIGMA,FE:V:V;0) 2.98150E+02 +8*GFEFCC#+22*GHSERVV#-205321 + -60.967*T; 6.00000E+03 N REF269 ! + PARAMETER G(SIGMA,FE:CR:CR,MO;0) 2.98150E+02 -148000; 6.00000E+03 N + REF115 ! + PARAMETER G(SIGMA,FE:MO:CR,MO;0) 2.98150E+02 121000; 6.00000E+03 N + REF115 ! + PARAMETER G(SIGMA,FE:CR:FE,MO;0) 2.98150E+02 570000; 6.00000E+03 N + REF115 ! + PARAMETER G(SIGMA,FE:CR:FE,V;0) 2.98150E+02 -235158; 6.00000E+03 N + REF323 ! + PARAMETER G(SIGMA,FE:MO:FE,MO;0) 2.98150E+02 222909; 6.00000E+03 N + REF10 ! + PARAMETER G(SIGMA,FE:V:FE,V;0) 2.98150E+02 -305784; 6.00000E+03 N + REF269 ! + + + PHASE V3C2 % 2 3 2 ! + CONSTITUENT V3C2 :FE,V : C : ! + + PARAMETER G(V3C2,FE:C;0) 2.98150E+02 +7250+741.566*T-125.833*T*LN(T) + +779485*T**(-1); 6.00000E+03 N REF275 ! + PARAMETER G(V3C2,V:C;0) 2.98150E+02 -260341+16.897*T+3*GHSERVV# + +2*GHSERCC#; 6.00000E+03 N REF256 ! + + LIST_OF_REFERENCES + NUMBER SOURCE + REF283 'Alan Dinsdale, SGTE Data for Pure Elements, + Calphad Vol 15(1991) p 317-425, + also in NPL Report DMA(A)195 Rev. August 1990' + REF101 'J-O Andersson, Calphad Vol 11 (1987) p 271-276, TRITA 0314; C-CR' + REF190 'P. Gustafson, Scan. J. Metall. vol 14, (1985) p 259-267 + TRITA 0237 (1984); C-FE' + REF104 'J-O Andersson, Calphad Vol 12 (1988) p 1-8 TRITA 0317 (1986); C + -MO' + REF98 'J. Lacaze and B. Sundman, provisional; Fe-Si' + REF256 'W. Huang, TRITA-MAC 431 (1990); C-V' + REF267 'W. Huang, Metall. Trans. Vol 21A(1990) p 2115-2123, + TRITA-MAC 411 (Rev 1989); C-FE-MN' + REF177 'NPL, unpublished work (1989); C-Mn-Si' + REF275 'W. Huang, TRITA-MAC 441 (1990), Fe-Mn-V-C *' + REF322 'Byeong-Joo Lee, unpublished revision (1991); C-Cr-Fe-Ni' + REF213 'P. Gustafson, TRITA-MAC 342, (1987); CR-FE-W' + REF115 'J-O Andersson, Met Trans A, Vol 19A, (1988) p 1385-1394 + TRITA 0322 (1986); CR-FE-MO' + REF324 'Byeong-Joo Lee, TRITA-MAC 475 (1991), C-Cr-Fe-V' + REF90 'I Ansara, unpublished work (1991); Cr-Si' + REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 + September 1989' + REF319 'H. Du and M. Hillert, revision; C-Fe-N' + REF99 'J. Lacaze and B. Sundman, Met. Trans A, Vol 22A (1991) + pp 2211-2223; C-Fe-Si' + REF316 'Caian Qui, Trita-MAC 482 (1992) Revision ; C-Cr-Fe-Mo' + REF113 'J-O Andersson, Calphad Vol 12 (1988), p 9-23 + TRITA 0321 (1986); C-FE-MO' + REF214 'P. Gustafson, TRITA-MAC 354 (1987); C-Cr-Fe-Mo-W' + REF10 'A. Fernandez Guillermet, CALPHAD Vol 6 (1982), p 127-140 + (sigma phase revised 1986), TRITA-MAC 200 (1982); FE-MO' + REF102 'J-O Andersson, Met. Trans A, Vol 19A, (1988) p 627-636 + TRITA 0207 (1986); C-CR-FE' + REF323 'Byeong-Joo Lee, TRITA-MAC 474 (1991), Cr-Fe-V' + REF42 'Annika Forsberg and John ]gren, TRITA-MAC 483 (1992); Fe-Mn-Si' + REF220 'P Gustafson, Inst. Met. Res. (Sweden) (1990); Estimations of + C-CR-FE-V, C-CR-FE-MO-V-W, FE-N-W, FE-MN-N, FE-N-SI, CR-N-V, C-CR + -N, + FE-MO-N, CR-N-W, CR-TI-N' + REF133 'K. Frisk, TRITA-MAC 429 (1990); CR-MO-NI' + REF132 'K. Frisk, TRITA-MAC 428 (1990); FE-MO-NI' + REF286 'SGTE Substance database, AUG 1989.' + REF107 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 + TRITA 0270 (1986); CR-FE' + REF269 'W. Huang, TRITA-MAC 432 (Rev 1989,1990); FE-V' + REF136 'Unassessed parameter, linear combination of unary data. (MU, + SIGMA)' + REF123 'K. Frisk, Report D 60, KTH, (1984); CR-MO' + REF325 'Byeong-Joo Lee, unpublished revision (1991), C-Cr-Fe-Mo-Ni' + REF270 'W. Huang, TRITA-MAC 432 (1990); C-Fe-V' + REF58 'B. Sundman, TEST' + REF207 'P. Gustafson, Metall. Trans. 19A(1988) p 2547-2554, + TRITA-MAC 348, (1987); C-CR-FE-W' + REF126 'K. Frisk, Metall. Trans. Vol 21A (1990) p 2477-2488, + TRITA 0409 (1989); CR-FE-N' + REF117 'J-O Andersson, TRITA-MAC 323 (1986); C-CR-FE-MO' + REF111 'J-O Andersson, CALPHAD Vol 7, (1983), p 305-315 (parameters + revised + 1986 due to new decription of V) TRITA 0201 (1982); FE-V' + ! + diff --git a/macros/step1-hss.OCM b/macros/ocv2/step1.OCM similarity index 88% rename from macros/step1-hss.OCM rename to macros/ocv2/step1.OCM index 393c635..1e2703d 100644 --- a/macros/step1-hss.OCM +++ b/macros/ocv2/step1.OCM @@ -1,109 +1,109 @@ -@$ Calculating property diagrams for a High Speed Steel (HSS) -@& - -set echo - -r t steel1 - -set c t=1200 p=1e5 n=1 w(c)=.009 w(cr)=.045, w(mo)=.1 w(si)=.001 w(v)=.009 - -@$ Enter a composition set for the MC carbide (FCC) -amend phase fcc comp_set y MC , -NONE -<.1 -NONE -<.1 -NONE ->.5 -<.2 - -@$ Set the default constitution for the FCC to be austenite -amend phase fcc default -<.2 -NONE -<.2 -<.1 -<.2 -<.2 ->.5 - -@$ Enter a composition set for the M2C carbide (HCP) -amend phase hcp comp_set y M2C , -NONE -NONE -NONE -NONE -NONE ->.5 -<.2 - -c e - -l r 1 - -@& - -l r 4 - -@& - -set axis 1 T 800 1800 10 - -l ax - -@& - -step - - - - - -@& - -l line - -@& - -l eq - -plot,,,,,,,,,,,, - - - -plot -T -w(*,cr),,,,,,,,,,,,,,,,,,, - - - -plot -T -H -plot,,,,,,,,,,,,,,,,,, - - -ent sym cp=hm.t; - - - -plot -T -cp,,,,,,,,,,,,,,,,,, - - - -@$ scaling of y axis - -plot -T -cp -yr -N -0 -200 - - - -set inter - +@$ Calculating property diagrams for a High Speed Steel (HSS) +@& + +set echo + +r t steel1 + +set c t=1200 p=1e5 n=1 w(c)=.009 w(cr)=.045, w(mo)=.1 w(si)=.001 w(v)=.009 + +@$ Enter a composition set for the MC carbide (FCC) +amend phase fcc comp_set y MC , +NONE +<.1 +NONE +<.1 +NONE +>.5 +<.2 + +@$ Set the default constitution for the FCC to be austenite +amend phase fcc default +<.2 +NONE +<.2 +<.1 +<.2 +<.2 +>.5 + +@$ Enter a composition set for the M2C carbide (HCP) +amend phase hcp comp_set y M2C , +NONE +NONE +NONE +NONE +NONE +>.5 +<.2 + +c e + +l r 1 + +@& + +l r 4 + +@& + +set axis 1 T 800 1800 10 + +l ax + +@& + +step + + + + + +@& + +l line + +@& + +l eq + +plot,,,,,,,,,,,, + + + +plot +T +w(*,cr),,,,,,,,,,,,,,,,,,, + + + +plot +T +H +plot,,,,,,,,,,,,,,,,,, + + +ent sym cp=hm.t; + + + +plot +T +cp,,,,,,,,,,,,,,,,,, + + + +@$ scaling of y axis + +plot +T +cp +yr +N +0 +200 + + + +set inter + diff --git a/macros/step2-agcu.OCM b/macros/ocv2/step2.OCM similarity index 100% rename from macros/step2-agcu.OCM rename to macros/ocv2/step2.OCM diff --git a/macros/step3-hogas.OCM b/macros/ocv2/step3.OCM similarity index 100% rename from macros/step3-hogas.OCM rename to macros/ocv2/step3.OCM diff --git a/macros/step4-feni.OCM b/macros/ocv2/step4.OCM similarity index 100% rename from macros/step4-feni.OCM rename to macros/ocv2/step4.OCM diff --git a/macros/step5-feni.OCM b/macros/ocv2/step5.OCM similarity index 100% rename from macros/step5-feni.OCM rename to macros/ocv2/step5.OCM diff --git a/macros/step6-femo.OCM b/macros/ocv2/step6.OCM similarity index 100% rename from macros/step6-femo.OCM rename to macros/ocv2/step6.OCM diff --git a/macros/step7-saf.OCM b/macros/ocv2/step7.OCM similarity index 100% rename from macros/step7-saf.OCM rename to macros/ocv2/step7.OCM diff --git a/macros/unary.OCM b/macros/ocv2/unary.OCM similarity index 100% rename from macros/unary.OCM rename to macros/ocv2/unary.OCM diff --git a/macros/ocv3/OU.TDB b/macros/ocv3/OU.TDB new file mode 100644 index 0000000..ebfdcec --- /dev/null +++ b/macros/ocv3/OU.TDB @@ -0,0 +1,279 @@ + +$ Database file written 2013- 3-10 +$ From database: USER + ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT O GAS_1/2_MOLE_O2 1.5999E+01 4.3410E+03 1.0252E+02! + ELEMENT U ORTHORHOMBIC_A20 2.3803E+02 6.3640E+03 5.0200E+01! + + SPECIES O-2 O1/-2! + SPECIES O2 O2! + SPECIES O3 O3! + SPECIES U+3 U1/+3! + SPECIES U+4 U1/+4! + SPECIES U+5 U1/+5! + SPECIES UO O1U1! + SPECIES UO2 O2U1! + SPECIES UO3 O3U1! + + FUNCTION OGAS 298.15 +243206.494-20.8612587*T-21.01555*T*LN(T) + +1.2687055E-04*T**2-1.23131283E-08*T**3-42897.09*T**(-1); 2950 Y + +252301.423-52.0847285*T-17.21188*T*LN(T)-5.413565E-04*T**2 + +7.64520667E-09*T**3-3973170.5*T**(-1); 6000 N ! + FUNCTION O2GAS 298.15 -6960.69252-51.1831473*T-22.25862*T*LN(T) + -.01023867*T**2+1.339947E-06*T**3-76749.55*T**(-1); 9.00000E+02 Y + -13136.0172+24.743296*T-33.55726*T*LN(T)-.0012348985*T**2 + +1.66943333E-08*T**3+539886*T**(-1); 3.70000E+03 Y + +14154.6461-51.4854586*T-24.47978*T*LN(T)-.002634759*T**2 + +6.01544333E-08*T**3-15120935*T**(-1); 9.60000E+03 Y + -314316.628+515.068037*T-87.56143*T*LN(T)+.0025787245*T**2 + -1.878765E-08*T**3+2.9052515E+08*T**(-1); 1.85000E+04 Y + -108797.175+288.483019*T-63.737*T*LN(T)+.0014375*T**2-9E-09*T**3 + +.25153895*T**(-1); 2.00000E+04 N ! + FUNCTION O3GAS 298.15 +130696.944-37.9096651*T-27.58118*T*LN(T) + -.02763076*T**2+4.60539333E-06*T**3+99530.45*T**(-1); 4.00000E+02 Y + +114760.623+176.626736*T-60.10286*T*LN(T)+.00206456*T**2 + -5.17486667E-07*T**3+1572175*T**(-1); 1.30000E+03 Y + +49468.3958+710.094819*T-134.3696*T*LN(T)+.039707355*T**2 + -4.10457667E-06*T**3+12362250*T**(-1); 2.10000E+03 Y + +866367.075-3566.80563*T+421.2001*T*LN(T)-.1284109*T**2 + +5.44768833E-06*T**3-2.1304835E+08*T**(-1); 2.80000E+03 Y + +409416.384-1950.70834*T+223.4437*T*LN(T)-.0922361*T**2 + +4.306855E-06*T**3-21589870*T**(-1); 3.50000E+03 Y + -1866338.6+6101.13383*T-764.8435*T*LN(T)+.09852775*T**2 + -2.59784667E-06*T**3+9.610855E+08*T**(-1); 4.90000E+03 Y + +97590.0432+890.79836*T-149.9608*T*LN(T)+.01283575*T**2 + -3.555105E-07*T**3-2.1699975E+08*T**(-1); 6000 N ! + FUNCTION GHSEROO 298.15 -3480.87-25.503038*T-11.136*T*LN(T) + -.005098888*T**2+6.61846E-07*T**3-38365*T**(-1); 1.00000E+03 Y + -6568.763+12.65988*T-16.8138*T*LN(T)-5.95798E-04*T**2+6.781E-09*T**3 + +262905*T**(-1); 3.30000E+03 Y + -13986.728+31.259625*T-18.9536*T*LN(T)-4.25243E-04*T**2 + +1.0721E-08*T**3+4383200*T**(-1); 6000 N ! + FUNCTION GASU 298.15 +523164.925+13.603288*T-32.513*T*LN(T) + +.01126565*T**2-2.43328E-06*T**3+151130*T**(-1); 9.00000E+02 Y + +541065.13-173.693179*T-5.336*T*LN(T)-.00723615*T**2-4.306E-08*T**3 + -2072960*T**(-1); 2.10000E+03 Y + +605452.662-512.542339*T+38.748*T*LN(T)-.0208079*T**2+7.5045E-07*T**3 + -19886375*T**(-1); 4.50000E+03 Y + -41328.1657+1300.29089*T-176.856*T*LN(T)+.0113664*T**2 + -1.56178333E-07*T**3+3.4654725E+08*T**(-1); 9.20000E+03 Y + +410972.67+537.324611*T-92.012*T*LN(T)+.0043702*T**2 + -4.90033333E-08*T**3-99572850*T**(-1); 1.20000E+04 N ! + FUNCTION GLIQUU 298.15 +3947.766+120.631251*T-26.9182*T*LN(T) + +.00125156*T**2-4.42605E-06*T**3+38568*T**(-1); 9.55000E+02 Y + -10166.3+281.797193*T-48.66*T*LN(T); 3.00000E+03 N ! + FUNCTION GFCCUU 298.15 -3407.734+130.955151*T-26.9182*T*LN(T) + +.00125156*T**2-4.42605E-06*T**3+38568*T**(-1); 9.55000E+02 Y + -17521.8+292.121093*T-48.66*T*LN(T); 3.00000E+03 N ! + FUNCTION GBCCUU 298.15 -752.767+131.5381*T-27.5152*T*LN(T) + -.00835595*T**2+9.67907E-07*T**3+204611*T**(-1); 1.04900E+03 Y + -4698.365+202.685635*T-38.2836*T*LN(T); 3.00000E+03 N ! + FUNCTION GHSERUU 298.15 -8407.734+130.955151*T-26.9182*T*LN(T) + +.00125156*T**2-4.42605E-06*T**3+38568*T**(-1); 9.55000E+02 Y + -22521.8+292.121093*T-48.66*T*LN(T); 3.00000E+03 N ! + FUNCTION GTETUU 298.15 -5156.136+106.976316*T-22.841*T*LN(T) + -.01084475*T**2+2.7889E-08*T**3+81944*T**(-1); 9.41500E+02 Y + -14327.309+244.16802*T-42.9278*T*LN(T); 3.00000E+03 N ! + FUNCTION UOGAS 298.15 +7058.467+16.66929*T-38.48092*T*LN(T) + -.01650935*T**2+6.74198333E-06*T**3-1.22913333E-09*T**4+257767*T**(-1); + 1.30000E+03 Y + +10617.823+76.4054808*T-50.04939*T*LN(T)+.0090553*T**2 + -2.0628666E-06*T**3+1.42865E-10*T**4-1254735*T**(-1); 4.00000E+03 N ! + FUNCTION UO2GAS 298.15 -477055.313+30.72281*T-44.35744*T*LN(T) + -.018817925*T**2+3.85927167E-06*T**3-4.58556667E-10*T**4 + +37425.465*T**(-1); 1.50000E+03 Y + -483042.479+128.845816*T-59.57586*T*LN(T)-.0026962*T**2 + -1.57719683E-08*T**3+8.57269167E-12*T**4+315972.55*T**(-1); 4000 N ! + FUNCTION UO3GAS 298.15 -813296.059+27.9636972*T-46.69199*T*LN(T) + -.047347135*T**2+1.58195017E-05*T**3-2.84654167E-09*T**4 + +139692.15*T**(-1); 9.00000E+02 Y + -827058.826+248.932783*T-81.70962*T*LN(T)-.001004739*T**2 + +1.85084167E-07*T**3-1.8022825E-11*T**4+1290177.5*T**(-1); 4000 N ! + FUNCTION LOWLIQ 298.15 +G4OV#+79775-25.0114*T-2.62269566E-21*T**7; + 2.60000E+03 N ! + FUNCTION O2ULIQ 298.15 -1590418+3618.8*T-480*T*LN(T)+.07*T**2 + -1E-06*T**3; 6000 N ! + FUNCTION G3OO 298.15 +G3OV#+GHSEROO#; 6000 N ! + FUNCTION G4OO 298.15 +G4OV#+GHSEROO#; 6000 N ! + FUNCTION G5OO 298.15 +G5OV#+GHSEROO#; 6000 N ! + FUNCTION G3OV 298.15 +G4OV#-G4VV#+G3VV#; 6000 N ! + FUNCTION G4OV 298.15 +GUO2#; 6000 N ! + FUNCTION G5OV 298.15 +GUO25#-.5*GHSEROO#+.69315*R#*T; 6000 N ! + FUNCTION G3VV 298.15 +GUO15#-1.5*GHSEROO#+1.12467*R#*T; 6000 N ! + FUNCTION G4VV 298.15 +G4OV#-2*GHSEROO#+545210.5; 6000 N ! + FUNCTION G5VV 298.15 +G5OV#-2*GHSEROO#+700000; 6000 N ! + FUNCTION GU3O8 298.15 -3674804.49+1600.50059*T + -276.747749*T*LN(T)-.0136644165*T**2+2036667.44*T**(-1); 2000 N ! + FUNCTION GU4O9 298.15 -4621329.3+1786.83274*T-311.20912*T*LN(T) + -.0311301013*T**2+1741269.49*T**(-1); 2.00000E+03 N ! + FUNCTION GUO15 298.15 +GUO2#-.5*GHSEROO#+747127-70.22618*T; 6000 N ! + FUNCTION GUO2 298.15 -1118940.2+554.00559*T-93.268*T*LN(T) + +.0101704254*T**2-2.03335671E-06*T**3+1091073.7*T**(-1); 6000 N ! + FUNCTION GUO25 298.15 +GUO2#+.5*GHSEROO#-58351.62+39.67611*T; 6000 N ! + FUNCTION UN_ASS 298.15 0; 300 N ! + + TYPE_DEFINITION % SEQ *! + DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! + DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! + + + PHASE GAS:G % 1 1.0 ! + CONSTITUENT GAS:G :O,O2,O3,U,UO,UO2,UO3 : ! + + PARAMETER G(GAS,O;0) 298.15 +OGAS#+RTLNP#; 6000 N REF174 ! + PARAMETER G(GAS,O2;0) 298.15 +O2GAS#+RTLNP#; 6000 N REF175 ! + PARAMETER G(GAS,O3;0) 298.15 +O3GAS#+RTLNP#; 6000 N REF176 ! + PARAMETER G(GAS,U;0) 298.15 +GASU#+RTLNP#; 6000 N REF160 ! + PARAMETER G(GAS,UO;0) 298.15 +UOGAS#+RTLNP#; 6000 N REF208 ! + PARAMETER G(GAS,UO2;0) 298.15 +UO2GAS#+RTLNP#; 6000 N REF209 ! + PARAMETER G(GAS,UO3;0) 298.15 +UO3GAS#+RTLNP#; 6000 N REF210 ! + + + PHASE IONIC_LIQUID:Y % 2 6 4 ! + CONSTITUENT IONIC_LIQUID:Y :U+4 : O-2,VA,O : ! + + PARAMETER G(IONIC_LIQUID,U+4:O-2;0) 298.15 +2*LOWLIQ#; 2.60000E+03 Y + +2*O2ULIQ#; 6000 N REF425 ! + PARAMETER G(IONIC_LIQUID,U+4:VA;0) 298.15 +GLIQUU#; 6000 N REF10 ! + PARAMETER G(IONIC_LIQUID,O;0) 298.15 +GHSEROO#-2648.9+31.44*T; + 6000 N REF10 ! + PARAMETER G(IONIC_LIQUID,U+4:O-2,VA;0) 298.15 +1773475.9-516*T; + 6000 N REF425 ! + PARAMETER G(IONIC_LIQUID,U+4:O-2,VA;1) 298.15 +46774.9-120.37888*T; + 6000 N REF425 ! + PARAMETER G(IONIC_LIQUID,U+4:O-2,VA;2) 298.15 -500000; 6000 N REF425 ! + PARAMETER G(IONIC_LIQUID,U+4:O-2,O;0) 298.15 -370000; 6000 N REF425 ! + + + TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! + PHASE BCC_A2 %& 2 1 3 ! + CONSTITUENT BCC_A2 :U : O,VA% : ! + + PARAMETER G(BCC_A2,U:O;0) 298.15 +GBCCUU#+GHSEROO#+100000; 6000 N REF70 ! + PARAMETER G(BCC_A2,U:VA;0) 298.15 +GBCCUU#; 6000 N REF10 ! + + + PHASE C1_MO2 % 3 1 2 1 ! + CONSTITUENT C1_MO2 :U+3,U+4%,U+5 : O-2%,VA : O-2,VA% : ! + + PARAMETER G(C1_MO2,U+3:O-2:O-2;0) 298.15 +G3OO#; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+4:O-2:O-2;0) 298.15 +G4OO#; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+5:O-2:O-2;0) 298.15 +G5OO#; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+3:VA:O-2;0) 298.15 100000; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+4:VA:O-2;0) 298.15 100000; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+5:VA:O-2;0) 298.15 100000; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+3:O-2:VA;0) 298.15 +G3OV#; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+4:O-2:VA;0) 298.15 +G4OV#; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+5:O-2:VA;0) 298.15 +G5OV#; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+3:VA:VA;0) 298.15 +G3VV#; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+4:VA:VA;0) 298.15 +G4VV#; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+5:VA:VA;0) 298.15 +G5VV#; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+4,U+5:O-2:O-2;0) 298.15 -124936.9-21.6838*T; + 6000 N REF425 ! + PARAMETER G(C1_MO2,U+3,U+4:O-2:VA;0) 298.15 40133.7; 6000 N REF425 ! + PARAMETER G(C1_MO2,U+3,U+4:O-2:VA;1) 298.15 1076.4; 6000 N REF425 ! + + + TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! + PHASE FCC_A1 %' 2 1 1 ! + CONSTITUENT FCC_A1 :U : O,VA : ! + + PARAMETER G(FCC_A1,U:O;0) 298.15 -504526+100*T+GHSEROO#+GHSERUU#; + 6000 N REF0 ! + PARAMETER G(FCC_A1,U:VA;0) 298.15 +GFCCUU#; 3.00000E+03 N REF10 ! + + + PHASE ORTHORHOMBIC_A20 % 1 1.0 ! + CONSTITUENT ORTHORHOMBIC_A20 :U% : ! + + PARAMETER G(ORTHORHOMBIC_A20,U;0) 298.15 +GHSERUU#; 4.00000E+03 N REF10 ! + + + PHASE TETRAGONAL_U % 1 1.0 ! + CONSTITUENT TETRAGONAL_U :U% : ! + + PARAMETER G(TETRAGONAL_U,U;0) 298.15 +GTETUU#; 3.00000E+03 N REF10 ! + + + PHASE U3O8_S % 2 8 3 ! + CONSTITUENT U3O8_S :O : U : ! + + PARAMETER G(U3O8_S,O:U;0) 298.15 +GU3O8#; 6000 N REF425 ! + + + PHASE U3O8_S2 % 2 8 3 ! + CONSTITUENT U3O8_S2 :O : U : ! + + PARAMETER G(U3O8_S2,O:U;0) 298.15 +GU3O8#+135-.279503106*T; 6000 N REF212 ! + + + PHASE U3O8_S3 % 2 8 3 ! + CONSTITUENT U3O8_S3 :O : U : ! + + PARAMETER G(U3O8_S3,O:U;0) 298.15 +GU3O8#+283-.540066486*T; 6000 N REF212 ! + + + PHASE U3O8_S4 % 2 8 3 ! + CONSTITUENT U3O8_S4 :O : U : ! + + PARAMETER G(U3O8_S4,O:U;0) 298.15 +GU3O8#+597-.918379739*T; 6000 N REF212 ! + + + PHASE U4O9_S % 2 9 4 ! + CONSTITUENT U4O9_S :O : U : ! + + PARAMETER G(U4O9_S,O:U;0) 298.15 +GU4O9#; 6000 N REF425 ! + + + PHASE U4O9_S2 % 2 9 4 ! + CONSTITUENT U4O9_S2 :O : U : ! + + PARAMETER G(U4O9_S2,O:U;0) 298.15 +GU4O9#+2594-7.45402299*T; 6000 N REF213 ! + + + PHASE U4O9_S3 % 2 9 4 ! + CONSTITUENT U4O9_S3 :O : U : ! + + PARAMETER G(U4O9_S3,O:U;0) 298.15 +GU4O9#+2684.25-7.5602*T; 6000 N REF213 ! + + + PHASE UO3 % 2 3 1 ! + CONSTITUENT UO3 :O : U : ! + + PARAMETER G(UO3,O:U;0) 298.15 -1260394.62+616.475675*T + -105.7368*T*LN(T)+.0104274*T**2-3.18099167E-06*T**3+868736*T**(-1); + 3.00000E+03 N REF211 ! + + + LIST_OF_REFERENCES + NUMBER SOURCE + REF174 'O1 JANAF 1982; ASSESSMENT DATED 3/77 SGTE OXYGEN , from SSUB' + REF175 'O2 T.C.R.A.S. Class: 1 OXYGEN , from SSUB' + REF176 'O3 T.C.R.A.S. Class: 4 OZONE , from SSUB' + REF10 'A T Dinsdale, SGTE Data for Pure Elements, Calphad 15(1991)4 p + 317-425; also in NPL Report DMA(A)195 Rev. August 1990' + REF160 'U1 T.C.R.A.S Class: 4 Data provided by T.C.R.A.S. in 2000, + from SSUB' + REF208 'O1U1 T.C.R.A.S Class: 6 Data provided by T.C.R.A.S. in 2000, + from SSUB, different of Tbase' + REF209 'O2U1 T.C.R.A.S. Class: 6 URANIUM DIOXIDE , from SSUB, + slightly different of Tbase' + REF210 'O3U1 T.C.R.A.S Class: 6 Data provided by T.C.R.A.S. in 2000, + from SSUB, different of Tbase' + REF425 'C. Guéneau, N. Dupin, B. Sundman, C. Martial, J.-C. Dumas, S. + Gossé,2 S. Chatain, F. De Bruycker, D. Manara, R.J.M. Konings, J. + Nucl. Mat. 419 (1-3), 145-167 (2011); C-O-Pu-U' + REF70 'fixing some parameters of low importance' + REF211 'O3U1 T.C.R.A.S. Class: 7 URANIUM TRIOXIDE, from SSUB' + REF212 'SSUB 3-URANIUM 8-OXIDE : M.H.Rand March 1994, taken from + Cordfunke. In the fuelbase, the expression relative to the alpha + form has been kept identical to SSUB for the higher temperatures + forms but the alpha form expression has been modified in 11GUE' + REF213 'SSUB 4-URANIUM 9-OXIDE : M.H.Rand March 1994, taken from + Cordfunke. In the fuelbase, the expression relative to the alpha + form has been kept identical to SSUB for beta and to 08GUE for + gamma but the alpha form expression has been modified in 11GUE' + ! + diff --git a/macros/ocv3/agcu.TDB b/macros/ocv3/agcu.TDB new file mode 100644 index 0000000..5189058 --- /dev/null +++ b/macros/ocv3/agcu.TDB @@ -0,0 +1,72 @@ +$ Database file written 2014- 2-22 +$ From database: SSOL2 + ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT AG FCC_A1 1.0787E+02 5.7446E+03 4.2551E+01! + ELEMENT CU FCC_A1 6.3546E+01 5.0041E+03 3.3150E+01! + + + FUNCTION GHSERAG 298.15 -7209.512+118.200733*T-23.8463314*T*LN(T) + -.001790585*T**2-3.98587E-07*T**3-12011*T**(-1); 1.23508E+03 Y + -15095.314+190.265169*T-33.472*T*LN(T)+1.412186E+29*T**(-9); 3000 N ! + FUNCTION GHSERCU 298.15 -7770.458+130.485403*T-24.112392*T*LN(T) + -.00265684*T**2+1.29223E-07*T**3+52478*T**(-1); 1.35802E+03 Y + -13542.33+183.804197*T-31.38*T*LN(T)+3.64643E+29*T**(-9); 3200 N ! + FUNCTION UN_ASS 298.15 0; 300 N ! + + TYPE_DEFINITION % SEQ *! + DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! + DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! + + + PHASE LIQUID:L % 1 1.0 ! + CONSTITUENT LIQUID:L :AG,CU : ! + + PARAMETER G(LIQUID,AG;0) 298.15 +11025.293-8.890146*T + -1.0322E-20*T**7+GHSERAG#; 1.23508E+03 Y + +11507.972-9.300495*T-1.412186E+29*T**(-9)+GHSERAG#; 3000 N REF283 ! + PARAMETER G(LIQUID,CU;0) 298.15 +12964.84-9.510243*T + -5.83932E-21*T**7+GHSERCU#; 1.35802E+03 Y + +13495.4-9.920463*T-3.64643E+29*T**(-9)+GHSERCU#; 3.20000E+03 N REF283 ! + PARAMETER G(LIQUID,AG,CU;0) 298.15 +17534.6-4.45479*T; 6000 N REF137 ! + PARAMETER G(LIQUID,AG,CU;1) 298.15 +2251.3-2.6733*T; 6000 N REF137 ! + PARAMETER G(LIQUID,AG,CU;2) 298.15 492.7; 6000 N REF137 ! + + + TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! + PHASE BCC_A2 %& 2 1 3 ! + CONSTITUENT BCC_A2 :AG,CU : VA% : ! + + PARAMETER G(BCC_A2,AG:VA;0) 298.15 +3400-1.05*T+GHSERAG#; 3000 N REF283 ! + PARAMETER G(BCC_A2,CU:VA;0) 298.15 +4017-1.255*T+GHSERCU#; 3200 N REF283 ! + PARAMETER G(BCC_A2,AG,CU:VA;0) 298.15 +35000-8*T; 6000 N REF135 ! + + + TYPE_DEFINITION ' GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! + PHASE FCC_A1 %' 2 1 1 ! + CONSTITUENT FCC_A1 :AG%,CU% : VA% : ! + + PARAMETER G(FCC_A1,AG:VA;0) 298.15 +GHSERAG#; 3.00000E+03 N REF283 ! + PARAMETER G(FCC_A1,CU:VA;0) 298.15 +GHSERCU#; 3.20000E+03 N REF283 ! + PARAMETER G(FCC_A1,AG,CU:VA;0) 298.15 +33819.1-8.1236*T; 6000 N REF137 ! + PARAMETER G(FCC_A1,AG,CU:VA;1) 298.15 -5601.9+1.32997*T; 6000 N REF137 ! + + + TYPE_DEFINITION ( GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 ! + PHASE HCP_A3 %( 2 1 .5 ! + CONSTITUENT HCP_A3 :AG,CU : VA% : ! + + PARAMETER G(HCP_A3,AG:VA;0) 298.15 +300+.3*T+GHSERAG#; 3000 N REF283 ! + PARAMETER G(HCP_A3,CU:VA;0) 298.15 +600+.2*T+GHSERCU#; 3200 N REF283 ! + PARAMETER G(HCP_A3,AG,CU:VA;0) 298.15 +35000-8*T; 6000 N REF135 ! + + LIST_OF_REFERENCES + NUMBER SOURCE + REF283 'Alan Dinsdale, SGTE Data for Pure Elements, + Calphad Vol 15(1991) p 317-425, + also in NPL Report DMA(A)195 Rev. August 1990' + REF137 'F.H. Hayes, H.L. Lukas, G. Effenberg, G. Petzow,' + Z. fur Metallkde, Vol 77 (1986), No 11, p 749-754; AG-CU-PB' + REF135 'Unassessed parameter, inserted to make this phase less stable.' + ! + diff --git a/macros/ocv3/all.OCM b/macros/ocv3/all.OCM new file mode 100644 index 0000000..a50b28f --- /dev/null +++ b/macros/ocv3/all.OCM @@ -0,0 +1,130 @@ +@$ running all test macros +set echo + +mac unary + +@$ ********************************************************* +@& ********************************************************* + +new Y +mac melting + +@$ ********************************************************* +@& ********************************************************* + +new Y +mac step1 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac step2 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac step3 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac step4 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac step5 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac step6 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac step7 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac map1 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac map2 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac map3 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac map4 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac map5 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac map6 + +@$ ********************************************************* +@& ********************************************************* + + +new Y +mac map8 + +@$ ********************************************************* +@& ********************************************************* + +new Y +mac map9 + +@$ ********************************************************* +@& ********************************************************* + +@& ********************************************************* + +new Y +mac map7 + +@$ ********************************************************* +@& ********************************************************* + + +@$ that is all + +set inter + diff --git a/macros/ocv3/hogas.TDB b/macros/ocv3/hogas.TDB new file mode 100644 index 0000000..d0614c8 --- /dev/null +++ b/macros/ocv3/hogas.TDB @@ -0,0 +1,142 @@ + +$ Database file written 2012- 5-31 +$ From database: USER + ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT H 1/2_MOLE_H2(GAS) 1.0079E+00 4.2340E+03 6.5285E+01! + ELEMENT O 1/2_MOLE_O2(GAS) 1.5999E+01 4.3410E+03 1.0252E+02! + + SPECIES H1O1 H1O1! + SPECIES H1O2 H1O2! + SPECIES H2 H2! + SPECIES H2O1 H2O1! + SPECIES H2O2 H2O2! + SPECIES O2 O2! + SPECIES O3 O3! + + FUNCTION F10447T 2.98150E+02 +211801.621+24.4989816*T-20.78611*T*LN(T); + 6.00000E+03 N ! + FUNCTION F10666T 2.98150E+02 +30698.6898+15.9096451*T-29.97699*T*LN(T) + +.001713168*T**2-6.799205E-07*T**3-25503.82*T**(-1); 1.00000E+03 Y + +31735.5127-12.686636*T-25.42186*T*LN(T)-.003149545*T**2 + +1.34404917E-07*T**3+116618.65*T**(-1); 3.00000E+03 Y + +41016.0783-20.7343256*T-24.94216*T*LN(T)-.0023107985*T**2 + +5.91863E-08*T**3-6415210*T**(-1); 8.60000E+03 Y + -154907.953+370.326117*T-69.24542*T*LN(T)+.0019361405*T**2 + -1.47539017E-08*T**3+1.4391015E+08*T**(-1); 1.80000E+04 Y + +326722.277-65.0792741*T-24.2768*T*LN(T)+6.42189E-05*T**2 + -1.30298483E-10*T**3-8.292415E+08*T**(-1); 2.00000E+04 N ! + FUNCTION F10729T 2.98150E+02 +1075.64106-55.242048*T-24.45435*T*LN(T) + -.018507875*T**2+2.36297E-06*T**3-29469.05*T**(-1); 8.00000E+02 Y + -7932.99164+54.2016233*T-40.775*T*LN(T)-.00501027*T**2 + +2.122915E-07*T**3+925845*T**(-1); 3.60000E+03 Y + -67875.8961+275.406716*T-68.1173*T*LN(T)+6.12331E-04*T**2 + -6.573855E-09*T**3+26048030*T**(-1); 6.00000E+03 N ! + FUNCTION F10854T 2.98150E+02 -9522.97393+78.5273873*T-31.35707*T*LN(T) + +.0027589925*T**2-7.46390667E-07*T**3+56582.3*T**(-1); 1.00000E+03 Y + +180.10884-15.6128262*T-17.84857*T*LN(T)-.00584168*T**2 + +3.14618667E-07*T**3-1280036*T**(-1); 2.10000E+03 Y + -18840.1661+92.3120249*T-32.05082*T*LN(T)-.0010728235*T**2 + +1.14281783E-08*T**3+3561002.5*T**(-1); 6.00000E+03 N ! + FUNCTION F10963T 2.98150E+02 -250423.434+4.45470312*T-28.40916*T*LN(T) + -.00623741*T**2-6.01526167E-08*T**3-64163.45*T**(-1); 1.10000E+03 Y + -256145.879+30.1894682*T-31.43044*T*LN(T)-.007055445*T**2 + +3.05535833E-07*T**3+1246309.5*T**(-1); 2.80000E+03 Y + -268423.418+116.690197*T-42.96842*T*LN(T)-.003069987*T**2 + +6.97594167E-08*T**3+2458230.5*T**(-1); 8.40000E+03 Y + -489068.882+553.259882*T-92.4077*T*LN(T)+.0016703495*T**2 + -1.32333233E-08*T**3+1.765625E+08*T**(-1); 1.80000E+04 Y + -165728.771+239.645643*T-59.77872*T*LN(T)+2.213599E-04*T**2 + -1.2921095E-09*T**3-4.1931655E+08*T**(-1); 2.00000E+04 N ! + FUNCTION F10983T 2.98150E+02 -147258.971-37.1497212*T-26.10636*T*LN(T) + -.036948065*T**2+6.659505E-06*T**3+65357.65*T**(-1); 7.00000E+02 Y + -156470.505+120.191295*T-50.94271*T*LN(T)-.007931945*T**2 + +4.29733833E-07*T**3+684985.5*T**(-1); 1.50000E+03 N ! + FUNCTION F13469T 2.98150E+02 +243206.494-20.8612587*T-21.01555*T*LN(T) + +1.2687055E-04*T**2-1.23131283E-08*T**3-42897.09*T**(-1); 2.95000E+03 + Y + +252301.423-52.0847285*T-17.21188*T*LN(T)-5.413565E-04*T**2 + +7.64520667E-09*T**3-3973170.5*T**(-1); 6.00000E+03 N ! + FUNCTION F13839T 2.98150E+02 -6960.69252-51.1831473*T-22.25862*T*LN(T) + -.01023867*T**2+1.339947E-06*T**3-76749.55*T**(-1); 9.00000E+02 Y + -13136.0172+24.743296*T-33.55726*T*LN(T)-.0012348985*T**2 + +1.66943333E-08*T**3+539886*T**(-1); 3.70000E+03 Y + +14154.6461-51.4854586*T-24.47978*T*LN(T)-.002634759*T**2 + +6.01544333E-08*T**3-15120935*T**(-1); 9.60000E+03 Y + -314316.628+515.068037*T-87.56143*T*LN(T)+.0025787245*T**2 + -1.878765E-08*T**3+2.9052515E+08*T**(-1); 1.85000E+04 Y + -108797.175+288.483019*T-63.737*T*LN(T)+.0014375*T**2-9E-09*T**3 + +.25153895*T**(-1); 2.00000E+04 N ! + FUNCTION F14145T 2.98150E+02 +130696.944-37.9096651*T-27.58118*T*LN(T) + -.02763076*T**2+4.60539333E-06*T**3+99530.45*T**(-1); 7.00000E+02 Y + +114760.623+176.626736*T-60.10286*T*LN(T)+.00206456*T**2 + -5.17486667E-07*T**3+1572175*T**(-1); 1.30000E+03 Y + +49468.3958+710.094819*T-134.3696*T*LN(T)+.039707355*T**2 + -4.10457667E-06*T**3+12362250*T**(-1); 2.10000E+03 Y + +866367.075-3566.80563*T+421.2001*T*LN(T)-.1284109*T**2 + +5.44768833E-06*T**3-2.1304835E+08*T**(-1); 2.80000E+03 Y + +409416.384-1950.70834*T+223.4437*T*LN(T)-.0922361*T**2 + +4.306855E-06*T**3-21589870*T**(-1); 3.50000E+03 Y + -1866338.6+6101.13383*T-764.8435*T*LN(T)+.09852775*T**2 + -2.59784667E-06*T**3+9.610855E+08*T**(-1); 4.90000E+03 Y + +97590.0432+890.79836*T-149.9608*T*LN(T)+.01283575*T**2 + -3.555105E-07*T**3-2.1699975E+08*T**(-1); 6.00000E+03 N ! + FUNCTION F10952T 2.98150E+02 -332319.671+1078.59563*T-186.8669*T*LN(T) + +.2320948*T**2-9.14296167E-05*T**3+978019*T**(-1); 5.00000E+02 Y + -62418.8788-3288.18729*T+495.1304*T*LN(T)-.504926*T**2 + +4.917665E-05*T**3-18523425*T**(-1); 5.40000E+02 Y + -8528143.9+142414.45*T-22596.19*T*LN(T)+27.48508*T**2 + -.00631160667*T**3+5.63356E+08*T**(-1); 6.00000E+02 Y + -331037.282+741.178604*T-117.41*T*LN(T); 6.01000E+02 N ! + FUNCTION F10981T 2.98150E+02 -214494.862+488.664597*T-89.3284*T*LN(T); + 1.50000E+03 N ! + FUNCTION UN_ASS 298.15 0; 300 N ! + + TYPE_DEFINITION % SEQ *! + DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! + DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! + + + PHASE GAS:G % 1 1.0 ! + CONSTITUENT GAS:G :H,H2,H2O1,O,O2,O3 : ! +$ CONSTITUENT GAS:G :H,H1O1,H1O2,H2,H2O1,H2O2,O,O2,O3 : ! + + PARAMETER G(GAS,H;0) 2.98150E+02 +F10447T#+R#*T*LN(1E-05*P); + 6.00000E+03 N REF86 ! + PARAMETER G(GAS,H1O1;0) 2.98150E+02 +F10666T#+R#*T*LN(1E-05*P); + 6.00000E+03 N REF93 ! + PARAMETER G(GAS,H1O2;0) 2.98150E+02 +F10729T#+R#*T*LN(1E-05*P); + 6.00000E+03 N REF94 ! + PARAMETER G(GAS,H2;0) 2.98150E+02 +F10854T#+R#*T*LN(1E-05*P); + 6.00000E+03 N REF95 ! + PARAMETER G(GAS,H2O1;0) 2.98150E+02 +F10963T#+R#*T*LN(1E-05*P); + 6.00000E+03 N REF101 ! + PARAMETER G(GAS,H2O2;0) 2.98150E+02 +F10983T#+R#*T*LN(1E-05*P); + 6.00000E+03 N REF102 ! + PARAMETER G(GAS,O;0) 2.98150E+02 +F13469T#+R#*T*LN(1E-05*P); + 6.00000E+03 N REF116 ! + PARAMETER G(GAS,O2;0) 2.98150E+02 +F13839T#+R#*T*LN(1E-05*P); + 6.00000E+03 N REF117 ! + PARAMETER G(GAS,O3;0) 2.98150E+02 +F14145T#+R#*T*LN(1E-05*P); + 6.00000E+03 N REF118 ! + + + LIST_OF_REFERENCES + NUMBER SOURCE + REF86 'H1 JANAF 1982; ASSESSMENT DATED 3/77 SGTE ** HYDROGEN < + MONATOMIC GAS>' + REF93 'H1O1 T.C.R.A.S. Class: 1' + REF94 'H1O2 T.C.R.A.S. Class: 4' + REF95 'H2 JANAF THERMOCHEMICAL TABLES SGTE ** HYDROGEN STANDARD + STATE FROM CODATA KEY VALUES. CP FROM JANAF PUB. 3/61' + REF101 'H2O1 T.C.R.A.S. Class: 1 WATER ' + REF102 'H2O2 JANAF SECOND EDIT SGTE HYDROGEN PEROXIDE ' + REF116 'O1 JANAF 1982; ASSESSMENT DATED 3/77 SGTE OXYGEN ' + REF117 'O2 T.C.R.A.S. Class: 1 OXYGEN ' + REF118 'O3 T.C.R.A.S. Class: 4 OZONE ' + REF128 'H2O1 T.C.R.A.S. Class: 4 WATER T.C.R.A.S. Class: 4 modified by + atd 12/9/94' + REF129 'H2O2 THERMODATA 01/93 HYDROGEN PEROXIDE 28/01/93' + ! + diff --git a/macros/ocv3/map1.OCM b/macros/ocv3/map1.OCM new file mode 100644 index 0000000..fd3ce7b --- /dev/null +++ b/macros/ocv3/map1.OCM @@ -0,0 +1,61 @@ +@$ Calculate the phase diagram for Ag-Cu +@& + +set echo + +r t agcu + + +set cond t=1000 p=1e5 n=1 x(cu)=.2 + +c e + +l r 1 + +@& + +set ax 1 x(cu) 0 1 ,,, +set ax 2 t 800 1500 10 + +l ax + +l sh + +set ref ag fcc,,,,, +set ref cu fcc,,,,, + +@& + +map + +@& + +plot +x(*,cu) +T +title map 1 fig 1 +render + +plot +x(*,cu) +T +xr +N +0 +0.2 +title map 1 fig 2 + + +plot +T +x(*,cu) +title map 1 fig 3 +render + +plot +ac(cu) +T +title map 1 fig 4 +render + +set inter diff --git a/macros/ocv3/map2.OCM b/macros/ocv3/map2.OCM new file mode 100644 index 0000000..e49344b --- /dev/null +++ b/macros/ocv3/map2.OCM @@ -0,0 +1,51 @@ +@$ Calculate the miscibility gap and liquidus for Cr-Mo +@& + +set echo + +r t steel1 +cr mo + +set cond t=800 p=1e5 n=1 x(mo)=.5 + +c e + +l r 1 + +@& + +set ax 1 x(mo) 0 1 ,, +set ax 2 t 500 3000 25 + +l ax + +l sh + +@& + +map + + +@& + +plot +x(*,cr) +T +title map 2 fig 1 +render + +set cond t=2500 x(mo)=.4 +c e + +map +N + + +plot + + +title map 2 fig 2 + + + +set inter diff --git a/macros/ocv3/map3.OCM b/macros/ocv3/map3.OCM new file mode 100644 index 0000000..b378dc5 --- /dev/null +++ b/macros/ocv3/map3.OCM @@ -0,0 +1,50 @@ +@$ Calculate the stable C-Fe phase diagram +@& + +set echo + +r t steel1 +fe c + + +set cond t=1000 p=1e5 n=1 x(c)=.2 + +c e + +l r 1 + +@& + +set ax 1 x(c) 0 1 ,,, +set ax 2 t 500 2000 25 + +l ax + +l sh + + +@& + +map + + +@& + +plot +x(*,c) +T +title map 3 fig 1 +render + +plot +x(*,c) +T +xr +n +0 +.2 +title map 3 fig 2 +render + + +set inter diff --git a/macros/ocv3/map4.OCM b/macros/ocv3/map4.OCM new file mode 100644 index 0000000..3899e16 --- /dev/null +++ b/macros/ocv3/map4.OCM @@ -0,0 +1,53 @@ +@$ Calculate the phase diagram for O-U +@& + +set echo + +r t ou + + +set c t=3200 p=1e5 n=1 x(o)=.5 + +c e + +l r 2 + +@& + +set ax 1 x(o) 0 1 ,, + +set ax 2 t 500 3500 25 + +map + +plot +x(*,o) +T +title map 4 fig 1 +render + + +set c t=2000 x(o)=.8 + +c e + +map +N + + + +plot + + +title map4 fig 2 +render + +plot + + +position outside right +render + + +set interactive + diff --git a/macros/ocv3/map5.OCM b/macros/ocv3/map5.OCM new file mode 100644 index 0000000..345d784 --- /dev/null +++ b/macros/ocv3/map5.OCM @@ -0,0 +1,93 @@ +@$ Calculate the phase diagram for Fe-Mo +@& + +set echo + +r t steel1 +fe mo + + +amend phase +bcc +comp +Y +FE + +>.5 +<.1 + +amend phase +bcc +def +<.1 +>.5 + + +@& + + +set cond t=2000 p=1e5 n=1 x(mo)=.7 + +c e + +l r 1 + +@& + +set ax 1 x(mo) 0 1 ,, +set ax 2 t 300 3000 25 + +l ax + +l sh + + +@& + +map + + +@& + +plot +x(*,mo) +T +title map5 fig 1 +render + + +@$ we must calculate the gamma loop separately + +set c t=1400 x(mo)=.02 + +c n + +l,,,,, + +@& + +map +N + + +plot +x(*,mo) +T +position bottom right +title map5 fig 2 +render + + + +plot +x(*,mo) +T +yr +N +1600 +1800 +title map5 fig 3 +render + + +set inter diff --git a/macros/ocv3/map6.OCM b/macros/ocv3/map6.OCM new file mode 100644 index 0000000..961e9cc --- /dev/null +++ b/macros/ocv3/map6.OCM @@ -0,0 +1,35 @@ +@$ Calculate an (incomplete) isopleth for Cr-Fe-Ni at 8 mass% Ni +@& + +set echo + +r t saf2507 +cr fe ni + +set c t=2000 p=1e5 w(cr)=.2 w(ni)=.08 n=1 + +c e +l + +4 + +@& + +set ax 1 w(cr) 0 1 ,,, +set ax 2 t 800 2200 25 + + + +map + + +@& + +plot +w(CR) +T +title map 6 fig 1 +render + + + set interactive diff --git a/macros/ocv3/map7.OCM b/macros/ocv3/map7.OCM new file mode 100644 index 0000000..572ea5a --- /dev/null +++ b/macros/ocv3/map7.OCM @@ -0,0 +1,44 @@ +@$ Calculate an (incomplete) isopleth for a HSS +@& + +set echo + +r t steel1 + +@& calculate at 1200 to create two fcc phases + +set c t=1200 p=1e5 n=1 w(c)=.008 w(cr)=.05, w(mo)=.08 w(v)=.01 w(si)=.003 + +c e + +l r 1 + +@& + +set axis 1 w(c) 0 0.02 ,,, +set axis 2 T 800 1800 25 + +l ax + +@& + +map + + + + + +l l + +@& + +l eq + + + +plot,,,,,,,, + + + +set inter + diff --git a/macros/ocv3/map8.OCM b/macros/ocv3/map8.OCM new file mode 100644 index 0000000..f32d093 --- /dev/null +++ b/macros/ocv3/map8.OCM @@ -0,0 +1,154 @@ +@$ +@$ Calculate a phase diagram for FCC ordering in the Fe-Ni system +@$ using partition and permutations +@& + +set echo + +@$ Enter the elements and their reference states +enter element Fe Iron BCC 55.847 0 0 + +enter element Ni Nickel FCC 58.69 0 0 + +@$ These functions describe the end-member energies at Fe3Ni, Fe2Ni2 and FeNi3 +@$ respectivly. The VASP energies relative to pure Fe amd Ni as fcc are: +@$ Fe3Ni1 -0.071689 eV for 1 atom?? +@$ Fe2Ni2 -0.138536 eV for 1 atom?? +@$ Fe1Ni3 -0.125748 eV for 1 atom?? +@$ To modify to J/mol atoms multiply with 96500 +@$ bond energy multiplied with 3, 4 and 3 respectively. + +enter tp-sym evtoj constant 96500 + +enter tp-sym GA3B1 fun 1 -0.071689*evtoj;,,,,, +enter tp-sym GA2B2 fun 1 -0.138536*evtoj;,,,,, +enter tp-sym GA1B3 fun 1 -0.125748*evtoj;,,,,, + +@$ We may have to use some regular solution parameter later +enter tp-sym L0 fun 1 12000; ,,,,, +enter tp-sym L1 fun 1 0; ,,,,, +enter tp-sym L2 fun 1 0; ,,,,, + +@$ this is an approximate SRO contribution to the LRO phase. It is +@$ set to about a quater of the L1_0 ordering energy, +@$ equal to the Fe-Ni bond energy +enter tp-sym GSRO fun 1 -0.034*evtoj;,,,,, + +@$ ================================================== +@$ This is an fcc phase with lro but no explicit sro +@$ described with the sublattice model + +enter phase PARTITIONED_FCC 4 .25 Fe NI; .25 Fe NI; .25 Fe NI; .25 Fe NI; + +@$ we must set that this has FCC permutations before entering parameters +set phase part bit fcc-perm + +@$ we must add disordered set before entering parameters +amend phase part dis 4 yes + +enter param G(part,Fe:Fe:Fe:Ni),,GA3B1; 6000 N test +enter param G(part,Fe:Ni:Ni:Ni),,GA1B3; 6000 N test +enter param G(part,Fe:Fe:Ni:Ni),,GA2B2; 6000 N test + +enter param G(part,Fe,Ni:Fe,Ni:*:*),,GSRO; 6000 N test + +amend biblio test VASP calculation by test; + +@$ These are possible disordered parameters +enter param GD(part,Fe,Ni;0),,L0; 6000 N test +enter param GD(part,Fe,Ni;1),,L1; 6000 N test +enter param GD(part,Fe,Ni;2),,L2; 6000 N test + + +list data ,, + + +@& + +we have to create composition sets manually + +@$ this default constitution is Fe3Ni_L12 +amend phase part comp-set y , , +<.2 >.5 +<.2 >.5 +<.2 >.5 +>.5 <.2 + +@$ this default constitution is FeNi_L10 +amend phase part comp-set y , , +<.2 >.5 +<.2 >.5 +>.5 <.2 +>.5 <.2 + +@$ this default constitution is FeNi3_L12 +amend phase part comp-set y , , +<.2 >.5 +<.2 >.5 +<.2 >.5 +>.5 <.2 + +@$ However, the L12 can have max Ni or Fe on any sublattice, there is no +@$ check that it is always the first or last sublattice with the highest +@$ fraction of the minor element. This should be arranged in todo_after ... + + +set c t=400 p=1e5 n=1 x(ni)=.6 + +c e + +l r 2 + + +@& + +set ax 1 x(ni) 0 1 ,,,, + +@$ we have to take very small T steps +set ax 2 t 10 1000 10 + +map + + + + +@$ just the FeNi/FeNi3 + + +set c x(ni)=.9 + +c e + +map +N + + + + +plot + + +title map 8 fig 1 +render + + +set c t=300 x(ni)=.4 + +c e + +map +N + + + + +plot + + +title map 8 fig 2 +render + +set inter + + + diff --git a/macros/ocv3/map9.OCM b/macros/ocv3/map9.OCM new file mode 100644 index 0000000..fcd2364 --- /dev/null +++ b/macros/ocv3/map9.OCM @@ -0,0 +1,420 @@ +@$ OC macro file for RE-W system, +@$ M Palumbo, S G Fries, T Hammerschmidt et al, +@$ Comp. Mat. Sci, Vol 81 (2014) 439-445; +@& + +set echo + +enter element RE Rhenium HCP 186.21 5355.5 36.526 +enter element W Tungsten BCC 183.85 4970.0 32.62 + +enter tpfun GHSERRE fun 298.15 0;,,,, +enter tpfun GHSERW fun 298.15 0;,,,, +enter tpfun UNASS fun 298.15 0; 300,,,, +enter tpfun ZERO fun 298.15 0; 6000,,,, + +@$ eVtoJ is J/eV per atom, eVtoJ29 the same for 29 atoms etc. +enter tpfun eVtoJ const 96490,,,, +enter tpfun eVtoJ8 fun 298.15 8*eVtoJ;,,,,, +enter tpfun eVtoJ12 fun 298.15 12*eVtoJ;,,,,, +enter tpfun eVtoJ13 fun 298.15 13*eVtoJ;,,,,, +enter tpfun eVtoJ24 fun 298.15 24*eVtoJ;,,,,, +enter tpfun eVtoJ29 fun 298.15 29*eVtoJ;,,,, +enter tpfun eVtoJ30 fun 298.15 30*eVtoJ;,,,,, + +l tp * + +@$--------------- +@& + +enter phase fcc 4 +.25 RE W; +.25 RE W; +.25 RE W; +.25 RE W; + +@$ mark that we have parameter permutations according to fcc tetrahedrons +set phase fcc bit fcc_perm + +ent par G(fcc,RE:RE:RE:RE) 298.15 0.062787*eVtoJ;,,,14Pal fcc.A +ent par G(fcc,W:RE:RE:RE) 298.15 0.11703575*eVtoJ;,,,14Pal L12.A3B +ent par G(fcc,W:W:RE:RE) 298.15 0.2098125*eVtoJ;,,,14Pal L10.AB +ent par G(fcc,W:W:W:RE) 298.15 0.33351125*eVtoJ;,,,14Pal L12.AB3 +ent par G(fcc,W:W:W:W) 298.15 0.474125*eVtoJ;,,,14Pal fcc.B +@$----------- + +list data + +@& + +amend bib 14Pal M Palumbo, S G Fries, T Hammerschmidt et al, +Comp. Mat. Sci, Vol 81 (2014) 439-445; + +list data + +@& + +enter phase bcc 4 .25 RE W; .25 RE W; .25 RE W; .25 RE W; + +@$ the BCC permutations are not yet implemented .... + +ent par G(bcc,RE:RE:RE:RE) 298.15 0.320286*eVtoJ;,,,14Pal bcc.A +ent par G(bcc,W:RE:RE:RE) 298.15 0.21785575*eVtoJ;,,,14Pal D03.A3B +ent par G(bcc,RE:W:RE:RE) 298.15 0.21785575*eVtoJ;,,,14Pal D03.A3B +ent par G(bcc,RE:RE:W:RE) 298.15 0.21785575*eVtoJ;,,,14Pal D03.A3B +ent par G(bcc,RE:RE:RE:W) 298.15 0.21785575*eVtoJ;,,,14Pal D03.A3B +ent par G(bcc,W:RE:W:RE) 298.15 0.1385725*eVtoJ;,,,14Pal B32.AB +ent par G(bcc,RE:W:W:RE) 298.15 0.1385725*eVtoJ;,,,14Pal B32.AB +ent par G(bcc,W:RE:RE:W) 298.15 0.1385725*eVtoJ;,,,14Pal B32.AB +ent par G(bcc,RE:W:RE:W) 298.15 0.1385725*eVtoJ;,,,14Pal B32.AB +ent par G(bcc,W:W:RE:RE) 298.15 0.0971185*eVtoJ;,,,14Pal B2.AB +ent par G(bcc,RE:RE:W:W) 298.15 0.0971185*eVtoJ;,,,14Pal B2.AB +ent par G(bcc,W:W:W:RE) 298.15 0.04742525*eVtoJ;,,,14Pal D03.AB3 +ent par G(bcc,W:W:RE:W) 298.15 0.04742525*eVtoJ;,,,14Pal D03.AB3 +ent par G(bcc,W:RE:W:W) 298.15 0.04742525*eVtoJ;,,,14Pal D03.AB3 +ent par G(bcc,RE:W:W:W) 298.15 0.04742525*eVtoJ;,,,14Pal D03.AB3 +ent par G(bcc,W:W:W:W) 298.15 0*eVtoJ;,,,14Pal bcc.B +@$----------- + +list data + +@& + +list phase bcc data + +@& + +@$------- + +enter phase hcp 4 .25 RE W; .25 RE W; .25 RE W; .25 RE W; +@$ The HCP tetrahedron is the same as FCC +set phase hcp bit fcc_perm + +ent par G(hcp,RE:RE:RE:RE) 298.15 0*eVtoJ;,,,14Pal hcp.A +ent par G(hcp,W:RE:RE:RE) 298.15 0.12874775*eVtoJ;,,,14Pal D0_19.A3B +ent par G(hcp,W:W:RE:RE) 298.15 0.2823905*eVtoJ;,,,14Pal B19.AB +ent par G(hcp,W:W:W:RE) 298.15 0.38047325*eVtoJ;,,,14Pal D0_19.AB3 +ent par G(hcp,W:W:W:W) 298.15 0.490701*eVtoJ;,,,14Pal hcp.B + +list phase hcp data + +@& +@$------- + +ent phase A15 2 2 RE W; 6 RE W; +ent par G(A15,RE:RE) 298.15 0.185144*eVtoJ8;,,,14Pal A15.A +ent par G(A15,RE:W) 298.15 0.19109475*eVtoJ8;,,,14Pal A15.AB +ent par G(A15,W:RE) 298.15 0.02878425*eVtoJ8;,,,14Pal A15.BA +ent par G(A15,W:W) 298.15 0.089645*eVtoJ8;,,,14Pal A15.B + +list phase A15 data + +@& +@$-------- + +ent phase sigma 5 2 RE W; 4 RE W; 8 RE W; 8 RE W; 8 RE W; +ent par G(sigma,RE:RE:RE:RE:RE) 298.15 0.103465*eVtoJ30;,,,14Pal sigma.A +ent par G(sigma,W:RE:RE:RE:RE) 298.15 0.117920533*eVtoJ30;,,,14Pal sigma.BAAAA +ent par G(sigma,RE:W:RE:RE:RE) 298.15 0.074164067*eVtoJ30;,,,14Pal sigma.ABAAA +ent par G(sigma,W:W:RE:RE:RE) 298.15 0.0887456*eVtoJ30;,,,14Pal sigma.BBAAA +ent par G(sigma,RE:RE:RE:RE:W) 298.15 0.075425133*eVtoJ30;,,,14Pal sigma.AAAAB +ent par G(sigma,RE:RE:RE:W:RE) 298.15 0.144846133*eVtoJ30;,,,14Pal sigma.AAABA +ent par G(sigma,RE:RE:W:RE:RE) 298.15 0.062163133*eVtoJ30;,,,14Pal sigma.AABAA +ent par G(sigma,W:RE:RE:RE:W) 298.15 0.096883667*eVtoJ30;,,,14Pal sigma.BAAAB +ent par G(sigma,W:RE:RE:W:RE) 298.15 0.166788667*eVtoJ30;,,,14Pal sigma.BAABA +ent par G(sigma,W:RE:W:RE:RE) 298.15 0.078029667*eVtoJ30;,,,14Pal sigma.BABAA +ent par G(sigma,RE:W:RE:RE:W) 298.15 0.0425622*eVtoJ30;,,,14Pal sigma.ABAAB +ent par G(sigma,RE:W:RE:W:RE) 298.15 0.1150282*eVtoJ30;,,,14Pal sigma.ABABA +ent par G(sigma,RE:W:W:RE:RE) 298.15 0.0432172*eVtoJ30;,,,14Pal sigma.ABBAA +ent par G(sigma,W:W:RE:RE:W) 298.15 0.067439733*eVtoJ30;,,,14Pal sigma.BBAAB +ent par G(sigma,W:W:RE:W:RE) 298.15 0.141463733*eVtoJ30;,,,14Pal sigma.BBABA +ent par G(sigma,W:W:W:RE:RE) 298.15 0.062896733*eVtoJ30;,,,14Pal sigma.BBBAA +ent par G(sigma,RE:RE:RE:W:W) 298.15 0.145899267*eVtoJ30;,,,14Pal sigma.AAABB +ent par G(sigma,RE:RE:W:RE:W) 298.15 0.052479267*eVtoJ30;,,,14Pal sigma.AABAB +ent par G(sigma,RE:RE:W:W:RE) 298.15 0.151518267*eVtoJ30;,,,14Pal sigma.AABBA +ent par G(sigma,W:RE:RE:W:W) 298.15 0.1732738*eVtoJ30;,,,14Pal sigma.BAABB +ent par G(sigma,W:RE:W:RE:W) 298.15 0.0767538*eVtoJ30;,,,14Pal sigma.BABAB +ent par G(sigma,W:RE:W:W:RE) 298.15 0.1743168*eVtoJ30;,,,14Pal sigma.BABBA +ent par G(sigma,RE:W:RE:W:W) 298.15 0.117787333*eVtoJ30;,,,14Pal sigma.ABABB +ent par G(sigma,RE:W:W:RE:W) 298.15 0.031243333*eVtoJ30;,,,14Pal sigma.ABBAB +ent par G(sigma,RE:W:W:W:RE) 298.15 0.135710333*eVtoJ30;,,,14Pal sigma.ABBBA +ent par G(sigma,W:W:RE:W:W) 298.15 0.149161867*eVtoJ30;,,,14Pal sigma.BBABB +ent par G(sigma,W:W:W:RE:W) 298.15 0.059292867*eVtoJ30;,,,14Pal sigma.BBBAB +ent par G(sigma,W:W:W:W:RE) 298.15 0.165621867*eVtoJ30;,,,14Pal sigma.BBBBA +ent par G(sigma,RE:RE:W:W:W) 298.15 0.1662344*eVtoJ30;,,,14Pal sigma.AABBB +ent par G(sigma,W:RE:W:W:W) 298.15 0.192115933*eVtoJ30;,,,14Pal sigma.BABBB +ent par G(sigma,RE:W:W:W:W) 298.15 0.142513467*eVtoJ30;,,,14Pal sigma.ABBBB +ent par G(sigma,W:W:W:W:W) 298.15 0.17298*eVtoJ30;,,,14Pal sigma.B + +list phase sigma data + +@& +@$------------- + +ent phase chi 4 1 RE W; 4 RE W; 12 RE W; 12 RE W; +ent par G(chi,RE:RE:RE:RE) 298.15 0.057085*eVtoJ29;,,,14Pal chi.A +ent par G(chi,W:RE:RE:RE) 298.15 0.044341138*eVtoJ29;,,,14Pal chi.BAAA +ent par G(chi,RE:W:RE:RE) 298.15 0.010266552*eVtoJ29;,,,14Pal chi.ABAA +ent par G(chi,W:W:RE:RE) 298.15 0.00176469*eVtoJ29;,,,14Pal chi.BBAA +ent par G(chi,RE:RE:RE:W) 298.15 0.222213655*eVtoJ29;,,,14Pal chi.AAAB +ent par G(chi,RE:RE:W:RE) 298.15 0.107317655*eVtoJ29;,,,14Pal chi.AABA +ent par G(chi,W:RE:RE:W) 298.15 0.203353793*eVtoJ29;,,,14Pal chi.BAAB +ent par G(chi,W:RE:W:RE) 298.15 0.093724793*eVtoJ29;,,,14Pal chi.BABA +ent par G(chi,RE:W:RE:W) 298.15 0.154246207*eVtoJ29;,,,14Pal chi.ABAB +ent par G(chi,RE:W:W:RE) 298.15 0.065460207*eVtoJ29;,,,14Pal chi.ABBA +ent par G(chi,W:W:RE:W) 298.15 0.138812345*eVtoJ29;,,,14Pal chi.BBAB +ent par G(chi,W:W:W:RE) 298.15 0.059790345*eVtoJ29;,,,14Pal chi.BBBA +ent par G(chi,RE:RE:W:W) 298.15 0.32744331*eVtoJ29;,,,14Pal chi.AABB +ent par G(chi,W:RE:W:W) 298.15 0.312474448*eVtoJ29;,,,14Pal chi.BABB +ent par G(chi,RE:W:W:W) 298.15 0.294603862*eVtoJ29;,,,14Pal chi.ABBB +ent par G(chi,W:W:W:W) 298.15 0.283917*eVtoJ29;,,,14Pal chi.B + +list phase chi data + +@& +@$---------- + +ent phase mu 5 1 RE W; 6 RE W; 2 RE W; 2 RE W; 2 RE W; +ent par G(mu,RE:RE:RE:RE:RE) 298.15 0.213904*eVtoJ13;,,,14Pal mu.A +ent par G(mu,W:RE:RE:RE:RE) 298.15 0.232698923*eVtoJ13;,,,14Pal mu.BAAAA +ent par G(mu,RE:RE:RE:RE:W) 298.15 0.237154846*eVtoJ13;,,,14Pal mu.AAAAB +ent par G(mu,RE:RE:RE:W:RE) 298.15 0.172403846*eVtoJ13;,,,14Pal mu.AAABA +ent par G(mu,RE:RE:W:RE:RE) 298.15 0.166768846*eVtoJ13;,,,14Pal mu.AABAA +ent par G(mu,W:RE:RE:RE:W) 298.15 0.261267769*eVtoJ13;,,,14Pal mu.BAAAB +ent par G(mu,W:RE:RE:W:RE) 298.15 0.187943769*eVtoJ13;,,,14Pal mu.BAABA +ent par G(mu,W:RE:W:RE:RE) 298.15 0.189324769*eVtoJ13;,,,14Pal mu.BABAA +ent par G(mu,RE:RE:RE:W:W) 298.15 0.195145692*eVtoJ13;,,,14Pal mu.AAABB +ent par G(mu,RE:RE:W:RE:W) 298.15 0.193476692*eVtoJ13;,,,14Pal mu.AABAB +ent par G(mu,RE:RE:W:W:RE) 298.15 0.136986692*eVtoJ13;,,,14Pal mu.AABBA +ent par G(mu,W:RE:RE:W:W) 298.15 0.216702615*eVtoJ13;,,,14Pal mu.BAABB +ent par G(mu,W:RE:W:RE:W) 298.15 0.216780615*eVtoJ13;,,,14Pal mu.BABAB +ent par G(mu,W:RE:W:W:RE) 298.15 0.156615615*eVtoJ13;,,,14Pal mu.BABBA +ent par G(mu,RE:RE:W:W:W) 298.15 0.157312538*eVtoJ13;,,,14Pal mu.AABBB +ent par G(mu,RE:W:RE:RE:RE) 298.15 0.340443538*eVtoJ13;,,,14Pal mu.ABAAA +ent par G(mu,W:RE:W:W:W) 298.15 0.174036462*eVtoJ13;,,,14Pal mu.BABBB +ent par G(mu,W:W:RE:RE:RE) 298.15 0.369531462*eVtoJ13;,,,14Pal mu.BBAAA +ent par G(mu,RE:W:RE:RE:W) 298.15 0.385507385*eVtoJ13;,,,14Pal mu.ABAAB +ent par G(mu,RE:W:RE:W:RE) 298.15 0.294760385*eVtoJ13;,,,14Pal mu.ABABA +ent par G(mu,RE:W:W:RE:RE) 298.15 0.314514385*eVtoJ13;,,,14Pal mu.ABBAA +ent par G(mu,W:W:RE:RE:W) 298.15 0.421966308*eVtoJ13;,,,14Pal mu.BBAAB +ent par G(mu,W:W:RE:W:RE) 298.15 0.326644308*eVtoJ13;,,,14Pal mu.BBABA +ent par G(mu,W:W:W:RE:RE) 298.15 0.344868308*eVtoJ13;,,,14Pal mu.BBBAA +ent par G(mu,RE:W:RE:W:W) 298.15 0.346191231*eVtoJ13;,,,14Pal mu.ABABB +ent par G(mu,RE:W:W:RE:W) 298.15 0.355482231*eVtoJ13;,,,14Pal mu.ABBAB +ent par G(mu,RE:W:W:W:RE) 298.15 0.276514231*eVtoJ13;,,,14Pal mu.ABBBA +ent par G(mu,W:W:RE:W:W) 298.15 0.381076154*eVtoJ13;,,,14Pal mu.BBABB +ent par G(mu,W:W:W:RE:W) 298.15 0.393287154*eVtoJ13;,,,14Pal mu.BBBAB +ent par G(mu,W:W:W:W:RE) 298.15 0.310854154*eVtoJ13;,,,14Pal mu.BBBBA +ent par G(mu,RE:W:W:W:W) 298.15 0.320410077*eVtoJ13;,,,14Pal mu.ABBBB +ent par G(mu,W:W:W:W:W) 298.15 0.356369*eVtoJ13;,,,14Pal mu.B + +list phase mu data + +@& +@$-------- + +ent phase C14 3 2 RE W; 6 RE W; 4 RE W; +ent par G(C14,RE:RE:RE) 298.15 0.286726*eVtoJ12;,,,14Pal C14.A +ent par G(C14,RE:W:RE) 298.15 0.331349833*eVtoJ12;,,,14Pal C14.ABA +ent par G(C14,W:RE:RE) 298.15 0.203029667*eVtoJ12;,,,14Pal C14.BAA +ent par G(C14,RE:RE:W) 298.15 0.4255515*eVtoJ12;,,,14Pal C14.AAB +ent par G(C14,W:W:RE) 298.15 0.2850135*eVtoJ12;,,,14Pal C14.BBA +ent par G(C14,RE:W:W) 298.15 0.527325333*eVtoJ12;,,,14Pal C14.ABB +ent par G(C14,W:RE:W) 298.15 0.380295167*eVtoJ12;,,,14Pal C14.BAB +ent par G(C14,W:W:W) 298.15 0.459543*eVtoJ12;,,,14Pal C14.B + +list phase C14 data + +@& + +@$----------- + +ent phase C15 2 8 RE W; 16 RE W; +ent par G(C15,RE:RE) 298.15 0.345061*eVtoJ24;,,,14Pal C15.A +ent par G(C15,W:RE) 298.15 0.250001667*eVtoJ24;,,,14Pal C15.A2B +ent par G(C15,RE:W) 298.15 0.491933333*eVtoJ24;,,,14Pal C15.AB2 +ent par G(C15,W:W) 298.15 0.454032*eVtoJ24;,,,14Pal C15.B + +list phase C15 data + +@& + +@$---------- + +ent phase C36 5 4 RE W; 4 RE W; 4 RE W; 6 RE W; 6 RE W; +ent par G(C36,RE:RE:RE:RE:RE) 298.15 0.31195*eVtoJ24;,,,14Pal C36.A +ent par G(C36,RE:RE:W:RE:RE) 298.15 0.337458833*eVtoJ24;,,,14Pal C36.AABAA +ent par G(C36,RE:W:RE:RE:RE) 298.15 0.250287833*eVtoJ24;,,,14Pal C36.ABAAA +ent par G(C36,W:RE:RE:RE:RE) 298.15 0.247355833*eVtoJ24;,,,14Pal C36.BAAAA +ent par G(C36,RE:RE:RE:RE:W) 298.15 0.37904175*eVtoJ24;,,,14Pal C36.AAAAB +ent par G(C36,RE:RE:RE:W:RE) 298.15 0.34407575*eVtoJ24;,,,14Pal C36.AAABA +ent par G(C36,RE:W:W:RE:RE) 298.15 0.315368667*eVtoJ24;,,,14Pal C36.ABBAA +ent par G(C36,W:RE:W:RE:RE) 298.15 0.305384667*eVtoJ24;,,,14Pal C36.BABAA +ent par G(C36,W:W:RE:RE:RE) 298.15 0.224973667*eVtoJ24;,,,14Pal C36.BBAAA +ent par G(C36,RE:RE:W:RE:W) 298.15 0.442608583*eVtoJ24;,,,14Pal C36.AABAB +ent par G(C36,RE:RE:W:W:RE) 298.15 0.410960583*eVtoJ24;,,,14Pal C36.AABBA +ent par G(C36,RE:W:RE:RE:W) 298.15 0.353971583*eVtoJ24;,,,14Pal C36.ABAAB +ent par G(C36,RE:W:RE:W:RE) 298.15 0.321842583*eVtoJ24;,,,14Pal C36.ABABA +ent par G(C36,W:RE:RE:RE:W) 298.15 0.346623583*eVtoJ24;,,,14Pal C36.BAAAB +ent par G(C36,W:RE:RE:W:RE) 298.15 0.315309583*eVtoJ24;,,,14Pal C36.BAABA +ent par G(C36,RE:RE:RE:W:W) 298.15 0.4229085*eVtoJ24;,,,14Pal C36.AAABB +ent par G(C36,W:W:W:RE:RE) 298.15 0.2877075*eVtoJ24;,,,14Pal C36.BBBAA +ent par G(C36,RE:W:W:RE:W) 298.15 0.415114417*eVtoJ24;,,,14Pal C36.ABBAB +ent par G(C36,RE:W:W:W:RE) 298.15 0.397507417*eVtoJ24;,,,14Pal C36.ABBBA +ent par G(C36,W:RE:W:W:RE) 298.15 0.380724417*eVtoJ24;,,,14Pal C36.BABBA +ent par G(C36,W:W:RE:RE:W) 298.15 0.328912417*eVtoJ24;,,,14Pal C36.BBAAB +ent par G(C36,W:W:RE:W:RE) 298.15 0.295539417*eVtoJ24;,,,14Pal C36.BBABA +ent par G(C36,RE:RE:W:W:W) 298.15 0.506832333*eVtoJ24;,,,14Pal C36.AABBB +ent par G(C36,RE:W:RE:W:W) 298.15 0.416418333*eVtoJ24;,,,14Pal C36.ABABB +ent par G(C36,W:RE:RE:W:W) 298.15 0.403344333*eVtoJ24;,,,14Pal C36.BAABB +ent par G(C36,W:RE:W:RE:W) 298.15 0.403344333*eVtoJ24;,,,14Pal C36.BABAB +ent par G(C36,W:W:W:RE:W) 298.15 0.38162625*eVtoJ24;,,,14Pal C36.BBBAB +ent par G(C36,W:W:W:W:RE) 298.15 0.36110925*eVtoJ24;,,,14Pal C36.BBBBA +ent par G(C36,RE:W:W:W:W) 298.15 0.496471167*eVtoJ24;,,,14Pal C36.ABBBB +ent par G(C36,W:RE:W:W:W) 298.15 0.481127167*eVtoJ24;,,,14Pal C36.BABBB +ent par G(C36,W:W:RE:W:W) 298.15 0.382497167*eVtoJ24;,,,14Pal C36.BBABB +ent par G(C36,W:W:W:W:W) 298.15 0.459342*eVtoJ24;,,,14Pal C36.B + +list phase C36 data + +@& + +list short + +@& +@$--------- + +@$ Calculate the stable phase diagram + +set c t=1000 p=1e5 n=1 x(w)=.3 + +c e + +l r + + +@& + +l r 2 + +@& + +set ax 1 x(w) 0 1 .025 + +set ax 2 T 100 6000 25 + +map + +plot + + +title map 9 fig 1 +render + +@& + +@$ Calculate speciation in sigma across the whole diagram at 1000 K + +set ax +2 +none + +list ax + +@& + +set stat phase *=sus + +set stat phase sigma=ent 1 + +l short + +@& + +@$ conditions not restored after map +l c +set c x(w)=.3 + + +@$ avoid using grid minimizer as that creates two composition sets +c n + +l,,,, + +@& + +@$ when using step delete previous map results +step +Y + +plot +x(w) +y(sigma,*) +title map 9 fig 2 +render + +@$ also plot the Gibbs energy, enthalpy and heat capacity + +plot +x(w) +gm +title map 9 fig 3 +render + +plot +x(w) +hm +position off +title map 9 fig 4 + +enter symbol +cp +hm.t; + + +plot +x(w) +cp +title map 9 fig 5 +render + +@$ finally calculate the Gibbs energy curves for all phases at 3000 K + +set stat ph *=ent 0 + +c e + +step +Y +sep + + +plot +x(w) +gm(*) +position outside right +title map 9 fig 6 +render + +plot +x(w) +hm(*) +title map 9 fig 7 +render + + +@$ Finally calculate the Gibbs energy of an endmember + +c p +sigma +1 +n +1 +0 +1 +0 +1 +only + +set inter + diff --git a/macros/ocv3/melting.OCM b/macros/ocv3/melting.OCM new file mode 100644 index 0000000..0bfa576 --- /dev/null +++ b/macros/ocv3/melting.OCM @@ -0,0 +1,24 @@ +@$ Calculating a multicomponent single equilibrium +@$ Including the melting point of the alloy +@& + +set echo + +r t steel1 + +set c t=1200 p=1e5 n=1 x(c)=.01 x(cr)=.05, x(mo)=.05 x(si)=.003 x(v)=.01 + +c e + +l ,,,, + +@& + +c tran +liq +1 + +list,,,,, + +set inter + diff --git a/macros/ocv3/saf2507.TDB b/macros/ocv3/saf2507.TDB new file mode 100644 index 0000000..468a7d4 --- /dev/null +++ b/macros/ocv3/saf2507.TDB @@ -0,0 +1,1066 @@ + +$ Database file written 2014-10- 1 +$ From database: SSOL2 + ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01! + ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! + ELEMENT MN CBCC_A12 5.4938E+01 4.9960E+03 3.2008E+01! + ELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01! + ELEMENT N 1/2_MOLE_N2(G) 1.4007E+01 4.3350E+03 9.5751E+01! + ELEMENT NI FCC_A1 5.8690E+01 4.7870E+03 2.9796E+01! + + SPECIES N2 N2! + + FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) + +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y + -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N ! + FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N ! + FUNCTION GFELIQ 2.98150E+02 +12040.17-6.55843*T-3.6751551E-21*T**7 + +GHSERFE#; 1.81100E+03 Y + -10839.7+291.302*T-46*T*LN(T); 6.00000E+03 N ! + FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N ! + FUNCTION GHSERMN 2.98150E+02 -8115.28+130.059*T-23.4582*T*LN(T) + -.00734768*T**2+69827*T**(-1); 1.51900E+03 Y + -28733.41+312.2648*T-48*T*LN(T)+1.656847E+30*T**(-9); 2.00000E+03 N ! + FUNCTION GHSERMO 2.98150E+02 -7746.302+131.9197*T-23.56414*T*LN(T) + -.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4; + 2.89600E+03 Y + -30556.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9); + 5.00000E+03 N ! + FUNCTION GPMOLIQ 2.98150E+02 +YMOLIQ#*EXP(ZMOLIQ#); 6.00000E+03 N ! + FUNCTION GHSERNN 2.98150E+02 -3750.675-9.45425*T-12.7819*T*LN(T) + -.00176686*T**2+2.681E-09*T**3-32374*T**(-1); 9.50000E+02 Y + -7358.85+17.2003*T-16.3699*T*LN(T)-6.5107E-04*T**2+3.0097E-08*T**3 + +563070*T**(-1); 3.35000E+03 Y + -16392.8+50.26*T-20.4695*T*LN(T)+2.39754E-04*T**2-8.333E-09*T**3 + +4596375*T**(-1); 6.00000E+03 N ! + FUNCTION GHCPNI 2.98150E+02 +6610.72+GHSERNI#; 6.00000E+03 N ! + FUNCTION GHSERNI 2.98150E+02 -5179.159+117.854*T-22.096*T*LN(T) + -.0048407*T**2; 1.72800E+03 Y + -27840.655+279.135*T-43.1*T*LN(T)+1.12754E+31*T**(-9); 3.00000E+03 N + ! + FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T) + -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y + -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N + ! + FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N ! + FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N ! + FUNCTION GMNBCC 2.98150E+02 -3235.3+127.85*T-23.7*T*LN(T) + -.00744271*T**2+60000*T**(-1); 1.51900E+03 Y + -23188.83+307.7043*T-48*T*LN(T)+1.265152E+30*T**(-9); 2.00000E+03 N ! + FUNCTION GPMOBCC 2.98150E+02 +YMOBCC#*EXP(ZMOBCC#); 6.00000E+03 N ! + FUNCTION GNIBCC 2.98150E+02 +8715.084-3.556*T+GHSERNI#; 6.00000E+03 + N ! + FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N ! + FUNCTION GFEFCC 2.98150E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 + +GHSERFE#; 1.81100E+03 Y + -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N + ! + FUNCTION GMOFCC 2.98150E+02 +15200+.63*T+GHSERMO#; 6.00000E+03 N ! + FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! + FUNCTION GMNFCC 2.98150E+02 -3439.3+131.884*T-24.5177*T*LN(T) + -.006*T**2+69600*T**(-1); 1.51900E+03 Y + -26070.1+309.6664*T-48*T*LN(T)+3.86196E+30*T**(-9); 2.00000E+03 N ! + FUNCTION GPFEHCP 2.98150E+02 +YFEHCP#*EXP(ZFEHCP#); 6.00000E+03 N ! + FUNCTION GPMU1 2.98150E+02 +8.72E-05*P; 6.00000E+03 N ! + FUNCTION GPMU2 2.98150E+02 +1.04E-04*P; 6.00000E+03 N ! + FUNCTION GPR1 2.98150E+02 +3.81E-04*P; 6.00000E+03 N ! + FUNCTION GPR2 2.98150E+02 +4.33E-04*P; 6.00000E+03 N ! + FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N ! + FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N ! + FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N ! + FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N ! + FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N ! + FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N ! + FUNCTION YMOLIQ 2.98150E+02 +VMOLIQ#*EXP(-EMOLIQ#); 6.00000E+03 N ! + FUNCTION ZMOLIQ 2.98150E+02 +1*LN(XMOLIQ#); 6.00000E+03 N ! + FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N ! + FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N ! + FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N ! + FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N ! + FUNCTION YMOBCC 2.98150E+02 +VMOBCC#*EXP(-EMOBCC#); 6.00000E+03 N ! + FUNCTION ZMOBCC 2.98150E+02 +1*LN(XMOBCC#); 6.00000E+03 N ! + FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! + FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N ! + FUNCTION YFEHCP 2.98150E+02 +VFEHCP#*EXP(-EFEHCP#); 6.00000E+03 N ! + FUNCTION ZFEHCP 2.98150E+02 +1*LN(XFEHCP#); 6.00000E+03 N ! + FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N + ! + FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N ! + FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N ! + FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 + N ! + FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N ! + FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 + N ! + FUNCTION VMOLIQ 2.98150E+02 +9.75079E-06*EXP(AMOLIQ#); 6.00000E+03 + N ! + FUNCTION EMOLIQ 2.98150E+02 +1*LN(CMOLIQ#); 6.00000E+03 N ! + FUNCTION XMOLIQ 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 + N ! + FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N + ! + FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N ! + FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N ! + FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 + N ! + FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N ! + FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 + N ! + FUNCTION VMOBCC 2.98150E+02 +9.34372E-06*EXP(AMOBCC#); 6.00000E+03 + N ! + FUNCTION EMOBCC 2.98150E+02 +1*LN(CMOBCC#); 6.00000E+03 N ! + FUNCTION XMOBCC 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 + N ! + FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 + N ! + FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N ! + FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 + N ! + FUNCTION VFEHCP 2.98150E+02 +6.59121E-06*EXP(AFEHCP#); 6.00000E+03 + N ! + FUNCTION EFEHCP 2.98150E+02 +1*LN(CFEHCP#); 6.00000E+03 N ! + FUNCTION XFEHCP 2.98150E+02 +1*EXP(.8064454*DFEHCP#)-1; 6.00000E+03 + N ! + FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N + ! + FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N ! + FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N ! + FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N ! + FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; + 6.00000E+03 N ! + FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N ! + FUNCTION AMOLIQ 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2 + +1.14687E-12*T**3; 6.00000E+03 N ! + FUNCTION CMOLIQ 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; + 6.00000E+03 N ! + FUNCTION DMOBCC 2.98150E+02 +1*LN(BMOBCC#); 6.00000E+03 N ! + FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N + ! + FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N ! + FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N ! + FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; + 6.00000E+03 N ! + FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; + 6.00000E+03 N ! + FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N ! + FUNCTION AMOBCC 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2 + +1.14687E-12*T**3; 6.00000E+03 N ! + FUNCTION CMOBCC 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; + 6.00000E+03 N ! + FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N ! + FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; + 6.00000E+03 N ! + FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N ! + FUNCTION AFEHCP 2.98150E+02 +7.3646E-05*T; 6.00000E+03 N ! + FUNCTION CFEHCP 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; + 6.00000E+03 N ! + FUNCTION DFEHCP 2.98150E+02 +1*LN(BFEHCP#); 6.00000E+03 N ! + FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N ! + FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; + 6.00000E+03 N ! + FUNCTION BMOBCC 2.98150E+02 +1+1.13837E-11*P+4.875E-16*T*P + +1.2675E-19*T**2*P; 6.00000E+03 N ! + FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N ! + FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; + 6.00000E+03 N ! + FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; + 6.00000E+03 N ! + FUNCTION BFEHCP 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; + 6.00000E+03 N ! + FUNCTION UN_ASS 298.15 0; 300 N ! + + TYPE_DEFINITION % SEQ *! + DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! + DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! + + + PHASE LIQUID:L % 1 1.0 ! + CONSTITUENT LIQUID:L :CR,FE,MN,MO,N,NI : ! + + PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T + +2.37615E-21*T**7+GHSERCR#+GPCRLIQ#; 2.18000E+03 Y + +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#+GPCRLIQ#; 6.00000E+03 + N REF283 ! + PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 + N REF283 ! + PARAMETER G(LIQUID,MN;0) 2.98150E+02 +17859.91-12.6208*T + -4.41929E-21*T**7+GHSERMN#; 1.51900E+03 Y + +18739.51-13.2288*T-1.656847E+30*T**(-9)+GHSERMN#; 2.00000E+03 N REF283 ! + PARAMETER G(LIQUID,MO;0) 2.98150E+02 +41831.347-14.694912*T + +4.24519E-22*T**7+GHSERMO#+GPMOLIQ#; 2.89600E+03 Y + +34095.373-11.890046*T+4.849315E+33*T**(-9)+GHSERMO#+GPMOLIQ#; + 5.00000E+03 N REF283 ! + PARAMETER G(LIQUID,N;0) 2.98150E+02 +29950+59.02*T+GHSERNN#; + 6.00000E+03 N REF283 ! + PARAMETER G(LIQUID,NI;0) 2.98150E+02 +11235.527+108.457*T + -22.096*T*LN(T)-.0048407*T**2-3.82318E-21*T**7; 1.72800E+03 Y + -9549.775+268.598*T-43.1*T*LN(T); 3.00000E+03 N REF283 ! + PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -14550+6.65*T; 6.00000E+03 + N REF107 ! + PARAMETER G(LIQUID,CR,FE,N;0) 2.98150E+02 -340750+187.4*T; + 6.00000E+03 N REF126 ! + PARAMETER G(LIQUID,CR,FE,N,NI;0) 2.98150E+02 -261500; 6.00000E+03 N + REF129 ! + PARAMETER G(LIQUID,CR,FE,NI;0) 2.98150E+02 14510; 6.00000E+03 N + REF322 ! + PARAMETER G(LIQUID,CR,FE,NI;1) 2.98150E+02 11977; 6.00000E+03 N + REF322 ! + PARAMETER G(LIQUID,CR,FE,NI;2) 2.98150E+02 5147; 6.00000E+03 N + REF322 ! + PARAMETER G(LIQUID,CR,MN;0) 2.98150E+02 -15009+13.6587*T; 6.00000E+03 + N REF326 ! + PARAMETER G(LIQUID,CR,MN;1) 2.98150E+02 +504+.9479*T; 6.00000E+03 N + REF326 ! + PARAMETER G(LIQUID,CR,MO;0) 2.98150E+02 +15810-6.714*T; 6.00000E+03 + N REF123 ! + PARAMETER G(LIQUID,CR,MO;1) 2.98150E+02 -6220; 6.00000E+03 N REF123 ! + PARAMETER G(LIQUID,CR,N;0) 2.98150E+02 -161800-16.11*T; 6.00000E+03 + N REF128 ! + PARAMETER G(LIQUID,CR,N;1) 2.98150E+02 65508; 6.00000E+03 N REF128 ! + PARAMETER G(LIQUID,CR,N,NI;0) 2.98150E+02 -89400; 6.00000E+03 N + REF129 ! + PARAMETER G(LIQUID,CR,NI;0) 2.98150E+02 +318-7.3318*T; 6.00000E+03 + N REF322 ! + PARAMETER G(LIQUID,CR,NI;1) 2.98150E+02 +16941-6.3696*T; 6.00000E+03 + N REF322 ! + PARAMETER G(LIQUID,FE,MN;0) 2.98150E+02 -3950+.489*T; 6.00000E+03 N + REF261 ! + PARAMETER G(LIQUID,FE,MN;1) 2.98150E+02 1145; 6.00000E+03 N REF261 ! + PARAMETER G(LIQUID,FE,MO;0) 2.98150E+02 -6973-.37*T; 6.00000E+03 N + REF10 ! + PARAMETER G(LIQUID,FE,MO;1) 2.98150E+02 -9424+4.502*T; 6.00000E+03 + N REF10 ! + PARAMETER G(LIQUID,FE,MO,NI;0) 2.98150E+02 50000; 6.00000E+03 N + REF132 ! + PARAMETER G(LIQUID,FE,N;0) 2.98150E+02 -19930-12.01*T; 6.00000E+03 + N REF128 ! + PARAMETER G(LIQUID,FE,NI;0) 2.98150E+02 -18378.86+6.03912*T; + 6.00000E+03 N REF158 ! + PARAMETER G(LIQUID,FE,NI;1) 2.98150E+02 +9228.1-3.54642*T; + 6.00000E+03 N REF158 ! + PARAMETER G(LIQUID,MN,N;0) 2.98150E+02 -142308+6.0759*T; 2.50000E+03 + N REF317 ! + PARAMETER G(LIQUID,MN,N;1) 2.98150E+02 32906; 2.50000E+03 N REF317 ! + PARAMETER G(LIQUID,MN,NI;0) 2.98150E+02 -69233.16+10.54315*T; + 6.00000E+03 N REF182 ! + PARAMETER G(LIQUID,MN,NI;1) 2.98150E+02 7258.05; 6.00000E+03 N + REF182 ! + PARAMETER G(LIQUID,MO,N;0) 2.98150E+02 -198280+37.49*T; 6.00000E+03 + N REF128 ! + PARAMETER G(LIQUID,MO,NI;0) 2.98150E+02 -46540+19.53*T; 6.00000E+03 + N REF125 ! + PARAMETER G(LIQUID,MO,NI;1) 2.98150E+02 2915; 6.00000E+03 N REF125 ! + PARAMETER G(LIQUID,N,NI;0) 2.98150E+02 14981; 6.00000E+03 N REF129 ! + + + PHASE AL3NI2 % 2 .6 .4 ! + CONSTITUENT AL3NI2 :NI : NI% : ! + + PARAMETER G(AL3NI2,NI:NI;0) 2.98150E+02 +GHCPNI#; 6.00000E+03 N + REF95 ! + + + PHASE ALNI_B2 % 2 .5 .5 ! + CONSTITUENT ALNI_B2 :NI%,VA : NI : ! + + PARAMETER G(ALNI_B2,NI:NI;0) 2.98150E+02 +3109+4.721*T-.0043572*T**2 + +1.06896E-06*T**3+GHSERNI#; 6.00000E+03 N REF95 ! + PARAMETER G(ALNI_B2,VA:NI;0) 2.98150E+02 +108736-5.062*T+.5*GHSERNI#; + 6.00000E+03 N REF95 ! + + + TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! + PHASE BCC_A2 %& 2 1 3 ! + CONSTITUENT BCC_A2 :CR%,FE%,MN,MO%,NI : N,VA% : ! + + PARAMETER G(BCC_A2,CR:N;0) 2.98150E+02 +GHSERCR#+3*GHSERNN#+311870 + +29.12*T; 6.00000E+03 N REF128 ! + PARAMETER TC(BCC_A2,CR:N;0) 2.98150E+02 -311.5; 6.00000E+03 N + REF128 ! + PARAMETER BMAGN(BCC_A2,CR:N;0) 2.98150E+02 -.008; 6.00000E+03 N + REF128 ! + PARAMETER G(BCC_A2,FE:N;0) 2.98150E+02 +93562+165.07*T+GHSERFE# + +3*GHSERNN#; 6.00000E+03 N REF128 ! + PARAMETER TC(BCC_A2,FE:N;0) 2.98150E+02 1043; 6.00000E+03 N REF128 ! + PARAMETER BMAGN(BCC_A2,FE:N;0) 2.98150E+02 2.22; 6.00000E+03 N + REF128 ! + PARAMETER G(BCC_A2,MN:N;0) 2.98150E+02 -55600+606.648*T-100.41*T*LN(T) + +844897*T**(-1); 2.50000E+03 N REF317 ! + PARAMETER G(BCC_A2,MO:N;0) 2.98150E+02 +GHSERMO#+3*GHSERNN#+299700 + +79.73*T; 6.00000E+03 N REF128 ! + PARAMETER G(BCC_A2,NI:N;0) 2.98150E+02 +200000+200*T+GHSERNI# + +3*GHSERNN#; 6.00000E+03 N REF123 ! + PARAMETER TC(BCC_A2,NI:N;0) 2.98150E+02 575; 6.00000E+03 N REF123 ! + PARAMETER BMAGN(BCC_A2,NI:N;0) 2.98150E+02 .85; 6.00000E+03 N + REF123 ! + PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N + REF281 ! + PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.01; 6.00000E+03 N + REF281 ! + PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF281 ! + PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N + REF281 ! + PARAMETER G(BCC_A2,MN:VA;0) 2.98150E+02 +GMNBCC#; 6.00000E+03 N + REF283 ! + PARAMETER TC(BCC_A2,MN:VA;0) 2.98150E+02 -580; 2.00000E+03 N REF281 ! + PARAMETER BMAGN(BCC_A2,MN:VA;0) 2.98150E+02 -.27; 2.00000E+03 N + REF281 ! + PARAMETER G(BCC_A2,MO:VA;0) 2.98150E+02 +GHSERMO#+GPMOBCC#; + 5.00000E+03 N REF283 ! + PARAMETER G(BCC_A2,NI:VA;0) 2.98150E+02 +GNIBCC#; 3.00000E+03 N + REF283 ! + PARAMETER TC(BCC_A2,NI:VA;0) 2.98150E+02 575; 6.00000E+03 N REF281 ! + PARAMETER BMAGN(BCC_A2,NI:VA;0) 2.98150E+02 .85; 6.00000E+03 N + REF281 ! + PARAMETER G(BCC_A2,CR,FE:N;0) 2.98150E+02 -799379+293*T; 6.00000E+03 + N REF126 ! + PARAMETER TC(BCC_A2,CR,FE:N;0) 2.98150E+02 1650; 6.00000E+03 N + REF126 ! + PARAMETER TC(BCC_A2,CR,FE:N;1) 2.98150E+02 550; 6.00000E+03 N + REF126 ! + PARAMETER BMAGN(BCC_A2,CR,FE:N;0) 2.98150E+02 -.85; 6.00000E+03 N + REF126 ! + PARAMETER BMAGN(BCC_A2,CR,NI:N;0) 2.98150E+02 4; 6.00000E+03 N + REF129 ! + PARAMETER TC(BCC_A2,CR,NI:N;0) 2.98150E+02 2373; 6.00000E+03 N + REF128 ! + PARAMETER TC(BCC_A2,CR,NI:N;1) 2.98150E+02 617; 6.00000E+03 N + REF128 ! + PARAMETER G(BCC_A2,CR:N,VA;0) 2.98150E+02 -200000; 6.00000E+03 N + REF128 ! + PARAMETER G(BCC_A2,FE,MO:N;0) 2.98150E+02 -151200; 6.00000E+03 N + REF134 ! + PARAMETER G(BCC_A2,MN:N,VA;0) 2.98150E+02 -185000; 2.50000E+03 N + REF317 ! + PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 + N REF107 ! + PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N + REF107 ! + PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N + REF107 ! + PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N + REF107 ! + PARAMETER G(BCC_A2,CR,FE,MN:VA;0) 2.98150E+02 -8374; 6.00000E+03 N + REF326 ! + PARAMETER G(BCC_A2,CR,FE,NI:VA;0) 2.98150E+02 -2673+2.0415*T; + 6.00000E+03 N REF322 ! + PARAMETER G(BCC_A2,CR,MN:VA;0) 2.98150E+02 -20328+18.7339*T; + 6.00000E+03 N REF326 ! + PARAMETER G(BCC_A2,CR,MN:VA;1) 2.98150E+02 -9162+4.4183*T; + 6.00000E+03 N REF326 ! + PARAMETER TC(BCC_A2,CR,MN:VA;0) 2.98150E+02 -1325; 6.00000E+03 N + REF326 ! + PARAMETER TC(BCC_A2,CR,MN:VA;2) 2.98150E+02 -1133; 6.00000E+03 N + REF326 ! + PARAMETER TC(BCC_A2,CR,MN:VA;4) 2.98150E+02 -10294; 6.00000E+03 N + REF326 ! + PARAMETER TC(BCC_A2,CR,MN:VA;6) 2.98150E+02 26706; 6.00000E+03 N + REF326 ! + PARAMETER TC(BCC_A2,CR,MN:VA;8) 2.98150E+02 -28117; 6.00000E+03 N + REF326 ! + PARAMETER BMAGN(BCC_A2,CR,MN:VA;0) 2.98150E+02 .48643; 6.00000E+03 + N REF326 ! + PARAMETER BMAGN(BCC_A2,CR,MN:VA;2) 2.98150E+02 -.72035; 6.00000E+03 + N REF326 ! + PARAMETER BMAGN(BCC_A2,CR,MN:VA;4) 2.98150E+02 -1.93265; 6.00000E+03 + N REF326 ! + PARAMETER G(BCC_A2,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; + 6.00000E+03 N REF123 ! + PARAMETER G(BCC_A2,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 + N REF123 ! + PARAMETER G(BCC_A2,CR,NI:VA;0) 2.98150E+02 +17170-11.8199*T; + 6.00000E+03 N REF322 ! + PARAMETER G(BCC_A2,CR,NI:VA;1) 2.98150E+02 +34418-11.8577*T; + 6.00000E+03 N REF322 ! + PARAMETER TC(BCC_A2,CR,NI:VA;0) 2.98150E+02 2373; 6.00000E+03 N + REF162 ! + PARAMETER TC(BCC_A2,CR,NI:VA;1) 2.98150E+02 617; 6.00000E+03 N + REF162 ! + PARAMETER BMAGN(BCC_A2,CR,NI:VA;0) 2.98150E+02 4; 6.00000E+03 N + REF162 ! + PARAMETER G(BCC_A2,FE,MN:VA;0) 2.98150E+02 -2759+1.237*T; 6.00000E+03 + N REF261 ! + PARAMETER TC(BCC_A2,FE,MN:VA;0) 2.98150E+02 123; 6.00000E+03 N + REF261 ! + PARAMETER G(BCC_A2,FE,MO:VA;0) 2.98150E+02 +36818-9.141*T; + 6.00000E+03 N REF10 ! + PARAMETER G(BCC_A2,FE,MO:VA;1) 2.98150E+02 -362-5.724*T; 6.00000E+03 + N REF10 ! + PARAMETER TC(BCC_A2,FE,MO:VA;0) 2.98150E+02 335; 6.00000E+03 N + REF10 ! + PARAMETER TC(BCC_A2,FE,MO:VA;1) 2.98150E+02 526; 6.00000E+03 N + REF10 ! + PARAMETER G(BCC_A2,FE,MO,NI:VA;0) 2.98150E+02 -35743; 6.00000E+03 N + REF132 ! + PARAMETER G(BCC_A2,FE,NI:VA;0) 2.98150E+02 -956.63-1.28726*T; + 6.00000E+03 N REF158 ! + PARAMETER G(BCC_A2,FE,NI:VA;1) 2.98150E+02 +1789.03-1.92912*T; + 6.00000E+03 N REF158 ! + PARAMETER G(BCC_A2,MN,NI:VA;0) 2.98150E+02 -51638.31+3.64*T; + 6.00000E+03 N REF182 ! + PARAMETER G(BCC_A2,MN,NI:VA;1) 2.98150E+02 6276; 6.00000E+03 N + REF182 ! + PARAMETER G(BCC_A2,MO,NI:VA;0) 2.98150E+02 46422; 6.00000E+03 N + REF125 ! + + + TYPE_DEFINITION ' GES A_P_D CBCC_A12 MAGNETIC -3.0 2.80000E-01 ! + PHASE CBCC_A12 %' 2 1 1 ! + CONSTITUENT CBCC_A12 :CR,FE,MN%,NI : N,VA% : ! + + PARAMETER G(CBCC_A12,CR:N;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CBCC_A12,FE:N;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CBCC_A12,MN:N;0) 2.98150E+02 -53114+299.266*T + -50.216*T*LN(T)+358309*T**(-1); 2.50000E+03 N REF317 ! + PARAMETER G(CBCC_A12,NI:N;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CBCC_A12,CR:VA;0) 2.98150E+02 +11087+2.7196*T+GHSERCR#; + 6.00000E+03 N REF283 ! + PARAMETER G(CBCC_A12,FE:VA;0) 2.98150E+02 +4745+GHSERFE#; 6.00000E+03 + N REF283 ! + PARAMETER G(CBCC_A12,MN:VA;0) 2.98150E+02 +GHSERMN#; 2.00000E+03 N + REF283 ! + PARAMETER TC(CBCC_A12,MN:VA;0) 2.98150E+02 -285; 2.00000E+03 N REF281 ! + PARAMETER BMAGN(CBCC_A12,MN:VA;0) 2.98150E+02 -.66; 2.00000E+03 N + REF281 ! + PARAMETER G(CBCC_A12,NI:VA;0) 2.98150E+02 +3556+GHSERNI#; 3.00000E+03 + N REF283 ! + PARAMETER G(CBCC_A12,MN:N,VA;0) 2.98150E+02 -58869; 2.50000E+03 N + REF317 ! + PARAMETER G(CBCC_A12,CR,MN:VA;0) 2.98150E+02 -36796+20.385*T; + 6.00000E+03 N REF326 ! + PARAMETER G(CBCC_A12,FE,MN:VA;0) 2.98150E+02 -10184; 6.00000E+03 N + REF261 ! + PARAMETER G(CBCC_A12,MN,NI:VA;0) 2.98150E+02 -54754.84+17.991*T; + 6.00000E+03 N REF0 ! + PARAMETER G(CBCC_A12,MN,NI:VA;1) 2.98150E+02 -11924; 6.00000E+03 N + REF0 ! + + + PHASE CEMENTITE % 2 3 1 ! + CONSTITUENT CEMENTITE :CR,FE%,MN,MO,NI : N : ! + + PARAMETER G(CEMENTITE,CR:N;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CEMENTITE,FE:N;0) 2.98150E+02 -20060+538.7902*T + -99.7371*T*LN(T)+226735*T**(-1); 6.00000E+03 N REF319 ! + PARAMETER G(CEMENTITE,MN:N;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CEMENTITE,MO:N;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CEMENTITE,NI:N;0) 298.15 UN_ASS; 300 N REF0 ! + + + PHASE CHI_A12 % 3 24 10 24 ! + CONSTITUENT CHI_A12 :CR,FE : CR,MO : CR,FE,MO : ! + + PARAMETER G(CHI_A12,CR:CR:CR;0) 2.98150E+02 +48*GCRFCC#+10*GHSERCR# + +109000+123*T; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:CR:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR# + +24*GCRFCC#+18300-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(CHI_A12,CR:MO:CR;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# + +24*GCRFCC#-26000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:MO:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO# + +24*GCRFCC#+32555-385*T; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,CR:CR:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR# + +24*GFEFCC#+500000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:CR:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERCR# + +57300-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(CHI_A12,CR:MO:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# + +24*GFEFCC#+500000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:MO:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERMO# + +305210-270*T; 6.00000E+03 N REF115 ! + PARAMETER G(CHI_A12,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR# + +24*GMOFCC#+500000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:CR:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR# + +24*GMOFCC#+100000; 6.00000E+03 N REF115 ! + PARAMETER G(CHI_A12,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# + +24*GMOFCC#+500000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO# + +24*GMOFCC#+97300-100*T; 6.00000E+03 N REF115 ! + + + PHASE CR3MN5 % 2 3 5 ! + CONSTITUENT CR3MN5 :CR : MN : ! + + PARAMETER G(CR3MN5,CR:MN;0) 2.98150E+02 +3*GHSERCR#+5*GHSERMN#-72550 + +21.1732*T; 6.00000E+03 N REF326 ! + + + PHASE CR3SI % 2 3 1 ! + CONSTITUENT CR3SI :CR% : CR : ! + + PARAMETER G(CR3SI,CR:CR;0) 2.98150E+02 +17008.82+4*T+4*GHSERCR#; + 6.00000E+03 N REF90 ! + + + PHASE CRSI2 % 2 1 2 ! + CONSTITUENT CRSI2 :CR% : CR : ! + + PARAMETER G(CRSI2,CR:CR;0) 2.98150E+02 +10000+10*T+3*GHSERCR#; + 6.00000E+03 N REF90 ! + + + PHASE CUB_A13 % 2 1 1 ! + CONSTITUENT CUB_A13 :CR,FE,MN%,NI : N,VA% : ! + + PARAMETER G(CUB_A13,CR:N;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CUB_A13,FE:N;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CUB_A13,MN:N;0) 2.98150E+02 -67484+299.266*T-50.216*T*LN(T) + +358309*T**(-1); 2.50000E+03 N REF317 ! + PARAMETER G(CUB_A13,NI:N;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CUB_A13,CR:VA;0) 2.98150E+02 +15899+.6276*T+GHSERCR#; + 6.00000E+03 N REF283 ! + PARAMETER G(CUB_A13,FE:VA;0) 2.98150E+02 +3745+GHSERFE#; 6.00000E+03 + N REF283 ! + PARAMETER G(CUB_A13,MN:VA;0) 2.98150E+02 -5800.4+135.995*T + -24.8785*T*LN(T)-.00583359*T**2+70269*T**(-1); 1.51900E+03 Y + -28290.76+311.2933*T-48*T*LN(T)+3.96757E+30*T**(-9); 2.00000E+03 N + REF283 ! + PARAMETER G(CUB_A13,NI:VA;0) 2.98150E+02 +2092+GHSERNI#; 3.00000E+03 + N REF283 ! + PARAMETER G(CUB_A13,MN:N,VA;0) 2.98150E+02 -58869; 2.50000E+03 N + REF317 ! + PARAMETER G(CUB_A13,CR,MN:VA;0) 2.98150E+02 -31260+16.4919*T; + 6.00000E+03 N REF326 ! + PARAMETER G(CUB_A13,FE,MN:VA;0) 2.98150E+02 -11518+2.819*T; + 6.00000E+03 N REF261 ! + PARAMETER G(CUB_A13,MN,NI:VA;0) 2.98150E+02 -62040.75+26.82825*T; + 6.00000E+03 N REF182 ! + PARAMETER G(CUB_A13,MN,NI:VA;1) 2.98150E+02 -12370.01; 6.00000E+03 + N REF182 ! + + + TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! + PHASE FCC_A1 %( 2 1 1 ! + CONSTITUENT FCC_A1 :CR,FE%,MN,MO,NI% : N,VA% : ! + + PARAMETER G(FCC_A1,CR:N;0) 2.98150E+02 -124460+142.16*T-8.5*T*LN(T) + +GHSERCR#+GHSERNN#; 6.00000E+03 N REF128 ! + PARAMETER G(FCC_A1,FE:N;0) 2.98150E+02 -20277+245.3931*T + -21.2984*T*LN(T)+GHSERFE#+GHSERNN#; 6.00000E+03 N REF319 ! + PARAMETER G(FCC_A1,MN:N;0) 2.98150E+02 -75940+292.226*T-50.294*T*LN(T) + +265051*T**(-1); 2.50000E+03 N REF317 ! + PARAMETER G(FCC_A1,MO:N;0) 2.98150E+02 +GHSERMO#+GHSERNN#-65344+149.7*T + -9.78*T*LN(T); 6.00000E+03 N REF128 ! + PARAMETER G(FCC_A1,NI:N;0) 2.98150E+02 +38680+143.09*T-10.9*T*LN(T) + +.00438*T**2+GHSERNI#+GHSERNN#; 6.00000E+03 N REF123 ! + PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; + 6.00000E+03 N REF281 ! + PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N + REF281 ! + PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N + REF281 ! + PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF281 ! + PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N + REF281 ! + PARAMETER G(FCC_A1,MN:VA;0) 2.98150E+02 +GMNFCC#; 6.00000E+03 N + REF283 ! + PARAMETER TC(FCC_A1,MN:VA;0) 2.98150E+02 -1620; 2.00000E+03 N REF281 ! + PARAMETER BMAGN(FCC_A1,MN:VA;0) 2.98150E+02 -1.86; 2.00000E+03 N + REF281 ! + PARAMETER G(FCC_A1,MO:VA;0) 2.98150E+02 +15200+.63*T+GHSERMO#+GPMOBCC#; + 5.00000E+03 N REF283 ! + PARAMETER G(FCC_A1,NI:VA;0) 2.98150E+02 +GHSERNI#; 3.00000E+03 N + REF283 ! + PARAMETER TC(FCC_A1,NI:VA;0) 2.98150E+02 633; 6.00000E+03 N REF281 ! + PARAMETER BMAGN(FCC_A1,NI:VA;0) 2.98150E+02 .52; 6.00000E+03 N + REF281 ! + PARAMETER G(FCC_A1,CR,FE:N;0) 2.98150E+02 -128930+86.49*T; + 6.00000E+03 N REF126 ! + PARAMETER G(FCC_A1,CR,FE:N;1) 2.98150E+02 24330; 6.00000E+03 N + REF126 ! + PARAMETER G(FCC_A1,CR,FE:N,VA;0) 2.98150E+02 -162516; 6.00000E+03 N + REF126 ! + PARAMETER G(FCC_A1,CR,MO:N;0) 2.98150E+02 -40000; 6.00000E+03 N + REF128 ! + PARAMETER G(FCC_A1,CR,NI:N,VA;0) 2.98150E+02 -661270+305*T; + 6.00000E+03 N REF129 ! + PARAMETER G(FCC_A1,CR:N,VA;0) 2.98150E+02 20000; 6.00000E+03 N + REF128 ! + PARAMETER G(FCC_A1,FE,NI:N;0) 2.98150E+02 -22710+5.19*T; 6.00000E+03 + N REF129 ! + PARAMETER G(FCC_A1,FE,NI:N;1) 2.98150E+02 3334; 6.00000E+03 N + REF129 ! + PARAMETER G(FCC_A1,FE:N,VA;0) 2.98150E+02 -26150; 6.00000E+03 N + REF128 ! + PARAMETER G(FCC_A1,MN:N,VA;0) 2.98150E+02 -69698+11.5845*T; + 2.50000E+03 N REF317 ! + PARAMETER G(FCC_A1,MO:N,VA;0) 2.98150E+02 -52565; 6.00000E+03 N + REF128 ! + PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; + 6.00000E+03 N REF107 ! + PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N + REF107 ! + PARAMETER G(FCC_A1,CR,FE,MN:VA;0) 2.98150E+02 -6815; 6.00000E+03 N + REF326 ! + PARAMETER G(FCC_A1,CR,FE,NI:VA;0) 2.98150E+02 +16580-9.783*T; + 6.00000E+03 N REF322 ! + PARAMETER G(FCC_A1,CR,MN:VA;0) 2.98150E+02 -19088+17.5423*T; + 6.00000E+03 N REF326 ! + PARAMETER G(FCC_A1,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; + 6.00000E+03 N REF58 ! + PARAMETER G(FCC_A1,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 + N REF58 ! + PARAMETER G(FCC_A1,CR,MO,NI:VA;0) 2.98150E+02 -30000; 6.00000E+03 N + REF58 ! + PARAMETER G(FCC_A1,CR,NI:VA;0) 2.98150E+02 +8030-12.8801*T; + 6.00000E+03 N REF322 ! + PARAMETER G(FCC_A1,CR,NI:VA;1) 2.98150E+02 +33080-16.0362*T; + 6.00000E+03 N REF322 ! + PARAMETER TC(FCC_A1,CR,NI:VA;0) 2.98150E+02 -3605; 6.00000E+03 N + REF162 ! + PARAMETER BMAGN(FCC_A1,CR,NI:VA;0) 2.98150E+02 -1.91; 6.00000E+03 N + REF162 ! + PARAMETER G(FCC_A1,FE,MN:VA;0) 2.98150E+02 -7762+3.865*T; 6.00000E+03 + N REF261 ! + PARAMETER G(FCC_A1,FE,MN:VA;1) 2.98150E+02 -259; 6.00000E+03 N + REF261 ! + PARAMETER TC(FCC_A1,FE,MN:VA;0) 2.98150E+02 -2282; 6.00000E+03 N + REF261 ! + PARAMETER TC(FCC_A1,FE,MN:VA;1) 2.98150E+02 -2068; 6.00000E+03 N + REF261 ! + PARAMETER G(FCC_A1,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; + 6.00000E+03 N REF10 ! + PARAMETER G(FCC_A1,FE,MO,NI:VA;0) 2.98150E+02 -204791+163.93*T; + 6.00000E+03 N REF132 ! + PARAMETER G(FCC_A1,FE,MO,NI:VA;1) 2.98150E+02 +11555-55.81*T; + 6.00000E+03 N REF132 ! + PARAMETER G(FCC_A1,FE,MO,NI:VA;2) 2.98150E+02 77975; 6.00000E+03 N + REF132 ! + PARAMETER G(FCC_A1,FE,NI:VA;0) 2.98150E+02 -12054.355+3.27413*T; + 6.00000E+03 N REF158 ! + PARAMETER G(FCC_A1,FE,NI:VA;1) 2.98150E+02 +11082.1315-4.45077*T; + 6.00000E+03 N REF158 ! + PARAMETER G(FCC_A1,FE,NI:VA;2) 2.98150E+02 -725.805174; 6.00000E+03 + N REF158 ! + PARAMETER TC(FCC_A1,FE,NI:VA;0) 2.98150E+02 2133; 6.00000E+03 N + REF158 ! + PARAMETER TC(FCC_A1,FE,NI:VA;1) 2.98150E+02 -682; 6.00000E+03 N + REF158 ! + PARAMETER BMAGN(FCC_A1,FE,NI:VA;0) 2.98150E+02 9.55; 6.00000E+03 N + REF158 ! + PARAMETER BMAGN(FCC_A1,FE,NI:VA;1) 2.98150E+02 7.23; 6.00000E+03 N + REF158 ! + PARAMETER BMAGN(FCC_A1,FE,NI:VA;2) 2.98150E+02 5.93; 6.00000E+03 N + REF158 ! + PARAMETER BMAGN(FCC_A1,FE,NI:VA;3) 2.98150E+02 6.18; 6.00000E+03 N + REF158 ! + PARAMETER G(FCC_A1,MN,NI:VA;0) 2.98150E+02 -58158+10.878*T; + 6.00000E+03 N REF182 ! + PARAMETER G(FCC_A1,MN,NI:VA;1) 2.98150E+02 6276; 6.00000E+03 N + REF182 ! + PARAMETER G(FCC_A1,MO,NI:VA;0) 2.98150E+02 +4803.7-5.96*T; + 6.00000E+03 N REF125 ! + PARAMETER G(FCC_A1,MO,NI:VA;1) 2.98150E+02 10880; 6.00000E+03 N + REF125 ! + + + PHASE FE4N % 2 4 1 ! + CONSTITUENT FE4N :FE,NI : N,VA : ! + + PARAMETER G(FE4N,FE:N;0) 2.98150E+02 -37514+72.6235*T+4*GHSERFE# + +GHSERNN#; 6.00000E+03 N REF319 ! + PARAMETER G(FE4N,NI:N;0) 2.98150E+02 -5393+142.97*T-15.65*T*LN(T) + +.0154*T**2+4*GHSERNI#+GHSERNN#; 6.00000E+03 N REF129 ! + PARAMETER G(FE4N,FE:VA;0) 2.98150E+02 +4*GFEFCC#+10; 6.00000E+03 N + REF319 ! + PARAMETER G(FE4N,NI:VA;0) 2.98150E+02 +4*GHSERNI#+10; 6.00000E+03 N + REF59 ! + PARAMETER G(FE4N,FE:N,VA;0) 2.98150E+02 +64679-21.9574*T; 6.00000E+03 + N REF319 ! + PARAMETER G(FE4N,FE:N,VA;1) 2.98150E+02 -27905-3.0409*T; 6.00000E+03 + N REF319 ! + + + PHASE FECN_CHI % 2 5 2 ! + CONSTITUENT FECN_CHI :FE : N : ! + + PARAMETER G(FECN_CHI,FE:N;0) 2.98150E+02 -53838+952.0774*T + -174.5248*T*LN(T)+438672*T**(-1); 6.00000E+03 N REF319 ! + + + TYPE_DEFINITION ) GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 ! + PHASE HCP_A3 %) 2 1 .5 ! + CONSTITUENT HCP_A3 :CR,FE,MN,MO,NI : N,VA% : ! + + PARAMETER G(HCP_A3,CR:N;0) 2.98150E+02 -65760+64.69*T-3.93*T*LN(T) + +GHSERCR#+.5*GHSERNN#; 6.00000E+03 N REF128 ! + PARAMETER G(HCP_A3,FE:N;0) 2.98150E+02 -13863+40.2123*T+GHSERFE# + +.5*GHSERNN#; 6.00000E+03 N REF319 ! + PARAMETER G(HCP_A3,MN:N;0) 2.98150E+02 -60607+211.1804*T + -37.7331*T*LN(T)+129442*T**(-1); 2.50000E+03 N REF317 ! + PARAMETER G(HCP_A3,MO:N;0) 2.98150E+02 +GHSERMO#+.5*GHSERNN#-29450 + +28.7*T; 6.00000E+03 N REF128 ! + PARAMETER G(HCP_A3,NI:N;0) 2.98150E+02 -4409.6+72.93*T-7.36*T*LN(T) + +.00614*T**2+GHSERNI#+.5*GHSERNN#; 6.00000E+03 N REF123 ! + PARAMETER G(HCP_A3,CR:VA;0) 2.98150E+02 +4438+GHSERCR#+GPCRBCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(HCP_A3,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N + REF281 ! + PARAMETER BMAGN(HCP_A3,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N + REF281 ! + PARAMETER G(HCP_A3,FE:VA;0) 2.98150E+02 -3705.78+12.591*T-1.15*T*LN(T) + +6.4E-04*T**2+GHSERFE#+GPFEHCP#; 1.81100E+03 Y + -3957.199+5.24951*T+4.9251E+30*T**(-9)+GHSERFE#+GPFEHCP#; 6.00000E+03 N + REF283 ! + PARAMETER G(HCP_A3,MN:VA;0) 2.98150E+02 -4439.3+133.007*T + -24.5177*T*LN(T)-.006*T**2+69600*T**(-1); 1.51900E+03 Y + -27070.1+310.7894*T-48*T*LN(T)+3.86196E+30*T**(-9); 2.00000E+03 N + REF283 ! + PARAMETER TC(HCP_A3,MN:VA;0) 2.98150E+02 -1620; 2.00000E+03 N REF281 ! + PARAMETER BMAGN(HCP_A3,MN:VA;0) 2.98150E+02 -1.86; 2.00000E+03 N + REF281 ! + PARAMETER G(HCP_A3,MO:VA;0) 2.98150E+02 +11550+GHSERMO#+GPMOBCC#; + 5.00000E+03 N REF283 ! + PARAMETER G(HCP_A3,NI:VA;0) 2.98150E+02 +1046+1.255*T+GHSERNI#; + 3.00000E+03 N REF283 ! + PARAMETER TC(HCP_A3,NI:VA;0) 2.98150E+02 633; 6.00000E+03 N REF26 ! + PARAMETER BMAGN(HCP_A3,NI:VA;0) 2.98150E+02 .52; 6.00000E+03 N + REF26 ! + PARAMETER G(HCP_A3,CR,FE:N;0) 2.98150E+02 +12826-19.48*T; 6.00000E+03 + N REF126 ! + PARAMETER G(HCP_A3,CR,MO:N;0) 2.98150E+02 -8754; 6.00000E+03 N + REF128 ! + PARAMETER G(HCP_A3,CR,NI:N;0) 2.98150E+02 1443; 6.00000E+03 N + REF129 ! + PARAMETER G(HCP_A3,CR:N,VA;0) 2.98150E+02 +21120-10.61*T; 6.00000E+03 + N REF128 ! + PARAMETER G(HCP_A3,CR:N,VA;1) 2.98150E+02 -6204; 6.00000E+03 N + REF128 ! + PARAMETER G(HCP_A3,FE:N,VA;0) 2.98150E+02 +10012-19.9853*T; + 6.00000E+03 N REF319 ! + PARAMETER G(HCP_A3,FE:N,VA;1) 2.98150E+02 -9446+9.3472*T; 6.00000E+03 + N REF319 ! + PARAMETER G(HCP_A3,MN:N,VA;0) 2.98150E+02 -7194-5.2075*T; 2.50000E+03 + N REF317 ! + PARAMETER G(HCP_A3,MN:N,VA;1) 2.98150E+02 -11810+6.9538*T; 2.50000E+03 + N REF317 ! + PARAMETER G(HCP_A3,MO,NI:N;0) 2.98150E+02 -80000; 6.00000E+03 N + REF134 ! + PARAMETER G(HCP_A3,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; + 6.00000E+03 N REF126 ! + PARAMETER G(HCP_A3,CR,MN:VA;0) 2.98150E+02 41800; 6.00000E+03 N + REF326 ! + PARAMETER G(HCP_A3,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; + 6.00000E+03 N REF117 ! + PARAMETER G(HCP_A3,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 + N REF117 ! + PARAMETER G(HCP_A3,FE,MN:VA;0) 2.98150E+02 -5582+3.865*T; 6.00000E+03 + N REF261 ! + PARAMETER G(HCP_A3,FE,MN:VA;1) 2.98150E+02 273; 6.00000E+03 N + REF261 ! + PARAMETER G(HCP_A3,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; + 6.00000E+03 N REF10 ! + PARAMETER G(HCP_A3,FE,NI:VA;0) 2.98150E+02 -12054.355+3.27413*T; + 6.00000E+03 N REF158 ! + PARAMETER G(HCP_A3,FE,NI:VA;1) 2.98150E+02 +11082-4.45077*T; + 6.00000E+03 N REF158 ! + PARAMETER G(HCP_A3,FE,NI:VA;2) 2.98150E+02 -725.8; 6.00000E+03 N + REF158 ! + + + PHASE HIGH_SIGMA % 3 8 4 18 ! + CONSTITUENT HIGH_SIGMA :MN : CR : CR,MN : ! + + PARAMETER G(HIGH_SIGMA,MN:CR:CR;0) 2.98150E+02 +8*GMNFCC#+22*GHSERCR# + -192369+152.4742*T; 6.00000E+03 N REF326 ! + PARAMETER G(HIGH_SIGMA,MN:CR:MN;0) 2.98150E+02 +8*GMNFCC#+4*GHSERCR# + +18*GMNBCC#-74263-10.7082*T; 6.00000E+03 N REF326 ! + PARAMETER G(HIGH_SIGMA,MN:CR:CR,MN;0) 2.98150E+02 90000; 6.00000E+03 + N REF326 ! + + + PHASE LAVES_PHASE % 2 2 1 ! + CONSTITUENT LAVES_PHASE :CR,FE : MO : ! + + PARAMETER G(LAVES_PHASE,CR:MO;0) 2.98150E+02 +2*GCRFCC#+GHSERMO#-8000 + -6*T; 6.00000E+03 N REF214 ! + PARAMETER G(LAVES_PHASE,FE:MO;0) 2.98150E+02 -10798-.132*T+2*GFEFCC# + +GHSERMO#; 6.00000E+03 N REF10 ! + + + PHASE MC_ETA % 2 1 1 ! + CONSTITUENT MC_ETA :MO% : VA : ! + + PARAMETER G(MC_ETA,MO:VA;0) 2.98150E+02 +GHSERMO#+15200+.63*T; + 6.00000E+03 N REF113 ! + + + PHASE MN4N % 2 4 1 ! + CONSTITUENT MN4N :MN : N : ! + + PARAMETER G(MN4N,MN:N;0) 2.98150E+02 -155790+691.0638*T + -126.9328*T*LN(T)+307417*T**(-1); 2.50000E+03 N REF317 ! + + + PHASE MN6N4 % 2 6 4 ! + CONSTITUENT MN6N4 :MN : N : ! + + PARAMETER G(MN6N4,MN:N;0) 2.98150E+02 -465614+1428.332*T + -251.337*T*LN(T)+1027898*T**(-1); 2.50000E+03 N REF317 ! + + + PHASE MN6N5 % 2 6 5 ! + CONSTITUENT MN6N5 :MN : N : ! + + PARAMETER G(MN6N5,MN:N;0) 2.98150E+02 -546880+1591.607*T + -276.668*T*LN(T)+1297983*T**(-1); 2.50000E+03 N REF317 ! + + + PHASE MONI3_GAMMA % 2 1 3 ! + CONSTITUENT MONI3_GAMMA :MO : NI : ! + + PARAMETER G(MONI3_GAMMA,MO:NI;0) 2.98150E+02 +3*GHSERNI#+GHSERMO#-4199 + -7*T; 6.00000E+03 N REF125 ! + + + PHASE MONI4_BETA % 2 1 4 ! + CONSTITUENT MONI4_BETA :MO : NI : ! + + PARAMETER G(MONI4_BETA,MO:NI;0) 2.98150E+02 +4*GHSERNI#+GHSERMO#-4330 + -9.21*T; 6.00000E+03 N REF125 ! + + + PHASE MONI_DELTA % 3 24 20 12 ! + CONSTITUENT MONI_DELTA :CR,FE,NI : CR,FE,MO,NI : MO : ! + + PARAMETER G(MONI_DELTA,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR# + +12*GHSERMO#+50000; 6.00000E+03 N REF133 ! + PARAMETER G(MONI_DELTA,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(MONI_DELTA,NI:CR:MO;0) 2.98150E+02 +24*GHSERNI#+20*GHSERCR# + +12*GHSERMO#-200000; 6.00000E+03 N REF133 ! + PARAMETER G(MONI_DELTA,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(MONI_DELTA,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE# + +12*GHSERMO#+100000; 6.00000E+03 N REF132 ! + PARAMETER G(MONI_DELTA,NI:FE:MO;0) 2.98150E+02 +24*GHSERNI#+20*GHSERFE# + +12*GHSERMO#; 6.00000E+03 N REF132 ! + PARAMETER G(MONI_DELTA,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO# + +100000; 6.00000E+03 N REF133 ! + PARAMETER G(MONI_DELTA,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO# + +100000; 6.00000E+03 N REF132 ! + PARAMETER G(MONI_DELTA,NI:MO:MO;0) 2.98150E+02 +24*GHSERNI#+32*GHSERMO# + -212100+1089*T-142*T*LN(T); 6.00000E+03 N REF125 ! + PARAMETER G(MONI_DELTA,CR:NI:MO;0) 2.98150E+02 +24*GCRFCC#+20*GNIBCC# + +12*GHSERMO#-200000; 6.00000E+03 N REF133 ! + PARAMETER G(MONI_DELTA,FE:NI:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERNI# + +12*GHSERMO#; 6.00000E+03 N REF132 ! + PARAMETER G(MONI_DELTA,NI:NI:MO;0) 2.98150E+02 +24*GHSERNI#+20*GNIBCC# + +12*GHSERMO#-1030-93.5*T+13.5*T*LN(T); 6.00000E+03 N REF125 ! + + + PHASE MU_PHASE % 3 7 2 4 ! + CONSTITUENT MU_PHASE :CR,FE,NI : MO : CR,FE,MO,NI : ! + + PARAMETER G(MU_PHASE,CR:MO:CR;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# + +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(MU_PHASE,FE:MO:CR;0) 2.98150E+02 +7*GFEFCC#+2*GHSERMO# + +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(MU_PHASE,NI:MO:CR;0) 2.98150E+02 +7*GHSERNI#+2*GHSERMO# + +4*GHSERCR#; 6.00000E+03 N REF136 ! + PARAMETER G(MU_PHASE,CR:MO:FE;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# + +4*GHSERFE#+130000-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(MU_PHASE,FE:MO:FE;0) 2.98150E+02 +39475-6.032*T+7*GFEFCC# + +2*GHSERMO#+4*GHSERFE#+GPMU1#; 6.00000E+03 N REF10 ! + PARAMETER G(MU_PHASE,NI:MO:FE;0) 2.98150E+02 +7*GHSERNI#+2*GHSERMO# + +4*GHSERFE#+784294-249.607*T; 6.00000E+03 N REF132 ! + PARAMETER G(MU_PHASE,CR:MO:MO;0) 2.98150E+02 +7*GCRFCC#+6*GHSERMO# + +130000-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(MU_PHASE,FE:MO:MO;0) 2.98150E+02 -46663-5.891*T+7*GFEFCC# + +6*GHSERMO#+GPMU2#; 6.00000E+03 N REF10 ! + PARAMETER G(MU_PHASE,NI:MO:MO;0) 2.98150E+02 +7*GHSERNI#+6*GHSERMO# + +28506-47.3*T; 6.00000E+03 N REF132 ! + PARAMETER G(MU_PHASE,CR:MO:NI;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# + +4*GNIBCC#; 6.00000E+03 N REF136 ! + PARAMETER G(MU_PHASE,FE:MO:NI;0) 2.98150E+02 +7*GFEFCC#+2*GHSERMO# + +4*GHSERNI#+354030-229.4*T; 6.00000E+03 N REF132 ! + PARAMETER G(MU_PHASE,NI:MO:NI;0) 2.98150E+02 +7*GHSERNI#+2*GHSERMO# + +4*GNIBCC#+398566-200*T; 6.00000E+03 N REF132 ! + PARAMETER G(MU_PHASE,CR,FE:MO:MO;0) 2.98150E+02 -45000; 6.00000E+03 + N REF115 ! + + + PHASE PI % 3 12.8 7.2 4 ! + CONSTITUENT PI :CR : FE,NI : N : ! + + PARAMETER G(PI,CR:FE:N;0) 2.98150E+02 -160994+12.8*GHSERCR# + +7.2*GHSERFE#+4*GHSERNN#; 6.00000E+03 N REF129 ! + PARAMETER G(PI,CR:NI:N;0) 2.98150E+02 -651800+316*T+12.8*GHSERCR# + +7.2*GHSERNI#+4*GHSERNN#; 6.00000E+03 N REF129 ! + + + PHASE P_PHASE % 3 24 20 12 ! + CONSTITUENT P_PHASE :CR,FE,NI : CR,FE,MO,NI : MO : ! + + PARAMETER G(P_PHASE,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR# + +12*GHSERMO#+252300-100*T; 6.00000E+03 N REF133 ! + PARAMETER G(P_PHASE,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(P_PHASE,NI:CR:MO;0) 2.98150E+02 +24*GHSERNI#+20*GHSERCR# + +12*GHSERMO#-341858; 6.00000E+03 N REF133 ! + PARAMETER G(P_PHASE,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(P_PHASE,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE# + +12*GHSERMO#+111361; 6.00000E+03 N REF132 ! + PARAMETER G(P_PHASE,NI:FE:MO;0) 2.98150E+02 +24*GHSERNI#+20*GHSERFE# + +12*GHSERMO#-170245+100*T; 6.00000E+03 N REF132 ! + PARAMETER G(P_PHASE,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO# + +95573-200*T; 6.00000E+03 N REF133 ! + PARAMETER G(P_PHASE,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO# + +362525-332.7*T; 6.00000E+03 N REF132 ! + PARAMETER G(P_PHASE,NI:MO:MO;0) 2.98150E+02 +24*GHSERNI#+32*GHSERMO# + +26739-100*T; 6.00000E+03 N REF132 ! + PARAMETER G(P_PHASE,CR:NI:MO;0) 2.98150E+02 +24*GCRFCC#+20*GNIBCC# + +12*GHSERMO#-434085; 6.00000E+03 N REF133 ! + PARAMETER G(P_PHASE,FE:NI:MO;0) 2.98150E+02 +24*GFEFCC#+20*GNIBCC# + +12*GHSERMO#; 6.00000E+03 N REF132 ! + PARAMETER G(P_PHASE,NI:NI:MO;0) 2.98150E+02 +24*GHSERNI#+20*GNIBCC# + +12*GHSERMO#+208845-100*T; 6.00000E+03 N REF132 ! + + + PHASE R_PHASE % 3 27 14 12 ! + CONSTITUENT R_PHASE :CR,FE,NI : MO : CR,FE,MO,NI : ! + + PARAMETER G(R_PHASE,CR:MO:CR;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO# + +12*GHSERCR#-20000; 6.00000E+03 N REF115 ! + PARAMETER G(R_PHASE,FE:MO:CR;0) 2.98150E+02 +27*GFEFCC#+14*GHSERMO# + +12*GHSERCR#+600260-620*T; 6.00000E+03 N REF115 ! + PARAMETER G(R_PHASE,NI:MO:CR;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(R_PHASE,CR:MO:FE;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO# + +12*GHSERFE#+645260-620*T; 6.00000E+03 N REF115 ! + PARAMETER G(R_PHASE,FE:MO:FE;0) 2.98150E+02 -77487-50.486*T+27*GFEFCC# + +14*GHSERMO#+12*GHSERFE#+GPR1#; 6.00000E+03 N REF10 ! + PARAMETER G(R_PHASE,NI:MO:FE;0) 2.98150E+02 +27*GHSERNI#+14*GHSERMO# + +12*GHSERFE#; 6.00000E+03 N REF132 ! + PARAMETER G(R_PHASE,CR:MO:MO;0) 2.98150E+02 +27*GCRFCC#+26*GHSERMO# + -20000; 6.00000E+03 N REF115 ! + PARAMETER G(R_PHASE,FE:MO:MO;0) 2.98150E+02 +313474-289.472*T + +27*GFEFCC#+26*GHSERMO#+GPR2#; 6.00000E+03 N REF10 ! + PARAMETER G(R_PHASE,NI:MO:MO;0) 2.98150E+02 +27*GHSERNI#+26*GHSERMO# + -18000; 6.00000E+03 N REF132 ! + PARAMETER G(R_PHASE,CR:MO:NI;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(R_PHASE,FE:MO:NI;0) 2.98150E+02 +27*GFEFCC#+14*GHSERMO# + +12*GNIBCC#; 6.00000E+03 N REF132 ! + PARAMETER G(R_PHASE,NI:MO:NI;0) 2.98150E+02 +27*GHSERNI#+14*GHSERMO# + +12*GNIBCC#+100000; 6.00000E+03 N REF132 ! + + + PHASE SIGMA % 3 8 4 18 ! + CONSTITUENT SIGMA :FE,MN,NI : CR,MO : CR,FE,MN,MO,NI : ! + + PARAMETER G(SIGMA,FE:CR:CR;0) 2.98150E+02 +8*GFEFCC#+22*GHSERCR#+92300 + -95.96*T+GPSIG1#; 6.00000E+03 N REF107 ! + PARAMETER G(SIGMA,MN:CR:CR;0) 2.98150E+02 +8*GMNFCC#+22*GHSERCR# + +65859.5; 6.00000E+03 N REF326 ! + PARAMETER G(SIGMA,NI:CR:CR;0) 2.98150E+02 +8*GHSERNI#+22*GHSERCR# + +221157-227*T; 6.00000E+03 N REF322 ! + PARAMETER G(SIGMA,FE:MO:CR;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO# + +18*GHSERCR#+488480-360*T; 6.00000E+03 N REF115 ! + PARAMETER G(SIGMA,MN:MO:CR;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(SIGMA,NI:MO:CR;0) 2.98150E+02 +8*GHSERNI#+4*GHSERMO# + +18*GHSERCR#+386423; 6.00000E+03 N REF133 ! + PARAMETER G(SIGMA,FE:CR:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# + +18*GHSERFE#+117300-95.96*T+GPSIG2#; 6.00000E+03 N REF107 ! + PARAMETER G(SIGMA,MN:CR:FE;0) 2.98150E+02 +8*GMNFCC#+4*GHSERCR# + +18*GHSERFE#-95576-45.2*T; 6.00000E+03 N REF0 ! + PARAMETER G(SIGMA,NI:CR:FE;0) 2.98150E+02 +8*GHSERNI#+4*GHSERCR# + +18*GHSERFE#; 6.00000E+03 N REF136 ! + PARAMETER G(SIGMA,FE:MO:FE;0) 2.98150E+02 -1813-27.272*T+8*GFEFCC# + +18*GHSERFE#+4*GHSERMO#; 6.00000E+03 N REF10 ! + PARAMETER G(SIGMA,MN:MO:FE;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(SIGMA,NI:MO:FE;0) 2.98150E+02 +8*GHSERNI#+18*GHSERFE# + +4*GHSERMO#+658600-200*T; 6.00000E+03 N REF132 ! + PARAMETER G(SIGMA,FE:CR:MN;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# + +18*GMNBCC#-83640+18.26*T; 6.00000E+03 N REF0 ! + PARAMETER G(SIGMA,MN:CR:MN;0) 2.98150E+02 +8*GMNFCC#+4*GHSERCR# + +18*GMNBCC#-172946+69.0245*T; 6.00000E+03 N REF326 ! + PARAMETER G(SIGMA,NI:CR:MN;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(SIGMA,FE:MO:MN;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(SIGMA,MN:MO:MN;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(SIGMA,NI:MO:MN;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(SIGMA,FE:CR:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# + +18*GHSERMO#+312580-260*T; 6.00000E+03 N REF115 ! + PARAMETER G(SIGMA,MN:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(SIGMA,NI:CR:MO;0) 2.98150E+02 +8*GHSERNI#+18*GHSERMO# + +4*GHSERCR#-131651; 6.00000E+03 N REF133 ! + PARAMETER G(SIGMA,FE:MO:MO;0) 2.98150E+02 +83326-69.618*T+8*GFEFCC# + +22*GHSERMO#; 6.00000E+03 N REF10 ! + PARAMETER G(SIGMA,MN:MO:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(SIGMA,NI:MO:MO;0) 2.98150E+02 +8*GHSERNI#+22*GHSERMO#+85662; + 6.00000E+03 N REF133 ! + PARAMETER G(SIGMA,FE:CR:NI;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# + +18*GNIBCC#; 6.00000E+03 N REF136 ! + PARAMETER G(SIGMA,MN:CR:NI;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(SIGMA,NI:CR:NI;0) 2.98150E+02 +8*GHSERNI#+4*GHSERCR# + +18*GNIBCC#+175400; 6.00000E+03 N REF200 ! + PARAMETER G(SIGMA,FE:MO:NI;0) 2.98150E+02 +8*GFEFCC#+18*GNIBCC# + +4*GHSERMO#+408600-200*T; 6.00000E+03 N REF132 ! + PARAMETER G(SIGMA,MN:MO:NI;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(SIGMA,NI:MO:NI;0) 2.98150E+02 +8*GHSERNI#+4*GHSERMO# + +18*GNIBCC#-16385; 6.00000E+03 N REF133 ! + PARAMETER G(SIGMA,FE:CR:CR,MN;0) 2.98150E+02 -1095771+862.0312*T; + 6.00000E+03 N REF326 ! + PARAMETER G(SIGMA,FE:CR:CR,MO;0) 2.98150E+02 -148000; 6.00000E+03 N + REF115 ! + PARAMETER G(SIGMA,MN:CR:CR,MN;0) 2.98150E+02 -1095771+862.0312*T; + 6.00000E+03 N REF326 ! + PARAMETER G(SIGMA,FE:MO:CR,MO;0) 2.98150E+02 121000; 6.00000E+03 N + REF115 ! + PARAMETER G(SIGMA,FE:CR:FE,MO;0) 2.98150E+02 570000; 6.00000E+03 N + REF115 ! + PARAMETER G(SIGMA,FE:MO:FE,MO;0) 2.98150E+02 222909; 6.00000E+03 N + REF10 ! + PARAMETER G(SIGMA,FE,NI:MO:MO;0) 2.98150E+02 -164570-10*T; + 6.00000E+03 N REF132 ! + + LIST_OF_REFERENCES + NUMBER SOURCE + REF283 'Alan Dinsdale, SGTE Data for Pure Elements, + Calphad Vol 15(1991) p 317-425, + also in NPL Report DMA(A)195 Rev. August 1990' + REF95 'I Ansara, P Willemin B Sundman (1988); Al-Ni' + REF128 'K. Frisk, TRITA-MAC 393 (1989); CR-N,FE-N,MO-N,CR-MO-N' + REF317 'Caian Qui and Armando Fernandez Guillermet, Trita-MAC 472 (1991); + Mn-N' + REF123 'K. Frisk, Report D 60, KTH, (1984); CR-MO' + REF319 'H. Du and M. Hillert, revision; C-Fe-N' + REF213 'P. Gustafson, TRITA-MAC 342, (1987); CR-FE-W' + REF115 'J-O Andersson, Met Trans A, Vol 19A, (1988) p 1385-1394 + TRITA 0322 (1986); CR-FE-MO' + REF326 'Byeong-Joo Lee, unpublished revision (1991), Cr-Mn' + REF90 'I Ansara, unpublished work (1991); Cr-Si' + REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 + September 1989' + REF129 'K. Frisk, TRITA-MAC 422 (1990); CR-FE-N-NI' + REF59 'B. Sundman, fix' + REF214 'P. Gustafson, TRITA-MAC 354 (1987); C-Cr-Fe-Mo-W' + REF10 'A. Fernandez Guillermet, CALPHAD Vol 6 (1982), p 127-140 + (sigma phase revised 1986), TRITA-MAC 200 (1982); FE-MO' + REF113 'J-O Andersson, Calphad Vol 12 (1988), p 9-23 + TRITA 0321 (1986); C-FE-MO' + REF125 'K. Frisk, Calphad (1990), Vol 14, p 311-320; MO-NI' + REF133 'K. Frisk, TRITA-MAC 429 (1990); CR-MO-NI' + REF132 'K. Frisk, TRITA-MAC 428 (1990); FE-MO-NI' + REF136 'Unassessed parameter, linear combination of unary data. (MU, + SIGMA)' + REF107 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 + TRITA 0270 (1986); CR-FE' + REF322 'Byeong-Joo Lee, unpublished revision (1991); C-Cr-Fe-Ni' + REF200 'P. Gustafson, Calphad Vol 11 (1987) p 277-292, + TRITA-MAC 320 (1986); CR-NI-W ' + REF261 'W. Huang, Calphad Vol 13 (1989) pp 243-252, + TRITA-MAC 388 (rev 1989); FE-MN' + REF158 'A. Dinsdale, T. Chart, MTDS NPL, unpublished work (1986); FE-NI' + REF182 'NPL, unpublished work (1989); Mn-Ni' + REF126 'K. Frisk, Metall. Trans. Vol 21A (1990) p 2477-2488, + TRITA 0409 (1989); CR-FE-N' + REF134 'K. Frisk, TRITA-MAC 433 (1990); FE-CR-MO-NI-N' + REF58 'B. Sundman, TEST' + REF117 'J-O Andersson, TRITA-MAC 323 (1986); C-CR-FE-MO' + REF162 'A. Dinsdale, T. Chart, MTDS NPL, Unpublished work (1986); CR-NI' + REF26 'A. Fernandez Guillermet, Z. Metallkde. Vol 79(1988) p.524-536, + TRITA-MAC 362 (1988); C-CO-NI AND C-CO-FE-NI' + ! + diff --git a/macros/ocv3/steel1.TDB b/macros/ocv3/steel1.TDB new file mode 100644 index 0000000..c820294 --- /dev/null +++ b/macros/ocv3/steel1.TDB @@ -0,0 +1,1210 @@ + +$ Database file written 2012- 2-11 +$ From database: SSOL2 + ELEMENT /- ELECTRON_GAS 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT VA VACUUM 0.0000E+00 0.0000E+00 0.0000E+00! + ELEMENT C GRAPHITE 1.2011E+01 1.0540E+03 5.7400E+00! + ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01! + ELEMENT FE BCC_A2 5.5847E+01 4.4890E+03 2.7280E+01! + ELEMENT MO BCC_A2 9.5940E+01 4.5890E+03 2.8560E+01! + ELEMENT SI DIAMOND_A4 2.8085E+01 3.2175E+03 1.8820E+01! + ELEMENT V BCC_A2 5.0941E+01 4.5070E+03 3.0890E+01! + + SPECIES C1 C! + SPECIES C2 C2! + SPECIES C3 C3! + SPECIES C4 C4! + SPECIES C5 C5! + SPECIES C6 C6! + SPECIES C7 C7! + SPECIES V1C1 V1C1! + + FUNCTION GHSERCC 2.98150E+02 -17368.441+170.73*T-24.3*T*LN(T) + -4.723E-04*T**2+2562600*T**(-1)-2.643E+08*T**(-2)+1.2E+10*T**(-3); + 6.00000E+03 N ! + FUNCTION GPCLIQ 2.98150E+02 +YCLIQ#*EXP(ZCLIQ#); 6.00000E+03 N ! + FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) + +.00189435*T**2-1.47721E-06*T**3+139250*T**(-1); 2.18000E+03 Y + -34869.344+344.18*T-50*T*LN(T)-2.88526E+32*T**(-9); 6.00000E+03 N ! + FUNCTION GPCRLIQ 2.98150E+02 +YCRLIQ#*EXP(ZCRLIQ#); 6.00000E+03 N ! + FUNCTION GFELIQ 2.98150E+02 +12040.17-6.55843*T-3.6751551E-21*T**7 + +GHSERFE#; 1.81100E+03 Y + -10839.7+291.302*T-46*T*LN(T); 6.00000E+03 N ! + FUNCTION GPFELIQ 2.98150E+02 +YFELIQ#*EXP(ZFELIQ#); 6.00000E+03 N ! + FUNCTION GHSERMO 2.98150E+02 -7746.302+131.9197*T-23.56414*T*LN(T) + -.003443396*T**2+5.66283E-07*T**3+65812*T**(-1)-1.30927E-10*T**4; + 2.89600E+03 Y + -30556.41+283.559746*T-42.63829*T*LN(T)-4.849315E+33*T**(-9); + 5.00000E+03 N ! + FUNCTION GPMOLIQ 2.98150E+02 +YMOLIQ#*EXP(ZMOLIQ#); 6.00000E+03 N ! + FUNCTION GHSERSI 2.98150E+02 -8162.609+137.227259*T-22.8317533*T*LN(T) + -.001912904*T**2-3.552E-09*T**3+176667*T**(-1); 1.68700E+03 Y + -9457.642+167.271767*T-27.196*T*LN(T)-4.20369E+30*T**(-9); + 3.60000E+03 N ! + FUNCTION GHSERVV 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T) + -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y + -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; + 2.18300E+03 Y + -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); + 4.00000E+03 N ! + FUNCTION GPCRBCC 2.98150E+02 +YCRBCC#*EXP(ZCRBCC#); 6.00000E+03 N ! + FUNCTION GPCGRA 2.98150E+02 +YCGRA#*EXP(ZCGRA#); 6.00000E+03 N ! + FUNCTION GHSERFE 2.98150E+02 +1225.7+124.134*T-23.5143*T*LN(T) + -.00439752*T**2-5.8927E-08*T**3+77359*T**(-1); 1.81100E+03 Y + -25383.581+299.31255*T-46*T*LN(T)+2.29603E+31*T**(-9); 6.00000E+03 N + ! + FUNCTION GPFEBCC 2.98150E+02 +YFEBCC#*EXP(ZFEBCC#); 6.00000E+03 N ! + FUNCTION GSIBCC 2.98150E+02 +47000-22.5*T+GHSERSI#; 6.00000E+03 N ! + FUNCTION GPMOBCC 2.98150E+02 +YMOBCC#*EXP(ZMOBCC#); 6.00000E+03 N ! + FUNCTION GFECEM 2.98150E+02 -10745+706.04*T-120.6*T*LN(T)+GPCEM1#; + 6.00000E+03 N ! + FUNCTION GCRFCC 2.98150E+02 +7284+.163*T+GHSERCR#; 6.00000E+03 N ! + FUNCTION GFEFCC 2.98150E+02 -1462.4+8.282*T-1.15*T*LN(T)+6.4E-04*T**2 + +GHSERFE#; 1.81100E+03 Y + -27098.266+300.25256*T-46*T*LN(T)+2.78854E+31*T**(-9); 6.00000E+03 N + ! + FUNCTION GMOFCC 2.98150E+02 +15200+.63*T+GHSERMO#; 6.00000E+03 N ! + FUNCTION GPCDIA 2.98150E+02 +YCDIA#*EXP(ZCDIA#); 6.00000E+03 N ! + FUNCTION GPCFCC 2.98150E+02 +YCFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! + FUNCTION GPFEFCC 2.98150E+02 +YFEFCC#*EXP(ZFEFCC#); 6.00000E+03 N ! + FUNCTION GHSERVZ 2.98150E+02 -7930.43+133.346053*T-24.134*T*LN(T) + -.003098*T**2+1.2175E-07*T**3+69460*T**(-1); 7.90000E+02 Y + -7967.842+143.291093*T-25.9*T*LN(T)+6.25E-05*T**2-6.8E-07*T**3; + 4.00000E+03 Y + -41689.864+321.140783*T-47.43*T*LN(T)+6.44389E+31*T**(-9); + 6.00000E+03 N ! + FUNCTION GPFEHCP 2.98150E+02 +YFEHCP#*EXP(ZFEHCP#); 6.00000E+03 N ! + FUNCTION GCRM23C6 2.98150E+02 -521983+3622.24*T-620.965*T*LN(T) + -.126431*T**2; 6.00000E+03 N ! + FUNCTION GFEM23C6 2.98150E+02 +7.666667*GFECEM#-1.666667*GHSERCC#+66920 + -40*T; 6.00000E+03 N ! + FUNCTION GVM23C6 2.98150E+02 -990367+4330.63*T-728.829*T*LN(T) + +5003425*T**(-1); 6.00000E+03 N ! + FUNCTION GCRM3C2 2.98150E+02 -100823.8+530.66989*T-89.6694*T*LN(T) + -.0301188*T**2; 6.00000E+03 N ! + FUNCTION GCRM7C3 2.98150E+02 -201690+1103.128*T-190.177*T*LN(T) + -.0578207*T**2; 6.00000E+03 N ! + FUNCTION GPMU1 2.98150E+02 +8.72E-05*P; 6.00000E+03 N ! + FUNCTION GPMU2 2.98150E+02 +1.04E-04*P; 6.00000E+03 N ! + FUNCTION GPR1 2.98150E+02 +3.81E-04*P; 6.00000E+03 N ! + FUNCTION GPR2 2.98150E+02 +4.33E-04*P; 6.00000E+03 N ! + FUNCTION GPSIG1 2.98150E+02 +1.09E-04*P; 6.00000E+03 N ! + FUNCTION GPSIG2 2.98150E+02 +1.117E-04*P; 6.00000E+03 N ! + FUNCTION L0BCC 2.98150E+02 -27809+11.62*T; 6.00000E+03 N ! + FUNCTION FESIW1 2.98150E+02 +1260*R#; 6.00000E+03 N ! + FUNCTION L1BCC 2.98150E+02 -11544; 6.00000E+03 N ! + FUNCTION L2BCC 2.98150E+02 3890; 6.00000E+03 N ! + FUNCTION ETCFESI 2.98150E+02 63; 6.00000E+03 N ! + FUNCTION YCLIQ 2.98150E+02 +VCLIQ#*EXP(-ECLIQ#); 6.00000E+03 N ! + FUNCTION ZCLIQ 2.98150E+02 +1*LN(XCLIQ#); 6.00000E+03 N ! + FUNCTION YCRLIQ 2.98150E+02 +VCRLIQ#*EXP(-ECRLIQ#); 6.00000E+03 N ! + FUNCTION ZCRLIQ 2.98150E+02 +1*LN(XCRLIQ#); 6.00000E+03 N ! + FUNCTION YFELIQ 2.98150E+02 +VFELIQ#*EXP(-EFELIQ#); 6.00000E+03 N ! + FUNCTION ZFELIQ 2.98150E+02 +1*LN(XFELIQ#); 6.00000E+03 N ! + FUNCTION YMOLIQ 2.98150E+02 +VMOLIQ#*EXP(-EMOLIQ#); 6.00000E+03 N ! + FUNCTION ZMOLIQ 2.98150E+02 +1*LN(XMOLIQ#); 6.00000E+03 N ! + FUNCTION YCRBCC 2.98150E+02 +VCRBCC#*EXP(-ECRBCC#); 6.00000E+03 N ! + FUNCTION ZCRBCC 2.98150E+02 +1*LN(XCRBCC#); 6.00000E+03 N ! + FUNCTION YCGRA 2.98150E+02 +VCGRA#*EXP(-ECGRA#); 6.00000E+03 N ! + FUNCTION ZCGRA 2.98150E+02 +1*LN(XCGRA#); 6.00000E+03 N ! + FUNCTION YFEBCC 2.98150E+02 +VFEBCC#*EXP(-EFEBCC#); 6.00000E+03 N ! + FUNCTION ZFEBCC 2.98150E+02 +1*LN(XFEBCC#); 6.00000E+03 N ! + FUNCTION YMOBCC 2.98150E+02 +VMOBCC#*EXP(-EMOBCC#); 6.00000E+03 N ! + FUNCTION ZMOBCC 2.98150E+02 +1*LN(XMOBCC#); 6.00000E+03 N ! + FUNCTION GPCEM1 2.98150E+02 +VCEM1#*P; 6.00000E+03 N ! + FUNCTION YCDIA 2.98150E+02 +VCDIA#*EXP(-ECDIA#); 6.00000E+03 N ! + FUNCTION ZCDIA 2.98150E+02 +1*LN(XCDIA#); 6.00000E+03 N ! + FUNCTION YCFCC 2.98150E+02 +VCFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! + FUNCTION ZFEFCC 2.98150E+02 +1*LN(XFEFCC#); 6.00000E+03 N ! + FUNCTION YFEFCC 2.98150E+02 +VFEFCC#*EXP(-EFEFCC#); 6.00000E+03 N ! + FUNCTION YFEHCP 2.98150E+02 +VFEHCP#*EXP(-EFEHCP#); 6.00000E+03 N ! + FUNCTION ZFEHCP 2.98150E+02 +1*LN(XFEHCP#); 6.00000E+03 N ! + FUNCTION VCLIQ 2.98150E+02 +7.626E-06*EXP(ACLIQ#); 6.00000E+03 N ! + FUNCTION ECLIQ 2.98150E+02 +1*LN(CCLIQ#); 6.00000E+03 N ! + FUNCTION XCLIQ 2.98150E+02 +1*EXP(.5*DCLIQ#)-1; 6.00000E+03 N ! + FUNCTION VCRLIQ 2.98150E+02 +7.653E-06*EXP(ACRLIQ#); 6.00000E+03 N + ! + FUNCTION ECRLIQ 2.98150E+02 +1*LN(CCRLIQ#); 6.00000E+03 N ! + FUNCTION XCRLIQ 2.98150E+02 +1*EXP(.8*DCRLIQ#)-1; 6.00000E+03 N ! + FUNCTION VFELIQ 2.98150E+02 +6.46677E-06*EXP(AFELIQ#); 6.00000E+03 + N ! + FUNCTION EFELIQ 2.98150E+02 +1*LN(CFELIQ#); 6.00000E+03 N ! + FUNCTION XFELIQ 2.98150E+02 +1*EXP(.8484467*DFELIQ#)-1; 6.00000E+03 + N ! + FUNCTION VMOLIQ 2.98150E+02 +9.75079E-06*EXP(AMOLIQ#); 6.00000E+03 + N ! + FUNCTION EMOLIQ 2.98150E+02 +1*LN(CMOLIQ#); 6.00000E+03 N ! + FUNCTION XMOLIQ 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 + N ! + FUNCTION VCRBCC 2.98150E+02 +7.188E-06*EXP(ACRBCC#); 6.00000E+03 N + ! + FUNCTION ECRBCC 2.98150E+02 +1*LN(CCRBCC#); 6.00000E+03 N ! + FUNCTION XCRBCC 2.98150E+02 +1*EXP(.8*DCRBCC#)-1; 6.00000E+03 N ! + FUNCTION VCGRA 2.98150E+02 +5.259E-06*EXP(ACGRA#); 6.00000E+03 N ! + FUNCTION ECGRA 2.98150E+02 +1*LN(CCGRA#); 6.00000E+03 N ! + FUNCTION XCGRA 2.98150E+02 +1*EXP(.9166667*DCGRA#)-1; 6.00000E+03 + N ! + FUNCTION VFEBCC 2.98150E+02 +7.042095E-06*EXP(AFEBCC#); 6.00000E+03 + N ! + FUNCTION EFEBCC 2.98150E+02 +1*LN(CFEBCC#); 6.00000E+03 N ! + FUNCTION XFEBCC 2.98150E+02 +1*EXP(.7874195*DFEBCC#)-1; 6.00000E+03 + N ! + FUNCTION VMOBCC 2.98150E+02 +9.34372E-06*EXP(AMOBCC#); 6.00000E+03 + N ! + FUNCTION EMOBCC 2.98150E+02 +1*LN(CMOBCC#); 6.00000E+03 N ! + FUNCTION XMOBCC 2.98150E+02 +1*EXP(.6923076*DMOBCC#)-1; 6.00000E+03 + N ! + FUNCTION VCEM1 2.98150E+02 +2.339E-05*EXP(ACEM1#); 6.00000E+03 N ! + FUNCTION VCDIA 2.98150E+02 +3.412E-06*EXP(ACDIA#); 6.00000E+03 N ! + FUNCTION ECDIA 2.98150E+02 +1*LN(CCDIA#); 6.00000E+03 N ! + FUNCTION XCDIA 2.98150E+02 +1*EXP(.8*DCDIA#)-1; 6.00000E+03 N ! + FUNCTION VCFCC 2.98150E+02 +1.031E-05*EXP(ACFCC#); 6.00000E+03 N ! + FUNCTION EFEFCC 2.98150E+02 +1*LN(CFEFCC#); 6.00000E+03 N ! + FUNCTION XFEFCC 2.98150E+02 +1*EXP(.8064454*DFEFCC#)-1; 6.00000E+03 + N ! + FUNCTION VFEFCC 2.98150E+02 +6.688726E-06*EXP(AFEFCC#); 6.00000E+03 + N ! + FUNCTION VFEHCP 2.98150E+02 +6.59121E-06*EXP(AFEHCP#); 6.00000E+03 + N ! + FUNCTION EFEHCP 2.98150E+02 +1*LN(CFEHCP#); 6.00000E+03 N ! + FUNCTION XFEHCP 2.98150E+02 +1*EXP(.8064454*DFEHCP#)-1; 6.00000E+03 + N ! + FUNCTION ACLIQ 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 + N ! + FUNCTION CCLIQ 2.98150E+02 1.6E-10; 6.00000E+03 N ! + FUNCTION DCLIQ 2.98150E+02 +1*LN(BCLIQ#); 6.00000E+03 N ! + FUNCTION ACRLIQ 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N + ! + FUNCTION CCRLIQ 2.98150E+02 3.72E-11; 6.00000E+03 N ! + FUNCTION DCRLIQ 2.98150E+02 +1*LN(BCRLIQ#); 6.00000E+03 N ! + FUNCTION AFELIQ 2.98150E+02 +1.135E-04*T; 6.00000E+03 N ! + FUNCTION CFELIQ 2.98150E+02 +4.22534787E-12+2.71569924E-14*T; + 6.00000E+03 N ! + FUNCTION DFELIQ 2.98150E+02 +1*LN(BFELIQ#); 6.00000E+03 N ! + FUNCTION AMOLIQ 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2 + +1.14687E-12*T**3; 6.00000E+03 N ! + FUNCTION CMOLIQ 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; + 6.00000E+03 N ! + FUNCTION DMOBCC 2.98150E+02 +1*LN(BMOBCC#); 6.00000E+03 N ! + FUNCTION ACRBCC 2.98150E+02 +1.7E-05*T+9.2E-09*T**2; 6.00000E+03 N + ! + FUNCTION CCRBCC 2.98150E+02 2.08E-11; 6.00000E+03 N ! + FUNCTION DCRBCC 2.98150E+02 +1*LN(BCRBCC#); 6.00000E+03 N ! + FUNCTION ACGRA 2.98150E+02 +2.32E-05*T+2.85E-09*T**2; 6.00000E+03 + N ! + FUNCTION CCGRA 2.98150E+02 3.3E-10; 6.00000E+03 N ! + FUNCTION DCGRA 2.98150E+02 +1*LN(BCGRA#); 6.00000E+03 N ! + FUNCTION AFEBCC 2.98150E+02 +2.3987E-05*T+1.2845E-08*T**2; + 6.00000E+03 N ! + FUNCTION CFEBCC 2.98150E+02 +2.20949565E-11+2.41329523E-16*T; + 6.00000E+03 N ! + FUNCTION DFEBCC 2.98150E+02 +1*LN(BFEBCC#); 6.00000E+03 N ! + FUNCTION AMOBCC 2.98150E+02 +1.4378E-05*T+2.33031E-10*T**2 + +1.14687E-12*T**3; 6.00000E+03 N ! + FUNCTION CMOBCC 2.98150E+02 +7.88107E-12+3.375E-16*T+8.775E-20*T**2; + 6.00000E+03 N ! + FUNCTION ACEM1 2.98150E+02 -1.36E-05*T+4E-08*T**2; 6.00000E+03 N ! + FUNCTION ACDIA 2.98150E+02 +2.43E-06*T+5E-09*T**2; 6.00000E+03 N ! + FUNCTION CCDIA 2.98150E+02 6.8E-12; 6.00000E+03 N ! + FUNCTION DCDIA 2.98150E+02 +1*LN(BCDIA#); 6.00000E+03 N ! + FUNCTION ACFCC 2.98150E+02 +1.44E-04*T; 6.00000E+03 N ! + FUNCTION CFEFCC 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; + 6.00000E+03 N ! + FUNCTION DFEFCC 2.98150E+02 +1*LN(BFEFCC#); 6.00000E+03 N ! + FUNCTION AFEFCC 2.98150E+02 +7.3097E-05*T; 6.00000E+03 N ! + FUNCTION AFEHCP 2.98150E+02 +7.3646E-05*T; 6.00000E+03 N ! + FUNCTION CFEHCP 2.98150E+02 +2.62285341E-11+2.71455808E-16*T; + 6.00000E+03 N ! + FUNCTION DFEHCP 2.98150E+02 +1*LN(BFEHCP#); 6.00000E+03 N ! + FUNCTION BCLIQ 2.98150E+02 +1+3.2E-10*P; 6.00000E+03 N ! + FUNCTION BCRLIQ 2.98150E+02 +1+4.65E-11*P; 6.00000E+03 N ! + FUNCTION BFELIQ 2.98150E+02 +1+4.98009787E-12*P+3.20078924E-14*T*P; + 6.00000E+03 N ! + FUNCTION BMOBCC 2.98150E+02 +1+1.13837E-11*P+4.875E-16*T*P + +1.2675E-19*T**2*P; 6.00000E+03 N ! + FUNCTION BCRBCC 2.98150E+02 +1+2.6E-11*P; 6.00000E+03 N ! + FUNCTION BCGRA 2.98150E+02 +1+3.6E-10*P; 6.00000E+03 N ! + FUNCTION BFEBCC 2.98150E+02 +1+2.80599565E-11*P+3.06481523E-16*T*P; + 6.00000E+03 N ! + FUNCTION BCDIA 2.98150E+02 +1+8.5E-12*P; 6.00000E+03 N ! + FUNCTION BFEFCC 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; + 6.00000E+03 N ! + FUNCTION BFEHCP 2.98150E+02 +1+3.25236341E-11*P+3.36607808E-16*T*P; + 6.00000E+03 N ! + FUNCTION UN_ASS 298.15 0; 300 N ! + + TYPE_DEFINITION % SEQ *! + DEFINE_SYSTEM_DEFAULT ELEMENT 2 ! + DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- ! + + + PHASE LIQUID:L % 1 1.0 ! + CONSTITUENT LIQUID:L :C,CR,FE,MO,SI,V : ! + + PARAMETER G(LIQUID,C;0) 2.98150E+02 +117369-24.63*T+GHSERCC#+GPCLIQ#; + 6.00000E+03 N REF283 ! + PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T + +2.37615E-21*T**7+GHSERCR#+GPCRLIQ#; 2.18000E+03 Y + +18409.36-8.563683*T+2.88526E+32*T**(-9)+GHSERCR#+GPCRLIQ#; 6.00000E+03 + N REF283 ! + PARAMETER G(LIQUID,FE;0) 2.98150E+02 +GFELIQ#+GPFELIQ#; 6.00000E+03 + N REF283 ! + PARAMETER G(LIQUID,MO;0) 2.98150E+02 +41831.347-14.694912*T + +4.24519E-22*T**7+GHSERMO#+GPMOLIQ#; 2.89600E+03 Y + +34095.373-11.890046*T+4.849315E+33*T**(-9)+GHSERMO#+GPMOLIQ#; + 5.00000E+03 N REF283 ! + PARAMETER G(LIQUID,SI;0) 2.98150E+02 +50696.36-30.099439*T + +2.09307E-21*T**7+GHSERSI#; 1.68700E+03 Y + +49828.165-29.559069*T+4.20369E+30*T**(-9)+GHSERSI#; 3.60000E+03 N + REF283 ! + PARAMETER G(LIQUID,V;0) 2.98150E+02 +20764.117-9.455552*T + -5.19136E-22*T**7+GHSERVV#; 7.90000E+02 Y + +20764.117-9.455552*T-5.19136E-22*T**7+GHSERVV#; 2.18300E+03 Y + +22072.354-10.0848*T-6.44389E+31*T**(-9)+GHSERVV#; 4.00000E+03 N REF283 ! + PARAMETER G(LIQUID,C,CR;0) 2.98150E+02 -90526-25.9116*T; 6.00000E+03 + N REF101 ! + PARAMETER G(LIQUID,C,CR;1) 2.98150E+02 80000; 6.00000E+03 N REF101 ! + PARAMETER G(LIQUID,C,CR;2) 2.98150E+02 80000; 6.00000E+03 N REF101 ! + PARAMETER G(LIQUID,C,CR,FE;0) 2.98150E+02 -496063; 6.00000E+03 N + REF322 ! + PARAMETER G(LIQUID,C,CR,FE;1) 2.98150E+02 57990; 6.00000E+03 N + REF322 ! + PARAMETER G(LIQUID,C,CR,FE;2) 2.98150E+02 61404; 6.00000E+03 N + REF322 ! + PARAMETER G(LIQUID,C,CR,V;0) 2.98150E+02 -769497; 6.00000E+03 N + REF324 ! + PARAMETER G(LIQUID,C,CR,V;1) 2.98150E+02 263981; 6.00000E+03 N + REF324 ! + PARAMETER G(LIQUID,C,CR,V;2) 2.98150E+02 3599; 6.00000E+03 N REF324 ! + PARAMETER G(LIQUID,C,FE;0) 2.98150E+02 -124320+28.5*T; 6.00000E+03 + N REF190 ! + PARAMETER G(LIQUID,C,FE;1) 2.98150E+02 19300; 6.00000E+03 N REF190 ! + PARAMETER G(LIQUID,C,FE;2) 2.98150E+02 +49260-19*T; 6.00000E+03 N + REF190 ! + PARAMETER G(LIQUID,C,FE,SI;0) 2.98150E+02 445740; 6.00000E+03 N + REF99 ! + PARAMETER G(LIQUID,C,FE,SI;1) 2.98150E+02 -6065-35.33*T; 6.00000E+03 + N REF99 ! + PARAMETER G(LIQUID,C,FE,SI;2) 2.98150E+02 +2545792-1450.6*T; + 6.00000E+03 N REF99 ! + PARAMETER G(LIQUID,C,FE,V;0) 2.98150E+02 -60000; 6.00000E+03 N + REF270 ! + PARAMETER G(LIQUID,C,FE,V;1) 2.98150E+02 -60000; 6.00000E+03 N + REF270 ! + PARAMETER G(LIQUID,C,FE,V;2) 2.98150E+02 100000; 6.00000E+03 N + REF270 ! + PARAMETER G(LIQUID,C,FE,MO;0) 2.98150E+02 -37800; 6.00000E+03 N + REF113 ! + PARAMETER G(LIQUID,C,MO;0) 2.98150E+02 -217800+38.41*T; 6.00000E+03 + N REF104 ! + PARAMETER G(LIQUID,C,MO;1) 2.98150E+02 30000; 6.00000E+03 N REF104 ! + PARAMETER G(LIQUID,C,MO;2) 2.98150E+02 47000; 6.00000E+03 N REF104 ! + PARAMETER G(LIQUID,C,SI;0) 2.98150E+02 -133000+30.97*T; 6.00000E+03 + N REF99 ! + PARAMETER G(LIQUID,C,V;0) 2.98150E+02 -284196+38.952*T; 6.00000E+03 + N REF256 ! + PARAMETER G(LIQUID,C,V;1) 2.98150E+02 +96335-17.775*T; 6.00000E+03 + N REF256 ! + PARAMETER G(LIQUID,C,V;2) 2.98150E+02 102050; 6.00000E+03 N REF256 ! + PARAMETER G(LIQUID,CR,FE;0) 2.98150E+02 -14550+6.65*T; 6.00000E+03 + N REF107 ! + PARAMETER G(LIQUID,CR,FE,V;0) 2.98150E+02 14881; 6.00000E+03 N + REF323 ! + PARAMETER G(LIQUID,CR,FE,V;1) 2.98150E+02 17968; 6.00000E+03 N + REF323 ! + PARAMETER G(LIQUID,CR,FE,V;2) 2.98150E+02 -7692; 6.00000E+03 N + REF323 ! + PARAMETER G(LIQUID,CR,MO;0) 2.98150E+02 +15810-6.714*T; 6.00000E+03 + N REF123 ! + PARAMETER G(LIQUID,CR,MO;1) 2.98150E+02 -6220; 6.00000E+03 N REF123 ! + PARAMETER G(LIQUID,CR,SI;0) 2.98150E+02 -120157.52+16.63891*T; + 6.00000E+03 N REF90 ! + PARAMETER G(LIQUID,CR,SI;1) 2.98150E+02 -49502.35+13.76967*T; + 6.00000E+03 N REF90 ! + PARAMETER G(LIQUID,CR,V;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 + N REF323 ! + PARAMETER G(LIQUID,CR,V;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 + N REF323 ! + PARAMETER G(LIQUID,FE,MO;0) 2.98150E+02 -6973-.37*T; 6.00000E+03 N + REF10 ! + PARAMETER G(LIQUID,FE,MO;1) 2.98150E+02 -9424+4.502*T; 6.00000E+03 + N REF10 ! + PARAMETER G(LIQUID,FE,SI;0) 2.98150E+02 -164435+41.977*T; 6.00000E+03 + N REF99 ! + PARAMETER G(LIQUID,FE,SI;1) 2.98150E+02 -21.523*T; 6.00000E+03 N + REF99 ! + PARAMETER G(LIQUID,FE,SI;2) 2.98150E+02 -18821+22.07*T; 6.00000E+03 + N REF99 ! + PARAMETER G(LIQUID,FE,SI;3) 2.98150E+02 9696; 6.00000E+03 N REF99 ! + PARAMETER G(LIQUID,FE,V;0) 2.98150E+02 -34679+1.895*T; 6.00000E+03 + N REF269 ! + PARAMETER G(LIQUID,FE,V;1) 2.98150E+02 10209; 6.00000E+03 N REF269 ! + + + TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! + PHASE BCC_A2 %& 2 1 3 ! + CONSTITUENT BCC_A2 :CR%,FE%,MO%,SI,V% : C,VA% : ! + + PARAMETER G(BCC_A2,CR:C;0) 2.98150E+02 +GHSERCR#+3*GHSERCC#+GPCRBCC# + +3*GPCGRA#+416000; 6.00000E+03 N REF101 ! + PARAMETER TC(BCC_A2,CR:C;0) 2.98150E+02 -311.5; 6.00000E+03 N + REF101 ! + PARAMETER BMAGN(BCC_A2,CR:C;0) 2.98150E+02 -.008; 6.00000E+03 N + REF101 ! + PARAMETER G(BCC_A2,FE:C;0) 2.98150E+02 +322050+75.667*T+GHSERFE# + +GPFEBCC#+3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF190 ! + PARAMETER TC(BCC_A2,FE:C;0) 2.98150E+02 1043; 6.00000E+03 N REF190 ! + PARAMETER BMAGN(BCC_A2,FE:C;0) 2.98150E+02 2.22; 6.00000E+03 N + REF190 ! + PARAMETER G(BCC_A2,MO:C;0) 2.98150E+02 +331000-75*T+GHSERMO#+3*GHSERCC#; + 6.00000E+03 N REF104 ! + PARAMETER G(BCC_A2,SI:C;0) 2.98150E+02 +322050-75.667*T+GSIBCC# + +3*GHSERCC#+3*GPCGRA#; 6.00000E+03 N REF98 ! + PARAMETER G(BCC_A2,V:C;0) 2.98150E+02 +108449+GHSERVV#+3*GHSERCC#; + 6.00000E+03 N REF256 ! + PARAMETER G(BCC_A2,CR:VA;0) 2.98150E+02 +GHSERCR#+GPCRBCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(BCC_A2,CR:VA;0) 2.98150E+02 -311.5; 6.00000E+03 N + REF281 ! + PARAMETER BMAGN(BCC_A2,CR:VA;0) 2.98150E+02 -.01; 6.00000E+03 N + REF281 ! + PARAMETER G(BCC_A2,FE:VA;0) 2.98150E+02 +GHSERFE#+GPFEBCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(BCC_A2,FE:VA;0) 2.98150E+02 1043; 6.00000E+03 N REF281 ! + PARAMETER BMAGN(BCC_A2,FE:VA;0) 2.98150E+02 2.22; 6.00000E+03 N + REF281 ! + PARAMETER G(BCC_A2,MO:VA;0) 2.98150E+02 +GHSERMO#+GPMOBCC#; + 5.00000E+03 N REF283 ! + PARAMETER G(BCC_A2,SI:VA;0) 2.98150E+02 +GSIBCC#; 3.60000E+03 N + REF283 ! + PARAMETER G(BCC_A2,V:VA;0) 2.98150E+02 +GHSERVV#; 4.00000E+03 N + REF283 ! + PARAMETER G(BCC_A2,CR,FE:C;0) 2.98150E+02 -1250000+667.7*T; + 6.00000E+03 N REF322 ! + PARAMETER TC(BCC_A2,CR,FE:C;0) 2.98150E+02 1650; 6.00000E+03 N + REF102 ! + PARAMETER TC(BCC_A2,CR,FE:C;1) 2.98150E+02 550; 6.00000E+03 N + REF102 ! + PARAMETER BMAGN(BCC_A2,CR,FE:C;0) 2.98150E+02 -.85; 6.00000E+03 N + REF102 ! + PARAMETER G(BCC_A2,CR:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N + REF101 ! + PARAMETER G(BCC_A2,FE,MO:C;0) 2.98150E+02 -1250000+667.7*T; + 6.00000E+03 N REF325 ! + PARAMETER TC(BCC_A2,FE,MO:C;0) 2.98150E+02 335; 6.00000E+03 N + REF104 ! + PARAMETER TC(BCC_A2,FE,MO:C;1) 2.98150E+02 526; 6.00000E+03 N + REF104 ! + PARAMETER G(BCC_A2,FE,SI:C;0) 2.98150E+02 78866; 6.00000E+03 N + REF99 ! + PARAMETER G(BCC_A2,FE,V:C;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 + N REF270 ! + PARAMETER G(BCC_A2,FE,V:C;1) 2.98150E+02 8283; 6.00000E+03 N REF270 ! + PARAMETER G(BCC_A2,FE:C,VA;0) 2.98150E+02 -190*T; 6.00000E+03 N + REF190 ! + PARAMETER G(BCC_A2,V:C,VA;0) 2.98150E+02 -297868; 6.00000E+03 N + REF256 ! + PARAMETER G(BCC_A2,CR,FE:VA;0) 2.98150E+02 +20500-9.68*T; 6.00000E+03 + N REF107 ! + PARAMETER TC(BCC_A2,CR,FE:VA;0) 2.98150E+02 1650; 6.00000E+03 N + REF107 ! + PARAMETER TC(BCC_A2,CR,FE:VA;1) 2.98150E+02 550; 6.00000E+03 N + REF107 ! + PARAMETER BMAGN(BCC_A2,CR,FE:VA;0) 2.98150E+02 -.85; 6.00000E+03 N + REF107 ! + PARAMETER G(BCC_A2,CR,FE,V:VA;0) 2.98150E+02 14881; 6.00000E+03 N + REF323 ! + PARAMETER G(BCC_A2,CR,FE,V:VA;1) 2.98150E+02 17968; 6.00000E+03 N + REF323 ! + PARAMETER G(BCC_A2,CR,FE,V:VA;2) 2.98150E+02 -7692; 6.00000E+03 N + REF323 ! + PARAMETER G(BCC_A2,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; + 6.00000E+03 N REF123 ! + PARAMETER G(BCC_A2,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 + N REF123 ! + PARAMETER G(BCC_A2,CR,SI:VA;0) 2.98150E+02 -102850.19+9.85457*T; + 6.00000E+03 N REF90 ! + PARAMETER G(BCC_A2,CR,SI:VA;1) 2.98150E+02 -49502.35+13.76967*T; + 6.00000E+03 N REF90 ! + PARAMETER G(BCC_A2,CR,V:VA;0) 2.98150E+02 -9875-2.6964*T; 6.00000E+03 + N REF323 ! + PARAMETER G(BCC_A2,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 + N REF323 ! + PARAMETER G(BCC_A2,FE,MO:VA;0) 2.98150E+02 +36818-9.141*T; + 6.00000E+03 N REF10 ! + PARAMETER G(BCC_A2,FE,MO:VA;1) 2.98150E+02 -362-5.724*T; 6.00000E+03 + N REF10 ! + PARAMETER TC(BCC_A2,FE,MO:VA;0) 2.98150E+02 335; 6.00000E+03 N + REF10 ! + PARAMETER TC(BCC_A2,FE,MO:VA;1) 2.98150E+02 526; 6.00000E+03 N + REF10 ! + PARAMETER G(BCC_A2,FE,SI:VA;0) 2.98150E+02 +4*L0BCC#-4*FESIW1#; + 6.00000E+03 N REF98 ! + PARAMETER G(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*L1BCC#; 6.00000E+03 N + REF98 ! + PARAMETER G(BCC_A2,FE,SI:VA;2) 2.98150E+02 +16*L2BCC#; 6.00000E+03 + N REF98 ! + PARAMETER TC(BCC_A2,FE,SI:VA;1) 2.98150E+02 +8*ETCFESI#; 6.00000E+03 + N REF98 ! + PARAMETER G(BCC_A2,FE,V:VA;0) 2.98150E+02 -23674+.465*T; 6.00000E+03 + N REF269 ! + PARAMETER G(BCC_A2,FE,V:VA;1) 2.98150E+02 8283; 6.00000E+03 N + REF269 ! + PARAMETER TC(BCC_A2,FE,V:VA;0) 2.98150E+02 -110; 6.00000E+03 N + REF111 ! + PARAMETER TC(BCC_A2,FE,V:VA;1) 2.98150E+02 3075; 6.00000E+03 N + REF111 ! + PARAMETER TC(BCC_A2,FE,V:VA;2) 2.98150E+02 808; 6.00000E+03 N + REF111 ! + PARAMETER TC(BCC_A2,FE,V:VA;3) 2.98150E+02 -2169; 6.00000E+03 N + REF111 ! + PARAMETER BMAGN(BCC_A2,FE,V:VA;0) 2.98150E+02 -2.26; 6.00000E+03 N + REF111 ! + + + TYPE_DEFINITION ' GES A_P_D CBCC_A12 MAGNETIC -3.0 2.80000E-01 ! + PHASE CBCC_A12 %' 2 1 1 ! + CONSTITUENT CBCC_A12 :CR,FE,SI,V : C,VA% : ! + + PARAMETER G(CBCC_A12,CR:C;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CBCC_A12,FE:C;0) 2.98150E+02 +80000+GHSERFE#+GHSERCC#; + 6.00000E+03 N REF267 ! + PARAMETER G(CBCC_A12,SI:C;0) 2.98150E+02 +1000000+566.0326*T + -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); + 3.00000E+03 N REF177 ! + PARAMETER G(CBCC_A12,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; + 6.00000E+03 N REF275 ! + PARAMETER G(CBCC_A12,CR:VA;0) 2.98150E+02 +11087+2.7196*T+GHSERCR#; + 6.00000E+03 N REF283 ! + PARAMETER G(CBCC_A12,FE:VA;0) 2.98150E+02 +4745+GHSERFE#; 6.00000E+03 + N REF283 ! + PARAMETER G(CBCC_A12,SI:VA;0) 2.98150E+02 +50208-20.377*T+GHSERSI#; + 3.60000E+03 N REF283 ! + PARAMETER G(CBCC_A12,V:VA;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CBCC_A12,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N + REF267 ! + PARAMETER G(CBCC_A12,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; + 6.00000E+03 N REF42 ! + PARAMETER G(CBCC_A12,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N + REF42 ! + PARAMETER G(CBCC_A12,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N + REF42 ! + PARAMETER G(CBCC_A12,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N + REF275 ! + + + PHASE CEMENTITE % 2 3 1 ! + CONSTITUENT CEMENTITE :CR,FE%,MO,V : C : ! + + PARAMETER G(CEMENTITE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#-48000 + -9.2888*T; 6.00000E+03 N REF322 ! + PARAMETER G(CEMENTITE,FE:C;0) 2.98150E+02 +GFECEM#; 6.00000E+03 N + REF190 ! + PARAMETER G(CEMENTITE,MO:C;0) 2.98150E+02 +3*GHSERMO#+GHSERCC#+77000 + -57.4*T; 6.00000E+03 N REF104 ! + PARAMETER G(CEMENTITE,V:C;0) 2.98150E+02 -156971+601.922*T + -100.438*T*LN(T)+765557*T**(-1); 6.00000E+03 N REF275 ! + PARAMETER G(CEMENTITE,CR,FE:C;0) 2.98150E+02 +25278-17.5*T; + 6.00000E+03 N REF322 ! + PARAMETER G(CEMENTITE,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N + REF316 ! + PARAMETER G(CEMENTITE,CR,V:C;0) 2.98150E+02 -29622-8.0892*T; + 6.00000E+03 N REF324 ! + PARAMETER G(CEMENTITE,CR,V:C;1) 2.98150E+02 -5160-7.5711*T; + 6.00000E+03 N REF324 ! + PARAMETER G(CEMENTITE,FE,V:C;0) 2.98150E+02 -45873-12.414*T; + 6.00000E+03 N REF270 ! + + + PHASE CHI_A12 % 3 24 10 24 ! + CONSTITUENT CHI_A12 :CR,FE : CR,MO : CR,FE,MO : ! + + PARAMETER G(CHI_A12,CR:CR:CR;0) 2.98150E+02 +48*GCRFCC#+10*GHSERCR# + +109000+123*T; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:CR:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR# + +24*GCRFCC#+18300-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(CHI_A12,CR:MO:CR;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# + +24*GCRFCC#-26000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:MO:CR;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO# + +24*GCRFCC#+32555-385*T; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,CR:CR:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR# + +24*GFEFCC#+500000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:CR:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERCR# + +57300-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(CHI_A12,CR:MO:FE;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# + +24*GFEFCC#+500000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:MO:FE;0) 2.98150E+02 +48*GFEFCC#+10*GHSERMO# + +305210-270*T; 6.00000E+03 N REF115 ! + PARAMETER G(CHI_A12,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERCR# + +24*GMOFCC#+500000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:CR:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERCR# + +24*GMOFCC#+100000; 6.00000E+03 N REF115 ! + PARAMETER G(CHI_A12,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+10*GHSERMO# + +24*GMOFCC#+500000; 6.00000E+03 N REF213 ! + PARAMETER G(CHI_A12,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+10*GHSERMO# + +24*GMOFCC#+97300-100*T; 6.00000E+03 N REF115 ! + + + PHASE CR2VC2 % 3 2 1 2 ! + CONSTITUENT CR2VC2 :CR : V : C : ! + + PARAMETER G(CR2VC2,CR:V:C;0) 2.98150E+02 -105987-38.2069*T+2*GHSERCR# + +GHSERVV#+2*GHSERCC#; 6.00000E+03 N REF324 ! + + + PHASE CR3SI % 2 3 1 ! + CONSTITUENT CR3SI :CR%,SI : CR,SI% : ! + + PARAMETER G(CR3SI,CR:CR;0) 2.98150E+02 +17008.82+4*T+4*GHSERCR#; + 6.00000E+03 N REF90 ! + PARAMETER G(CR3SI,SI:CR;0) 2.98150E+02 +167008.8+4*T+GHSERCR# + +3*GHSERSI#; 6.00000E+03 N REF90 ! + PARAMETER G(CR3SI,CR:SI;0) 2.98150E+02 -125456.6+4*T+3*GHSERCR# + +GHSERSI#; 6.00000E+03 N REF90 ! + PARAMETER G(CR3SI,SI:SI;0) 2.98150E+02 +24543.3+4*T+4*GHSERSI#; + 6.00000E+03 N REF90 ! + + + PHASE CR5SI3 % 2 5 3 ! + CONSTITUENT CR5SI3 :CR : SI : ! + + PARAMETER G(CR5SI3,CR:SI;0) 2.98150E+02 -318953.76+1067.49776*T + -182.57818*T*LN(T)-.02391968*T**2-2.31728E-06*T**3; 6.00000E+03 N + REF90 ! + + + PHASE CRSI % 2 1 1 ! + CONSTITUENT CRSI :CR : SI : ! + + PARAMETER G(CRSI,CR:SI;0) 2.98150E+02 -79041.68+311.75228*T + -51.62865*T*LN(T)-.00447355*T**2+391330*T**(-1); 6.00000E+03 N REF90 ! + + + PHASE CRSI2 % 2 1 2 ! + CONSTITUENT CRSI2 :CR%,SI : CR,SI% : ! + + PARAMETER G(CRSI2,CR:CR;0) 2.98150E+02 +10000+10*T+3*GHSERCR#; + 6.00000E+03 N REF90 ! + PARAMETER G(CRSI2,SI:CR;0) 2.98150E+02 +150000-T+2*GHSERCR#+GHSERSI#; + 6.00000E+03 N REF90 ! + PARAMETER G(CRSI2,CR:SI;0) 2.98150E+02 -96793.65+333.25242*T + -57.85575*T*LN(T)-.01322769*T**2-4.3203E-07*T**3; 6.00000E+03 N REF90 ! + PARAMETER G(CRSI2,SI:SI;0) 2.98150E+02 +77711.85-15.05638*T+3*GHSERSI#; + 6.00000E+03 N REF90 ! + PARAMETER G(CRSI2,CR:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; + 6.00000E+03 N REF90 ! + PARAMETER G(CRSI2,SI:CR,SI;0) 2.98150E+02 -57532.96+11.37201*T; + 6.00000E+03 N REF90 ! + + + PHASE CUB_A13 % 2 1 1 ! + CONSTITUENT CUB_A13 :CR,FE,SI,V : C,VA% : ! + + PARAMETER G(CUB_A13,CR:C;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CUB_A13,FE:C;0) 2.98150E+02 +90000+GHSERFE#+GHSERCC#; + 6.00000E+03 N REF267 ! + PARAMETER G(CUB_A13,SI:C;0) 2.98150E+02 +1000000+566.0326*T + -85.955678*T*LN(T)-.007814909*T**2+3.7239E-07*T**3+1688653*T**(-1); + 3.00000E+03 N REF177 ! + PARAMETER G(CUB_A13,V:C;0) 2.98150E+02 +10000+GHSERVV#+GHSERCC#; + 6.00000E+03 N REF275 ! + PARAMETER G(CUB_A13,CR:VA;0) 2.98150E+02 +15899+.6276*T+GHSERCR#; + 6.00000E+03 N REF283 ! + PARAMETER G(CUB_A13,FE:VA;0) 2.98150E+02 +3745+GHSERFE#; 6.00000E+03 + N REF283 ! + PARAMETER G(CUB_A13,SI:VA;0) 2.98150E+02 +47279-20.377*T+GHSERSI#; + 3.60000E+03 N REF283 ! + PARAMETER G(CUB_A13,V:VA;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(CUB_A13,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N + REF267 ! + PARAMETER G(CUB_A13,FE,SI:VA;0) 2.98150E+02 -153141+46.48*T; + 6.00000E+03 N REF42 ! + PARAMETER G(CUB_A13,FE,SI:VA;1) 2.98150E+02 -92352; 6.00000E+03 N + REF42 ! + PARAMETER G(CUB_A13,FE,SI:VA;2) 2.98150E+02 62240; 6.00000E+03 N + REF42 ! + PARAMETER G(CUB_A13,FE,V:VA;0) 2.98150E+02 -10000; 6.00000E+03 N + REF275 ! + + + PHASE DIAMOND_A4 % 1 1.0 ! + CONSTITUENT DIAMOND_A4 :C,SI% : ! + + PARAMETER G(DIAMOND_A4,C;0) 2.98150E+02 -16359.441+175.61*T + -24.31*T*LN(T)-4.723E-04*T**2+2698000*T**(-1)-2.61E+08*T**(-2) + +1.11E+10*T**(-3)+GPCDIA#; 6.00000E+03 N REF283 ! + PARAMETER G(DIAMOND_A4,SI;0) 2.98150E+02 +GHSERSI#; 3.60000E+03 N + REF283 ! + + + TYPE_DEFINITION ( GES A_P_D FCC_A1 MAGNETIC -3.0 2.80000E-01 ! + PHASE FCC_A1 %( 2 1 1 ! + CONSTITUENT FCC_A1 :CR,FE%,MO,SI,V : C,VA% : ! + + PARAMETER G(FCC_A1,CR:C;0) 2.98150E+02 +GHSERCR#+GHSERCC#+1200-1.94*T; + 6.00000E+03 N REF322 ! + PARAMETER G(FCC_A1,FE:C;0) 2.98150E+02 +77207-15.877*T+GFEFCC#+GHSERCC# + +GPCFCC#; 6.00000E+03 N REF190 ! + PARAMETER TC(FCC_A1,FE:C;0) 2.98150E+02 -201; 6.00000E+03 N REF190 ! + PARAMETER BMAGN(FCC_A1,FE:C;0) 2.98150E+02 -2.1; 6.00000E+03 N + REF190 ! + PARAMETER G(FCC_A1,MO:C;0) 2.98150E+02 -7500-8.3*T-750000*T**(-1) + +GHSERMO#+GHSERCC#; 6.00000E+03 N REF104 ! + PARAMETER G(FCC_A1,SI:C;0) 2.98150E+02 +GHSERSI#+GHSERCC#-20510+38.7*T; + 6.00000E+03 N REF98 ! + PARAMETER G(FCC_A1,V:C;0) 2.98150E+02 -117302+262.57*T-41.756*T*LN(T) + -.00557101*T**2+590546*T**(-1); 6.00000E+03 N REF256 ! + PARAMETER G(FCC_A1,CR:VA;0) 2.98150E+02 +GCRFCC#+GPCRBCC#; + 6.00000E+03 N REF281 ! + PARAMETER TC(FCC_A1,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N + REF281 ! + PARAMETER BMAGN(FCC_A1,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N + REF281 ! + PARAMETER G(FCC_A1,FE:VA;0) 2.98150E+02 +GFEFCC#+GPFEFCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(FCC_A1,FE:VA;0) 2.98150E+02 -201; 6.00000E+03 N REF281 ! + PARAMETER BMAGN(FCC_A1,FE:VA;0) 2.98150E+02 -2.1; 6.00000E+03 N + REF281 ! + PARAMETER G(FCC_A1,MO:VA;0) 2.98150E+02 +15200+.63*T+GHSERMO#+GPMOBCC#; + 5.00000E+03 N REF283 ! + PARAMETER G(FCC_A1,SI:VA;0) 2.98150E+02 +51000-21.8*T+GHSERSI#; + 3.60000E+03 N REF283 ! + PARAMETER G(FCC_A1,V:VA;0) 2.98150E+02 +7500+1.7*T+GHSERVZ#; + 4.00000E+03 N REF283 ! + PARAMETER G(FCC_A1,CR,FE:C;0) 2.98150E+02 -74319+3.2353*T; + 6.00000E+03 N REF322 ! + PARAMETER G(FCC_A1,CR,V:C;0) 2.98150E+02 +35698-50.0981*T; + 6.00000E+03 N REF324 ! + PARAMETER G(FCC_A1,CR:C,VA;0) 2.98150E+02 -11977+6.8194*T; + 6.00000E+03 N REF322 ! + PARAMETER G(FCC_A1,FE,MO:C;0) 2.98150E+02 6000; 6.00000E+03 N + REF113 ! + PARAMETER G(FCC_A1,FE,SI:C;0) 2.98150E+02 +143220+39.31*T; + 6.00000E+03 N REF99 ! + PARAMETER G(FCC_A1,FE,SI:C;1) 2.98150E+02 -216321; 6.00000E+03 N + REF99 ! + PARAMETER G(FCC_A1,FE,V:C;0) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 + N REF270 ! + PARAMETER G(FCC_A1,FE,V:C;1) 2.98150E+02 -7645.5-2.069*T; 6.00000E+03 + N REF270 ! + PARAMETER G(FCC_A1,FE,V:C,VA;0) 2.98150E+02 -40000; 6.00000E+03 N + REF270 ! + PARAMETER G(FCC_A1,FE:C,VA;0) 2.98150E+02 -34671; 6.00000E+03 N + REF190 ! + PARAMETER G(FCC_A1,MO,V:C;0) 2.98150E+02 -18000; 6.00000E+03 N + REF220 ! + PARAMETER G(FCC_A1,MO:C,VA;0) 2.98150E+02 -41300; 6.00000E+03 N + REF104 ! + PARAMETER G(FCC_A1,V:C,VA;0) 2.98150E+02 -74811+10.201*T; 6.00000E+03 + N REF256 ! + PARAMETER G(FCC_A1,V:C,VA;1) 2.98150E+02 -30394; 6.00000E+03 N + REF256 ! + PARAMETER G(FCC_A1,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; + 6.00000E+03 N REF107 ! + PARAMETER G(FCC_A1,CR,FE:VA;1) 2.98150E+02 1410; 6.00000E+03 N + REF107 ! + PARAMETER G(FCC_A1,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; + 6.00000E+03 N REF58 ! + PARAMETER G(FCC_A1,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 + N REF58 ! + PARAMETER G(FCC_A1,CR,SI:VA;0) 2.98150E+02 -122850+9.85457*T; + 6.00000E+03 N REF58 ! + PARAMETER G(FCC_A1,CR,SI:VA;1) 2.98150E+02 -49502+13.76967*T; + 6.00000E+03 N REF58 ! + PARAMETER G(FCC_A1,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 + N REF323 ! + PARAMETER G(FCC_A1,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 + N REF323 ! + PARAMETER G(FCC_A1,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; + 6.00000E+03 N REF10 ! + PARAMETER G(FCC_A1,FE,SI:VA;0) 2.98150E+02 -125248+41.116*T; + 6.00000E+03 N REF98 ! + PARAMETER G(FCC_A1,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N + REF98 ! + PARAMETER G(FCC_A1,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N + REF98 ! + PARAMETER G(FCC_A1,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 + N REF269 ! + + + PHASE FE1SI1 % 2 .5 .5 ! + CONSTITUENT FE1SI1 :FE : SI : ! + + PARAMETER G(FE1SI1,FE:SI;0) 2.98150E+02 +.5*GHSERFE#+.5*GHSERSI#-36381 + +2.22*T; 6.00000E+03 N REF98 ! + + + PHASE FE2SI % 2 .666667 .333333 ! + CONSTITUENT FE2SI :FE : SI : ! + + PARAMETER G(FE2SI,FE:SI;0) 2.98150E+02 +.6666667*GHSERFE# + +.3333333*GHSERSI#-23752-3.54*T; 6.00000E+03 N REF98 ! + + + PHASE FE4N % 2 4 1 ! + CONSTITUENT FE4N :FE : C,VA : ! + + PARAMETER G(FE4N,FE:C;0) 2.98150E+02 +15965+4*GHSERFE#+GHSERCC#; + 6.00000E+03 N REF319 ! + PARAMETER G(FE4N,FE:VA;0) 2.98150E+02 +4*GFEFCC#+10; 6.00000E+03 N + REF319 ! + + + PHASE FE5SI3 % 2 .625 .375 ! + CONSTITUENT FE5SI3 :FE : SI : ! + + PARAMETER G(FE5SI3,FE:SI;0) 2.98150E+02 +.625*GHSERFE#+.375*GHSERSI# + -30143+.27*T; 6.00000E+03 N REF98 ! + + + PHASE FE8SI2C % 3 8 2 1 ! + CONSTITUENT FE8SI2C :FE : SI : C : ! + + PARAMETER G(FE8SI2C,FE:SI:C;0) 2.98150E+02 +8*GHSERFE#+2*GHSERSI# + +GHSERCC#-231047+5.566*T; 6.00000E+03 N REF99 ! + + + PHASE FECN_CHI % 2 5 2 ! + CONSTITUENT FECN_CHI :FE : C : ! + + PARAMETER G(FECN_CHI,FE:C;0) 2.98150E+02 -11287.4+1013.78*T + -176.412*T*LN(T)+810869*T**(-1); 6.00000E+03 N REF319 ! + + + PHASE FESI2_H % 2 .3 .7 ! + CONSTITUENT FESI2_H :FE : SI : ! + + PARAMETER G(FESI2_H,FE:SI;0) 2.98150E+02 +.3*GHSERFE#+.7*GHSERSI#-19649 + -.92*T; 6.00000E+03 N REF98 ! + + + PHASE FESI2_L % 2 .333333 .666667 ! + CONSTITUENT FESI2_L :FE : SI : ! + + PARAMETER G(FESI2_L,FE:SI;0) 2.98150E+02 +.333333*GHSERFE# + +.666667*GHSERSI#-27383+3.48*T; 6.00000E+03 N REF98 ! + + + PHASE GRAPHITE % 1 1.0 ! + CONSTITUENT GRAPHITE :C : ! + + PARAMETER G(GRAPHITE,C;0) 2.98150E+02 +GHSERCC#+GPCGRA#; 6.00000E+03 + N REF283 ! + + + TYPE_DEFINITION ) GES A_P_D HCP_A3 MAGNETIC -3.0 2.80000E-01 ! + PHASE HCP_A3 %) 2 1 .5 ! + CONSTITUENT HCP_A3 :CR,FE,MO,SI,V : C,VA% : ! + + PARAMETER G(HCP_A3,CR:C;0) 2.98150E+02 +GHSERCR#+.5*GHSERCC#-18504 + +9.4173*T-2.4997*T*LN(T)+.001386*T**2; 6.00000E+03 N REF322 ! + PARAMETER G(HCP_A3,FE:C;0) 2.98150E+02 +52905-11.9075*T+GFEFCC# + +.5*GHSERCC#+GPCFCC#; 6.00000E+03 N REF190 ! + PARAMETER G(HCP_A3,MO:C;0) 2.98150E+02 -24150-3.625*T-163000*T**(-1) + +GHSERMO#+.5*GHSERCC#; 6.00000E+03 N REF104 ! + PARAMETER G(HCP_A3,SI:C;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(HCP_A3,V:C;0) 2.98150E+02 -85473+182.441*T-30.551*T*LN(T) + -.00538998*T**2+229029*T**(-1); 6.00000E+03 N REF256 ! + PARAMETER G(HCP_A3,CR:VA;0) 2.98150E+02 +4438+GHSERCR#+GPCRBCC#; + 6.00000E+03 N REF283 ! + PARAMETER TC(HCP_A3,CR:VA;0) 2.98150E+02 -1109; 6.00000E+03 N + REF281 ! + PARAMETER BMAGN(HCP_A3,CR:VA;0) 2.98150E+02 -2.46; 6.00000E+03 N + REF281 ! + PARAMETER G(HCP_A3,FE:VA;0) 2.98150E+02 -3705.78+12.591*T-1.15*T*LN(T) + +6.4E-04*T**2+GHSERFE#+GPFEHCP#; 1.81100E+03 Y + -3957.199+5.24951*T+4.9251E+30*T**(-9)+GHSERFE#+GPFEHCP#; 6.00000E+03 N + REF283 ! + PARAMETER G(HCP_A3,MO:VA;0) 2.98150E+02 +11550+GHSERMO#+GPMOBCC#; + 5.00000E+03 N REF283 ! + PARAMETER G(HCP_A3,SI:VA;0) 2.98150E+02 +49200-20.8*T+GHSERSI#; + 3.60000E+03 N REF283 ! + PARAMETER G(HCP_A3,V:VA;0) 2.98150E+02 +4000+2.4*T+GHSERVZ#; + 4.00000E+03 N REF283 ! + PARAMETER G(HCP_A3,CR,FE,MO:C;0) 2.98150E+02 -57062; 6.00000E+03 N + REF316 ! + PARAMETER G(HCP_A3,CR,MO:C;0) 2.98150E+02 -3905+18.5304*T; + 6.00000E+03 N REF316 ! + PARAMETER G(HCP_A3,CR,V:C;0) 2.98150E+02 +17165-9.9072*T; 6.00000E+03 + N REF323 ! + PARAMETER G(HCP_A3,CR:C,VA;0) 2.98150E+02 4165; 6.00000E+03 N + REF207 ! + PARAMETER G(HCP_A3,FE,MO:C;0) 2.98150E+02 +13030-33.8*T; 6.00000E+03 + N REF113 ! + PARAMETER G(HCP_A3,FE,V:C;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 + N REF270 ! + PARAMETER G(HCP_A3,FE:C,VA;0) 2.98150E+02 -22126; 6.00000E+03 N + REF319 ! + PARAMETER G(HCP_A3,MO:C,VA;0) 2.98150E+02 4150; 6.00000E+03 N + REF104 ! + PARAMETER G(HCP_A3,V:C,VA;0) 2.98150E+02 +12430-3.986*T; 6.00000E+03 + N REF256 ! + PARAMETER G(HCP_A3,CR,FE:VA;0) 2.98150E+02 +10833-7.477*T; + 6.00000E+03 N REF126 ! + PARAMETER G(HCP_A3,CR,MO:VA;0) 2.98150E+02 +28890-7.962*T; + 6.00000E+03 N REF117 ! + PARAMETER G(HCP_A3,CR,MO:VA;1) 2.98150E+02 +5974-2.428*T; 6.00000E+03 + N REF117 ! + PARAMETER G(HCP_A3,CR,V:VA;0) 2.98150E+02 -9874-2.6964*T; 6.00000E+03 + N REF323 ! + PARAMETER G(HCP_A3,CR,V:VA;1) 2.98150E+02 -1720-2.5237*T; 6.00000E+03 + N REF323 ! + PARAMETER G(HCP_A3,FE,MO:VA;0) 2.98150E+02 +28347-17.691*T; + 6.00000E+03 N REF10 ! + PARAMETER G(HCP_A3,FE,SI:VA;0) 2.98150E+02 -123468+41.116*T; + 6.00000E+03 N REF42 ! + PARAMETER G(HCP_A3,FE,SI:VA;1) 2.98150E+02 -142708; 6.00000E+03 N + REF42 ! + PARAMETER G(HCP_A3,FE,SI:VA;2) 2.98150E+02 89907; 6.00000E+03 N + REF42 ! + PARAMETER G(HCP_A3,FE,V:VA;0) 2.98150E+02 -15291-4.138*T; 6.00000E+03 + N REF270 ! + + + PHASE KSI_CARBIDE % 2 3 1 ! + CONSTITUENT KSI_CARBIDE :CR,FE,MO% : C : ! + + PARAMETER G(KSI_CARBIDE,CR:C;0) 2.98150E+02 +3*GHSERCR#+GHSERCC#+114060 + -47.2519*T; 6.00000E+03 N REF316 ! + PARAMETER G(KSI_CARBIDE,FE:C;0) 2.98150E+02 +14540+20*T+3*GHSERFE# + +GHSERCC#; 6.00000E+03 N REF113 ! + PARAMETER G(KSI_CARBIDE,MO:C;0) 2.98150E+02 +167009-33*T+3*GHSERMO# + +GHSERCC#; 6.00000E+03 N REF113 ! + PARAMETER G(KSI_CARBIDE,CR,FE:C;0) 2.98150E+02 -139900; 6.00000E+03 + N REF316 ! + PARAMETER G(KSI_CARBIDE,CR,MO:C;0) 2.98150E+02 -348033; 6.00000E+03 + N REF316 ! + PARAMETER G(KSI_CARBIDE,FE,MO:C;0) 2.98150E+02 -380000; 6.00000E+03 + N REF113 ! + + + PHASE LAVES_PHASE % 2 2 1 ! + CONSTITUENT LAVES_PHASE :CR,FE : MO : ! + + PARAMETER G(LAVES_PHASE,CR:MO;0) 2.98150E+02 +2*GCRFCC#+GHSERMO#-8000 + -6*T; 6.00000E+03 N REF214 ! + PARAMETER G(LAVES_PHASE,FE:MO;0) 2.98150E+02 -10798-.132*T+2*GFEFCC# + +GHSERMO#; 6.00000E+03 N REF10 ! + + + PHASE M23C6 % 3 20 3 6 ! + CONSTITUENT M23C6 :CR%,FE%,V : CR%,FE%,MO%,V : C : ! + + PARAMETER G(M23C6,CR:CR:C;0) 2.98150E+02 +GCRM23C6#; 6.00000E+03 N + REF102 ! + PARAMETER G(M23C6,FE:CR:C;0) 2.98150E+02 +.1304348*GCRM23C6# + +.8695652*GFEM23C6#; 6.00000E+03 N REF102 ! + PARAMETER G(M23C6,V:CR:C;0) 2.98150E+02 +.869565*GVM23C6# + +.130435*GCRM23C6#; 6.00000E+03 N REF323 ! + PARAMETER G(M23C6,CR:FE:C;0) 2.98150E+02 +.8695652*GCRM23C6# + +.1304348*GFEM23C6#; 6.00000E+03 N REF102 ! + PARAMETER G(M23C6,FE:FE:C;0) 2.98150E+02 +GFEM23C6#; 6.00000E+03 N + REF102 ! + PARAMETER G(M23C6,V:FE:C;0) 2.98150E+02 +.869565*GVM23C6# + +.130435*GFEM23C6#; 6.00000E+03 N REF323 ! + PARAMETER G(M23C6,CR:MO:C;0) 2.98150E+02 +20*GHSERCR#+3*GHSERMO# + +6*GHSERCC#-439117-50.0535*T; 6.00000E+03 N REF316 ! + PARAMETER G(M23C6,FE:MO:C;0) 2.98150E+02 +20*GHSERFE#+3*GHSERMO# + +6*GHSERCC#-76351-5.095*T; 6.00000E+03 N REF316 ! + PARAMETER G(M23C6,V:MO:C;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(M23C6,CR:V:C;0) 2.98150E+02 +.869565*GCRM23C6# + +.130435*GVM23C6#; 6.00000E+03 N REF323 ! + PARAMETER G(M23C6,FE:V:C;0) 2.98150E+02 +.869565*GFEM23C6# + +.130435*GVM23C6#; 6.00000E+03 N REF323 ! + PARAMETER G(M23C6,V:V:C;0) 2.98150E+02 +GVM23C6#; 6.00000E+03 N + REF323 ! + PARAMETER G(M23C6,CR,FE:CR:C;0) 2.98150E+02 -205342+141.6667*T; + 6.00000E+03 N REF322 ! + PARAMETER G(M23C6,CR,FE,V:CR:C;0) 2.98150E+02 -1499585; 6.00000E+03 + N REF324 ! + PARAMETER G(M23C6,CR,V:CR:C;0) 2.98150E+02 -385502; 6.00000E+03 N + REF324 ! + PARAMETER G(M23C6,CR,FE:FE:C;0) 2.98150E+02 -205342+141.6667*T; + 6.00000E+03 N REF322 ! + PARAMETER G(M23C6,CR,FE,V:FE:C;0) 2.98150E+02 -1499585; 6.00000E+03 + N REF324 ! + PARAMETER G(M23C6,CR,V:FE:C;0) 2.98150E+02 -385502; 6.00000E+03 N + REF324 ! + PARAMETER G(M23C6,CR,FE:MO:C;0) 2.98150E+02 -177850+153.905*T; + 6.00000E+03 N REF316 ! + PARAMETER G(M23C6,CR,FE:V:C;0) 2.98150E+02 -205342+141.6667*T; + 6.00000E+03 N REF324 ! + PARAMETER G(M23C6,CR,FE,V:V:C;0) 2.98150E+02 -1499585; 6.00000E+03 + N REF324 ! + PARAMETER G(M23C6,CR,V:V:C;0) 2.98150E+02 -385502; 6.00000E+03 N + REF324 ! + + + PHASE M3C2 % 2 3 2 ! + CONSTITUENT M3C2 :CR,MO,V : C : ! + + PARAMETER G(M3C2,CR:C;0) 2.98150E+02 +GCRM3C2#; 6.00000E+03 N + REF322 ! + PARAMETER G(M3C2,MO:C;0) 2.98150E+02 +3*GHSERMO#+2*GHSERCC#+27183; + 6.00000E+03 N REF316 ! + PARAMETER G(M3C2,V:C;0) 2.98150E+02 -222500+16.6545*T+3*GHSERVV# + +2*GHSERCC#; 6.00000E+03 N REF324 ! + PARAMETER G(M3C2,CR,MO:C;0) 2.98150E+02 40000; 6.00000E+03 N REF316 ! + PARAMETER G(M3C2,CR,V:C;0) 2.98150E+02 21072; 6.00000E+03 N REF324 ! + + + PHASE M3SI % 2 3 1 ! + CONSTITUENT M3SI :FE : SI : ! + + PARAMETER G(M3SI,FE:SI;0) 2.98150E+02 +3*GHSERFE#+GHSERSI#-94274-3.56*T; + 6.00000E+03 N REF42 ! + + + PHASE M5C2 % 2 5 2 ! + CONSTITUENT M5C2 :FE,V : C : ! + + PARAMETER G(M5C2,FE:C;0) 2.98150E+02 +5*GHSERFE#+2*GHSERCC#+54852 + -33.7518*T; 6.00000E+03 N REF322 ! + PARAMETER G(M5C2,V:C;0) 2.98150E+02 -307123.3+1059.7*T-175.66*T*LN(T) + +1453274*T**(-1); 6.00000E+03 N REF275 ! + + + PHASE M6C % 4 2 2 2 1 ! + CONSTITUENT M6C :FE : MO : CR,FE,MO,V : C : ! + + PARAMETER G(M6C,FE:MO:CR:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERCR# + +2*GHSERMO#+GHSERCC#-25298-54.8698*T; 6.00000E+03 N REF316 ! + PARAMETER G(M6C,FE:MO:FE:C;0) 2.98150E+02 +4*GHSERFE#+2*GHSERMO# + +GHSERCC#+77705-101.5*T; 6.00000E+03 N REF113 ! + PARAMETER G(M6C,FE:MO:MO:C;0) 2.98150E+02 +2*GHSERFE#+4*GHSERMO# + +GHSERCC#-122410+30.25*T; 6.00000E+03 N REF113 ! + PARAMETER G(M6C,FE:MO:V:C;0) 2.98150E+02 +2*GHSERFE#+2*GHSERMO# + +2*GHSERVV#+GHSERCC#-173000; 6.00000E+03 N REF220 ! + PARAMETER G(M6C,FE:MO:FE,MO:C;0) 2.98150E+02 -37700; 6.00000E+03 N + REF113 ! + + + PHASE M7C3 % 2 7 3 ! + CONSTITUENT M7C3 :CR%,FE,MO,V : C : ! + + PARAMETER G(M7C3,CR:C;0) 2.98150E+02 +GCRM7C3#; 6.00000E+03 N + REF322 ! + PARAMETER G(M7C3,FE:C;0) 2.98150E+02 +7*GHSERFE#+3*GHSERCC#+75000 + -48.2168*T; 6.00000E+03 N REF322 ! + PARAMETER G(M7C3,MO:C;0) 2.98150E+02 +7*GHSERMO#+3*GHSERCC#-140415 + +24.24*T; 6.00000E+03 N REF316 ! + PARAMETER G(M7C3,V:C;0) 2.98150E+02 -454245+1518.48*T-250.981*T*LN(T) + +2148691*T**(-1); 6.00000E+03 N REF324 ! + PARAMETER G(M7C3,CR,FE:C;0) 2.98150E+02 -4520-10*T; 6.00000E+03 N + REF322 ! + PARAMETER G(M7C3,CR,FE,V:C;0) 2.98150E+02 -250158; 6.00000E+03 N + REF324 ! + PARAMETER G(M7C3,CR,MO:C;0) 2.98150E+02 165280; 6.00000E+03 N + REF316 ! + PARAMETER G(M7C3,CR,V:C;0) 2.98150E+02 -110271; 6.00000E+03 N + REF324 ! + + + PHASE MC_ETA % 2 1 1 ! + CONSTITUENT MC_ETA :MO% : C%,VA : ! + + PARAMETER G(MC_ETA,MO:C;0) 2.98150E+02 -9100-5.35*T-750000*T**(-1) + +GHSERMO#+GHSERCC#; 6.00000E+03 N REF113 ! + PARAMETER G(MC_ETA,MO:VA;0) 2.98150E+02 +GHSERMO#+15200+.63*T; + 6.00000E+03 N REF113 ! + PARAMETER G(MC_ETA,MO:C,VA;0) 2.98150E+02 -59500; 6.00000E+03 N + REF104 ! + + + PHASE MC_SHP % 2 1 1 ! + CONSTITUENT MC_SHP :MO : C : ! + + PARAMETER G(MC_SHP,MO:C;0) 2.98150E+02 -32983+2.5*T+GHSERMO#+GHSERCC#; + 6.00000E+03 N REF104 ! + + + PHASE MONI_DELTA % 3 24 20 12 ! + CONSTITUENT MONI_DELTA :CR,FE : CR,FE,MO : MO : ! + + PARAMETER G(MONI_DELTA,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR# + +12*GHSERMO#+50000; 6.00000E+03 N REF133 ! + PARAMETER G(MONI_DELTA,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(MONI_DELTA,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(MONI_DELTA,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE# + +12*GHSERMO#+100000; 6.00000E+03 N REF132 ! + PARAMETER G(MONI_DELTA,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO# + +100000; 6.00000E+03 N REF133 ! + PARAMETER G(MONI_DELTA,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO# + +100000; 6.00000E+03 N REF132 ! + + + PHASE MU_PHASE % 3 7 2 4 ! + CONSTITUENT MU_PHASE :CR,FE : MO : CR,FE,MO : ! + + PARAMETER G(MU_PHASE,CR:MO:CR;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# + +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(MU_PHASE,FE:MO:CR;0) 2.98150E+02 +7*GFEFCC#+2*GHSERMO# + +4*GHSERCR#+130000-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(MU_PHASE,CR:MO:FE;0) 2.98150E+02 +7*GCRFCC#+2*GHSERMO# + +4*GHSERFE#+130000-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(MU_PHASE,FE:MO:FE;0) 2.98150E+02 +39475-6.032*T+7*GFEFCC# + +2*GHSERMO#+4*GHSERFE#+GPMU1#; 6.00000E+03 N REF10 ! + PARAMETER G(MU_PHASE,CR:MO:MO;0) 2.98150E+02 +7*GCRFCC#+6*GHSERMO# + +130000-100*T; 6.00000E+03 N REF115 ! + PARAMETER G(MU_PHASE,FE:MO:MO;0) 2.98150E+02 -46663-5.891*T+7*GFEFCC# + +6*GHSERMO#+GPMU2#; 6.00000E+03 N REF10 ! + PARAMETER G(MU_PHASE,CR,FE:MO:MO;0) 2.98150E+02 -45000; 6.00000E+03 + N REF115 ! + + + PHASE P_PHASE % 3 24 20 12 ! + CONSTITUENT P_PHASE :CR,FE : CR,FE,MO : MO : ! + + PARAMETER G(P_PHASE,CR:CR:MO;0) 2.98150E+02 +24*GCRFCC#+20*GHSERCR# + +12*GHSERMO#+252300-100*T; 6.00000E+03 N REF133 ! + PARAMETER G(P_PHASE,FE:CR:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(P_PHASE,CR:FE:MO;0) 298.15 UN_ASS; 300 N REF0 ! + PARAMETER G(P_PHASE,FE:FE:MO;0) 2.98150E+02 +24*GFEFCC#+20*GHSERFE# + +12*GHSERMO#+111361; 6.00000E+03 N REF132 ! + PARAMETER G(P_PHASE,CR:MO:MO;0) 2.98150E+02 +24*GCRFCC#+32*GHSERMO# + +95573-200*T; 6.00000E+03 N REF133 ! + PARAMETER G(P_PHASE,FE:MO:MO;0) 2.98150E+02 +24*GFEFCC#+32*GHSERMO# + +362525-332.7*T; 6.00000E+03 N REF132 ! + + + PHASE R_PHASE % 3 27 14 12 ! + CONSTITUENT R_PHASE :CR,FE : MO : CR,FE,MO : ! + + PARAMETER G(R_PHASE,CR:MO:CR;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO# + +12*GHSERCR#-20000; 6.00000E+03 N REF115 ! + PARAMETER G(R_PHASE,FE:MO:CR;0) 2.98150E+02 +27*GFEFCC#+14*GHSERMO# + +12*GHSERCR#+600260-620*T; 6.00000E+03 N REF115 ! + PARAMETER G(R_PHASE,CR:MO:FE;0) 2.98150E+02 +27*GCRFCC#+14*GHSERMO# + +12*GHSERFE#+645260-620*T; 6.00000E+03 N REF115 ! + PARAMETER G(R_PHASE,FE:MO:FE;0) 2.98150E+02 -77487-50.486*T+27*GFEFCC# + +14*GHSERMO#+12*GHSERFE#+GPR1#; 6.00000E+03 N REF10 ! + PARAMETER G(R_PHASE,CR:MO:MO;0) 2.98150E+02 +27*GCRFCC#+26*GHSERMO# + -20000; 6.00000E+03 N REF115 ! + PARAMETER G(R_PHASE,FE:MO:MO;0) 2.98150E+02 +313474-289.472*T + +27*GFEFCC#+26*GHSERMO#+GPR2#; 6.00000E+03 N REF10 ! + + + PHASE SIC % 2 1 1 ! + CONSTITUENT SIC :SI : C : ! + + PARAMETER G(SIC,SI:C;0) 2.98150E+02 -85572.2636+173.200518*T + -25.856*T*LN(T)-.02106825*T**2+3.2153E-06*T**3+438415*T**(-1); + 7.00000E+02 Y + -95145.9018+300.345769*T-45.093*T*LN(T)-.00366815*T**2 + +2.19983333E-07*T**3+1341065*T**(-1); 2.10000E+03 Y + -105007.971+360.308813*T-53.073*T*LN(T)-7.4525E-04*T**2 + +1.73166667E-08*T**3+3693345*T**(-1); 4.00000E+03 N REF286 ! + + + PHASE SIGMA % 3 8 4 18 ! + CONSTITUENT SIGMA :FE : CR,MO,V : CR,FE,MO,V : ! + + PARAMETER G(SIGMA,FE:CR:CR;0) 2.98150E+02 +8*GFEFCC#+22*GHSERCR#+92300 + -95.96*T+GPSIG1#; 6.00000E+03 N REF107 ! + PARAMETER G(SIGMA,FE:MO:CR;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO# + +18*GHSERCR#+488480-360*T; 6.00000E+03 N REF115 ! + PARAMETER G(SIGMA,FE:V:CR;0) 2.98150E+02 +155735-89.5976*T+8*GFEFCC# + +4*GHSERVV#+18*GHSERCR#; 6.00000E+03 N REF323 ! + PARAMETER G(SIGMA,FE:CR:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# + +18*GHSERFE#+117300-95.96*T+GPSIG2#; 6.00000E+03 N REF107 ! + PARAMETER G(SIGMA,FE:MO:FE;0) 2.98150E+02 -1813-27.272*T+8*GFEFCC# + +18*GHSERFE#+4*GHSERMO#; 6.00000E+03 N REF10 ! + PARAMETER G(SIGMA,FE:V:FE;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV# + +18*GHSERFE#-157961+60.729*T; 6.00000E+03 N REF269 ! + PARAMETER G(SIGMA,FE:CR:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERCR# + +18*GHSERMO#+312580-260*T; 6.00000E+03 N REF115 ! + PARAMETER G(SIGMA,FE:MO:MO;0) 2.98150E+02 +83326-69.618*T+8*GFEFCC# + +22*GHSERMO#; 6.00000E+03 N REF10 ! + PARAMETER G(SIGMA,FE:V:MO;0) 2.98150E+02 +8*GFEFCC#+4*GHSERVV# + +18*GHSERMO#; 6.00000E+03 N REF136 ! + PARAMETER G(SIGMA,FE:CR:V;0) 2.98150E+02 -245761-67.3294*T+8*GFEFCC# + +4*GHSERCR#+18*GHSERVV#; 6.00000E+03 N REF323 ! + PARAMETER G(SIGMA,FE:MO:V;0) 2.98150E+02 +8*GFEFCC#+4*GHSERMO# + +18*GHSERVV#; 6.00000E+03 N REF136 ! + PARAMETER G(SIGMA,FE:V:V;0) 2.98150E+02 +8*GFEFCC#+22*GHSERVV#-205321 + -60.967*T; 6.00000E+03 N REF269 ! + PARAMETER G(SIGMA,FE:CR:CR,MO;0) 2.98150E+02 -148000; 6.00000E+03 N + REF115 ! + PARAMETER G(SIGMA,FE:MO:CR,MO;0) 2.98150E+02 121000; 6.00000E+03 N + REF115 ! + PARAMETER G(SIGMA,FE:CR:FE,MO;0) 2.98150E+02 570000; 6.00000E+03 N + REF115 ! + PARAMETER G(SIGMA,FE:CR:FE,V;0) 2.98150E+02 -235158; 6.00000E+03 N + REF323 ! + PARAMETER G(SIGMA,FE:MO:FE,MO;0) 2.98150E+02 222909; 6.00000E+03 N + REF10 ! + PARAMETER G(SIGMA,FE:V:FE,V;0) 2.98150E+02 -305784; 6.00000E+03 N + REF269 ! + + + PHASE V3C2 % 2 3 2 ! + CONSTITUENT V3C2 :FE,V : C : ! + + PARAMETER G(V3C2,FE:C;0) 2.98150E+02 +7250+741.566*T-125.833*T*LN(T) + +779485*T**(-1); 6.00000E+03 N REF275 ! + PARAMETER G(V3C2,V:C;0) 2.98150E+02 -260341+16.897*T+3*GHSERVV# + +2*GHSERCC#; 6.00000E+03 N REF256 ! + + LIST_OF_REFERENCES + NUMBER SOURCE + REF283 'Alan Dinsdale, SGTE Data for Pure Elements, + Calphad Vol 15(1991) p 317-425, + also in NPL Report DMA(A)195 Rev. August 1990' + REF101 'J-O Andersson, Calphad Vol 11 (1987) p 271-276, TRITA 0314; C-CR' + REF190 'P. Gustafson, Scan. J. Metall. vol 14, (1985) p 259-267 + TRITA 0237 (1984); C-FE' + REF104 'J-O Andersson, Calphad Vol 12 (1988) p 1-8 TRITA 0317 (1986); C + -MO' + REF98 'J. Lacaze and B. Sundman, provisional; Fe-Si' + REF256 'W. Huang, TRITA-MAC 431 (1990); C-V' + REF267 'W. Huang, Metall. Trans. Vol 21A(1990) p 2115-2123, + TRITA-MAC 411 (Rev 1989); C-FE-MN' + REF177 'NPL, unpublished work (1989); C-Mn-Si' + REF275 'W. Huang, TRITA-MAC 441 (1990), Fe-Mn-V-C *' + REF322 'Byeong-Joo Lee, unpublished revision (1991); C-Cr-Fe-Ni' + REF213 'P. Gustafson, TRITA-MAC 342, (1987); CR-FE-W' + REF115 'J-O Andersson, Met Trans A, Vol 19A, (1988) p 1385-1394 + TRITA 0322 (1986); CR-FE-MO' + REF324 'Byeong-Joo Lee, TRITA-MAC 475 (1991), C-Cr-Fe-V' + REF90 'I Ansara, unpublished work (1991); Cr-Si' + REF281 'Alan Dinsdale, SGTE Data for Pure Elements, NPL Report DMA(A)195 + September 1989' + REF319 'H. Du and M. Hillert, revision; C-Fe-N' + REF99 'J. Lacaze and B. Sundman, Met. Trans A, Vol 22A (1991) + pp 2211-2223; C-Fe-Si' + REF316 'Caian Qui, Trita-MAC 482 (1992) Revision ; C-Cr-Fe-Mo' + REF113 'J-O Andersson, Calphad Vol 12 (1988), p 9-23 + TRITA 0321 (1986); C-FE-MO' + REF214 'P. Gustafson, TRITA-MAC 354 (1987); C-Cr-Fe-Mo-W' + REF10 'A. Fernandez Guillermet, CALPHAD Vol 6 (1982), p 127-140 + (sigma phase revised 1986), TRITA-MAC 200 (1982); FE-MO' + REF102 'J-O Andersson, Met. Trans A, Vol 19A, (1988) p 627-636 + TRITA 0207 (1986); C-CR-FE' + REF323 'Byeong-Joo Lee, TRITA-MAC 474 (1991), Cr-Fe-V' + REF42 'Annika Forsberg and John ]gren, TRITA-MAC 483 (1992); Fe-Mn-Si' + REF220 'P Gustafson, Inst. Met. Res. (Sweden) (1990); Estimations of + C-CR-FE-V, C-CR-FE-MO-V-W, FE-N-W, FE-MN-N, FE-N-SI, CR-N-V, C-CR + -N, + FE-MO-N, CR-N-W, CR-TI-N' + REF133 'K. Frisk, TRITA-MAC 429 (1990); CR-MO-NI' + REF132 'K. Frisk, TRITA-MAC 428 (1990); FE-MO-NI' + REF286 'SGTE Substance database, AUG 1989.' + REF107 'J-O Andersson, B. Sundman, CALPHAD Vol 11, (1987), p 83-92 + TRITA 0270 (1986); CR-FE' + REF269 'W. Huang, TRITA-MAC 432 (Rev 1989,1990); FE-V' + REF136 'Unassessed parameter, linear combination of unary data. (MU, + SIGMA)' + REF123 'K. Frisk, Report D 60, KTH, (1984); CR-MO' + REF325 'Byeong-Joo Lee, unpublished revision (1991), C-Cr-Fe-Mo-Ni' + REF270 'W. Huang, TRITA-MAC 432 (1990); C-Fe-V' + REF58 'B. Sundman, TEST' + REF207 'P. Gustafson, Metall. Trans. 19A(1988) p 2547-2554, + TRITA-MAC 348, (1987); C-CR-FE-W' + REF126 'K. Frisk, Metall. Trans. Vol 21A (1990) p 2477-2488, + TRITA 0409 (1989); CR-FE-N' + REF117 'J-O Andersson, TRITA-MAC 323 (1986); C-CR-FE-MO' + REF111 'J-O Andersson, CALPHAD Vol 7, (1983), p 305-315 (parameters + revised + 1986 due to new decription of V) TRITA 0201 (1982); FE-V' + ! + diff --git a/macros/ocv3/step1.OCM b/macros/ocv3/step1.OCM new file mode 100644 index 0000000..943760d --- /dev/null +++ b/macros/ocv3/step1.OCM @@ -0,0 +1,125 @@ +@$ Calculating property diagrams for a High Speed Steel (HSS) +@& + +set echo + +r t steel1 + +set c t=1200 p=1e5 n=1 w(c)=.009 w(cr)=.045, w(mo)=.1 w(si)=.001 w(v)=.009 + +@$ Enter a composition set for the MC carbide (FCC) +amend phase fcc comp_set y MC , +NONE +<.1 +NONE +<.1 +NONE +>.5 +<.2 + +@$ Set the default constitution for the FCC to be austenite +amend phase fcc default +<.2 +NONE +<.2 +<.1 +<.2 +<.2 +>.5 + +@$ Enter a composition set for the M2C carbide (HCP) +amend phase hcp comp_set y M2C , +NONE +NONE +NONE +NONE +NONE +>.5 +<.2 + +c e + +l r 1 + +@& + +l r 4 + +@& + +set axis 1 T 800 1800 10 + +l ax + +@& + +step + + + + + +@& + +l line + +@& + +l eq + +plot +T +NP(*) +title +step 1 fig 1 +render + + +@$ move the line identification out of the plot +plot + + +? +position outside right +title step 1 fig 2 +render + +plot +T +w(*,cr) +title step 1 fig 3 +render + +plot +T +H +title step 1 fig 4 +render + + +ent sym cp=hm.t; + + + +plot +T +cp +title step 1 fig 5 +render + +@$ scaling of y axis + +plot +T +cp +yr +N +0 +200 +title step 1 fig 6 +position off +render + + +set inter + diff --git a/macros/ocv3/step2.OCM b/macros/ocv3/step2.OCM new file mode 100644 index 0000000..23c82da --- /dev/null +++ b/macros/ocv3/step2.OCM @@ -0,0 +1,40 @@ +@$ Calculating G curves for the phases in Ag-Cu +@& + +set echo + +r t agcu + + +set cond t=1000 p=1e5 n=1 x(cu)=.2 + +c e + +l r 1 + +@& + +set ref ag fcc,,,,, +set ref cu fcc,,,,,, + +set ax 1 x(cu) 0 1 ,,, + +l ax + +l sh + + +@& + +step +sep + +@& + +plot +x(cu) +G(*) +title step2 fig 1 +render + +set inter diff --git a/macros/ocv3/step3.OCM b/macros/ocv3/step3.OCM new file mode 100644 index 0000000..831b672 --- /dev/null +++ b/macros/ocv3/step3.OCM @@ -0,0 +1,64 @@ +@$ +@$ Calculating speciation in a gas phase and plot y, H and Cp +@& + +set echo + +r t hogas + +l d,,,,, + + +set c t=3000 p=1e5 n(h)=2 n(o)=1 + +c e + +l,,,,, + +set ax 1 t 1000 6000 25 + +step + + +@& + +plot +T +y(gas,*) +title step3 fig 1 +render + +plot + + +position bottom left +title step3 fig 2 +render + + +plot +T +H +title step3 fig 3 +render + +plot + + +position off +title step3 fig 4 +render + + +ent symb cp=h.t; + +plot +T +cp +title step3 fig 5 +render + + + +set inter + diff --git a/macros/ocv3/step4.OCM b/macros/ocv3/step4.OCM new file mode 100644 index 0000000..0dade7b --- /dev/null +++ b/macros/ocv3/step4.OCM @@ -0,0 +1,147 @@ +@$ +@$ Calculate G curves in the ordered FCC in the Fe-Ni system +@$ +@& + +set echo + +@$ Enter the elements and their reference states +enter element Fe Iron BCC 55.847 0 0 + +enter element Ni Nickel FCC 58.69 0 0 + +@$ These functions describe the end-member energies at Fe3Ni, Fe2Ni2 and FeNi3 +@$ respectivly. The VASP energies relative to pure Fe amd Ni as fcc are: +@$ Fe3Ni1 -0.071689 eV for 1 atom?? +@$ Fe2Ni2 -0.138536 eV for 1 atom?? +@$ Fe1Ni3 -0.125748 eV for 1 atom?? +@$ To modify to J/mol atoms multiply with 96500 +@$ bond energy multiplied with 3, 4 and 3 respectively. + +enter tp-sym evtoj constant 96500 + +enter tp-sym GA3B1 fun 1 -0.071689*evtoj;,,,,, +enter tp-sym GA2B2 fun 1 -0.138536*evtoj;,,,,, +enter tp-sym GA1B3 fun 1 -0.125748*evtoj;,,,,, + +@$ We may have to use some regular solution parameter later +enter tp-sym L0 fun 1 12000; ,,,,, +enter tp-sym L1 fun 1 0; ,,,,, +enter tp-sym L2 fun 1 0; ,,,,, + +@$ this is an approximate SRO contribution to the LRO phase. It is +@$ set to about a quater of the L1_0 ordering energy, +@$ equal to the Fe-Ni bond energy +enter tp-sym GSRO fun 1 -0.034*evtoj;,,,,, + +@$ ================================================== +@$ This is an fcc phase with lro but no explicit sro +@$ described with the sublattice model +enter phase PARTITIONED_FCC 4 .25 Fe NI; .25 Fe NI; .25 Fe NI; .25 Fe NI; + + +@$ we must add disordered set before entering parameters +amend phase part dis 4 yes + +enter param G(part,Fe:Fe:Fe:Ni),,GA3B1; 6000 N test +enter param G(part,Fe:Fe:Ni:Fe),,GA3B1; 6000 N test +enter param G(part,Fe:Ni:Fe:Fe),,GA3B1; 6000 N test +enter param G(part,Ni:Fe:Fe:Fe),,GA3B1; 6000 N test +enter param G(part,Fe:Ni:Ni:Ni),,GA1B3; 6000 N test +enter param G(part,Ni:Fe:Ni:Ni),,GA1B3; 6000 N test +enter param G(part,Ni:Ni:Fe:Ni),,GA1B3; 6000 N test +enter param G(part,Ni:Ni:Ni:Fe),,GA1B3; 6000 N test +enter param G(part,Fe:Fe:Ni:Ni),,GA2B2; 6000 N test +enter param G(part,Fe:Ni:Fe:Ni),,GA2B2; 6000 N test +enter param G(part,Ni:Fe:Fe:Ni),,GA2B2; 6000 N test +enter param G(part,Fe:Ni:Ni:Fe),,GA2B2; 6000 N test +enter param G(part,Ni:Fe:Ni:Fe),,GA2B2; 6000 N test +enter param G(part,Ni:Ni:Fe:Fe),,GA2B2; 6000 N test + +enter param G(part,Fe,Ni:Fe,Ni:*:*),,GSRO; 6000 N test +enter param G(part,Fe,Ni:*:Fe,Ni:*),,GSRO; 6000 N test +enter param G(part,Fe,Ni:*:*:Fe,Ni),,GSRO; 6000 N test +enter param G(part,*:Fe,Ni:Fe,Ni:*),,GSRO; 6000 N test +enter param G(part,*:Fe,Ni:*:Fe,Ni),,GSRO; 6000 N test +enter param G(part,*:*:Fe,Ni:Fe,Ni),,GSRO; 6000 N test + +amend biblio test VASP calculation by test; + +@$ These are possible disordered parameters +enter param GD(part,Fe,Ni;0),,L0; 6000 N test +enter param GD(part,Fe,Ni;1),,L1; 6000 N test +enter param GD(part,Fe,Ni;2),,L2; 6000 N test + + +list data ,, + + +we have to create composition sets manually + +@$ this is by default Fe3Ni_L12 +amend phase part comp-set y , , +<.2 >.5 +>.5 <.2 +>.5 <.2 +>.5 <.2 + +@$ this is by default FeNi_L10 +amend phase part comp-set y , , +<.2 >.5 +<.2 >.5 +>.5 <.2 +>.5 <.2 + +@$ this is by default FeNi3_L12 +amend phase part comp-set y , , +<.2 >.5 +<.2 >.5 +<.2 >.5 +>.5 <.2 + + +set c t=400 p=1e5 n=1 x(ni)=.6 + +c e + +l r 2 + + +@& + +set ax 1 x(ni) 0 1 ,,,, + +step sep + + + + +@& + + + +plot +x(ni) +GM(*) +title step 4 fig 1 + + +@$ the constitution of FeNi3 + +plot +x(ni) +y(part#4,*) +title step4 fig 2 + +plot + + +title step4 fig 3 +position outside right +render + + +set inter + + + diff --git a/macros/ocv3/step5.OCM b/macros/ocv3/step5.OCM new file mode 100644 index 0000000..167f981 --- /dev/null +++ b/macros/ocv3/step5.OCM @@ -0,0 +1,138 @@ +@$ Calculate y and Cp as function of T for the ordered FCC FeNi3 +@$ +@& + +set echo + +@$ Enter the elements and their reference states +enter element Fe Iron BCC 55.847 0 0 + +enter element Ni Nickel FCC 58.69 0 0 + +@$ These functions describe the end-member energies at Fe3Ni, Fe2Ni2 and FeNi3 +@$ respectivly. The VASP energies relative to pure Fe amd Ni as fcc are: +@$ Fe3Ni1 -0.071689 eV for 1 atom?? +@$ Fe2Ni2 -0.138536 eV for 1 atom?? +@$ Fe1Ni3 -0.125748 eV for 1 atom?? +@$ To modify to J/mol atoms multiply with 96500 +@$ bond energy multiplied with 3, 4 and 3 respectively. + +enter tp-sym evtoj constant 96500 + +enter tp-sym GA3B1 fun 1 -0.071689*evtoj;,,,,, +enter tp-sym GA2B2 fun 1 -0.138536*evtoj;,,,,, +enter tp-sym GA1B3 fun 1 -0.125748*evtoj;,,,,, + +@$ We may have to use some regular solution parameter later +enter tp-sym L0 fun 1 12000; ,,,,, +enter tp-sym L1 fun 1 0; ,,,,, +enter tp-sym L2 fun 1 0; ,,,,, + +@$ this is an approximate SRO contribution to the LRO phase. It is +@$ set to about a quater of the L1_0 ordering energy, +@$ equal to the Fe-Ni bond energy +enter tp-sym GSRO fun 1 -0.034*evtoj;,,,,, + +@$ ================================================== +@$ This is an fcc phase with lro but no explicit sro +@$ described with the sublattice model +enter phase PARTITIONED_FCC 4 .25 Fe NI; .25 Fe NI; .25 Fe NI; .25 Fe NI; + + +@$ we must add disordered set before entering parameters +amend phase part dis 4 yes + +enter param G(part,Fe:Fe:Fe:Ni),,GA3B1; 6000 N test +enter param G(part,Fe:Fe:Ni:Fe),,GA3B1; 6000 N test +enter param G(part,Fe:Ni:Fe:Fe),,GA3B1; 6000 N test +enter param G(part,Ni:Fe:Fe:Fe),,GA3B1; 6000 N test +enter param G(part,Fe:Ni:Ni:Ni),,GA1B3; 6000 N test +enter param G(part,Ni:Fe:Ni:Ni),,GA1B3; 6000 N test +enter param G(part,Ni:Ni:Fe:Ni),,GA1B3; 6000 N test +enter param G(part,Ni:Ni:Ni:Fe),,GA1B3; 6000 N test +enter param G(part,Fe:Fe:Ni:Ni),,GA2B2; 6000 N test +enter param G(part,Fe:Ni:Fe:Ni),,GA2B2; 6000 N test +enter param G(part,Ni:Fe:Fe:Ni),,GA2B2; 6000 N test +enter param G(part,Fe:Ni:Ni:Fe),,GA2B2; 6000 N test +enter param G(part,Ni:Fe:Ni:Fe),,GA2B2; 6000 N test +enter param G(part,Ni:Ni:Fe:Fe),,GA2B2; 6000 N test + +enter param G(part,Fe,Ni:Fe,Ni:*:*),,GSRO; 6000 N test +enter param G(part,Fe,Ni:*:Fe,Ni:*),,GSRO; 6000 N test +enter param G(part,Fe,Ni:*:*:Fe,Ni),,GSRO; 6000 N test +enter param G(part,*:Fe,Ni:Fe,Ni:*),,GSRO; 6000 N test +enter param G(part,*:Fe,Ni:*:Fe,Ni),,GSRO; 6000 N test +enter param G(part,*:*:Fe,Ni:Fe,Ni),,GSRO; 6000 N test + +amend biblio test VASP calculation by test; + +@$ These are possible disordered parameters +enter param GD(part,Fe,Ni;0),,L0; 6000 N test +enter param GD(part,Fe,Ni;1),,L1; 6000 N test +enter param GD(part,Fe,Ni;2),,L2; 6000 N test + + +list data ,, + + +we have to create composition sets manually + +@$ this is by default FeNi3_L12 +amend phase part comp-set y ,, +>.5 <.1 +<.1 >.5 +<.1 >.5 +<.1 >.5 + + +set c t=400 p=1e5 n=1 x(ni)=.75 + +c e + +l r 2 + + +@& + +set ax 1 T 10 800 10 + +step + + + + +@& + +ent sym cp=h.t; + +c sym cp + +@& + +plot +T +y(part#2,*) +title step5 fig 1 +render + + +plot +T +cp +title step5 fig 2 + + +plot +T +cp +yr +N +0 +30 +title step5 fig 3 +render + +set inter + + + diff --git a/macros/ocv3/step6.OCM b/macros/ocv3/step6.OCM new file mode 100644 index 0000000..c33705b --- /dev/null +++ b/macros/ocv3/step6.OCM @@ -0,0 +1,51 @@ +@$ Calculate G curves for Fe-Mo at 1400K +@& + +set echo + +r t steel1 +fe mo + + +set c t=1400 p=1e5 n=1 x(mo)=.2 + +c e + +l r 1 + +@& + +set axis 1 x(mo) 0 1 .01 + +@& + +set ref fe bcc ,,,,,,, +set ref mo bcc ,,,,,,, + +@& + +step +sep + + + +plot + + +title step 6 fig 1 +render + +plot +x(mo) +gm(*) +yr +N +-5000 +1000 +position right bottom +title step 6 fig 2 +render + + +set inter + diff --git a/macros/ocv3/step7.OCM b/macros/ocv3/step7.OCM new file mode 100644 index 0000000..2795196 --- /dev/null +++ b/macros/ocv3/step7.OCM @@ -0,0 +1,97 @@ +@$ Calculate phass fractions and other property diagrams for SAF2507 +@& + +set echo + +r t saf2507 + +set c t=1273.15 p=1e5 n=1 W(cr)=.25 w(ni)=.07, w(mo)=.03 w(mn)=.015 w(n)=.002 + +@$ set c t=1273 p=1e5 n=1 x(cr)=.266 x(ni)=.066, x(mo)=.017 x(mn)=.015 x(n)=.008 + +c e + +l r 1 + +set axis 1 T 800 1800 10 + +l ax + +@& + +step + + + +plot + + +title step 7 fig 1 +render + +plot + + +position top left +title step 7 fig 2 +render + +ent sym prefcc=100*w(fcc,cr)+300*w(fcc,mo)+1600*w(fcc,n); + +ent sym prebcc=100*w(bcc,cr)+300*w(bcc,mo)+1600*w(bcc,n); + + +set c t=1350 + +c e + +l,,,,, + +@& + +set ax 1 w(n) 0 .005 + +step + + +plot +w(n) +np(*) +title step 7 fig 3 +render + +plot +w(n) +prefcc +position off +title step 7 fig 4 + +plot +w(n) +prebcc +title step 7 fig 5 +render + +@$ step with 50% ferrite + +set stat ph bcc=fix 0.5 + +set c t=none + +l c + +@& + +c e + +step + + +plot +w(n) +T +title step 7 fig 6 +render + +set inter + diff --git a/macros/ocv3/unary.OCM b/macros/ocv3/unary.OCM new file mode 100644 index 0000000..00c4846 --- /dev/null +++ b/macros/ocv3/unary.OCM @@ -0,0 +1,41 @@ +@$ Calculation for pure Fe +@$ Just to check it can change stable phase +@$ P-T diagram does not work +@& + +set echo + +r t steel1 +fe + +set c t=1000 p=1e5 n=1 + +c e + +l sh + +l,,,, + +@& + +set c b + +set c n=none + +c e + + +l,,,, + + +set c t=2000 +c e +l,,,, + +@& + +set c b=1 +c e +l,,,, + +set inter diff --git a/manual/OC-userguide.tex b/manual/OC-userguide.tex new file mode 100644 index 0000000..a93f823 --- /dev/null +++ b/manual/OC-userguide.tex @@ -0,0 +1,1218 @@ +\documentclass[12pt]{article} +\usepackage[latin1]{inputenc} +\topmargin -1mm +\oddsidemargin -1mm +\evensidemargin -1mm +\textwidth 155mm +\textheight 220mm +\parskip 2mm +\parindent 3mm +\setcounter{secnumdepth}{5} +%\pagestyle{empty} + +% +% This is a file used for a printable PDF version of the user guide +% AND as on-line help, either directly or processed to remove LaTeX specials +% +%--------------------------------------------------- +% +% The first version of this is generated manually but eventially a +% software program should be developed to update this automatically whenever +% the software is changed +% +%--------------------------------------------------- +% +% Some advice: +% +% The commands and subcommands are arranged alphabetically +% +% It will be difficult to update the help text for the +% questions after the commands and subcommands as they are normally +% not part of the command monitor. +% +% The _ used in many commands must be replaced by \_ +% +%--------------------------------------------------- +% +% The on-line help software will react if the user types a ? +% as answer to a question. It will search for the help text starting by +% the main command, any subcommand and finally question texts. +% The quesntion text may be difficult to update as already mentioned. +% Any text found in this file from the command/question found up to +% the next command will be written on the screen and +% then the question will be asked again. +% +%--------------------------------------------------- +% +\begin{document} + +\begin{center} + +{\Huge \bf User Guide to the + +Open Calphad software package + +version 1.0 + +} + +VERY VERY PRELIMINARY + +Bo Sundman, \today + +\end{center} + +This is a first test version + +\section{Introduction} + +The Open Calphad software project aims to provide a hig quality +software for thermodynamic calculations for inorganic systems i.e. +gases. liquid, alloys with may different crystalline phases. + +It also provides a framwork to store many different composition +dependent properties of materials. + +\section{Some general features} + +The command monitor has a menu of command and each of these usually +has submenus and finally some questions may be asked like phase names, +a value or an expression. At any level the user should be able to +type a ? and get some help, usually an extract from this manual, a +menue or possible answers. + +\subsection{Names and symbols} + +There are many symbols and names used in this package. A symbol or +name MUST start with a letter A-Z. It usually can contain digits and +the underscore character after the intitial letter. Some special +symbols are also used: + +\begin{itemize} +\item /- is used to denote the electron. /+ can be used for a psoitiv charge. +\item \# are used to identify composition sets after a phase name or +sublattice after a constituent name. +\item \& are used in parameter identifiers to specify the constituent +for the parameter. +\end{itemize} + +\subsection{Parameters} + +All data is organized on the base of a phase and the phase is +identified by a name. Each phase can have a different model for the +composition dependence but the way to enter model parameters is the +same for all models. However, the meaning of a model parameter may +depend on the model of the phase. + +Many types of data can be stored as explained in the section on +parameter identifiers. The parameter also has a constituent +specification explained in the constituent array section and possibly +a degree, the meaning of which is model dependent. + +The basic syntax of a parameter is + +``identifier'' ( ``phase name'' , ``constituent array'' ; ``degree'' ) ``expression'' ``reference'' + +These parts will now be explained in more detail. + +\subsubsection{Parameter Identifiers} + +The OC thermodynamic pacakage can handle any property that depend on +composition using the composition models implemented. It is easy to +extend the number of properties by declaring property identifiers in +ths source code. The value of such identifiers can be obtained by the +command ``list symbol''. If the parameters should have an influence +on the Gibbs energy (like the Curie temperature) or a diffusion +coefficient (like the mobility) the necessary code to calculate this +must be added also. + +The list here is tentative. Case should be used not to use the +same symbol name for different things ... + +\begin{itemize} +\item G, the Gibbs energy or an interaction parameter. +\item TC, the critical temperature for ferro or antiferro magnetic +ordering using the Inden model. +\item BMAGN, the avarage Bohr magneton number using the Inden model. +\item CTA, the Curie temperature for ferromagnetic ordering using +a modified Inden model. +\item NTA, the Neel temperature for antiferromagnetic ordering using a +modified Inden model. +\item IBM\&C, the individual Bohr magneton number for constituent C +using a modified Inden model. For example IBM\&FE(BCC,FE) is the Bohr +magneton number for BCC Fe. The identifier IBM\&FE(BCC,CR) means the +Bohr magneton number of a single Fe atom in BCC Cr. An identifier +IBM\&FE(BCC,CR,FE) can be used to decribe the composition dependence of +the Bohr magneton number for Fe in BCC. +\item THET, the Debye or Einstein temperature. +\item MOBQ\&C, the logarithm of the mobility of constituent C +\item RHO, the electrical resistivity +\item MAGS, the magnetic suseptibility +\item GTT, the glas transition temperature +\item VISC, the viscosity +\item LPAX, the lattic parameter in X direction +\item LPAY, the lattic parameter in Y direction +\item LPAZ, the lattic parameter in Z direction +\item LPTH, the deviation from cubic structure +\item EC11A, the elastic constrant C11 +\item EC12A, the elastic constrant C12 +\item EC44A, the elastic constrant C44 +\end{itemize} + +\subsection{Constituent array and degrees} + +A constituent array specifies one or more constituent in each +sublattice. A constituent must be entered as a species with fixed +stoichiometry. Between constituents in different sublattices one must +give a colon, ":", between interacting constituents in the same +sublattice one must give a comma, ",". A constituent array with +exactly one constituent in each sublattice is also called an endmember +as it give the value for a ``compound'' with fixed stoichiometry. +Constituent arrays with one or more interaction describe the +composition dependence of the property, without such parameter the +property will vary liearly between the endmembers. + +If there are no sublattices, like in the gas, one just give the phase +and the constituent + +G(gas,C1O2) + +If no degree is specified it is assumed to be zero. For endmembers +the degree must be zero but it may sometimes be useful to specify the +zero in order to distinguish the parameter from the expression for the +chemical potential of a component. In the gas phase one normally +assumes there are no interactions but it is possible to add such +parameters. For an fcc phase with 4 sublattice for ordering and one +for interstitials an endmember parameter is + +G(fcc,AL:NI:NI:NI:VA) + +This would be the Gibbs energy of an Al1NI3 compound. + +An interaction between vacancies and carbon in the austenite is + +G(fcc,Fe:C,VA;0) + +For interaction one should always specify a degree but also in this +case an omitted degree is interpreted as zero. + +% +% "identifier" ( "phase name" , "constituent array" ; "degree" ) "expression" +% ``reference'' +% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% +% Below is an extract of the OC command interface. +% Comparing this with the current software is be way to know +% where to update the user guide. +% +%F ! basic commands +%F character (len=16), dimension(ncbas) :: cbas=& +%F ['AMEND ','CALCULATE ','SET ',& +%F 'ENTER ','EXIT ','LIST ',& +%F 'QUIT ','READ ','SAVE ',& +%F 'HELP ','INFORMATION ','BACK ',& +%F 'NEW ','MACRO ','ABOUT ',& +%F 'DEBUG ','SELECT ','DELETE ',& +%F 'STEP ','MAP ','PLOT ',& +%F 'HPCALC ','FIN ',' '] +%F ! in French +%F ! 'MODIFIEZ ','CALCULEZ ','REGLEZ ',& +%F ! 'ENTREZ ','EXIT ','AFFICHER ',& +%F ! 'QUIT ','LIRE ','SAUVGARDE ',& +%F ! 'AIDEZ ','INFORMATION ','RETURNEZ ',& +%F ! 'NOUVEAU ','MACRO ','ABOUT ',& +%F ! 'DEBUG ','SELECTIONEZ ','EFFACEZ ',& +%F ! 'STEP ','MAP ','DESSINEZ ',& +%F ! 'HPCALC ','FIN ',' '] +%F ! options preceeded by - +%F ! for example "list -out=myfile.dat all_data" or +%F ! "list all_data -out=myfile.dat" +%F character (len=16), dimension(ncopt) :: copt=& +%F ['OUTPUT ','ALL ','FORCE ',& +%F 'VERBOSE ','SILENT ',' '] +%F !------------------- +%F ! subcommands to LIST +%F character (len=16), dimension(nclist) :: clist=& +%F ['DATA ','SHORT ','PHASE ',& +%F 'STATE_VARIABLES ','REFERENCES ','PARAMETER_IDENTI',& +%F 'AXIS ','TPFUN_SYMBOLS ','QUIT ',& +%F ' ','EQUILIBRIA ','RESULTS ',& +%F 'CONDITIONS ','SYMBOLS ',' '] +%F !------------------- +%F ! subsubcommands to LIST PHASE +%F character (len=16), dimension(nclph) :: clph=& +%F ['DATA ','CONSTITUTION ','MODEL ',& +%F ' ',' ',' '] +%F !------------------- +%F ! subcommands to CALCULATE +%F character (len=16), dimension(ncalc) :: ccalc=& +%F ['TPFUN_SYMBOLS ','PHASE ','NO_GLOBAL ',& +%F ' ','QUIT ','GLOBAL_GRIDMIN ',& +%F 'SYMBOL ','EQUILIBRIUM ','ALL_EQUILIBRIA '] +%F !------------------- +%F ! subcommands to CALCULATE PHASE +%F character (len=16), dimension(nccph) :: ccph=& +%F ['ONLY_G ','G_AND_DGDY ','ALL_DERIVATIVES '] +%F !------------------- +%F ! subcommands to ENTER +%F character (len=16), dimension(ncent) :: center=& +%F ['TPFUN_SYMBOL ','ELEMENT ','SPECIES ',& +%F 'PHASE ','PARAMETER ','REFERENCE ',& +%F 'CONSTITUTION ','EXPERIMENT ','QUIT ',& +%F 'EQUILIBRIUM ','SYMBOL ',' '] +%F !------------------- +%F ! subcommands to READ +%F character (len=16), dimension(ncread) :: cread=& +%F ['UNFORMATTED ','TDB ','QUIT '] +%F !------------------- +%F ! subcommands to AMEND first level +%F ! many of these should be subcommands to PHASE +%F character (len=16), dimension(ncam1) :: cam1=& +%F ['SYMBOL ','ELEMENT ','SPECIES ',& +%F 'PHASE ','PARAMETER ','REFERENCE ',& +%F 'TPFUN_SYMBOL ','CONSTITUTION ','QUIT ',& +%F 'COMPONENTS ','GENERAL ','DEBYE_MODEL '] +%F !------------------- +%F ! subsubcommands to AMEND PHASE +%F character (len=16), dimension(ncamph) :: camph=& +%F ['MAGNETIC_CONTRIB','COMPOSITION_SET ','DISORDERED_FRACS',& +%F 'GLAS_TRANSITION ','QUIT ','DEFAULT_CONSTIT ',& +%F 'DEBYE_MODEL ',' ',' '] +%F !------------------- +%F ! subcommands to SET. +%F character (len=16), dimension(ncset) :: cset=& +%F ['CONDITION ','STATUS ','ADVANCED ',& +%F 'LEVEL ','INTERACTIVE ','REFERENCE_STATE ',& +%F 'QUIT ','ECHO ','PHASE ',& +%F 'UNITS ','LOG_FILE ','WEIGHT ',& +%F 'NUMERIC_OPTIONS ','AXIS ','INPUT_AMOUNTS ',& +%F ' ',' ',' '] +%F ! subsubcommands to SET STATUS +%F character (len=16), dimension(ncstat) :: cstatus=& +%F ['ELEMENT ','SPECIES ','PHASE ',& +%F 'CONSTITUENT ',' ',' '] +%F ! 123456789.123456---123456789.123456---123456789.123456 +%F ! subsubcommands to SET ADVANCED +%F character (len=16), dimension(ncadv) :: cadv=& +%F ['LEVEL ',' ',' '] +%F ! 123456789.123456---123456789.123456---123456789.123456 +%F ! subsubcommands to SET PHASE +%F character (len=16), dimension(nsetph) :: csetph=& +%F ['CONSTITUTION ','STATUS ','DEFAULT_CONSTITU',& +%F 'AMOUNT ','BITS ',' '] +%F ! 123456789.123456---123456789.123456---123456789.123456 +%F !------------------- +%F ! subsubsubcommands to SET PHASE BITS +%F character (len=16), dimension(nsetphbits) :: csetphbits=& +%F ['FCC_PERMUTATIONS','BCC_PERMUTATIONS','IONIC_LIQUID_MDL',& +%F 'AQUEOUS_MODEL ','QUASICHEMICAL ','FCC_CVM_TETRADRN',& +%F 'FACT_QUASICHEMCL','NO_AUTO_COMP_SET','ELASTIC_MODEL_A ',& +%F ' ',' ',' ',& +%F ' ',' ',' '] +%F ! 123456789.123456---123456789.123456---123456789.123456 +%F !------------------- +%F ! subcommands to DEBUG +%F character (len=16), dimension(ncdebug) :: cdebug=& +%F ['FREE_LISTS ','STOP_ON_ERROR ',' ',& +%F ' ',' ',' '] +%F !------------------- +%F ! subcommands to SELECT, maybe some should be CUSTOMMIZE ?? +%F character (len=16), dimension(nselect) :: cselect=& +%F ['EQUILIBRIUM ','MINIMIZER ','GRAPHICS ',& +%F 'LANGUAGE ',' ',' '] +%F !------------------- +%F ! subcommands to DELETE +%F character (len=16), dimension(nrej) :: crej=& +%F ['ELEMENTS ','SPECIES ','PHASE ',& +%F 'QUIT ',' ',' '] +%F !------------------- +%F +% +%! end extract of command user interface +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% +% below the commands are arranged in alphabetical order + +\section{All commands} + +The commands in alphabetica order as listed with the ? + +\begin{tabular}{llll} +ABOUT & ENTER & LIST & READ \\ +AMEND & EXIT & MACRO & SAVE \\ +BACK & FIN & MAP & SELECT \\ +CALCULATE & HELP & NEW & SET \\ +DEBUG & HPCALC & PLOT & STEP \\ +DELETE & INFORMATION & QUIT \\ +\end{tabular} + +Many of the commands have ``subcommands'' and usually there is a +default (listed within slashes //) which is selected by pressing +return. One can type commands and subcommands and other parameters on +the same line if one knows the order, using a comma, ``,'' to select +the default. + +There some options that can be set for the whole session or for just a +single command. The optins are idenfified by a - in front like +-output=myfile.dat. + +\subsection{Option} + +These should be possible to specify at each command. But +they are not yet implemented. + +\begin{itemize} +\item -OUTPUT {\em file name} +\item -ALL apply for all +\item -FORCE override normal restrictions +\item -VERBOSE write information while executing +\item -SILENT do not write anything except fatal error messages +\end{itemize} +%=================================================================== +\section{About} + +Some information about the software. + +%=================================================================== +\section{Amend} + +Intended to allow changes of already entered data. Only some +of the subcommands are implemented. + +%-------------------------------- +\subsection{Element} + +Not implemented yet. + +%-------------------------------- +\subsection{Debye\_Model} + +Not implemented yet. + +%-------------------------------- +\subsection{Components} + +By default the elements are the components. Ths command can set any +orthogonal set of species as components. The number of components +cannot be changed. + +Not implemented yet. + +%-------------------------------- +\subsection{Constitution} + +The user can set a constitution of a phase before a calculation. This +will be used as initial constitution for a calculation. + +%-------------------------------- +\subsection{General} + +A number of user specific settings for defaults can be made: + +\begin{itemize} +\item The name of the system. + +\item The level of the user (beginner, frequent user, expert). This +may affect the behaviour of the program. + +\item If global minimization is allowed or not. + +\item If gridpoints should be merged after global minimization +(sometimes set for debugging). + +\item Forbid automatic creation or deletion of composition sets. +\end{itemize} + +%-------------------------------- +\subsection{Parameter} + +The possible parameters are defined by the model of the phase. By +specifying a parameter the user can change its expression. See the +ENTER PARAMETER command. + +%-------------------------------- +\subsection{Phase} + +Some of the properties of the phase can be amended by this command. + +%......................... +\subsubsection{Magnetic\_Contrib} + +A model for the magnetic contribution to the Gibbs energy can be set +by this command. + +%......................... +\subsubsection{Composition\_Set} + +More composition sets of a phase can be created. Phases with +miscibility gaps or which can exist with different chemical ordering +like A2 and B2 must be treated as different composition sets. The +user can specify a prefix and suffix for the composition set. The +composition set will always habe a suffix \#digit where digiit is a +number between 1 and 9. One cannot have more than 9 composition sets. + +Composition sets can also be created automatically by the software. In +such a case the composition set will have the suffix \_AUTO, + +In some cases it may be interesting to create metastable states inside +miscibility gaps and one can prevent automatic creation of composition +sets by {\rm AMEND GENERAL} or for an individual phase by {\em SET +PHASE BIT {\em phase} NO\_AUTO\_COMP\_SET} + +%......................... +\subsubsection{Default\_Constit} + +The default constitution of a phase can be set. This will be used +when the first calculation with the phase is made. Depending on the +minimizing software used the initial consititution can be important to +find the correct quilibrium if the phase has ordering or a miscibility +gap. + +%......................... +\subsubsection{Disordered\_Fracs} + +For phases with several sublattices the Gibbs energy of the phase can +be divided into two sets of fractions where the second or +``disordered'' set have only one or two sublattice and the fractions +on these represent the sum of fraction on some or all of the first or +``ordered'' set of sublattices. This is particularly important for +phases with ordering like FCC, BCC and HCP and for intermediate phases +like SIGMA, MU etc. + +%......................... +\subsubsection{Glas\_Transition} + +Not implemented yet. + +%......................... +\subsubsection{Quit} + +Do not amend anything for the phase. + +%-------------------------------- +\subsection{Quit} + +Do not amend anything. + +%-------------------------------- +\subsection{Reference} + +The reference for a parameter can be amended. + +%-------------------------------- +\subsection{Species} + +Not implemented yet. + +%-------------------------------- +\subsection{Symbol} + +Not implemented yet. + +%-------------------------------- +\subsection{Tpfun\_Symbol} + +Not implemented yet. + +%=================================================================== +\section{Back } + +Return back from the command monitor to the application program. + +%=================================================================== +\section{Calculate } + +Different things can be calculated. The normal thing to calculate is +{\bf equilibrium}, the other things are special. + +%-------------------------------- +\subsection{All\_Equilibria} + +Intended for the assessment procedure. Not implemented yet. + +%-------------------------------- +\subsection{Equilibrium} + +The normal command to calculate the equilibrium of a system for the +current set of conditions and phase status. You can calculate a +metastable equilibrium if some phases that should be stable have been +set dormant or suspended or if automatic creation of composition sets +is not allowed. + +%-------------------------------- +\subsection{Global\_Gridmin} + +Calculate with the global grid minimizer without using ths result as a +start point for the general minimizer. Used to debug the grid +minimizer. + +%-------------------------------- +\subsection{No\_Global} + +Calculate the equilibrium with the current minimizer without using a +global gid minimizer to generate start constitutions. + +%-------------------------------- +\subsection{Phase} + +The Gibbs energy of a phase and possible derivatives are calculated. +Mainly for debugging the implementation of models. + +\subsubsection{Only\_G} + +The Gibbs energy and all T and P derivatives calculated and listed. + +\subsubsection{G\_and\_dGdy} + +The Gibbs energy, all T and P derivatives and all first +derivatives with respect to constituents are calculated and listed. + +\subsubsection{All\_Derivatives} + +The Gibbs energy, all T and P derivatives and all first and second +derivatives with respect to constituents are calculated and listed. + +%-------------------------------- +\subsection{Quit} + +Quit calculating. + +%-------------------------------- +\subsection{Symbol} + +A state variable symbol is calculated using the results from the +last equilibrium or grid minimizer calculation. + +%-------------------------------- +\subsection{Tpfun\_Symbols} + +A specific TPFUN symbol is calculated for current values of T and P. + +%=================================================================== +\section{Debug } + +Several possibilities to trace calculations will be implemented in +order to find errors. The only implemented feature is to stop the +program whenever an error occurs. This is useful to find errors using +macro files so the macro not just goes on doing other things. + +\subsection{Stop\_on\_Error} + +The program will stop at the command level after printing the error +message if an error has occured when using macro file. This makes it +easier to use macro files to find errors. + +%=================================================================== +\section{Delete } + +Not implemented yet and may never be, it is not so easy to allow +deleting things when the data structure is so involved, it may be +better to enter the data again without the thing that should be +deleted. + +\section{Exit } + +Terminate the OC software. + +%=================================================================== +\section{Enter } + +In most cases data will be read from a database file. But it is +possible to enter all thermodynamic data interactivly. This should +normally start by entering all elements, then all species (the +elements will automatically also be species) and then the phases. + +A species have a fixed stoichiometry and possibly a charge. The +species are the constituents of the phases. + +A phase can have sublattices and various additions like magnetic or +elastic (the latter not implemented yet). + +TPFUN symbols can be used to describe common parts of model +parameters. + +Each parameter of a phase is entered separately. One may use +TPFUN symbols which are already entered. + +At present the multicomponent CEF model is the only one implemented. +This includes the gas phase, regular solutions with Redlich-Kister +Muggianu model and phases with up to 10 sublattices and magnetic +contributions. + +%-------------------------------- +\subsection{Constitution} + +The constitution (fraction of all constituents) of a phase can be +entered. This is a way to provide start values for a calculation or +to calculate the Gibbs enegy for a specific phase at a specific +constitution using {\bf calculate phase}. + +%-------------------------------- +\subsection{Element} + +The data for an element is entered. It consists of is symbol, name, +reference state, mass, H298-H0 and S298. The latter two values are +never used for any calculation. + +%-------------------------------- +\subsection{Equilibrium} + +One can have several equilibria each with a unique set of conditions +incuding phase status (dormant, suspended, fix or entered). This is +useful for compare different states, to simulate transformations and +to assess model parameters as each experimental or theoretical +information represented as an equilibrium. + +%-------------------------------- +\subsection{Experiment} + +This is for assessment, not implemented yet. + +%-------------------------------- +\subsection{Parameter} + +A parameter is definde by its identifier, the phase and constituent +array. A parameter can be a constant or depend on T and P. The +parameter will be multiplied with the fractions of the constituents +given by the constituent array. + +For example G(LIQUID,CR) is the Gibbs energy of liquid Cr relative to +its reference state, normally the stable state of Cr at 298.15 K and 1 +bar. + +For a gas molecule G(GAS,C1O2) is the Gibbs energy of the C1O2 molecule +relative to the reference states of C (carbon) and O (oxygen). + +For phases with sublattices the constituents in each sublattice are +separated by a semicolon, ``:'' and interacting constituents in +the same sublattice by a comma, ``,''. For example + +G(FCC,FE:C,VA) is the interaction between C (carbon) and VA (vacant +interstitial sites) in the FCC phase. + +One can store many different types of data in OC using the parameter +identifier. A description of the identifiers currently implemeneted +are given in the introduction. Here is a short list. + +\begin{itemize} +\item G, the Gibbs energy or an interaction parameter +\item TC, the critical temperature for ferro or antiferro magnetic ordering +\item BMAGN, the avarage Bohr magneton number +\item CTA, the Curie temperature for ferromagnetic ordering +\item NTA, the Neel temperature for antiferromagnetic ordering +\item IBM\&C, the individual Bohr magneton number for constituent C +\item THETA, the Debye or Einstein temperature +\item MOBQ\&C, the logarithm of the mobility of constituent C +\item RHO, the electrical resistivity +\item MAGS, the magnetic suseptibility +\item GTT, the glas transition temperature +\item VISC, the viscosity +\item LPAX, the lattice parameter in X direction +\item LPTH, the deviation from cubic structure +\item EC11A, the elastic constrant C11 +\item EC12A, the elastic constrant C12 +\item EC44A, the elastic constrant C44 +\end{itemize} + +The actual list is given by LIST PARAMETER\_ID. + +%-------------------------------- +\subsection{Phase} + +All thermodynamic data are connected to a phase as defined by its +parameters, see {\bf enter parameter}. A phase has a name with can +contain letters, digits and the underscore character. + +A phase can have 1 or more sublattices and the user must specify the +number of sites on each. He must also specify the constituents on +each sublattice. For some models, like the ionic liquid model, the +number of sites may change with composition. + +By default the model for a phase is assumed to be the Compound Energy +Formalism (CEF). If any onther model should be used that is set by +the {\bf amend} or {\bf set phase bit} commands. + +%-------------------------------- +\subsection{Quit} + +Quit entering things. + +%-------------------------------- +\subsection{Reference} + +Each parameter must have a reference. When entering a parameter a +reference symbol is given and with this command one can give a full +reference text for that symbol like a published paper or report. + +%-------------------------------- +\subsection{Species} + +A species consists of a name and a stochiometric formula. It can have +a valence or charge. The name is often the stoichiometric formula +but it does not have to be that. Examples: + +\begin{itemize} +\item enter species water h2o +\item enter species c2h2cl1\_trans c2h2cl2 +\item enter species c2h2cl1\_cis c2h2cl2 +\item enter species h+ h1/- -1 +\end{itemize} + +Single letter element names must be followed by a stocichiometric +factor unless it is the last element when 1 is assumed. Two-letter +element names have by default the stoichiometric factor 1. + +\begin{itemize} +\item enter species carbonmonoxide c1o1 +\item enter species cobaltoxide coo +\item enter species carbondioxide c1o2 +\end{itemize} + +The species name is important as it is name, not the stoichiometry, +that is used when referring to the species elsewhere like as +constituent. + +%-------------------------------- +\subsection{Symbol} + +The OC package has both ``symbols'' and ``tpfun\_symbols'', the latter +has a very special syntax and can be used when entering parameters. + +The symbols are designed to handle relations between state variables, +one can define expressions like + +enter symbol K = X(LIQUID,CR)/X(BCC,CR); + +where K is set to the partition of the Cr mole fractions between +liquid and bcc. + +It is intended to implement ``dot'' derivatives like CP=H.T which is +the temperature derivative of the enthalpy for the given set of +conditions in order to calculate heat capacities. + +%-------------------------------- +\subsection{Tpfun\_Symbol} + +This symbol is an expression depending on T and P that can be used +when entering parameters. A TPfun can refer to another TPfun. + +%=================================================================== +\section{Exit} + +Terminate the OC software in English. + +%=================================================================== +\section{Fin } + +Terminate the OC software in French. + +%=================================================================== +\section{Help } + +Can give a list if commands or subcommands or parts of this help text. + +%=================================================================== +\section{HPCALC } + +A reverse polish calculator. + +%=================================================================== +\section{Information } + +Not implemeneted yet. + +%=================================================================== +\section{List } + +Many things can be listed. Output is normally on the screen unless it +is redirected by the -output option. + +%-------------------------------- +\subsection{Axis} + +Lists the axis set. + +%-------------------------------- +\subsection{Conditions} + +Lists the conditions set. + +%-------------------------------- +\subsection{Data} + +Lists all thermodynamic data. + +%-------------------------------- +\subsection{Equilibria} + +Lists the equilibria entered (not the result ...). + +%-------------------------------- +\subsection{Phase} + +List data for a phase + +%................... +\subsubsection{Data} + +List the model and thermodynamic data. + +%................... +\subsubsection{Constitution} + +List the constitution of the phase. + +%................... +\subsubsection{Model} + +List some model data for axample if there is a disordered fraction set. + +%-------------------------------- +\subsection{Quit} + +You did not really want to list anyting. + +%-------------------------------- +\subsection{References} + +List the references for data. + +%-------------------------------- +\subsection{Results} + +List the results of an equilibrium calculation. + +%-------------------------------- +\subsection{Short} + +A listing with a single line for each element, species and phase with +some essential data. + +%-------------------------------- +\subsection{State\_Variables} + +Values of state variables like G, HM(LIQUID) etc. can be listed. +Terminated by an empty line. Note that symbols cannot be listed here, +they are calculated by the CALCULATE SYMBOL command. + +%-------------------------------- +\subsection{Symbols} + +All state variable sysmbols listed but not their values, they are +calculated by the CALCULATE SYMBOL command. + +%-------------------------------- +\subsection{Tpfun\_Symbols} + +All TPFUN symbols listed. + +%=================================================================== +\section{Macro } + +By specifying a file name commands will be read from that file. The +default extention is BMM. A macro file can open another macro file +(max 5 levels). When a mcro file finish with SET INTERACTIVE the +calling macro file will continue. + +%=================================================================== +\section{Map } + +For phase diagram calculations. Not implemented yet. + +%=================================================================== +\section{New } + +To remove all data so a new system can be entered. Not implemented. + +%=================================================================== +\section{Plot } + +Plot the result from a STEP or MAP calculation. A simple interface to +gnuplot has been implemented for step calculations. + +%=================================================================== +\section{Quit } + +Terminate the OC software in Swedish. + +%=================================================================== +\section{Read } + +At present there is no SAVE command implemented in OC as it is +difficult to do that before the datastructure is well defined. + +It is possible to read a (non-encrypted) TDB file but it should be not +too different from what is generated by the LIST\_DATA command in TC. + +%-------------------------------- +\subsection{Quit} + +Yuo did not really want to read anything. + +%-------------------------------- +\subsection{TDB} + +A TDB file (with extention TDB) should be specified. The TDB file +must not deviate very much from the output of Thermo-Calc. + +%-------------------------------- +\subsection{Unformatted} + +For use when a SAVE command is implemeneted in OC. + +%=================================================================== +\section{Save } + +Not implemented yet. + +%=================================================================== +\section{Select } + +%-------------------------------- +\subsection{Equilibrium} + +As the user can enter several equilibria with different conditions +this command allows him to select the current eqilibria. + +%-------------------------------- +\subsection{Graphics} + +Not implemented yet. + +%-------------------------------- +\subsection{Minimizer} + +There are two minimizers implemented, LUKAS and SUNDMAN\_HILLERT and +both have their limitations at present. + +%=================================================================== +\section{Set } + +Many things can be set. Things to be ``set'' and ``amended'' +sometimes overlap. + +%-------------------------------- +\subsection{Advanced} + +Not implemented yet + +%-------------------------------- +\subsection{Axis} + +A condition can be set as an axis variable with a low and high limit +and a maximum increement. With 2 or more axis one will calculate a +phase diagram, i.e. lines where the set of stable phases changes. + +With one axis one calculates the set of stable phases and their +properties while changing the axis variable. + +%-------------------------------- +\subsection{Condition} + +A condition is a value assigned to a state variable or an expression +of state variables. By setting the status of a phase to fix one has +also set a condition. + +%-------------------------------- +\subsection{Echo} + +This is useful command in macro files. + +%-------------------------------- +\subsection{Input\_Amounts} + +This allows the user to specify a system by giving a redundant amount +of various species in the system. The software will tranform this to +conditions on the amounts of the components. + +%-------------------------------- +\subsection{Interactive} + +The usual end of a macro file. Gives command back to the keyboard of +the user, or to the calling macro file. Without this the program will +just terminate. + +%-------------------------------- +\subsection{Level} + +I am no longer sure what this should do and if it is needed ... + +%-------------------------------- +\subsection{Log\_File} + +A useful command to save all interactive input while running OC. The +log file can easily be transformed to a macro file. All bug reports +should be accompanied by a log file which reproduces the bug. + +%-------------------------------- +\subsection{Numeric\_Options} + +Some numeric option can be set. + +%-------------------------------- +\subsection{Phase} + +Some phase specific things can be set, also for the model. + +%.................... +\subsubsection{AMOUNT} + +One can specify the amount of the phase which is used as initial value +for an equilibrium calculation. + +%.................... +\subsubsection{BITS} + +Some of the models and data storage depend on the bits of the phase. +These are + +%. . . . . . . . . . +\begin{itemize} +%\subsubsubsection{FCC\_PERMUTATIONS] +\item FCC\_PERMUTATIONS is intended for the 4 sublattice CEF model for +fcc ordering. Setting this bit means that only unique model +parameters needs to be entered, the software will take care of all +permutations. HCP permutations is also handelled by this bit as they +are identical in the 4 sublattice model. + +%. . . . . . . . . . +%\subsubsubsection{BCC\_PERMUTATIONS} +\item BCC\_PERMUTATIONS is intended for the 4 sublattice CEF model for +BCC ordering. The BCC tetrahedron is unsymmetric which makes it a bit +more complicated. Not implemented yet. + +%. . . . . . . . . . +%\subsubsubsection{IONIC\_LIQUID\_MDL} +\item IONIC\_LIQUID\_MDL. By setting this bit the phase is treated +with the 2 sublattice paritally ionic liquid model. It must have been +entered with 2 sublattices and only cations in the first sublattice +and only anions, vacancy and neutrals in the second. + +%. . . . . . . . . . +%\subsubsubsection{AQUEOUS\_MODEL} +\item AQUEOUS\_MODEL. Not implemented yet. + +%. . . . . . . . . . +%\subsubsubsection{QUASICHEMICAL} +\item QUASICHEMICAL. Is intended for the classical quasichemical +model for crystalline phases. Not implemented yet. + +%. . . . . . . . . . +%\subsubsubsection{FCC\_CVM\_TETRADRN} +\item FCC\_CVM\_TETRADRN. Is intended for the CVM tetrahedron model. +Not implemented yet. + +%. . . . . . . . . . +%\subsubsubsection{FACT\_QUASICHEMCL} +\item FACT\_QUASICHEMCL. Is intended for one for the FACT modified +quasichemical liquid models. Not implemented yet. + +%. . . . . . . . . . +%\subsubsubsection{NO\_AUTO\_COMP\_SET} +\item NO\_AUTO\_COMP\_SET. This makes it possible to prevent that a +specific phase has automatic composition set created during +calculations. + +%. . . . . . . . . . +%\subsubsubsection{ELASTIC\_MODEL\_A} +\item ELASTIC\_MODEL\_A. This should specify the elastic model to be +used. Not implemented yet. +\end{itemize} + +%.................... +\subsubsection{CONSTITUTION} + +This is the same as {\bf amend phase constitution}. + +%.................... +\subsubsection{DEFAULT\_CONSTITU} + +Same as {\bf amend phase default\_constit}. + +%.................... +\subsubsection{STATUS} + +A phase can have 4 status + +\begin{itemize} +\item entered, this is the default. The phase will be stable if that +would give the most stable state for the current conditions. The user +can give a tentative amount. +\item suspended, the phase will not be included in any calculations. +\item dormant, the phase will be included in the calculations but will +not be allowed to become stable even if that would give the most +stable equilibrium. In such a case the phase will have a positive +driving force. +\item fixed means that it is a condition that the phase is stable with +the specified amount. Note that for solution phases the composition +is not known. +\end{itemize} + +%-------------------------------- +\subsection{Quit} + +You did not really want to set anything + +%-------------------------------- +\subsection{Reference\_State} + +For each component (also when not the elements) one should be able to +specify a phase at a given temperature and pressure as reference +state. The phase must exist for the pure component. Not implemented +yet. + +%-------------------------------- +\subsection{Status} + +%.................... +\subsection{Constituent} + +A constituent of a phase can be suspended. But not yet implemented. + +%.................... +\subsection{Element} + +An element can be ENTERED or SUSPENDED. If an element is suspended +all species with this element is automatically suspended. + +%.................... +\subsection{Phase} + +A phase can have 4 status as described for the SET PHASE STATUS +command above. Changing the pase status does not affect anything +except the phase itself. + +%.................... +\subsection{Species} + +A species can be ENTERED or SUSPENDED. If a species is suspended +all phases that have this as single constituent in a sublattice +will be automatically suspened. + +%-------------------------------- +\subsection{Units} + +For each property the unit can be specified like Kelvin, Farenheit or +Celsius for temperature. Not implemented yet. + +%-------------------------------- +\subsection{Weight} + +Intended for assessments. Not implemented yet. + +%=================================================================== +\section{Step } + +Requires that a single axis is set. + +Calculates equilibria from the low axis limit to the high at each +increment. + +%=================================================================== +% Using this file for on-line help there must be a section after last command +\section{Summary } + +That's all. + +\end{document} diff --git a/minimizer/matsmin.F90 b/minimizer/matsmin.F90 index 1d8d468..3c4f63e 100644 --- a/minimizer/matsmin.F90 +++ b/minimizer/matsmin.F90 @@ -1,5 +1,7 @@ ! Hillert's Minimizer as implemented by Sundman (HMS) ! Based on Mats Hillert paper in Physica 1981 and Bo Janssons thesis 1984 +! Details of this implementation in Computational Materials Science, vol 101, +! (2015) pp 127-137 ! MODULE liboceq ! @@ -22,19 +24,20 @@ MODULE liboceq !--------------------------- ! ! To be implemented -! - calculating dot derivatives (Cp, thermal expansion etc) PARTLY DONE +! - calculating dot derivatives (Cp, thermal expansion etc) PARTIALLY DONE ! - stability check (eigenvalues) ! - fix bug with mass and mass fractions -! - conditions representing properties H, V, S etc. +! - conditions for properties H, V, S etc. ! - expressions as conditions ! ! To be done later outside this module: -! - step, map and plot (gnuplot) DONE +! - step, map and plot (gnuplot) PARTIALLY DONE ! - assessment module ! use general_thermodynamic_package ! - use omp_lib +! For parallellization, also use in gtp3.F90 +! use omp_lib ! implicit none character*8, parameter :: hmsversion='HMS-2.00' @@ -73,7 +76,7 @@ MODULE liboceq ! chargebal is 1 if external charge balance needed, ionliq<0 unless ! ionic liquid when it is equal to nkl(1)=number of cations integer chargebal,ionliq,i2sly(2) - double precision charge,yva + double precision iliqcharge,yva ! end specific ionic liquids end TYPE meq_phase !\end{verbatim} @@ -111,8 +114,6 @@ MODULE liboceq ! aphl: initial guess of amount of each stable phase integer iphl(maxel+2),icsl(maxel+2) double precision aphl(maxel+2) -! this is because I tried to scale the total amount of phases during iterations -! double precision antot ! stphl: current list of stable phases, value is index in phr array integer, dimension(maxel+2) :: stphl ! current values of chemical potentials stored in gtp_equilibrium_data @@ -212,6 +213,8 @@ subroutine calceq7(mode,meqrec,mapfix,ceq) ! conditions on T and P and mole fractions of components double precision, dimension(2) :: tpval double precision, dimension(maxel) :: xknown,vmu +! antot is total number of moles of atoms. Needed to scale results from +! gridmin which assumes 1 mole of atoms double precision xxx,antot,cvalue logical gridtest,formap ! for global minimization (change maybe to allocate dynamically) @@ -273,7 +276,9 @@ subroutine calceq7(mode,meqrec,mapfix,ceq) meqrec%nfixmu=0 meqrec%tpindep=.TRUE. ! limit change in T and P. For P it should be a factor ... - meqrec%tpmaxdelta(1)=2.0D2 +! meqrec%tpmaxdelta(1)=2.0D2 +! T limit decreased t0 100 after problem with condition on H (htest2.OCM) + meqrec%tpmaxdelta(1)=1.0D2 meqrec%tpmaxdelta(2)=1.0D2 ! now we calculate maxsph, nfixmu and maybe other things for later lastcond=>ceq%lastcondition @@ -308,17 +313,17 @@ subroutine calceq7(mode,meqrec,mapfix,ceq) case default if(.not.associated(condition,lastcond)) goto 70 case(1) ! fix T - if(cvalue.le.zero) then - write(*,*)'Condition on T must be larger than zero' - gx%bmperr=7777; goto 1000 + if(cvalue.le.0.1D0) then + write(*,*)'Condition on T must be larger than 0.1 K' + gx%bmperr=4187; goto 1000 endif meqrec%maxsph=meqrec%maxsph-1 meqrec%tpindep(1)=.FALSE. ceq%tpval(1)=cvalue case(2) ! fix P - if(cvalue.le.zero) then - write(*,*)'Condition on P must be larger than zero' - gx%bmperr=7777; goto 1000 + if(cvalue.le.0.1D0) then + write(*,*)'Condition on P must be larger than 0.1 Pa' + gx%bmperr=4187; goto 1000 endif meqrec%maxsph=meqrec%maxsph-1 meqrec%tpindep(2)=.FALSE. @@ -440,8 +445,9 @@ subroutine calceq7(mode,meqrec,mapfix,ceq) if(gx%bmperr.ne.0) goto 1000 if(meqrec%typesofcond.eq.1) then ! with only massbalance condition make a global grid minimization - call global_gridmin(1,tpval,xknown,meqrec%nv,meqrec%iphl,meqrec%icsl,& - meqrec%aphl,nyphl,yarr,vmu,ceq) +! call global_gridmin(1,tpval,antot,xknown,meqrec%nv,& + call global_gridmin(1,tpval,xknown,meqrec%nv,& + meqrec%iphl,meqrec%icsl,meqrec%aphl,nyphl,yarr,vmu,ceq) if(ocv()) write(*,*)'back from gridmin' if(gx%bmperr.ne.0) then ! if global fails reset error code and try a default start set of phases @@ -453,6 +459,15 @@ subroutine calceq7(mode,meqrec,mapfix,ceq) gridtest=.true. gx%bmperr=0; goto 110 endif +! multiply phase amounts with antot as global_grimin assumes 1 mole + if(abs(antot-one).gt.1.0D-8) then +! write(*,*)'From gridmin: ',meqrec%nv,antot + do mph=1,meqrec%nv + call get_phase_compset(meqrec%iphl(mph),meqrec%icsl(mph),& + lokph,lokcs) + ceq%phase_varres(lokcs)%amfu=antot*ceq%phase_varres(lokcs)%amfu + enddo + endif goto 200 endif if(ocv()) write(*,103)(meqrec%iphl(mjj),meqrec%icsl(mjj),meqrec%aphl(mjj),& @@ -501,7 +516,7 @@ subroutine calceq7(mode,meqrec,mapfix,ceq) meqrec%aphl(1)=one if(ocv()) write(*,*)'No gridminimization, selecting phase ',& jph,' as stable' -! this sets the default constitution +! this sets the default constitution call set_default_constitution(jph,1,ceq) else ! write(*,*)'No phase to set stable' @@ -629,7 +644,9 @@ subroutine calceq7(mode,meqrec,mapfix,ceq) tpval(2)=ceq%tpval(2) ! with what=-1 this is a test, what is changed if new phase should be stable. ! Use same variables as earler call. New composition sets can be entered + stop 'This is not yet implemented' what=-1 +! call global_gridmin(what,tpval,antot,xknown,meqrec%nv,meqrec%iphl,& call global_gridmin(what,tpval,xknown,meqrec%nv,meqrec%iphl,& meqrec%icsl,meqrec%aphl,nyphl,yarr,vmu,ceq) if(gx%bmperr.ne.0) then @@ -844,6 +861,7 @@ subroutine meq_phaseset(meqrec,formap,ceq) ! iadd=-1 ! iadd =-1 turns on verbose in meq_sameset iadd=0 irem=iremsave +! write(*,*)'Calling meq_sameset',meqrec%noofits ! meq_sameset varies amounts of stable phases and constitutions of all phases ! If there is a phase change (iadd or irem nonzeri) or error it exits call meq_sameset(irem,iadd,meqrec,meqrec%phr,ceq) @@ -1123,6 +1141,7 @@ subroutine meq_sameset(irem,iadd,meqrec,phr,ceq) integer kk,kkz,level3,mph,negam,negamph,nj,nk,nl integer nz1,nz2 TYPE(meq_phase), pointer :: pmi + logical, save :: once=.true. ! character ch1*1 ! double precision, dimension(maxel) :: ccm ! double precision, dimension(maxel) :: sccm @@ -1147,6 +1166,9 @@ subroutine meq_sameset(irem,iadd,meqrec,phr,ceq) double precision, dimension(:), allocatable :: cit ! double precision, dimension(:,:), allocatable :: cpmat double precision deltat,deltap,deltaam,yfact +! this is an emergecy fix to improve convergence for ionic liquid + double precision, parameter :: ionliqyfact=3.0D-1 +! double precision, parameter :: ionliqyfact=1.0D0 integer iz,tcol,pcol integer notf,dncol,iy,jy,iremsave,phasechangeok double precision, dimension(:), allocatable :: lastdeltaam @@ -1210,7 +1232,7 @@ subroutine meq_sameset(irem,iadd,meqrec,phr,ceq) ! ! >>>>>>>>>>>> here we can parallelize ! -!$omp parallel do private(pmi) shared(meqrec) +!-$omp parallel do private(pmi) shared(meqrec) parallel: do mph=1,meqrec%nphase pmi=>phr(mph) ! this routine calculates the phase matrix and inverts it. @@ -1226,14 +1248,18 @@ subroutine meq_sameset(irem,iadd,meqrec,phr,ceq) gx%bmperr=0 else ! Inversion error for stable phase is fatal, error code already set -! write(*,*)'Matrix inversion error for stable phase',pmi%iph - stop + if(once) then + write(*,*)'Warning, matrix inversion problem: ',pmi%iph + once=.false. + endif +! stop + gx%bmperr=0 endif endif !107 format(a,6(1pe12.3)) ! end of pmi% scope enddo parallel -!$omp end parallel do +!-$omp end parallel do ! !======================================================================= ! step 2: calculation of equil matrix @@ -1255,9 +1281,7 @@ subroutine meq_sameset(irem,iadd,meqrec,phr,ceq) ! debug output of equil matrix, last column is right hand side 380 continue if(vbug) then -! ! when problem output the smat here and (and svar below) and study!!! -! do iz=1,nz1 write(*,228)'smat1:',(smat(iz,jz),jz=1,nz2) enddo @@ -1306,11 +1330,13 @@ subroutine meq_sameset(irem,iadd,meqrec,phr,ceq) endif endif if(abs(svar(iz)-ceq%cmuval(ik)).gt.ceq%xconv) then - if(vbug) write(*,387)'Potential: ',iz,ik,svar(iz),& - ceq%cmuval(ik),abs(svar(iz)-ceq%cmuval(ik)),ceq%xconv -387 format(a,2i3,2(1pe15.7),2(1pe12.4)) +! write(*,387)'Unconverged pot: ',iz,ik,svar(iz),& + if(vbug) write(*,387)'Unconverged pot: ',iz,ik,svar(iz),& + ceq%cmuval(ik),svar(iz)-ceq%cmuval(ik),ceq%xconv +387 format(a,2i3,2(1pe14.6),2(1pe12.4)) converged=7 endif +! new chemical potential ceq%cmuval(ik)=svar(iz) iz=iz+1 enddo setmu @@ -1319,7 +1345,8 @@ subroutine meq_sameset(irem,iadd,meqrec,phr,ceq) ! update T and P if variable if(meqrec%tpindep(1)) then xxx=ceq%tpval(1) -! limit changes in T to +/-half its current value +! limit changes in T to +/- 0.2 of its current value + write(*,*)'Change in T 1: ',svar(ioff) if(abs(svar(ioff)/ceq%tpval(1)).gt.0.2D0) then svar(ioff)=sign(0.2D0*ceq%tpval(1),svar(ioff)) endif @@ -1331,12 +1358,17 @@ subroutine meq_sameset(irem,iadd,meqrec,phr,ceq) ceq%tpval(1),deltat,svar(ioff) 386 format(a,3(1pe12.4)) endif +! desperately trying to fix problems with convergence with H condition ... +! There must be a scaling error in calculating the coefficient for Delta T +! in the equilibrium matrix + deltat=2.0D1*deltat + write(*,*)'Change in T 2: ',deltat ceq%tpval(1)=ceq%tpval(1)+deltat ! problems here when -finit-local0zero is removed ! write(*,*)'T and deltaT:',ceq%tpval(1),deltat - if(ceq%tpval(1).le.zero) then - write(*,*)'Attempt to set temperature negative!!!' - gx%bmperr=9996; goto 1000 + if(ceq%tpval(1).le.0.1D0) then + write(*,*)'Attempt to set temperature less than 0.1 K' + gx%bmperr=4187; goto 1000 endif ioff=ioff+1 endif @@ -1353,9 +1385,9 @@ subroutine meq_sameset(irem,iadd,meqrec,phr,ceq) ceq%tpval(2),deltap,svar(ioff) endif ceq%tpval(2)=ceq%tpval(2)+svar(ioff) - if(ceq%tpval(2).le.zero) then - write(*,*)'Pressure set negative!!!' - gx%bmperr=9996; goto 1000 + if(ceq%tpval(2).le.0.1D0) then + write(*,*)'Attempt to set pressure lower than 0.1 Pa!!!' + gx%bmperr=4187; goto 1000 endif ioff=ioff+1 endif @@ -1386,7 +1418,7 @@ subroutine meq_sameset(irem,iadd,meqrec,phr,ceq) phamount2: do jph=1,meqrec%nstph ! loop for all stable phases jj=meqrec%stphl(jph) - phr(jj)%curd%damount=zero +! phr(jj)%curd%damount=zero ! kkz=test_phase_status(phr(jj)%iph,phr(jj)%ics,xxx,ceq) kkz=phr(jj)%phasestatus ! new -4=hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fixed @@ -1438,7 +1470,7 @@ subroutine meq_sameset(irem,iadd,meqrec,phr,ceq) if(vbug) write(*,363)'Stable phase: ',jj,phr(jj)%iph,& phr(jj)%ics,phf,phs,deltaam 363 format(a,3i3,6(1pe12.4)) - phr(jj)%curd%damount=deltaam +! phr(jj)%curd%damount=deltaam ioff=ioff+1 elseif(kkz.eq.PHFIXED) then ! phase is fix, there is no change in its amounts @@ -1505,6 +1537,7 @@ subroutine meq_sameset(irem,iadd,meqrec,phr,ceq) ! chargefact=one requires more than 100 iterations ! this value requires about 40 iteration chargefact=5.0D-1 +! chargefact=1.0D-1 ! kk is used to check if a charged phase is stable, ! it is incremented for each stable phase kk=1 @@ -1603,16 +1636,21 @@ subroutine meq_sameset(irem,iadd,meqrec,phr,ceq) ! For charged phases add a term ! phr(jj)%invmat(phr(jj)%idim,phr(jj)%idim)*Q ys=ys-chargefact*phr(jj)%invmat(nj,phr(jj)%idim)*& - phr(jj)%charge + phr(jj)%curd%netcharge +! ys=ys-chargefact*phr(jj)%invmat(nj,phr(jj)%idim)*& +! phr(jj)%charge ! jph is nonzero only for stable phases if(jph.gt.0 .and. & ! if(jj.eq.meqrec%stphl(kk) .and. & ! Hm, is this check correct? kk is updated above to be the next stable phase.. - abs(phr(jj)%charge).gt.chargerr) then - chargerr=abs(phr(jj)%charge) - signerr=phr(jj)%charge +! abs(phr(jj)%charge).gt.chargerr) then +! chargerr=abs(phr(jj)%charge) +! signerr=phr(jj)%charge + abs(phr(jj)%curd%netcharge).gt.chargerr) then + chargerr=abs(phr(jj)%curd%netcharge) + signerr=phr(jj)%curd%netcharge endif -! write(*,*)'Charge: ',jj,phr(jj)%charge +! write(*,*)'Charge: ',jj,phr(jj)%netcharge endif ycorr(nj)=ys+cit(nj) if(abs(ycorr(nj)).gt.ycormax2) then @@ -1740,7 +1778,14 @@ subroutine meq_sameset(irem,iadd,meqrec,phr,ceq) ! The O-Pu-U test case converged up to 2800 without any particular factor ! with a factor 0.4 it converged up to 3000K (~150 its), yfact does not ! has any significant influence. - yarr(nj)=yprev+4.0D-1*ycorr(nj)*yfact +! yarr(nj)=yprev+4.0D-1*ycorr(nj)*yfact +! tafidbug, 0.2 created problems +! yarr(nj)=yprev+2.0D-1*ycorr(nj)*yfact +! yarr(nj)=yprev+3.0D-1*ycorr(nj)*yfact + yarr(nj)=yprev+ionliqyfact*ycorr(nj)*yfact +! yarr(nj)=yprev+ycorr(nj)*yfact +! write(*,281)'ycorr: ',nj,yfact,yprev,yarr(nj) +281 format(a,i3,6(1pe12.4)) else yarr(nj)=yprev+ycorr(nj)*yfact endif @@ -1803,6 +1848,7 @@ subroutine meq_sameset(irem,iadd,meqrec,phr,ceq) ! The request for 100 times better than ceq%xconv is OK with conditions ! N(U)= N(O)= but not with N= x(O)= ! if(chargerr.gt.1.0D-2*ceq%xconv) then +! strengthen charge balance convergence criteria if(chargerr.gt.ceq%xconv) then if(ocv()) write(*,654)'Charge error: ',signerr,chargerr,ceq%xconv 654 format(a,6(1pe12.4)) @@ -1838,7 +1884,7 @@ subroutine meq_sameset(irem,iadd,meqrec,phr,ceq) irem,iadd,0,phf,dgmmax goto 1100 endif -! write(*,*)'Convergence critieria: ',converged +! write(*,*)'Iterations and convergence: ',meqrec%noofits,converged if(vbug) write(*,*)'Convergence criteria: ',converged ! converged=1 or 2 means constituent fraction in metastable phase not converged if(converged.gt.3) goto 100 @@ -1969,9 +2015,9 @@ subroutine setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,& integer notf,nz2,nrow double precision cvalue,totam,pham,mag,mat,map,xxx,zval,xval ! the next line of values are a desperate search for a solution - double precision totalmol,totalmass + double precision totalmol,totalmass,check1,check2,unconv double precision, allocatable :: xcol(:),mamu(:),zcol(:) - double precision, allocatable :: xxmm(:),wwnn(:) + double precision, allocatable :: xxmm(:),wwnn(:),hval(:) logical :: vbug=.FALSE. !------------------------------------------------------------------- @@ -2007,7 +2053,7 @@ subroutine setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,& ! of the equations can be rather complex. ! At present only a limited set has been implemented. ! -! A serious bug concerning mole fraction condition was discovered 2014.09.30 +! A serious bug concerning mole fraction condition was fixed 2014.09.30 ! !------------------------------------------------------------------- ! zero all values in equil matrix, dimension (nz1)x(nz1) @@ -2137,23 +2183,198 @@ subroutine setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,& select case(stvix) case default write(*,*)'not a condition:',stvix,stvnorm,cmix(1),cmix(2),cmix(3) - gx%bmperr=9988; goto 1000 - case(1:6) -! stvix=1..6: U, S, V, H, A, G conditions not implemented + gx%bmperr=4208; goto 1000 + case(1:2,5) +! stvix=1..6: U, S, V, H, A, G, some conditions not implemented +! 1 2 3 4 5 6 write(*,*)'Not implemented yet: ',stvix,stvnorm - gx%bmperr=9988; goto 1000 + gx%bmperr=4207; goto 1000 +!------------------------------------------------------------------ + case(3) ! V volume condition + write(*,*)'Not implemented yet: ',stvix,stvnorm + gx%bmperr=4207; goto 1000 +!------------------------------------------------------------------ + case(4) ! Heat balance condition +! Enthalpy for system or phase, normallized or not +! gx%bmperr=4207; goto 1000 + if(stvnorm.eq.0) then +! not normallized + if(cmix(3).eq.0) then +! condition is H=value + sph=0 + else +! condition is H(phase#set)=value, not implemented yet + gx%bmperr=4207; goto 1000 + sph=cmix(3); scs=cmix(4) + endif +! dH=\sum_alpha FU(alpha)(dG/y_i-Td2G/dTdy_i)c_iA\mu_A + (dG/dT-Td2G/dT2)dT+.. +! +\sum_alpha (G-TdG/dT)\delta FU(alpha) = +! \sum_alpha FU(alpha)\sum_i(dG/dy_i-Td2G/dTdy_i)c_iG + H-\tilde H +! write(*,*)'Condition on H: ',pmi%ncc,dncol + allocate(xcol(nz2)) + xcol=zero + totam=zero + notf=0 + check1=zero + check2=zero + hallph: do jph=1,meqrec%nstph +! sum over all stable phases + jj=meqrec%stphl(jph) + pmi=>phr(jj) +! if phase is not fixed there is a column in xcol for variable amount +! This has to be done before loop of elements + if(pmi%phasestatus.ne.PHFIXED) notf=notf+1 +! moles formula unit of phase + pham=pmi%curd%amfu + allocate(hval(pmi%ncc)) +! calculate the terms dG/dy_i - T*d2G/dTdy_i for all constituents + do ie=1,pmi%ncc + hval(ie)=pmi%curd%dgval(1,ie,1)-& + ceq%tpval(1)*pmi%curd%dgval(2,ie,1) + enddo +! write(*,75)'hval: ',hval +! write(*,75)'cmuval: ',(ceq%cmuval(ie),ie=1,meqrec%nrel) +! calculate the terms to be multiplied with the unknown mu(ie) + hallel: do ie=1,meqrec%nrel +! multiply terms with the inverse phase matrix and hval + call calc_dgdytermsh(meqrec%nrel,ie,meqrec%tpindep,hval,& + mamu,mag,mat,map,pmi,ceq%cmuval,meqrec%noofits) + if(gx%bmperr.ne.0) goto 1000 +! write(*,99)'hfix: ',mag,mat,map,mamu +99 format(a,6(1pe12.4)) + ncol=ie +! calculate a term for each column to be multiplied with chemical potential +! if the potential is fixed add the term to the rhs + do ke=1,meqrec%nfixmu + if(meqrec%mufixel(ke).eq.ie) then +! components with fix chemical potential added to rhs, do not increment ncol!!! + xcol(nz2)=xcol(nz2) - pham*meqrec%mufixval(ke)*mamu(ie) +! xcol(nz2)=xcol(nz2) + pham*meqrec%mufixval(ke)*mamu(ie) + endif + cycle hallel + enddo +! mamu(ie) = \sum_i hval(i) \sum_j \sum_B dM^a_B/dy_j z^a_ij +! sign here may be wrong, should be opposite to that for xcol(nz2) 7 lines up + xcol(ncol)=xcol(ncol) + pham*mamu(ie) +! xcol(ncol)=xcol(ncol) - pham*mamu(ie) + ncol=ncol+1 + check1=check1-pham*mamu(ie)*ceq%cmuval(ie) +! write(*,76)'check1: ',ie,check1,pham*mamu(ie)*ceq%cmuval(ie) +76 format(a,i3,5(1pe12.4)) + enddo hallel +! hval no longer needed + deallocate(hval) +! If T or P are variable, mat and map include \sum_j hval(j) + if(tcol.gt.0) then + xxx=xcol(tcol) +! gval(2,1) is dG/dT, gval(4,1) is d2G/dT2, sign???? +! xcol(tcol)=xcol(tcol)-pham*(mat-& + xcol(tcol)=xcol(tcol)+pham*(mat-& + pmi%curd%gval(2,1) + ceq%tpval(1)*pmi%curd%gval(4,1)) +! write(*,363)'d2G/dTdy H: ',nrow+1,ie,tcol,& +! xxx,xcol(tcol),pham,mat + endif + if(pcol.gt.0) then + xxx=xcol(pcol) +! gval(3,1) is dG/dP, gval(5,1) is d2G/dTdP, sign??? +! xcol(pcol)=xcol(pcol)+pham*(map-& + xcol(pcol)=xcol(pcol)-pham*(map-& + pmi%curd%gval(3,1)+ceq%tpval(1)*pmi%curd%gval(5,1)) +! write(*,363)'d2G/dPdy: H',nrow+1,ie,pcol,& +! xxx,xcol(pcol),pham,mat + endif +! enddo hallel +! Sum the total enthalpy + totam=totam+pham*(pmi%curd%gval(1,1)-& + ceq%tpval(1)*pmi%curd%gval(2,1)) +! write(*,74)'pham: ',jj,pham,totam,ceq%cmuval(1),ceq%cmuval(2) +! Now the term multipled with change of the amount of the phase + if(pmi%phasestatus.ne.PHFIXED) then + xcol(dncol+notf)=pmi%curd%gval(1,1)-& + ceq%tpval(1)*pmi%curd%gval(2,1) + endif +! term to the RHS, sign??? +! xcol(nz2)=xcol(nz2)-pham*mag +! check2=check2-pham*mag + xcol(nz2)=xcol(nz2)+pham*mag +! xcol(nz2)=xcol(nz2)-pham*mag + check2=check2+pham*mag +! write(*,76)'Check2: ',jj,pham,mag,pham*mag +! deallocate(hval) + enddo hallph +! Add difference to the RHS. Totam is summed above, cvalue is prescribed value +! write(*,74)'Enthalpy: ',nrow+1,ceq%tpval(1),ceq%rtn,& +! xcol(nz2),totam,cvalue/ceq%rtn + xcol(nz2)=xcol(nz2)+totam-cvalue/ceq%rtn +! test if condition converged, use relative error + unconv=abs(totam-cvalue/ceq%rtn) + if(unconv.gt.abs(ceq%xconv*totam)) then + write(*,6121)'Unconv enthalpy: ',ceq%tpval(1),& + totam,cvalue/ceq%rtn,unconv,ceq%xconv*totam +6121 format(a,F7.2,2(1pe14.6),4(1pe12.4)) + if(converged.lt.5) converged=5 + endif +! we have added one more equation to the equilibrium matrix + nrow=nrow+1 + if(nrow.gt.nz1) stop 'too many equations 7A' + do ncol=1,nz2 + smat(nrow,ncol)=xcol(ncol) + enddo +! write(*,74)'hline: ',nrow,xcol +75 format(a,6(1pe14.6)) +74 format(a,i2,6(1pe11.3)) +! check1 and check2 should be equal if we set H as current value and release T +! write(*,75)'Check: ',check1,check2 + deallocate(xcol) +! unfinished +! .......................................................... + else +! normallizing can be M (per mole, 1), W (per mass, 2) or V (per volume, 3) + gx%bmperr=4207; goto 1000 + endif +!------------------------------------------------------------------ + case(6) ! G +! Gibbs energy, for system or a phase + gx%bmperr=4207; goto 1000 + if(stvnorm.eq.0) then +! not normallized + if(cmix(3).eq.0) then +! condition is G=value + sph=0 + else +! condition is G(phase#set)=value + gx%bmperr=4207; goto 1000 + sph=cmix(3); scs=cmix(4) + endif +! current value of dG=\sum_A dM_A \mu_A + G -\tilde G=0 + allocate(xcol(nz2)) + xcol=zero +!...unfinished + nrow=nrow+1 + if(nrow.gt.nz1) stop 'too many equations 7A' + do ncol=1,nz2 + smat(nrow,ncol)=xcol(ncol) + enddo +! set rhs to G^prescribed - G^current + smat(nrow,nz2)=cvalue + deallocate(xcol) + else +! normallizing can be M (per mole, 1), W (per mass, 2) or V (per volume, 3?) + gx%bmperr=4207; goto 1000 + endif !------------------------------------------------------------------ case(7) ! NP ! Amount of phase in moles, use fix phase instead - write(*,*)'Not implemented yet, use set phase fix: ',stvix,stvnorm - gx%bmperr=9988; goto 1000 + write(*,352)stvix,stvnorm +352 format('Not implemented yet, use set status phase=fix: ',2i5) + gx%bmperr=4207; goto 1000 nrow=nrow+1 if(nrow.gt.nz1) stop 'too many equations 7A' !------------------------------------------------------------------ case(8) ! BP ! Amount of phase in mass, use fix phase instead - write(*,*)'Not implemented yet, use set phase fix: ',stvix,stvnorm - gx%bmperr=9988; goto 1000 + write(*,352)stvix,stvnorm + gx%bmperr=4207; goto 1000 nrow=nrow+1 if(nrow.gt.nz1) stop 'too many equations 8A' !------------------------------------------------------------------ @@ -2170,7 +2391,7 @@ subroutine setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,& else ! condition is N(phase#set,A)=fix; how to handle if phase#set not stable? write(*,*)'Condition N(phase#set,A)=fix not allowed' - gx%bmperr=9898; goto 1000 + gx%bmperr=4208; goto 1000 sel=cmix(5); sph=cmix(3); scs=cmix(4) endif ! write(*,*)'Condition on N, N(A) or N(phase,A)',sph,sel @@ -2255,13 +2476,11 @@ subroutine setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,& else xcol(dncol+notf)=xcol(dncol+notf)+pmi%xmol(ie) endif -! right hand side (rhs) contribution is -! - NP(phase)*\sum_i \sum_j dM(ie)/dy_i * dG/dy_j * z_ij -! xcol(nz2)=xcol(nz2)-pham*mag endif ! Maybe this should be included also for fixed phases ....?? YES ! right hand side (rhs) contribution is ! - NP(phase)*\sum_i \sum_j dM(ie)/dy_i * dG/dy_j * z_ij + xxx=xcol(nz2) xcol(nz2)=xcol(nz2)-pham*mag enddo nallel ! this is to used on the RHS for compare with prescribed value @@ -2270,6 +2489,10 @@ subroutine setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,& else totam=totam+pham*pmi%sumxmol endif +! tafidbug +! write(*,665)xxx,pham,mag,cvalue,totam,& +! xxx-pham*mag+cvalue-totam +665 format('RHS: ',6(1pe12.4)) enddo nallph ! ! in xcol are values summed over all phases and components @@ -2283,9 +2506,11 @@ subroutine setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,& smat(nrow,ncol)=xcol(ncol) enddo ! add N^prescribed - N^current to rhs (right hand side) -! xxx=smat(nrow,nz2) + xxx=smat(nrow,nz2) ! convergence problems using condition fix phase with amount >0, change sign ... smat(nrow,nz2)=smat(nrow,nz2)-cvalue+totam +! tafidbug +! smat(nrow,nz2)=smat(nrow,nz2)+cvalue-totam ! write(*,363)'RHSN: ',nrow,nz2,0,smat(nrow,nz2),xxx,cvalue,totam,& ! cvalue-totam deallocate(xcol) @@ -2305,7 +2530,7 @@ subroutine setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,& elseif(stvnorm.gt.1) then ! only normallizing of N with respect to amount of moles (M) is allowed write(*,*)'N can only be normalled with M',stvix,stvnorm,cmix(2) - gx%bmperr=9988; goto 1000 + gx%bmperr=4208; goto 1000 else !------------------------------------------------------------ ! N=fix and N(A)=fix treated above as they have a "simple" summation, @@ -2317,7 +2542,7 @@ subroutine setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,& ! and -N(A)/N**2 in the end. if(cmix(3).eq.0) then write(*,*)'Condition NM=fix is illegal' - gx%bmperr=9898; goto 1000 + gx%bmperr=4208; goto 1000 elseif(cmix(4).eq.0) then ! condition is x(A)=fix sel=cmix(3); sph=0 @@ -2436,7 +2661,7 @@ subroutine setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,& nrow=nrow+1 if(nrow.gt.nz1) then write(*,*)'too many equations 11B: ',nrow,nz1,meqrec%nfixph - gx%bmperr=3333; goto 1000 + gx%bmperr=4209; goto 1000 endif ! sum zcol and xcol to nrow in smat multiplying xcol with current amount ! and normallizing with total amount, including the RHS (column nz2) @@ -2469,7 +2694,7 @@ subroutine setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,& else ! condition is B(phase#set,A)=fix; how to handle if phase#set not stable? ! write(*,*)'Condition B(phase#set,A)=fix not allowed' - gx%bmperr=9898; goto 1000 + gx%bmperr=4208; goto 1000 sel=cmix(5); sph=cmix(3); scs=cmix(4) endif ! Formulate equation for total amount B: each M_A multiplied with mass_A @@ -2578,7 +2803,7 @@ subroutine setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,& nrow=nrow+1 if(nrow.gt.nz1) then write(*,*)'too many equations 12A',nrow - gx%bmperr=6543; goto 1000 + gx%bmperr=4209; goto 1000 endif do ncol=1,nz2 smat(nrow,ncol)=xcol(ncol) @@ -2605,7 +2830,7 @@ subroutine setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,& elseif(stvnorm.ne.2) then ! only normallizing of B with respect to mass (W) is allowed write(*,*)'Allowed normallizing with W only',stvix,stvnorm,cmix(2) - gx%bmperr=9988; goto 1000 + gx%bmperr=4208; goto 1000 else !------------------------------- ! B=fix and B(A)=fix treated above as they have a "simple" summation, @@ -2617,7 +2842,7 @@ subroutine setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,& ! and -B(A)/B**2 in the end. if(cmix(3).eq.0) then write(*,*)'Condition BW=fix is illegal' - gx%bmperr=9898; goto 1000 + gx%bmperr=4208; goto 1000 elseif(cmix(4).eq.0) then ! condition is x(A)=fix sel=cmix(3); sph=0 @@ -2737,7 +2962,7 @@ subroutine setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,& nrow=nrow+1 if(nrow.gt.nz1) then write(*,*)'too many equations 12B',nrow,nz1 - gx%bmperr=3333; goto 1000 + gx%bmperr=4209; goto 1000 endif ! copy to smat row nrow do ncol=1,nz2 @@ -2769,7 +2994,7 @@ subroutine setup_equilmatrix(meqrec,phr,nz1,smat,tcol,pcol,& case(13) ! Y ! Constituent fraction: phase#set, (subl.,) constituent index (over all subl) write(*,*)'Not implemented yet: ',stvix,stvnorm,cmix(2),cmix(3),cmix(4) - gx%bmperr=9988; goto 1000 + gx%bmperr=4207; goto 1000 nrow=nrow+1 if(nrow.gt.nz1) stop 'too many equations 13A' end select @@ -2820,7 +3045,7 @@ subroutine meq_onephase(meqrec,pmi,ceq) double precision, dimension(maxconst) :: yarr,dqsum ! phase matrix, its inverse is returned as part of pmi double precision, dimension(:,:), allocatable :: pmat - double precision qsp,sumsit,ykvot,ysum,qsum,spmass,yva + double precision qsp,sumsit,ykvot,ysum,qsum,spmass,yva,fion double precision, dimension(:,:), allocatable :: sumion ! ! write(*,*)'in meq_onephase: ' @@ -2834,7 +3059,7 @@ subroutine meq_onephase(meqrec,pmi,ceq) write(*,*)'get_phase_data error in meq_onephase',iph,ics,gx%bmperr goto 1000 endif -! make sure all fractions >ymin and sums in alll sublattices equail to unity +! make sure all fractions >ymin and sums in all sublattices are equal to unity nochange=0 ncc=0 do ll=1,nsl @@ -2876,12 +3101,14 @@ subroutine meq_onephase(meqrec,pmi,ceq) ! If external charge balance phase matrix has one more line+column pmi%chargebal=1 nd1=ncc+1 - pmi%charge=qq(2) +! pmi%charge=qq(2) + pmi%curd%netcharge=qq(2) ! write(*,*)'Calculated qq(2): ',iph,ics,qq(2) else pmi%chargebal=0 nd1=ncc - pmi%charge=zero +! pmi%charge=zero + pmi%curd%netcharge=zero endif !-------------------------- ! sublattice rows, nd2=nd1+1 because I use Lukas matrix inverter @@ -2895,6 +3122,8 @@ subroutine meq_onephase(meqrec,pmi,ceq) pmi%idim=nd1 pmi%ncc=ncc allocate(pmi%invmat(nd1,nd1)) + pmi%invmat=zero +! write(*,*)'Allocated invmat: ',nd1,ncc ! meqrec is not available in this routine but meqrec%nrel passed in call allocate(pmi%xmol(nrel)) allocate(pmi%dxmol(nrel,ncc)) @@ -2950,7 +3179,6 @@ subroutine meq_onephase(meqrec,pmi,ceq) pmi%sumxmol=pmi%sumxmol+pmi%xmol(iz) pmi%sumwmol=pmi%sumwmol+pmi%xmol(iz)*mass_of(iz,ceq) enddo -! some stoichiometric phases have wrong number of moles like Cr2VC2 ... ! phase_varres(lokcs)%abnorm already set by set_constitution pmi%xdone=1 ! @@ -2960,6 +3188,11 @@ subroutine meq_onephase(meqrec,pmi,ceq) write(*,*),'calcg error in meq_onephase ',iph,gx%bmperr goto 1000 endif +! set the inverted phase matrix to zero !!! + pmi%invmat=zero +! do ik=1,ncc +! pmi%invmat(ik,ik)=one +! enddo ! maybe some common ending goto 900 endif @@ -3076,7 +3309,6 @@ subroutine meq_onephase(meqrec,pmi,ceq) !----------------------------------------------- ionic liquid phase ionliq: if(test_phase_status_bit(iph,PHIONLIQ)) then ! write(*,*)'Warning; ionic liquid model not fully implemented' -! gx%bmperr=4207; goto 1000 ! Calculate M_A and dM_A/dy_i taking into account that P and Q varies ! call get_phase_data(iph,ics,nsl,nkl,knr,yarr,sites,qq,ceq) pmi%ionliq=nkl(1) @@ -3108,14 +3340,17 @@ subroutine meq_onephase(meqrec,pmi,ceq) if(btest(pmi%curd%constat(ncon),CONVA)) then ! This is the nypothetical vacancy .... its charge is sites(2) = Q yva=yarr(ncon) +! save its index in isly(1), otherwise that is number of constit+1 i2sly(1)=ncon ! pmi%valency(ncon)=sites(2) ! write(*,*)'Va: ',ncon,yva else call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp) if(gx%bmperr.ne.0) goto 1000 -! if(qsp.eq.zero) i2sly(2)=ncon - if(qsp.eq.zero .and. i2sly(2).eq.0) i2sly(2)=ncon +! i2sly is index of first neutral (if any) otherwise number of constit+1 + if(qsp.eq.zero .and. i2sly(2).gt.ncon) i2sly(2)=ncon +! write(*,*)'Species: ',ncon,i2sly,qsp +! if(qsp.eq.zero .and. i2sly(2).eq.0) i2sly(2)=ncon ! pmi%valency(ncon)=abs(qsp) ! write(*,*)'charge: ',ncon,qsp do jk=1,nspel @@ -3126,7 +3361,7 @@ subroutine meq_onephase(meqrec,pmi,ceq) pmi%xmol(ielno(jk))=pmi%xmol(ielno(jk))+qsp*yarr(ncon) sumion(ielno(jk),ll)=sumion(ielno(jk),ll)+& stoi(jk)*yarr(ncon) -! take into account that the site ratios depend on constitition later +! take into account that the site ratios depend on constitition in corrion_.. ! write(*,21)'ddMA:',jk,ielno(jk),ncon,ll,& ! pmi%dxmol(ielno(jk),ncon),qsp,sites(ll),stoi(jk) !21 format(a,4i3,4(1pe12.4)) @@ -3198,7 +3433,7 @@ subroutine meq_onephase(meqrec,pmi,ceq) ! ncon is the total number of constituents icon=ncon !......................................... end handling P and Q variation -!261 continue +261 continue ! meqrec is not available in this routine do ik=1,nrel pmi%sumxmol=pmi%sumxmol+pmi%xmol(ik) @@ -3213,15 +3448,21 @@ subroutine meq_onephase(meqrec,pmi,ceq) endif ! correction of second derivatives due to variation of P and Q if(meqrec%noofits.gt.1) then - call corriliq_d2gdyidyj(nkl,knr,ceq%cmuval,pmi,ncon,pmat,ceq) +! NOTE pmat is dimensioned pmat(nd1,nd2) + call corriliq_d2gdyidyj(nkl,knr,ceq%cmuval,pmi,ncon,nd1,pmat,ceq) if(gx%bmperr.ne.0) goto 1000 endif +! write(*,17)'pots: ',(ceq%cmuval(ik),ik=1,3) +! do ll=1,nd1 +! write(*,17)'cion: ',(pmat(ll,ik),ik=1,nd1) +! enddo ! calculate phase matrix elements, the second derivatives ! note pmat has some contributions above ?? neq=icon + fion=one do ik=1,icon do jk=ik,icon - pmat(ik,jk)=pmat(ik,jk)+& + pmat(ik,jk)=fion*pmat(ik,jk)+& ceq%phase_varres(lokcs)%d2gval(ixsym(ik,jk),1) ! remove next line when using a routine inverting a symmetric matrix if(jk.gt.ik) pmat(jk,ik)=pmat(ik,jk) @@ -3242,6 +3483,7 @@ subroutine meq_onephase(meqrec,pmi,ceq) !65 format(a,6i4,10i3) ! do ll=1,nd1 ! write(*,17)'pmat: ',(pmat(ll,ik),ik=1,nd1) +17 format(a,6(1pe12.4)) ! enddo ! invert the phase matrix (faster routine should be used) IONIC LIQUID MODEL call mdinv(nd1,nd2,pmat,pmi%invmat,nd1,ierr) @@ -3382,18 +3624,200 @@ end subroutine meq_onephase !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\begin{verbatim} - subroutine corriliq_d2gdyidyj(nkl,knr,curmu,pmi,ncc,pmat,ceq) + subroutine corriliq_d2gdyidyj(nkl,knr,curmu,pmi,ncc,nd1,pmat,ceq) ! correction of d2G/dy1dy2 for ionic liquid because the formula unit is ! not fixed. This contributes ONLY to the second derivaties of G and ! is not really part of the model itself, only needed when minimizing G implicit none type(gtp_equilibrium_data), pointer :: ceq TYPE(meq_phase), pointer :: pmi - integer ncc,nkl(*),knr(*) - double precision curmu(*),pmat(ncc,*) + integer ncc,nd1,nkl(*),knr(*) + double precision curmu(*),pmat(nd1,*) !\end{verbatim} -! corr = \sum_A \mu_A * d2 N_A/dy_i dy_k ; i cation, j anion, Va vacancy, k any -! N_A = P*\sum_i b_Ai y_i + Q(\sum_j b_Aj y_j) +! corr = \sum_A \mu_A*d2(N_A)/dy_i/dy_k ; i cation, k cation, anion, Va +! N_A = P*\sum_i b_Ai y_i + Q(\sum_j b_Aj y_j + ... ) b_Ai stoich.fact. of A +! P = \sum_j v_j y_j + y_Va Q +! Q = \sum_i v_i y_i +! +! Derivativs of P and Q +! dP/dy_i = y_Va v_i; dP/dy_j = v_j; dP/dy_Va = Q +! dQ/dy_i = v_i dQ/dy_j = zero dQ/dy_Va = zero +! d2P/dy_idy_Va = v_i +! +! d(N_A\mu_A)/dy_i = dP/dy_i\sum_jb_Aj + v_i +! + integer i1,i2,icon,jcon,loksp,nspel,ielno(10),el,allions,nobug + double precision stoi(10),spmass,qsp1,qsp2,add1,add2,yva,sumcat,bug + double precision bugfix +!tafidbug +! write(*,*)'Skipping liquid correction' +! goto 1000 +! this correction term affects only second derivatives and thus convergence +! speed and stability. But it seems just to mess up everything. +! +! dpqdy(1..ncc) is the absolute value of the charge of the species +! It is not used as we must get species data, better not to use ... +! i2sly(1) is index of vacancy, i2sly(2) is index of first neutral +! If either is missing it is equal to number of constituents+1 + allions=min(pmi%i2sly(1),pmi%i2sly(2)) +! write(*,12)'mu: ',(curmu(i1),i1=1,noel()) +12 format(a,6(1pe12.4)) + if(nkl(1).eq.0) then +! no cations (bor anions), only neutrals, no need to calculate anything +! write(*,*)'Liquids without cations have fixed stoichiometry 1.0 + goto 1000 + endif +! If there are vacancies we save its fraction here, if not set to zero +! if(pmi%i2sly(1).lt.ncc) then + if(pmi%i2sly(1).le.ncc) then + yva=pmi%curd%yfr(pmi%i2sly(1)) + else + yva=zero + endif +! write(*,11)'corrion 1: ',yva,pmi%i2sly,nkl(1)+nkl(2),allions,ncc +11 format(a,1pe12.4,10i5) +! to simplify testing, 0 means include contribution from pairs of cations + nobug=0 + bugfix=one + sumcat=zero +! just loop for all cations here. Inside this loop we step jcon +! for all constituents up to vacancies or last anion. + do icon=1,nkl(1) +! icon=0 +! do i1=1,nkl(1) +! do i1=1,allions-1 +! loop for all cations and anions +! icon=icon+1 + loksp=knr(icon) + call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp1) + if(gx%bmperr.ne.0) goto 1000 + add2=zero + do el=1,nspel +! skip any vacancy in a species, they have zero chemical potential anyway + if(ielno(el).gt.0) add2=add2+stoi(el)*curmu(ielno(el)) + enddo + add1=add2 +! write(*,13)'first cat: ',icon,0,qsp1,add1 +13 format(a,2i3,6(1pe12.4)) +!-------------------------2nd derivatives wrt two cations + jcon=icon + do while(jcon.le.nkl(1)) +! loop for all pairs of cations incl twins, nkl(1) is number of cations +! A smart but messy solution is to skip this loop for jcon=icon ... + loksp=knr(jcon) + call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp2) + if(gx%bmperr.ne.0) goto 1000 + add2=zero + do el=1,nspel + if(ielno(el).ne.0) add2=add2+stoi(el)*curmu(ielno(el)) + enddo + bug=add2 +! sumcat is used below for derivative wrt cation and vacancy + if(icon.eq.1) then + sumcat=sumcat+pmi%curd%yfr(jcon)*add2 +! write(*,13)'sumcat: ',0,jcon,yva,pmi%curd%yfr(jcon),& +! add2,sumcat + endif +! if there are no vacancies the derivative of P is zero wrt two cations +! this is \sum_A dP/dy_icon*b_Ajcon*mu_A+\sum_A dP/dy_jcon*b_Aicon*mu_A + if(nobug.eq.0 .and. yva.gt.zero) then + add2=bugfix*yva*(qsp1*add2+qsp2*add1) +! if(abs(yva*(add2)).gt.1.0D2) then +! This is a sensitive point for convergence, values of 1.0D+33 found !!! +! But bad converge also when small values, less than 100 +! add2=-1.0D2 +! endif +! write(*,13)'pmat caca: ',icon,jcon,qsp1,yva,bug,add2 +! store value in pmat as correction to d2G/dyidyj + pmat(icon,jcon)=-add2 +! tafidbug 2 +! pmat(icon,jcon)=add2 + endif + jcon=jcon+1 + enddo +! ------------------------ 2nd derivative wrt to cation and anion + do while(jcon.lt.allions) +! loop for all anions, allions-1 is last anion + loksp=knr(jcon) + call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp2) + if(gx%bmperr.ne.0) goto 1000 + add2=zero + do el=1,nspel + if(ielno(el).ne.0) add2=add2+stoi(el)*curmu(ielno(el)) + enddo + bug=add2 +! This is \sum_A dP/dy_jcon*b_Aicon*mu_A+\sum_A dQ/dy_icon*b_Ajcon*mu_A +! Note dP/dy = -qsp2 as qsp2 is negative + add2=qsp1*add2-qsp2*add1 +! write(*,13)'pmat caan: ',icon,jcon,qsp2,bug,add2 +! store value in pmat as correction to d2G/dyidyj + pmat(icon,jcon)=-add2 +! tafidbug 2 +! pmat(icon,jcon)=add2 + jcon=jcon+1 + enddo +!------------- second derivative wrt cation and vacancy +! if(icon.le.nkl(1) .and. jcon.eq.pmi%i2sly(1)) then + if(jcon.le.ncc .and. jcon.eq.pmi%i2sly(1)) then +! if no vacancy then i2sly(1)=ncc+1 +! This is \sum_A d2P/dy_icon dy_Va*\sum_k y_k*b_Ak*\mu_A + Q * b_Aicon*\mu_A + add2=qsp1*sumcat+pmi%curd%sites(2)*add1 +! It think the line above is correct but the one below works better ... +! add2=qsp1*sumcat +! write(*,13)'pmat cava: ',icon,jcon,qsp1,& +! sumcat,pmi%curd%sites(2),add1,add2 +! store value in pmat as correction to d2G/dyidyj + pmat(icon,jcon)=-add2 +! tafidbug 2 +! pmat(icon,jcon)=add2 + jcon=jcon+1 + endif +!------------- second derivative wrt cation and neutral +! is this really correct?? + do while(jcon.le.ncc) + loksp=knr(jcon) + call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp2) + if(gx%bmperr.ne.0) goto 1000 + add2=zero + do el=1,nspel + if(ielno(el).ne.0) add2=add2+stoi(el)*curmu(ielno(el)) + enddo + bug=add2 +! This is \sum_A dQ/dy_icon * b_Ajcon * mu_A, icon is cation and jcon neutal + add2=qsp1*add2 +! write(*,13)'pmat cane: ',icon,jcon,qsp1,bug,add2 + pmat(icon,jcon)=-add2 +! tafidbug 2 +! pmat(icon,jcon)=add2 + jcon=jcon+1 + enddo +!------------- no other terms + enddo +! write(*,*)'Correction to phase matrix from corriliq: ',& +! pmi%curd%phtupx,nobug +! do icon=1,ncc +! write(*,1100)(pmat(icon,jcon),jcon=1,ncc) +! enddo +1100 format(6(1pe12.4)) +1000 continue + return + end subroutine corriliq_d2gdyidyj + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!-\begin{verbatim} + subroutine corriliq_d2gdyidyj_old(nkl,knr,curmu,yva,pmi,ncc,pmat,ceq) +! correction of d2G/dy1dy2 for ionic liquid because the formula unit is +! not fixed. This contributes ONLY to the second derivaties of G and +! is not really part of the model itself, only needed when minimizing G + implicit none + type(gtp_equilibrium_data), pointer :: ceq + TYPE(meq_phase), pointer :: pmi + integer ncc,nkl(*),knr(*) + double precision curmu(*),pmat(ncc,*),yva +!-\end{verbatim} +! corr = \sum_A \mu_A * d2 N_A/dy_i dy_k ; i cation, j anion, Va vacancy, k meu +! N_A = P*\sum_i b_Ai y_i + Q(\sum_j b_Aj y_j) + Q(\sum_j b_Ak y_k) ! P = \sum_j v_j y_j + y_Va \sum_i v_i y_i ! Q = \sum_i v_i y_i ! N_A = (\sum_j v_jy_j + y_Va\sum_i v_iy_i)\sum_i b_Aiy_i + @@ -3406,64 +3830,101 @@ subroutine corriliq_d2gdyidyj(nkl,knr,curmu,pmi,ncc,pmat,ceq) ! d2N_A/dy_kdy_m = y_Va v_m b_Ak + y_Va v_k b_Am ! integer i1,i2,icon,jcon,loksp,nspel,ielno(10),el,allions - double precision stoi(10),spmass,qsp,qsp1,add1,add2,add3 + double precision stoi(10),spmass,qsp,qsp1,add1,add2,add3,bcat,bani,bneu ! +! dpqdy(1..ncc) is the absolute value of the charge of the species +! It is not used as we must get species data, better not to use ... +! i2sly(1) is index of vacancy, i2sly(2) is index of first neutral +! If either is missing it is equal to number of constituents+1 allions=min(pmi%i2sly(1),pmi%i2sly(2)) +! write(*,11)'corrion 2: ',pmi%i2sly,nkl(1)+nkl(2),allions,ncc +11 format(a,10i5) icon=0 - do i1=1,nkl(1)+nkl(2) -! loop for all canstituents. Note qsp1 is needed below + write(*,12)'mu: ',(curmu(i1),i1=1,noel()) +12 format(a,6(1pe12.4)) +! do i1=1,nkl(1)+nkl(2) +! loop for all constituents + if(nkl(1).eq.0) then +! write(*,*)'Liquids without cations have fixed stoichiometry 1.0 +! gx%bmperr=9876 + goto 1000 + endif + do i1=1,nkl(1) +! loop for all cations, one derivative must be for a cation icon=icon+1 - if(pmi%curd%dpqdy(icon).ne.zero) then - loksp=knr(icon) - call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp1) + loksp=knr(icon) + call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp1) + if(gx%bmperr.ne.0) goto 1000 + add2=zero + do el=1,nspel +! skip any vacancy in a species, they have zero chemical potential anyway + if(ielno(el).gt.0) add2=add2+stoi(el)*curmu(ielno(el)) + enddo + add1=add2 + write(*,13)'cation: ',icon,0,qsp1,add1 +13 format(a,2i3,6(1pe12.4)) +!-------------------------2nd derivatives wrt two cations + jcon=icon + do while(jcon.le.nkl(1)) +! loop for all pairs of cations incl twins, nkl(1) is number of cations +! A smart and messy solution is to skip this loop for jcon=icon ... + loksp=knr(jcon) + call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp) if(gx%bmperr.ne.0) goto 1000 add2=zero do el=1,nspel -! skip vacancies, they have chemical potential zero anyway - if(ielno(el).gt.0) add2=add2+stoi(el)*curmu(ielno(el)) + if(ielno(el).ne.0) add2=add2+stoi(el)*curmu(ielno(el)) enddo - add1=pmi%curd%dpqdy(icon)*add2 -! if(pmi%i2sly(1).lt.pmi%i2sly(2)) then -! add1=pmi%curd%yfr(pmi%i2sly(1))*add1 -! endif - endif - jcon=icon + add2=add1*qsp+add2*qsp1 + write(*,13)'pmat caca: ',icon,jcon,add2,qsp,yva,yva*add2 +! store value in pmat as correction to d2G/dyidyj + pmat(icon,jcon)=-yva*add2 + jcon=jcon+1 + enddo +! ------------------------ 2nd derivative wrt cation and anion do while(jcon.lt.allions) -! loop for all cations and anions - if(pmi%curd%dpqdy(jcon).ne.zero) then - loksp=knr(jcon) - call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp) - if(gx%bmperr.ne.0) goto 1000 - add2=zero - do el=1,nspel - add2=add2+stoi(el)*curmu(ielno(el)) - enddo - add1=add1+pmi%curd%dpqdy(jcon)*add2 - endif +! loop for all anions, allions-1 is last anion + loksp=knr(jcon) + call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp) + if(gx%bmperr.ne.0) goto 1000 + add2=zero + do el=1,nspel + if(ielno(el).ne.0) add2=add2+stoi(el)*curmu(ielno(el)) + enddo +! anions have negative charge +! add2=add2*qsp1-add1*qsp + add2=add2*qsp1+add1*qsp + write(*,13)'pmat caan: ',icon,jcon,qsp,add2 +! store value in pmat as correction to d2G/dyidyj + pmat(icon,jcon)=-add2 jcon=jcon+1 enddo +!-------------second derivative wrt cation and vacancy if(jcon.eq.pmi%i2sly(1)) then -! contribution to the second derivative wrt cation and vacancy + write(*,13)'pmat cava: ',icon,jcon,add1,pmi%curd%sites(2),& + add1*pmi%curd%sites(2) +! store value in pmat as correction to d2G/dyidyj + pmat(icon,jcon)=-add1*pmi%curd%sites(2) + endif + jcon=jcon+1 +!-------------second derivative wrt cation and neutral + do while(jcon.le.ncc) + loksp=knr(jcon) + call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp) + if(gx%bmperr.ne.0) goto 1000 add2=zero - do i2=1,nkl(1) -! loop for all cations - loksp=knr(i2) - call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp) - if(gx%bmperr.ne.0) goto 1000 - add3=zero - do el=1,nspel - add3=add3+stoi(el)*curmu(ielno(el)) - enddo - add2=add2+pmi%curd%yfr(i2)*add3 + do el=1,nspel + if(ielno(el).ne.0) add2=add2+stoi(el)*curmu(ielno(el)) enddo - add1=add1+qsp1*add2 - endif + write(*,13)'pmat cane: ',icon,jcon,add2,qsp1,qsp1*add2 ! store value in pmat as correction to d2G/dyidyj - pmat(icon,jcon)=-add1 + pmat(icon,jcon)=-qsp1*add2 + jcon=jcon+1 + enddo enddo 1000 continue return - end subroutine corriliq_d2gdyidyj + end subroutine corriliq_d2gdyidyj_old !/!\!/!\!/!\!/!\!/\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ @@ -3568,7 +4029,7 @@ end function same_composition !\begin{verbatim} subroutine calc_dgdyterms1(nrel,ia,tpindep,mamu,mag,mat,map,pmi,& curmux,noofits) -! any change must also be made in subroutine calc_dyterms2 +! any change must also be made in subroutine calc_dyterms2 and calc_dgdytermsh ! calculate the terms in the deltay expression for amounts of component ia ! ! DM_A = \sum_B mu_B*MAMU(B) - MAG - MAT*dt - MAP*dp @@ -3606,6 +4067,8 @@ subroutine calc_dgdyterms1(nrel,ia,tpindep,mamu,mag,mat,map,pmi,& sum=sum+cib*pmi%dxmol(ia,jy) enddo mamu(ib)=sum +! tafid bug +! mamu(ib)=-sum enddo !----------- ! if(noofits.eq.1) then @@ -3632,6 +4095,8 @@ subroutine calc_dgdyterms1(nrel,ia,tpindep,mamu,mag,mat,map,pmi,& if(tpindep(2)) cip=cip+pmi%invmat(jy,iy)*pmi%curd%dgval(3,jy,1) enddo morr=pmi%dxmol(ia,iy) +! tafid bug +! morr=-pmi%dxmol(ia,iy) mag=mag+morr*cig mat=mat+morr*cit map=map+morr*cip @@ -3649,7 +4114,7 @@ subroutine calc_dgdyterms2(iy,nrel,mamu,mag,mat,map,pmi) integer iy,nrel double precision mag,mat,map,mamu(*) type(meq_phase), pointer :: pmi -!\end{verbatim} +!\end{verbatim} %- ! these are to be multiplied with mu(ib), nothing, deltaT, deltaP ! I am not sure if this is used ... integer jy,ib @@ -3691,6 +4156,97 @@ end subroutine calc_dgdyterms2 !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ +!\begin{verbatim} %+ + subroutine calc_dgdytermsh(nrel,ia,tpindep,hval,mamu,mag,mat,map,pmi,& + curmux,noofits) +! This is a variant of dgdyterms1 including a term multiplied with each +! term (hval) in the summation over the comstituents as needed when calculating +! an equation for fix V or H. If hval(i)=1.0 it should give the same +! results as dgdyterms1 +! +! calculate the terms in the deltay expression for amounts of component ia +! +! DM_A = \sum_B mu_B*MAMU(B) - MAG - MAT*dt - MAP*dp +! +! where MAMU=\sum_i dM_A/dy_i*\sum_j invmat(i,j)*dM_B/dy_j +! c_iB=\sum_j invmat(i,j)*dM_B/dy_j etc etc +! +! it may not be very efficient but first get it right .... +! tpindep(1) is TRUE if T variable, tpindep(2) is TRUE if P are variable + implicit none + integer ia,nrel,noofits + logical tpindep(2) + double precision, dimension(*) :: hval,mamu + double precision mag,mat,map + double precision curmux(*) +! pmi is the phase data record for this phase + type(meq_phase), pointer :: pmi +!\end{verbatim} +! THIS IS MODIFIED FOR CONDITIONS ON H and related properties +! these are to be multiplied with mu(ib), nothing, deltaT, deltaP + integer iy,jy,ib + double precision sum,cig,cit,cip,cib + double precision morr,curmu(maxel) +! +! write(*,11)'in termsh: ',ia,0,0,pmi%invmat + mag=zero + do ib=1,nrel + sum=zero + do iy=1,pmi%ncc + cib=zero + do jy=1,pmi%ncc + cib=cib+pmi%invmat(iy,jy)*pmi%dxmol(ib,jy) + enddo + sum=sum+cib*hval(iy) +! write(*,11)'termsh mu: ',ib,iy,0,hval(iy),sum +11 format(a,3i2,6(1pe12.4)) + enddo + mamu(ib)=sum + enddo +!----------- +! if(noofits.eq.1) then +! curmu=zero +! else + do iy=1,nrel + curmu(iy)=curmux(iy) + enddo +! endif +!----------- +! \sum_i \sum_j e_ij*dM_A/dy_i dG/dy_j + mag=zero + mat=zero + map=zero + do iy=1,pmi%ncc + cig=zero + cit=zero + cip=zero + do jy=1,pmi%ncc +! I inversed order of iy, jy, does it still converge?? + cig=cig+pmi%invmat(jy,iy)*pmi%curd%dgval(1,jy,1) +! write(*,11)'termsh g: ',ia,iy,jy,pmi%invmat(jy,iy),& +! pmi%curd%dgval(1,jy,1),cig +! always calculate cit because cp debug!! +! hval(j)=dG/dy_j-Td2G/dTdy_j or something similar + if(tpindep(1)) then + cit=cit+pmi%invmat(jy,iy)*pmi%curd%dgval(2,jy,1) +! write(*,11)'termsh t: ',ia,iy,jy,pmi%curd%dgval(2,jy,1),cit + endif + if(tpindep(2)) cip=cip+& + pmi%invmat(jy,iy)*pmi%curd%dgval(3,jy,1) + enddo +! morr=pmi%dxmol(ia,iy) + morr=hval(iy) + mag=mag+morr*cig + mat=mat+morr*cit + map=map+morr*cip + enddo +! write(*,11)'termsh: ',ia,0,0,mag,mat,map,(mamu(jy),jy=1,nrel) +1000 continue + return + end subroutine calc_dgdytermsh + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + !\begin{verbatim} subroutine meq_evaluate_all_svfun(kou,ceq) ! evaluate and list values of all state variable functions @@ -3703,13 +4259,13 @@ subroutine meq_evaluate_all_svfun(kou,ceq) integer kf,nsvfun double precision val nsvfun=nosvf() - write(kou,75) + if(kou.gt.0) write(kou,75) 75 format('No Name ',12x,'Value') do kf=1,nsvfun ! actual arguments needed if svflista(kf)%nactarg>0 val=meq_evaluate_svfun(kf,actual_arg,0,ceq) if(gx%bmperr.ne.0) goto 1000 - write(kou,77)kf,svflista(kf)%name,val + if(kou.gt.0) write(kou,77)kf,svflista(kf)%name,val 77 format(i3,1x,a,1x,1PE15.8) enddo 1000 continue @@ -3735,6 +4291,7 @@ subroutine meq_get_state_varorfun_value(statevar,value,dummy,ceq) call get_state_var_value(statevar,value,encoded,ceq) if(gx%bmperr.ne.0) then ! if error try using meq_evaluate_svfun try calling meq_evaluate_svfun +! write(*,*)'In meq_get_state_varofun 2: ',gx%bmperr lrot=gx%bmperr gx%bmperr=0 encoded=statevar @@ -3742,6 +4299,8 @@ subroutine meq_get_state_varorfun_value(statevar,value,dummy,ceq) call find_svfun(encoded,lrot,ceq) if(gx%bmperr.ne.0) then ! if error here return previous error code +! write(*,*)'In meq_get_state_varofun 3: ',gx%bmperr + value=zero gx%bmperr=lrot; goto 1000 else mode=1 @@ -3770,17 +4329,21 @@ double precision function meq_evaluate_svfun(lrot,actual_arg,mode,ceq) TYPE(gtp_equilibrium_data), pointer :: ceq !\end{verbatim} ! THIS SUBROUTINE MOVED FROM pmod25D + character encoded*60 double precision argval(20) type(gtp_state_variable), pointer :: svr,svr2 integer jv,jt,istv,ieq,nsvfun double precision value ! + value=zero argval=zero nsvfun=nosvf() +! write(*,*)'in meq_evaluate_svfun 1',lrot,nsvfun,mode ! locate function if(lrot.le.0 .or. lrot.gt.nsvfun) then gx%bmperr=4140; goto 1000 endif +! write(*,*)'in meq_evaluate_svfun 2',svflista(lrot)%narg if(svflista(lrot)%narg.eq.0) goto 300 ! get values of arguments jv=0 @@ -3788,22 +4351,28 @@ double precision function meq_evaluate_svfun(lrot,actual_arg,mode,ceq) 100 continue jt=jt+1 istv=svflista(lrot)%formal_arguments(1,jt) +! write(*,*)'in meq_evaluate_svfun 3A',jt,istv if(istv.lt.0) then ! if eqnoval nonzero it indicates from which equilibrium to get its value ieq=svflista(lrot)%eqnoval +!******************************************************************** +! Note!! it should be evaluated!! Not implemented ... +!******************************************************************** if(ieq.eq.0) then value=ceq%svfunres(-istv) else value=eqlista(ieq)%svfunres(-istv) endif -! write(*,*)'evaluate_svfun symbol',ieq,value +! write(*,*)'in meq_evaluate_svfun 3X',ieq,istv,value else -! the 1:10 was a new bug discovered in GNU fortran 4.7 and later +! the need for 1:10 was a new bug discovered in GNU fortran 4.7 and later call make_stvrec(svr,svflista(lrot)%formal_arguments(1:10,jt)) if(gx%bmperr.ne.0) goto 1000 if(svflista(lrot)%formal_arguments(10,jt).eq.0) then -! get state variable value +! get state variable or symbol value +! write(*,*)'In meq_evaluate_svfun 3D: ',svr call state_variable_val(svr,value,ceq) +! error check at the end of if... else ! state variable derivative, the denominator is the next variable jt=jt+1 @@ -3813,10 +4382,11 @@ double precision function meq_evaluate_svfun(lrot,actual_arg,mode,ceq) ! This routine need access to the subroutines in the minimizer call meq_state_var_value_derivative(svr,svr2,value,ceq) endif - if(gx%bmperr.ne.0) goto 1000 endif + if(gx%bmperr.ne.0) goto 1000 jv=jv+1 argval(jv)=value +! write(*,*)'in meq_evaluate_svfun 3B: ',jv,jt,argval(jv) if(jt.lt.svflista(lrot)%narg) goto 100 ! all arguments evaluated (or no arguments needed) 300 continue @@ -3824,6 +4394,7 @@ double precision function meq_evaluate_svfun(lrot,actual_arg,mode,ceq) ! If mode=0 and SVFVAL set return the stored value value=ceq%svfunres(lrot) ! write(*,350)'evaluate svfun 2: ',0,lrot,value +350 format(a,2i4,1pe12.4) elseif(mode.eq.0 .and. btest(svflista(lrot)%status,SVFEXT)) then ! if mode=0 and SVFEXT set use value from equilibrium eqno ieq=svflista(lrot)%eqnoval @@ -3840,6 +4411,7 @@ double precision function meq_evaluate_svfun(lrot,actual_arg,mode,ceq) endif else ! if mode=1 always evaluate +! write(*,*)'in meq_evaluate_svfun 5',argval(1) value=evalf(svflista(lrot)%linkpnode,argval) if(pfnerr.ne.0) then write(*,*)'evaluate_svfun putfunerror ',pfnerr @@ -3848,8 +4420,8 @@ double precision function meq_evaluate_svfun(lrot,actual_arg,mode,ceq) endif modeval ! save value in current equilibrium ceq%svfunres(lrot)=value - meq_evaluate_svfun=value 1000 continue + meq_evaluate_svfun=value return end function meq_evaluate_svfun diff --git a/models/pmod25.F90 b/models/gtp3.F90 similarity index 89% rename from models/pmod25.F90 rename to models/gtp3.F90 index 865c6ca..c090085 100644 --- a/models/pmod25.F90 +++ b/models/gtp3.F90 @@ -1,1429 +1,1406 @@ -!*************************************************************** -! General Thermodynamic Package (GTP) -! for thermodynamic modelling and calculations -! -MODULE GENERAL_THERMODYNAMIC_PACKAGE -! -! Copyright 2011-2015, Bo Sundman, France -! -! This program is free software; you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation; either version 2 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -! -! contact person: bo.sundman@gmail.com -! -!----------------------------------------------------------------------- -! -! for known unfinished/unchecked bugs and parallelization problems -! look for BEWARE -! -!----------------------------------------------------------------------- -! -! Description of data structure -! -! For all elements, species and phases there are two arrays defined. -! The first (data) array contains the elements species etc and all their data -! in the order they were entered and the data are never moved. -! The second (index) array contain the elements, species etc in alphabetical -! (or whatever) order and is updated whenever a new element, species etc -! is added. This array is an integer array with the index of the data array. -! Most links inside the different records to elements, species etc -! are indices to the data array which is never changed. -! TPFUNS used in parameters are also stored in an array and the index -! to this array is stored in the property record to specify the function. -! -! For parameters inside each phase record there is one (or 2 if disordered set) -! lists with endmember parameters. Each endmember record can be the root -! of a binary tree with interaction parameters. Each of these records -! can have a property list with various data like G, TC, MQ etc. These -! records are created dynamically and can only be found by following the links. -! -! Each phase has one or more composition sets. These are part of the -! equilibrium data structure which also contains conditions, calculated -! values of TP functions and other symbols. -! -! An equilibrium record has been introduced. One such record is created -! in init_gtp and it is called FIRSTEQ which is a global variable. -! There is also an array EQLISTA which should contain all allocated -! equilibrium records, FIRSTEQ is a pointer to the first element in this array. -! More equilibrium records can be initiated by enter_equilibrium subroutine. -! This copies the relevant data from FIRSTEQ. -! After a second equilibrium is created it is forbidden to enter elements, -! species? or phases and create additional fraction sets, i.e. one must -! not change the data structure except to add/remove composition sets -! (but not implemented yet for multiple equilibria). Composition sets must be -! created in all equilibrium records at the same time (if done in a thread -! then all threads must stop while this is done). During step/map calculation -! each calculated equilibria is saved for later use in plotting och other -! postprocessing. These saved equilibria may have different number of -! composition sets so great care must be taken using them. -! -! The equilibrium data record is "stand alone" and contains all necessary -! data to describe the equilibrium (except the model parameters and other -! static data). In parallel processing each thread will have its own -! equilibrium data record. -! -! The intention is that several equilibra can be created both to store -! individual experimental data in assessments and for each thread in parallel. -! In the equilibrium record there are conditions, components (with chemical -! potentials) and an error code and most important, the phase_varres record -! array with one or more record for each phase. This array must be identical -! in all equilibria recods. Each composition set has a phase_varres record -! and they are linked from the phase record by the LIKTOCS array. As the -! phase_varres records are in an array the link is simply an integer index of -! this array. There is a free list inside the phase_varres array to be used -! when adding or removing a composition set. -! >>> NOT DONE: when composition sets are created they must be -! created in all equilibrium records at the same time. -! The EQ_TPRES array is declared inside the equilibrium record. -! The index to a function in EQ_TPRES is the same as the index to the TPFUN -! array declared globally in TPFUN. The TPFUN array has the actual expression, -! and EQ_TPRES has the last calculated results, which can be different in each -! equilibrium. The TPFUN index is used in property records to specify -! the function of a parameter. -! -! In many subroutines the equilibrium record called CEQ (Current EQilibrium) -! is an argument which means it operates on the data in that -! equilibrium record only. -! -! In the record array PHASE_VARRES (including disordered) each phase -! and composition set has a record. If no parallel calculation and no -! experiments the equilibrium record FIRSTEQ is enough. -! -! In programming for parallel processing THREADPRIVATE -! should be avoided as it usually has a very slow implementation. -! -! Some routines exist both with and without the CEQ argument. A programmer -! can create his own array of equilibrium data records and use any of -! them in such calls. ???? Maybe not, then how to update when a new -! composition set is needed??? -! -! Thread specific data are needed for conditions, phase status, constitution, -! function values and calc results like G and derivatives for each phase, -! amounts of phases etc. When calling a subroutine to get mole frations etc -! the equilibrium record CEQ must be supplied. -! -! The global error code is defined in tpfunlib, that is not very good. There -! must be an error code specific to each equilibrium. Or can one declare -! the error code as "local" to the thread? -! -! routines for inverting matrix etc - use lukasnum -! TP functions, tpfunlib makes USE of metlib - use tpfunlib -! for parallel processing, not used yet -! use OMP_LIB -! -!-------------------------------------------------------------------------- -! -! To be added or fixed (in no special order, * means priority): -! - *reference states for G, H, MU etc -! - volume model -! - parameter permutations for ordering (option B, done for F) -! - *dot derivatives -! - consistent units conversion between user/software (C/F/K,cal/BTU/eV/J etc) -! - reciprocal composition dependent parameters -! - HSS corrected quasichemical liquid model -! - multicomponent CVM tetrahedron fcc model -! - *other components than the elements -! - wildcards in state variables (like show x(*), partially done) -! - Implement SER phase data. When calculating with the SER phase one must -! have different magnetic models for different elements !! -! - amend_data for elements, species, phases, symbols -! - more symbols (variables, value-functions, PUTFUN functions, coefficients) -! - New magnetic model (Wei) -! - New heat capacity models (from 0 K) -! - Enable that state variables functions can call TP functions -! - Improve the grid for gridminimization -! - *find out how to handle the error code in parallel processing -! - *save/read of data using random access file -! - parallellisation -! - Modify gcalc so one can calcule just a single property like the mobility -! - write TDB files -! -!------------------------------------------------------------------------- -! -! Done so far -! date item -! 2013.03.01 Release version 1 -! -!================================================================= -! - IMPLICIT NONE -! -!----------------------------------------------------------------- -! error messages -! numbers 4000 to 4220 defined. gx%bmperr is set to message index - integer, parameter :: nooferm=4220 - character (len=64), dimension(4000:nooferm) :: bmperrmess - data bmperrmess(4000:4199)& - /'Too many coefficients in a TP function. ',& - 'Illegal character in a TP function, digit expected. ',& - 'Unknown symbol in TP function ',& - 'Expected ( after unary function ',& - 'Too many ) in a TP function ',& - 'Illegal character in a TP function ',& - 'Too few ) in a TP function ',& - 'Too many ( in exponent ',& - 'Illegally placed ( in the exponent of a TP function ',& - 'No digits after ( in the exponent of a TP function ',& -! 4010: - 'Illegally placed ) in exponent in TP function ',& - 'Too high power in a TP function, max 99, min -99 ',& - 'Missing ) in the exponent of a TP function ',& - 'Illegal termination of a TP function reading a TDB file ',& - 'No more free TP root records ',& - 'No more free TP expression records ',& - 'Illegal expression inside unary argument of a TP function ',& - 'Illegal code found when evaluating a TP function ',& - 'Found a coefficent zero in a term of a TP function ',& - 'Illegal code in a TP function ',& -! 4020: - 'Negative argument to logarithm in a TP function ',& - 'Unknown unary function in evaluation for a TP function ',& - 'Too many symbols in a TP function term ',& - 'Two unary functions in a TP function term ',& - 'Too complicated TP function term ',& - 'Too many temperature ranges in a TP function ',& - 'TP function with same name already entered ',& - 'Symbol referenced in a parameter does not exist ',& - 'Missing separator between phase and constituent array in paramet',& - 'Cannot enter disordered fraction set when several composition se',& -! 4030 - 'Cannot enter disordered fraction set when suspended constituents',& - 'Wildcards in interaction parameters not yet implemented ',& - 'Interaction between 2 wildcards are illegal ',& - 'Illegal character in element symbol ',& - 'Element with this symbol already entered ',& - 'Element symbol and name must start with letter A-Z ',& - 'Reference state must start with letter A-Z ',& - 'Element mass must not be negative ',& - 'Enthalpy difference H298-H0 must be positive ',& - 'Entropy at 298.15 must be positive ',& -! 4040 - 'Too many elements ',& - 'Too many species ',& - 'No such element ',& - 'Text position outside text ',& - 'Species symbol must start with letter A-Z ',& - 'No elements or too many elements in species formula ',& - 'Unknown element in species formula ',& - 'Negative stoichiometric factor in species ',& - 'The charge must be the final "element" ',& - 'Species already entered ',& -! 4050 - 'No such phase ',& - 'No such species ',& - 'No such component ',& - 'Phase name must start with letter A-Z ',& - 'Phase already entered ',& - 'Model not implemented yet ',& - 'Too few or too many sublattices ',& - 'Sites on a sublattice must be positive ',& - 'Too few or too many constituents in a sublattice ',& - 'Too many constituents ',& -! 4060 - 'No such TP function ',& - 'Expected constituent array, found nothing ',& - 'Illegal character in constituent array ',& - 'Illegal degree of parameter, must be 0-9 ',& - 'No free interaction records ',& - 'Wrong number of sublattices ',& - 'No such constituent in a sublattice ',& - 'No such interacting constituent ',& - 'This phase has no disordered fraction set ',& - 'Wrong number of sublattices in disordered fraction set ',& -! 4070 - 'No free endmember records ',& - 'No free property records ',& - 'No such composition set ',& - 'Inconsistent composition set specifications ',& - 'Overflow in push ',& - 'Undeflow in pop ',& - 'Sublattice out of range for entering disordered fraction set ',& - 'Disordered fraction set already entered ',& - 'Not implemented yet ',& - 'Ionic liquid Not implemented yet ',& -! 4080 - 'Suspended constituents not implemented yet ',& - 'Stability factor not implemented yet ',& - 'No such composition dependent property parameter ',& - 'Empty line, expected species stoichiometry ',& - 'No element in species stoichiometry ',& - 'Species cannot be entered as it is implicitly suspended ',& - 'Excess model not implemented yet ',& - 'Bad name for a symbol ',& - 'Too deeply nested TP functions ',& - 'Reading unknown addition type from file ',& -! 4090 - 'Addition already entered ',& - 'No more addition records ',& - 'Maximum 9 composition sets ',& - 'Illegal composition set number ',& - 'No more records for phases or composition sets. ',& - 'Hidden phase cannot be ENTERED, SUSPENDED, DORMANT or FIXED ',& - 'No such constituents ',& - 'Too many argument to a state variable ',& - 'This state variable must have two arguments ',& - 'First character of a state variable is wrong ',& -! 4100 - 'State variable starting with M not followed by U ',& - 'State variable starting with L not followed by NAC ',& - 'Missing ( for arguments for state variable ',& - 'Missing ) after arguments of state variable ',& - 'Unknown phase used as state varible argument ',& - 'Unknown constituent used as state variable argument ',& - 'Unknown component used as state variable argument ',& - 'State variable starting with D not followed by G ',& - 'State variable starting with T follwed by other character than C',& - 'State variable starting with B missing P, MAG, M, V, W or F ',& -! 4110 - 'This state variable cannot not have two arguments ',& - 'This state variable must have an argument ',& - 'Impossible reference state for this constituent ',& - 'No such property for this phase ',& - 'Cannot calculate property value per volume as no volume data ',& - 'Property per formula unit only for a single phase ',& - 'State variable number must be larger than zero ',& - 'Only state variable Y can have 3 indices ',& - 'Illegal normalization of state variable ',& - 'Phase is hidden ',& -! 4120 - 'Wrong syntax for mobility variable ',& - 'Ambiguous phase name ',& - 'Illegal name for an equilibrium ',& - 'Equilibrium with this name already entered ',& - 'No such equilibrium ',& - 'Not allowed to enter more model data ',& - 'No state variable supplied ',& - 'Illegal state variable for conditions ',& - 'Only one kind of state variable in expressions ',& - 'Illegal value for a state variable ',& -! 4130 line below - 'Factor in front of a condition must be followed by * ',& - 'No such condition ',& - 'Function name must start with a letter A-Z ',& - 'Function name and expression must be separated by "=" ',& - 'Error in function expression (putfun) ',& - 'Unknown symbol used in function ',& - 'Symbol with this name already entered ',& - 'Symbol name must start with letter A-Z ',& - 'Illegal character in symbol name ',& - 'Cannot check name of unknown kind of symbol ',& -! 4140 - 'No such symbol ',& - 'Error evaluating symbol value ',& - 'Error listing symbol expression ',& - 'No conditions at all ',& - 'Degrees of freedom not zero ',& - 'Unknown type of addition ',& - 'Quitting due to repeated input error ',& - 'Gridminimizer found gridpoint outside range ',& - 'Gridminimizer error when generating endmember values ',& - 'Gridminimizer found an element without gridpoint ',& -! 4150 next line - 'Gridminimizer have no gridpoint for a pure element ',& - 'Conditions not only T, P and massbalance ',& - 'Illegal to set all phases as fix ',& - 'Cannot enter a new equilibrium if there are no phases ',& - 'Trying to enter an illegal reference ',& - 'A reference must have an identifier ',& - 'Reference identifier already exists ',& - 'Error in TDB file, species terminator error ',& - 'Unknown potential ',& - 'Cannot calculate potentials for charged constituents ',& -! 4160 next line - 'Illegal endmember for reference state ',& - 'End member without atoms ',& - 'Same species twice in component list ',& - 'Component stoichiometry matrix singular ',& - 'Too many interaction levels ',& - 'Error reading save file ',& - 'Error reading save file at EOF ',& - 'Composition set prefix must start with a letter ',& - 'This property has no specifier ',& - 'Parameter specifier missing ',& -! 4170 - 'Properties needed for Inden magnetic model not defined ',& - 'Request for non-existing chemical potential ',& - 'Removing current data not implemented ',& - 'Grid minimization not allowed ',& - 'Illegal composition in call to grid minimization ',& - 'Too many gridpoints ',& - 'No phases and no gridpoints in call to grid minimization ',& - 'Grid minimizer want to create composition set but is not allowed',& - 'Non-existing fix phase ',& - 'State variable N or B cannot have two indices for grid minimizer',& -! 4180 - 'Condition on B is not allowed for grid minimizer ',& - 'Element has no composition in grid minimizer ',& - 'Too complicated mass balance conditions ',& - 'Two mass balance conditions for same element ',& - 'Cannot handle conditions on both N and B ',& - 'No mole fractions when summing composition ',& - 'Error in TDB file, missing function ',& - ' ',& - ' ',& - ' ',& -! 4190 - ' ',& - ' ',& - ' ',& - ' ',& - ' ',& - ' ',& - ' ',& - ' ',& - ' ',& - ' '/ -! 4200 errors in minimizer - data bmperrmess(4200:4220)& - /'No phase that can be set stable ',& - 'Attempt to set too many phaes as stable ',& - 'Total amount is negative ',& - 'Error solving system matrix ',& - 'Too many iterations ',& - 'Phase matrix singular ',& - 'Cannot handle models without analytical second derivativatives ',& - 'Ionic liquid model not implemented yet ',& - ' ',& - ' ',& -! 4210 - 'Phase change not allowed due to step/map constraints ',& - ' ',& - ' ',& - ' ',& - ' ',& - ' ',& - ' ',& - ' ',& - ' ',& - ' ',& -! 4220 - ' '/ -! last used error codes above -! -!================================================================= -! -!\begin{verbatim} -!-Bits in global status word (GS) in globaldata record -! level of user: beginner, occational, advanced; NOGLOB: no global gridmin calc -! NOMERGE: no merge of gridmin result, NODATA: not any data, -! NOPHASE: no phase in system, NOACS: no automatic creation of composition set -! NOREMCS: do not remove any redundant unstable composition sets -! NOSAVE: data changed after last save command -! VERBOSE: maximum of listing -! SETVERB: explicit setting of verbose -! SETSILENT: as little aoutput as possible -! NOAFTEREQ: no manipulations of results after equilirum calculation -! >>>> some of these should be moved to the gtp_equilibrium_data record - integer, parameter :: & - GSBEG=0, GSOCC=1, GSADV=2, GSNOGLOB=3, & - GSNOMERGE=4, GSNODATA=5, GSNOPHASE=6, GSNOACS=7, & - GSNOREMCS=8, GSNOSAVE=9, GSVERBOSE=10, GSSETVERB=11,& - GSSILENT=12, GSNOAFTEREQ=13 -!-Bits in element record - integer, parameter :: & - ELSUS=0 -!-Bits in species record -! Suspended, implicitly suspended, species is element, species is vacancy -! species have charge, species is (system) component - integer, parameter :: & - SPSUS=0, SPIMSUS=1, SPEL=2, SPVA=3, & - SPION=4, SPSYS=5 -!\end{verbatim} -!\begin{verbatim} -!-Bits in phase record -! hidden, implictly hidden, ideal, no concentration variation (NOCV), -! Phase has parameters entered (PHHASP), -! F option (FORD), B option (BORD), Sigma ordering (SORD), -! multiple/disordered fraction sets (MFS), gas, liquid, ionic liquid, -! aqueous, dilute config. entropy (DILCE), quasichemical (QCE), CVM, -! FACT, not create comp. sets (NOCS), Helmholz energy model (HELM), -! Model without 2nd derivatives (PHNODGDY2), Elastic model A, -! explicit charge balance needed (XCB), - integer, parameter :: & - PHHID=0, PHIMHID=1, PHID=2, PHNOCV=3, & ! 1 2 4 8 - PHHASP=4, PHFORD=5, PHBORD=6, PHSORD=7, & - PHMFS=8, PHGAS=9, PHLIQ=10, PHIONLIQ=11, & - PHAQ1=12, PHDILCE=13, PHQCE=14, PHCVMCE=15,& - PHFACTCE=16, PHNOCS=17, PHHELM=18, PHNODGDY2=19,& - PHELMA=20, PHEXCB=21 -! -!-Bits in constituent fraction (phase_varres) record STATUS2 -! CSDFS is set if record is for disordred fraction set, then one must use -! sublattices from fraction_set record -! CSDLNK: a disordred fraction set in this phase_varres record -! CSSUS and CSFIXDORM replaced by the integer PHSTATE -!- CSSUS: set if comp. set if must not be stable, -!- CSFIXDORM: set if fix or dormant, -! CSCONSUS set if one or more constituents suspended (status array constat -! specify constituent status) -! CSORDER: set if fractions are ordered (only used for BCC/FCC ordering -! with a disordered fraction set). -! CSSTABLE: set if phase is stable after an equilibrium calculation -! CSAUTO set if composition set created during calculations -! CSDEFCON set if there is a default constitution -! NOTE phase_status ENTERED means both CSSUS and CSFIXDORM are sero (not set) - integer, parameter :: & -! CSDFS=0, CSDLNK=1, CSSUS=2, CSFIXDORM=3, & - CSDFS=0, CSDLNK=1, CSDUM2=2, CSDUM3=3, & - CSCONSUS=4, CSORDER=5, CSSTABLE=6, CSAUTO=7, & - CSDEFCON=8 -!\end{verbatim} -!\begin{verbatim} -!-Bits in constat array for each constituent -! For each constituent: is suspended, is implicitly suspended, is vacancy - integer, parameter :: & - CONSUS=0,CONIMSUS=1,CONVA=2 -!-Bits in state variable functions (svflista) -! SVFVAL symbol evaluated only explicitly (mode=1 in call) - integer, parameter :: & - SVFVAL=0,SVFEXT=1 -!-Bits in gtp_equilibrium_data record -! EQNOTHREAD set if equilibrium must be calculated before threading -! (in assessment) for example if a symbol must be evaluated in this -! equilibrium before used in another like H(T)-H298 -! EQNOGLOB set if no global minimization -! EQNOEQCAL set if no successful equilibrium calculation made -! EQINCON set if current conditions inconsistent with last calculation -! EQFAIL set if last calculation failed -! EQNOACS set if no automatic composition sets ?? not used !! see GSNOACS -! EQGRIDTEST set if grid minimizer should be used after equilibrium - integer, parameter :: & - EQNOTHREAD=0, EQNOGLOB=1, EQNOEQCAL=2, EQINCON=3, & - EQFAIL=4, EQNOACS=5, EQGRIDTEST=6 -!-Bits in parameter property type record (gtp_propid) -! constant (no T or P dependence), only P, property has an element suffix -! (like mobility), property has a constituent suffix - integer, parameter :: & - IDNOTP=0, IDONLYP=1, IDELSUFFIX=2, IDCONSUFFIX=3 -!- Bits in condition status word (some set in onther ways??) -! singlevar means T=, x(el)= etc, singlevalue means value is a number -! phase means the condition is a fix phase - integer, parameter :: & - ACTIVE=0,SINGLEVAR=1,SINGLEVALUE=2,PHASE=3 -! -! >>> Bits for symbols and TP functions missing ??? -!\end{verbatim} -! -!---------------------------------------------------------------------- -! -!\begin{verbatim} -! some constants, phase status - integer, parameter :: PHHIDDEN=-4 - integer, parameter :: PHSUS=-3 - integer, parameter :: PHDORM=-2 - integer, parameter :: PHENTUNST=-1 - integer, parameter :: PHENTERED=0 - integer, parameter :: PHENTSTAB=1 - integer, parameter :: PHFIXED=2 - character (len=12), dimension(-4:2), parameter :: phstate=& - (/'HIDDEN ','SUSPENDED ','DORMANT ','ENTERED UNST',& - 'ENTERED ','ENTERED STBL','FIXED '/) -!\end{verbatim} -! -!---------------------------------------------------------------------- -! -!\begin{verbatim} -! Parameters defining the size of arrays etc. -! max elements, species, phases, sublattices, constituents (ideal phase) - integer, parameter :: maxel=100,maxsp=1000,maxph=400,maxsubl=10,maxconst=1000 -! maximum number of consitutents in non-ideal phase - integer, parameter :: maxcons2=100 -! maximum number of elsements in a species - integer, parameter :: maxspel=10 -! maximum number of references - integer, private, parameter :: maxrefs=1000 -! maximum number of equilibria - integer, private, parameter :: maxeq=500 -! some dp values, default precision of Y and default minimum value of Y -! zero and one set in tpfun - double precision, private, parameter :: YPRECD=1.0D-6,YMIND=1.0D-30 -! dimension for push/pop in calcg, max composition dependent interaction - integer, private, parameter :: maxpp=1000,maxinter=3 -! max number of TP symbols - integer, private, parameter :: maxtpf=20*maxph -! max number of properties (G, TC, BMAG MQ%(...) etc) - integer, private, parameter :: maxprop=50 -! max number of state variable functions - integer, private, parameter :: maxsvfun=500 -! version number -! changes in last 2 digits means no change in SAVE/READ format - character*8, parameter :: gtpversion='GTP-2.00' - character*8, parameter :: savefile='OCF-2.00' -!\end{verbatim} -!================================================================= -!\begin{verbatim} -! The number of additions to the Gibbs energy of a phase is increasing -! This is a way to try to organize them. Each addtion has a unique -! number identifying it when created, listed or calculated. These -! numbers are defined here - integer, public, parameter :: indenmagnetic=1 - integer, public, parameter :: debyecp=2 - integer, public, parameter :: weimagnetic=3 - integer, public, parameter :: einsteincp=4 - integer, public, parameter :: elasticmodela=5 - integer, public, parameter :: glastransmodela=6 -! Note that additions often use parameters like Curie or Debye temperatures -! defined by parameter identifiers stored in gtp_propid -!\end{verbatim} -!================================================================= -! -! below here are data structures and global data in this module -! -!================================================================= -!\begin{verbatim} - TYPE gtp_global_data -! status should contain bits how advanced the user is and other defaults -! it also contain bits if new data can be entered (if more than one equilib) - integer status - character name*24 - double precision rgas,rgasuser,pnorm - END TYPE gtp_global_data - TYPE(gtp_global_data) :: globaldata -!\end{verbatim} -!================================================================= -! -! below here are thermodynamic model data structures -! -!================================================================= -! -!\begin{verbatim} -! this constant must be incremented whenever a change is made in gtp_element - INTEGER, parameter :: gtp_element_version=1 - TYPE gtp_element -! data for each element: symbol, name, reference state, mass, h298-h0, s298 - character :: symbol*2,name*12,ref_state*24 - double precision :: mass,h298_h0,s298 -! splink: index of corresponing species in array splink -! Status bits are stored in the integer status -! alphaindex: the alphabetical order of this elements -! refstatesymbol: indicates H0 (1), H298 (0, default) or G (2) for endmembers - integer :: splink,status,alphaindex,refstatesymbol - END TYPE gtp_element -! allocated in init_gtp - TYPE(gtp_element), private, allocatable :: ellista(:) - INTEGER, private, allocatable :: ELEMENTS(:) -!\end{verbatim} -!----------------------------------------------------------------- -!\begin{verbatim} -! this constant must be incremented whenever a change is made in gtp_species - INTEGER, parameter :: gtp_species_version=1 - TYPE gtp_species -! data for each species: symnol, mass, charge, status -! mass is in principle redundant as calculated from element mass - character :: symbol*24 - double precision :: mass,charge -! alphaindex: the alphabetical order of this species -! noofel: number of elements - integer :: noofel,status,alphaindex -! Use an integer array ellinks to indicate the elements in the species -! The corresponing stoichiometry is in the array stochiometry -! ???? these should not be pointers, changed to allocatable ???? - integer, dimension(:), allocatable :: ellinks - double precision, dimension(:), allocatable :: stoichiometry - END TYPE gtp_species -! allocated in init_gtp - TYPE(gtp_species), private, allocatable :: splista(:) - INTEGER, private, allocatable :: SPECIES(:) -!\end{verbatim} -!----------------------------------------------------------------- -!\begin{verbatim} -! this constant must be incremented whenever a change is made in gtp_component - INTEGER, parameter :: gtp_component_version=1 - TYPE gtp_components -! The components are simply an array of indices to species records -! the components must be "orthogonal". There is always a "systems components" -! that by default is the elements. -! Later one may implement that the user can define a different "system set" -! and also specific sets for each phase. -! The reference state is set as a phase and value of T and P. -! The name of the phase and its link and the link to the constituent is stored -! the endmember array is for the reference phase to calculate GREF -! The last calculated values of the chemical potentials (for user defined -! and default reference states) should be stored here. -! molat is the number of moles of components in the defined reference state - integer :: splink,phlink,status - character*16 :: refstate - integer, dimension(:), allocatable :: endmember - double precision, dimension(2) :: tpref - double precision, dimension(2) :: chempot - double precision mass,molat - END TYPE gtp_components -! allocated in gtp_equilibrium_data -!\end{verbatim} -!----------------------------------------------------------------- -!\begin{verbatim} -! this constant must be incremented whenever a change is made in gtp_endmember - INTEGER, parameter :: gtp_endmember_version=1 - TYPE gtp_endmember -! end member parameter record, note ordered phases can have -! several permutations of fraction pointers like for B2: (Al:Fe) and (Fe:Al). -! There are links (i.e. indices) to next end member and to the interactio tree -! and to a list of property record -! The phase link is needed for SAVE/READ as one cannot know the number of -! sublattices otherwise. One could just store nsl but a link back to the -! phase record might be useful in other cases. -! noofpermut: number of permutations (for ordered phases: (Al:Fe) and (Fe:Al) -! phaselink: index of phase record -! antalem: sequenial order of creation, useful to keep track of structure -! propointer: link to properties for this endmember -! nextem: link to next endmember -! intponter: root of interaction tree of parameters -! fraclinks: indices of fractions to be multiplied with the parameter - integer :: noofpermut,phaselink,antalem - TYPE(gtp_property), pointer :: propointer - TYPE(gtp_endmember), pointer :: nextem - TYPE(gtp_interaction), pointer :: intpointer -! there is at least one fraclinks per sublattice -! the second index of fraclinks is the permutation (normally only one) -! the first indec of fraclinks points to a fraction for each sublattice. -! The fractions are numbered sequentially independent of sublattices, a -! sigma phase with (FE:CR,MO:CR,FE,MO) has 6 fractions (incl one for FE in -! first sublattice) and the end member (FE:MO:CR) has the fraclinks 1,3,4 -! This means these values can be used as index to the array with fractions. -! The actual species can be found via the sublattice record -! integer, dimension(:,:), pointer :: fraclinks - integer, dimension(:,:), allocatable :: fraclinks - END TYPE gtp_endmember -! dynamically allocated when entering a parameter -!\end{verbatim} -!----------------------------------------------------------------- -!\begin{verbatim} -! this constant must be incremented when a change is made in gtp_interaction - INTEGER, parameter :: gtp_interaction_version=1 - TYPE gtp_interaction -! this record constitutes the parameter tree. There are links to NEXT -! interaction on the same level (i.e. replace current fraction) and -! to HIGHER interactions (i.e. includes current interaction) -! There can be several permutations of the interactions (both sublattice -! and fraction permuted, like interaction in B2 (Al:Al,Fe) and (Al,Fe:Al)) -! The number of permutations of interactions can be the same, more or fewer -! comparared to the lower order parameter (endmember or other interaction). -! The necessary information is stored in noofip. It is not easy to keep -! track of permutations during calculations, the smart way to store the last -! permutation calculated is in this record ... but that will not work for -! parallell calculations as this record is static ... -! status: may be useful eventually -! antalint: sequential number of interaction record, to follow the structure -! order: for permutations one must have a sequential number in each node -! propointer: link to properties for this parameter -! nextlink: link to interaction on same level (replace interaction) -! highlink: link to interaction on higher level (include this interaction) -! sublattice: (array of) sublattices with interaction fraction -! fraclink: (array of) index of fraction to be multiplied with this parameter -! noofip: (array of) number of permutations, see above. - integer status,antalint,order - TYPE(gtp_property), pointer :: propointer - TYPE(gtp_interaction), pointer :: nextlink,highlink - integer, dimension(:), allocatable :: sublattice,fraclink,noofip - END TYPE gtp_interaction -! allocated dynamically and linked from endmember records -!\end{verbatim} -!----------------------------------------------------------------- -!\begin{verbatim} -! this constant must be incremented when a change is made in gtp_property - INTEGER, parameter :: gtp_property_version=1 - TYPE gtp_property -! This is the property record. The end member and interaction records -! have pointer to this. Severall different properties can be linked -! from a parameter record like G, TC, BMAGN, VA, MQ etc. -! Some properties are connected to a constituent (or component?) like the -! mobility and also the Bohr mangneton number. -! Allocated as linked from endmembers and interaction records -! reference: can be used to indicate the source of the data -! refix: can be used to indicate the source of the data -! nextpr: link to next property record -! extra: TOOP and KOHLER can be implemented inside the property record -! proptype: type of propery, 1 is G, other see parameter property -! degree: if parameter has Redlich-Kister or similar degrees (powers) -! degreelink: indices of TP functions for different degrees (0-9) -! protect: can be used to prevent listing of the parameter -! antalprop: probably redundant (from the time of arrays of propery records) - character*16 reference - TYPE(gtp_property), pointer :: nextpr - integer proptype,degree,extra,protect,refix,antalprop - integer, dimension(:), allocatable :: degreelink - END TYPE gtp_property -! property records, linked from endmember and interaction records, allocated -! when needed. Each propery like G, TC, has a property record linking -! a TPFUN record (by index to tpfun_parres) -!\end{verbatim} -!----------------------------------------------------------------- -!\begin{verbatim} -! this constant must be incremented when a change is made in gtp_biblioref -! old name gtp_datareference - INTEGER, parameter :: gtp_biblioref_version=1 - TYPE gtp_biblioref -! store data references -! reference: can be used for search of reference -! refspec: free text - character*16 reference - character*64, dimension(:), allocatable :: refspec - END TYPE gtp_biblioref -! allocated in init_gtp - TYPE(gtp_biblioref), private, allocatable :: bibrefs(:) -!\end{verbatim} -!----------------------------------------------------------------- -!\begin{verbatim} -! this constant must be incremented when a change is made in gtp_propid - INTEGER, parameter :: gtp_propid_version=1 - TYPE gtp_propid -! this identifies different properties that can depend on composition -! Property 1 is the Gibbs energy and the others are usually used in -! some function to contribute to the Gibbs energy like TC or BMAGN -! But one can also have properties used for other things like mobilities -! with additional especification like MQ&FE -! symbol: property identifier like G for Gibbs energy -! note: short description for listings -! prop_elsymb: additional for element dependent properties like mobilities - character symbol*4,note*16,prop_elsymb*2 -! Each property has a unique value of idprop. Status can state if a property -! has a constituent specifier or if it can depend on T or P - integer status -! this can be a constituent specification for Bohr mangetons or mobilities -! such specification is stored in the property record, not here -! integer prop_spec,listid -! >>> added "listid" as a conection to the "state variable" listing here. -! This replaces TC, BMAG, MQ etc included as "state variables" in order to -! list their values. In this way all propids become available - end TYPE gtp_propid -! the value TYPTY stored in property records is "idprop" or -! if IDELSUFFIX set then 100*"idprop"+ellista index of element -! if IDCONSUFFIX set then 100*"idprop"+constituent index -! When the parameter is read the suffix symbol is translated to the -! current element or constituent index - TYPE(gtp_propid), dimension(:), private, allocatable :: propid -!\end{verbatim} -!----------------------------------------------------------------- -!\begin{verbatim} -! this constant must be incremented when a change is made in gtp_phase_add - INTEGER, parameter :: gtp_phase_add_version=1 - TYPE gtp_phase_add -! record for additions to the Gibbs energy for a phase like magnetism -! addrecno: ? -! aff: antiferomagnetic factor (Inden model) -! need_property: depend on these properties (like Curie T) -! explink: function to calculate with the properties it need -! nextadd: link to another addition - integer type,addrecno,aff - integer, dimension(:), allocatable :: need_property - TYPE(tpfun_expression), dimension(:), pointer :: explink - TYPE(gtp_phase_add), pointer :: nextadd - type(gtp_elastic_modela), pointer :: elastica - END TYPE gtp_phase_add -! allocated when needed and linked from phase record -!\end{verbatim} -!----------------------------------------------------------------- -!\begin{verbatim} -! addition record to calculate the elastic energy contribution -! declared as allocatable in gtp_phase_add -! this constant must be incremented when a change is made in gtp_elastic_modela - INTEGER, parameter :: gtp_elastic_modela_version=1 - TYPE gtp_elastic_modela -! lattice parameters (configuration) in 3 dimensions - double precision, dimension(3,3) :: latticepar -! epsilon in Voigt notation - double precision, dimension(6) :: epsa -! elastic constant matrix in Voigt notation - double precision, dimension(6,6) :: cmat -! calculated elastic energy addition (with derivative to T and P?) - double precision, dimension(6) :: eeadd -! maybe more - end TYPE gtp_elastic_modela -!\end{verbatim} -!----------------------------------------------------------------- -!\begin{verbatim} -! this constant must be incremented when a change is made in gtp_phasetuple - INTEGER, parameter :: gtp_phasetuple_version=1 - TYPE gtp_phasetuple -! for handling a single array with phases and composition sets -! first index is phase index, second index is composition set -! A tuplet index always refer to the same phase+compset. New tuples with -! the same phase and other compsets are added at the end. - integer phase,compset - end TYPE gtp_phasetuple -!\end{verbatim} -! declared globally -!----------------------------------------------------------------- -! NOTE: if one wants to model bond energies beteween sites in a phase -! like in a 3 sublattice sigma one can enter parameters like G(sigma,A:B:*) -! which will mean the bond energy between an A atom in first sublattice and -! B in the second. The parameter G(sigma,B:A:*) will be different. Such -! parameters are added to the Gibbs energy even if there are G(sigma,A:B:C) -!----------------------------------------------------------------- -!\begin{verbatim} -! a smart way to have an array of pointers used in gtp_phase - TYPE endmemrecarray - type(gtp_endmember), pointer :: p1 - end TYPE endmemrecarray -!----------------------------------------------------------------- -! this constant must be incremented when a change is made in gtp_phase - INTEGER, parameter :: gtp_phase_version=1 - TYPE gtp_phaserecord -! this is the record for phase model data. It points to many other records. -! Phases are stored in order of creation in phlista(i) and can be found -! in alphabetical order through the array phases(i) -! sublista is now removed and all data included in phlista -! sublattice and constituent data (they should be merged) -! The constitent link is the index to the splista(i), same function -! as LOKSP in iws. Species in alphabetcal order is in species(i) -! One can allocate a dynamic array for the constituent list, done -! by subroutine create_constitlist. -! Note that the phase has a dynamic status word status2 in gtp_phase_varres -! which can be differnt in different parallell calculations. -! This status word has the FIX/ENT/SUS/DORM status bits for example -! name: phase name, note composition sets can have pre and suffixes -! model: free text -! phletter: G for gas, L for liquid -! alphaindex: the alphabetcal order of the phase (excluding gas and liquids) - character name*24,models*72,phletter*1 - integer status1,alphaindex -! noofcs: number of composition sets, -! nooffs: number of fraction sets (replaces partitioned phases in TC) - integer noofcs,nooffs -! additions: link to addition record list -! ordered: link to endmember record list -! disordered: link to endmember list for disordered fractions (if any) - TYPE(gtp_phase_add), pointer :: additions - TYPE(gtp_endmember), pointer :: ordered,disordered -! To allow parallel processing of endmembers, store a pointer to each here - integer noemr,ndemr - TYPE(endmemrecarray), dimension(:), allocatable :: oendmemarr,dendmemarr -!----------------------------------------------------------------- -! this used to be sublista but is now incorporated in gtp_phaserecord !!! -! static data, contains pointers to constituent record and sites -! noofsubl: number if sublattices -! cslink: is index to first composition set (deleted) -! linktocs: array with indices to phase_varres records (to replace clink) -! tnooffr: total number of fractions (constituents) -! nooffr: array with number of constituents in each sublattice -! sites: array with site rations (? dynamic for ionic liquid) -! constitlist: indices of species that are constituents (in all soblattices) - integer noofsubl,tnooffr - integer, dimension(9) :: linktocs - integer, dimension(:), allocatable :: nooffr -! number of sites in phase_varres record as it can vary with composition -! double precision, dimension(:), allocatable :: sites - integer, dimension(:), allocatable :: constitlist -! used in ionic liquid: -! i2slx(1) is index of Va, i2slx(2) is index if last anion (both can be zero) - integer, dimension(2) :: i2slx -! allocated in init_gtp. - END TYPE gtp_phaserecord -! NOTE phase with index 0 is the reference phase for the elements -! The array sublista is now merged into phlista -! allocated in init_gtp - TYPE(gtp_phaserecord), private, allocatable :: phlista(:) - INTEGER, private, allocatable :: PHASES(:) - TYPE(gtp_phasetuple), allocatable :: PHASETUPLE(:) -!\end{verbatim} -!----------------------------------------------------------------- -! -!=================================================================== -! -! below here are data structures for equilibrium description -! -!=================================================================== -! -!----------------------------------------------------------------- -!\begin{verbatim} -! this constant must be incremented when a change is made in gtp_state_variable - INTEGER, parameter :: gtp_state_variable_version=2 - TYPE gtp_state_variable -! this is to specify a formal or real argument to a function of state variables -! statev/istv: state variable index -! phref/iref: if a specified reference state (for chemical potentials) -! unit/iunit: 100 for percent, no other defined at present -! argtyp together with the next 4 integers represent the indices(4), only 0-4 -! argtyp=0: no indices (T or P) -! argtyp=1: component -! argtyp=2: phase and compset -! argtyp=3: phase and compset and component -! argtyp=4: phase and compset and constituent - integer statevarid,norm,unit,phref,argtyp -! these integers represent the previous indices(4) - integer phase,compset,component,constituent -! a state variable can be part of an expression with coefficients -! the coefficient can be stored here. Default value is unity. -! In many cases it is ignored - double precision coeff -! NOTE this is also used to store a condition of a fix phase -! In such a case statev is negative and the absolute value of statev -! is the phase index. The phase and compset indices are also stored in -! "phase" and "compset" ?? -! This is a temporary storage of the old state variable identifier - integer oldstv - end TYPE gtp_state_variable -! used for state variables/properties in various subroutines -!\end{verbatim} -!----------------------------------------------------------------- -!\begin{verbatim} -! this constant must be incremented when a change is made in gtp_condition -! NOTE on unformatted SAVE files the conditions are written as texts - INTEGER, parameter :: gtp_condition_version=1 - TYPE gtp_condition -! these records form a circular list linked from gtp_equilibrium_data records -! each record contains a condition to be used for calculation -! it is a state variable equation or a phase to be fixed -! The state variable is stored as an integer with indices -! NOTE: some state variables cannot be used as conditions: Q=18, DG=19, 25, 26 -! There can be several terms in a condition (like x(liq,c)-x(fcc,c)=0) -! noofterms: number of terms in condition expression -! statev: the type of state variable (must be the same in all terms) -! negative value of statev means phase index for fix phase -! active: zero if condition is active, nonzero for other cases -! unit: is 100 if value in percent, can also be used for temperature unit etc. -! nid: identification sequential number (in order of creation), redundant -! iref: part of the state variable (iref can be comp.set number) -! iunit: ? confused with unit? -! seqz is a sequential index of conditions, used for axis variables -! symlink: index of symbol for prescribed value (1) and uncertainity (2) -! condcoeff: there is a coefficient and set of indices for each term -! prescribed: the prescribed value -! NOTE: if there is a symlink value that is the prescribed value -! current: the current value (not used?) -! uncertainity: the uncertainity (for experiments) - integer :: noofterms,statev,active,iunit,nid,iref,seqz -! TYPE(putfun_node), pointer :: symlink1,symlink2 -! better to let condition symbol be index in svflista array - integer symlink1,symlink2 - integer, dimension(:,:), allocatable :: indices - double precision, dimension(:), allocatable :: condcoeff - double precision prescribed, current, uncertainity -! currently this is not used but it will be - TYPE(gtp_state_variable), dimension(:), allocatable :: statvar - TYPE(gtp_condition), pointer :: next, previous - end TYPE gtp_condition -! declared inside the gtp_equilibrium_data record -!\end{verbatim} -!----------------------------------------------------------------- -!\begin{verbatim} -! this constant must be incremented when a change is made in gtp_putfun_lista - INTEGER, parameter :: gtp_putfun_lista_version=1 - TYPE gtp_putfun_lista -! these are records for state variable functions. The function itself -! is handelled by the putfun package. -! linkpnode: pointer to start node of putfun expression -! narg: number of symbols in the function -! nactarg: number of actual parameter specifications needed in call -! (like @P, @C and @S -! status: can be used for various things -! status bit SVFVAL=0 means value evaluated only when called with mode=1 -! eqnoval: used to specify the equilibrium the value should be taken from -! (for handling what is called "variables" in TC) -! name: name of symbol - integer narg,nactarg,status,eqnoval - type(putfun_node), pointer :: linkpnode - character name*16 -! this array has identification of state variable (and other function) symbols - integer, dimension(:,:), pointer :: formal_arguments - end TYPE gtp_putfun_lista -! this is the global array with state variable functions - TYPE(gtp_putfun_lista), dimension(:), allocatable :: svflista -! NOTE the value of a function is stored locally in each equilibrium record -! in array svfunres. -! The number of entered state variable functions. Used when a new one stored - integer, private :: nsvfun -!\end{verbatim} -!----------------------------------------------------------------- -!\begin{verbatim} -! this constant must be incremented when a change is made in gtp_fraction_set - INTEGER, parameter :: gtp_fraction_set_version=1 - TYPE gtp_fraction_set -! info about disordred fractions for some phases like ordered fcc, sigma etc -! latd: the number of sublattices added to first disordred sublattice -! ndd: sublattices for this fraction set, -! tnoofxfr: number of disordered fractions -! tnoofyfr: same for ordered fractions (=same as in phlista). -! varreslink: index of disordered phase_varres, -! phdapointer: pointer to the same phase_varres record as varreslink -! (Note that there is a bit set indicating that the sublattices should -! be taken from this record) -! totdis: 0 indicates no total disorder (sigma), 1=fcc, bcc or hcp -! id: parameter suffix, D for disordered -! dsites: number of sites in sublattices, disordred fractions stored in -! another phase_varres record linked from phdapointer -! splink: pointers to species record for the constituents -! nooffr: the number of fractions in each sublattice -! y2x: the conversion from sublattice constituents to disordered and -! dxidyj: are the the coeff to multiply the y fractions to get the disordered -! xfra(y2x(i))=xfra(y2x(i))+dxidyj(i)*yfra(i) -! disordered fractions stored in the phase_varres record with index varreslink -! (also pointed to by phdapointer). Maybe phdapointer is redundant?? -! arrays originally declared as pointers now changed to allocatable - integer latd,ndd,tnoofxfr,tnoofyfr,varreslink,totdis - character*1 id - double precision, dimension(:), allocatable :: dsites - integer, dimension(:), allocatable :: nooffr - integer, dimension(:), allocatable :: splink - integer, dimension(:), allocatable :: y2x - double precision, dimension(:), allocatable :: dxidyj -! factor needed when reading from TDB file for sigma etc. - double precision fsites -! in parallel processing the disordered phase_varres record is linked -! by this pointer, used in parcalcg and calcg_internal - TYPE(gtp_phase_varres), pointer :: phdapointer - END TYPE gtp_fraction_set -! these records are declared in the phase_varres record as DISFRA for -! each composition set and linked from the phase_varres record -!\end{verbatim} -!----------------------------------------------------------------- -!\begin{verbatim} -! this constant must be incremented when a change is made in gtp_phase_varres - INTEGER, parameter :: gtp_phase_varres_version=1 - TYPE gtp_phase_varres -! Data here must be different in equilibria representing different experiments -! or calculated in parallel or results saved from step or map. -! nextfree: In unused phase_varres record it is the index to next free record -! The global integer csfree is the index of the first free record -! phlink: is index of phase record for this phase_varres record -! status2: has phase status bits like ENT/FIX/SUS/DORM -! phstate: indicate state: fix/stable/entered/unknown/dormant/suspended/hidden -! 2 1 0 -1 -2 -3 -4 -! phtupx: phase tuple index -! constat: array with status word for each constituent, any can be suspended -! yfr: the site fraction array -! mmyfr: min/max fractions, negative is a minumum -! abnorm(1): amount moles of atoms for a formula unit of the composition set -! abnorm(2): mass/formula unit (both set by call to set_constitution) -! sites: site ratios (which can vary for ionic liquids) -! prefix and suffix are added to the name for composition sets 2 and higher -! disfra: a structure describing the disordered fraction set (if any) - integer nextfree,phlink,status2,phstate,phtupx - double precision, dimension(2) :: abnorm - character*4 prefix,suffix -! changed to allocatable - integer, dimension(:), allocatable :: constat - double precision, dimension(:), allocatable :: yfr - real, dimension(:), allocatable :: mmyfr - double precision, dimension(:), allocatable :: sites -! for ionic liquid derivatives of sites wrt fractions (it is the charge), -! 2nd derivates only when one constituent is vacancy -! 1st sublattice P=\sum_j (-v_j)*y_j + Qy_Va -! 2nd sublattice Q=\sum_i v_i*y_i - double precision, dimension(:), allocatable :: dpqdy - double precision, dimension(:), allocatable :: d2pqdvay -! for extra fraction sets, better to go via phase record index above -! this TYPE(gtp_fraction_set) variable is a bit messy. Declaring it in this -! way means the record is stored inside this record. - type(gtp_fraction_set) :: disfra -! It seems difficult to get the phdapointer in disfra record to work -! --- -! arrays for storing calculated results for each phase (composition set) -! amfu: is amount formula units of the composition set (calculated result) -! netcharge: is net charge of phase -! dgm: driving force (calculated result) -! amcom: not used -! damount: set to last change of phase amount in equilibrium calculations -! qqsave: values of qq calculated in set_constitution -! double precision amount(2),dgm,amcom,damount,qqsave(3) -! double precision amfu,netcharge,dgm,amcom,damount,qqsave(3) - double precision amfu,netcharge,dgm,amcom,damount -! Other properties may be that: gval(*,2) is TC, (*,3) is BMAG, see listprop -! nprop: the number of different properties (set in allocate) -! ncc: total number of site fractions (redundant but used in some subroutines) -! BEWHARE: ncc seems to be wrong using TQ test program fenitq.F90 ??? -! listprop(1): is number of calculated properties -! listprop(2:listprop(1)): identifies the property stored in gval(1,ipy) etc -! 2=TC, 3=BMAG. Properties defined in the gtp_propid record - integer nprop,ncc - integer, dimension(:), allocatable :: listprop -! gval etc are for all composition dependent properties, gval(*,1) for G -! gval(*,1): is G, G.T, G.P, G.T.T, G.T.P and G.P.P -! dgval(1,j,1): is first derivatives of G wrt fractions j -! dgval(2,j,1): is second derivatives of G wrt fractions j and T -! dgval(3,j,1): is second derivatives of G wrt fractions j and P -! d2gval(ixsym(i,j),1): is second derivatives of G wrt fractions i and j - double precision, dimension(:,:), allocatable :: gval - double precision, dimension(:,:,:), allocatable :: dgval - double precision, dimension(:,:), allocatable :: d2gval -! added for strain/stress, current values of lattice parameters - double precision, dimension(3,3) :: curlat -! saved values from last equilibrium calculation -! double precision, dimension(:), allocatable :: dsf - double precision, dimension(:,:), allocatable :: cinvy - double precision, dimension(:), allocatable :: cxmol - double precision, dimension(:,:), allocatable :: cdxmol - END TYPE gtp_phase_varres -! this record is created inside the gtp_equilibrium record -!\end{verbatim} -!----------------------------------------------------------------- -!\begin{verbatim} -! this must be incremented when a change is made in gtp_equilibrium_data - INTEGER, parameter :: gtp_equilibrium_data_version=2 - TYPE gtp_equilibrium_data -! this contains all data specific to an equilibrium like conditions, -! status, constitution and calculated values of all phases etc -! Several equilibria may be calculated simultaneously in parallell threads -! so each equilibrium must be independent -! NOTE: the error code must be local to each equilibria!!!! -! During step and map thses records with results are saved -! values of T and P, conditions etc. -! Values here are normally set by external conditions or calculated from model -! local list of components, phase_varres with amounts and constitution -! lists of element, species, phases and thermodynamic parameters are global -! tpval(1) is T, tpval(2) is P, rgas is R, rtn is R*T -! status: not used yet? -! multiuse: used for various things like direction in start equilibria -! eqno: sequential number assigned when created -! next: index of next equilibrium in a sequence during step/map calculation. -! eqname: name of equilibrium -! tpval: value of T and P -! rtn: value of R*T - integer status,multiuse,eqno,next - character eqname*24 - double precision tpval(2),rtn -! svfunres: the values of state variable functions valid for this equilibrium - double precision, dimension(:), allocatable :: svfunres -! the experiments are used in assessments and stored like conditions -! lastcondition: link to condition list -! lastexperiment: link to experiment list - TYPE(gtp_condition), pointer :: lastcondition,lastexperiment -! components and conversion matrix from components to elements -! complist: array with components -! compstoi: stoichiometric matrix of compoents relative to elements -! invcompstoi: inverted stoichiometric matrix - TYPE(gtp_components), dimension(:), allocatable :: complist - double precision, dimension(:,:), allocatable :: compstoi - double precision, dimension(:,:), allocatable :: invcompstoi -! one record for each phase+composition set that can be calculated -! phase_varres: here all calculated data for the phase is stored - TYPE(gtp_phase_varres), dimension(:), allocatable :: phase_varres -! index to the tpfun_parres array is the same as in the global array tpres -! eq_tpres: here local calculated values of TP functions are stored - TYPE(tpfun_parres), dimension(:), pointer :: eq_tpres -! current values of chemical potentials stored in component record but -! duplicated here for easy acces by application software - double precision, dimension(:), allocatable :: cmuval -! xconc: convergence criteria for constituent fractions and other things - double precision xconv -! delta-G value for merging gridpoints in grid minimizer -! smaller value creates problem for test step3.BMM, MC and austenite merged - double precision :: gmindif=-5.0D-2 -! maxiter: maximum number of iterations allowed - integer maxiter -! this is to save a copy of the last calculated system matrix, needed -! to calculate dot derivatives, initiate to zero - integer :: sysmatdim=0,nfixmu=0,nfixph=0 - integer, allocatable :: fixmu(:) - integer, allocatable :: fixph(:,:) - double precision, allocatable :: savesysmat(:,:) - END TYPE gtp_equilibrium_data -! The primary copy of this structures is declared globally as FIRSTEQ here -! Others may be created when needed for storing experimental data or -! for parallel processing. A global array of these are - TYPE(gtp_equilibrium_data), dimension(:), allocatable, target :: eqlista - TYPE(gtp_equilibrium_data), pointer :: firsteq -! This array of equilibrium records are used for storing results during -! STEP and MAP calculations. - TYPE(gtp_equilibrium_data), dimension(:), allocatable :: eqlines -!\end{verbatim} -!----------------------------------------------------------------- -!\begin{verbatim} -! for each permutation in the binary interaction tree of an endmember one must -! keep track of the permutation and the permutation limit. -! It is not possible to push the value on pystack as one must remember -! them when changing the endmember permutation -! integer, parameter :: permstacklimit=150 -! this constant must be incremented when a change is made in gtp_parcalc - INTEGER, parameter :: gtp_parcalc_version=1 - TYPE gtp_parcalc -! This record contains temporary data that must be separate in different -! parallell processes when calculating G and derivatives for any phase. -! There is nothing here that need to be saved after the calculation is finished -! global variables used when calculating G and derivaties -! sublattice with interaction, interacting constituent, endmember constituents -! PRIVATE inside this structure not liked by some compilers.... -! endcon must have maxsubl dimension as it is used for all phases - integer :: intlat(maxinter),intcon(maxinter),endcon(maxsubl) -! interaction level and number of fraction variables - integer :: intlevel,nofc -! explained above, to be used for FCC and BCC permutations ?? -! integer, dimension(permstacklimit) :: lastperm,permlimit -! interacting constituents (max 4) for composition dependent interaction -! iq(j) indicate interacting constituents -! for binary RK+Muggianu iq(3)=iq(4)=iq(5)=0 -! for ternary Muggianu in same sublattice iq(4)=iq(5)=0 -! for reciprocal composition dependent iq(5)=0 -! for Toop, Kohler and simular iq(5) non-zero (not implemented) - integer :: iq(5) -! fraction variables in endmember (why +2?) and interaction - double precision :: yfrem(maxsubl+2),yfrint(maxinter) -! local copy of T, P and RT for this equilibrium - double precision :: tpv(2),rgast -! double precision :: ymin=1.0D-30 - end TYPE gtp_parcalc -! this record is declared locally in subroutine calcg_nocheck -!\end{verbatim} -!------------------------------------------------------------------- -!\begin{verbatim} -! this constant must be incremented when a change is made in gtp_pystack - INTEGER, parameter :: gtp_pystack_version=1 - TYPE gtp_pystack -! records created inside the subroutine push/pop_pystack -! data stored during calculations when entering an interaction record -! previous: link to previous record in stack -! ipermutsave: permutation must be saved -! intrecsave: link to interaction record -! pysave: saved value of product of all constituent fractions -! dpysave: saved value of product of all derivatives of constituent fractions -! d2pysave: saved value of product of all 2nd derivatives of constit fractions - TYPE(gtp_pystack), pointer :: previous - integer :: pmqsave - TYPE(gtp_interaction), pointer :: intrecsave - double precision :: pysave - double precision, dimension(:), allocatable :: dpysave - double precision, dimension(:), allocatable :: d2pysave - end TYPE gtp_pystack -! declared inside the calcg_internal subroutine -!\end{verbatim} -!----------------------------------------------------------------- -! -!=================================================================== -! -! below here are data structures for various applications -! They indicate data that may need to be saved together with -! the thermodynamic data. Exactly how this will be handelled -! will have to be solved later -! -!=================================================================== -! -!----------------------------------------------------------------- -!\begin{verbatim} - INTEGER, parameter :: gtp_eqnode_version=1 - TYPE gtp_eqnode -! This record is to arrange calculated equilibria, for example results -! from a STEP or MAP calculation, in an ordered way. The equilibrium records -! linked from an eqnode record should normally represent one or more lines -! in a diagram but may be used for other purposes. -! ident is to be able to find a specific node -! nodedtype is to specify invariant, middle, end etc. -! status can be used to supress a line -! color can be used to sepecify color or linetypes (dotted, thick ... etc) -! exits are the number of lines that should exit from the node -! done are the number of calculated lines currently exiting from the node - integer ident,nodetype,status,color,exits,done -! this node can be in a multilayerd list of eqnodes - type(gtp_eqnode), pointer :: top,up,down,next,prev -! nodeq is a pointer to the equilibrium record at the node - type(gtp_equilibrium_data), pointer :: nodeq -! eqlista are pointers to line of equilibria starting or ending at the node -! The equilibrium records are linked with a pointer inside themselves - type(gtp_equilibrium_data), dimension(:), pointer :: eqlista -! axis is the independent axis variable for the line, negative means decrement -! noeqs gives the number of equilibria in each eqlista, a negative value -! indicates that the node is an endpoint (each line normally has a -! start point and an end point) - integer, dimension(:), allocatable :: axis,noeqs -! This is a possibility to specify a status for each equilibria in each line -! integer, dimension(:,:), allocatable :: eqstatus - end TYPE gtp_eqnode -! can be allocated in a gtp_applicationhead record -!\end{verbatim} -!------------------------------------------------------------------ -!\begin{verbatim} - INTEGER, parameter :: gtp_applicationhead_version=1 - TYPE gtp_applicationhead -! This record should summarize the essential information about an application -! using GTP. How it should link to other information is not clear. -! The character variables should be used to indicate that. - integer apptyp,status - character*64 general,special -! These can be used to define axis and other things - integer, dimension(:), allocatable :: ivals - double precision, dimension(:), allocatable :: rvals - character*64, dimension(:), allocatable :: cvals - type(gtp_applicationhead), pointer :: nextapp,prevapp -! The headnode can be the start of a structure of eqnodes with lines - type(gtp_eqnode) :: headnode -! this is the start of a list of nodes with calculated lines or -! single equilibria that belong to the application. - type(gtp_eqnode), dimension(:), allocatable :: nodlista - end TYPE gtp_applicationhead -! this record is allocated when necessary - type(gtp_applicationhead), pointer :: firstapp,lastapp -!\end{verbatim} -!----------------------------------------------------------------- -! -! a global array to provide information about composition sets -! phcs(nph) is the composition set counter for phase nph -! integer, dimension(maxph) :: phcs ----- removed as redundant ?? -! -!=================================================================== -! -! Below are private global variables like free lists etc. -! -!=================================================================== - -! Several arrays with lists have a free list: csfree,addrecs,eqfree,reffree -! -!\begin{verbatim} -! counters for elements, species and phases initiated to zero - integer, private :: noofel=0,noofsp=0,noofph=0 -! counter for phase tuples (combination of phase+compset) - integer :: nooftuples=0 -! counters for property and interaction records, just for fun - integer, private :: noofprop,noofint,noofem -! free lists in phase_varres records and addition records - integer, private :: csfree,addrecs -! free list of references and equilibria - integer, private :: reffree,eqfree -! maximum number of properties calculated for a phase - integer, private :: maxcalcprop=20 -! highest used phase_varres record (for saving on file) - integer, private :: highcs -! Trace for debugging (not used) - logical, private :: ttrace -! minimum constituent fraction - double precision :: bmpymin -! number of defined property types like TC, BMAG etc - integer, private :: ndefprop -!\end{verbatim} - -CONTAINS - -! 1-5: initialization, number of things, find things, get things, set things, -include "pmod25A.F90" - -! 6: calculate things -include "pmod25B.F90" - -! 7: state variable manipulations -include "pmod25C.F90" - -! 8-9: state variable functions, interactive things -include "pmod25D.F90" - -! 10: list things -include "pmod25E.F90" - -! 11: save and read -include "pmod25F.F90" - -! 12: enter data -include "pmod25G.F90" - -! 13-15: status for things, unfinished things, internal stuff -include "pmod25H.F90" - -! 16: Additions (magnetic and others) -include "pmod25I.F90" - -! 17-18: Grid minimizer and miscellaneous -include "pmod25J.F90" - - -END MODULE GENERAL_THERMODYNAMIC_PACKAGE - +!*************************************************************** +! General Thermodynamic Package (GTP) +! for thermodynamic modelling and calculations +! +MODULE GENERAL_THERMODYNAMIC_PACKAGE +! +! Copyright 2011-2015, Bo Sundman, France +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +! +! contact person: bo.sundman@gmail.com +! +!----------------------------------------------------------------------- +! +! for known unfinished/unchecked bugs and parallelization problems +! look for BEWARE +! +!----------------------------------------------------------------------- +! +! Description of data structure +! +! For all elements, species and phases there are two arrays defined. +! The first (data) array contains the elements species etc and all their data +! in the order they were entered and the data are never moved. +! The second (index) array contain the elements, species etc in alphabetical +! (or whatever) order and is updated whenever a new element, species etc +! is added. This array is an integer array with the index of the data array. +! Most links inside the different records to elements, species etc +! are indices to the data array which is never changed. +! TPFUNS used in parameters are also stored in an array and the index +! to this array is stored in the property record to specify the function. +! +! For parameters inside each phase record there is one (or 2 if disordered set) +! lists with endmember parameters. Each endmember record can be the root +! of a binary tree with interaction parameters. Each of these records +! can have a property list with various data like G, TC, MQ etc. These +! records are created dynamically and can only be found by following the links. +! +! Each phase has one or more composition sets. These are part of the +! equilibrium data structure which also contains conditions, +! calculated values of TP functions and other symbols. To identify a +! phase+comp.set a phasetuple has been intoduced. This contains two +! integers, th first is the phase number, the second the composition +! set number. The second or higher composition set of a phase will +! have a tupel index higher that the number of phases. +! +! One equilibrium record is created in init_gtp and it is called +! FIRSTEQ which is a global variable. There is also an array EQLISTA +! which should contain all allocated equilibrium records, FIRSTEQ is a +! pointer to the first element in this array. More equilibrium +! records can be initiated by the enter_equilibrium subroutine. This +! copies the relevant data from FIRSTEQ. After a second equilibrium +! is created it is forbidden to enter elements, species and phases and +! create additional fraction sets, i.e. one must not change the data +! structure except to add/remove composition sets (but this should +! anyway be avoided). Composition sets must be created in all +! equilibrium records at the same time (if done in a thread then all +! threads must stop while this is done). During step/map calculation +! each calculated equilibria is saved for later use in plotting och +! other postprocessing. These saved equilibria may have different +! number of composition sets so great care must be taken using them. +! +! The equilibrium data record is "stand alone" and contains all necessary +! data to describe the equilibrium (except the model parameters and other +! static data). In parallel processing each thread will have its own +! equilibrium data record. +! +! The intention is that several equilibra can be created both to store +! individual experimental data in assessments and for each thread in +! parallel. In the equilibrium record there are conditions, +! components (with chemical potentials) and an error code and most +! important, the phase_varres record array with one or more record for +! each phase. This array must be identical in all equilibria recods. +! Each composition set has a phase_varres record and they are linked +! from the phase record by the LIKTOCS array. As the phase_varres +! records are in an array the link is simply an integer index of this +! array. There is a free list (in FIRSTEQ) in the phase_varres array +! to be used when adding or removing a composition set. The EQ_TPRES +! array is declared inside the equilibrium record for calculated +! results of the TPFUNS as these can be different in each equilibria. +! The index to a function in EQ_TPRES is the same as the index to the +! TPFUN array declared globally in TPFUN. The TPFUN array has the +! actual expression, and EQ_TPRES has the last calculated results, +! which can be different in each equilibrium. The TPFUN index is used +! in property records to specify the function of a parameter. +! +! In many subroutines the equilibrium record called CEQ (Current EQilibrium) +! is an argument which means it operates on the data in that +! equilibrium record only. +! +! In the record array PHASE_VARRES (including disordered) each phase +! and composition set has a record. If no parallel calculation and no +! experiments the equilibrium record FIRSTEQ is enough. +! +! In programming for parallel processing THREADPRIVATE +! should be avoided as it usually has a very slow implementation. +! +! Some routines exist both with and without the CEQ argument. A programmer +! can create his own array of equilibrium data records and use any of +! them in such calls. ???? Maybe not, then how to update when a new +! composition set is needed??? +! +! Thread specific data are needed for conditions, phase status, constitution, +! function values and calc results like G and derivatives for each phase, +! amounts of phases etc. When calling a subroutine to get mole frations etc +! the equilibrium record CEQ must be supplied. +! +! The global error code is defined in tpfunlib, that is not very good. There +! must be an error code specific to each equilibrium. Or can one declare +! the error code as "local" to the thread? +! +!-------------------------------------------------------------------------- +! +! EXTERNAL MODULES +! routines for inverting matrix etc + use lukasnum +! TP functions, tpfunlib makes USE of metlib + use tpfunlib +! for parallel processing +! use OMP_LIB +! +!-------------------------------------------------------------------------- +! +! Versions +! date item +! 2013.03.01 Release version 1 +! 2015.01.07 Release version 2 +! +!================================================================= +! + IMPLICIT NONE +! +!----------------------------------------------------------------- +! error messages +! numbers 4000 to 4220 defined. gx%bmperr is set to message index +! A lot of error flags set have no messages .... + integer, parameter :: nooferm=4220 + character (len=64), dimension(4000:nooferm) :: bmperrmess + data bmperrmess(4000:4199)& + /'Too many coefficients in a TP function. ',& + 'Illegal character in a TP function, digit expected. ',& + 'Unknown symbol in TP function ',& + 'Expected ( after unary function ',& + 'Too many ) in a TP function ',& + 'Illegal character in a TP function ',& + 'Too few ) in a TP function ',& + 'Too many ( in exponent ',& + 'Illegally placed ( in the exponent of a TP function ',& + 'No digits after ( in the exponent of a TP function ',& +! 4010: + 'Illegally placed ) in exponent in TP function ',& + 'Too high power in a TP function, max 99, min -99 ',& + 'Missing ) in the exponent of a TP function ',& + 'Illegal termination of a TP function reading a TDB file ',& + 'No more free TP root records ',& + 'No more free TP expression records ',& + 'Illegal expression inside unary argument of a TP function ',& + 'Illegal code found when evaluating a TP function ',& + 'Found a coefficent zero in a term of a TP function ',& + 'Illegal code in a TP function ',& +! 4020: + 'Negative argument to logarithm in a TP function ',& + 'Unknown unary function in evaluation for a TP function ',& + 'Too many symbols in a TP function term ',& + 'Two unary functions in a TP function term ',& + 'Too complicated TP function term ',& + 'Too many temperature ranges in a TP function ',& + 'TP function with same name already entered ',& + 'Symbol referenced in a parameter does not exist ',& + 'Missing separator between phase and constituent array in paramet',& + 'Cannot enter disordered fraction set when several composition se',& +! 4030 + 'Cannot enter disordered fraction set when suspended constituents',& + 'Wildcards in interaction parameters not yet implemented ',& + 'Interaction between 2 wildcards are illegal ',& + 'Illegal character in element symbol ',& + 'Element with this symbol already entered ',& + 'Element symbol and name must start with letter A-Z ',& + 'Reference state must start with letter A-Z ',& + 'Element mass must not be negative ',& + 'Enthalpy difference H298-H0 must be positive ',& + 'Entropy at 298.15 must be positive ',& +! 4040 + 'Too many elements ',& + 'Too many species ',& + 'No such element ',& + 'Text position outside text ',& + 'Species symbol must start with letter A-Z ',& + 'No elements or too many elements in species formula ',& + 'Unknown element in species formula ',& + 'Negative stoichiometric factor in species ',& + 'The charge must be the final "element" ',& + 'Species already entered ',& +! 4050 + 'No such phase ',& + 'Unknown or ambiguous species name ',& + 'No such component ',& + 'Phase name must start with letter A-Z ',& + 'Phase already entered ',& + 'Model not implemented yet ',& + 'Too few or too many sublattices ',& + 'Sites on a sublattice must be positive ',& + 'Too few or too many constituents in a sublattice ',& + 'Too many constituents ',& +! 4060 + 'No such TP function ',& + 'Expected constituent array, found nothing ',& + 'Illegal character in constituent array ',& + 'Illegal degree of parameter, must be 0-9 ',& + 'No free interaction records ',& + 'Wrong number of sublattices ',& + 'No such constituent in a sublattice ',& + 'No such interacting constituent ',& + 'This phase has no disordered fraction set ',& + 'Wrong number of sublattices in disordered fraction set ',& +! 4070 + 'No free endmember records ',& + 'No free property records ',& + 'No such composition set ',& + 'Inconsistent composition set specifications ',& + 'Overflow in push ',& + 'Undeflow in pop ',& + 'Sublattice out of range for entering disordered fraction set ',& + 'Disordered fraction set already entered ',& + 'Not implemented yet ',& + 'Ionic liquid Not implemented yet ',& +! 4080 + 'Suspended constituents not implemented yet ',& + 'Stability factor not implemented yet ',& + 'No such composition dependent property parameter ',& + 'Empty line, expected species stoichiometry ',& + 'No element in species stoichiometry ',& + 'Species cannot be entered as it is implicitly suspended ',& + 'Excess model not implemented yet ',& + 'Bad name for a symbol ',& + 'Too deeply nested TP functions ',& + 'Reading unknown addition type from file ',& +! 4090 + 'Addition already entered ',& + 'No more addition records ',& + 'Maximum 9 composition sets ',& + 'Illegal composition set number ',& + 'No more records for phases or composition sets. ',& + 'Hidden phase cannot be ENTERED, SUSPENDED, DORMANT or FIXED ',& + 'No such constituents or ambiguous name ',& + 'Too many argument to a state variable ',& + 'This state variable must have two arguments ',& + 'First character of a state variable is wrong ',& +! 4100 + 'State variable starting with M not followed by U ',& + 'State variable starting with L not followed by NAC ',& + 'Missing ( for arguments for state variable ',& + 'Missing ) after arguments of state variable ',& + 'Unknown phase used as state varible argument ',& + 'Unknown constituent used as state variable argument ',& + 'Unknown component used as state variable argument ',& + 'State variable starting with D not followed by G ',& + 'State variable starting with T follwed by other character than C',& + 'State variable starting with B missing P, MAG, M, V, W or F ',& +! 4110 + 'This state variable cannot not have two arguments ',& + 'This state variable must have an argument ',& + 'Impossible reference state for this constituent ',& + 'No such property for this phase ',& + 'Cannot calculate property value per volume as no volume data ',& + 'Property per formula unit only for a single phase ',& + 'State variable number must be larger than zero ',& + 'Only state variable Y can have 3 indices ',& + 'Illegal normalization of state variable ',& + 'Phase is hidden ',& +! 4120 + 'Wrong syntax for mobility variable ',& + 'Ambiguous phase name ',& + 'Illegal name for an equilibrium ',& + 'Equilibrium with this name already entered ',& + 'No such equilibrium ',& + 'Not allowed to enter more model data ',& + 'No state variable supplied ',& + 'Illegal state variable for conditions ',& + 'Only one kind of state variable in expressions ',& + 'Illegal value for a state variable ',& +! 4130 line below + 'Factor in front of a condition must be followed by * ',& + 'No such condition ',& + 'Function name must start with a letter A-Z ',& + 'Function name and expression must be separated by "=" ',& + 'Error in function expression (putfun) ',& + 'Unknown symbol used in function ',& + 'Symbol with this name already entered ',& + 'Symbol name must start with letter A-Z ',& + 'Illegal character in symbol name ',& + 'Cannot check name of unknown kind of symbol ',& +! 4140 + 'No such symbol ',& + 'Error evaluating symbol value ',& + 'Error listing symbol expression ',& + 'No conditions at all ',& + 'Degrees of freedom not zero ',& + 'Unknown type of addition ',& + 'Quitting due to repeated input error ',& + 'Gridminimizer found gridpoint outside range ',& + 'Gridminimizer error when generating endmember values ',& + 'Gridminimizer found an element without gridpoint ',& +! 4150 next line + 'Gridminimizer have no gridpoint for a pure element ',& + 'Conditions not only T, P and massbalance ',& + 'Illegal to set all phases as fix ',& + 'Cannot enter a new equilibrium if there are no phases ',& + 'Trying to enter an illegal reference ',& + 'A reference must have an identifier ',& + 'Reference identifier already exists ',& + 'Error in TDB file, species terminator error ',& + 'Unknown potential ',& + 'Cannot calculate potentials for charged constituents ',& +! 4160 next line + 'Illegal endmember for reference state ',& + 'End member without atoms ',& + 'Same species twice in component list ',& + 'Component stoichiometry matrix singular ',& + 'Too many interaction levels ',& + 'Error reading save file ',& + 'Error reading save file at EOF ',& + 'Composition set prefix must start with a letter ',& + 'This property has no specifier ',& + 'Parameter specifier missing ',& +! 4170 + 'Properties needed for Inden magnetic model not defined ',& + 'Request for non-existing chemical potential ',& + 'Removing current data not implemented ',& + 'Grid minimization not allowed ',& + 'Illegal composition in call to grid minimization ',& + 'Too many gridpoints ',& + 'No phases and no gridpoints in call to grid minimization ',& + 'Grid minimizer want to create composition set but is not allowed',& + 'Non-existing fix phase ',& + 'State variable N or B cannot have two indices for grid minimizer',& +! 4180 + 'Condition on B is not allowed for grid minimizer ',& + 'Element has no composition in grid minimizer ',& + 'Too complicated mass balance conditions ',& + 'Two mass balance conditions for same element ',& + 'Cannot handle conditions on both N and B ',& + 'No mole fractions when summing composition ',& + 'Error in TDB file, missing function ',& + 'Temperature (K) or pressure (Pa) must be larger than 0.1 ',& + ' ',& + ' ',& +! 4190 + ' ',& + ' ',& + ' ',& + ' ',& + ' ',& + ' ',& + ' ',& + ' ',& + ' ',& + ' '/ +! 4200 errors in minimizer + data bmperrmess(4200:4220)& + /'No phase that can be set stable ',& + 'Attempt to set too many phases as stable ',& + 'Total amount is negative ',& + 'Error solving system matrix ',& + 'Too many iterations ',& + 'Phase matrix singular ',& + 'Cannot handle models without analytical second derivativatives ',& + 'This type of condition not yet implemented ',& + 'This type of condition is not allowed ',& + 'Error setting up system matrix, too many equations ',& +! 4210 + 'Phase change not allowed due to step/map constraints ',& + ' ',& + ' ',& + ' ',& + ' ',& + ' ',& + ' ',& + 'Use "calculate symbol" for state variable symbols ',& + ' ',& + ' ',& +! 4220 + ' '/ +! last used error codes above +! +!================================================================= +! +!\begin{verbatim} +!-Bits in global status word (GS) in globaldata record +! level of user: beginner, occational, advanced; NOGLOB: no global gridmin calc +! NOMERGE: no merge of gridmin result, NODATA: not any data, +! NOPHASE: no phase in system, NOACS: no automatic creation of composition set +! NOREMCS: do not remove any redundant unstable composition sets +! NOSAVE: data changed after last save command +! VERBOSE: maximum of listing +! SETVERB: explicit setting of verbose +! SILENT: as little output as possible +! NOAFTEREQ: no manipulations of results after equilirum calculation +! >>>> some of these should be moved to the gtp_equilibrium_data record + integer, parameter :: & + GSBEG=0, GSOCC=1, GSADV=2, GSNOGLOB=3, & + GSNOMERGE=4, GSNODATA=5, GSNOPHASE=6, GSNOACS=7, & + GSNOREMCS=8, GSNOSAVE=9, GSVERBOSE=10, GSSETVERB=11,& + GSSILENT=12, GSNOAFTEREQ=13 +!---------------------------------------------------------------- +!-Bits in element record + integer, parameter :: & + ELSUS=0 +!---------------------------------------------------------------- +!-Bits in species record +! Suspended, implicitly suspended, species is element, species is vacancy +! species have charge, species is (system) component + integer, parameter :: & + SPSUS=0, SPIMSUS=1, SPEL=2, SPVA=3, & + SPION=4, SPSYS=5 +!\end{verbatim} +!---------------------------------------------------------------- +!\begin{verbatim} +!-Bits in phase record +! hidden, implictly hidden, ideal, no concentration variation (NOCV), +! Phase has parameters entered (PHHASP), +! F option (FORD), B option (BORD), Sigma ordering (SORD), +! multiple/disordered fraction sets (MFS), gas, liquid, ionic liquid, +! aqueous, dilute config. entropy (DILCE), quasichemical (QCE), CVM, +! FACT, not create comp. sets (NOCS), Helmholz energy model (HELM), +! Model without 2nd derivatives (PHNODGDY2), Elastic model A, +! explicit charge balance needed (XCB), + integer, parameter :: & + PHHID=0, PHIMHID=1, PHID=2, PHNOCV=3, & ! 1 2 4 8 + PHHASP=4, PHFORD=5, PHBORD=6, PHSORD=7, & + PHMFS=8, PHGAS=9, PHLIQ=10, PHIONLIQ=11, & + PHAQ1=12, PHDILCE=13, PHQCE=14, PHCVMCE=15,& + PHFACTCE=16, PHNOCS=17, PHHELM=18, PHNODGDY2=19,& + PHELMA=20, PHEXCB=21 +! +!---------------------------------------------------------------- +!-Bits in constituent fraction (phase_varres) record STATUS2 +! CSDFS is set if record is for disordred fraction set, then one must use +! sublattices from fraction_set record +! CSDLNK: a disordred fraction set in this phase_varres record +! CSDUM2 and CSDUM3 not used +! CSCONSUS set if one or more constituents suspended (status array constat +! specify constituent status) +! CSORDER: set if fractions are ordered (only used for BCC/FCC ordering +! with a disordered fraction set). +! CSSTABLE: set if phase is stable after an equilibrium calculation +! CSAUTO set if composition set created during calculations +! CSDEFCON set if there is a default constitution + integer, parameter :: & + CSDFS=0, CSDLNK=1, CSDUM2=2, CSDUM3=3, & + CSCONSUS=4, CSORDER=5, CSSTABLE=6, CSAUTO=7, & + CSDEFCON=8 +!\end{verbatim} +!---------------------------------------------------------------- +!\begin{verbatim} +!-Bits in constat array for each constituent +! For each constituent: is suspended, is implicitly suspended, is vacancy + integer, parameter :: & + CONSUS=0,CONIMSUS=1,CONVA=2 +!---------------------------------------------------------------- +!-Bits in state variable functions (svflista) +! SVFVAL symbol evaluated only explicitly (mode=1 in call) + integer, parameter :: & + SVFVAL=0,SVFEXT=1 +!---------------------------------------------------------------- +!-Bits in gtp_equilibrium_data record +! EQNOTHREAD set if equilibrium must be calculated before threading +! (in assessment) for example if a symbol must be evaluated in this +! equilibrium before used in another like H(T)-H298 +! EQNOGLOB set if no global minimization +! EQNOEQCAL set if no successful equilibrium calculation made +! EQINCON set if current conditions inconsistent with last calculation +! EQFAIL set if last calculation failed +! EQNOACS set if no automatic composition sets ?? not used !! see GSNOACS +! EQGRIDTEST set if grid minimizer should be used after equilibrium + integer, parameter :: & + EQNOTHREAD=0, EQNOGLOB=1, EQNOEQCAL=2, EQINCON=3, & + EQFAIL=4, EQNOACS=5, EQGRIDTEST=6 +!---------------------------------------------------------------- +!-Bits in parameter property type record (gtp_propid) +! constant (no T or P dependence), only P, property has an element suffix +! (like mobility), property has a constituent suffix + integer, parameter :: & + IDNOTP=0, IDONLYP=1, IDELSUFFIX=2, IDCONSUFFIX=3 +!---------------------------------------------------------------- +!- Bits in condition status word (some set in onther ways??) +! singlevar means T=, x(el)= etc, singlevalue means value is a number +! phase means the condition is a fix phase + integer, parameter :: & + ACTIVE=0,SINGLEVAR=1,SINGLEVALUE=2,PHASE=3 +! +! >>> Bits for symbols and TP functions missing ??? +!\end{verbatim} +! +!---------------------------------------------------------------------- +! +! Defining the phase status is very important, maybe a status for MAPFIX +! should be added. +!\begin{verbatim} +! some constants, phase status + integer, parameter :: PHHIDDEN=-4 + integer, parameter :: PHSUS=-3 + integer, parameter :: PHDORM=-2 + integer, parameter :: PHENTUNST=-1 + integer, parameter :: PHENTERED=0 + integer, parameter :: PHENTSTAB=1 + integer, parameter :: PHFIXED=2 + character (len=12), dimension(-4:2), parameter :: phstate=& + (/'HIDDEN ','SUSPENDED ','DORMANT ','ENTERED UNST',& + 'ENTERED ','ENTERED STBL','FIXED '/) +!\end{verbatim} +! +!---------------------------------------------------------------------- +! +!\begin{verbatim} +! Parameters defining the size of arrays etc. +! max elements, species, phases, sublattices, constituents (ideal phase) + integer, parameter :: maxel=100,maxsp=1000,maxph=800,maxsubl=10,maxconst=1000 +! maximum number of consitutents in non-ideal phase + integer, parameter :: maxcons2=100 +! maximum number of elsements in a species + integer, parameter :: maxspel=10 +! maximum number of references + integer, private, parameter :: maxrefs=1000 +! maximum number of equilibria + integer, private, parameter :: maxeq=500 +! some dp values, default precision of Y and default minimum value of Y +! zero and one set in tpfun + double precision, private, parameter :: YPRECD=1.0D-6,YMIND=1.0D-30 +! dimension for push/pop in calcg, max composition dependent interaction + integer, private, parameter :: maxpp=1000,maxinter=3 +! max number of TP symbols + integer, private, parameter :: maxtpf=20*maxph +! max number of properties (G, TC, BMAG MQ%(...) etc) + integer, private, parameter :: maxprop=50 +! max number of state variable functions + integer, private, parameter :: maxsvfun=500 +! version number +! changes in last 2 digits means no change in SAVE/READ format + character*8, parameter :: gtpversion='GTP-3.00' + character*8, parameter :: savefile='OCF-3.00' +!\end{verbatim} +!================================================================= +!\begin{verbatim} +! The number of additions to the Gibbs energy of a phase is increasing +! This is a way to try to organize them. Each addtion has a unique +! number identifying it when created, listed or calculated. These +! numbers are defined here + integer, public, parameter :: indenmagnetic=1 + integer, public, parameter :: debyecp=2 + integer, public, parameter :: weimagnetic=3 + integer, public, parameter :: einsteincp=4 + integer, public, parameter :: elasticmodela=5 + integer, public, parameter :: glastransmodela=6 +! Note that additions often use extra parameters like Curie or Debye +! temperatures defined by parameter identifiers stored in gtp_propid +!\end{verbatim} +! ================================================================= +! +! below here are data structures and global data in this module +! +!================================================================= +!\begin{verbatim} + TYPE gtp_global_data +! status should contain bits how advanced the user is and other defaults +! it also contain bits if new data can be entered (if more than one equilib) + integer status + character name*24 + double precision rgas,rgasuser,pnorm + END TYPE gtp_global_data + TYPE(gtp_global_data) :: globaldata +!\end{verbatim} +!================================================================= +! +! below here are thermodynamic model data structures +! +!================================================================= +! +!\begin{verbatim} +! this constant must be incremented whenever a change is made in gtp_element + INTEGER, parameter :: gtp_element_version=1 + TYPE gtp_element +! data for each element: symbol, name, reference state, mass, h298-h0, s298 + character :: symbol*2,name*12,ref_state*24 + double precision :: mass,h298_h0,s298 +! splink: index of corresponing species in array splink +! Status bits are stored in the integer status +! alphaindex: the alphabetical order of this elements +! refstatesymbol: indicates H0 (1), H298 (0, default) or G (2) for endmembers + integer :: splink,status,alphaindex,refstatesymbol + END TYPE gtp_element +! allocated in init_gtp + TYPE(gtp_element), private, allocatable :: ellista(:) + INTEGER, private, allocatable :: ELEMENTS(:) +!\end{verbatim} +!----------------------------------------------------------------- +!\begin{verbatim} +! this constant must be incremented whenever a change is made in gtp_species + INTEGER, parameter :: gtp_species_version=1 + TYPE gtp_species +! data for each species: symnol, mass, charge, status +! mass is in principle redundant as calculated from element mass + character :: symbol*24 + double precision :: mass,charge +! alphaindex: the alphabetical order of this species +! noofel: number of elements + integer :: noofel,status,alphaindex +! Use an integer array ellinks to indicate the elements in the species +! The corresponing stoichiometry is in the array stochiometry +! ???? these should not be pointers, changed to allocatable ???? + integer, dimension(:), allocatable :: ellinks + double precision, dimension(:), allocatable :: stoichiometry + END TYPE gtp_species +! allocated in init_gtp + TYPE(gtp_species), private, allocatable :: splista(:) + INTEGER, private, allocatable :: SPECIES(:) +!\end{verbatim} +!----------------------------------------------------------------- +!\begin{verbatim} +! this constant must be incremented whenever a change is made in gtp_component + INTEGER, parameter :: gtp_component_version=1 + TYPE gtp_components +! The components are simply an array of indices to species records +! the components must be "orthogonal". There is always a "systems components" +! that by default is the elements. +! Later one may implement that the user can define a different "system set" +! and also specific sets for each phase. +! The reference state is set as a phase and value of T and P. +! The name of the phase and its link and the link to the constituent is stored +! the endmember array is for the reference phase to calculate GREF +! The last calculated values of the chemical potentials (for user defined +! and default reference states) should be stored here. +! molat is the number of moles of components in the defined reference state + integer :: splink,phlink,status + character*16 :: refstate + integer, dimension(:), allocatable :: endmember + double precision, dimension(2) :: tpref + double precision, dimension(2) :: chempot + double precision mass,molat + END TYPE gtp_components +! allocated in gtp_equilibrium_data +!\end{verbatim} +!----------------------------------------------------------------- +!\begin{verbatim} +! this constant must be incremented whenever a change is made in gtp_endmember + INTEGER, parameter :: gtp_endmember_version=1 + TYPE gtp_endmember +! end member parameter record, note ordered phases can have +! several permutations of fraction pointers like for B2: (Al:Fe) and (Fe:Al). +! There are links (i.e. indices) to next end member and to the interactio tree +! and to a list of property record +! The phase link is needed for SAVE/READ as one cannot know the number of +! sublattices otherwise. One could just store nsl but a link back to the +! phase record might be useful in other cases. +! noofpermut: number of permutations (for ordered phases: (Al:Fe) and (Fe:Al) +! phaselink: index of phase record +! antalem: sequenial order of creation, useful to keep track of structure +! propointer: link to properties for this endmember +! nextem: link to next endmember +! intponter: root of interaction tree of parameters +! fraclinks: indices of fractions to be multiplied with the parameter + integer :: noofpermut,phaselink,antalem + TYPE(gtp_property), pointer :: propointer + TYPE(gtp_endmember), pointer :: nextem + TYPE(gtp_interaction), pointer :: intpointer +! there is at least one fraclinks per sublattice +! the second index of fraclinks is the permutation (normally only one) +! the first indec of fraclinks points to a fraction for each sublattice. +! The fractions are numbered sequentially independent of sublattices, a +! sigma phase with (FE:CR,MO:CR,FE,MO) has 6 fractions (incl one for FE in +! first sublattice) and the end member (FE:MO:CR) has the fraclinks 1,3,4 +! This means these values can be used as index to the array with fractions. +! The actual species can be found via the sublattice record +! integer, dimension(:,:), pointer :: fraclinks + integer, dimension(:,:), allocatable :: fraclinks + END TYPE gtp_endmember +! dynamically allocated when entering a parameter +!\end{verbatim} +!----------------------------------------------------------------- +!\begin{verbatim} +! this constant must be incremented when a change is made in gtp_interaction + INTEGER, parameter :: gtp_interaction_version=1 + TYPE gtp_interaction +! this record constitutes the parameter tree. There are links to NEXT +! interaction on the same level (i.e. replace current fraction) and +! to HIGHER interactions (i.e. includes current interaction) +! There can be several permutations of the interactions (both sublattice +! and fraction permuted, like interaction in B2 (Al:Al,Fe) and (Al,Fe:Al)) +! The number of permutations of interactions can be the same, more or fewer +! comparared to the lower order parameter (endmember or other interaction). +! The necessary information is stored in noofip. It is not easy to keep +! track of permutations during calculations, the smart way to store the last +! permutation calculated is in this record ... but that will not work for +! parallell calculations as this record is static ... +! status: may be useful eventually +! antalint: sequential number of interaction record, to follow the structure +! order: for permutations one must have a sequential number in each node +! propointer: link to properties for this parameter +! nextlink: link to interaction on same level (replace interaction) +! highlink: link to interaction on higher level (include this interaction) +! sublattice: (array of) sublattices with interaction fraction +! fraclink: (array of) index of fraction to be multiplied with this parameter +! noofip: (array of) number of permutations, see above. + integer status,antalint,order + TYPE(gtp_property), pointer :: propointer + TYPE(gtp_interaction), pointer :: nextlink,highlink + integer, dimension(:), allocatable :: sublattice,fraclink,noofip + END TYPE gtp_interaction +! allocated dynamically and linked from endmember records +!\end{verbatim} +!----------------------------------------------------------------- +!\begin{verbatim} +! this constant must be incremented when a change is made in gtp_property + INTEGER, parameter :: gtp_property_version=1 + TYPE gtp_property +! This is the property record. The end member and interaction records +! have pointer to this. Severall different properties can be linked +! from a parameter record like G, TC, BMAGN, VA, MQ etc. +! Some properties are connected to a constituent (or component?) like the +! mobility and also the Bohr mangneton number. +! Allocated as linked from endmembers and interaction records +! reference: can be used to indicate the source of the data +! refix: can be used to indicate the source of the data +! nextpr: link to next property record +! extra: TOOP and KOHLER can be implemented inside the property record +! proptype: type of propery, 1 is G, other see parameter property +! degree: if parameter has Redlich-Kister or similar degrees (powers) +! degreelink: indices of TP functions for different degrees (0-9) +! protect: can be used to prevent listing of the parameter +! antalprop: probably redundant (from the time of arrays of propery records) + character*16 reference + TYPE(gtp_property), pointer :: nextpr + integer proptype,degree,extra,protect,refix,antalprop + integer, dimension(:), allocatable :: degreelink + END TYPE gtp_property +! property records, linked from endmember and interaction records, allocated +! when needed. Each propery like G, TC, has a property record linking +! a TPFUN record (by index to tpfun_parres) +!\end{verbatim} +!----------------------------------------------------------------- +!\begin{verbatim} +! this constant must be incremented when a change is made in gtp_biblioref +! old name gtp_datareference + INTEGER, parameter :: gtp_biblioref_version=1 + TYPE gtp_biblioref +! store data references +! reference: can be used for search of reference +! refspec: free text + character*16 reference + character*64, dimension(:), allocatable :: refspec + END TYPE gtp_biblioref +! allocated in init_gtp + TYPE(gtp_biblioref), private, allocatable :: bibrefs(:) +!\end{verbatim} +!----------------------------------------------------------------- +!\begin{verbatim} +! this constant must be incremented when a change is made in gtp_propid + INTEGER, parameter :: gtp_propid_version=1 + TYPE gtp_propid +! this identifies different properties that can depend on composition +! Property 1 is the Gibbs energy and the others are usually used in +! some function to contribute to the Gibbs energy like TC or BMAGN +! But one can also have properties used for other things like mobilities +! with additional especification like MQ&FE +! symbol: property identifier like G for Gibbs energy +! note: short description for listings +! prop_elsymb: additional for element dependent properties like mobilities + character symbol*4,note*16,prop_elsymb*2 +! Each property has a unique value of idprop. Status can state if a property +! has a constituent specifier or if it can depend on T or P + integer status +! this can be a constituent specification for Bohr mangetons or mobilities +! such specification is stored in the property record, not here +! integer prop_spec,listid +! >>> added "listid" as a conection to the "state variable" listing here. +! This replaces TC, BMAG, MQ etc included as "state variables" in order to +! list their values. In this way all propids become available + end TYPE gtp_propid +! the value TYPTY stored in property records is "idprop" or +! if IDELSUFFIX set then 100*"idprop"+ellista index of element +! if IDCONSUFFIX set then 100*"idprop"+constituent index +! When the parameter is read the suffix symbol is translated to the +! current element or constituent index + TYPE(gtp_propid), dimension(:), private, allocatable :: propid +!\end{verbatim} +!----------------------------------------------------------------- +!\begin{verbatim} +! this constant must be incremented when a change is made in gtp_phase_add + INTEGER, parameter :: gtp_phase_add_version=1 + TYPE gtp_phase_add +! record for additions to the Gibbs energy for a phase like magnetism +! addrecno: ? +! aff: antiferomagnetic factor (Inden model) +! need_property: depend on these properties (like Curie T) +! explink: function to calculate with the properties it need +! nextadd: link to another addition + integer type,addrecno,aff + integer, dimension(:), allocatable :: need_property + TYPE(tpfun_expression), dimension(:), pointer :: explink + TYPE(gtp_phase_add), pointer :: nextadd + type(gtp_elastic_modela), pointer :: elastica + END TYPE gtp_phase_add +! allocated when needed and linked from phase record +!\end{verbatim} +!----------------------------------------------------------------- +!\begin{verbatim} +! addition record to calculate the elastic energy contribution +! declared as allocatable in gtp_phase_add +! this constant must be incremented when a change is made in gtp_elastic_modela + INTEGER, parameter :: gtp_elastic_modela_version=1 + TYPE gtp_elastic_modela +! lattice parameters (configuration) in 3 dimensions + double precision, dimension(3,3) :: latticepar +! epsilon in Voigt notation + double precision, dimension(6) :: epsa +! elastic constant matrix in Voigt notation + double precision, dimension(6,6) :: cmat +! calculated elastic energy addition (with derivative to T and P?) + double precision, dimension(6) :: eeadd +! maybe more + end TYPE gtp_elastic_modela +!\end{verbatim} +!----------------------------------------------------------------- +!\begin{verbatim} +! this constant must be incremented when a change is made in gtp_phasetuple + INTEGER, parameter :: gtp_phasetuple_version=1 + TYPE gtp_phasetuple +! for handling a single array with phases and composition sets +! first index is phase index, second index is composition set +! A tuplet index always refer to the same phase+compset. New tuples with +! the same phase and other compsets are added at the end. + integer phase,compset + end TYPE gtp_phasetuple +!\end{verbatim} + TYPE(gtp_phasetuple), allocatable :: PHASETUPLE(:) +! ----------------------------------------------------------------- +! NOTE: if one wants to model bond energies beteween sites in a phase +! like in a 3 sublattice sigma one can enter parameters like +! G(sigma,A:B:*) which will mean the bond energy between an A atom in +! first sublattice and B in the second. The parameter G(sigma,B:A:*) +! will be different. Such parameters are added to the Gibbs energy +! even if there are also endmember parameters like G(sigma,A:B:C) +! ----------------------------------------------------------------- +!\begin{verbatim} +! a smart way to have an array of pointers used in gtp_phase + TYPE endmemrecarray + type(gtp_endmember), pointer :: p1 + end TYPE endmemrecarray +!----------------------------------------------------------------- +! this constant must be incremented when a change is made in gtp_phase + INTEGER, parameter :: gtp_phase_version=1 + TYPE gtp_phaserecord +! this is the record for phase model data. It points to many other records. +! Phases are stored in order of creation in phlista(i) and can be found +! in alphabetical order through the array phases(i) +! sublista is now removed and all data included in phlista +! sublattice and constituent data (they should be merged) +! The constitent link is the index to the splista(i), same function +! as LOKSP in iws. Species in alphabetcal order is in species(i) +! One can allocate a dynamic array for the constituent list, done +! by subroutine create_constitlist. +! Note that the phase has a dynamic status word status2 in gtp_phase_varres +! which can be differnt in different parallell calculations. +! This status word has the FIX/ENT/SUS/DORM status bits for example +! name: phase name, note composition sets can have pre and suffixes +! model: free text +! phletter: G for gas, L for liquid +! alphaindex: the alphabetcal order of the phase (gas and liquids first) + character name*24,models*72,phletter*1 + integer status1,alphaindex +! noofcs: number of composition sets, +! nooffs: number of fraction sets (replaces partitioned phases in TC) + integer noofcs,nooffs +! additions: link to addition record list +! ordered: link to endmember record list +! disordered: link to endmember list for disordered fractions (if any) + TYPE(gtp_phase_add), pointer :: additions + TYPE(gtp_endmember), pointer :: ordered,disordered +! To allow parallel processing of endmembers, store a pointer to each here + integer noemr,ndemr + TYPE(endmemrecarray), dimension(:), allocatable :: oendmemarr,dendmemarr +! noofsubl: number if sublattices +! tnooffr: total number of fractions (constituents) +! linktocs: array with indices to phase_varres records +! nooffr: array with number of constituents in each sublattice +! Note that sites are stored in phase_varres as they may vary with the +! constituion for ionic liquid) +! constitlist: indices of species that are constituents (in all soblattices) + integer noofsubl,tnooffr + integer, dimension(9) :: linktocs + integer, dimension(:), allocatable :: nooffr +! number of sites in phase_varres record as it can vary with composition + integer, dimension(:), allocatable :: constitlist +! used in ionic liquid: +! i2slx(1) is index of Va, i2slx(2) is index if last anion (both can be zero) + integer, dimension(2) :: i2slx +! allocated in init_gtp. + END TYPE gtp_phaserecord +! NOTE phase with index 0 is the reference phase for the elements +! allocated in init_gtp + TYPE(gtp_phaserecord), private, allocatable :: phlista(:) + INTEGER, private, allocatable :: PHASES(:) +!\end{verbatim} +!----------------------------------------------------------------- +! +!=================================================================== +! +! below here are data structures for equilibrium description +! +!=================================================================== +! +!----------------------------------------------------------------- +!\begin{verbatim} +! this constant must be incremented when a change is made in gtp_state_variable + INTEGER, parameter :: gtp_state_variable_version=2 + TYPE gtp_state_variable +! this is to specify a formal or real argument to a function of state variables +! statev/istv: state variable index +! phref/iref: if a specified reference state (for chemical potentials) +! unit/iunit: 100 for percent, no other defined at present +! argtyp together with the next 4 integers represent the indices(4), only 0-4 +! argtyp=0: no indices (T or P) +! argtyp=1: component +! argtyp=2: phase and compset +! argtyp=3: phase and compset and component +! argtyp=4: phase and compset and constituent + integer statevarid,norm,unit,phref,argtyp +! these integers represent the previous indices(4) + integer phase,compset,component,constituent +! a state variable can be part of an expression with coefficients +! the coefficient can be stored here. Default value is unity. +! In many cases it is ignored + double precision coeff +! NOTE this is also used to store a condition of a fix phase +! In such a case statev is negative and the absolute value of statev +! is the phase index. The phase and compset indices are also stored in +! "phase" and "compset" ?? +! This is a temporary storage of the old state variable identifier + integer oldstv + end TYPE gtp_state_variable +! used for state variables/properties in various subroutines +!\end{verbatim} +!----------------------------------------------------------------- +!\begin{verbatim} +! this constant must be incremented when a change is made in gtp_condition +! NOTE on unformatted SAVE files the conditions are written as texts + INTEGER, parameter :: gtp_condition_version=1 + TYPE gtp_condition +! these records form a circular list linked from gtp_equilibrium_data records +! each record contains a condition to be used for calculation +! it is a state variable equation or a phase to be fixed +! The state variable is stored as an integer with indices +! NOTE: some state variables cannot be used as conditions: Q=18, DG=19, 25, 26 +! There can be several terms in a condition (like x(liq,c)-x(fcc,c)=0) +! noofterms: number of terms in condition expression +! statev: the type of state variable (must be the same in all terms) +! negative value of statev means phase index for fix phase +! active: zero if condition is active, nonzero for other cases +! unit: is 100 if value in percent, can also be used for temperature unit etc. +! nid: identification sequential number (in order of creation), redundant +! iref: part of the state variable (iref can be comp.set number) +! iunit: ? confused with unit? +! seqz is a sequential index of conditions, used for axis variables +! symlink: index of symbol for prescribed value (1) and uncertainity (2) +! condcoeff: there is a coefficient and set of indices for each term +! prescribed: the prescribed value +! NOTE: if there is a symlink value that is the prescribed value +! current: the current value (not used?) +! uncertainity: the uncertainity (for experiments) + integer :: noofterms,statev,active,iunit,nid,iref,seqz +! TYPE(putfun_node), pointer :: symlink1,symlink2 +! better to let condition symbol be index in svflista array + integer symlink1,symlink2 + integer, dimension(:,:), allocatable :: indices + double precision, dimension(:), allocatable :: condcoeff + double precision prescribed, current, uncertainity +! currently this is not used but it will be + TYPE(gtp_state_variable), dimension(:), allocatable :: statvar + TYPE(gtp_condition), pointer :: next, previous + end TYPE gtp_condition +! declared inside the gtp_equilibrium_data record +!\end{verbatim} +!----------------------------------------------------------------- +!\begin{verbatim} +! this constant must be incremented when a change is made in gtp_putfun_lista + INTEGER, parameter :: gtp_putfun_lista_version=1 + TYPE gtp_putfun_lista +! these are records for state variable functions. The function itself +! is handelled by the putfun package. +! linkpnode: pointer to start node of putfun expression +! narg: number of symbols in the function +! nactarg: number of actual parameter specifications needed in call +! (like @P, @C and @S +! status: can be used for various things +! status bit SVFVAL=0 means value evaluated only when called with mode=1 +! eqnoval: used to specify the equilibrium the value should be taken from +! (for handling what is called "variables" in TC) +! name: name of symbol + integer narg,nactarg,status,eqnoval + type(putfun_node), pointer :: linkpnode + character name*16 +! this array has identification of state variable (and other function) symbols + integer, dimension(:,:), pointer :: formal_arguments + end TYPE gtp_putfun_lista +! this is the global array with state variable functions + TYPE(gtp_putfun_lista), dimension(:), allocatable :: svflista +! NOTE the value of a function is stored locally in each equilibrium record +! in array svfunres. +! The number of entered state variable functions. Used when a new one stored + integer, private :: nsvfun +!\end{verbatim} +!----------------------------------------------------------------- +!\begin{verbatim} +! this constant must be incremented when a change is made in gtp_fraction_set + INTEGER, parameter :: gtp_fraction_set_version=1 + TYPE gtp_fraction_set +! info about disordred fractions for some phases like ordered fcc, sigma etc +! latd: the number of sublattices added to first disordred sublattice +! ndd: sublattices for this fraction set, +! tnoofxfr: number of disordered fractions +! tnoofyfr: same for ordered fractions (=same as in phlista). +! varreslink: index of disordered phase_varres, +! phdapointer: pointer to the same phase_varres record as varreslink +! (Note that there is a bit set indicating that the sublattices should +! be taken from this record) +! totdis: 0 indicates no total disorder (sigma), 1=fcc, bcc or hcp +! id: parameter suffix, D for disordered +! dsites: number of sites in sublattices, disordred fractions stored in +! another phase_varres record linked from phdapointer +! splink: pointers to species record for the constituents +! nooffr: the number of fractions in each sublattice +! y2x: the conversion from sublattice constituents to disordered and +! dxidyj: are the the coeff to multiply the y fractions to get the disordered +! xfra(y2x(i))=xfra(y2x(i))+dxidyj(i)*yfra(i) +! disordered fractions stored in the phase_varres record with index varreslink +! (also pointed to by phdapointer). Maybe phdapointer is redundant?? +! arrays originally declared as pointers now changed to allocatable + integer latd,ndd,tnoofxfr,tnoofyfr,varreslink,totdis + character*1 id + double precision, dimension(:), allocatable :: dsites + integer, dimension(:), allocatable :: nooffr + integer, dimension(:), allocatable :: splink + integer, dimension(:), allocatable :: y2x + double precision, dimension(:), allocatable :: dxidyj +! factor needed when reading from TDB file for sigma etc. + double precision fsites +! in parallel processing the disordered phase_varres record is linked +! by this pointer, used in parcalcg and calcg_internal + TYPE(gtp_phase_varres), pointer :: phdapointer + END TYPE gtp_fraction_set +! these records are declared in the phase_varres record as DISFRA for +! each composition set and linked from the phase_varres record +!\end{verbatim} +!----------------------------------------------------------------- +!\begin{verbatim} +! this constant must be incremented when a change is made in gtp_phase_varres + INTEGER, parameter :: gtp_phase_varres_version=1 + TYPE gtp_phase_varres +! Data here must be different in equilibria representing different experiments +! or calculated in parallel or results saved from step or map. +! nextfree: In unused phase_varres record it is the index to next free record +! The global integer csfree is the index of the first free record +! phlink: is index of phase record for this phase_varres record +! status2: has phase status bits like ENT/FIX/SUS/DORM +! phstate: indicate state: fix/stable/entered/unknown/dormant/suspended/hidden +! 2 1 0 -1 -2 -3 -4 +! phtupx: phase tuple index + integer nextfree,phlink,status2,phstate,phtupx +! abnorm(1): amount moles of atoms for a formula unit of the composition set +! abnorm(2): mass/formula unit (both set by call to set_constitution) +! prefix and suffix are added to the name for composition sets 2 and higher + double precision, dimension(2) :: abnorm + character*4 prefix,suffix +! constat: array with status word for each constituent, any can be suspended +! yfr: the site fraction array +! mmyfr: min/max fractions, negative is a minumum +! sites: site ratios (which can vary for ionic liquids) + integer, dimension(:), allocatable :: constat + double precision, dimension(:), allocatable :: yfr + real, dimension(:), allocatable :: mmyfr + double precision, dimension(:), allocatable :: sites +! for ionic liquid derivatives of sites wrt fractions (it is the charge), +! 2nd derivates only when one constituent is vacancy +! 1st sublattice P=\sum_j (-v_j)*y_j + Qy_Va +! 2nd sublattice Q=\sum_i v_i*y_i +! dpqdy is the abs(valency) of the species, set in set_constitution +! for the vacancy it is the same as the number of sites on second subl. +! used in the minimizer and maybe elsewhere + double precision, dimension(:), allocatable :: dpqdy + double precision, dimension(:), allocatable :: d2pqdvay +! disfra: a structure describing the disordered fraction set (if any) +! for extra fraction sets, better to go via phase record index above +! this TYPE(gtp_fraction_set) variable is a bit messy. Declaring it in this +! way means the record is stored inside this record. + type(gtp_fraction_set) :: disfra +! --- +! arrays for storing calculated results for each phase (composition set) +! amfu: is amount formula units of the composition set (calculated result) +! netcharge: is net charge of phase +! dgm: driving force + double precision amfu,netcharge,dgm +! Other properties may be that: gval(*,2) is TC, (*,3) is BMAG, see listprop +! nprop: the number of different properties (set in allocate) +!- ncc: total number of site fractions (redundant but used in some subroutines) +! BEWHARE: ncc seems to be wrong using TQ test program fenitq.F90 ??? +! listprop(1): is number of calculated properties +! listprop(2:listprop(1)): identifies the property stored in gval(1,ipy) etc +! 2=TC, 3=BMAG. Properties defined in the gtp_propid record +!- integer nprop,ncc + integer nprop + integer, dimension(:), allocatable :: listprop +! gval etc are for all composition dependent properties, gval(*,1) for G +! gval(*,1): is G, G.T, G.P, G.T.T, G.T.P and G.P.P +! dgval(1,j,1): is first derivatives of G wrt fractions j +! dgval(2,j,1): is second derivatives of G wrt fractions j and T +! dgval(3,j,1): is second derivatives of G wrt fractions j and P +! d2gval(ixsym(i,j),1): is second derivatives of G wrt fractions i and j + double precision, dimension(:,:), allocatable :: gval + double precision, dimension(:,:,:), allocatable :: dgval + double precision, dimension(:,:), allocatable :: d2gval +! added for strain/stress, current values of lattice parameters + double precision, dimension(3,3) :: curlat +! saved values from last equilibrium for dot derivative calculations + double precision, dimension(:,:), allocatable :: cinvy + double precision, dimension(:), allocatable :: cxmol + double precision, dimension(:,:), allocatable :: cdxmol + END TYPE gtp_phase_varres +! this record is created inside the gtp_equilibrium record +!\end{verbatim} +!----------------------------------------------------------------- +!\begin{verbatim} +! this must be incremented when a change is made in gtp_equilibrium_data + INTEGER, parameter :: gtp_equilibrium_data_version=2 + TYPE gtp_equilibrium_data +! this contains all data specific to an equilibrium like conditions, +! status, constitution and calculated values of all phases etc +! Several equilibria may be calculated simultaneously in parallell threads +! so each equilibrium must be independent +! NOTE: the error code must be local to each equilibria!!!! +! During step and map each equilibrium record with results is saved +! values of T and P, conditions etc. +! Values here are normally set by external conditions or calculated from model +! local list of components, phase_varres with amounts and constitution +! lists of element, species, phases and thermodynamic parameters are global +! status: not used yet? +! multiuse: used for various things like direction in start equilibria +! eqno: sequential number assigned when created +! next: index of next equilibrium in a sequence during step/map calculation. +! eqname: name of equilibrium +! tpval(1) is T, tpval(2) is P, rgas is R, rtn is R*T +! rtn: value of R*T + integer status,multiuse,eqno,next + character eqname*24 + double precision tpval(2),rtn +! svfunres: the values of state variable functions valid for this equilibrium + double precision, dimension(:), allocatable :: svfunres +! the experiments are used in assessments and stored like conditions +! lastcondition: link to condition list +! lastexperiment: link to experiment list + TYPE(gtp_condition), pointer :: lastcondition,lastexperiment +! components and conversion matrix from components to elements +! complist: array with components +! compstoi: stoichiometric matrix of compoents relative to elements +! invcompstoi: inverted stoichiometric matrix + TYPE(gtp_components), dimension(:), allocatable :: complist + double precision, dimension(:,:), allocatable :: compstoi + double precision, dimension(:,:), allocatable :: invcompstoi +! one record for each phase+composition set that can be calculated +! phase_varres: here all calculated data for the phase is stored + TYPE(gtp_phase_varres), dimension(:), allocatable :: phase_varres +! index to the tpfun_parres array is the same as in the global array tpres +! eq_tpres: here local calculated values of TP functions are stored + TYPE(tpfun_parres), dimension(:), pointer :: eq_tpres +! current values of chemical potentials stored in component record but +! duplicated here for easy acces by application software + double precision, dimension(:), allocatable :: cmuval +! xconc: convergence criteria for constituent fractions and other things + double precision xconv +! delta-G value for merging gridpoints in grid minimizer +! smaller value creates problem for test step3.BMM, MC and austenite merged + double precision :: gmindif=-5.0D-2 +! maxiter: maximum number of iterations allowed + integer maxiter +! this is to save a copy of the last calculated system matrix, needed +! to calculate dot derivatives, initiate to zero + integer :: sysmatdim=0,nfixmu=0,nfixph=0 + integer, allocatable :: fixmu(:) + integer, allocatable :: fixph(:,:) + double precision, allocatable :: savesysmat(:,:) + END TYPE gtp_equilibrium_data +! The primary copy of this structures is declared globally as FIRSTEQ here +! Others may be created when needed for storing experimental data or +! for parallel processing. A global array of these are + TYPE(gtp_equilibrium_data), dimension(:), allocatable, target :: eqlista + TYPE(gtp_equilibrium_data), pointer :: firsteq +! This array of equilibrium records are used for storing results during +! STEP and MAP calculations. + TYPE(gtp_equilibrium_data), dimension(:), allocatable :: eqlines +!\end{verbatim} +!----------------------------------------------------------------- +!\begin{verbatim} +! for each permutation in the binary interaction tree of an endmember one must +! keep track of the permutation and the permutation limit. +! It is not possible to push the value on pystack as one must remember +! them when changing the endmember permutation +! integer, parameter :: permstacklimit=150 +! this constant must be incremented when a change is made in gtp_parcalc + INTEGER, parameter :: gtp_parcalc_version=1 + TYPE gtp_parcalc +! This record contains temporary data that must be separate in different +! parallell processes when calculating G and derivatives for any phase. +! There is nothing here that need to be saved after the calculation is finished +! global variables used when calculating G and derivaties +! sublattice with interaction, interacting constituent, endmember constituents +! PRIVATE inside this structure not liked by some compilers.... +! endcon must have maxsubl dimension as it is used for all phases + integer :: intlat(maxinter),intcon(maxinter),endcon(maxsubl) +! interaction level and number of fraction variables + integer :: intlevel,nofc +! interacting constituents (max 4) for composition dependent interaction +! iq(j) indicate interacting constituents +! for binary RK+Muggianu iq(3)=iq(4)=iq(5)=0 +! for ternary Muggianu in same sublattice iq(4)=iq(5)=0 +! for reciprocal composition dependent iq(5)=0 +! for Toop, Kohler and simular iq(5) non-zero (not implemented) + integer :: iq(5) +! fraction variables in endmember (why +2?) and interaction + double precision :: yfrem(maxsubl+2),yfrint(maxinter) +! local copy of T, P and RT for this equilibrium + double precision :: tpv(2),rgast +! double precision :: ymin=1.0D-30 + end TYPE gtp_parcalc +! this record is declared locally in subroutine calcg_nocheck +!\end{verbatim} +!------------------------------------------------------------------- +!\begin{verbatim} +! this constant must be incremented when a change is made in gtp_pystack + INTEGER, parameter :: gtp_pystack_version=1 + TYPE gtp_pystack +! records created inside the subroutine push/pop_pystack +! data stored during calculations when entering an interaction record +! previous: link to previous record in stack +! ipermutsave: permutation must be saved +! intrecsave: link to interaction record +! pysave: saved value of product of all constituent fractions +! dpysave: saved value of product of all derivatives of constituent fractions +! d2pysave: saved value of product of all 2nd derivatives of constit fractions + TYPE(gtp_pystack), pointer :: previous + integer :: pmqsave + TYPE(gtp_interaction), pointer :: intrecsave + double precision :: pysave + double precision, dimension(:), allocatable :: dpysave + double precision, dimension(:), allocatable :: d2pysave + end TYPE gtp_pystack +! declared inside the calcg_internal subroutine +!\end{verbatim} +!----------------------------------------------------------------- +! +!=================================================================== +! +! below here are data structures for various applications +! They indicate data that may need to be saved together with +! the thermodynamic data. Exactly how this will be handelled +! will have to be solved later +! +!=================================================================== +! +!----------------------------------------------------------------- +!\begin{verbatim} + INTEGER, parameter :: gtp_eqnode_version=1 + TYPE gtp_eqnode +! This record is to arrange calculated equilibria, for example results +! from a STEP or MAP calculation, in an ordered way. The equilibrium records +! linked from an eqnode record should normally represent one or more lines +! in a diagram but may be used for other purposes. +! ident is to be able to find a specific node +! nodedtype is to specify invariant, middle, end etc. +! status can be used to supress a line +! color can be used to sepecify color or linetypes (dotted, thick ... etc) +! exits are the number of lines that should exit from the node +! done are the number of calculated lines currently exiting from the node + integer ident,nodetype,status,color,exits,done +! this node can be in a multilayerd list of eqnodes + type(gtp_eqnode), pointer :: top,up,down,next,prev +! nodeq is a pointer to the equilibrium record at the node + type(gtp_equilibrium_data), pointer :: nodeq +! eqlista are pointers to line of equilibria starting or ending at the node +! The equilibrium records are linked with a pointer inside themselves + type(gtp_equilibrium_data), dimension(:), pointer :: eqlista +! axis is the independent axis variable for the line, negative means decrement +! noeqs gives the number of equilibria in each eqlista, a negative value +! indicates that the node is an endpoint (each line normally has a +! start point and an end point) + integer, dimension(:), allocatable :: axis,noeqs +! This is a possibility to specify a status for each equilibria in each line +! integer, dimension(:,:), allocatable :: eqstatus + end TYPE gtp_eqnode +! can be allocated in a gtp_applicationhead record +!\end{verbatim} +!------------------------------------------------------------------ +!\begin{verbatim} + INTEGER, parameter :: gtp_applicationhead_version=1 + TYPE gtp_applicationhead +! This record should summarize the essential information about an application +! using GTP. How it should link to other information is not clear. +! The character variables should be used to indicate that. + integer apptyp,status + character*64 general,special +! These can be used to define axis and other things + integer, dimension(:), allocatable :: ivals + double precision, dimension(:), allocatable :: rvals + character*64, dimension(:), allocatable :: cvals + type(gtp_applicationhead), pointer :: nextapp,prevapp +! The headnode can be the start of a structure of eqnodes with lines + type(gtp_eqnode) :: headnode +! this is the start of a list of nodes with calculated lines or +! single equilibria that belong to the application. + type(gtp_eqnode), dimension(:), allocatable :: nodlista + end TYPE gtp_applicationhead +! this record is allocated when necessary + type(gtp_applicationhead), pointer :: firstapp,lastapp +!\end{verbatim} +!----------------------------------------------------------------- +! +! a global array to provide information about composition sets +! phcs(nph) is the composition set counter for phase nph +! integer, dimension(maxph) :: phcs ----- removed as redundant ?? +! +!=================================================================== +! +! Below are private global variables like free lists etc. +! +!=================================================================== + +! Several arrays with lists have a free list: csfree,addrecs,eqfree,reffree +! +!\begin{verbatim} +! counters for elements, species and phases initiated to zero + integer, private :: noofel=0,noofsp=0,noofph=0 +! counter for phase tuples (combination of phase+compset) + integer, private :: nooftuples=0 +! counters for property and interaction records, just for fun + integer, private :: noofprop,noofint,noofem +! free lists in phase_varres records and addition records + integer, private :: csfree,addrecs +! free list of references and equilibria + integer, private :: reffree,eqfree +! maximum number of properties calculated for a phase + integer, private :: maxcalcprop=20 +! highest used phase_varres record (for saving on file) + integer, private :: highcs +! Trace for debugging (not used) + logical, private :: ttrace +! minimum constituent fraction + double precision :: bmpymin +! number of defined property types like TC, BMAG etc + integer, private :: ndefprop +!\end{verbatim} + +CONTAINS + +! 1-5: initialization, how many, find things, get things, set things, +include "gtp3A.F90" + +! 12: enter data +include "gtp3B.F90" + +! 10: list data +include "gtp3C.F90" + +! 11: save and read from files +include "gtp3D.F90" + +! 7: state variable manipulations +include "gtp3E.F90" + +! 8-9: state variable functions, interactive things +include "gtp3F.F90" + +! 13-15: status for things, unfinished things, internal stuff +include "gtp3G.F90" + +! 16: Additions (magnetic and others) +include "gtp3H.F90" + +! 6: calculate things +include "gtp3X.F90" + +! 17-18: Grid minimizer and miscellaneous +include "gtp3Y.F90" + + +END MODULE GENERAL_THERMODYNAMIC_PACKAGE + diff --git a/models/pmod25A.F90 b/models/gtp3A.F90 similarity index 74% rename from models/pmod25A.F90 rename to models/gtp3A.F90 index 7a2d94f..6378639 100644 --- a/models/pmod25A.F90 +++ b/models/gtp3A.F90 @@ -1,1643 +1,2067 @@ -! -! included in pmod25.F90 -! -!**************************************************** -! general subroutines for creating and handling elements, species, phases etc -! accessable externally - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ -!> 1. Initialization -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine init_gtp(intvar,dblvar) -! initiate the data structure -! create element and species record for electrons and vacancies -! the allocation of many arrays should be provided calling this routne -! intvar and dblvar will eventually be used for allocations and defaults - implicit none - integer intvar(*) - double precision dblvar(*) -!\end{verbatim} - character tpname*16,tpfun*80 - integer jl,ieq,ip,lrot,npid -! - noofel=0; noofsp=0; noofph=0; nooftuples=0 -! write(*,3)'In init_gtp',maxel,maxsp,maxph -3 format(a,10i5) -! allocate records for elements - allocate(ellista(-1:maxel)) - allocate(elements(-1:maxel)) -! allocate records for species - allocate(splista(maxsp)) - allocate(species(maxsp)) -! allocate records for phases - allocate(phlista(0:maxph)) - allocate(phases(0:maxph)) - allocate(phasetuple(0:2*maxph)) -! phases(0) is refrence phase, evidently this index is never set - phases(0)=0 -!--------------------------- -! create special element /- - ellista(-1)%symbol='/-' - ellista(-1)%name='Electron' - ellista(-1)%ref_state='Electron_gas' - ellista(-1)%mass=zero - ellista(-1)%h298_h0=zero - ellista(-1)%s298=zero - ellista(-1)%status=0 - ellista(-1)%alphaindex=-1 -! The electron does not have any corresponing species - ellista(-1)%splink=-1 - elements(-1)=-1 -! create special elements VA - ellista(0)%symbol='VA' - ellista(0)%name='Vacancy' - ellista(0)%ref_state='Vaccum' - ellista(0)%mass=zero - ellista(0)%h298_h0=zero - ellista(0)%s298=0.0D0 - ellista(0)%status=0 - ellista(0)%alphaindex=0 -! splink set below -! ellista(0)%splink=0 -! allocate element link array - allocate(splista(1)%ellinks(1)) - allocate(splista(1)%stoichiometry(1)) - splista(1)%symbol='VA' - splista(1)%mass=zero - splista(1)%charge=zero - splista(1)%status=0 -! set status bits that is is also an element and it is the vacancy - splista(1)%status=ibset(splista(1)%status,SPEL) - splista(1)%status=ibset(splista(1)%status,SPVA) - splista(1)%alphaindex=1 - splista(1)%noofel=1 - splista(1)%ellinks(1)=0 - splista(1)%stoichiometry(1)=one - elements(0)=0 - noofsp=1 - species(1)=1 -! link from element Va to species Va - ellista(0)%splink=1 -! write(*,3)'more allocate: ',maxrefs,maxprop,maxeq,maxtpf,maxsvfun - allocate(bibrefs(maxrefs)) - allocate(propid(maxprop)) -! first free data reference record (static) - reffree=1 - addrecs=0 -!--------------------------------------- - noofem=0 - noofint=0 - noofprop=0 -!---------------------------------------- -! initiate equilibrium record list -! dimension arrays for in first equilibrium record including phase_varres - allocate(eqlista(maxeq)) - do jl=1,maxeq-1 - eqlista(jl)%next=jl+1 - enddo - eqlista(maxeq)%next=-1 - eqfree=1 -! create first equilibrium record incl complist - call enter_equilibrium('DEFAULT_EQUILIBRIUM ',ieq) - if(gx%bmperr.ne.0) then - write(*,*)' error in first enter_equilibrium',gx%bmperr - goto 1000 - endif - firsteq=>eqlista(1) -! nullify some pointers because of error entering first - nullify(firsteq%lastcondition,firsteq%lastexperiment) -! set phase_varres free list in firsteq. These are always allocated together - do jl=1,2*maxph-1 - firsteq%phase_varres(jl)%nextfree=jl+1 - enddo -! NOTE last phase_varres record used for copy in shiftcompsets - firsteq%phase_varres(2*maxph)%nextfree=-1 -! csfree is not declared ... how can that be?? where is it declared ?? - csfree=1 -! convergence criteria for constituent fractions, 1e-6 works most often -! But one should take care to equilibrate fractions smaller than xconv!!! - firsteq%xconv=1.0D-6 - firsteq%maxiter=500 -! initiate tp functions -! write(*,*)'init_gtp: initiate TP fuctions' - jl=maxtpf - call tpfun_init(jl,firsteq%eq_tpres) -!------------------------------------ -! Property records define what can be used as "id" for parameters, the first -! must be G for the "chemical" part. The others are connected to various -! additions or are simply properties that may depend on composition and is -! needed in other contexts, like mobilities, viscosities etc. -! create property id records for G - npid=1 - propid(npid)%symbol='G ' - propid(npid)%note='Energy ' - propid(npid)%status=0 -!============================================================ -! VERY IMPORTANT: The properties defined below must not be equal to state -! variables, if so they cannot be listed and other errors may occur -! -! ANY CHANGES HERE MUST BE MADE ALSO IN SUBROUTINE state_variable_val, pmod25c -! -!============================================================ -! Mixed Curie/Neel Temperature, set bits that TC and BM cannot depend on T - npid=npid+1 - propid(npid)%symbol='TC ' - propid(npid)%note='Mix Curie/Neel T' - propid(npid)%status=0 -! TC cannot depend on T but on P - propid(npid)%status=ibset(propid(npid)%status,IDONLYP) -!....................................... -! Average Bohr magneton number - npid=npid+1 - propid(npid)%symbol='BMAG ' - propid(npid)%note='Aver Bohr magn no' - propid(npid)%status=0 -! BM cannot depend on either T or P ?? - propid(npid)%status=ibset(propid(npid)%status,IDNOTP) -!....................................... -! Specific Curie temperature - npid=npid+1 - propid(npid)%symbol='CTA ' - propid(npid)%note='Curie temperature' - propid(npid)%status=0 -! CTA cannot depend on either T or P ?? - propid(npid)%status=ibset(propid(npid)%status,IDONLYP) -!....................................... -! Specific Neel temperature - npid=npid+1 - propid(npid)%symbol='NTA ' - propid(npid)%note='Neel temperature' - propid(npid)%status=0 -! NTA cannot depend on T but on P - propid(npid)%status=ibset(propid(npid)%status,IDONLYP) -!....................................... -! Individual Bohr magneton number - npid=npid+1 - propid(npid)%symbol='IBM ' - propid(npid)%note='Ind. Bohr magn no' - propid(npid)%status=0 -! IBM cannot depend on either T or P and it is individual - propid(npid)%status=ibset(propid(npid)%status,IDCONSUFFIX) - propid(npid)%status=ibset(propid(npid)%status,IDONLYP) -!....................................... -! Debye or Einstein temperature - npid=npid+1 - propid(npid)%symbol='THETA ' - propid(npid)%note='Debye or Einst temp' - propid(npid)%status=0 -! THETA cannot depend on T but on P - propid(npid)%status=ibset(propid(npid)%status,IDONLYP) -!....................................... -! logarithm of individual mobility - npid=npid+1 - propid(npid)%symbol='MQ ' - propid(npid)%note='LN mob. of const.' - propid(npid)%status=0 -! MQ is specific för a constituent - propid(npid)%status=ibset(propid(npid)%status,IDCONSUFFIX) -!....................................... -! Electrical resistivity - npid=npid+1 - propid(npid)%symbol='RHO ' - propid(npid)%note='Elect resistivity' - propid(npid)%status=0 -!....................................... -! Magnetic suseptibility - npid=npid+1 - propid(npid)%symbol='MAGS ' - propid(npid)%note='Magn suseptibility' - propid(npid)%status=0 -!....................................... -! Glas trasition temperature - npid=npid+1 - propid(npid)%symbol='GTT ' - propid(npid)%note='Glas trans temperature' - propid(npid)%status=0 -! Cannot depend on temperature - propid(npid)%status=ibset(propid(npid)%status,IDONLYP) -!....................................... -! Viscosity - npid=npid+1 - propid(npid)%symbol='VISCA ' - propid(npid)%note='Viscosity' - propid(npid)%status=0 -!....................................... -! Lattice parameter in direction X - npid=npid+1 - propid(npid)%symbol='LPX ' - propid(npid)%note='Lat par X axis' - propid(npid)%status=0 -! lattice parameters may depend on T and P -!....................................... -! Lattice parameter in direction Y - npid=npid+1 - propid(npid)%symbol='LPY ' - propid(npid)%note='Lat par Y axis' - propid(npid)%status=0 -! lattice parameters may depend on T and P -!....................................... -! Lattice parameter in direction Z - npid=npid+1 - propid(npid)%symbol='LPZ ' - propid(npid)%note='Lat par Z axis' - propid(npid)%status=0 -! lattice parameters may depend on T and P -!....................................... -! This is an angle for non-cubic lattices - npid=npid+1 - propid(npid)%symbol='LPTH ' - propid(npid)%note='Lat angle TH' - propid(npid)%status=0 -! Angle may depend on T and P -!....................................... -! This is an elastic "constant" - npid=npid+1 - propid(npid)%symbol='EC11 ' - propid(npid)%note='Elast const C11' - propid(npid)%status=0 -! The elastic constant may depend on T and P -!....................................... -! This is another elastic "constant" - npid=npid+1 - propid(npid)%symbol='EC12 ' - propid(npid)%note='Elast const C12' - propid(npid)%status=0 -! The elastic constant may depend on T and P -!....................................... -! This is yet another elastic "constant" - npid=npid+1 - if(npid.gt.maxprop) then - write(*,*)'Too many parameter identifiers, increase maxprop' - gx%bmperr=7777; goto 1000 - endif - propid(npid)%symbol='EC44 ' - propid(npid)%note='Elast const C44' - propid(npid)%status=0 -! The elastic constant may depend on T and P -!....................................... -! IMPORTRANT: When adding more parameter identifiers one should never -! use a name ending in D as that would be taken as a "disordered" -! The number of defined properties, should be less than maxprop -! IMPORTANT: In the addition records one must use the parameter identifier -! to extract the calculated composition dependent values - ndefprop=npid -!------------------------------------------------- - highcs=0 -! globaldata record; set gas constant mm - globaldata%status=0 -! set advanced user, no data, no phase, no equilibrium calculated - globaldata%status=ibset(globaldata%status,GSADV) - globaldata%status=ibset(globaldata%status,GSNODATA) - globaldata%status=ibset(globaldata%status,GSNOPHASE) - firsteq%status=ibset(firsteq%status,EQNOEQCAL) -! set gas constant and some default values - globaldata%name='current' - globaldata%rgas=8.31451D0 -! more recent value -! globaldata%rgas=8.3144621D0 -! old value of gas constant - globaldata%rgasuser=8.31451D0 - globaldata%pnorm=one -! write(*,*)'init_gtp: enter R and RTLNP' -! enter R as TP function - tpname='R' -! write(tpfun,777)' 10 8.31451; 20000 N ' -!777 format(a) -! call enter_tpfun(tpname,tpfun,lrot,.FALSE.) - call enter_tpconstant(tpname,globaldata%rgas) - if(gx%bmperr.ne.0) goto 1000 - tpname='RTLNP' - tpfun=' 10 R*T*LN(1.0D-5*P); 20000 N ' - call enter_tpfun(tpname,tpfun,lrot,.FALSE.) - if(gx%bmperr.ne.0) goto 1000 -! default minimum fraction - bmpymin=ymind -! putfun error code .... should use buperr at least - pfnerr=0 -!------------------------------------ -! allocate array for state variable function -! write(*,*)'init_gtp: allocate array for state variable functions' - allocate(svflista(maxsvfun)) -! number of state variable function - nsvfun=0 -! zero the array with equilibrium index for functions, not used aywhere?? -! pflocal=0 -! enter some useful state variable function - tpfun=' R=8.31451;' - ip=1 -! write(*,*)'init_gtp: entering function R' - call enter_svfun(tpfun,ip,firsteq) -! if(gx%bmperr.ne.0) then -! write(*,*)'Error entering R',gx%bmperr -! goto 1000 -! endif -! write(*,*)'Entered symbol R' - tpfun=' RT=R*T;' - ip=1 -! write(*,*)'init_gtp: entering function RT' - call enter_svfun(tpfun,ip,firsteq) -! if(gx%bmperr.ne.0) then -! write(*,*)'Error entering symbol RT' -! goto 1000 -! endif -! write(*,*)'Entered symbol RT' - tpfun=' T_C=T-273.15;' - ip=1 -! write(*,*)'init_gtp: entering function T_C' - call enter_svfun(tpfun,ip,firsteq) -! if(gx%bmperr.ne.0) then -! write(*,*)'Error entering symbol T_C' -! goto 1000 -! endif -! finished initiating -1000 continue -! write(*,*)'exit from init_gtp' - return - END subroutine init_gtp - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ -!> 2. Number of things -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - integer function noel() -! number of elements because noofel is private -! should take care if elements are suspended -!\end{verbatim} %+ - noel=noofel - end function noel - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - integer function nosp() -! number of species because noofsp is private -! should take care if species are suspended -!\end{verbatim} %+ - nosp=noofsp - end function nosp - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - integer function noph() -! number of phases because noofph is private -! should take care if phases are hidden -!\end{verbatim} %+ - noph=noofph - end function noph - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - integer function noofcs(iph) -! returns the number of compositions sets for phase iph - implicit none - integer iph -!\end{verbatim} %+ - if(iph.le.0 .or. iph.gt.noofph) then - gx%bmperr=4050; goto 1000 - endif - noofcs=phlista(phases(iph))%noofcs -1000 continue - return - end function noofcs - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - integer function noconst(iph,ics,ceq) -! number of constituents for iph (include single constituents on a sublattice) -! It tests if a constituent is suspended which can be different in each ics. - implicit none - integer iph,ics - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer lokph,lokcs,noc,jl - if(iph.gt.0 .and. iph.le.noofph) then - lokph=phases(iph) - if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then -! write(*,*)'noconst 1 error 4072' - gx%bmperr=4072; goto 1000 - elseif(ics.eq.0) then - ics=1 - endif - lokcs=phlista(lokph)%linktocs(ics) - if(btest(ceq%phase_varres(lokcs)%status2,CSCONSUS)) then -! some constituents suspended - noc=phlista(lokph)%tnooffr - do jl=1,phlista(lokph)%tnooffr - if(btest(ceq%phase_varres(lokcs)%constat(jl),CONSUS)) then - noc=noc-1 - endif - enddo - noconst=noc - else - noconst=phlista(lokph)%tnooffr - endif - else - gx%bmperr=4050 - endif -1000 continue - return - end function noconst - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - integer function nosvf() -! number of state variable functions -!\end{verbatim} - implicit none - nosvf=nsvfun - return - end function nosvf - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - integer function noeq() -! returns the number of equilibria entered -!\end{verbatim} - implicit none - noeq=eqfree-1 -1000 continue - return - end function noeq - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - integer function nonsusphcs(ceq) -! integer function totalphcs(ceq) -! returns the total number of unhidden phases+composition sets -! in the system. Used for dimensioning work arrays and in loops - implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer tphic,iph,ics,lokph - double precision xxx - tphic=0 - do iph=1,noofph - lokph=phases(iph) - ics=1 - if(test_phase_status(iph,ics,xxx,ceq).ne.PHHIDDEN) then -! phase is not hidden - do ics=1,phlista(lokph)%noofcs -! if(test_phase_status(iph,ics,xxx,ceq).eq.4) goto 400 - if(test_phase_status(iph,ics,xxx,ceq).ne.PHSUS) then - tphic=tphic+1 - endif -! composition set not suspended -! tphic=tphic+phlista(lokph)%noofcs - enddo - endif - enddo -1000 continue -! write(*,*)'25 A nonsusphcs: ',tphic -! totalphcs=tphic - nonsusphcs=tphic - return - end function nonsusphcs - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ -!> 3. Find things -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine find_element_by_name(name,iel) -! find an element index by its name - implicit none - character name*(*) - integer iel -!\end{verbatim} %+ - integer lokel - character symbol*2 - symbol=name - call capson(symbol) - do lokel=-1,noofel -! write(*,*)'find_element 1: ',lokel,symbol,' ',ellista(lokel)%symbol - if(symbol.eq.ellista(lokel)%symbol) then - iel=ellista(lokel)%alphaindex - goto 1000 - endif - enddo - iel=-100 - gx%bmperr=4042 -1000 continue - return - end subroutine find_element_by_name - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine find_component_by_name(name,icomp,ceq) -! BEWARE: one may in the future have different components in different -! equilibria. components are a subset of the species - implicit none - character*(*) name - integer icomp - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} %+ - integer loksp - call find_species_record_noabbr(name,loksp) - if(gx%bmperr.ne.0) then - gx%bmperr=4052; goto 1000 - endif -! check that species actually is component - do icomp=1,noofel - if(ceq%complist(icomp)%splink.eq.loksp) goto 1000 - enddo - gx%bmperr=4052 -1000 continue - return - end subroutine find_component_by_name - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine find_species_by_name(name,isp) -! locates a species index from its name - implicit none - character name*(*) - integer isp -!\end{verbatim} %+ - character symbol*24 - integer loksp - symbol=name - call capson(symbol) - do loksp=1,noofsp -! write(*,*)'find species 2: ',loksp,splista(loksp)%symbol - if(compare_abbrev(symbol,splista(loksp)%symbol)) then - isp=splista(loksp)%alphaindex - goto 1000 - endif - enddo -! write(*,*)'in find_species_by_name' - gx%bmperr=4051 - loksp=0 -1000 continue - return - end subroutine find_species_by_name - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine find_species_record(name,loksp) -! locates a species record allowing abbreviations - implicit none - character name*(*) - integer loksp -!\end{verbatim} %+ - character symbol*24 - symbol=name - call capson(symbol) - do loksp=1,noofsp -! write(*,17)'find species 17: ',loksp,splista(loksp)%symbol,name -!17 format(a,i3,' "',a,'" "',a,'"') - if(compare_abbrev(symbol,splista(loksp)%symbol)) goto 1000 - enddo -! write(*,*)'Error in find_species_record "',name,'"' - gx%bmperr=4051 - loksp=0 -1000 continue - return - end subroutine find_species_record - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine find_species_record_noabbr(name,loksp) -! locates a species record no abbreviations allowed - implicit none - character name*(*) - integer loksp -!\end{verbatim} %+ - character symbol*24 - symbol=name - call capson(symbol) - do loksp=1,noofsp -! write(*,17)'find species 17B: ',loksp,splista(loksp)%symbol,name -!17 format(a,i3,' "',a,'" "',a,'"') - if(symbol.eq.splista(loksp)%symbol) goto 1000 - enddo -! write(*,*)'Error in find_species_record_noabbr "',name,'"' - gx%bmperr=4051 - loksp=0 -1000 continue - return - end subroutine find_species_record_noabbr - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine find_species_record_exact(name,loksp) -! locates a species record, exact match needed -! for parameters, V must not be accepted as abbreviation of VA or C for CR - implicit none - integer loksp - character name*(*) -!\end{verbatim} %+ - character symbol*24 - symbol=name - call capson(symbol) - do loksp=1,noofsp -! write(*,17)'find species 17: ',loksp,splista(loksp)%symbol,name -!17 format(a,i3,' "',a,'" "',a,'"') - if(symbol.eq.splista(loksp)%symbol) goto 1000 - enddo -! write(*,*)'in find_species_record' - gx%bmperr=4051 - loksp=0 -1000 continue - return - end subroutine find_species_record_exact - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine find_phasetuple_by_name(name,phcsx) -! finds a phase with name "name", returns phase tuple index -! handles composition sets either with prefix/suffix or #digit -! When no pre/suffix nor # always return first composition set - implicit none - character name*(*) - integer phcsx -!\end{verbatim} %+ - integer iph,ics - call find_phasex_by_name(name,phcsx,iph,ics) -1000 continue - return - end subroutine find_phasetuple_by_name - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine find_phase_by_name(name,iph,ics) -! finds a phase with name "name", returns address of phase, first fit accepted -! handles composition sets either with prefix/suffix or #digit -! When no pre/suffix nor # always return first composition set - implicit none - character name*(*) - integer iph,ics -!\end{verbatim} %+ - integer phcsx - call find_phasex_by_name(name,phcsx,iph,ics) -1000 continue - return - end subroutine find_phase_by_name - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine find_phasex_by_name(name,phcsx,iph,ics) -! finds a phase with name "name", returns address of phase, first fit accepted -! handles composition sets either with prefix/suffix or #digit -! When no pre/suffix nor # always return first composition set - implicit none - character name*(*) - integer phcsx,iph,ics -!\end{verbatim} %+ - character name1*36,csname*36,name2*24 - TYPE(gtp_phase_varres), pointer :: csrec - integer kp,kcs,lokph,jcs,lokcs -! convert to upper case locally - name1=name - call capson(name1) -! write(*,*)'find phase: ',name1 -! composition set as #digit - kp=index(name1,'#') - if(kp.gt.0) then - ics=ichar(name1(kp+1:kp+1))-ichar('0') -! negative ics should give error, 0 should be the same as 1 - if(ics.eq.0) ics=1 - if(ics.lt.1 .or. ics.gt.9) then - gx%bmperr=4093; goto 1000 - endif - name1(kp:)=' ' - kcs=ics - else - ics=1 - kcs=0 - endif -! write(*,17)ics,kcs -!17 format('find_phase 3: ',2i4) - loop1: do lokph=1,noofph - name2=phlista(lokph)%name -! write(*,*)'find_phase 2: ',name1,name2 - if(compare_abbrev(name1,name2)) then - if(ics.le.phlista(lokph)%noofcs) then - goto 300 - else -! write(*,18)ics,phlista(lokph)%noofcs -!18 format('find_phase 4: ',2i4) - gx%bmperr=4072; goto 1000 - endif - endif -! if there are composition sets check name including prefix/suffix -! write(*,*)'find_phase 5: ',lokph,phlista(lokph)%noofcs - csno: do jcs=2,phlista(lokph)%noofcs - lokcs=phlista(lokph)%linktocs(jcs) -! write(*,*)'25A: find phase: ',jcs,lokcs,phlista(lokph)%noofcs - csrec=>firsteq%phase_varres(lokcs) - kp=len_trim(csrec%prefix) - if(kp.gt.0) then - csname=csrec%prefix(1:kp)//'_'//name2 - else - csname=name2 - endif -! write(*,*)'find phase: ',kp - kp=len_trim(csrec%suffix) - if(kp.gt.0) csname=csname(1:len_trim(csname))//'_'//& - csrec%suffix(1:kp) -! write(*,244)ics,kcs,jcs,kp,name1(1:len_trim(name1)),& -! csname(1:len_trim(csname)) -244 format('25A: find_phase: ',4i3,'<',a,'>=?=<',a,'>') - if(compare_abbrev(name1,csname)) then -! if user has provided both # and pre/suffix these must be consistent - if(kcs.gt.0 .and. kcs.ne.jcs) then -! automatically created composition sets all have the suffix _AUTO but -! can have several numbers -! write(*,*)'25A: mix? ',jcs,phlista(lokph)%noofcs - if(jcs.eq.phlista(lokph)%noofcs) goto 1100 - cycle csno - endif - ics=jcs - goto 300 - endif - enddo csno - enddo loop1 -! no phase found - gx%bmperr=4050 - goto 1000 -300 continue - iph=phlista(lokph)%alphaindex - phcsx=firsteq%phase_varres(phlista(lokph)%linktocs(ics))%phtupx - gx%bmperr=0 -1000 continue - return -1100 continue - gx%bmperr=4073 - goto 1000 - END subroutine find_phasex_by_name - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine find_phase_by_name_exact(name,iph,ics) -! finds a phase with name "name", returns address of phase. exact match req. -! handles composition sets either with prefix/suffix or #digit -! no pre/suffix nor # gives first composition set - implicit none - character name*(*) - integer iph,ics -!\end{verbatim} - character name1*36,csname*36,name2*24 - TYPE(gtp_phase_varres), pointer :: csrec - integer kp,kcs,iphfound,lokph,jcs,lokcs -! convert to upper case locally - name1=name - call capson(name1) -! composition set as #digit - kp=index(name1,'#') - if(kp.gt.0) then - ics=ichar(name1(kp+1:kp+1))-ichar('0') -! negative ics should give error, 0 should be the same as 1 - if(ics.eq.0) ics=1 - if(ics.lt.1 .or. ics.gt.9) then - gx%bmperr=4093; goto 1000 - endif - name1(kp:)=' ' - kcs=ics - else - ics=1 - kcs=0 - endif -! write(*,17)ics,kcs -17 format('find_phase 3: ',2i4) -! write(*,11)'fpbne 1: ',name,noofph -11 format(a,a,'; ',2i3) - iphfound=0 - loop1: do lokph=1,noofph - name2=phlista(lokph)%name -! write(*,*)'find_phase 2: ',name1,name2 - if(compare_abbrev(name1,name2)) then - if(ics.le.phlista(lokph)%noofcs) then -! possible phase, if iphfound>0 exact match is required - if(iphfound.ne.0) then - if(name1.eq.name2) then - iphfound=lokph - goto 300 - else - iphfound=-lokph - endif - else - iphfound=lokph - endif - else -! write(*,18)ics,phlista(lokph)%noofcs -18 format('find_phase 4: ',2i4) - gx%bmperr=4072; goto 1000 - endif - endif - enddo loop1 -! write(*,*)'find_phase ',iphfound - if(iphfound.lt.0) then -! several phases found - gx%bmperr=4121; goto 1000 - elseif(iphfound.le.0) then -! no phase found - gx%bmperr=4050; goto 1000 - else - lokph=iphfound - goto 300 - endif -! if there are composition sets check name including prefix/suffix - write(*,*)'find_phase 5: ',lokph,phlista(lokph)%noofcs - do jcs=2,phlista(lokph)%noofcs - lokcs=phlista(lokph)%linktocs(jcs) - csrec=>firsteq%phase_varres(lokcs) - kp=len_trim(csrec%prefix) - if(kp.gt.0) then - csname=csrec%prefix(1:kp)//'_'//name2 - else - csname=name2 - endif - kp=len_trim(csrec%suffix) - if(kp.gt.0) csname=csname(1:len_trim(csname))//'_'//& - csrec%suffix(1:kp) - if(compare_abbrev(name1,csname)) then -! if user has provided both # and pre/suffix these must be consistent - if(kcs.gt.0 .and. kcs.ne.jcs) goto 1100 - ics=jcs - goto 300 - endif - enddo -250 continue -! no phase with this name - gx%bmperr=4050 - goto 1000 -300 continue - iph=phlista(lokph)%alphaindex - gx%bmperr=0 -1000 continue - return -1100 continue - gx%bmperr=4073 - goto 1000 - END subroutine find_phase_by_name_exact - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine find_constituent(iph,spname,mass,icon) -! find the constituent "spname" of a phase. spname can have a sublattice #digit -! Return the index of the constituent in icon. Additionally the mass -! of the species is returned. - implicit none - character*(*) spname - double precision mass - integer iph,icon -!\end{verbatim} - character spname1*24 - integer lokph,kp,ll,kk,loksp,ls - lokph=phases(iph) - kp=index(spname,'#') - if(kp.gt.0) then - ls=ichar(spname(kp+1:kp+1))-ichar('0') - spname1=spname(1:kp-1) - else - ls=0 - spname1=spname - endif - call capson(spname1) - icon=0 - lloop: do ll=1,phlista(lokph)%noofsubl - sploop: do kk=1,phlista(lokph)%nooffr(ll) - icon=icon+1 - if(ls.eq.0 .or. ls.eq.ll) then - loksp=phlista(lokph)%constitlist(icon) -! constituent icon is the requested one -! write(*,55)ll,kk,icon,spname1(1:3),splista(loksp)%symbol(1:3) -!55 format('find_const 7: ',3i3,1x,a,2x,a) - if(compare_abbrev(spname1,splista(loksp)%symbol)) then - mass=splista(loksp)%mass - goto 1000 - endif - endif - enddo sploop - enddo lloop - gx%bmperr=4096 -1000 continue - return - end subroutine find_constituent - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine findeq(name,ieq) -! finds the equilibrium with name "name" and returns its index -! ieq should be the current equilibrium - implicit none - character name*(*) - integer ieq -!\end{verbatim} %+ - character name2*64 - integer jeq - name2=name - call capson(name2) -! Accept abbreviations of PREVIOUS and FIRST (DEFAULT is the same as the first) -! write(*,*)'25A equil: ',name2(1:20),ieq - if(compare_abbrev(name2,'PREVIOUS ')) then - jeq=max(1,ieq-1); goto 200 - elseif(compare_abbrev(name2,'FIRST ')) then - jeq=1; goto 200 - endif - jeq=0 -100 jeq=jeq+1 -! write(*,*)'findeq 2: ',jeq,name2 - if(jeq.ge.eqfree) then - gx%bmperr=4124 - goto 1000 - endif -! write(*,*)'findeq 3: ',jeq,eqlista(jeq)%eqname - if(.not.compare_abbrev(name2,eqlista(jeq)%eqname)) goto 100 -! if(eqlista(jeq)%eqname.ne.name2) goto 100 -200 continue - ieq=jeq -1000 continue - end subroutine findeq - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} %- - subroutine selecteq(ieq,ceq) -! checks if equilibrium ieq exists and if so set it as current - implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq - integer ieq -!\end{verbatim} - if(ieq.lt.0 .or. ieq.ge.eqfree) then - gx%bmperr=4124 - goto 1000 - endif - ceq=>eqlista(ieq) -1000 continue - end subroutine selecteq - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ -!> 4. Get things -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine get_phase_record(iph,lokph) -! given phase index iph this returns the phase location lokph - implicit none - integer iph,lokph -!\end{verbatim} %+ - if(iph.lt.1 .or. iph.gt.noofph) then -! write(*,*)'gpr: ',iph,noofph - gx%bmperr=4050 - else - lokph=phases(iph) - endif - return - end subroutine get_phase_record - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine get_phase_variance(iph,nv) -! returns the number of independent variable fractions in phase iph - implicit none - integer iph,nv -!\end{verbatim} %+ - integer lokph - call get_phase_record(iph,lokph) - nv=phlista(lokph)%tnooffr-phlista(lokph)%noofsubl - return - end subroutine get_phase_variance - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine get_constituent_location(lokph,cno,loksp) -! returns the location of the species record of a constituent -! requred for ionic liquids as phlista is private - implicit none - integer lokph,loksp,cno -!\end{verbatim} %+ - loksp=phlista(lokph)%constitlist(cno) - return - end subroutine get_constituent_location - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine get_phase_compset(iph,ics,lokph,lokcs) -! Given iph and ics the phase and composition set locations are returned -! Checks that ics and ics are not outside bounds. - implicit none - integer iph,ics,lokph,lokcs -!\end{verbatim} %+ - if(iph.le.0 .or. iph.gt.noofph) then - gx%bmperr=4050; goto 1000 - endif - lokph=phases(iph) -! find composition set - if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then - gx%bmperr=4072; goto 1000 - elseif(ics.eq.0) then - ics=1 - endif - lokcs=phlista(lokph)%linktocs(ics) -1000 continue - return - end subroutine get_phase_compset - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine get_constituent_name(iph,iseq,spname,mass) -! find the constituent with sequential index iseq in phase iph -! return name in "spname" and mass in mass - implicit none - character*(*) spname - integer iph,iseq - double precision mass -!\end{verbatim} - integer lokph,loksp - if(iph.gt.0 .and. iph.le.noofph) then - lokph=phases(iph) - else - gx%bmperr=4050 - goto 1000 - endif - if(iseq.gt.0 .and. iseq.le.phlista(lokph)%tnooffr) then - loksp=phlista(lokph)%constitlist(iseq) - spname=splista(loksp)%symbol - mass=splista(loksp)%mass - else - write(*,*)'No such constituent' - gx%bmperr=7777 - endif -1000 continue - return - end subroutine get_constituent_name - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine get_phase_constituent_name(iph,icon,name) -! return the name of constituent icon of phase iph -! redundant? - implicit none - character*(*) name - integer iph,icon -!\end{verbatim} - integer lokph - if(iph.le.0 .or. iph.gt.noofph) then - gx%bmperr=4050; goto 1000 - endif - lokph=phases(iph) - if(icon.le.0 .or. icon.gt.phlista(lokph)%tnooffr) then - gx%bmperr=4096; goto 1000 - endif -! loksp=phlista(lokph)%constitlist(icon) -! name=splista(loksp)%symbol - name=splista(phlista(lokph)%constitlist(icon))%symbol -1000 continue - return - end subroutine get_phase_constituent_name - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine get_element_data(iel,elsym,elname,refstat,mass,h298,s298) -! return element data as that is stored as private in GTP - implicit none - character elsym*2, elname*(*),refstat*(*) - double precision mass,h298,s298 - integer iel -!\end{verbatim} - integer lokel - if(iel.le.noofel) then - lokel=elements(iel) - elsym=ellista(lokel)%symbol - elname=ellista(lokel)%name - refstat=ellista(lokel)%ref_state - mass=ellista(lokel)%mass - h298=ellista(lokel)%h298_h0 - s298=ellista(lokel)%s298 - else - gx%bmperr=4042 - endif - end subroutine get_element_data - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine get_component_name(icomp,name,ceq) -! return the name of component icomp - implicit none - character*(*) name - integer icomp - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} %+ - if(icomp.gt.noofel) then - gx%bmperr=4052 - else - name=splista(ceq%complist(icomp)%splink)%symbol - if(buperr.ne.0) then - write(*,*)'gcn buperr: ',buperr - gx%bmperr=buperr - endif - endif -1000 continue - return - end subroutine get_component_name - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine get_species_name(isp,spsym) -! return species name, isp is species number - implicit none - character spsym*(*) - integer isp -!\end{verbatim} - if(isp.le.0 .or. isp.gt.noofsp) then -! write(*,*)'in get_species_name' - gx%bmperr=4051; goto 1000 - endif -! loksp=species(isp) -! spsym=splista(loksp)%symbol - spsym=splista(species(isp))%symbol -1000 return - end subroutine get_species_name - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine get_species_data(loksp,nspel,ielno,stoi,smass,qsp) -! return species data, loksp is from a call to find_species_record -! nspel: integer, number of elements in species -! ielno: integer array, element indices -! stoi: double array, stocichiometric factors -! smass: double, mass of species -! qsp: double, charge of the species - implicit none - integer, dimension(*) :: ielno - double precision, dimension(*) :: stoi(*) - integer loksp,nspel - double precision smass,qsp -!\end{verbatim} - integer jl,iel - if(loksp.le.0 .or. loksp.gt.noofsp) then -! write(*,*)'in get_species_data' - gx%bmperr=4051; goto 1000 - endif - nspel=splista(loksp)%noofel - elements: do jl=1,nspel - iel=splista(loksp)%ellinks(jl) - ielno(jl)=ellista(iel)%alphaindex - stoi(jl)=splista(loksp)%stoichiometry(jl) - enddo elements - smass=splista(loksp)%mass - qsp=splista(loksp)%charge -1000 return - end subroutine get_species_data - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - double precision function mass_of(component,ceq) -! return mass of component -! smass: double, mass of species - implicit none - integer :: component - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - if(component.le.0 .or. component.gt.noofel) then - write(*,*)'Calling mass_of with illegal component number: ',component - gx%bmperr=7777; goto 1000 - endif -! return in kg - mass_of=ceq%complist(component)%mass -1000 return - end function mass_of - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine phase_name(phtuple,name) -! Given the phase tuple this subroutine returns the name with pre- and suffix -! for composition sets added and also a \# followed by a digit 2-9 for -! composition sets higher than 1. - implicit none - character name*(*) - type(gtp_phasetuple) :: phtuple -!\end{verbatim} %+ - call get_phase_name(phtuple%phase,phtuple%compset,name) -1000 continue - return - end subroutine phase_name - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine get_phase_name(iph,ics,name) -! Given the phase index and composition set number this subroutine returns -! the name with pre- and suffix for composition sets added and also -! a \# followed by a digit 2-9 for composition sets higher than 1. - implicit none - character name*(*) - integer iph,ics -!\end{verbatim} - character phname*36 - integer lokph,lokcs,kp - call get_phase_compset(iph,ics,lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 - if(ics.eq.1) then - name=phlista(lokph)%name - else - kp=len_trim(firsteq%phase_varres(lokcs)%prefix) - if(kp.gt.0) then - phname=firsteq%phase_varres(lokcs)%prefix(1:kp)//'_'//& - phlista(lokph)%name - else - phname=phlista(lokph)%name - endif - kp=len_trim(firsteq%phase_varres(lokcs)%suffix) - if(kp.gt.0) then - phname(len_trim(phname)+1:)='_'//firsteq%phase_varres(lokcs)%suffix - endif - phname(len_trim(phname)+1:)='#'//char(ics+ichar('0')) - name=phname - endif -1000 continue - return - end subroutine get_phase_name - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine get_phase_data(iph,ics,nsl,nkl,knr,yarr,sites,qq,ceq) -! return the structure of phase iph and constituntion of comp.set ics -! nsl: integer, number of sublattices -! nkl: integer array, number of constituents in each sublattice -! knr: integer array, species location (not index) of constituents (all subl) -! yarr: double array, fraction of constituents (in all sublattices) -! sites: double array, number of sites in each sublattice -! qq: double array, (must be dimensioned at least 5) although only 2 used: -! qq(1) is number of real atoms per formula unit for current constitution -! qq(2) is net charge of phase for current constitution -! ceq: pointer, to current gtp_equilibrium_data record - implicit none - integer, dimension(*) :: nkl,knr - double precision, dimension(*) :: yarr,sites,qq - integer iph,ics,nsl - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer lokph,lokcs,kkk,ll,jj,loksp - double precision vsum,qsum,ql,vl,yz -! - if(iph.lt.1 .or. iph.gt.noofph) then - gx%bmperr=4050; goto 1000 - else - lokph=phases(iph) - endif - nsl=phlista(lokph)%noofsubl - if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then - gx%bmperr=4072; goto 1000 - elseif(ics.eq.0) then - ics=1 - endif - lokcs=phlista(lokph)%linktocs(ics) -! lokcs=phlista(lokph)%cslink -! jcs=ics-1 -! do while(jcs.gt.0) -! lokcs=ceq%phase_varres(lokcs)%next -! if(lokcs.le.0) then -! write(*,*)'get_phase_data error 4072' -! gx%bmperr=4072; goto 1000 -! endif -! jcs=jcs-1 -! enddo -! >>>>> get_phase_data missing: for ionic liquid sites vary with composition - vsum=zero - qsum=zero - kkk=0 - if(.not.btest(ceq%phase_varres(lokcs)%status2,CSCONSUS)) then - sublat: do ll=1,nsl - nkl(ll)=phlista(lokph)%nooffr(ll) -! For ionic liquid one must use this but at present values are not set - sites(ll)=ceq%phase_varres(lokcs)%sites(ll) -! sites(ll)=phlista(lokph)%sites(ll) -! write(*,*)'get_phase_data 7:',lokcs,ll,sites(ll) - ql=zero - vl=zero - const: do jj=1,nkl(ll) - kkk=kkk+1 - loksp=phlista(lokph)%constitlist(kkk) - knr(kkk)=loksp - yz=ceq%phase_varres(lokcs)%yfr(kkk) - yarr(kkk)=yz - if(loksp.gt.0) then -! loksp is -99 for wildcards. ionic liquid can have that in first sublattice - ql=ql+yz*splista(loksp)%charge - if(btest(splista(loksp)%status,SPVA)) then - vl=yz - endif - endif - enddo const - vsum=vsum+sites(ll)*(one-vl) - qsum=qsum+sites(ll)*ql - enddo sublat - qq(1)=vsum - qq(2)=qsum -! write(*,*)'get_phase_data: ',qq(1),qq(2) - else -! >>>> unfinished handle the case with suspended constituents -! write(*,*)'get_phase_data with suspended constituents not implemented' - gx%bmperr=4080; goto 1000 - endif -! -1000 continue - return - end subroutine get_phase_data - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - integer function get_phtuplearray(phcs) -! copies the internal phase tuple array to external software -! function value set to number of tuples - type(gtp_phasetuple), dimension(*) :: phcs -!\end{verbatim} - integer iz - do iz=1,nooftuples - phcs(iz)=phasetuple(iz) - enddo -1000 continue - get_phtuplearray=nooftuples - return - end function get_phtuplearray - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ -!> 5. Set things -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ -! -!-\begin{verbatim} -! subroutine set_mean_constitution(iph,ics,ceq) -! sets a start constitution 1/ns in all sublattices where ns is the number -! of constituents in the sublattice. -! implicit none -! integer iph,ics -! TYPE(gtp_equilibrium_data), pointer :: ceq -!-\end{verbatim} -! integer, dimension(maxsubl) :: knl -! double precision, dimension(maxsubl) :: sites -! integer, dimension(maxconst) :: knr -! double precision, dimension(maxconst) :: yarr -! double precision, dimension(5) :: qq -! double precision df -! integer nsl,kkk,ll,jl -! call get_phase_data(iph,ics,nsl,knl,knr,yarr,sites,qq,ceq) -! if(gx%bmperr.ne.0) goto 1000 -! kkk=0 -! do ll=1,nsl -! if(knl(ll).gt.1) then -! df=one/dble(knl(ll)) -! do jl=1,knl(ll) -! kkk=kkk+1 -! yarr(kkk)=df -! enddo -! endif -! enddo -! write(*,17)iph,ics,(yarr(j),j=1,kkk) -!17 format('Default cons: ',2i3,5(1pe12.4)) -! call set_constitution(iph,ics,yarr,qq,ceq) -!1000 continue -! return -! end subroutine set_mean_constitution -! -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine set_constitution(iph,ics,yfra,qq,ceq) -! set the constituent fractions of a phase and composition set and the -! number of real moles and mass per formula unit of phase -! returns number of real atoms in qq(1), charge in qq(2) and mass in qq(3) -! for ionic liquids sets the number of sites in the sublattices - implicit none - double precision, dimension(*) :: yfra,qq - integer iph,ics - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer lokph,lokcs,ll,ml,ic,loksp,jl,locva - double precision charge,spat,asite,bsite,badd,yz,yva,sumat,asum,bsum -! double precision charge1,bion1,ionsites(2) - double precision charge1,bion1 -! TYPE(gtp_fraction_set), pointer :: disrec - logical ionicliq -! write(*,*)'In set_constitution ...' - if(iph.le.0 .or. iph.gt.noofph) then - gx%bmperr=4050; goto 1000 - endif - lokph=phases(iph) - if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then - gx%bmperr=4072; goto 1000 - elseif(ics.eq.0) then - ics=1 - endif - lokcs=phlista(lokph)%linktocs(ics) - ionicliq=btest(phlista(lokph)%status1,PHIONLIQ) - if(ionicliq) then -! default values of i2slx - phlista(lokph)%i2slx(1)=phlista(lokph)%tnooffr+1 - phlista(lokph)%i2slx(2)=phlista(lokph)%tnooffr+1 - yva=zero - locva=0 - endif -!---- - if(ocv()) write(*,8)'25Ay:',iph,ics,& - (yfra(ic),ic=1,phlista(lokph)%tnooffr) -8 format(a,2i2,6(1pe11.3)) - nosuscon: if(btest(ceq%phase_varres(lokcs)%status2,CSCONSUS)) then -! >>>> unfinished: handle the case when some constituents are suspended -! write(*,*)'set_constitution with suspended constituents not implemented' - write(*,*)'suspended const in: ',lokph,lokcs - gx%bmperr=4080; goto 1000 - else -! no suspended constituents -! As the application program may have errors first make sure than -! the constituents fractions are correct: -! - no negative fractions -! - sum of fractions in each sublattice unity -! if(ocv()) write(*,*)'25A 2: ',ionicliq - ic=0 - do ll=1,phlista(lokph)%noofsubl -! write(*,*)'25A sumy 2: ',ll,ic,phlista(lokph)%noofsubl - asite=zero - do ml=1,phlista(lokph)%nooffr(ll) - yz=yfra(ic+ml) - if(yz.lt.bmpymin) yz=bmpymin - ceq%phase_varres(lokcs)%yfr(ic+ml)=yz - asite=asite+yz - enddo -! make sure sum of fractions is unity in each sublattice - do ml=1,phlista(lokph)%nooffr(ll) - ceq%phase_varres(lokcs)%yfr(ic+ml)=& - ceq%phase_varres(lokcs)%yfr(ic+ml)/asite - enddo -! write(*,13)'25A y: ',ll,ic,asite,bmpymin,& -! (ceq%phase_varres(lokcs)%yfr(ic+ml),& -! ml=1,phlista(lokph)%nooffr(ll)) -13 format(a,2i2,2(1pe12.4),1x,4(1pe12.4)) - ic=ic+phlista(lokph)%nooffr(ll) - enddo -!-------- - ll=1; ml=0; asum=zero; bsum=zero; charge=zero - if(ionicliq) then -! For ionic liquid we do not know the number of sites - asite=one - bion1=zero - else - asite=ceq%phase_varres(lokcs)%sites(ll) - endif -! what is bsite used for??? - bsite=asite; badd=zero - spat=zero - allcon: do ic=1,phlista(lokph)%tnooffr - yz=ceq%phase_varres(lokcs)%yfr(ic) -! if(ocv()) write(*,*)'25A 3: ',ic,yz - notva: if(btest(ceq%phase_varres(lokcs)%constat(ic),CONVA)) then -! i2slx(1) should be set to the index of vacancies (if any) - if(ionicliq) phlista(lokph)%i2slx(1)=ic - locva=ic - yva=yz - else -! sum charge and for constituents with several atoms spat sum number of atoms - loksp=phlista(lokph)%constitlist(ic) - charge=charge+bsite*yz*splista(loksp)%charge -! derivates of sites for ionic liquid model -! if(ocv()) write(*,*)'25A 4: ',loksp,charge - if(ionicliq) then - ceq%phase_varres(lokcs)%dpqdy(ic)=abs(splista(loksp)%charge) -! if(ocv()) write(*,*)'25A dpqdy: ',& -! ic,abs(splista(loksp)%charge) -! i2slx(2) should be set to the index of the first neutral (if any) - if(splista(loksp)%charge.eq.zero .and.& - phlista(lokph)%i2slx(2).gt.ic) & - phlista(lokph)%i2slx(2)=ic - endif - badd=badd+bsite*yz*splista(loksp)%mass -! write(*,56)'setcon: ',iph,loksp,splista(loksp)%mass,yz,badd -56 format(a,2i3,3(1pe12.4)) - sumat=zero -! This is not adopted for other components than the elements - do jl=1,splista(loksp)%noofel - sumat=sumat+splista(loksp)%stoichiometry(jl) - enddo - spat=spat+yz*sumat -! check sum number of atoms for ionic liquid -! if(sumat.gt.1) then -! write(*,7)'spat: ',lokph,splista(loksp)%noofel,sumat,yz,spat -!7 format(a,2i3,3F10.4) -! endif -! write(*,11)loksp,yz,splista(loksp)%mass,badd,bsum -11 format('set_const 3: ',i3,4(1PE15.7)) - endif notva -! ml is constituent number in this sublattice, ic for all sublattices - ml=ml+1 -! if(ocv()) write(*,*)'25A 5: ',ml - newsubl: if(ml.ge.phlista(lokph)%nooffr(ll)) then -! next sublattice - ionliq: if(ionicliq) then -! for ioniq liquids the number of sites is the charge on opposite sublattice - if(ll.eq.1) then -! Q=\sum_i v_i y_i = charge -! write(*,88)'ionliq: ',ll,badd,bion1 -88 format(a,i3,6(1pe12.4)) - ceq%phase_varres(lokcs)%sites(2)=charge -! write(*,*)'Ionic 2: ',ceq%phase_varres(lokcs)%sites(2) -! bsite=one - charge1=charge - charge=zero -! initiate vacancy and neutral indices beyond last index (already done??) - phlista(lokph)%i2slx=phlista(lokph)%tnooffr+1 - elseif(ll.eq.2) then -! P=\sum_j (-v_j)y_j + Qy_Va. Note charge is total charge and valences -! on 2nd sublattice is negative -! Now we know number of sites on sublattice 1, update asum and bsum - sumat=-charge+charge1*yva - ceq%phase_varres(lokcs)%sites(1)=sumat -! write(*,*)'Ionic 1: ',ceq%phase_varres(lokcs)%sites(1) - asum=asum*sumat - bsum=bion1*sumat - charge=zero -! write(*,88)'ionliq: ',ll,badd,bion1,bsum,sumat,yva - else - write(*,*)'Ionic liquid must have two sublattices' - gx%bmperr=7777; goto 1000 - endif - endif ionliq -! note: for ionic liquid previous values of asum and bsum are updated -! when fractions in sublattice 2 have been set - asum=asum+asite*spat - bsum=bsum+badd -! write(*,33)'25A g:',lokcs,ll,asum,asite,spat -33 format(a,2i2,6(1pe12.4)) -! write(*,39)'set_con: ',ll,ml,asum,asite,spat -!39 format(a,2i5,3(1pe12.4)) -! write(*,12)'set_const 12: ',ll,asum,asite,bsum,badd -!12 format(a,i3,4(1pe12.4)) - if(ll.lt.phlista(lokph)%noofsubl) then - ll=ll+1; ml=0 -! asite=phlista(lokph)%sites(ll); spat=zero - asite=ceq%phase_varres(lokcs)%sites(ll) - spat=zero; bion1=badd; badd=zero -! if ionic liquid bsite must be 1.0 when summing second sublattice. Why??? - if(.not.ionicliq) bsite=asite - endif - endif newsubl - enddo allcon -! write(*,33)'25A h:',lokcs,ll,asum,asite,spat - endif nosuscon -! save charge, number of moles and mass of real atoms per formula unit -! write(*,33)'25A i:',lokcs,0,charge,asum,bsum,asite,spat - ceq%phase_varres(lokcs)%netcharge=charge - ceq%phase_varres(lokcs)%abnorm(1)=asum - ceq%phase_varres(lokcs)%abnorm(2)=bsum - if(ionicliq .and. locva.gt.0) then -! the ionic liquid vacancy charge is the number of sites on second subl. - ceq%phase_varres(lokcs)%dpqdy(locva)=ceq%phase_varres(lokcs)%sites(2) -! if(ocv()) write(*,*)'25A dpqdy(va): ',& -! locva,ceq%phase_varres(lokcs)%sites(2) - endif -! if(ionicliq) then -! write(*,301)'25A xsc:',lokcs,asum,bsum,ceq%phase_varres(lokcs)%sites,& -! charge1 -!301 format(a,i3,6(1pe12.4)) -! write(*,301)'25A y: ',ic,ceq%phase_varres(lokcs)%yfr -! endif - qq(1)=asum - qq(2)=charge - qq(3)=bsum -! set disordered fractions if any - if(btest(phlista(lokph)%status1,phmfs)) then -!now set disordered fractions if any - call calc_disfrac(lokph,lokcs,ceq) - if(gx%bmperr.ne.0) goto 1000 - endif -314 format(a,8F8.3) -1000 continue -! if(ionicliq) write(*,*)'25A s_c: ',phlista(lokph)%i2slx - return - end subroutine set_constitution - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - +! +! gtp3A.F90 included in gtp3.F90 +! +!**************************************************** +! general subroutines for creating and handling elements, species, phases etc +! accessable externally + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ +!> 1. Initialization +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine init_gtp(intvar,dblvar) +! initiate the data structure +! create element and species record for electrons and vacancies +! the allocation of many arrays should be provided calling this routne +! intvar and dblvar will eventually be used for allocations and defaults + implicit none + integer intvar(*) + double precision dblvar(*) +!\end{verbatim} + character tpname*16,tpfun*80 + integer jl,ieq,ip,lrot,npid +! + noofel=0; noofsp=0; noofph=0; nooftuples=0 +! write(*,3)'In init_gtp',maxel,maxsp,maxph +3 format(a,10i5) +! allocate records for elements + allocate(ellista(-1:maxel)) + allocate(elements(-1:maxel)) +! allocate records for species + allocate(splista(maxsp)) + allocate(species(maxsp)) +! allocate records for phases + allocate(phlista(0:maxph)) + allocate(phases(0:maxph)) + allocate(phasetuple(0:2*maxph)) +! phases(0) is refrence phase, evidently this index is never set + phases(0)=0 +!--------------------------- +! create special element /- + ellista(-1)%symbol='/-' + ellista(-1)%name='Electron' + ellista(-1)%ref_state='Electron_gas' + ellista(-1)%mass=zero + ellista(-1)%h298_h0=zero + ellista(-1)%s298=zero + ellista(-1)%status=0 + ellista(-1)%alphaindex=-1 +! The electron does not have any corresponing species + ellista(-1)%splink=-1 + elements(-1)=-1 +! create special elements VA + ellista(0)%symbol='VA' + ellista(0)%name='Vacancy' + ellista(0)%ref_state='Vaccum' + ellista(0)%mass=zero + ellista(0)%h298_h0=zero + ellista(0)%s298=0.0D0 + ellista(0)%status=0 + ellista(0)%alphaindex=0 +! splink set below +! ellista(0)%splink=0 +! allocate element link array + allocate(splista(1)%ellinks(1)) + allocate(splista(1)%stoichiometry(1)) + splista(1)%symbol='VA' + splista(1)%mass=zero + splista(1)%charge=zero + splista(1)%status=0 +! set status bits that is is also an element and it is the vacancy + splista(1)%status=ibset(splista(1)%status,SPEL) + splista(1)%status=ibset(splista(1)%status,SPVA) + splista(1)%alphaindex=1 + splista(1)%noofel=1 + splista(1)%ellinks(1)=0 + splista(1)%stoichiometry(1)=one + elements(0)=0 + noofsp=1 + species(1)=1 +! link from element Va to species Va + ellista(0)%splink=1 +! write(*,3)'more allocate: ',maxrefs,maxprop,maxeq,maxtpf,maxsvfun + allocate(bibrefs(maxrefs)) + allocate(propid(maxprop)) +! first free data reference record (static) + reffree=1 + addrecs=0 +!--------------------------------------- + noofem=0 + noofint=0 + noofprop=0 +!---------------------------------------- +! initiate equilibrium record list +! dimension arrays for in first equilibrium record including phase_varres + allocate(eqlista(maxeq)) + do jl=1,maxeq-1 + eqlista(jl)%next=jl+1 + enddo + eqlista(maxeq)%next=-1 + eqfree=1 +! create first equilibrium record incl complist + call enter_equilibrium('DEFAULT_EQUILIBRIUM ',ieq) + if(gx%bmperr.ne.0) then + write(*,*)' error in first enter_equilibrium',gx%bmperr + goto 1000 + endif + firsteq=>eqlista(1) +! nullify some pointers because of error entering first + nullify(firsteq%lastcondition,firsteq%lastexperiment) +! set phase_varres free list in firsteq. These are always allocated together + do jl=1,2*maxph-1 + firsteq%phase_varres(jl)%nextfree=jl+1 + enddo +! NOTE last phase_varres record used for copy in shiftcompsets + firsteq%phase_varres(2*maxph)%nextfree=-1 +! csfree is not declared ... how can that be?? where is it declared ?? + csfree=1 +! convergence criteria for constituent fractions, 1e-6 works most often +! But one should take care to equilibrate fractions smaller than xconv!!! + firsteq%xconv=1.0D-6 + firsteq%maxiter=500 +! initiate tp functions +! write(*,*)'init_gtp: initiate TP fuctions' + jl=maxtpf + call tpfun_init(jl,firsteq%eq_tpres) +!------------------------------------ +! Property records define what can be used as "id" for parameters, the first +! must be G for the "chemical" part. The others are connected to various +! additions or are simply properties that may depend on composition and is +! needed in other contexts, like mobilities, viscosities etc. +! create property id records for G + npid=1 + propid(npid)%symbol='G ' + propid(npid)%note='Energy ' + propid(npid)%status=0 +!============================================================ +! VERY IMPORTANT: The properties defined below must not be equal to state +! variables, if so they cannot be listed and other errors may occur +! +! ANY CHANGES HERE MUST BE MADE ALSO IN SUBROUTINE state_variable_val, pmod25c +! +!============================================================ +! Mixed Curie/Neel Temperature, set bits that TC and BM cannot depend on T 2 + npid=npid+1 + propid(npid)%symbol='TC ' + propid(npid)%note='Comb Curie/Neel T' + propid(npid)%status=0 +! TC cannot depend on T but on P + propid(npid)%status=ibset(propid(npid)%status,IDONLYP) +!....................................... +! Average Bohr magneton number 3 + npid=npid+1 + propid(npid)%symbol='BMAG ' + propid(npid)%note='Aver Bohr magn no' + propid(npid)%status=0 +! BM cannot depend on either T or P ?? + propid(npid)%status=ibset(propid(npid)%status,IDNOTP) +!....................................... +! Specific Curie temperature 4 + npid=npid+1 + propid(npid)%symbol='CTA ' + propid(npid)%note='Curie temperature' + propid(npid)%status=0 +! CTA cannot depend on either T or P ?? + propid(npid)%status=ibset(propid(npid)%status,IDONLYP) +!....................................... +! Specific Neel temperature 5 + npid=npid+1 + propid(npid)%symbol='NTA ' + propid(npid)%note='Neel temperature' + propid(npid)%status=0 +! NTA cannot depend on T but on P + propid(npid)%status=ibset(propid(npid)%status,IDONLYP) +!....................................... +! Individual Bohr magneton number 6 + npid=npid+1 + propid(npid)%symbol='IBM ' + propid(npid)%note='Ind. Bohr magn no' + propid(npid)%status=0 +! IBM cannot depend on either T or P and it is individual + propid(npid)%status=ibset(propid(npid)%status,IDCONSUFFIX) + propid(npid)%status=ibset(propid(npid)%status,IDONLYP) +!....................................... +! Debye or Einstein temperature 7 + npid=npid+1 + propid(npid)%symbol='THETA ' + propid(npid)%note='Debye or Einst temp' + propid(npid)%status=0 +! THETA cannot depend on T but on P + propid(npid)%status=ibset(propid(npid)%status,IDONLYP) +!....................................... +! logarithm of individual mobility 8 + npid=npid+1 + propid(npid)%symbol='MQ ' + propid(npid)%note='LN mob. of const.' + propid(npid)%status=0 +! MQ is specific för a constituent + propid(npid)%status=ibset(propid(npid)%status,IDCONSUFFIX) +!....................................... +! Electrical resistivity 9 + npid=npid+1 + propid(npid)%symbol='RHO ' + propid(npid)%note='Elect resistivity' + propid(npid)%status=0 +!....................................... +! Magnetic suseptibility 10 + npid=npid+1 + propid(npid)%symbol='MSUS ' + propid(npid)%note='Magn suseptibility' + propid(npid)%status=0 +!....................................... +! Glas trasition temperature 11 + npid=npid+1 + propid(npid)%symbol='GTT ' + propid(npid)%note='Glas trans temperature' + propid(npid)%status=0 +! Cannot depend on temperature + propid(npid)%status=ibset(propid(npid)%status,IDONLYP) +!....................................... +! Viscosity 12 + npid=npid+1 + propid(npid)%symbol='VISCA ' + propid(npid)%note='Viscosity' + propid(npid)%status=0 +!....................................... +! Lattice parameter in direction X 13 + npid=npid+1 + propid(npid)%symbol='LPX ' + propid(npid)%note='Lat par X axis' + propid(npid)%status=0 +! lattice parameters may depend on T and P +!....................................... +! Lattice parameter in direction Y 14 + npid=npid+1 + propid(npid)%symbol='LPY ' + propid(npid)%note='Lat par Y axis' + propid(npid)%status=0 +! lattice parameters may depend on T and P +!....................................... +! Lattice parameter in direction Z 15 + npid=npid+1 + propid(npid)%symbol='LPZ ' + propid(npid)%note='Lat par Z axis' + propid(npid)%status=0 +! lattice parameters may depend on T and P +!....................................... +! This is an angle for non-cubic lattices 16 + npid=npid+1 + propid(npid)%symbol='LPTH ' + propid(npid)%note='Lat angle TH' + propid(npid)%status=0 +! Angle may depend on T and P +!....................................... +! This is an elastic "constant" 17 + npid=npid+1 + propid(npid)%symbol='EC11 ' + propid(npid)%note='Elast const C11' + propid(npid)%status=0 +! The elastic constant may depend on T and P +!....................................... +! This is another elastic "constant" 18 + npid=npid+1 + propid(npid)%symbol='EC12 ' + propid(npid)%note='Elast const C12' + propid(npid)%status=0 +! The elastic constant may depend on T and P +!....................................... +! This is yet another elastic "constant" 19 + npid=npid+1 + if(npid.gt.maxprop) then + write(*,*)'Too many parameter identifiers, increase maxprop' + gx%bmperr=7777; goto 1000 + endif + propid(npid)%symbol='EC44 ' + propid(npid)%note='Elast const C44' + propid(npid)%status=0 +! The elastic constant may depend on T and P +!....................................... +! IMPORTRANT: When adding more parameter identifiers one should never +! use a name ending in D as that would be taken as a "disordered" +! The number of defined properties, should be less than maxprop +! IMPORTANT: In the addition records one must use the parameter identifier +! to extract the calculated composition dependent values + ndefprop=npid +!------------------------------------------------- + highcs=0 +! globaldata record; set gas constant mm + globaldata%status=0 +! set beginner, no data, no phase, no equilibrium calculated + globaldata%status=ibset(globaldata%status,GSBEG) +! globaldata%status=ibset(globaldata%status,GSADV) + globaldata%status=ibset(globaldata%status,GSNODATA) + globaldata%status=ibset(globaldata%status,GSNOPHASE) + firsteq%status=ibset(firsteq%status,EQNOEQCAL) +! set gas constant and some default values + globaldata%name='current' + globaldata%rgas=8.31451D0 +! more recent value +! globaldata%rgas=8.3144621D0 +! old value of gas constant + globaldata%rgasuser=8.31451D0 + globaldata%pnorm=one +! write(*,*)'init_gtp: enter R and RTLNP' +! enter R as TP function + tpname='R' +! write(tpfun,777)' 10 8.31451; 20000 N ' +!777 format(a) +! call enter_tpfun(tpname,tpfun,lrot,.FALSE.) + call enter_tpconstant(tpname,globaldata%rgas) + if(gx%bmperr.ne.0) goto 1000 + tpname='RTLNP' + tpfun=' 10 R*T*LN(1.0D-5*P); 20000 N ' + call enter_tpfun(tpname,tpfun,lrot,.FALSE.) + if(gx%bmperr.ne.0) goto 1000 +! default minimum fraction + bmpymin=ymind +! putfun error code .... should use buperr at least + pfnerr=0 +!------------------------------------ +! allocate array for state variable function +! write(*,*)'init_gtp: allocate array for state variable functions' + allocate(svflista(maxsvfun)) +! number of state variable function + nsvfun=0 +! zero the array with equilibrium index for functions, not used aywhere?? +! pflocal=0 +! enter some useful state variable function + tpfun=' R=8.31451;' + ip=1 +! write(*,*)'init_gtp: entering function R' + call enter_svfun(tpfun,ip,firsteq) +! if(gx%bmperr.ne.0) then +! write(*,*)'Error entering R',gx%bmperr +! goto 1000 +! endif +! write(*,*)'Entered symbol R' + tpfun=' RT=R*T;' + ip=1 +! write(*,*)'init_gtp: entering function RT' + call enter_svfun(tpfun,ip,firsteq) +! if(gx%bmperr.ne.0) then +! write(*,*)'Error entering symbol RT' +! goto 1000 +! endif +! write(*,*)'Entered symbol RT' + tpfun=' T_C=T-273.15;' + ip=1 +! write(*,*)'init_gtp: entering function T_C' + call enter_svfun(tpfun,ip,firsteq) +! if(gx%bmperr.ne.0) then +! write(*,*)'Error entering symbol T_C' +! goto 1000 +! endif +! we evaluate all symbols to avoid some problems ... no output +! call meq_evaluate_all_svfun(-1,ceq) cannot be used as in minimizer ... + call evaluate_all_svfun_old(-1,firsteq) +! finished initiating +1000 continue +! write(*,*)'exit from init_gtp' + return + END subroutine init_gtp + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ +!> 2. Number of things +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + integer function noel() +! number of elements because noofel is private +! should take care if elements are suspended +!\end{verbatim} %+ + noel=noofel + end function noel + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + integer function nosp() +! number of species because noofsp is private +! should take care if species are suspended +!\end{verbatim} %+ + nosp=noofsp + end function nosp + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + integer function noph() +! number of phases because noofph is private +! should take care if phases are hidden +!\end{verbatim} %+ + noph=noofph + end function noph + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + integer function noofcs(iph) +! returns the number of compositions sets for phase iph + implicit none + integer iph +!\end{verbatim} %+ + if(iph.le.0 .or. iph.gt.noofph) then + gx%bmperr=4050; goto 1000 + endif + noofcs=phlista(phases(iph))%noofcs +1000 continue + return + end function noofcs + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + integer function noconst(iph,ics,ceq) +! number of constituents for iph (include single constituents on a sublattice) +! It tests if a constituent is suspended which can be different in each ics. + implicit none + integer iph,ics + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} %+ + integer lokph,lokcs,noc,jl + if(iph.gt.0 .and. iph.le.noofph) then + lokph=phases(iph) + if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then +! write(*,*)'noconst 1 error 4072' + gx%bmperr=4072; goto 1000 + elseif(ics.eq.0) then + ics=1 + endif + lokcs=phlista(lokph)%linktocs(ics) + if(btest(ceq%phase_varres(lokcs)%status2,CSCONSUS)) then +! some constituents suspended + noc=phlista(lokph)%tnooffr + do jl=1,phlista(lokph)%tnooffr + if(btest(ceq%phase_varres(lokcs)%constat(jl),CONSUS)) then + noc=noc-1 + endif + enddo + noconst=noc + else + noconst=phlista(lokph)%tnooffr + endif + else + gx%bmperr=4050 + endif +1000 continue + return + end function noconst + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + integer function nooftup() +! number of phase tuples +!\end{verbatim} + implicit none + nooftup=nooftuples + return + end function nooftup + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + integer function nosvf() +! number of state variable functions +!\end{verbatim} + implicit none + nosvf=nsvfun + return + end function nosvf + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + integer function noeq() +! returns the number of equilibria entered +!\end{verbatim} + implicit none + noeq=eqfree-1 +1000 continue + return + end function noeq + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + integer function nonsusphcs(ceq) +! returns the total number of unhidden phases+composition sets +! in the system. Used for dimensioning work arrays and in loops + implicit none + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer tphic,iph,ics,lokph + double precision xxx + tphic=0 + do iph=1,noofph + lokph=phases(iph) + ics=1 + if(test_phase_status(iph,ics,xxx,ceq).ne.PHHIDDEN) then +! phase is not hidden + do ics=1,phlista(lokph)%noofcs +! if(test_phase_status(iph,ics,xxx,ceq).eq.4) goto 400 + if(test_phase_status(iph,ics,xxx,ceq).ne.PHSUS) then + tphic=tphic+1 + endif +! composition set not suspended +! tphic=tphic+phlista(lokph)%noofcs + enddo + endif + enddo +1000 continue +! write(*,*)'25 A nonsusphcs: ',tphic + nonsusphcs=tphic + return + end function nonsusphcs + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ +!> 3. Find things +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine find_element_by_name(name,iel) +! find an element index by its name, exact fit required + implicit none + character name*(*) + integer iel +!\end{verbatim} %+ + integer lokel + character symbol*2 + symbol=name + call capson(symbol) + do lokel=-1,noofel +! write(*,*)'find_element 1: ',lokel,symbol,' ',ellista(lokel)%symbol + if(symbol.eq.ellista(lokel)%symbol) then + iel=ellista(lokel)%alphaindex + goto 1000 + endif + enddo + iel=-100 + gx%bmperr=4042 +1000 continue + return + end subroutine find_element_by_name + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine find_component_by_name(name,icomp,ceq) +! BEWARE: one may in the future have different components in different +! equilibria. components are a subset of the species + implicit none + character*(*) name + integer icomp + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} %+ + integer loksp + call find_species_record_noabbr(name,loksp) + if(gx%bmperr.ne.0) then + gx%bmperr=4052; goto 1000 + endif +! check that species actually is component + do icomp=1,noofel + if(ceq%complist(icomp)%splink.eq.loksp) goto 1000 + enddo + gx%bmperr=4052 +1000 continue + return + end subroutine find_component_by_name + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine find_species_by_name(name,isp) +! locates a species index from its name, unique abbreviation +! or exact match needed + implicit none + character name*(*) + integer isp +!\end{verbatim} %+ + character symbol*24 + integer loksp,lensym + logical exact + exact=.FALSE. + symbol=name + call capson(symbol) + isp=0 + do loksp=1,noofsp +! write(*,*)'find species 2: ',loksp,splista(loksp)%symbol + if(compare_abbrev(symbol,splista(loksp)%symbol)) then + if(isp.eq.0) then + isp=splista(loksp)%alphaindex + lensym=len_trim(splista(loksp)%symbol) +! write(*,*)'3A abbr match: ',lensym,' <',symbol(1:lensym),'><',& +! splista(loksp)%symbol(1:lensym+1),'>' + if(symbol(1:lensym+1).eq.splista(loksp)%symbol(1:lensym+1)) then +! write(*,*)'3A exact match with species name' + exact=.TRUE. + goto 1000 + endif + else +! abbreviation is not unique + isp=0 + exit + endif + endif + enddo + if(isp.eq.0) then +! write(*,*)'in find_species_by_name' + gx%bmperr=4051 + loksp=0 + endif +1000 continue + return + end subroutine find_species_by_name + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine find_species_record(name,loksp) +! locates a species record allowing abbreviations + implicit none + character name*(*) + integer loksp +!\end{verbatim} %+ + character symbol*24 + integer isp,lensp + logical exact + exact=.FALSE. + symbol=name + isp=0 + call capson(symbol) + do loksp=1,noofsp +! write(*,17)'3A find species: ',loksp,splista(loksp)%symbol,name +17 format(a,i3,' "',a,'" "',a,'"') + if(compare_abbrev(symbol,splista(loksp)%symbol)) then + if(isp.eq.0) then + isp=loksp +! it would be enough to compare lengths of species ... + lensp=len_trim(splista(loksp)%symbol) + if(symbol(1:lensp+1).eq.splista(loksp)%symbol(1:lensp+1)) then +! write(*,*)'3A exact match' + exact=.TRUE. + goto 1000 + endif + else +! ambiguous species name but we may find an exact later ... + isp=-1 + endif + endif + enddo + if(isp.le.0) then +! write(*,*)'Error in find_species_record "',name,'"' + gx%bmperr=4051 + loksp=0 + else + loksp=isp + endif +1000 continue + return + end subroutine find_species_record + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine find_species_record_noabbr(name,loksp) +! locates a species record no abbreviations allowed + implicit none + character name*(*) + integer loksp +!\end{verbatim} %+ + character symbol*24 + symbol=name + call capson(symbol) + do loksp=1,noofsp +! write(*,17)'find species 17B: ',loksp,splista(loksp)%symbol,name +!17 format(a,i3,' "',a,'" "',a,'"') + if(symbol.eq.splista(loksp)%symbol) goto 1000 + enddo +! write(*,*)'Error in find_species_record_noabbr "',name,'"' + gx%bmperr=4051 + loksp=0 +1000 continue + return + end subroutine find_species_record_noabbr + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine find_species_record_exact(name,loksp) +! locates a species record, exact match needed +! for parameters, V must not be accepted as abbreviation of VA or C for CR + implicit none + integer loksp + character name*(*) +!\end{verbatim} %+ + character symbol*24 + symbol=name + call capson(symbol) + do loksp=1,noofsp +! write(*,17)'find species 17: ',loksp,splista(loksp)%symbol,name +!17 format(a,i3,' "',a,'" "',a,'"') + if(symbol.eq.splista(loksp)%symbol) goto 1000 + enddo +! write(*,*)'in find_species_record' + gx%bmperr=4051 + loksp=0 +1000 continue + return + end subroutine find_species_record_exact + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine find_phasetuple_by_name(name,phcsx) +! finds a phase with name "name", returns phase tuple index +! handles composition sets either with prefix/suffix or #digit +! When no pre/suffix nor # always return first composition set + implicit none + character name*(*) + integer phcsx +!\end{verbatim} %+ + integer iph,ics + call find_phasex_by_name(name,phcsx,iph,ics) +1000 continue + return + end subroutine find_phasetuple_by_name + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine find_phase_by_name(name,iph,ics) +! finds a phase with name "name", returns address of phase, first fit accepted +! handles composition sets either with prefix/suffix or #digit +! When no pre/suffix nor # always return first composition set + implicit none + character name*(*) + integer iph,ics +!\end{verbatim} %+ + integer phcsx + call find_phasex_by_name(name,phcsx,iph,ics) +1000 continue + return + end subroutine find_phase_by_name + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine find_phasex_by_name(name,phcsx,iph,ics) +! finds a phase with name "name", returns index and tuplet of phase. +! All phases checked and error return if name is ambiguous +! handles composition sets either with prefix/suffix or #digit or both +! if no # check all composition sets for prefix/suffix + implicit none + character name*(*) + integer phcsx,iph,ics +!\end{verbatim} %+ + character name1*36,csname*36,name2*24,name3*24 + TYPE(gtp_phase_varres), pointer :: csrec + integer kp,kcs,lokph,jcs,lokcs,first1,fcs,lcs,lenam +! convert to upper case locally + name1=name + call capson(name1) +! write(*,*)'3A find phase: ',name1 +! composition set as #digit + kp=index(name1,'#') + if(kp.gt.0) then + ics=ichar(name1(kp+1:kp+1))-ichar('0') +! negative ics should give error, 0 should be the same as 1 + if(ics.eq.0) ics=1 + if(ics.lt.1 .or. ics.gt.9) then + gx%bmperr=4093; goto 1000 + endif + name1(kp:)=' ' + kcs=ics + else + ics=1 + kcs=0 + endif +! write(*,17)name(1:len_trim(name)),ics,kcs,kp +17 format('3A find_phase 3: ',a,2x,10i4) + first1=0 + loop1: do lokph=1,noofph + if(kcs.eq.0) then +! no composition set specified explicitly, all sets must be checked + fcs=2; lcs=phlista(lokph)%noofcs + elseif(kcs.le.phlista(lokph)%noofcs) then + fcs=max(2,kcs); lcs=kcs + else +! this phase does not have a composition set kcs + cycle loop1 + endif + name2=phlista(lokph)%name + if(kcs.le.1) then + if(compare_abbrev(name1,name2)) then + if(first1.eq.0) then + first1=lokph + if(len_trim(name1).eq.len_trim(name2)) then +! exact match, we already know there is a composition set +! write(*,*)'3A exact match',name1(1:len_trim(name1)),lokph + goto 300 + endif + else +! another phase with same abbreviation, phase name is ambiguous + gx%bmperr=4121 + goto 1000 + endif + endif + endif +! if composition set specified check only that set, otherwise all from 2 + loop2: do jcs=fcs,lcs + lokcs=phlista(lokph)%linktocs(jcs) + csrec=>firsteq%phase_varres(lokcs) + kp=len_trim(csrec%prefix) + if(kp.gt.0) then + csname=csrec%prefix(1:kp)//'_'//name2 + else + csname=name2 + endif + kp=len_trim(csrec%suffix) + if(kp.gt.0) csname=csname(1:len_trim(csname))//'_'//& + csrec%suffix(1:kp) +! write(*,244)ics,kcs,jcs,kp,fcs,lcs,first1,name1(1:len_trim(name1)),& +! csname(1:len_trim(csname)) +244 format('3A: find_phase: ',7i3,'<',a,'>=?=<',a,'>') + if(compare_abbrev(name1,csname)) then + if(first1.eq.lokph) then +! match already with first composition set, that is OK + cycle loop2 + elseif(first1.eq.0) then + first1=lokph + ics=jcs + else +! ambiguous phase name + gx%bmperr=4121; goto 1000 + endif + elseif(kcs.gt.1) then +! No mach with phase name including pre/suffix but if user has specified # +! accept also match with original name without pre/suffix + if(compare_abbrev(name1,name2)) then + if(first1.eq.0) then + first1=lokph + ics=jcs + else +! another phase with same abbreviation, phase name is ambiguous + gx%bmperr=4121 + goto 1000 + endif + endif + endif + enddo loop2 + enddo loop1 + if(first1.eq.0) then +! no phase found + gx%bmperr=4050 + goto 1000 + endif +300 continue + iph=phlista(first1)%alphaindex +! ics set above + phcsx=firsteq%phase_varres(phlista(first1)%linktocs(ics))%phtupx + gx%bmperr=0 +1000 continue + return +1100 continue + gx%bmperr=4073 + goto 1000 + END subroutine find_phasex_by_name + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine find_phasex_by_name_old(name,phcsx,iph,ics) +! finds a phase with name "name", returns address of phase, first fit accepted +! handles composition sets either with prefix/suffix or #digit +! no pre/suffix nor # always return first composition set + implicit none + character name*(*) + integer phcsx,iph,ics +!\end{verbatim} %+ +! THIS SHOULD BE REWRITTEN ... + character name1*36,csname*36,name2*24,name3*24 + TYPE(gtp_phase_varres), pointer :: csrec + integer kp,kcs,lokph,jcs,lokcs,first1,first2 +! convert to upper case locally + name1=name + call capson(name1) +! write(*,*)'find phase: ',name1 +! composition set as #digit + kp=index(name1,'#') + if(kp.gt.0) then + ics=ichar(name1(kp+1:kp+1))-ichar('0') +! negative ics should give error, 0 should be the same as 1 + if(ics.eq.0) ics=1 + if(ics.lt.1 .or. ics.gt.9) then + gx%bmperr=4093; goto 1000 + endif + name1(kp:)=' ' + kcs=ics + else + ics=1 + kcs=0 + endif + write(*,17)ics,kcs,kp +17 format('3A find_phase 3: ',10i4) + first1=0 + first2=0 + loop1: do lokph=1,noofph + name2=phlista(lokph)%name +! write(*,*)'find_phase 2: ',name1,name2 + if(compare_abbrev(name1,name2)) then + if(ics.le.phlista(lokph)%noofcs) then +! goto 300 + if(first1.eq.0) then + first1=lokph + else +! phase name is ambiguous + gx%bmperr=4121 + goto 1000 + endif + else +! write(*,18)ics,phlista(lokph)%noofcs +!18 format('find_phase 4: ',2i4) + gx%bmperr=4072; goto 1000 + endif + endif +! if there are composition sets check name including prefix/suffix +! write(*,*)'find_phase 5: ',lokph,phlista(lokph)%noofcs + csno: do jcs=2,phlista(lokph)%noofcs + lokcs=phlista(lokph)%linktocs(jcs) +! write(*,*)'3A: find phase: ',jcs,lokcs,phlista(lokph)%noofcs + csrec=>firsteq%phase_varres(lokcs) + kp=len_trim(csrec%prefix) + if(kp.gt.0) then + csname=csrec%prefix(1:kp)//'_'//name2 + else + csname=name2 + endif +! write(*,*)'find phase: ',kp + kp=len_trim(csrec%suffix) + if(kp.gt.0) csname=csname(1:len_trim(csname))//'_'//& + csrec%suffix(1:kp) +! write(*,244)ics,kcs,jcs,kp,name1(1:len_trim(name1)),& +! csname(1:len_trim(csname)) +244 format('3A: find_phase: ',4i3,'<',a,'>=?=<',a,'>') + if(compare_abbrev(name1,csname)) then + if(first2.eq.0) then +! if user has provided both # and pre/suffix these must be consistent + if(kcs.gt.0 .and. kcs.ne.jcs) then +! automatically created composition sets all have the suffix _AUTO but +! can have several numbers +! write(*,*)'3A: mix? ',jcs,phlista(lokph)%noofcs + if(jcs.eq.phlista(lokph)%noofcs) goto 1100 + cycle csno + endif + first2=jcs + else +! ambiguous phase name + gx%bmperr=4121; goto 1000 + endif +! ics=jcs +! goto 300 + endif + enddo csno + enddo loop1 + if(first1.eq.0) then +! no phase found + gx%bmperr=4050 + goto 1000 + endif +300 continue + if(first2.eq.0) then + ics=1 + else + ics=first2 + endif +! iph=phlista(lokph)%alphaindex +! phcsx=firsteq%phase_varres(phlista(lokph)%linktocs(ics))%phtupx + iph=phlista(first1)%alphaindex + phcsx=firsteq%phase_varres(phlista(first1)%linktocs(ics))%phtupx + gx%bmperr=0 +1000 continue + return +1100 continue + gx%bmperr=4073 + goto 1000 + END subroutine find_phasex_by_name_old + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine find_phase_by_name_exact(name,iph,ics) +! finds a phase with name "name", returns address of phase. exact match req. +! handles composition sets either with prefix/suffix or #digit +! no pre/suffix nor # gives first composition set + implicit none + character name*(*) + integer iph,ics +!\end{verbatim} + character name1*36,csname*36,name2*24 + TYPE(gtp_phase_varres), pointer :: csrec + integer kp,kcs,iphfound,lokph,jcs,lokcs +! convert to upper case locally + name1=name + call capson(name1) +! composition set as #digit + kp=index(name1,'#') + if(kp.gt.0) then + ics=ichar(name1(kp+1:kp+1))-ichar('0') +! negative ics should give error, 0 should be the same as 1 + if(ics.eq.0) ics=1 + if(ics.lt.1 .or. ics.gt.9) then + gx%bmperr=4093; goto 1000 + endif + name1(kp:)=' ' + kcs=ics + else + ics=1 + kcs=0 + endif +! write(*,17)ics,kcs +17 format('find_phase 3: ',2i4) +! write(*,11)'fpbne 1: ',name,noofph +11 format(a,a,'; ',2i3) + iphfound=0 + loop1: do lokph=1,noofph + name2=phlista(lokph)%name +! write(*,*)'find_phase 2: ',name1,name2 + if(compare_abbrev(name1,name2)) then + if(ics.le.phlista(lokph)%noofcs) then +! possible phase, if iphfound>0 exact match is required + if(iphfound.ne.0) then + if(name1.eq.name2) then + iphfound=lokph + goto 300 + else + iphfound=-lokph + endif + else + iphfound=lokph + endif + else +! write(*,18)ics,phlista(lokph)%noofcs +18 format('find_phase 4: ',2i4) + gx%bmperr=4072; goto 1000 + endif + endif + enddo loop1 +! write(*,*)'find_phase ',iphfound + if(iphfound.lt.0) then +! several phases found + gx%bmperr=4121; goto 1000 + elseif(iphfound.le.0) then +! no phase found + gx%bmperr=4050; goto 1000 + else + lokph=iphfound + goto 300 + endif +! if there are composition sets check name including prefix/suffix + write(*,*)'find_phase 5: ',lokph,phlista(lokph)%noofcs + do jcs=2,phlista(lokph)%noofcs + lokcs=phlista(lokph)%linktocs(jcs) + csrec=>firsteq%phase_varres(lokcs) + kp=len_trim(csrec%prefix) + if(kp.gt.0) then + csname=csrec%prefix(1:kp)//'_'//name2 + else + csname=name2 + endif + kp=len_trim(csrec%suffix) + if(kp.gt.0) csname=csname(1:len_trim(csname))//'_'//& + csrec%suffix(1:kp) + if(compare_abbrev(name1,csname)) then +! if user has provided both # and pre/suffix these must be consistent + if(kcs.gt.0 .and. kcs.ne.jcs) goto 1100 + ics=jcs + goto 300 + endif + enddo +250 continue +! no phase with this name + gx%bmperr=4050 + goto 1000 +300 continue + iph=phlista(lokph)%alphaindex + gx%bmperr=0 +1000 continue + return +1100 continue + gx%bmperr=4073 + goto 1000 + END subroutine find_phase_by_name_exact + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine find_constituent(iph,spname,mass,icon) +! find the constituent "spname" of a phase. spname can have a sublattice #digit +! Return the index of the constituent in icon. Additionally the mass +! of the species is returned. + implicit none + character*(*) spname + double precision mass + integer iph,icon +!\end{verbatim} + character spname1*24 + integer lokph,kp,ll,kk,loksp,ls,first + lokph=phases(iph) + kp=index(spname,'#') + if(kp.gt.0) then + ls=ichar(spname(kp+1:kp+1))-ichar('0') + spname1=spname(1:kp-1) + else + ls=0 + spname1=spname + endif + call capson(spname1) + icon=0 + first=0 + lloop: do ll=1,phlista(lokph)%noofsubl + sploop: do kk=1,phlista(lokph)%nooffr(ll) + icon=icon+1 + if(ls.eq.0 .or. ls.eq.ll) then + loksp=phlista(lokph)%constitlist(icon) +! constituent icon is the requested one +! write(*,55)ll,kk,icon,spname1(1:3),splista(loksp)%symbol(1:3) +!55 format('find_const 7: ',3i3,1x,a,2x,a) + if(compare_abbrev(spname1,splista(loksp)%symbol)) then + if(first.eq.0) then + first=loksp + else + gx%bmperr=4121 + goto 1000 + endif + goto 1000 + endif + endif + enddo sploop + enddo lloop + if(first.eq.0) then + gx%bmperr=4096 + else + mass=splista(first)%mass + endif +1000 continue + return + end subroutine find_constituent + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine findeq(name,ieq) +! finds the equilibrium with name "name" and returns its index +! ieq should be the current equilibrium + implicit none + character name*(*) + integer ieq +!\end{verbatim} %+ + character name2*64 + integer jeq + name2=name + call capson(name2) +! Accept abbreviations of PREVIOUS and FIRST (DEFAULT is the same as the first) +! write(*,*)'3A equil: ',name2(1:20),ieq + if(compare_abbrev(name2,'PREVIOUS ')) then + jeq=max(1,ieq-1); goto 200 + elseif(compare_abbrev(name2,'FIRST ')) then + jeq=1; goto 200 + endif + jeq=0 +100 jeq=jeq+1 +! write(*,*)'findeq 2: ',jeq,name2 + if(jeq.ge.eqfree) then + gx%bmperr=4124 + goto 1000 + endif +! write(*,*)'findeq 3: ',jeq,eqlista(jeq)%eqname + if(.not.compare_abbrev(name2,eqlista(jeq)%eqname)) goto 100 +! if(eqlista(jeq)%eqname.ne.name2) goto 100 +200 continue + ieq=jeq +1000 continue + end subroutine findeq + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} %- + subroutine selecteq(ieq,ceq) +! checks if equilibrium ieq exists and if so set it as current + implicit none + TYPE(gtp_equilibrium_data), pointer :: ceq + integer ieq +!\end{verbatim} + if(ieq.lt.0 .or. ieq.ge.eqfree) then + gx%bmperr=4124 + goto 1000 + endif + ceq=>eqlista(ieq) +1000 continue + end subroutine selecteq + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ +!> 4. Get things +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine get_phase_record(iph,lokph) +! given phase index iph this returns the phase location lokph + implicit none + integer iph,lokph +!\end{verbatim} %+ + if(iph.lt.1 .or. iph.gt.noofph) then +! write(*,*)'gpr: ',iph,noofph + gx%bmperr=4050 + else + lokph=phases(iph) + endif + return + end subroutine get_phase_record + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine get_phase_variance(iph,nv) +! returns the number of independent variable fractions in phase iph + implicit none + integer iph,nv +!\end{verbatim} %+ + integer lokph + call get_phase_record(iph,lokph) + nv=phlista(lokph)%tnooffr-phlista(lokph)%noofsubl + return + end subroutine get_phase_variance + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine get_constituent_location(lokph,cno,loksp) +! returns the location of the species record of a constituent +! requred for ionic liquids as phlista is private + implicit none + integer lokph,loksp,cno +!\end{verbatim} %+ + loksp=phlista(lokph)%constitlist(cno) + return + end subroutine get_constituent_location + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine get_phase_compset(iph,ics,lokph,lokcs) +! Given iph and ics the phase and composition set locations are returned +! Checks that ics and ics are not outside bounds. + implicit none + integer iph,ics,lokph,lokcs +!\end{verbatim} %+ + if(iph.le.0 .or. iph.gt.noofph) then + gx%bmperr=4050; goto 1000 + endif + lokph=phases(iph) +! find composition set + if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then + gx%bmperr=4072; goto 1000 + elseif(ics.eq.0) then + ics=1 + endif + lokcs=phlista(lokph)%linktocs(ics) +1000 continue + return + end subroutine get_phase_compset + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine get_constituent_name(iph,iseq,spname,mass) +! find the constituent with sequential index iseq in phase iph +! return name in "spname" and mass in mass + implicit none + character*(*) spname + integer iph,iseq + double precision mass +!\end{verbatim} + integer lokph,loksp + if(iph.gt.0 .and. iph.le.noofph) then + lokph=phases(iph) + else + gx%bmperr=4050 + goto 1000 + endif + if(iseq.gt.0 .and. iseq.le.phlista(lokph)%tnooffr) then + loksp=phlista(lokph)%constitlist(iseq) + spname=splista(loksp)%symbol + mass=splista(loksp)%mass + else + write(*,*)'No such constituent' + gx%bmperr=7777 + endif +1000 continue + return + end subroutine get_constituent_name + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine get_phase_constituent_name(iph,icon,name,sublat) +! return the name of constituent icon of phase iph +! redundant? + implicit none + character*(*) name + integer iph,icon,sublat +!\end{verbatim} + integer lokph,sumc + if(iph.le.0 .or. iph.gt.noofph) then + gx%bmperr=4050; goto 1000 + endif + lokph=phases(iph) + if(icon.le.0 .or. icon.gt.phlista(lokph)%tnooffr) then + gx%bmperr=4096; goto 1000 + endif +! loksp=phlista(lokph)%constitlist(icon) +! name=splista(loksp)%symbol + name=splista(phlista(lokph)%constitlist(icon))%symbol +! sublattice + sublat=1 + sumc=phlista(lokph)%nooffr(sublat) + do while(icon.gt.sumc) + sublat=sublat+1 + sumc=sumc+phlista(lokph)%nooffr(sublat) + enddo +1000 continue + return + end subroutine get_phase_constituent_name + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine get_element_data(iel,elsym,elname,refstat,mass,h298,s298) +! return element data as that is stored as private in GTP + implicit none + character elsym*2, elname*(*),refstat*(*) + double precision mass,h298,s298 + integer iel +!\end{verbatim} + integer lokel + if(iel.le.noofel) then + lokel=elements(iel) + elsym=ellista(lokel)%symbol + elname=ellista(lokel)%name + refstat=ellista(lokel)%ref_state + mass=ellista(lokel)%mass + h298=ellista(lokel)%h298_h0 + s298=ellista(lokel)%s298 + else + gx%bmperr=4042 + endif + end subroutine get_element_data + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine get_component_name(icomp,name,ceq) +! return the name of component icomp + implicit none + character*(*) name + integer icomp + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} %+ + if(icomp.gt.noofel) then + gx%bmperr=4052 + else + name=splista(ceq%complist(icomp)%splink)%symbol + if(buperr.ne.0) then + write(*,*)'gcn buperr: ',buperr + gx%bmperr=buperr + endif + endif +1000 continue + return + end subroutine get_component_name + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine get_species_name(isp,spsym) +! return species name, isp is species number + implicit none + character spsym*(*) + integer isp +!\end{verbatim} + if(isp.le.0 .or. isp.gt.noofsp) then +! write(*,*)'in get_species_name' + gx%bmperr=4051; goto 1000 + endif +! loksp=species(isp) +! spsym=splista(loksp)%symbol + spsym=splista(species(isp))%symbol +1000 return + end subroutine get_species_name + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine get_species_data(loksp,nspel,ielno,stoi,smass,qsp) +! return species data, loksp is from a call to find_species_record +! nspel: integer, number of elements in species +! ielno: integer array, element indices +! stoi: double array, stocichiometric factors +! smass: double, mass of species +! qsp: double, charge of the species + implicit none + integer, dimension(*) :: ielno + double precision, dimension(*) :: stoi(*) + integer loksp,nspel + double precision smass,qsp +!\end{verbatim} + integer jl,iel + if(loksp.le.0 .or. loksp.gt.noofsp) then +! write(*,*)'in get_species_data' + gx%bmperr=4051; goto 1000 + endif + nspel=splista(loksp)%noofel + elements: do jl=1,nspel + iel=splista(loksp)%ellinks(jl) + ielno(jl)=ellista(iel)%alphaindex + stoi(jl)=splista(loksp)%stoichiometry(jl) + enddo elements + smass=splista(loksp)%mass + qsp=splista(loksp)%charge +1000 return + end subroutine get_species_data + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + double precision function mass_of(component,ceq) +! return mass of component +! smass: double, mass of species + implicit none + integer :: component + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + if(component.le.0 .or. component.gt.noofel) then + write(*,*)'Calling mass_of with illegal component number: ',component + gx%bmperr=7777; goto 1000 + endif +! return in kg + mass_of=ceq%complist(component)%mass +1000 return + end function mass_of + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine get_phasetup_name(phtuple,name) +! Given the phase tuple this subroutine returns the name with pre- and suffix +! for composition sets added and also a \# followed by a digit 2-9 for +! composition sets higher than 1. + implicit none + character name*(*) + type(gtp_phasetuple) :: phtuple +!\end{verbatim} %+ + call get_phase_name(phtuple%phase,phtuple%compset,name) +1000 continue + return + end subroutine get_phasetup_name + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine get_phase_name(iph,ics,name) +! Given the phase index and composition set number this subroutine returns +! the name with pre- and suffix for composition sets added and also +! a \# followed by a digit 2-9 for composition sets higher than 1. + implicit none + character name*(*) + integer iph,ics +!\end{verbatim} + character phname*36 + integer lokph,lokcs,kp + call get_phase_compset(iph,ics,lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 + if(ics.eq.1) then + name=phlista(lokph)%name + else + kp=len_trim(firsteq%phase_varres(lokcs)%prefix) + if(kp.gt.0) then + phname=firsteq%phase_varres(lokcs)%prefix(1:kp)//'_'//& + phlista(lokph)%name + else + phname=phlista(lokph)%name + endif + kp=len_trim(firsteq%phase_varres(lokcs)%suffix) + if(kp.gt.0) then + phname(len_trim(phname)+1:)='_'//firsteq%phase_varres(lokcs)%suffix + endif + phname(len_trim(phname)+1:)='#'//char(ics+ichar('0')) + name=phname + endif +1000 continue + return + end subroutine get_phase_name + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine get_phase_data(iph,ics,nsl,nkl,knr,yarr,sites,qq,ceq) +! return the structure of phase iph and constituntion of comp.set ics +! nsl: integer, number of sublattices +! nkl: integer array, number of constituents in each sublattice +! knr: integer array, species location (not index) of constituents (all subl) +! yarr: double array, fraction of constituents (in all sublattices) +! sites: double array, number of sites in each sublattice +! qq: double array, (must be dimensioned at least 5) although only 2 used: +! qq(1) is number of real atoms per formula unit for current constitution +! qq(2) is net charge of phase for current constitution +! ceq: pointer, to current gtp_equilibrium_data record + implicit none + integer, dimension(*) :: nkl,knr + double precision, dimension(*) :: yarr,sites,qq + integer iph,ics,nsl + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer lokph,lokcs,kkk,ll,jj,loksp + double precision vsum,qsum,ql,vl,yz +! + if(iph.lt.1 .or. iph.gt.noofph) then + gx%bmperr=4050; goto 1000 + else + lokph=phases(iph) + endif + nsl=phlista(lokph)%noofsubl + if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then + gx%bmperr=4072; goto 1000 + elseif(ics.eq.0) then + ics=1 + endif +! extra check if using saved equilibria which may have less composition sets + lokcs=phlista(lokph)%linktocs(ics) + if(lokcs.le.0) then + write(*,*)'Index of composition set missing, maybe using a saved equil.' + gx%bmperr=4072 + goto 1000 + endif +! lokcs=phlista(lokph)%cslink +! jcs=ics-1 +! do while(jcs.gt.0) +! lokcs=ceq%phase_varres(lokcs)%next +! if(lokcs.le.0) then +! write(*,*)'get_phase_data error 4072' +! gx%bmperr=4072; goto 1000 +! endif +! jcs=jcs-1 +! enddo +! >>>>> get_phase_data missing: for ionic liquid sites vary with composition + vsum=zero + qsum=zero + kkk=0 + if(.not.btest(ceq%phase_varres(lokcs)%status2,CSCONSUS)) then + sublat: do ll=1,nsl + nkl(ll)=phlista(lokph)%nooffr(ll) +! we get strange error "index 1 or array ceq above bound of 0" + if(size(ceq%phase_varres(lokcs)%sites).lt.1) then + write(*,*)'Strange error when step: ',iph,ics,lokcs,ll + gx%bmperr=8765; goto 1000 + endif +! write(*,17)'3 A Strange error: ',iph,ics,lokcs,ll,& +! size(ceq%phase_varres(lokcs)%sites) +17 format(a,10i6) + sites(ll)=ceq%phase_varres(lokcs)%sites(ll) + ql=zero + vl=zero + const: do jj=1,nkl(ll) + kkk=kkk+1 + loksp=phlista(lokph)%constitlist(kkk) + knr(kkk)=loksp + yz=ceq%phase_varres(lokcs)%yfr(kkk) + yarr(kkk)=yz + if(loksp.gt.0) then +! loksp is -99 for wildcards. ionic liquid can have that in first sublattice + ql=ql+yz*splista(loksp)%charge + if(btest(splista(loksp)%status,SPVA)) then + vl=yz + endif + endif + enddo const + vsum=vsum+sites(ll)*(one-vl) + qsum=qsum+sites(ll)*ql + enddo sublat + qq(1)=vsum + qq(2)=qsum +! write(*,*)'get_phase_data: ',qq(1),qq(2) + else +! >>>> unfinished handle the case with suspended constituents +! write(*,*)'get_phase_data with suspended constituents not implemented' + gx%bmperr=4080; goto 1000 + endif +! +1000 continue + return + end subroutine get_phase_data + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + integer function get_phtuplearray(phcs) +! copies the internal phase tuple array to external software +! function value set to number of tuples + type(gtp_phasetuple), dimension(*) :: phcs +!\end{verbatim} + integer iz + do iz=1,nooftuples + phcs(iz)=phasetuple(iz) + enddo +1000 continue + get_phtuplearray=nooftuples + return + end function get_phtuplearray + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ +!> 5. Set things +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ +! +!-\begin{verbatim} +! subroutine set_mean_constitution(iph,ics,ceq) +! sets a start constitution 1/ns in all sublattices where ns is the number +! of constituents in the sublattice. +! implicit none +! integer iph,ics +! TYPE(gtp_equilibrium_data), pointer :: ceq +!-\end{verbatim} +! integer, dimension(maxsubl) :: knl +! double precision, dimension(maxsubl) :: sites +! integer, dimension(maxconst) :: knr +! double precision, dimension(maxconst) :: yarr +! double precision, dimension(5) :: qq +! double precision df +! integer nsl,kkk,ll,jl +! call get_phase_data(iph,ics,nsl,knl,knr,yarr,sites,qq,ceq) +! if(gx%bmperr.ne.0) goto 1000 +! kkk=0 +! do ll=1,nsl +! if(knl(ll).gt.1) then +! df=one/dble(knl(ll)) +! do jl=1,knl(ll) +! kkk=kkk+1 +! yarr(kkk)=df +! enddo +! endif +! enddo +! write(*,17)iph,ics,(yarr(j),j=1,kkk) +!17 format('Default cons: ',2i3,5(1pe12.4)) +! call set_constitution(iph,ics,yarr,qq,ceq) +!1000 continue +! return +! end subroutine set_mean_constitution +! +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine set_constitution(iph,ics,yfra,qq,ceq) +! set the constituent fractions of a phase and composition set and the +! number of real moles and mass per formula unit of phase +! returns number of real atoms in qq(1), charge in qq(2) and mass in qq(3) +! for ionic liquids sets the number of sites in the sublattices + implicit none + double precision, dimension(*) :: yfra,qq + integer iph,ics + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer lokph,lokcs,ll,ml,ic,loksp,jl,locva + double precision charge,spat,asite,bsite,badd,yz,yva,sumat,asum,bsum +! double precision charge1,bion1,ionsites(2) + double precision charge1,bion1 +! The mass is not calculated correctly in version 2, attempt to fix + double precision bliq1 +! TYPE(gtp_fraction_set), pointer :: disrec + logical ionicliq +! write(*,*)'In set_constitution ...' + if(iph.le.0 .or. iph.gt.noofph) then + gx%bmperr=4050; goto 1000 + endif + lokph=phases(iph) + if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then + gx%bmperr=4072; goto 1000 + elseif(ics.eq.0) then + ics=1 + endif + lokcs=phlista(lokph)%linktocs(ics) + ionicliq=btest(phlista(lokph)%status1,PHIONLIQ) + if(ionicliq) then +! default values of i2slx + phlista(lokph)%i2slx(1)=phlista(lokph)%tnooffr+1 + phlista(lokph)%i2slx(2)=phlista(lokph)%tnooffr+1 + yva=zero + locva=0 + endif +!---- + if(ocv()) write(*,8)'3Ay:',iph,ics,& + (yfra(ic),ic=1,phlista(lokph)%tnooffr) +8 format(a,2i2,6(1pe11.3)) + nosuscon: if(btest(ceq%phase_varres(lokcs)%status2,CSCONSUS)) then +! >>>> unfinished: handle the case when some constituents are suspended +! write(*,*)'set_constitution with suspended constituents not implemented' + write(*,*)'suspended const in: ',lokph,lokcs + gx%bmperr=4080; goto 1000 + else +! no suspended constituents +! As the application program may have errors first make sure than +! the constituents fractions are correct: +! - no negative fractions +! - sum of fractions in each sublattice unity +! if(ocv()) write(*,*)'3A 2: ',ionicliq + ic=0 + do ll=1,phlista(lokph)%noofsubl +! write(*,*)'3A sumy 2: ',ll,ic,phlista(lokph)%noofsubl + asite=zero + do ml=1,phlista(lokph)%nooffr(ll) + yz=yfra(ic+ml) + if(yz.lt.bmpymin) yz=bmpymin + ceq%phase_varres(lokcs)%yfr(ic+ml)=yz + asite=asite+yz + enddo +! make sure sum of fractions is unity in each sublattice + do ml=1,phlista(lokph)%nooffr(ll) + ceq%phase_varres(lokcs)%yfr(ic+ml)=& + ceq%phase_varres(lokcs)%yfr(ic+ml)/asite + enddo +! write(*,13)'3A y: ',ll,ic,asite,bmpymin,& +! (ceq%phase_varres(lokcs)%yfr(ic+ml),& +! ml=1,phlista(lokph)%nooffr(ll)) +13 format(a,2i2,2(1pe12.4),1x,4(1pe12.4)) + ic=ic+phlista(lokph)%nooffr(ll) + enddo +!-------- + ll=1; ml=0; asum=zero; bsum=zero; charge=zero + if(ionicliq) then +! For ionic liquid we do not know the number of sites + asite=one + bion1=zero + else + asite=ceq%phase_varres(lokcs)%sites(ll) + endif +! what is bsite used for??? + bsite=asite; badd=zero + spat=zero + allcon: do ic=1,phlista(lokph)%tnooffr + yz=ceq%phase_varres(lokcs)%yfr(ic) +! if(ocv()) write(*,*)'3A 3: ',ic,yz + notva: if(btest(ceq%phase_varres(lokcs)%constat(ic),CONVA)) then +! the constituent is the vacancy +! i2slx(1) should be set to the index of vacancies (if any) + if(ionicliq) phlista(lokph)%i2slx(1)=ic + locva=ic + yva=yz + else +! sum charge and for constituents with several atoms spat sum number of atoms + loksp=phlista(lokph)%constitlist(ic) + charge=charge+bsite*yz*splista(loksp)%charge +! derivates of sites for ionic liquid model +! if(ocv()) write(*,*)'3A 4: ',loksp,charge + if(ionicliq) then + ceq%phase_varres(lokcs)%dpqdy(ic)=abs(splista(loksp)%charge) +! if(ocv()) write(*,*)'3A dpqdy: ',& +! ic,abs(splista(loksp)%charge) +! i2slx(2) should be set to the index of the first neutral (if any) + if(splista(loksp)%charge.eq.zero .and.& + phlista(lokph)%i2slx(2).gt.ic) & + phlista(lokph)%i2slx(2)=ic + endif +! add the mass of the constituents + badd=badd+bsite*yz*splista(loksp)%mass +! write(*,56)'3A badd: ',iph,loksp,splista(loksp)%mass,yz,bsite,badd +56 format(a,2i3,6(1pe12.4)) + sumat=zero +! This is not adopted for other components than the elements + do jl=1,splista(loksp)%noofel + sumat=sumat+splista(loksp)%stoichiometry(jl) + enddo + spat=spat+yz*sumat +! check sum number of atoms for ionic liquid +! if(sumat.gt.1) then +! write(*,7)'spat: ',lokph,splista(loksp)%noofel,sumat,yz,spat +!7 format(a,2i3,3F10.4) +! endif +! write(*,11)loksp,yz,splista(loksp)%mass,badd,bsum +11 format('set_const 3: ',i3,4(1PE15.7)) + endif notva +! ml is constituent number in this sublattice, ic for all sublattices + ml=ml+1 +! if(ocv()) write(*,*)'3A 5: ',ml + newsubl: if(ml.ge.phlista(lokph)%nooffr(ll)) then +! next sublattice + ionliq: if(ionicliq) then +! for ioniq liquids the number of sites is the charge on opposite sublattice + if(ll.eq.1) then +! Q=\sum_i v_i y_i = charge +! write(*,88)'ionliq: ',ll,badd,bion1 +88 format(a,i3,6(1pe12.4)) + ceq%phase_varres(lokcs)%sites(2)=charge +! write(*,*)'Ionic 2: ',ceq%phase_varres(lokcs)%sites(2) +! bsite=one + charge1=charge + charge=zero +! same the mass of the constituents on first sublattice + bliq1=badd + badd=zero +! initiate vacancy and neutral indices beyond last index (already done??) + phlista(lokph)%i2slx=phlista(lokph)%tnooffr+1 + elseif(ll.eq.2) then +! P=\sum_j (-v_j)y_j + Qy_Va. Note charge is total charge and valences +! on 2nd sublattice is negative +! Now we know number of sites on sublattice 1, update asum and bsum + sumat=-charge+charge1*yva + ceq%phase_varres(lokcs)%sites(1)=sumat +! write(*,*)'Ionic 1: ',ceq%phase_varres(lokcs)%sites(1) + asum=asum*sumat + bsum=bion1*sumat + charge=zero +! write(*,88)'3A iliq: ',ll,badd,bion1,bsum,sumat,yva +! new way to calculate mass of ionic liquid + bsum=sumat*bliq1+ceq%phase_varres(lokcs)%sites(2)*badd +! write(*,66)'3A ilmass: ',ll,ceq%phase_varres(lokcs)%sites,& +! bliq1,badd,bsum +66 format(a,i3,6(1pe12.4)) + badd=zero + else + write(*,*)'Ionic liquid must have two sublattices',ll + gx%bmperr=7777; goto 1000 + endif + endif ionliq +! note: for ionic liquid previous values of asum and bsum are updated +! when fractions in sublattice 2 have been set + asum=asum+asite*spat + bsum=bsum+badd +! write(*,33)'3A g:',lokcs,ll,asum,asite,spat +33 format(a,2i2,6(1pe12.4)) +! write(*,39)'set_con: ',ll,ml,asum,asite,spat +!39 format(a,2i5,3(1pe12.4)) +! write(*,12)'set_const 12: ',ll,asum,asite,bsum,badd +!12 format(a,i3,4(1pe12.4)) + if(ll.lt.phlista(lokph)%noofsubl) then + ll=ll+1; ml=0 +! asite=phlista(lokph)%sites(ll); spat=zero + asite=ceq%phase_varres(lokcs)%sites(ll) + spat=zero; bion1=badd; badd=zero +! if ionic liquid bsite must be 1.0 when summing second sublattice. Why??? + if(.not.ionicliq) bsite=asite + endif + endif newsubl + enddo allcon +! write(*,33)'3A h:',lokcs,ll,asum,asite,spat + endif nosuscon +! save charge, number of moles and mass of real atoms per formula unit +! write(*,33)'3A isum:',lokcs,0,charge,asum,bsum,asite,spat + ceq%phase_varres(lokcs)%netcharge=charge + ceq%phase_varres(lokcs)%abnorm(1)=asum + ceq%phase_varres(lokcs)%abnorm(2)=bsum + if(ionicliq .and. locva.gt.0) then +! the ionic liquid vacancy charge is the number of sites on second subl. + ceq%phase_varres(lokcs)%dpqdy(locva)=ceq%phase_varres(lokcs)%sites(2) +! if(ocv()) write(*,*)'3A dpqdy(va): ',& +! locva,ceq%phase_varres(lokcs)%sites(2) + endif +! if(ionicliq) then +! write(*,301)'3A xsc:',lokcs,asum,bsum,ceq%phase_varres(lokcs)%sites,& +! charge1 +!301 format(a,i3,6(1pe12.4)) +! write(*,301)'3A y: ',ic,ceq%phase_varres(lokcs)%yfr +! endif + qq(1)=asum + qq(2)=charge + qq(3)=bsum +! set disordered fractions if any + if(btest(phlista(lokph)%status1,phmfs)) then +!now set disordered fractions if any + call calc_disfrac(lokph,lokcs,ceq) + if(gx%bmperr.ne.0) goto 1000 + endif +314 format(a,8F8.3) +1000 continue +! if(ionicliq) write(*,*)'3A s_c: ',phlista(lokph)%i2slx + return + end subroutine set_constitution + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine set_reference_state(icomp,iph,tpval,ceq) +! set the reference state of a component to be "iph" at tpval + implicit none + integer icomp,iph + double precision, dimension(2) :: tpval + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer nsl,nkl(maxsubl),knr(maxconst),splink,j1,ie,elink + integer ll,jj,nrel,lokph,noendm,jerr,lokres,ny,endmemx,endmemxy,ics + double precision sites(maxsubl),qq(5),yarrsave(maxconst),xsum,gmin,gval + double precision, dimension(:), allocatable :: yarr,xcomp,xmol + integer, dimension(:), allocatable :: maxjj,jend,jendsave + double precision tpsave(2),molat,saveg(6) +! iph negative means remove current reference state + if(iph.lt.0) then + ceq%complist(icomp)%phlink=0 + deallocate(ceq%complist(icomp)%endmember) + ceq%complist(icomp)%tpref=zero + ceq%complist(icomp)%refstate='SER (default)' + goto 1000 + endif +! calculate the composition of the component in mole fractions + nrel=noel() + allocate(xcomp(nrel)) + splink=ceq%complist(icomp)%splink + xcomp=zero + xsum=zero + do j1=1,splista(splink)%noofel + elink=splista(splink)%ellinks(j1) + ie=ellista(elink)%alphaindex + xcomp(ie)=splista(splink)%stoichiometry(j1) + xsum=xsum+xcomp(ie) + enddo + do ie=1,splista(splink)%noofel + xcomp(ie)=xcomp(ie)/xsum + enddo +! write(*,17)'3A srs x: ',iph,(xcomp(ie),ie=1,nrel) +17 format(a,i3,15(f5.2)) +! find suitable endmember with correct composition and lowest G +! Note that lowest G is calculated at current T, may be different at another T + call get_phase_data(iph,1,nsl,nkl,knr,yarrsave,sites,qq,ceq) + if(gx%bmperr.ne.0) goto 1000 + allocate(maxjj(0:nsl)) + allocate(jend(1:nsl)) + allocate(jendsave(1:nsl)) +! generate all endmembers, maybe there is a better way ... +! and set unity fraction in yarr and check composition + ny=0 + maxjj(0)=1 + do ll=1,nsl + ny=ny+nkl(ll) + maxjj(ll)=ny + enddo + allocate(yarr(ny)) + yarr=zero + jj=1 + do ll=1,nsl + yarr(jj)=one + jend(ll)=jj + jj=jj+nkl(ll) + enddo + allocate(xmol(nrel)) +! lokph=phases(iph) +! we must save the gval for lokres (composition set 1) + ics=1 + call get_phase_compset(iph,ics,lokph,lokres) + if(gx%bmperr.ne.0) goto 1000 + gmin=1.0D5 + noendm=0 + tpsave=ceq%tpval + if(tpval(1).gt.zero) then +! negative tpval means current temperature, else use tpval(1) + ceq%tpval(1)=tpval(1) + endif + ceq%tpval(2)=tpval(2) + do ie=1,6 + saveg(ie)=ceq%phase_varres(lokres)%gval(ie,1) + enddo +! write(*,912)'3G Saved G: ',lokres,ceq%phase_varres(lokres)%gval(1,1),& +! saveg(1) +!---------------------------------------------- +! return here for each endmember + endmemx=0 +200 continue +! write(*,*)'3G endm: ',(jend(jj),jj=1,nsl) +! write(*,17)'3G srs y: ',(yarr(jj),jj=1,ny) + call set_constitution(iph,1,yarr,qq,ceq) + if(gx%bmperr.ne.0) goto 900 +! this subroutine converts site fractions in phase iph, compset 1 +! to mole fractions of components (or elements ??? ) + endmemx=endmemx+1 + call calc_phase_mol(iph,xmol,ceq) + if(gx%bmperr.ne.0) goto 900 +! write(*,17)'3G srs xem: ',(xmol(ie),ie=1,nrel) + do jj=1,nrel + if(abs(xmol(jj)-xcomp(jj)).gt.1.0D-12) goto 250 + enddo +!-------------------------------------------------- +! we have an endmember with the correct composition + call calcg(iph,1,0,lokres,ceq) + if(gx%bmperr.ne.0) goto 900 + gval=ceq%phase_varres(lokres)%gval(1,1)/qq(1) +! write(*,222)'3G, srs gval: ',qq(1),gval,gmin +222 format(a,F10.3,2(1pe12.4)) + if(gval.lt.gmin) then +! we should check i electrically neutral ?? + noendm=noendm+1 + gmin=gval + jendsave=jend + molat=qq(1) + endmemxy=endmemx +! write(*,229)'3G min: ',gmin,jendsave +229 format(a,1pe12.4,10i4) + endif +250 continue +! change constitution .... quit when all endmembers done + ll=nsl +! should this always be 0? + maxjj(0)=0 +260 continue +! jend is the current endmember + jj=jend(ll) + yarr(jj)=zero + jj=jj+1 + if(jj.gt.maxjj(ll)) then + jend(ll)=maxjj(ll-1)+1 + yarr(jend(ll))=one + ll=ll-1 +! if ll becomes zero here all endmemebrs have been generated (?) + if(ll.ge.1) goto 260 + else + jend(ll)=jj + yarr(jj)=one + goto 200 + endif +!---------------------------------------------- + if(noendm.eq.0) then +! if no endmember found this phase cannt be reference phase + write(*,*)'This phase cannot be reference state for for this component' + gx%bmperr=7777; goto 900 + endif +! endmemx and endmemxy redundant +! write(*,808)'3G reference state endmember',lokph,endmemxy,jendsave +808 format(a,i3,2x,10i3) +! If all OK then save phase location, endmember array, T and P + ceq%complist(icomp)%phlink=lokph + if(.not.allocated(ceq%complist(icomp)%endmember)) then +! if the user changes reference state do not allocate again + allocate(ceq%complist(icomp)%endmember(nsl)) + endif + ceq%complist(icomp)%endmember=jendsave +! allocate(ceq%complist(icomp)%endmember(1)) +! ceq%complist(icomp)%endmember=endmemxy +! molat is probably redundant as calcg_endmember returns for one mole component + ceq%complist(icomp)%molat=molat +! Note tpval(1) can be negative indicating current T + ceq%complist(icomp)%tpref=tpval + ceq%complist(icomp)%refstate=phlista(lokph)%name +! restore original constitution of compset 1 +900 continue + ceq%tpval=tpsave + jerr=gx%bmperr; gx%bmperr=0 + call set_constitution(iph,1,yarrsave,qq,ceq) + if(jerr.ne.0) then + gx%bmperr=jerr + endif +! restore original values of G and derivatives + do ie=1,6 + ceq%phase_varres(lokres)%gval(ie,1)=saveg(ie) + enddo +! write(*,912)'3G Restored G: ',lokres,ceq%phase_varres(lokres)%gval(1,1),& +! saveg(1) +912 format(a,i5,6(1pe12.4)) +1000 continue + return + end subroutine set_reference_state + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + diff --git a/models/pmod25G.F90 b/models/gtp3B.F90 similarity index 93% rename from models/pmod25G.F90 rename to models/gtp3B.F90 index f166078..1ff3d5b 100644 --- a/models/pmod25G.F90 +++ b/models/gtp3B.F90 @@ -1,3920 +1,4000 @@ -! included in pmod25 -! -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ -!> 12. Enter data -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine new_element(symb,name,refstate,mass,h298,s298) -! Creates an element record after checks. -! symb: character*2, symbol (it can be a single character like H or V) -! name: character, free text name of the element -! refstate: character, free text name of reference state. -! mass: double, mass of element in g/mol -! h298: double, enthalpy difference between 0 and 298.14 K -! s298: double, entropy at 298.15 K - implicit none - CHARACTER*(*) symb,name,refstate - DOUBLE PRECISION mass,h298,s298 -!\end{verbatim} - CHARACTER symb2*2,symb24*24 - integer knr(1),jl,jjj,kkk,nsl,loksp,lokph,nycomp - double precision stoik(1) - character ch1*1,model*24,phname*24,const(1)*24 - if(.not.allowenter(1)) then - gx%bmperr=4125 - goto 1000 - endif -! check input data -100 continue - call capson(symb) - if(ucletter(symb(1:1))) then - if(len(symb).ge.2) then - if(ucletter(symb(2:2)) .or. symb(2:2).eq.' ') then - goto 200 - endif - else - goto 200 - endif - endif -! element name error, must be only letters (except /- already entered) -! write(6,*)'new element not allowed ',symb,gx%bmperr - gx%bmperr=4033 - goto 1000 -200 continue -! check element not already entered - symb2=symb(1:2) -! write(*,202)'new element 1: ',symb,symb2 -202 format(a,'"',a,'"',a,'"') - reallynew: do jl=0,noofel - if(symb2.eq.ellista(jl)%symbol) then - gx%bmperr=4034 - goto 1000 - endif - enddo reallynew -! element name is not really needed but must start with letter -! write(*,12)symb,name,refstate,mass,h298,s298 -!12 format('new_el: "',a,'"',a,'"',a,'"',3(1PE12.4)) - call capson(name) - if(name(1:1).ne.' ') then -! allow empty element state - if(.not.ucletter(name(1:1))) then - gx%bmperr=4035 - goto 1000 - endif - endif -300 continue -! reference state must start with letter, no other check - call capson(refstate) - if(refstate(1:1).ne.' ') then -! allow empty reference state - if(.not.ucletter(refstate(1:1))) then -! error here when 1/2_MOLE_O2(G) etc .... - refstate='GAS_'//refstate -! gx%bmperr=4036 -! goto 1000 - endif - endif -400 continue -! mass, h298-h0 and s298 must not be negative - if(mass.lt.zero) then - gx%bmperr=4037 - goto 1000 - endif - if(h298.lt.zero) then - gx%bmperr=4038 - goto 1000 - endif - if(s298.lt.zero) then - gx%bmperr=4039 - goto 1000 - endif -! All OK, increment noofel and store values in record noofel - noofel=noofel+1 - if(noofel.gt.maxel) then - gx%bmperr=4040 - goto 1000 - endif -! ensure that symbol has no strange characters -! write(*,202)'new element 1B: ',symb,symb2 - ellista(noofel)%symbol=' ' - ellista(noofel)%symbol=symb - ellista(noofel)%name=name - ellista(noofel)%ref_state=refstate - ellista(noofel)%mass=mass - ellista(noofel)%h298_h0=h298 - ellista(noofel)%s298=s298 - ellista(noofel)%status=0 - ellista(noofel)%alphaindex=noofel -! value 0 is H298, 1 H0, 2 G - ellista(noofel)%refstatesymbol=0 -! Now create corresponding species - noofsp=noofsp+1 - if(noofel.gt.maxsp) then - gx%bmperr=4041 - goto 1000 - endif - ellista(noofel)%splink=noofsp -! write(*,202)'new element 1C: ',symb,symb2 - symb24=' ' - symb24=symb2 -! write(*,77)symb,symb2,symb24 -!77 format('new element 77: ',a,'"',a,'"',a,'"') - splista(noofsp)%symbol=symb24 - splista(noofsp)%mass=mass - splista(noofsp)%charge=zero - splista(noofsp)%status=0 - splista(noofsp)%status=ibset(splista(noofsp)%status,SPEL) - splista(noofsp)%alphaindex=noofsp - splista(noofsp)%noofel=1 -! allocate - allocate(splista(noofsp)%ellinks(1)) - allocate(splista(noofsp)%stoichiometry(1)) - splista(noofsp)%ellinks(1)=noofel - splista(noofsp)%stoichiometry(1)=one -! return with error code 0 i.e. no error -! gx%bmperr=0 -! rearrange ELEMENTS and SPECIES to maintain these in alphabetical order - elements(noofel)=noofel - call alphaelorder - species(noofsp)=noofsp - call alphasporder -! As this is an element add the species to the component list of firsteq -! Beware that the alphabetical order may have changed. jjj used later - jjj=ellista(noofel)%alphaindex - if(jjj.lt.noofel) then -! write(*,*)'Fixing components in alphabetical order!!',jjj,noofel - do kkk=noofel,jjj+1,-1 - firsteq%complist(kkk)%splink=firsteq%complist(kkk-1)%splink - firsteq%complist(kkk)%phlink=firsteq%complist(kkk-1)%phlink - firsteq%complist(kkk)%refstate=firsteq%complist(kkk-1)%refstate - firsteq%complist(kkk)%tpref(1)=firsteq%complist(kkk-1)%tpref(1) - firsteq%complist(kkk)%tpref(2)=firsteq%complist(kkk-1)%tpref(2) - enddo - else - jjj=noofel - endif - firsteq%complist(jjj)%splink=noofsp - firsteq%complist(jjj)%phlink=0 -! do not copy element reference state name here - firsteq%complist(jjj)%refstate='SER (default)' - firsteq%complist(jjj)%tpref(1)=2.9815D2 - firsteq%complist(jjj)%tpref(2)=1.0D5 -! copy mass of component from species record - firsteq%complist(jjj)%mass=mass -! NOTE jjj is used below when adding this element to reference phase -! also set the stoichiometry matrix, just the diagonal. Also the inverse - firsteq%compstoi(noofel,noofel)=one - firsteq%invcompstoi(noofel,noofel)=one -! write(*,*)'new_el: ',noofel,name,symb24 - nycomp=noofel - if(noofel.eq.1) then -! create reference phase with index 0 -! phname='ELEMENT_REFERENCE_PHASE ' - phname='SELECT_ELEMENT_REFERENCE' - nsl=1 - knr(1)=1 -! const(1)=name - const(1)=symb24 - stoik(1)=one - model='NON_MIXING' - ch1='Z' - call new_phase(phname,nsl,knr,const,stoik,model,ch1) - if(gx%bmperr.ne.0) goto 1000 -! set phase hidden as it should never be included in calculations - lokph=0 - phlista(lokph)%status1=ibset(phlista(lokph)%status1,phhid) -! add all additions ?? - else -! Add the element to the reference phase (phase 0) by extending the -! constituent list (and many other arrays) - loksp=firsteq%complist(jjj)%splink - call add_to_reference_phase(loksp) - if(gx%bmperr.ne.0) goto 1000 - endif - if(noofel.gt.0) then -! clear the nodata bit - globaldata%status=ibclr(globaldata%status,GSNODATA) - endif -! if(gx%bmperr.ne.0) goto 1000 -1000 continue -! write(*,*)'created new species: ',noofsp,splista(noofsp)%symbol - return - END subroutine new_element - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine new_species(symb,noelx,ellist,stoik) -! creates a new species -! symb: character*24, name of species, often equal to stoichimoetric formula -! noelx: integer, number of elements in stoichiometric formula (incl charge) -! ellist: character array, element names (electron is /-) -! stoik: double array, must be positive except for electron. - implicit none - character symb*(*),ellist(*)*(*) - integer noelx - double precision stoik(*) -!\end{verbatim} - double precision mass,charge - integer elindex(10) - integer loksp,noelxx,jl,jk - if(.not.allowenter(1)) then - gx%bmperr=4125 - goto 1000 - endif - call capson(symb) - if(.not.ucletter(symb(1:1))) then - gx%bmperr=4044 - goto 1000 - endif - if(noelx.le.0 .or. noelx.gt.10) then - gx%bmperr=4045 - goto 1000 - endif -! check symb is unique - call find_species_record(symb,loksp) - if(gx%bmperr.eq.0) then - gx%bmperr=4049; goto 1000 - endif - mass=zero - charge=zero - noelxx=noelx -! write(*,*)'new_species 1A: ',noelx - checkel: do jl=1,noelx - loopel: do jk=-1,noofel - if(ellist(jl).eq.ellista(jk)%symbol) goto 200 - enddo loopel -! an unknown element - gx%bmperr=4046 - goto 1000 -200 continue - elindex(jl)=jk - if(jk.ge.0) then - if(stoik(jl).lt.zero) then - gx%bmperr=4047 - goto 1000 - else - mass=mass+stoik(jl)*ellista(jk)%mass - endif - else -! this is the electron, save negative of stoick as charge negative -! the electron is not counted as "element" when storing - charge=-stoik(jl) - noelxx=noelxx-1 - if(jl.ne.noelx) then -! this must be the last element .... otherwise problem storing stoik - gx%bmperr=4048 - goto 1000 - endif - endif -! write(6,*)'new_species 2: ',symb,jl,mass,charge - enddo checkel - noofsp=noofsp+1 - if(noofsp.gt.maxsp) then - gx%bmperr=4125 - goto 1000 - endif -! store species data - splista(noofsp)%symbol=symb - splista(noofsp)%mass=mass - splista(noofsp)%charge=charge - splista(noofsp)%alphaindex=noofsp - splista(noofsp)%noofel=noelxx - splista(noofsp)%status=0 - if(charge.ne.zero) then - splista(noofsp)%status=ibset(splista(noofsp)%status,SPION) - endif -! allocate - allocate(splista(noofsp)%ellinks(noelxx)) - allocate(splista(noofsp)%stoichiometry(noelxx)) - loop2: do jl=1,noelxx - splista(noofsp)%ellinks(jl)=elindex(jl) - splista(noofsp)%stoichiometry(jl)=stoik(jl) - enddo loop2 -! return with no error - gx%bmperr=0 -! add species last and rearrange - species(noofsp)=noofsp - call alphasporder -! error: continue would be a nice use of non-digit labels .... -1000 continue - return - END subroutine new_species - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine new_phase(name,nsl,knr,const,sites,model,phtype) -! creates the data structure for a new phase -! name: character*24, name of phase -! nsl: integer, number of sublattices (range 1-9) -! knr: integer array, number of constituents in each sublattice -! const: character array, constituent (species) names in sequential order -! sites: double array, number of sites on the sublattices -! model: character, free text -! phtype: character*1, specifies G for gas, L for liquid - implicit none - character name*(*),model*(*),phtype*(*) - integer nsl - integer, dimension(*) :: knr - double precision, dimension(*) :: sites - character, dimension(*) :: const*(*) -!\end{verbatim} - character ch1*1 - double precision formalunits - integer kconlok(maxconst),kalpha(maxconst),iord(maxconst),klok(maxconst) - integer iva(maxconst) - logical externalchargebalance - integer iph,kkk,lokph,ll,nk,jl,jk,mm,lokcs,nkk,nyfas,loksp,tuple -! write(*,*)'enter new_phase: ',model(1:len_trim(model)) - if(.not.allowenter(2)) then - gx%bmperr=4125 - goto 1000 - endif -! check input - call capson(name) -! if(.not.ucletter(name)) then - if(.not.proper_symbol_name(name,0)) then - write(*,*)'Error for phase name: ',name(1:min(24,len(name))) - gx%bmperr=4053; goto 1000 - endif -! name unique? - call find_phase_by_name_exact(name,iph,kkk) -! write(6,*)'new phase 1A ',name,nsl,gx%bmperr,const(1) - if(gx%bmperr.eq.0) then -! if phase found then error as name not unique ... but check explicitly - lokph=phases(iph) - if(name.eq.phlista(lokph)%name) then - gx%bmperr=4054 - goto 1000 - endif -! name was not exactly the same, accept this phase name also - else - gx%bmperr=0 - endif - if(nsl.lt.1 .or. nsl.gt.maxsubl) then - gx%bmperr=4056 - goto 1000 - endif - site1: do ll=1,nsl - if(sites(ll).le.zero) then -! write(6,*)' new phase 1B: ',name,ll,nsl,sites(ll) - gx%bmperr=4057 - goto 1000 - endif - enddo site1 - nk=0 - knrtest: do ll=1,nsl - if(knr(ll).lt.1 .or. knr(ll).gt.maxconst) then - write(*,*)'new phase error:',ll,knr(ll),maxconst - gx%bmperr=4058; goto 1000 - endif - if(ll.ge.2 .and. knr(ll).gt.maxcons2) then - gx%bmperr=4059; goto 1000 - endif - nk=nk+knr(ll) - enddo knrtest - nkk=nk -! write(6,*)' new_phase 3: ',name,nsl,nkk,noofsp -! check constituents exists as species - externalchargebalance=.false. - constest: do jl=1,nkk - if(jl.eq.1 .and. model(1:13).eq.'IONIC_LIQUID ') then -! in this case * is allowed on first sublattice!! - if(const(1)(1:2).eq.'* ') then - kalpha(jl)=-99 - kconlok(jl)=-99 - cycle constest - endif - endif - call capson(const(jl)) -! write(6,297)' new_phase constituent: ',jl,const(jl),nkk - findspecies: do jk=1,noofsp - if(const(jl).eq.splista(jk)%symbol) then -! write(*,*)'at new 300: ',noofsp,jk,const(jl) - goto 300 - endif - enddo findspecies -! write(6,297)' new_phase constituent error: ',jl,const(jl),jk,nkk -297 format(a,i3,'>',A,'<',2i3) -! write(*,*)'in enter new phase: ',const(jl) - gx%bmperr=4051 - goto 1000 -! found species, check for duplicates (not done yet) ????? -300 continue - kalpha(jl)=splista(jk)%alphaindex - kconlok(jl)=jk -! write(6,73)' new_phase 4B: ',jl,const(jl),jk,kconlok(jl),kalpha(jl) -!73 format(A,i3,1x,A6,3I3) -! mark that PHEXCB bit must be set if species has a charge - if(splista(jk)%charge.ne.zero) then - externalchargebalance=.true. - endif - enddo constest -! reserve a new phase record and store data there and in other records -! the first phase entered is the reference phase created by init_gtp - if(noofph.eq.0 .and. phtype(1:1).eq.'Z') then -! phtyp=Z is the reference phase - nyfas=0 - else -! sort the phase in alphabetical order but always gas (if any) first -! then liquids specified by the phtype letter (G, L, etc) - noofph=noofph+1 - nyfas=noofph - endif - phlista(nyfas)%name=name - phlista(nyfas)%status1=0 - ionliq: if(model(1:13).eq.'IONIC_LIQUID ') then -! the external charge balance set above, not needed -! write(*,*)' *** ionic liquid entered!!!' - externalchargebalance=.FALSE. -! ionic liquid may have phtype='Y', change that to L - if(phtype(1:1).eq.'Y') phtype(1:1)='L' - if(nsl.ne.2) then -! if entered with only on sublattice then no cations and only neutrals!! - write(*,*)'Ionic liquid must have 2 sublattices' - gx%bmperr=7777; goto 1000 - endif - phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHIONLIQ) -! constituents in ionic liquid must be sorted in a special way - call sort_ionliqconst(lokph,0,knr,kconlok,klok) - if(gx%bmperr.ne.0) goto 1000 - else ! else link is for all other phases except ionic liquid -! sort the constituents in each sublattice according to alphaspindex -! write(6,70)5,(kalpha(i),i=1,nkk) -! write(6,70)5,(kconlok(i),i=1,nkk) -!70 format('new_phase ',I2,': ',20I3) - nk=1 - sort1: do ll=1,nsl - call sortin(kalpha(nk),knr(ll),iord(nk)) - if(buperr.ne.0) then - gx%bmperr=buperr - goto 1000 - endif -! iord(nk+1:nk+knr(ll)) has numbers 1..knr(ll), add on nk-1 to these -! to be in parity with index of kalpha(nk+1:nk+knr(ll)) - adjust: do mm=0,knr(ll)-1 - iord(nk+mm)=iord(nk+mm)+nk-1 - enddo adjust - nk=nk+knr(ll) - enddo sort1 -! write(6,70)6,(kalpha(i),i=1,nkk) -! write(6,70)6,(kconlok(iord(i)),i=1,nkk) -! in constituent record store kconlok(iord(i)) -! verify we can find species name ... -! test7: do kk=1,nkk -! write(6,71)kk,iord(kk),kconlok(iord(kk)),splista(kconlok(iord(kk)))%symbol -!71 format('new_phase 7: ',3I3,1x,A) -! enddo test7 - do jl=1,nkk - klok(jl)=kconlok(iord(jl)) - enddo - endif ionliq -!---------------------------------------- -! write(6,79)8,name,(klok(kk),kk=1,nkk) -79 format('new_phase ',I2,': ',A6,10I3) - ch1=phtype(1:1) - call capson(ch1) -! sort the phase in alphabetical but order but first gas, then liquid etc -! legal values of ch1 is G, L, S and C (gas, liquid, solution, compound) - if(ch1.eq.'G') then - phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHGAS) - model='ideal' - elseif(ch1.eq.'L') then - phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHLIQ) - endif - if(ch1.eq.' ') ch1='S' - phlista(nyfas)%phletter=ch1 - phlista(nyfas)%models=model - if(nyfas.eq.0) then - continue - else - call alphaphorder(tuple) - phlista(nyfas)%nooffs=1 - endif - phlista(nyfas)%noofsubl=nsl - allocate(phlista(nyfas)%nooffr(nsl)) -! sites stored in phase_varres -! allocate(phlista(nyfas)%sites(nsl)) - formalunits=zero - do ll=1,nsl - phlista(nyfas)%nooffr(ll)=knr(ll) -! phlista(nyfas)%sites(ll)=sites(ll) - formalunits=formalunits+sites(ll) - enddo -! write(*,*)'new_phase 8x: ',nyfas,nkk - phlista(nyfas)%tnooffr=nkk -! write(*,*)'new_phase 8y: ',nyfas,phlista(nyfas)%tnooffr -! create consituent record - call create_constitlist(phlista(nyfas)%constitlist,nkk,klok) -! in phase_varres we will indicate the VA constituent, indicate in iva - valoop: do jl=1,nkk - iva(jl)=0 - loksp=phlista(nyfas)%constitlist(jl) - if(loksp.gt.0) then -! ionic liquid can have a wildcard */-99 as constituent in first sublattice - if(btest(splista(loksp)%status,SPVA)) iva(jl)=ibset(iva(jl),CONVA) - endif - enddo valoop -! write(*,32)'new_ph 14A: ',nyfas,(phlista(nyfas)%constitlist(iz),iz=1,nkk) -32 format(a,i3,50(i3)) -! write(*,33)nkk,(iva(i),i=1,nkk) -!33 format('new_phase 14B: ',i3,2x,10i3) -! nprop=10 -! write(*,*)'new_phase: ',lokcs,name - call create_parrecords(nyfas,lokcs,nsl,nkk,maxcalcprop,iva,firsteq) -! write(*,*)'new_phase 15: ',nyfas,lokcs - if(gx%bmperr.ne.0) goto 1000 -! zero array of pointer to phase_varres record, then set first - phlista(nyfas)%linktocs=0 - phlista(nyfas)%linktocs(1)=lokcs - phlista(nyfas)%noofcs=1 - firsteq%phase_varres(lokcs)%phlink=nyfas - firsteq%phase_varres(lokcs)%prefix=' ' - firsteq%phase_varres(lokcs)%suffix=' ' - firsteq%phase_varres(lokcs)%abnorm(1)=formalunits - firsteq%phase_varres%ncc=nkk -! zero the phstate - firsteq%phase_varres(lokcs)%phstate=0 -! sites must be stored in phase_varres - do ll=1,nsl - firsteq%phase_varres(lokcs)%sites(ll)=sites(ll) - enddo -! make sure status word and some other links are set to zero - firsteq%phase_varres(lokcs)%status2=0 -! Setting of phase tuple is done in alphaphorder -! tuple=nooftuples+1 -! phasetuple(tuple)%phase=nyfas -! phasetuple(tuple)%compset=1 -! nooftuples=tuple - firsteq%phase_varres(lokcs)%phtupx=tuple -! write(*,*)'25G new phase tuple: ',nyfas,lokcs,tuple -! If one has made NEW the links are not always zero -! set some phase bits (PHGAS and PHLIQ set above) -! external charge balance etc. - if(externalchargebalance) then - phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHEXCB) - endif - if(nsl.eq.1) then -! if no sublattices set ideal bit. Will be cleared if excess parameter entered - phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHID) - endif - if(nkk.eq.nsl) then -! as many constiuents as sublattice - phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHNOCV) - endif -! nullify links - nullify(phlista(nyfas)%additions) - nullify(phlista(nyfas)%ordered) - nullify(phlista(nyfas)%disordered) -! initiate phcs, the phase composition set counter for nyfas redundant ?? -! (not for reference phase 0) -! if(nyfas.gt.0) phcs(nyfas)=1 - if(noofph.gt.0) then -! clear the nophase bit - globaldata%status=ibclr(globaldata%status,GSNOPHASE) - endif -1000 continue -! write(*,*)'end new_phase' disfra - return - END subroutine new_phase - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine sort_ionliqconst(lokph,mode,knr,kconlok,klok) -! sorts constituents in ionic liquid, both when entering phase -! and decoding parameter constituents -! order: 1st sublattice only cations -! 2nd: anions, VA, neutrals -! mode=0 at enter phase, wildcard ok in 1st sublattice if neiher anions nor Va -! mode=1 at enter parameter (wildcard allowed, i.e. some kconlok(i)=-1) -! some parameters not allowed, L(ion,A+:B,C), must be L(ion,*:B,C), check! - implicit none - integer lokph,knr(*),kconlok(*),klok(*),mode -!\end{verbatim} - integer nk,jl,jk,mm,kkk,ionva,byte - integer, dimension(:), allocatable :: kalpha,iord,iva,anion -! - allocate(kalpha(knr(1)+knr(2))) - allocate(iord(knr(1)+knr(2))) - allocate(iva(knr(1)+knr(2))) - allocate(anion(knr(1)+knr(2))) -! check1: constituents in sublattice 1 must all have positive charge -! if(mode.eq.1) then -! write(*,17)'sl2: ',knr(1),knr(2),(kconlok(mm),mm=1,knr(1)+knr(2)) -!17 format(a,2i3,2x,10i3) -! endif - do nk=1,knr(1) - if(kconlok(nk).lt.0) then -! wildcard give index -99. If mode=0 more checks later - kalpha(nk)=-99 - elseif(splista(kconlok(nk))%charge.le.zero) then - write(*,*)'In ionic_liquid only cations on first sublattice' - gx%bmperr=7777; goto 1000 - else - kalpha(nk)=splista(kconlok(nk))%alphaindex - endif - enddo -! write(*,69)'In 1: ',knr(1),(kconlok(mm),mm=1,knr(1)) - if(knr(1).gt.1) then - call sortin(kalpha,knr(1),iord) - if(buperr.ne.0) then - gx%bmperr=buperr - goto 1000 - endif - if(mode.eq.0 .and. kalpha(1).lt.0) then -! when entering phase a single wildcard allowed in first sublattice - write(*,*)'Illegal parameter with wildcard mixed with cations' - gx%bmperr=7777; goto 1000 - endif - do jl=1,knr(1) - klok(jl)=kconlok(iord(jl)) - enddo - else - klok(1)=kconlok(1) - endif -! write(*,69)'1st: ',knr(1),(kalpha(mm),mm=1,knr(1)) -! check2: constituents in sublattice 1 must be ANIONS, VA and NEUTRALS -! in that order - kkk=knr(1) - jl=0 - jk=0 - ionva=0 - do nk=1,knr(2) - if(mode.eq.0 .and. kconlok(nk+kkk).lt.0) then -! when entering phase no wildcards allowed in second sublattice - write(*,*)'You cannot enter phase with wildcard on 2nd sublattice' - gx%bmperr=7777; goto 1000 - elseif(kconlok(nk+kkk).lt.0) then -! wildcard, treat as anion ?? DO NOT ALLOW, what stoichiometry?? - write(*,*)'Ionic_liq parameter with wildcard on 2nd sublat. illegal' - gx%bmperr=7777; goto 1000 -! jk=jk+1 -! anion(jk)=nk - elseif(splista(kconlok(nk+kkk))%charge.gt.zero) then - write(*,*)'No cations allowed on second sublattice' - gx%bmperr=7777; goto 1000 - elseif(btest(splista(kconlok(nk+kkk))%status,SPVA)) then -! this is the hypothetical vacancy - ionva=nk - elseif(splista(kconlok(nk+kkk))%charge.eq.zero) then -! neutral species allowed, use iva, must be sorted after all anions and Va - jl=jl+1 - iva(jl)=nk - else -! anion - jk=jk+1 - anion(jk)=nk - endif - enddo -! write(*,88)'at 1: ',knr(2),(kconlok(knr(1)+mm),mm=1,knr(2)) -88 format(a,i4,2x,20i3) -! There are jl neutrals and jk anions, if vacancies set it as jk+1 -! if wildcard on first sublattice neither ainons nor Va allowed on 2nd - if(klok(1).lt.0 .and. (jk.gt.0 .or. ionva.ne.0)) then - write(*,*)'Only neutrals on second sublattice if wildcard on first' - gx%bmperr=7777; goto 1000 - endif - do nk=1,jk - if(anion(nk).gt.nk) then -! shift the anion to position nk, kconlok must be updated - if(ionva.eq.nk) then - byte=kconlok(kkk+nk) - kconlok(kkk+nk)=kconlok(kkk+anion(nk)) - ionva=anion(nk) - kconlok(kkk+ionva)=byte -! write(*,88)'byt 1: ',knr(2),(kconlok(knr(1)+mm),mm=1,knr(2)) - else - do mm=1,jl - if(iva(mm).eq.nk) exit - enddo - if(mm.gt.jl) stop 'big bug' - byte=kconlok(kkk+nk) - kconlok(kkk+nk)=kconlok(kkk+anion(nk)) - iva(mm)=anion(nk) - kconlok(kkk+iva(mm))=byte -! write(*,88)'byt 2: ',knr(2),(kconlok(knr(1)+mm),mm=1,knr(2)) - endif - anion(nk)=nk - endif - enddo -! write(*,88)'at 2: ',knr(2),(kconlok(knr(1)+mm),mm=1,knr(2)) -! now all ions should be in positions 1..jk. Fix position of vacancy -! by moving neiutrals - if(ionva.gt.jk+1) then - byte=kconlok(kkk+jk+1) - kconlok(kkk+jk+1)=kconlok(kkk+ionva) - kconlok(kkk+ionva)=byte - iva(ionva)=ionva - ionva=jk+1 - endif -! write(*,88)'at 3: ',knr(2),(kconlok(knr(1)+mm),mm=1,knr(2)) -! write(*,69)'2nda: ',jk,& -! (splista(kconlok(kkk+anion(mm)))%alphaindex,mm=1,jk) -! if(ionva.gt.0) & -! write(*,69)'2ndv: ',1,splista(kconlok(kkk+ionva))%alphaindex -! write(*,69)'2ndn: ',jl,& -! (splista(kconlok(kkk+iva(mm)))%alphaindex,mm=1,jl) -69 format(a,i3,2x,10i3,i5,10i3) - do mm=1,knr(2) - if(kconlok(kkk+mm).lt.0) then - kalpha(mm+kkk)=-99 - else - kalpha(mm+kkk)=splista(kconlok(kkk+mm))%alphaindex - endif - enddo - kkk=knr(1)+1 -! write(*,69)'2ndx: ',knr(2),(kalpha(mm+kkk-1),mm=1,knr(2)) - if(jk.gt.1) then -! write(*,69)'kalpha: ',jk,(kalpha(kkk+mm-1),mm=1,jk) - call sortin(kalpha(kkk),jk,iord) - if(buperr.ne.0) then - gx%bmperr=buperr; goto 1000 - endif -! write(*,69)'sort jk: ',jk,(iord(kkk+mm-1),mm=1,jk) - do mm=1,jk - klok(kkk+mm-1)=kconlok(kkk+iord(mm)-1) - enddo - elseif(jk.gt.0) then - klok(kkk)=kconlok(kkk) - endif - kkk=kkk+jk - if(ionva.gt.0) then - klok(kkk)=kconlok(kkk) - kkk=kkk+1 - endif - if(jl.gt.1) then - call sortin(kalpha(kkk),jl,iord) - if(buperr.ne.0) then - gx%bmperr=buperr; goto 1000 - endif - do mm=1,jl - klok(kkk+mm-1)=kconlok(kkk+iord(mm)-1) - enddo - elseif(jl.gt.0) then - klok(kkk)=kconlok(kkk) - endif - if(mode.eq.1) then -! final check for parameters: -! if only neutrals on sublatice 2 no interaction allowed on sublattice 1 - if(jk.eq.0 .and. ionva.eq.0) then - if(knr(1).gt.1) then - write(*,*)'Illegal interaction parameter' - gx%bmperr=7777; goto 1000 - else -! replace whatever constituent specified in sublattice 1 by wildcard - klok(1)=-99 - endif - endif - endif -! write(*,69)'al1: ',knr(1)+knr(2),& -! (klok(mm),mm=1,knr(1)+knr(2)) -! write(*,69)'al2: ',knr(1)+knr(2),& -! (splista(klok(mm))%alphaindex,mm=1,knr(1)+knr(2)) -!---------------------------------------------------------- -1000 continue - return - end subroutine sort_ionliqconst - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine add_composition_set(iph,prefix,suffix,icsno) -! adds a composition set to a phase. -! iph: integer, phase index -! prefix: character*4, optional prefix to original phase name -! suffix: character*4, optional suffix to original phase name -! icsno: integer, returned composition set index (value 2-9) -! ceq: pointer, to current gtp_equilibrium_data -! -! BEWARE this must be done in all equilibria (also during parallel processes) -! There may still be problems with equilibria saved during STEP and MAP -! - implicit none - integer iph,icsno - character*(*) prefix,suffix -! TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} -! also update phasetuple array !! - TYPE(gtp_equilibrium_data), pointer :: ceq - integer lokph,ncs,nsl,nkk,lokcs,lokcs1,nprop,lastcs,jl,nyttcs - integer leq,nydis,tuple,nz - character*4 pfix,sfix - integer iva(maxconst) - TYPE(gtp_phase_varres), pointer :: peq,neq,ndeq -! - if(iph.le.0 .or. iph.gt.noofph) then - gx%bmperr=4050; goto 1000 - endif - lokph=phases(iph) - ncs=phlista(lokph)%noofcs - if(ncs.gt.8) then -! max 9 composition sets - gx%bmperr=4092; goto 1000 - endif - ceq=>firsteq - icsno=ncs+1 -! collect some data needed - nsl=phlista(lokph)%noofsubl - nkk=phlista(lokph)%tnooffr - lokcs=phlista(lokph)%linktocs(phlista(lokph)%noofcs) - lokcs1=lokcs - nprop=ceq%phase_varres(lokcs)%nprop - lastcs=phlista(lokph)%linktocs(phlista(lokph)%noofcs) -! one must set the VA bit in the constituent status array - ivaloop: do jl=1,nkk - iva(jl)=ceq%phase_varres(lastcs)%constat(jl) - enddo ivaloop -! check that prefix is empty or start with a letter - if(biglet(prefix(1:1)).ne.' ' .and. & - (biglet(prefix(1:1)).lt.'A' .or. biglet(prefix(1:1)).gt.'Z')) then - write(*,*)'Prefix of composition set must start with a letter' - gx%bmperr=4167; goto 1000 - endif - if(biglet(suffix(1:1)).ne.' ' .and. & - (biglet(suffix(1:1)).lt.'A' .or. biglet(suffix(1:1)).gt.'Z')) then - write(*,*)'Suffix of composition set must start with a letter' - gx%bmperr=4167; goto 1000 - endif -!------------------------------------------------------------------ -! begin threadprotected code >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -! composition sets must be created in all equilibria -! note that indices to phase_varres same in all equilibria -! >>> beware not tested created composition sets with several equilibria -! maybe this call can be replaced by a simple assignment???? -! call create_parrecords(lokph,nyttcs,nsl,nkk,maxcalcprop,iva,ceq) -! call create_parrecords(lokph,nyttcs,nsl,nkk,maxcalcprop,iva,firsteq) - call create_parrecords(lokph,nyttcs,nsl,nkk,maxcalcprop,iva,firsteq) - if(gx%bmperr.ne.0) goto 1000 -! write(*,*)'add_cs: ',nyttcs -! add new tuple at the end and save tuple index - tuple=nooftuples+1 - phasetuple(tuple)%phase=iph - phasetuple(tuple)%compset=icsno - nooftuples=tuple -! write(*,*)'25G Adding phase tuple: ',tuple,lastcs,nyttcs -! save index of tuple in new phase_varres record - firsteq%phase_varres(nyttcs)%phtupx=tuple -! firsteq%phase_varres(lastcs)%phtupx=tuple -! peq=>eqlista(1)%phase_varres(lastcs) - peq=>firsteq%phase_varres(lastcs) -! write(*,*)'25G added compset: ',iph,icsno,noeq() - alleq: do leq=1,noeq() -! LOOP for all equilibria records to add this composition set to phase lokph -! lastcs is the previously last composition set, nyttcs is the new, -! same in all equilibria!! - neq=>eqlista(leq)%phase_varres(nyttcs) -! write(*,19)leq,eqlista(leq)%eqno -19 format('Equilibra: ',10i4) - phlista(lokph)%linktocs(icsno)=nyttcs - neq%phlink=lokph -! prefix and suffix, only letters and digits allowed but not checked ... - pfix=prefix; sfix=suffix; call capson(pfix); call capson(sfix) - neq%prefix=pfix - neq%suffix=sfix -! tuple index - neq%phtupx=tuple -! initiate the phstate as entered (value 0) - neq%phstate=PHENTERED -! increment composition set counter when leq=1, phlista same in all equilibria - if(leq.eq.1) then - phlista(lokph)%noofcs=phlista(lokph)%noofcs+1 - endif -! write(*,311)'25G sites: ',leq,iph,icsno,neq%sites -! sites, abnorm and amount formula units - if(.not.allocated(neq%sites)) allocate(neq%sites(nsl)) - neq%sites=peq%sites - neq%abnorm=peq%abnorm - neq%amfu=zero -! write(*,311)'25G amfu: ',leq,iph,icsno,neq%amfu,neq%abnorm,peq%abnorm -311 format(a,3i3,6(1pe12.4)) -! NOTE: these allocations below because create_parrecords does not work ... -! fractions and related - nz=size(peq%yfr) - if(.not.allocated(neq%yfr)) then - allocate(neq%yfr(nz)) - neq%yfr=peq%yfr - endif - if(.not.allocated(neq%mmyfr)) then - allocate(neq%mmyfr(nz)) - neq%mmyfr=peq%mmyfr - endif - if(.not.allocated(neq%constat)) then -! important!! constat has identification of the vacancy constituent !! - allocate(neq%constat(nz)) - neq%constat=peq%constat - endif -! copy status word but clear some bits CSDEFCON means default constitution - neq%status2=peq%status2 - neq%status2=ibclr(neq%status2,CSDEFCON) -! - if(.not.allocated(neq%gval)) then -! result arrays should have been allocated in create_parrecords ... -! but I do not call create_parrecords !! -! write(*,83)'25G gval: ',leq,lokph,nyttcs,nprop,nz -83 format(a,10i4) - allocate(neq%gval(6,nprop)) - allocate(neq%dgval(3,nz,nprop)) - allocate(neq%d2gval(nz*(nz+1)/2,nprop)) - allocate(neq%listprop(nprop)) - endif -!-------------------- -! write(*,88)'25G cs: ',nz,neq%status2,neq%constat -88 format(a,i2,2x,Z16,2x,10(1x,i3)) -! if there is a disordered fraction set one must copy the fraction set record -! and add a new parrecords to this. lokcs1 is first composition set - disordered: if(btest(phlista(lokph)%status1,phmfs)) then -! copy the old fraction set record to the new -!------------------------ does this work??? disfra has a lot of data - neq%disfra=peq%disfra -!------------------------- yes it works!! -! write(*,*)'disfra 1: ',peq%disfra%ndd,neq%disfra%ndd -! write(*,*)'disfra 2: ',peq%disfra%dxidyj(2),neq%disfra%dxidyj(2) -!-------------------------------------- - nsl=peq%disfra%ndd - nkk=peq%disfra%tnoofxfr -! write(*,*)'Creating disordered fraction set 1',lokcs1,nyttcs,nkk - do jl=1,nkk - iva(jl)=ceq%phase_varres(lokcs1)%constat(jl) - enddo - if(leq.eq.1) then -! allocate a parrecord for disordered fraction set for first equilibrium. -! Then use the same index: nydis, for all other equilibria. -! Maybe this can be made by a simple assignement???? - call create_parrecords(lokph,nydis,nsl,nkk,maxcalcprop,iva,firsteq) - if(gx%bmperr.ne.0) goto 1000 - else - write(*,*)'Using the same: ',leq,lokcs1,nydis - endif - ndeq=>eqlista(leq)%phase_varres(nydis) - ndeq%phlink=lokph - ndeq%prefix=' ' - ndeq%suffix=' ' -! sites must be copied to disordered phase_varres -! write(*,*)'25G dsites: ',size(neq%disfra%dsites),size(neq%sites) - ndeq%disfra%dsites=peq%disfra%dsites -! some status bits must be set - ndeq%status2=ibset(ndeq%status2,CSDFS) - neq%status2=ibset(neq%status2,CSDLNK) -! set the link from ordered disfra record to the disordered phase_varres record - neq%disfra%varreslink=nydis - endif disordered - enddo alleq -! end threadprotected code <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -!------------------------------------------------- -! write(*,*)'Link from ordred ',lastcs,& -! ' to disordered ',ceq%phase_varres(lastcs)%disfra%varreslink -! next=ceq%phase_varres(lastcs)%next -! write(*,*)'Link from ordred ',next,& -! ' to disordered ',ceq%phase_varres(next)%disfra%varreslink -1000 continue - return -! %status2 - end subroutine add_composition_set - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine remove_composition_set(iph,force) -! the last composition set is deleted -! -! >>>>>>>>>>>>>>>>>>>>>>>>>>>> NOTE <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ! -! Not safe to remove composition sets when more than one equilibrium ! -! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ! -! -! If force is TRUE delete anyway ... very dangerous ... -! - implicit none -! -! BEWARE must be for all equilibria but maybe not allowed when threaded -! - integer iph,jl,tuple - logical force -!\end{verbatim} - TYPE(gtp_phase_varres), pointer :: varres,disvarres - integer ics,lokph,lokcs,ncs,nsl,nkk,lastcs,nprop,idisvarres,kcs,leq -! - if(iph.le.0 .or. iph.gt.noofph) then - gx%bmperr=4050; goto 1000 - endif - lokph=phases(iph) - ncs=phlista(lokph)%noofcs - if(ncs.eq.1) then -! cannot remove composition set 1 or a nonexisting one - gx%bmperr=4093; goto 1000 - else - ics=ncs - endif - if(noeq().gt.1) then - if(force) then - write(*,*)' *** WARNING: deleting composition sets may cause errors' - else - write(*,*)'Cannot delete composition sets when several equilibria' - gx%bmperr=7777; goto 1000 - endif - endif -! find this tuple - do jl=1,nooftuples - if(phasetuple(jl)%phase.eq.iph) tuple=jl - enddo -! collect some data - nsl=phlista(lokph)%noofsubl - nkk=phlista(lokph)%tnooffr - lokcs=phlista(lokph)%linktocs(ics) - lastcs=lokcs - nprop=firsteq%phase_varres(lokcs)%nprop -! write(*,*)'25G Removing varres record: ',lastcs -!------------------------------------- -! begin threadprotected code to remove lastcs >>>>>>>>>>>>>>>>>>> -! delete compset ics, shift higher down (not necessary) -! deallocate data in lokcs and return records to free list -!------------------------------------- -! note that the index to phase_varres is the same in all equilibria!!!! - alleq: do leq=1,noeq() - varres=>eqlista(leq)%phase_varres(lastcs) - deallocate(varres%constat) - deallocate(varres%yfr) - deallocate(varres%mmyfr) - deallocate(varres%sites) -! these may not be allocated ... -! write(*,*)'delete varres dsitesdy: ',leq,lokcs,size(varres%dsitesdy) -! if(size(varres%dsitesdy).gt.1) deallocate(varres%dsitesdy) -! if(size(varres%d2sitesdy2).gt.1) deallocate(varres%d2sitesdy2) - deallocate(varres%listprop) - deallocate(varres%gval) - deallocate(varres%dgval) - deallocate(varres%d2gval) -! There is a disordered fraction record .... more to deallocate - disordered: if(allocated(varres%disfra%y2x)) then - deallocate(varres%disfra%dsites) - deallocate(varres%disfra%nooffr) - deallocate(varres%disfra%splink) - deallocate(varres%disfra%y2x) - deallocate(varres%disfra%dxidyj) -! now deallocate and release the phase_varres record with disordered fractions - idisvarres=varres%disfra%varreslink - disvarres=>eqlista(leq)%phase_varres(idisvarres) -! write(*,*)'25 GDeallocationg disordered varres record ',idisvarres - deallocate(disvarres%yfr) - if(allocated(varres%mmyfr)) deallocate(varres%mmyfr) - deallocate(disvarres%sites) -! these may not be allocated ... -! write(*,*)'delete cs dsitesdy: ',leq,size(disvarres%dsitesdy) -! if(size(disvarres%dsitesdy).gt.1) deallocate(disvarres%dsitesdy) -! if(size(disvarres%d2sitesdy2).gt.1) deallocate(disvarres%d2sitesdy2) - deallocate(disvarres%listprop) - deallocate(disvarres%gval) - deallocate(disvarres%dgval) - deallocate(disvarres%d2gval) -! BOS 1401227: I do not think this is an error, just ignore ... -! if(size(disvarres%disfra%dsites).gt.0) then -! write(*,*)'ERROR, only one level of disordering allowed',leq,& -! size(disvarres%disfra%dsites) -! stop -! endif - else - idisvarres=0 - endif disordered - enddo alleq -! write(*,*)'Done all equilibrium records' -! decrement the composition set counter for this phase -! the phlista record is global, not part of the equilibria - phlista(lokph)%noofcs=phlista(lokph)%noofcs-1 -! link the released phase_varres record back to free list, -! maintained in firsteq only - if(idisvarres.ne.0) then -! there was a disordered phase_varres record, link it into free list -! write(*,*)'25G Free list 2: ',csfree,idisvarres - firsteq%phase_varres(idisvarres)%nextfree=csfree - csfree=idisvarres - endif -! link the free phase_varres into the free list -! write(*,*)'25G Free list 1: ',csfree,lastcs - firsteq%phase_varres(lastcs)%nextfree=csfree - csfree=lastcs -! finally shift all composition sets in phlista(lokph)%linktocs -! if last deleted then ics>phlista(lokph)%noofcs - do kcs=ics,phlista(lokph)%noofcs - phlista(lokph)%linktocs(kcs)=phlista(lokph)%linktocs(kcs+1) - enddo -! and zero the last pointer to composition set. - phlista(lokph)%linktocs(phlista(lokph)%noofcs+1)=0 -! write(*,*)'Free list 1: ',csfree,lokcs -! update phasetuple array, overwrite tuple. This means tuples may change phase -! NOTE the first tuple for a phase+compset will never change position. Only -! those created later may be shifted ... but that may be complicated enough ... -! write(*,*)'Shifting phase tuples above deleted: ',tuple - do jl=tuple+1,nooftuples - phasetuple(jl-1)%phase=phasetuple(jl)%phase - phasetuple(jl-1)%compset=phasetuple(jl)%compset -! we must change the link in the phase_varres record also!! - lokph=phases(phasetuple(jl-1)%phase) - lokcs=phlista(lokph)%linktocs(phasetuple(jl-1)%compset) -! write(*,*)'25G Shifting down ',jl -! in all equilibrium records, luckily the phase_varres record the same!! - do leq=1,noeq() - eqlista(leq)%phase_varres(lokcs)%phtupx=jl-1 - enddo - enddo - nooftuples=nooftuples-1 -! write(*,*)'25G Warning: phase tuples may have changed phase ...' -! end threadprotected code <<<<<<<<<<<<<<<<<<<<<<<< -!------------------------- -1000 continue - return - end subroutine remove_composition_set - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine enter_parameter(lokph,typty,fractyp,nsl,endm,nint,lint,ideg,& - lfun,refx) -! enter a parameter for a phase from database or interactivly -! typty is the type of property, 1=G, 2=TC, ... , n*100+icon MQ&const#subl -! fractyp is fraction type, 1 is site fractions, 2 disordered fractions -! nsl is number of sublattices -! endm has one constituent index for each sublattice -! constituents in endm and lint should be ordered so endm has lowest -! (done by decode_constarr) -! nint is number of interacting constituents (can be zero) -! lint is array of sublattice+constituent indices for interactions -! ideg is degree -! lfun is link to function (integer index) -! refx is reference (text) -! if this is a phase with permutations all interactions should be in -! the first or the first two identical sublattices (except interstitals) -! a value in endm can be negative to indicate wildcard -! for ionic liquid constituents must be sorted specially - implicit none - integer, dimension(*) :: endm - character refx*(*) - integer lokph,fractyp,typty,nsl,nint,ideg,lfun - integer, dimension(2,*) :: lint -!\end{verbatim} - character notext*20 - integer iord(maxsubl),jord(2,maxsubl) - integer again,kkk,ll,kk1,mint,kk,lokint,iz,it,kint,ib,jl,zz - integer lj,i1,i2,newint,ifri,lokcs,noperm,firstint - integer, dimension(24) :: intperm - integer, dimension(:,:), allocatable :: elinks - integer, dimension(:,:), allocatable :: intlinks - type(gtp_endmember), pointer :: newem,endmemrec,lastem - type(gtp_interaction), pointer :: intrec,lastint,newintrec -! type(gtp_interaction), allocatable, target :: newintrec - type(gtp_property), pointer :: proprec,lastprop - TYPE(gtp_fraction_set) :: disfra - logical ionliq -! - if(gx%bmperr.ne.0) then - write(*,*)'Error ',gx%bmperr,' already set entering enter_parameter!' - gx%bmperr=0 - endif - if(fractyp.eq.2) goto 50 -! this is for site fractions -! write(*,6)'enter_parameter 1: ',lokph,nsl,phlista(lokph)%noofsubl,nint,ideg -6 format(a,10i5) - if(nsl.ne.phlista(lokph)%noofsubl) then - gx%bmperr=4065; goto 1000 - endif - kkk=0 - jord=0 - sublloop: do ll=1,nsl - emloop: do kk=1,phlista(lokph)%nooffr(ll) - kk1=kkk+kk -! write(*,12)lokph,nsl,ll,endm(ll),kk1,phlista(lokph)%constitlist(kk1) -!12 format('enter_parameter 2A: '4I4,5x,2i5) - if(endm(ll).eq.phlista(lokph)%constitlist(kk1)) then - iord(ll)=kk1 - goto 17 - endif - enddo emloop - if(endm(ll).eq.-99) then -! wildcard, sorted at the end - iord(ll)=-99 - else -! write(*,*)'error in enter_parameter ',endm(ll) - gx%bmperr=4096; goto 1000 - endif -17 continue - kkk=kkk+phlista(lokph)%nooffr(ll) - enddo sublloop -! write(*,*)'enter_parameter 2B: ',(iord(ll),ll=1,nsl) -! if(nint.eq.2) write(*,*)'enter_parameter 2C: ************************ ' -! end member constituents found, check interaction -! interactions are in sublattice order in lint -!80 continue - mint=1 -23 continue - kkk=0 - if(mint.le.nint) then - do ll=1,nsl - if(lint(1,mint).eq.ll) then - intloop: do kk=1,phlista(lokph)%nooffr(ll) - kkk=kkk+1 -! write(*,15)mint,lint(2,mint),kkk,phlista(lokph)%constitlist(kkk) - if(lint(2,mint).eq.phlista(lokph)%constitlist(kkk)) then -! write(*,*)'enter_parameter jord: ',mint,ll,kkk -! write(*,*)'Int no, subl, const: ',mint,ll,kkk - jord(1,mint)=ll - jord(2,mint)=kkk - mint=mint+1 -! write(*,*)'enter_parameter mint1: ',mint,ll,kkk,nint - if(mint.gt.nint) goto 28 - goto 23 - endif - enddo intloop -! a constituent does not exist in sublattice ll -! write(*,16)ll,mint,lint(1,mint),lint(2,mint) - gx%bmperr=4066; goto 1000 - endif - kkk=kkk+phlista(lokph)%nooffr(ll) - enddo - endif -28 continue -! write(*,*)'enter_parameter mint2: ',mint,nint -15 format('enter_parameter x: ',4I4) -16 format('enter_parameter y: ',4I4) - if(mint.lt.nint) then -! write(*,*)'enter_parameter error: ',nint,mint,lint(1,mint),lint(2,mint) - gx%bmperr=4067; goto 1000 - endif -! write(*,33)'epar 1: ',nint,((lint(i,j),i=1,2),j=1,nint) -33 format(a,i3,' : ',3(2i3,2x)) - goto 90 -!---------------- -! code below is for disordered fraction types, use fractset record -! one could try to handle both fraction types in the same code but -! that would just make it very very messy -50 continue - if(.not.btest(phlista(lokph)%status1,PHMFS)) then -! there are no disordered fraction sets for this phase - gx%bmperr=4068; goto 1000 - endif - lokcs=phlista(lokph)%linktocs(1) - disfra=firsteq%phase_varres(lokcs)%disfra -! number of sublattices in the disordered set - if(nsl.ne.disfra%ndd) then - gx%bmperr=4069; goto 1000 - endif - kkk=0 -! write(*,*)'25G: disordered parameter: ',nsl - do ll=1,nsl - do kk=1,disfra%nooffr(ll) - kk1=kkk+kk -! write(*,12)ll,endm(ll),kk1,disfra%splink(kk1) - if(endm(ll).eq.disfra%splink(kk1)) then - iord(ll)=kk1 - goto 67 - endif - enddo - if(endm(ll).eq.-99) then -! wildcard - iord(ll)=-99 - else -! write(*,*)'in enter_parameter' - gx%bmperr=4051; goto 1000 - endif -67 continue - kkk=kkk+disfra%nooffr(ll) - enddo -! check interaction constituents - mint=1 -73 continue - kkk=0 - if(mint.le.nint) then - do ll=1,nsl - if(lint(1,mint).eq.ll) then - do kk=1,disfra%nooffr(ll) - kkk=kkk+1 - if(lint(2,mint).eq.disfra%splink(kkk)) then - jord(1,mint)=ll - jord(2,mint)=kkk -! write(*,75)mint,lint(1,mint),lint(2,mint),kkk,ll,jord(1,mint),jord(2,mint) -75 format('ep 75: ',8i4) - mint=mint+1 - if(mint.gt.nint) goto 78 - goto 73 - endif - enddo -! a constituent does not exist in sublattice ll - gx%bmperr=4066; goto 1000 - endif - kkk=kkk+disfra%nooffr(ll) - enddo - endif -78 continue - if(mint.lt.nint) then - gx%bmperr=4067; goto 1000 - endif -!--------------------------------------------------- -! we have found all constituents for the end member and interactions -! now look if there are parameter records, otherwise create them -! try to keep end member records in some order of constituents ... -90 continue -! if(fractyp.eq.2) then -! write(*,92)'25G: endmembers: ',(iord(ii),ii=1,nsl) -! write(*,92)'25G: interactions: ',(jord(2,ii),ii=1,nint) -! endif - nullify(lastem) -! check that interactions are in sublattice and alphabetical order!! - again=0 - intcheck: do lokint=2,nint - if(jord(1,lokint).lt.jord(1,lokint-1)) then - corrsubl: do iz=1,2 - it=jord(iz,lokint) - jord(iz,lokint)=jord(iz,lokint-1) - jord(iz,lokint-1)=it - enddo corrsubl - again=1 - elseif(jord(1,lokint).eq.jord(1,lokint-1)) then - if(jord(2,lokint).lt.jord(2,lokint-1)) then - it=jord(2,lokint) - jord(2,lokint)=jord(2,lokint-1) - jord(2,lokint-1)=it -! write(*,*)'interactions: ',jord(2,lokint),jord(2,lokint-1) - again=1 - elseif(jord(2,lokint).eq.jord(2,lokint-1)) then - write(*,*)'Illegal with same interaction constituent twice',& - jord(2,lokint) - gx%bmperr=77778; goto 1000 - endif - endif - enddo intcheck -! write(*,*)'Again: ',again - if(again.eq.1) goto 90 -! Make sure the endmember has the alphabetically lowest constituent -! and that the interaction is not the same as the endmember -! write(*,92)'endmembers: ',(iord(i),i=1,nsl) -92 format(a,10i4) -! write(*,92)'interactions: ',(jord(2,i),i=1,nint) - placeibloop: do kint=1,nint -! ll is the sublattice with interaction - ll=jord(1,kint) - placeib: if(jord(2,kint).eq.iord(ll)) then -! write(*,*)'pmod25G: Illegal with interaction with same constituent' -! subroutine enter_parameter(lokph,typty,fractyp,nsl,endm,nint,lint,ideg,& -! lfun,refx) - write(*,97)lokph,typty,fractyp,nsl,(endm(zz),zz=1,nsl),& - ideg,nint,(lint(1,zz),lint(2,zz),zz=1,nint) -97 format('pmod25G: Illegal with interaction with same constituent:'/& - 3i3,i4,2x,15(i5)) - gx%bmperr=7777; goto 1000 - elseif(jord(2,kint).lt.iord(ll)) then -! constituent in iord higher than that in jord, exchange jord and iord. - ib=iord(ll) - iord(ll)=jord(2,kint) - if(kint.eq.nint) then -! there are no more interactions, just put ib in the place of jord(2,kint) - jord(2,kint)=ib - else -! a bit problematic, we may have to shift constituents in jord - moreint: do mint=kint+1,nint - if(jord(1,mint).gt.ll) then -! next interaction in another sublattice, put ib in jord(2,mint-1) - jord(2,mint-1)=ib - else - shiftint: if(ib.lt.jord(2,mint)) then -! next interaction is higher, put ib in jord(2,mint-1) - jord(2,mint-1)=ib - else -! interacting constituent is lower, we must shift constituents down in jord -! It can be done one at a time?? Example: user enter: -! L(fcc,D,E,C,A,B): iord(1)='D', jord(2,*)='A', 'B', 'C', 'E' (ordered above) -! kint=1 replaces iord(1)='A'; look for the place for 'D'; ninit=4 -! loop mint=2 but 'D' is higher than 'B' so shift jord one step making -! jord(2,*)='B', 'C', 'C', 'E'; -! loop mint=3 but D is higher than 'C' so shift jord(2,*)='B', 'C', 'E', 'E'; -! Now 'D' is lesser than 'E' so place it in jord(2,3): -! jord(2,*)='B', 'C', 'D', 'E'; - jord(2,mint-1)=jord(2,mint) - if(mint.lt.nint .and. jord(1,mint+1).eq.ll) then - jord(2,mint)=jord(2,mint+1) - else - jord(2,mint)=ib - endif - endif shiftint - endif - enddo moreint - endif - endif placeib - enddo placeibloop -! there may be permutations for ordered phases ... implemented for fcc - intperm=0 - ftyp1: if(fractyp.eq.1) then - if(btest(phlista(lokph)%status1,PHFORD)) then -! These permutations may require 2 interaction records created ... - call fccpermuts(lokph,nsl,iord,noperm,elinks,nint,jord,& - intperm,intlinks) - if(gx%bmperr.ne.0) goto 1000 -! make sure iord is alphabtically ordered to find the correct parameter -! endm() are species index, iord() are constituent index (overal all subl) -! elinks are constituent index, iord(*,1) is identical to elinks(*,1) - do jl=1,nsl - iord(jl)=elinks(jl,1) - enddo - elseif(btest(phlista(lokph)%status1,PHBORD)) then - call bccpermuts(lokph,nsl,iord,noperm,elinks,nint,jord,& - intperm,intlinks) - if(gx%bmperr.ne.0) goto 1000 -! make sure iord is alphabtically ordered to find the correct parameter -! endm() are species index, iord() are constituent index (overal all subl) - do jl=1,nsl - iord(jl)=elinks(jl,1) - enddo - else - noperm=1 - endif - else -! fraction type 2 has no permutations - noperm=1 - endif ftyp1 -! parameters for site fractions - if(fractyp.eq.1) then - endmemrec=>phlista(lokph)%ordered - else - endmemrec=>phlista(lokph)%disordered - endif -! write(*,91)'enter_param 90: ',fractyp,nsl,(iord(ii),ii=1,nsl) -91 format(a,i2,i3,10i4) - ionliq=btest(phlista(lokph)%status1,PHIONLIQ) - findem: do while(associated(endmemrec)) - if(.NOT.ionliq) then - lika:do lj=1,nsl -! iord(lj) can be negative for wildcard. Wildcard endmedmemers at the end - i1=iord(lj) - i2=endmemrec%fraclinks(lj,1) - if(i1.gt.0) then - if(i2.lt.0 .or. i1.lt.i2) then -! The new end member record should be inserted before this record - goto 100 - elseif(i1.gt.i2) then -! continue searching for the end member or place to create it - lastem=>endmemrec - endmemrec=>endmemrec%nextem - cycle findem - endif -! here i1<0 - elseif(i2.gt.0) then -! continue searching for the end member or place to create it - lastem=>endmemrec - endmemrec=>endmemrec%nextem - cycle findem - endif -! It is the same "wildcard" value if both i1 and i2 are negative - enddo lika - else -! for ionic liquids insert endmembers in order of second sublattice ... -! This is important as we want to calculate all parameters with anions -! before we come to vacancy and neutrals which should be multiplied with Q - illika:do lj=nsl,1,-1 -! iord(lj) can be negative for wildcard. Wildcard endmedmemers at the end - i1=iord(lj) - i2=endmemrec%fraclinks(lj,1) - if(i1.gt.0) then - if(i2.lt.0 .or. i1.lt.i2) then -! The new end member record should be inserted before this record - goto 100 - elseif(i1.gt.i2) then -! continue searching for the end member or place to create it - lastem=>endmemrec - endmemrec=>endmemrec%nextem - cycle findem - endif -! here i1<0 - elseif(i2.gt.0) then -! continue searching for the end member or place to create it - lastem=>endmemrec - endmemrec=>endmemrec%nextem - cycle findem - endif -! It is the same "wildcard" value if both i1 and i2 are negative - enddo illika - endif -!------------------------------------------------- -! found end member record with same constituents - goto 200 - enddo findem -! -! -100 continue -! we have not found any endmember record so we have to insert a record here -! lokem may be nonzero if we exited from findem loop to this label - call create_endmember(lokph,newem,noperm,nsl,iord,elinks) -! write(*,*)'enter_par: created endmember ',new - if(gx%bmperr.ne.0) goto 1000 -! insert link to new from last end member record, lastem. - if(.not.associated(lastem)) then - if(fractyp.eq.1) then - phlista(lokph)%ordered=>newem - else - phlista(lokph)%disordered=>newem - endif - else -! emlista(lastem)%next=new - lastem%nextem=>newem - endif -! insert link from new to next (if lokem=0 this record is the last) - newem%nextem=>endmemrec - endmemrec=>newem -!--------------------------------------------------- -! Here we have found or created the endmember record -! look for or create interaction record, no wildcards in interactions -! Interacting elements should be in sublattice and alphabetical order!! -200 continue -! write(*,*)'enter_parameter mint3: ',mint,nint - lokint=0 - someint: if(nint.gt.0) then -! when there are interaction records the ideal bit must be cleared - phlista(lokph)%status1=ibclr(phlista(lokph)%status1,PHID) -! to locate interaction record, - nullify(lastint) - mint=1 - intrec=>endmemrec%intpointer -! write(*,202)'enter_parameter 12A: ',lokph,typty,nsl,ideg,typty,lokem,& -! (lint(1,i),i=1,nint),(lint(2,i),i=1,nint) -202 format(/a,7i4,4x,10i4) - if(.not.associated(intrec)) then -! no interaction record for this endmember, create one - call create_interaction(newintrec,mint,jord,intperm,intlinks) - if(gx%bmperr.ne.0) goto 1000 -! write(*,*)'created interaction 9:',mint,nint - endmemrec%intpointer=>newintrec - intrec=>newintrec - lastint=>intrec -! mint=mint+1 - newint=1 -! write(*,*)'created interaction: ',newint,mint - else -! write(*,*)'existing interaction: ',intrec%status - newint=0 - firstint=0 - endif -300 continue -! write(*,303)' at 300A: ',lokph,newint,nint,mint,intrec%status -303 format(a,10i3) -! interaction records should be ordered according to the sublattice -! with the interaction. For interaction with permutations use the -! sublattice of the first permutation - findint: do while(mint.le.nint) -! write(*,*)'At findint: ',mint,nint,newint - if(intrec%sublattice(1).eq.jord(1,mint) .and. & - intrec%fraclink(1).eq.jord(2,mint)) then -! found an interaction with same constituent (maybe just created) - if(mint.eq.nint) then -! write(*,*)'same interaction, level: ',mint - goto 400 - endif - lastint=>intrec - intrec=>intrec%highlink - mint=mint+1 - newint=1 - if(.not.associated(intrec)) exit findint - else - if(mint.eq.nint) then -! error when storing permutations because newint=0 below. Moved it to the end -! but that gave error L(liq,C,Cr,V) was stored as L(Liq,C,Cr,Fe,V) -! Add a check on mint, if mint=nint one cannot store it as higher - newint=0 - endif -! we must store interactions in sublattice order and in order of constituent -! in jord(2,mint) otherwise we will never be able to find a permutation. - if(intrec%sublattice(1).gt.jord(1,mint)) then -! write(*,*)'insering interaction before existing' - exit findint - endif - lastint=>intrec - intrec=>intrec%nextlink - if(.not.associated(intrec)) exit findint - firstint=1 -! more records on this interaction level ? -! this worked for permutations but gave other errors, see above -! newint=0 - endif - enddo findint -! we can be here either because mint>nint or no more interaction records -! we must create at least one interactionrecord, newint=0 if same level -! If intrec is associated the nextint link should be set to this -310 continue -! write(*,*)'At 310',mint,nint - if(mint.le.nint) then -! write(*,303)' Linking at 310:',mint,nint,newint,firstint - call create_interaction(newintrec,mint,jord,intperm,intlinks) - if(gx%bmperr.ne.0) goto 1000 - if(newint.eq.1) then -! write(*,*)'Linking as higher' - lastint%highlink=>newintrec - elseif(associated(intrec)) then -! write(*,*)'Linking as previous' - newintrec%nextlink=>intrec -! write(*,*)'Ho ho said the sixth' - if(associated(lastint)) then - lastint%nextlink=>newintrec - else -! this should be linked from the endmember or lower order interaction -! write(*,*)'No previous interaction on this level' - endmemrec%intpointer=>newintrec - endif -! write(*,*)'Ho ho said the sixth' - else -! write(*,*)'Linking as next' - lastint%nextlink=>newintrec - endif -! redundant as newint set to 1 below ... -! newint=0 - intrec=>newintrec - lastint=>intrec - mint=mint+1 -! there may be more interaction records .... but they must all be created - newint=1 - goto 310 - endif -! Now we should have found or created the interaction record, -! check property list -400 continue - proprec=>intrec%propointer - if(.not.associated(proprec)) then - call create_proprec(intrec%propointer,typty,ideg,lfun,refx) - else - goto 800 - endif -! write(*,*)'enter_parameter 17: ',lokint,lokem,link - else -! Found endmember and there is no interaction, search the property list, -! there may not be any property! - proprec=>endmemrec%propointer - if(.not.associated(proprec)) then - call create_proprec(endmemrec%propointer,typty,ideg,lfun,refx) - else - goto 800 - endif - endif someint -! all done - goto 1000 -! we found parameter record with a property, now search property list -800 continue - do while(associated(proprec)) - lastprop=>proprec - if(proprec%proptype.eq.typty) then -! found property record, one should delete old and insert new function -! one must alse change the reference !!! And add the reference if new. -! mode=0 means no change of reference text if reference already exists - call capson(refx) - notext='*** Not set by user' - call tdbrefs(refx,notext,0,ifri) - if(ideg.le.proprec%degree) then - proprec%degreelink(ideg)=lfun - proprec%reference=refx - else - call extend_proprec(proprec,ideg,lfun) - proprec%reference=refx - endif - goto 1000 - endif - proprec=>proprec%nextpr - enddo -! no record for this property present, add a new property record - call create_proprec(lastprop%nextpr,typty,ideg,lfun,refx) -! all done and go home -1000 continue - if(gx%bmperr.eq.0) then -! mark that the phase has at least one parameter - phlista(lokph)%status1=ibset(phlista(lokph)%status1,PHHASP) - endif -! write(*,*)'enter_parameter 99: ',gx%bmperr -! write(*,888)'enter_parameter 77: ',(phlista(lokph)%constitlist(i),i=1,6) -888 format(A,6I3) - return - end subroutine enter_parameter - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine fccpermuts(lokph,nsl,iord,noperm,elinks,nint,jord,intperm,intlinks) -! finds all fcc/hcp permutations needed for this parameter -! The order of elements in the sublattices is irrelevant when one has F or B -! ordering as all permutations are stored in one place (with some exceptions) -! Thus the endmembers are ordered alphabetically in the sublattices and also -! the interaction parameters. Max 2 levels of interactions allowed. - implicit none - integer, dimension(*) :: iord,intperm - integer, dimension(2,*) :: jord - integer lokph,nsl,noperm,nint -!\end{verbatim} %+ - integer l2,ll,ib,again,clink,lshift,mshift,a211 - integer odd,inz,ip,iqq1,iqq2,isp,jb,jp,jsp,l3,level1,level2 - integer level2perm,lj,loksp,lsp,niqq1,nl1,nl2,nll,np,nq,nz - integer, dimension(4) :: elal,esame - integer, dimension(:,:), allocatable :: elinks - integer, dimension(:,:), allocatable :: intlinks - logical notsame - character carr*64 -! integer, dimension(3) :: esame -! -!------------------------------------------------------------------- -! -! This is a very long and messy subroutine and it calls others that are -! equally complicated. It is important it is understandable and correct, -! all possible cases has not been tested. Do not try to simplify it by making -! it more messy, this subroutine is not important for calculating speed -! but the structure it creates is important for speed. -! The corresponing routine for bcc permutations is even worse ... -! -!------------------------------------------------------------------- -! -! if(nint.eq.2) then -! write(*,501)'fccpermuts1: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2) -! endif -! I assume the ordering is in the first 4 sublattices, that could be changed - if(nsl.lt.4) then - write(*,*)'There must be at least 4 sublattices for fcc/hcp option' - gx%bmperr=7777; goto 1000 - endif - if(nint.gt.2) then - write(*,*)'Maximum 2nd level interaction with option F' - gx%bmperr=7777; goto 1000 - endif -! rearrange constituents in alphabetcal order in the sublattices, -! change interactions also! -! write(*,11)'fp1: ',(iord(i),i=1,4),nint,((jord(j,k),j=1,2),k=1,nint) -11 format(a,4i4,' interactions: ',i2,4i4) - do l2=1,4 - if(iord(l2).gt.0) then - loksp=phlista(lokph)%constitlist(iord(l2)) - elal(l2)=splista(loksp)%alphaindex - else - elal(l2)=iord(l2) - endif - enddo -! write(*,11)'fp2: ',(elal(i),i=1,4),nint,((jord(j,k),j=1,2),k=1,nint) - again=1 - lagain: do while(again.ne.0) -! yet another messy sorting - again=0 - do l2=1,3 - do ll=l2+1,4 - equal: if(elal(ll).lt.elal(ll-1)) then - again=1 - ib=elal(ll) - elal(ll)=elal(ll-1) - elal(ll-1)=ib -! write(*,*)'call 1',ll-1,elal(ll-1) - call findconst(lokph,ll-1,elal(ll-1),iord(ll-1)) - if(gx%bmperr.ne.0) goto 1000 -! write(*,*)'call 2',ll,elal(ll) - call findconst(lokph,ll,elal(ll),iord(ll)) - if(gx%bmperr.ne.0) goto 1000 -! if there are interacting constituents in ll or ll-1 shift them also - do lj=1,nint - if(jord(1,lj).eq.ll) then -! write(*,21)'fpi1: ',lj,jord(1,lj),jord(2,lj) -21 format(a,i2,2i4) - jord(1,lj)=ll-1 - loksp=phlista(lokph)%constitlist(jord(2,lj)) - ib=splista(loksp)%alphaindex -! write(*,*)'call 3',ll-1,ib - call findconst(lokph,ll-1,ib,jord(2,lj)) - if(gx%bmperr.ne.0) goto 1000 -! write(*,21)'fpi2: ',lj,jord(1,lj),jord(2,lj) - elseif(jord(1,lj).eq.ll-1) then -! write(*,21)'fpi3: ',lj,jord(1,lj),jord(2,lj) - jord(1,lj)=ll - loksp=phlista(lokph)%constitlist(jord(2,lj)) - ib=splista(loksp)%alphaindex -! write(*,*)'call 4',ll,ib - call findconst(lokph,ll,ib,jord(2,lj)) - if(gx%bmperr.ne.0) goto 1000 -! write(*,21)'fpi4: ',lj,jord(1,lj),jord(2,lj) - else -! write(*,23)'No interactions in sublattice: ',jord(1,lj) -23 format(a,2i3) - endif - enddo - endif equal - enddo - enddo - enddo lagain -! elements are now ordered in alphabetical order over the sublattices -! find how many equal -! if(nint.eq.2) then -! write(*,501)'fccpermuts2A: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2) -! endif - esame=0 - ib=1 - esame(ib)=1 - do ll=2,4 - if(elal(ll).eq.elal(ll-1)) then - esame(ib)=esame(ib)+1 - else - ib=ib+1 - esame(ib)=1 - endif - enddo - if(jord(1,1).ne.jord(1,2)) then -! we can have a case AX:AY:A:A and it should not be changed to AXY:A:A:A - notsame=.true. - else - notsame=.false. - endif -! we must rearrange interactions so they are in the first sublattice with -! the same endmember element for each level separately -! This is probably redundant as decode_constarr also sorts - do l2=1,nint - ib=elal(jord(1,l2)) - do ll=1,jord(1,l2)-1 - if(elal(ll).eq.ib) then -! write(*,*)'Shifting interacting constituent to sublattice: ',ll - nll=ll - if(l2.eq.2 .and. notsame) then -! if interactions should not be in same sublattice but with the same element -! in the endmember, increment ll to interact in next sublattice. It should -! be the same endmember constituent there! - if(ll.eq.jord(1,1)) nll=ll+1 -! write(*,*)'nll: ',ll,nll - endif - jord(1,l2)=nll - loksp=phlista(lokph)%constitlist(jord(2,l2)) - ib=splista(loksp)%alphaindex -! write(*,*)'call 5',nll,ib - call findconst(lokph,nll,ib,jord(2,l2)) - if(gx%bmperr.ne.0) goto 1000 - endif - enddo - enddo -! if(nint.eq.2) then -! write(*,501)'fccpermuts2B: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2) -! endif -! write(*,11)'fp3: ',(elal(i),i=1,4),nint,((jord(j,k),j=1,2),k=1,nint) -! write(*,11)'fp4: ',(iord(i),i=1,4) -! make sure that any interaction is connected to the first possible endmember -! for example A:A,B:B:B should be changed to A,B:A:B:B -! Also A,C:A,B:A:A should be A,B:A,C:A:A to have a unique record - do l2=1,nint - lj=jord(1,l2) - do ll=1,lj-1 -! ll must be less than 4 in this loop - equalem: if(elal(ll).eq.elal(lj)) then - if(l2.eq.1 .or. .not.notsame) then - jord(1,l2)=ll - loksp=phlista(lokph)%constitlist(jord(2,l2)) - ib=splista(loksp)%alphaindex -! write(*,*)'call 6',ll,ib - call findconst(lokph,ll,ib,jord(2,l2)) - if(gx%bmperr.ne.0) goto 1000 - else -! l2 must be 2 here, i.e. second order interaction - loksp=phlista(lokph)%constitlist(jord(2,1)) - ib=splista(loksp)%alphaindex - loksp=phlista(lokph)%constitlist(jord(2,2)) - jb=splista(loksp)%alphaindex - if(jb.lt.ib) then -! change them so the lowest constituent comes first in sublattice order -! write(*,*)'call 7',ll,jb - call findconst(lokph,ll,jb,jord(2,1)) - if(gx%bmperr.ne.0) goto 1000 -! write(*,*)'call 8',lj,ib - call findconst(lokph,lj,ib,jord(2,2)) - if(gx%bmperr.ne.0) goto 1000 -! write(*,*)'exchange: ',ib,jb,jord(2,1),jord(2,2) - else -! The interactions should not be in same sublattice, the next sublattice -! must have the same endmember constituent as jord(1,1), put it there - if(ll.eq.jord(1,1)) then - nll=ll+1 - else - nll=ll - endif - jord(1,l2)=nll - loksp=phlista(lokph)%constitlist(jord(2,l2)) - ib=splista(loksp)%alphaindex -! write(*,*)'call 9',nll,ib - call findconst(lokph,nll,ib,jord(2,l2)) - if(gx%bmperr.ne.0) goto 1000 - endif - endif - endif equalem - enddo - enddo -! if(nint.eq.2) then -! write(*,501)'fccpermuts2C: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2) -! endif -!-------------------------------- -! now we can calculate the number of endmember permutations -! Generate also all endmember links in elinks to be stored in endmember record - lshift=phlista(lokph)%nooffr(1) - if(esame(1).eq.4) then -! all 4 equal - noperm=1 - allocate(elinks(nsl,noperm)) - do ll=1,nsl - elinks(ll,1)=iord(ll) - enddo - elseif(esame(1).eq.3) then -! first 3 equal, one different: A:A:A:B; A:A:B:A; A:B:A:A; B:A:A:A - noperm=4 - allocate(elinks(nsl,noperm)) - do np=1,noperm - do ll=1,nsl - elinks(ll,np)=iord(ll) - enddo - if(np.lt.4) then -! shift the single different element forward step by step - ib=iord(4-np)+lshift - iord(4-np)=iord(5-np)-lshift - iord(5-np)=ib - endif - enddo - elseif(esame(1).eq.2) then - if(esame(2).eq.2) then -! the two first equal and also last two: A:A:B:B -! A:B:A:B; A:B:B:A; B:A:B:A; B:B;A:A; B:A:A:B -! I have no idea how to make this into a loop so I handle each separately - noperm=6 - allocate(elinks(nsl,noperm)) - np=1 - do ll=1,nsl - elinks(ll,np)=iord(ll) - enddo -! shift sublattice 2 and 3: A:B:A:B - ib=iord(2)+lshift - iord(2)=iord(3)-lshift - iord(3)=ib - np=np+1 - do ll=1,nsl - elinks(ll,np)=iord(ll) - enddo -! shift sublattice 3 and 4: A:B:B:A - ib=iord(3)+lshift - iord(3)=iord(4)-lshift - iord(4)=ib - np=np+1 - do ll=1,nsl - elinks(ll,np)=iord(ll) - enddo -! shift sublattice 1 and 2: B:A:B:A - ib=iord(1)+lshift - iord(1)=iord(2)-lshift - iord(2)=ib - np=np+1 - do ll=1,nsl - elinks(ll,np)=iord(ll) - enddo -! shift sublattice 2 and 3: B:B:A:A - ib=iord(2)+lshift - iord(2)=iord(3)-lshift - iord(3)=ib - np=np+1 - do ll=1,nsl - elinks(ll,np)=iord(ll) - enddo -! shift sublattice 2 and 4 (double lenght): B:A:A:B - ib=iord(2)+2*lshift - iord(2)=iord(4)-2*lshift - iord(4)=ib - np=np+1 - do ll=1,nsl - elinks(ll,np)=iord(ll) - enddo - else -! the first two equal and last 2 different: A:A:B:C - a211=1 - noperm=12 - allocate(elinks(nsl,noperm)) - call fccpe211(1,elinks,nsl,lshift,iord) - endif - elseif(esame(2).eq.3) then -! first different and last 3 equal: A:B:B:B; B:A:B:B; B:B:A:B; B:B:B:A - noperm=4 - allocate(elinks(nsl,noperm)) - do np=1,noperm - do ll=1,nsl - elinks(ll,np)=iord(ll) - enddo - if(np.lt.4) then -! shift the single different element backward step by step - ib=iord(np)+lshift - iord(np)=iord(np+1)-lshift - iord(np+1)=ib - endif - enddo - elseif(esame(2).eq.2) then -! two equal but first and last different - a211=2 - noperm=12 - allocate(elinks(nsl,noperm)) - call fccpe211(2,elinks,nsl,lshift,iord) - elseif(esame(3).eq.2) then -! first two different but last two equal - a211=3 - noperm=12 - allocate(elinks(nsl,noperm)) - call fccpe211(3,elinks,nsl,lshift,iord) - else -! all 4 different - noperm=24 - allocate(elinks(nsl,noperm)) - call fccpe1111(elinks,nsl,lshift,iord) - endif -! always skip debug output of endmembers for interaction parameters - intperm(1)=0 -! if(nint.eq.2) then -! write(*,501)'fccpermuts3: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2) -! endif - if(nint.gt.0) goto 200 -! comment next line to have debug output -! goto 200 -!-------------------- -! debug output of endmembers after rearranging - carr='fp6: ' - ib=6 - l3=1 - do ll=1,4 - if(elal(ll).gt.0) then - l2=len_trim(splista(species(elal(ll)))%symbol) - write(carr(ib:),16)splista(species(elal(ll)))%symbol(1:l2) -16 format(a) - ib=ib+l2 - else - carr(ib:)='*' - ib=ib+1 - endif -17 continue - if(l3.le.nint) then - if(jord(1,l3).eq.ll) then - loksp=phlista(lokph)%constitlist(jord(2,l3)) - l2=len_trim(splista(loksp)%symbol) - write(carr(ib:),18)splista(loksp)%symbol(1:l2) -18 format(',',a) - ib=ib+l2+1 - l3=l3+1 - goto 17 - endif - endif - if(ll.lt.4) carr(ib:ib)=':' - ib=ib+1 - enddo -! write(*,19)carr(1:ib) -! write(*,19)'fp7: ',esame,noperm -19 format(a,4i3,i5) -! More debug output: all endmember permutations - do np=1,noperm -! listing indices in constituent list (stored in endmember record) -! write(*,31)np,(elinks(ll,np),ll=1,nsl) -31 format('elinks: ',i3,3x,10i4) - enddo - do np=1,noperm -! Easier to check listing of permutations using constituent names - carr=' ' - ib=1 - do ll=1,nsl - if(elinks(ll,np).gt.0) then - loksp=phlista(lokph)%constitlist(elinks(ll,np)) - l2=len_trim(splista(loksp)%symbol) - write(carr(ib:),32)splista(loksp)%symbol(1:l2) -32 format(a,':') - ib=ib+l2+1 - else - carr(ib:)='*:' - ib=ib+2 - endif - enddo -! write(*,33)np,carr -33 format('emperm ',i3,': ',a) - enddo -! debug output of endmembers end -!-------------------- -200 continue -! done arranging component array and permutations of endmembers - if(nint.eq.0) then - goto 1000 - endif -!=============================================== -! Now the 1st level interactions ... store in intlinks(1..2) - allocate(intlinks(2,100)) -! intperm(1)=number of interaction permutations on level 1 for each endmember -! on level 1 each endmember perumtation has the same -! intperm(2)=total number of permutation links for level 1 -! intperm(3..) used for 2nd level - select case(noperm) - case default ! error - write(*,*)'Unknown case for endmemeber permutations: ',noperm - gx%bmperr=7777 -!---------- - case(1) ! A:A:A:A -! if(nint.eq.2) then -! write(*,501)'fccpermuts4: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2) -! endif - if(jord(1,1).ne.1) then - write(*,*)'Interaction must be in sublattice 1' - gx%bmperr=7777; goto 1000 - endif - intperm(1)=4 - intperm(2)=4 - clink=jord(2,1) -! set links to interaction with same element in all 4 sublattices - do l2=1,4 - intlinks(1,l2)=l2 - intlinks(2,l2)=clink - clink=clink+lshift - enddo - level1=1 -!---------- - case(4) ! A:A:A:B and A:B:B:B - if(esame(1).eq.3) then - if(jord(1,1).eq.1) then -! the interaction must be AX:A:A:B - call fccint31(jord,lshift,intperm,intlinks) - level1=2 - else -! the interaction must be A:A:A:BX - intperm(1)=1 - intperm(2)=4 - intlinks(1,1)=4 - intlinks(2,1)=jord(2,1) - do ll=2,4 - intlinks(1,ll)=5-ll - intlinks(2,ll)=intlinks(2,ll-1)-lshift - enddo - level1=3 - endif - elseif(jord(1,1).eq.2) then -! the interaction must be A:BX:B:B - call fccint31(jord,lshift,intperm,intlinks) - level1=4 - else -! the interaction must be AX:B:B:B - intperm(1)=1 - intperm(2)=4 - intlinks(1,1)=1 - intlinks(2,1)=jord(2,1) - do ll=2,4 - intlinks(1,ll)=ll - intlinks(2,ll)=intlinks(2,ll-1)+lshift - enddo - level1=5 - endif -!---------- - case(6) ! A:A:B:B - call fccint22(jord,lshift,intperm,intlinks) - level1=6 -!---------- - case(12) ! A:A:B:C; A:B:B:C; A:B:C:C - if(a211.eq.jord(1,1)) then - call fccint211(a211,jord,lshift,intperm,intlinks) - level1=7 - else -! interaction with one of the single constituents -! a single permutation follows the single different element in 4 sublattices -! starting from sublattice 1. There are 12 enemember permutations - intperm(1)=1 -! intperm(2)=12 - intperm(2)=noperm - l2=jord(1,1) - ib=phlista(lokph)%constitlist(elinks(l2,1)) - intlinks(1,1)=jord(1,1) - intlinks(2,1)=jord(2,1) - do ll=2,noperm - do l3=1,4 - jb=phlista(lokph)%constitlist(elinks(l3,ll)) - if(jb.eq.ib) goto 410 - enddo - write(*,*)'Cannot find endmember element for premutation ',ll,ib - gx%bmperr=7777; goto 1000 -410 continue - intlinks(1,ll)=l3 - mshift=(intlinks(1,ll)-intlinks(1,ll-1))*lshift - intlinks(2,ll)=intlinks(2,ll-1)+mshift -! write(*,422)ll,l3,jord(1,1),mshift,intlinks(1,ll),intlinks(2,ll) - enddo - level1=8 - endif -!---------- - case(24) ! A:B:C:D - write(*,77) -77 format(' *** CONGRATULATIONS, '/& - ' You must be the first to enter a parameter like this!!!') - intperm(1)=1 - intperm(2)=noperm - l2=jord(1,1) -! species number in endmember of interacting sublattice - ib=phlista(lokph)%constitlist(elinks(l2,1)) - intlinks(1,1)=l2 - intlinks(2,1)=jord(2,1) - do ll=2,24 - do l3=1,4 - jb=phlista(lokph)%constitlist(elinks(l3,ll)) - if(jb.eq.ib) goto 420 -! write(*,419)'elinks,ib: ',ll,l3,ib,jb,elinks(l3,ll) -!419 format(a,2i4,2x,3i4) - enddo - write(*,*)'Cannot find endmember element for premutation ',ll,ib - gx%bmperr=7777; goto 1000 -420 continue - intlinks(1,ll)=l3 - mshift=(intlinks(1,ll)-intlinks(1,ll-1))*lshift - intlinks(2,ll)=intlinks(2,ll-1)+mshift -! write(*,422)ll,l3,jord(1,1),mshift,intlinks(1,ll),intlinks(2,ll) -422 format('spec: ',3i3,2x,i10,2x,2i10) - enddo - level1=9 - end select -500 continue - if(nint.eq.1) goto 900 -!================================================================ -! 2nd level interaction permutations -! write(*,*)'First level interaction type: ',level1 -! write(*,502)' elinks and jord: ',elal,((jord(i,j),i=1,2),j=1,2) -501 format(a,2(2i4,2x)) -502 format(a,4(i4),' : ',2(2i4,2x)) -! -! The simplest 2nd level interaction is in the same sublattice as first - if(jord(1,2).eq.jord(1,1)) then -! AXY:B:C:D where X and Y are two different constituents (not A) and B, C, D -! can be any constituents. There are no new permutations, just add Y -! write(*,*)'shortcut' - intperm(3)=1 - intperm(4)=1 - nz=intperm(2) - loksp=phlista(lokph)%constitlist(jord(2,2)) - isp=splista(loksp)%alphaindex - do np=1,intperm(2) - intlinks(1,nz+np)=intlinks(1,np) - call findconst(lokph,intlinks(1,np),isp,intlinks(2,nz+np)) - if(gx%bmperr.ne.0) goto 1000 - enddo -! for debug output - goto 900 - endif -!----------------------------------------------------------- - select case(level1) - case default !error - write(*,*)'Unknown case for permutations on level 1: ',level1 - gx%bmperr=7777 -!----------------------------------------------------------- - case(1) ! AXY:A:A:A or AX:AX:A:A or AX:AY:A:A - call fccip2A(lokph,jord,intperm,intlinks) - if(gx%bmperr.ne.0) goto 1000 -!----------------------------------------------------------- - case(2) ! AXY:A:A:B or AX:AY:A:B or AX:A:A:BY -! write(*,*)'case 2: ',jord(1,2),jord(2,2) - if(jord(1,2).eq.4) then -! AX:A:A:BY, there should be 12 permutations, no new on second level - intperm(3)=1 - intperm(4)=1 - intperm(5)=12 - nz=intperm(2) - loksp=phlista(lokph)%constitlist(jord(2,2)) - isp=splista(loksp)%alphaindex - do np=1,4 -! sublattice for B the same for 3 permutations - do nq=1,3 - nz=nz+1 - intlinks(1,nz)=5-np - call findconst(lokph,5-np,isp,intlinks(2,nz)) - if(gx%bmperr.ne.0) goto 1000 - enddo - enddo - else -! AX:AY:A:B - call fccip2B(1,lokph,lshift,jord,intperm,intlinks) - if(gx%bmperr.ne.0) goto 1000 - endif -!----------------------------------------------------------- - case(3) ! A:A:A:BXY -! never hase as taken care by shortcut above - if(jord(1,2).ne.jord(1,1)) then - write(*,*)'Thinking error, restructure!' - gx%bmperr=7777; goto 1000 - endif -!----------------------------------------------------------- - case(4) ! A:BXY:B:B or A:BX:BY:B; no AY:BX:B:B as that would be case 5 -! A:BX:BY:B - call fccip2B(2,lokph,lshift,jord,intperm,intlinks) - if(gx%bmperr.ne.0) goto 1000 -!----------------------------------------------------------- - case(5) ! AX:BY:B:B -! This parameter has just 4 endmember permutations. On this level 3 more -! AX:B:B:B AX:BY:B:B AX:B:BY:B AX:B:B:BY -! B:AX:B:B B:AX:BY:B B:AX:B:BY BY:AX:B:B etc - intperm(3)=1 - intperm(4)=3 - intperm(5)=12 - loksp=phlista(lokph)%constitlist(jord(2,2)) - isp=splista(loksp)%alphaindex - nz=intperm(2) - do np=1,4 - nll=intlinks(1,np) - do ip=1,3 - nz=nz+1 - nll=nll+1 - if(nll.gt.4) nll=1 - intlinks(1,nz)=nll - call findconst(lokph,nll,isp,intlinks(2,nz)) - if(gx%bmperr.ne.0) goto 1000 - enddo - enddo -! endif -!----------------------------------------------------------- -! This is the important one as it includes the reciprocal excess parameter - case(6) ! AX:A:B:B or A:A:BX:B, 6 endmem and 2 level 1 permutations = 12 -! AX:A:B:B: AX:AX:B:B: 1; 0 totally 6 permutations -! AX:A:B:B: AX:AY:B:B and AY:AX:B:B; 2 additional permutations, totally 24 - loksp=phlista(lokph)%constitlist(jord(2,2)) - jsp=splista(loksp)%alphaindex - if(abs(jord(1,2)-jord(1,1)).gt.1) then -! level 2 interaction with another endmember constituent than level 1 -! AX:A:BY:B; 2 additional permutations, totally 24 -! The endmember permutations will put element B in sublattices: -! 3,4; 2,4; 2,3; 1,3; 1,2; 1,4; If that changes this must be changed too ... - intperm(3)=1 - intperm(4)=2 - intperm(5)=24 - nz=intperm(2) - nl1=3 - nl2=4 - do ip=1,6 - nz=nz+1 - intlinks(1,nz)=nl1 - call findconst(lokph,nl1,jsp,intlinks(2,nz)) - if(gx%bmperr.ne.0) goto 1000 - nz=nz+1 - intlinks(1,nz)=nl2 - call findconst(lokph,nl2,jsp,intlinks(2,nz)) - if(gx%bmperr.ne.0) goto 1000 - nz=nz+1 - intlinks(1,nz)=nl1 - call findconst(lokph,nl1,jsp,intlinks(2,nz)) - if(gx%bmperr.ne.0) goto 1000 - nz=nz+1 - intlinks(1,nz)=nl2 - call findconst(lokph,nl2,jsp,intlinks(2,nz)) - if(gx%bmperr.ne.0) goto 1000 - select case(nl1) - case default - write(*,*)'Error in fccpermut, case(lavel1=6), case(nl1)' - gx%bmperr=7777; goto 1000 - case(1) ! change nl2 to 2 or 4, nl1 should be 1 - if(nl2.eq.2) nl2=4 - if(nl2.eq.3) nl2=2 - case(2) ! change nl2 to 3 - if(nl2.eq.3) then - nl1=1 - nl2=3 - else - nl2=3 - endif - case(3) ! change nl1 to 2 - nl1=2 - end select - enddo - else -! interaction with same endmember element in 2 different sublattices -! write(*,*)'smart?' - loksp=phlista(lokph)%constitlist(jord(2,1)) - isp=splista(loksp)%alphaindex - if(isp.eq.jsp) then -! AX:AX:B:B or A:A:BX:BX, there are 12 permutations of AX:A:B:B on level 1 -! but there are only 6 second level interactions -! The endmember permutations will put element A in sublattices: -! 1,2; 1,3; 1,4; 2,4; 3,4; 2,3; and element B in sublattices: -! 3,4; 2,4; 2,3; 1,3; 1,2; 1,4; - intperm(3)=2 - intperm(4)=1 - intperm(5)=0 - intperm(6)=6 - nz=intperm(2) - if(jord(1,1).eq.1) then - nll=2 - else - nll=4 - endif - odd=1 - do np=1,12 - odd=1-odd - do jp=1,intperm(4+odd) -! this loop is done 1 or 0 times twice; nll=2,3,4; 4,4,3 // 4,4,3; 3,2,4 - nz=nz+1 - intlinks(1,nz)=nll - call findconst(lokph,nll,jsp,intlinks(2,nz)) - if(gx%bmperr.ne.0) goto 1000 -! nz= 13,14,15,16,17,18,19 -! nll= 2, 3, 4, 4, 4, 3, - if jord(1,1)=1 -! nll= 4, 4, 3, 3, 2, 4, - if jord(1,1)=2 - select case(nz) - case default - write(*,*)'Error in fccpermut, case(lavel1=6), nz=',nz - gx%bmperr=7777; goto 1000 - case(13) ! change nll to 3 if 2, else same - if(nll.eq.2) nll=3 ! 3 or same - case(14) -! the if .., -! if(nll.eq.4) then -! nll=3 -! else -! nll=4 -! endif -! is same as nll=7-nll - nll=7-nll - case(15,18) ! no change!! - continue - case(16) - if(nll.eq.3) nll=2 - case(17) - if(nll.eq.4) nll=3 - if(nll.eq.2) nll=4 - end select - enddo - enddo -! if the case and loops above works they are smart and easy to understand ??? - else -! AX:AY:B:B or A:A:BX:BY -! In this case we have the sume number of level2 permutations as level1 -! Just add an interaction on the other sublattice with same endmember -! The endmember permutations will put element A in sublattices: -! 1,2; 1,3; 1,4; 2,4; 3,4; 2,3; and element B in sublattices: -! 3,4; 2,4; 2,3; 1,3; 1,2; 1,4; -! The first interaction will be with the first of the sublattices, the -! second in the second, just switch - intperm(3)=1 - intperm(4)=1 - intperm(5)=intperm(2) - nz=intperm(2) - do np=1,6 -! Here AX:AY:B:B and AY:AX:B:B - nz=nz+1 - nll=intlinks(1,nz-11) - nl2=intlinks(1,nz-12) - intlinks(1,nz)=nll - write(*,73)'loop 6B: ',np,nll,nl2,nz -73 format(a,10i4) - call findconst(lokph,nll,jsp,intlinks(2,nz)) - if(gx%bmperr.ne.0) goto 1000 -! set the second interaction in sublattice with level 1 interaction - nz=nz+1 - intlinks(1,nz)=nl2 - call findconst(lokph,nl2,jsp,intlinks(2,nz)) - if(gx%bmperr.ne.0) goto 1000 - enddo -! if the case and loops above works they are smart and easy to understand ??? - endif - endif -!----------------------------------------------------------- -! Maybe this can wait a little ... - case(7) ! AX:A:B:C or A:BX:B:C or A:B:CX:C - write(*,*)'Not implemented yet 7' - gx%bmperr=7777 -!----------------------------------------------------------- -! Maybe this can wait a little ... - case(8) ! A:A:BX;C or similar - write(*,*)'Not implemented yet 8' - gx%bmperr=7777 -!----------------------------------------------------------- -! Maybe this can wait a little ... - case(9) ! AX:B:C:D or similar - write(*,*)'Not implemented yet 9' - gx%bmperr=7777 - end select -!----------------------------------------------------------- -! done permutations of interactions -! write(*,510)'510: ',(intperm(j),j=1,7) -510 format(a,10i4) -!------- debug output of first level interaction permutations -900 continue -! to skip remove comment on next line -! goto 1000 - if(nint.eq.2) then -! write(*,905)'Permutations of endmem and intlevel 1: ',noperm,& -! intperm(1),intperm(2) -! write(*,905)'Permutations of intlevel 2: ',intperm(3),& -! (intperm(3+i),i=1,intperm(3)) -905 format(a,i5,2x,10i4) - endif -! these are the base pointers to first and second level permutations - iqq1=0 - iqq2=intperm(2)+1 - inz=0 - emdmem: do np=1,noperm -! for each endmember permutation there are intperm(1) level 1 permutations - intlev1: do niqq1=1,intperm(1) - iqq1=iqq1+1 - if(nint.eq.2) then - level2=1 - if(intperm(3).eq.1) then -! there is a fixed number of 2nd level permutations - level2perm=intperm(4) - else -! the number of 2nd level interaction varies with the first level, it can be 0 - level2perm=intperm(3+niqq1) - if(level2perm.eq.0) cycle intlev1 - endif - else -! no 2nd level interaction - iqq2=0 - endif -910 continue - carr=' ' - ib=1 - subl: do ll=1,nsl -! endmember constituent, can be wildcard - loksp=elinks(ll,np) - if(loksp.gt.0) then - loksp=phlista(lokph)%constitlist(loksp) - lsp=len_trim(splista(loksp)%symbol) - carr(ib:)=splista(loksp)%symbol(1:lsp) - ib=ib+lsp - else - carr(ib:ib)='*' - ib=ib+1 - endif -920 continue - if(intlinks(1,iqq1).eq.ll) then -! level 1 interaction constituent -! NOTE: For error checks output of intlinks is more important than the -! constituent name in carr as the link also indicates the sublattice!!! -! if(nint.eq.2) & -! write(*,922)1,iqq1,intlinks(1,iqq1),intlinks(2,iqq1) -922 format('intlinks: ',2i5,2x,2i5,2x,3i5) - loksp=phlista(lokph)%constitlist(intlinks(2,iqq1)) - lsp=len_trim(splista(loksp)%symbol) - carr(ib:)=','//splista(loksp)%symbol(1:lsp) - ib=ib+lsp+1 - endif - if(iqq2.gt.0) then - if(intlinks(1,iqq2).eq.ll) then -! level 2 interaction constituent -! NOTE: For error checks output of intlinks is more important than the -! constituent name in carr as the link also indicates the sublattice!!! -! write(*,922)2,iqq2,intlinks(1,iqq2),intlinks(2,iqq2),jord(2,2) - loksp=phlista(lokph)%constitlist(intlinks(2,iqq2)) - lsp=len_trim(splista(loksp)%symbol) - carr(ib:)=','//splista(loksp)%symbol(1:lsp) - ib=ib+lsp+1 - endif - endif - if(ll.lt.nsl) then - carr(ib:)=': ' - ib=ib+2 - endif - enddo subl - inz=inz+1 -! write(*,925)inz,carr(1:len_trim(carr)) -925 format('inter perm ',i3,': ',a) - if(iqq2.gt.0) then -! there are level2perm number of 2nd order permutations - level2=level2+1 - iqq2=iqq2+1 - if(level2.le.level2perm) goto 910 - endif - enddo intlev1 - enddo emdmem -!------- debug output end -1000 continue - return - end subroutine fccpermuts - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine fccip2A(lokph,jord,intperm,intlinks) -! 2nd level interaction permutations for fcc - implicit none - integer, dimension(*) :: intperm - integer, dimension(2,*) :: jord,intlinks - integer lokph -!\end{verbatim} %+ - integer loksp,isp,jsp,ij,nll,ll,iqq,nz,ik -! AX:A:A:A, 2nd level can be AXY:A:A:A, AX:AX:A:A or AX:AY:A:A - loksp=phlista(lokph)%constitlist(jord(2,2)) - isp=splista(loksp)%alphaindex -! write(*,2)'fccip2A1: ',((jord(i,j),i=1,2),j=1,2) -!2 format(a,2(2i3,2x)) -! 2nd level interaction in another sublattice, AX:AX:A:A or AX:AY:A:A - loksp=phlista(lokph)%constitlist(jord(2,1)) - jsp=splista(loksp)%alphaindex -! write(*,*)'fccip2A2: ',isp,jsp - if(isp.eq.jsp) then -! 2nd level interacting constituent same as first level constituent: -! Level 1: Level2: -! AX:A:A:A; AX:AX:A:A; AX:A:AX:A; AX:A:A:AX 3 permutations -! A:AX:A:A; A:AX:AX:A; A:AX:A:AX 2 permutations -! A:A:AX:A; A:A:AX:AX 1 permutations -! A:A:A:AX; none 0 permutations -! write(*,*)'same interaction constituent in different sublattices' - intperm(3)=4 - intperm(4)=3 - intperm(5)=2 - intperm(6)=1 - intperm(7)=0 - intperm(8)=24 - iqq=intperm(2) - do ij=1,3 -! loop only to 3 as there is no 2nd level permutation for ij=4 - nll=intlinks(1,ij) - do ll=1,intperm(3+ij) - iqq=iqq+1 - nll=nll+1 - intlinks(1,iqq)=nll - if(nll.gt.4) then - write(*,*)'Error in 2nd level interaction of AX:AX:A:A' - gx%bmperr=7777; goto 1000 - endif - call findconst(lokph,intlinks(1,iqq),isp,intlinks(2,iqq)) - if(gx%bmperr.ne.0) goto 1000 -! write(*,76)'loop: ',ij,nll,iqq,intlinks(1,iqq),intlinks(2,iqq) -76 format(a,3i3,2x,2i4) - enddo - enddo -! debug output -! nc=0 -! nc1=0 -! nc2=intperm(2) -! do lj=1,4 -! do ljj=1,intperm(3+lj) -! nc=nc+1 -! nc1=nc1+1 -! nc2=nc2+1 -! write(*,77)nc,lj,ljj,& -! (intlinks(i,nc1),i=1,2),(intlinks(i,nc2),i=1,2) -77 format('AX:AX:A:A: ',i3,2x,2i3,2x,2(2i4,2x)) -! enddo -! enddo - else -! If 2nd level interacting element different -! Level 1: Level2: -! AX:A:A:A; AX:AY:A:A; AX:A:AY:A; AX:A:A:AY 3 permutations -! A:AX:A:A; AY:AX:A:A; A:AX:AY:A; A:AX:A:AY 3 permutations -! A:A:AX:A; AY:A:AX:A; A:AY:AX:A; A:A:AX:AY 3 permutations -! A:A:A:AX; AY:A:A:AX; A:AY:A:AX; A:A:AY:AX 3 permutations -! write(*,*)'different interaction constituent in different sublattices' - intperm(3)=1 - intperm(4)=3 - intperm(5)=12 - nz=intperm(2) - do ik=1,4 -! Note that these permutations include AY:AX:A:A linked from AX:A:A:A -! A first level interaction AY:A:A:A is stored in another interaction record -! with no link to this 2nd level interaction. - nll=intlinks(1,ik) - do ll=1,3 - nll=nll+1 - if(nll.gt.4) nll=1 - nz=nz+1 - intlinks(1,nz)=nll - call findconst(lokph,nll,isp,intlinks(2,nz)) - if(gx%bmperr.ne.0) goto 1000 -! write(*,88)nz,ik,ll,intlinks(1,nz),intlinks(2,nz) -88 format('loop: ',3i3,2x,2i5) - enddo - enddo - endif -1000 continue - return - end subroutine fccip2A - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine fccip2B(lq,lokph,lshift,jord,intperm,intlinks) -! 2nd level interaction permutations for fcc - implicit none - integer lq,lokph,lshift - integer, dimension(*) :: intperm - integer, dimension(2,*) :: jord,intlinks -!\end{verbatim} %+ - integer loksp,isp,jsp,ny,nz,mp,isub2,nll,ip,np -! lq=1 means AX:AY:A:B or AX:AX:A:B -! lq=2 means A:BX:BY:B or A:BX:BX:B -! This parameter has 4 endmember permuts each with 3 permuts on level 1 -! if X is same as Y only 2; 1; 0 - loksp=phlista(lokph)%constitlist(jord(2,1)) - isp=splista(loksp)%alphaindex - loksp=phlista(lokph)%constitlist(jord(2,2)) - jsp=splista(loksp)%alphaindex -! write(*,*)'fccip2B3: ',isp,jsp - if(isp.eq.jsp) then -! Endmember Level 1 Level 2 2; 1; 0; -! A:A:A:B AX:A:A:B AX:AX:A:B AX:A:AX:B -! A:AX:A:B A:AX:AX:B -! A:A:AX:B none -! A:A:B:A AX:A:B:A AX:AX:B:A AX:A:B:AX -! A:AX:B:A A:AX:B:AX -! A:A:B:AX none -! A:B:A:A AX:B:A:A AX:B:AX:A AX:B:A:AX -! A:B:AX:A A:B:AX:AX -! A:B:A:AX none -! B:A:A:A B:AX:A:A B:AX:AX:A B:AX:A:AX -! B:A:AX:A B:A:AX:AX -! B:A:A:AX none -! or the same for endmember A:B:B:B - intperm(3)=3 - intperm(4)=2 - intperm(5)=1 - intperm(6)=0 - intperm(7)=intperm(2) - ny=0 - nz=intperm(2) - mp=3 -! these loops are frustratingly messy .... but they seem to work ... - nploop: do np=1,intperm(2) - mp=mp+1 - if(lq.eq.1) then -! isub2 is the endmember sublattice occupied by the "different" constituent -! isub2=(20-np)/4 - isub2=(15-np)/3 - else -! isub2=(3+np)/4 - isub2=(2+np)/3 - endif -! nll is the sublattice with 1st level interaction - ny=ny+1 - nll=intlinks(1,ny) -! np = 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12 -! mp = 4, 5, 6, 4, 5, 6, 4, ... -! intperm(mp) = 2, 1, 0, 2, 1, 0, 2, 1, 0, 2, 1, 0 - do ip=1,intperm(mp) - nll=nll+1 - if(nll.eq.isub2) nll=nll+1 - nz=nz+1 - intlinks(1,nz)=nll -! write(*,13)'AX:AX:A:B: ',np,mp,ip,isub2,nz,nll,jsp -13 format(a,4i3,2x,i3,2i5) - call findconst(lokph,nll,jsp,intlinks(2,nz)) - if(gx%bmperr.ne.0) goto 1000 - enddo - if(mod(np,3).eq.0) mp=3 - enddo nploop - else -! Endmember Level 1 Level 2 2; -! A:A:A:B AX:A:A:B AX:AY:A:B AX:A:AY:B -! A:AX:A:B A:AX:AY:B AY:AX:A:B -! A:A:AX:B AY:A:AX:B A:AY:AX:B -! A:A:B:A AX:A:B:A AX:AY:B:A AX:A:B:AY etc -! There are 2 additional permutations for each of the 12 existing, the problem -! is mainly to know in which sublattice to add the interaction - intperm(3)=1 - intperm(4)=2 - intperm(5)=2*intperm(2) - ny=0 - nz=intperm(2) - do np=1,intperm(2) - if(lq.eq.1) then -! isub2 is the endmember sublattice occupied by the "different" constituent - isub2=(15-np)/3 - else -! isub2 should be 1 for np=1..4, 2 for np=4..7 etc - isub2=(np+2)/3 - endif -! nll is the sublattice with 1st level interaction - ny=ny+1 - nll=intlinks(1,ny) - do ip=1,2 -! set 2nd interaction in sublattice after first interaction. If that -! sublattice is >4 set it in first. If the endmember is the single other -! constituent set it in next. If that is >4 set it in first - nll=nll+1 - if(nll.gt.4) nll=1 - if(nll.eq.isub2) nll=nll+1 - if(nll.gt.4) nll=1 - nz=nz+1 - intlinks(1,nz)=nll -! write(*,13)'AX:AY:A:B: ',np,ip,0,isub2,nz,nll,jsp - call findconst(lokph,nll,jsp,intlinks(2,nz)) - if(gx%bmperr.ne.0) goto 1000 - enddo - enddo - endif -1000 continue - return - end subroutine fccip2B - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine fccint31(jord,lshift,intperm,intlinks) -! 1st level interaction in sublattice l1 with endmember A:A:A:B or A:B:B:B -! set the sublattice and link to constituent for each endmember permutation -! 1st permutation of endmember: AX:A:A:B; A:AX:A:B; A:A:AX;B 4 0 1 2 -! 2nd permutation of endmember: AX:A:B:A; A:AX:B:A; A:A:B:AX 3 0 1 3 -! 3rd permutation of endmember: AX:B:A:A; A:B:AX:A; A:B:A:AX 3 0 2 3 -! 4th permutation of endmember: B:AX:A:A; B:A:AX:A; B:A:A:AX 1 or 1 2 3 -! 1st permutation of endmember: A:BX:B:B; A:B:BX:B; A:B:B:BX 4 0 1 2 -! 2nd permutation of endmember: BX:A:B:B; B:A:BX:B; B:A:B:BX 1 etc -1 1 2 -! 3rd -1 0 2 ; -1 0 1 -! suck - implicit none - integer lshift - integer, dimension(2,*) :: jord,intlinks - integer, dimension(*) :: intperm -!\end{verbatim} %+ - integer l2,shift0,shift1,shift2,clink,idis,np -! - intperm(1)=3 - intperm(2)=12 - l2=jord(1,1) - clink=jord(2,1) - idis=0 - shift0=0 - shift1=1 - shift2=2 - do np=1,4 - intlinks(1,idis+1)=l2+shift0 - intlinks(2,idis+1)=clink+shift0*lshift - intlinks(1,idis+2)=l2+shift1 - intlinks(2,idis+2)=clink+shift1*lshift - intlinks(1,idis+3)=l2+shift2 - intlinks(2,idis+3)=clink+shift2*lshift - idis=idis+3 - subl: if(l2.eq.1) then - if(np.eq.1) then - shift2=3 - elseif(np.eq.2) then - shift1=2 - elseif(np.eq.3) then - shift0=1 - endif - else - if(np.eq.1) then - shift0=-1 - elseif(np.eq.2) then - shift1=0 - else - shift2=1 - endif - endif subl - enddo -1000 return - end subroutine fccint31 - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine fccint22(jord,lshift,intperm,intlinks) -! 1st level for endmember A:A:B:B with interaction in sublattice jord(1,1) -! 6 permutations of endmember, 2 permutations of interactions, 12 in total -! 1st endmemperm: AX:A:B:B; A:AX:B:B 0 1 -! 2nd endmemperm: AX:B:A:B; A:B:AX:B 0 2 -! 3rd endmemperm: AX:B:B:A; A:B:B:AX 0 3 -! 4th endmemperm: B:AX:B:A; B:A:B:AX 1 3 -! 5th endmemperm: B:B:AX:A; B:B:A:AX 2 3 -! 6th endmemperm: B:AX:A:B; B:A:AX:B or 1 2 -! 1th endmemperm: A:A:BX:B; A:A:B:BX 0 1 -! 2nd endmemperm: A:BX:A:B; A:B:A:BX -1 1 -! 3rd endmemperm: A:BX:B:A; A:B:BX:A -1 0 -! 4th endmemperm: BX:A:B:A; B:A:BX:A -2 0 -! 5th endmemperm: BX:B:A:A; B:BX:A:A -2 -1 -! 6th endmemperm: BX:A:A:B; B:A:A:BX -2 1 - implicit none - integer lshift - integer, dimension(2,*) :: jord,intlinks - integer, dimension(*) :: intperm -!\end{verbatim} %+ - integer shift0,shift1,l2,clink,idis,np -! - intperm(1)=2 - intperm(2)=12 - l2=jord(1,1) - clink=jord(2,1) - idis=0 - shift0=0 - shift1=1 - do np=1,6 - intlinks(1,idis+1)=l2+shift0 - intlinks(2,idis+1)=clink+shift0*lshift - intlinks(1,idis+2)=l2+shift1 - intlinks(2,idis+2)=clink+shift1*lshift - idis=idis+2 - subl: if(l2.eq.1) then - select case(np) - case default - write(*,*)'Case error in fccint22: ',np - case(1) !A:B:A:B is next endmember - shift1=2 - case(2) !A:B:B:A - shift1=3 - case(3) !B:A:B:A - shift0=1 - case(4) !B:B:A:A - shift0=2 - case(5) !B:A:A:B - shift0=1 - shift1=2 - case(6) ! no more - end select - else - select case(np) - case default - write(*,*)'Case error in fccint22: ',np - case(1) !A:B:A:B is next endmember - shift0=-1 - case(2) !A:B:B:A - shift1=0 - case(3) !B:A:B:A - shift0=-2 - case(4) !B:B:A:A - shift1=-1 - case(5) !B:A:A:B - shift1=1 - case(6) ! no more - end select - endif subl - enddo -1000 continue - return - end subroutine fccint22 - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine fccint211(a211,jord,lshift,intperm,intlinks) -! 1st level interaction in sublattice l1 with endmember like A:A:B:C -! 12 endmember permutations of AABC; ABBC; or ABCC -! 2 interaction permutations for each, 24 in total - implicit none - integer a211,lshift - integer, dimension(2,*) :: jord,intlinks - integer, dimension(*) :: intperm -!\end{verbatim} %+ - integer l2,clink,idis,shift0,shift1,np - intperm(1)=2 - intperm(2)=24 - l2=jord(1,1) - if(l2.ne.a211) then - write(*,*)'Error calling fccint211',a211,l2 - gx%bmperr=7777; goto 1000 - endif - clink=jord(2,1) - idis=0 - shift0=0 - shift1=1 -! endmemeber A:A:B:C; first permutation interactions: AX:A:B:C; A:AX:B:C -! endmemeber A:B:B:C; first permutation interactions: A:BX:B:C; A;B:BX:C -! endmemeber A:B:C:C; first permutation interactions: A:B:CX:C; A:B:C:CX - do np=1,12 - intlinks(1,idis+1)=l2+shift0 - intlinks(2,idis+1)=clink+shift0*lshift - intlinks(1,idis+2)=l2+shift1 - intlinks(2,idis+2)=clink+shift1*lshift - idis=idis+2 - subl: if(l2.eq.1) then -! endmember A:A:B:C - select case(np) - case default - write(*,*)'Case error in fccint211: ',np,a211 - case(1) !A:A:C:B is next endmember - continue - case(2) !A:C:A:B - shift1=2 - case(3) !A:C:B:A - shift1=3 - case(4) !A:B:C:A - continue - case(5) !A:B:A:C - shift1=2 - case(6) !B:A:A:C - shift0=1 - case(7) !B:A:C:A - shift1=3 - case(8) !B:C:A:A - shift0=2 - case(9) !C:B:A:A - continue - case(10) !C:A:B:A - shift0=1 - case(11) !C:A:A:B - shift1=2 - case(12) ! no more - end select - elseif(l2.eq.2) then -! endmember A:B:B:C - select case(np) - case default - write(*,*)'Case error in fccint211: ',np,a211 - case(1) !A:B:C:B is next endmember - shift1=2 - case(2) !C:B:A;B - continue - case(3) !C:B:B:A - shift1=1 - case(4) !B:B:C:A - shift0=-1 - shift1=0 - case(5) !B:B:A:C - continue - case(6) !B:A:B:C - shift1=1 - case(7) !B:A:C:B - shift1=2 - case(8) !C:A:B:B - shift0=1 - case(9) !A:C:B:B - continue - case(10) !B:C:A:B - shift0=-1 - case(11) !B:C:B:A - shift1=1 - case(12) ! no more - end select - else -! endmember A:B:C:C - select case(np) - case default - write(*,*)'Case error in fccint211: ',np,a211 - case(1) !A:C:B:C is next endmember - shift0=-1 - case(2) !C:A:B:C - shift1=0 - case(3) !C:B:A:C - shift0=-2 - case(4) !B:C:A:C - shift1=-1 - case(5) !B:A:C:C - shift1=1 - case(6) !B:C:C:A - shift1=1 - case(7) !C:B:C:A - shift1=1 - case(8) !C:C:B:A - shift1=1 - case(9) !C:C:A:B - shift1=1 - case(10) !C:A:C:B - shift1=1 - case(11) !A:C:C:B - shift1=1 - case(12) ! no more - end select - endif subl - enddo -1000 continue - return - end subroutine fccint211 - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine fccpe211(l1,elinks,nsl,lshift,iord) -! sets appropriate links to constituents for the 12 perumations of -! A:A:B:C (l1=1), A:B:B:C (l1=2) and A:B:C:C (l1=3) - implicit none - integer, dimension(nsl,*) :: elinks - integer, dimension(*) :: iord - integer l1,nsl,lshift -!\end{verbatim} %+ - integer odd,np,ll,ib -! l1=1; keep 1 and change 3o4 and 2o3 6 times; then change 1o2 and -! loop 2 times -! changing 3o4 and 2o3; then change 1o2 and loop 2 times changing 2o3 -! and 3o4 -! AABC; AACB; ACAB; ACBA; ABCA; ABAC; ! BAAC; BACA; BCAA; ! CBAA; -! CABA; CAAB; -! l1=2; keep 2 and change 3o4 and 1o3 6 times; then change 2o3 and -! loop 2 times -! changing 3o4 and 1o3; then change -! ABBC; ABCB; CBAB; CBBA; BBCA; BBAC; ! BABC; BACB; CABB; ! ACBB; -! BCAB; BCBA; -! l1=3; keep 4 and change 2o3 and 1o2 6 times; then change -! ABCC; ACBC; CABC; CBAC; BCAC; BACC; ! -! write(*,*)'fccpe211: ',l1 - odd=0 - loop12: do np=0,11 - do ll=1,nsl - if(iord(ll).lt.0) iord(ll)=-99 - elinks(ll,np+1)=iord(ll) - enddo -! note l1 and ll are different !!! - if(l1.eq.1) then -! AABC. Keep constituent in sublattice 1 first 6 loops; then for 3 and 3 - if(np.eq.5) then - ib=iord(1)+lshift - iord(1)=iord(2)-lshift - iord(2)=ib - odd=1-odd - elseif(np.eq.8) then - ib=iord(1)+lshift - iord(1)=iord(2)-lshift - iord(2)=ib - odd=1-odd - elseif(odd.eq.0) then - ib=iord(3)+lshift - iord(3)=iord(4)-lshift - iord(4)=ib - odd=1-odd - else - ib=iord(2)+lshift - iord(2)=iord(3)-lshift - iord(3)=ib - odd=1-odd - endif - elseif(l1.eq.2) then -! ABBC. Keep constituent in sublattice 2 for first 6; then for 3 and 3 - if(np.eq.5) then - ib=iord(2)+lshift - iord(2)=iord(3)-lshift - iord(3)=ib - odd=1-odd - elseif(np.eq.8) then - ib=iord(1)+lshift - iord(1)=iord(2)-lshift - iord(2)=ib - odd=1-odd - elseif(odd.eq.0) then - ib=iord(3)+lshift - iord(3)=iord(4)-lshift - iord(4)=ib - odd=1-odd - else - ib=iord(1)+2*lshift - iord(1)=iord(3)-2*lshift - iord(3)=ib - odd=1-odd - endif - else -! ABCC. Keep constituent in sublattice 4 for first 6; then for 3 and 3 - if(np.eq.5) then - ib=iord(2)+2*lshift - iord(2)=iord(4)-2*lshift - iord(4)=ib - elseif(np.eq.8) then - ib=iord(3)+lshift - iord(3)=iord(4)-lshift - iord(4)=ib - odd=1-odd - elseif(odd.eq.0) then - ib=iord(2)+lshift - iord(2)=iord(3)-lshift - iord(3)=ib - odd=1-odd - else - ib=iord(1)+lshift - iord(1)=iord(2)-lshift - iord(2)=ib - odd=1-odd - endif - endif - enddo loop12 -1000 continue - return - end subroutine fccpe211 - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine fccpe1111(elinks,nsl,lshift,iord) -! sets appropriate links to 24 permutations when all 4 constituents different -! A:B:C:D -! The do loop keeps the same constituent in first sublattice 6 times, changing -! the other 3 sublattice, then changes the constituent in the first sublattice -! and goes on changing in the other 3 until all configurations done - implicit none - integer, dimension(nsl,*) :: elinks - integer, dimension(*) :: iord - integer nsl,lshift -!\end{verbatim} - integer np,ll,odd,ib -! odd is either 0 or 1 - odd=1 - loop24: do np=0,23 - do ll=1,nsl - if(iord(ll).lt.0) iord(ll)=-99 - elinks(ll,np+1)=iord(ll) - enddo -! keep the same constituent in sublattice 1 for 6 endmembers, then shift - if(np.eq.5) then -! shift 1 and 2, change odd - ib=iord(2)-lshift - iord(2)=iord(1)+lshift - iord(1)=ib - odd=1-odd - elseif(np.eq.11) then -! shift 1 and 4, keep odd - ib=iord(3)-2*lshift - iord(3)=iord(1)+2*lshift - iord(1)=ib - elseif(np.eq.17) then -! shift 1 and 4, change odd - ib=iord(4)-3*lshift - iord(4)=iord(1)+3*lshift - iord(1)=ib - odd=1-odd - elseif(odd.eq.0) then - odd=1-odd -! shift 3 and 4 - ib=iord(4)-lshift - iord(4)=iord(3)+lshift - iord(3)=ib - else - odd=1-odd -! shift 2 and 3 - ib=iord(3)-lshift - iord(3)=iord(2)+lshift - iord(2)=ib - endif - enddo loop24 -1000 continue - return - end subroutine fccpe1111 - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine bccpermuts(lokph,nsl,iord,noperm,elinks,nint,jord,intperm,intlinks) -! finds all bcc permutations needed for this parameter - implicit none - integer lokph,nsl,noperm,nint - integer, dimension(*) :: iord,intperm - integer, dimension(2,*) :: jord - integer, dimension(:,:), allocatable :: elinks - integer, dimension(:,:), allocatable :: intlinks -!\end{verbatim} -! I assume the ordering is in the first 4 sublattices, that could be changed - if(nsl.lt.4) then - write(*,*)'There must be at least 4 sublattices for bcc option' - gx%bmperr=7777; goto 1000 - endif -! unifinished - write(*,*)'BCC permutations not implemented yet' - gx%bmperr=7777 -1000 continue - return - end subroutine bccpermuts - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine findconst(lokph,ll,spix,constix) -! locates the constituent index of species with index spix in sublattice ll -! and returns it in constix. For wildcards spix is -99; return -99 -! THERE MAY ALREADY BE A SIMULAR SUBROUTINE ... CHECK - implicit none - integer lokph,ll,spix,constix -!\end{verbatim} - integer nc,l2,loksp - if(spix.eq.-99) then - constix=-99 - goto 1000 - endif - nc=1 - do l2=1,ll-1 -! The number of constituents in each sublattice can vary, add together - nc=nc+phlista(lokph)%nooffr(l2) - enddo - constix=0 - do l2=nc,nc+phlista(lokph)%nooffr(ll)-1 - loksp=phlista(lokph)%constitlist(l2) - if(splista(loksp)%alphaindex.eq.spix) then - constix=l2; exit - endif - enddo - if(constix.eq.0) then - write(*,90)spix,nc -90 format('No such constituent with index ',i5,' in sublattice',i3) - gx%bmperr=7777; goto 1000 - endif -1000 continue - return - end subroutine findconst - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine tdbrefs(refid,line,mode,iref) -! store a reference from a TDB file or given interactivly -! If refid already exist and mode=1 then amend the reference text - implicit none - character*(*) refid,line - integer mode,iref -!\end{verbatim} - integer ip,ml,nr,mc,nc,jl -! make sure refid is left adjusted - ip=0 -10 ip=ip+1 - if(ip.gt.len(refid)) then - gx%bmperr=4154; goto 1000 - endif - if(refid(ip:ip).eq.' ') goto 10 - if(ip.gt.1) refid=refid(ip:) -! make it upper case - call capson(refid) -! look if refid already exist - do iref=1,reffree-1 - if(refid.eq.bibrefs(iref)%reference) then - if(mode.eq.1) then -! write(*,70)i,refid,bibrefs(i)%refspec -!70 format('tdbrefs: ',i4,a,a) - deallocate(bibrefs(iref)%refspec) - goto 200 - else -! reference already exist and no changes needed - goto 1000 - endif - endif - enddo -! if bibliographic reference does not exist do not create - if(mode.eq.1) goto 1000 - iref=reffree - reffree=reffree+1 - bibrefs(iref)%reference=refid -200 continue - ml=len_trim(line) - nr=(ml+63)/64 - allocate(bibrefs(iref)%refspec(nr)) - mc=1 - nc=0 -! write(*,202)'25G newref: ',iref,refid,nr,line(1:min(32,len_trim(line))) -!202 format(a,i4,1x,a,i3,1x,a) - do jl=1,nr -! 1-64 mc=1, nc=64 -! 65-122 - bibrefs(iref)%refspec(jl)=' ' - nc=nc+min(ml,64) - bibrefs(iref)%refspec(jl)=line(mc:nc) - mc=nc+1 - ml=ml-64 - enddo -1000 continue - return - end subroutine tdbrefs - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine enter_equilibrium(name,number) -! creates a new equilibrium. Allocates arrayes for conditions, -! components, phase data and results etc. -! returns index to new equilibrium record -! THIS CAN PROBABLY BE SIMPLIFIED, especially phase_varres array can be -! copied as a whole, not each record structure separately ... ??? - implicit none - character name*(*) - integer number -!\end{verbatim} - TYPE(gtp_phase_varres), pointer :: cpv,cp1 - character name2*64 - integer ieq,ipv,nc,jz,iz,jl,jk,novarres - if(.not.allowenter(3)) then - write(*,*)'25G: not allowed enter equilibrium: ',name - gx%bmperr=4153; goto 1000 - endif - name2=name - call capson(name2) - if(ocv()) write(*,*)'25G In routine to enter equilibria: ',& - name,noofph,eqfree - if(.not.proper_symbol_name(name2,0)) then -! the name must start with a letter A-Z and contain letters, numbers and _ - gx%bmperr=4122 - goto 1000 - endif -! check if name already used - call findeq(name2,ieq) - if(gx%bmperr.eq.0) then - gx%bmperr=4123 - goto 1000 - else -! reset error code - gx%bmperr=0 - endif - if(eqfree.le.maxeq) then - ieq=eqfree - eqfree=eqfree+1 - endif - number=ieq - if(ocv()) write(*,*)'25G create eq',eqfree,maxeq,ieq -! allocate data arrayes in equilibrium record - eqlista(ieq)%next=0 - eqlista(ieq)%eqname=name2 - eqlista(ieq)%eqno=ieq -! component list and matrix, if second or higher equilibrium copy content - if(ocv()) write(*,*)'25G: entereq 1: ',maxel,ieq,noofel - if(ieq.eq.1) then - allocate(eqlista(ieq)%complist(maxel)) - allocate(eqlista(ieq)%compstoi(maxel,maxel)) - allocate(eqlista(ieq)%invcompstoi(maxel,maxel)) - allocate(eqlista(ieq)%cmuval(maxel)) -! this is a bit meaningless but skipping it has given raise to strange errors - eqlista(ieq)%compstoi=zero - eqlista(ieq)%invcompstoi=zero - do jl=1,maxel - eqlista(ieq)%compstoi(jl,jl)=one - eqlista(ieq)%invcompstoi(jl,jl)=one - enddo - else - allocate(eqlista(ieq)%complist(noofel)) - allocate(eqlista(ieq)%compstoi(noofel,noofel)) - allocate(eqlista(ieq)%invcompstoi(noofel,noofel)) - allocate(eqlista(ieq)%cmuval(noofel)) - eqlista(ieq)%cmuval=zero - if(ocv()) write(*,*)'25G: entereq 1B: ' - do jl=1,noofel - eqlista(ieq)%complist(jl)%splink=firsteq%complist(jl)%splink - eqlista(ieq)%complist(jl)%phlink=firsteq%complist(jl)%phlink - eqlista(ieq)%complist(jl)%status=firsteq%complist(jl)%status -! if(firsteq%complist(jl)%phlink.gt.0) then -! only if there is a defined reference state - eqlista(ieq)%complist(jl)%refstate=firsteq%complist(jl)%refstate - eqlista(ieq)%complist(jl)%tpref=firsteq%complist(jl)%tpref - eqlista(ieq)%complist(jl)%chempot=zero - do jk=1,noofel - eqlista(ieq)%compstoi(jl,jk)=firsteq%compstoi(jl,jk) - eqlista(ieq)%invcompstoi(jl,jk)=firsteq%invcompstoi(jl,jk) - enddo - if(allocated(firsteq%complist(jl)%endmember)) then - iz=size(firsteq%complist(jl)%endmember) - if(ocv()) write(*,*)'25G: entereq 1E: ',iz - allocate(eqlista(ieq)%complist(jl)%endmember(iz)) - eqlista(ieq)%complist(jl)%endmember=& - firsteq%complist(jl)%endmember - endif -! endif - enddo - endif -! these records keep calculated values of G and derivatives for each phase -! For phase lokph the index to phase_varres is in phlista(lokph)%cslink -! For phase lokph the index to phase_varres is in phlista(lokph)%linktocs(ics) - if(ocv()) write(*,*)'25G: entereq 2: ',maxph - if(ieq.eq.1) then -! %multiuse is used for axis and direction of a start equilibrium - allocate(eqlista(ieq)%phase_varres(2*maxph)) - firsteq=>eqlista(ieq) - firsteq%multiuse=0 - goto 900 - else -! for ieq>1 allocate the current number of phase_varres records plus 10 -! for extra composition sets added later - eqlista(ieq)%multiuse=0 - novarres=csfree-1 - iz=noofph -! allocate(eqlista(ieq)%phase_varres(iz+10)) - allocate(eqlista(ieq)%phase_varres(2*maxph)) - if(ocv()) write(*,*)'25G varres: ',ieq,size(eqlista(ieq)%phase_varres) -! now copy the current content of firsteq%phase_varres to this equilibrium -! note, the SELECT_ELEMENT_REFERENCE phase has phase number 0 -! and phase_varres index 1, the number of phase_varres records is not the -! same as number of phases .... - copypv: do ipv=1,novarres -! note eqlista(1) is identical to firsteq - cp1=>eqlista(1)%phase_varres(ipv) - cpv=>eqlista(ieq)%phase_varres(ipv) - cpv%nextfree=cp1%nextfree - cpv%phlink=cp1%phlink - cpv%status2=cp1%status2 - cpv%abnorm=cp1%abnorm - cpv%prefix=cp1%prefix - cpv%suffix=cp1%suffix -! allocate and copy arrays - nc=size(cp1%yfr) -! note SIZE gives rubbish unless array is allocated - if(ocv()) write(*,*)'copy yfr 1: ',nc - allocate(cpv%yfr(nc)) - cpv%yfr=cp1%yfr -! problems with phase_varres in equilibrium 2 ... -! write(*,46)'1: ',cp1%yfr -! write(*,46)'v: ',cpv%yfr -46 format('yfr ',a,10(F7.3)) - allocate(cpv%constat(nc)) - cpv%constat=cp1%constat - if(allocated(cp1%mmyfr)) then -! problem with mmyfr??? .... no -! if(ocv()) write(*,*)'25G mmyfr 1: ',ipv,cpv%phlink,nc - allocate(cpv%mmyfr(nc)) - cpv%mmyfr=cp1%mmyfr -! write(*,34)'25G mmyfr 2: ',(cpv%mmyfr(jz),jz=1,nc) -34 format(1x,a,10(F7.3)) -! else -! write(*,*)'25G mmyfr not allocated' - endif - jz=size(cp1%sites) - allocate(cpv%sites(jz)) - cpv%sites=cp1%sites -! these are currently not allocated (ionic liquid model) Maybe not needed?? -! jz=size(cp1%dsitesdy) -! allocate(cpv%dsitesdy(jz)) -! cpv%dsitesdy=cp1%dsitesdy -! jz=size(cp1%d2sitesdy2) -! allocate(cpv%d2sitesdy2(jz)) -! cpv%d2sitesdy2=cp1%d2sitesdy2 -! the values in the following arrays are irrelevant, just allocate and zero - cpv%nprop=cp1%nprop - allocate(cpv%listprop(cp1%nprop)) - allocate(cpv%gval(6,cp1%nprop)) - allocate(cpv%dgval(3,nc,cp1%nprop)) - allocate(cpv%d2gval(nc*(nc+1)/2,cp1%nprop)) - cpv%listprop=0 - cpv%amfu=zero - cpv%dgm=zero - cpv%phstate=PHENTERED - cpv%netcharge=zero - cpv%gval=zero - cpv%dgval=zero - cpv%d2gval=zero -! copy the disordered fraction record, that should take care of all -! array allocations inside the disfra record ??? - cpv%disfra=cp1%disfra -! disordered: if(cpv%disfra%varreslink.gt.0) then -! if there is a disordered phase_varres record that must be taken care of -! lokdis=cpv%disfra%varreslink -! eqlista(ieq)%phase_varres(lokdis)%abnorm=& -! eqlista(1)%phase_varres(lokdis)%abnorm -! !!!! WOW it really seems to copy a whole tructure just by = !!! -! eqlista(ieq)%phase_varres(lokdis)=eqlista(1)%phase_varres(lokdis) -! BUT THEN I HAVE TO CHANGE EVERYTHING ABOVE ... NEXT RELEASE ... -! write(*,*)'copied dis: ',lokdis -! write(*,77)eqlista(ieq)%phase_varres(lokdis)%yfr(2),& -! eqlista(1)%phase_varres(lokdis)%yfr(2) -!77 format('enter eq: ',2(1pe15.6)) -! continue -! endif disordered - enddo copypv - endif -! From here also for first equilibria -900 continue - if(ocv()) write(*,*)'25G: entereq 3: ' -! nullify condition links, otherwise "if(associated(..)" does not work - nullify(eqlista(ieq)%lastcondition) - nullify(eqlista(ieq)%lastexperiment) - if(ocv()) write(*,*)'25G set T and P',ieq -! also set default local values of T and P (not conditions) - eqlista(ieq)%tpval(1)=1.0D3; eqlista(ieq)%tpval(2)=1.0D5 -! allocate and copy tpfun result array also for first equilibria -! jz=size(firsteq%eq_tpres) - jz=maxtpf - if(ocv()) write(*,*)'25G: entereq 4: ',jz,maxsvfun -! write(*,*)'create equil tpres size ',jz,notpf() - allocate(eqlista(ieq)%eq_tpres(jz)) -! allocate result array for state variable functions (svfunres) - if(ocv()) write(*,*)'25G maxsvfun: ',ieq,maxsvfun,jz - allocate(eqlista(ieq)%svfunres(maxsvfun)) -! convergence criteria - eqlista(ieq)%xconv=firsteq%xconv - eqlista(ieq)%maxiter=firsteq%maxiter -1000 continue - if(ocv()) write(*,*)'25G finished enter equilibrium',ieq - return - end subroutine enter_equilibrium - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine delete_equilibria(name,ceq) -! deletes an equilibrium (needed when repeated step/map) -! name can be an abbreviation line "_MAP*" -! deallocates all data. Minimal checks ... one cannot delete "ceq" - implicit none - character name*(*) - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - type(gtp_condition), pointer :: lastcond,pcond,qcond - integer cureq,ieq,ik,novarres,ipv -! - cureq=ceq%eqno - ik=index(name,'*')-1 - if(ik.lt.0) ik=min(24,len(name)) - do ieq=eqfree-1,1,-1 -! we cannot have "holes" in the free list?? Delete from the end... - if(ieq.eq.cureq) exit - if(eqlista(ieq)%eqname(1:ik).ne.name(1:ik)) exit - if(ocv()) write(*,*)'Deleting: ',eqlista(ieq)%eqname,ieq - eqlista(ieq)%eqname=' ' - deallocate(eqlista(ieq)%complist) - deallocate(eqlista(ieq)%compstoi) - deallocate(eqlista(ieq)%invcompstoi) - deallocate(eqlista(ieq)%cmuval) -! - novarres=csfree-1 -! write(*,*)'deallocationg phase_varres' - do ipv=1,novarres - deallocate(eqlista(ieq)%phase_varres(ipv)%yfr) - deallocate(eqlista(ieq)%phase_varres(ipv)%constat) - if(allocated(eqlista(ieq)%phase_varres(ipv)%mmyfr)) & - deallocate(eqlista(ieq)%phase_varres(ipv)%mmyfr) - deallocate(eqlista(ieq)%phase_varres(ipv)%sites) - deallocate(eqlista(ieq)%phase_varres(ipv)%listprop) - deallocate(eqlista(ieq)%phase_varres(ipv)%gval) - deallocate(eqlista(ieq)%phase_varres(ipv)%dgval) - deallocate(eqlista(ieq)%phase_varres(ipv)%d2gval) -! do not deallocate explicitly disfra as it is another phase_varres record ... - enddo - deallocate(eqlista(ieq)%phase_varres) -! condition list -! write(*,*)'deleting conditions' - lastcond=>eqlista(ieq)%lastcondition - if(associated(lastcond)) then - pcond=>lastcond%next - do while(.not.associated(pcond,lastcond)) - qcond=>pcond - pcond=>pcond%next - deallocate(qcond) - enddo - endif -! - deallocate(eqlista(ieq)%eq_tpres) - deallocate(eqlista(ieq)%svfunres) - enddo -! we have deleted all equilibria until ieq+1 - if(ocv()) write(*,900)ieq+1,eqfree-1 -900 format('Deleted equilibra from ',i3,' to ',i3) - eqfree=ieq+1 -1000 continue - return - end subroutine delete_equilibria - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine copy_equilibrium(neweq,name,ceq) -! creates a new equilibrium which is a copy of ceq. -! Allocates arrayes for conditions, -! components, phase data and results etc. from equilibrium ceq -! returns a pointer to the new equilibrium record -! THIS CAN PROBABLY BE SIMPLIFIED, especially phase_varres array can be -! copied as a whole, not each record structure separately ... ??? - implicit none - character name*(*) - integer number - type(gtp_equilibrium_data), pointer ::neweq,ceq -!\end{verbatim} - type(gtp_condition), pointer :: oldcond,lastcond - type(gtp_condition), pointer :: newcond1,newcond2 - type(gtp_condition), pointer :: bugcond - character name2*64 - integer ieq,ipv,jz,iz,jl,jk,novarres,oldeq - logical okname -! -! write(*,*)'In copy_equilibrium',len_trim(name) - nullify(neweq) - if(.not.allowenter(3)) then -! write(*,*)'Not allowed enter a copy' - gx%bmperr=4153; goto 1000 - endif -! write(*,*)'allow enter OK' -! not allowed to enter equilibria if there are no phases -! if(btest(globaldata%status,GSNOPHASE)) then -! write(*,*)'Meaningless to copy equilibria with no phase data' -! gx%bmperr=7777; goto 1000 -! endif -! equilibrium names starting with _ are automatically created by mapping -! and in some other cases. - if(name(1:1).eq.'_') then - name2=name(2:) - jk=1 - elseif(name(1:1).eq.' ') then - write(*,*)'A name must start with a letter' - gx%bmperr=8888; goto 1000 - else - name2=name - jk=0 - endif - call capson(name2) -! write(*,*)'25G Entering copy equilibria: ',name2,jk -! program crashed with this construction -! if(.not.proper_symbol_name(name2,0)) then - okname=proper_symbol_name(name2,0) - if(.not.okname) then -! the name must start with a letter A-Z and contain letters, numbers and _ - gx%bmperr=4122 - goto 1000 - endif -! write(*,*)'25G name check ok: ',jk -! remove initial "_" used for automatically created equilibria - if(jk.eq.1) then -! changing this cause a lot of trouble ... but I do not understand - name2='_'//name2 -! name2=name2(2:) - endif -! check if name already used -! write(*,*)'25G check if name unique: ',name2 - call findeq(name2,ieq) - if(gx%bmperr.eq.0) then - gx%bmperr=4123 - goto 1000 - else -! reset error code - gx%bmperr=0 - endif -! write(*,*)'25G check if name unique: ',eqfree - if(eqfree.le.maxeq) then - ieq=eqfree - eqfree=eqfree+1 - else - write(*,*)'Too many equilibrium required, increase dimension',eqfree - gx%bmperr=9999; goto 1000 - endif - number=ieq - if(ieq.eq.1) then - write(*,*)'Cannot copy to default equilibria' - gx%bmperr=7777; goto 1000 - endif -! write(*,*)'copy eq',eqfree,maxeq,ieq -! allocate data arrayes in equilibrium record - eqlista(ieq)%next=0 - eqlista(ieq)%eqname=name2 - eqlista(ieq)%eqno=ieq -! component list and matrix, if second or higher equilibrium copy content -! write(*,*)'25G: entereq 1A: ',maxel,noofel - allocate(eqlista(ieq)%complist(noofel)) - allocate(eqlista(ieq)%compstoi(noofel,noofel)) - allocate(eqlista(ieq)%invcompstoi(noofel,noofel)) - allocate(eqlista(ieq)%cmuval(noofel)) -! write(*,*)'25G: entereq 1B: ',noofel -! careful here because FIRSTEQ has other dimensions than the other - do jl=1,noofel - eqlista(ieq)%complist(jl)=ceq%complist(jl) - eqlista(ieq)%cmuval(jl)=ceq%cmuval(jl) - do jk=1,noofel - eqlista(ieq)%compstoi(jk,jl)=ceq%compstoi(jk,jl) - eqlista(ieq)%invcompstoi(jk,jl)=ceq%invcompstoi(jk,jl) - enddo - enddo - oldeq=ceq%eqno -! write(*,*)'25G: entereq 2: ',noofel - do jl=1,noofel - eqlista(ieq)%complist(jl)%splink=eqlista(oldeq)%complist(jl)%splink - eqlista(ieq)%complist(jl)%phlink=firsteq%complist(jl)%phlink - eqlista(ieq)%complist(jl)%status=firsteq%complist(jl)%status - if(firsteq%complist(jl)%phlink.gt.0) then -! only if there is a defined reference state - eqlista(ieq)%complist(jl)%refstate=firsteq%complist(jl)%refstate - eqlista(ieq)%complist(jl)%tpref=firsteq%complist(jl)%tpref - eqlista(ieq)%complist(jl)%chempot=zero - do jk=1,noofel - eqlista(ieq)%compstoi(jl,jk)=firsteq%compstoi(jl,jk) - eqlista(ieq)%invcompstoi(jl,jk)=firsteq%invcompstoi(jl,jk) - enddo - if(.not.allocated(eqlista(ieq)%complist(jl)%endmember)) then - iz=size(firsteq%complist(jl)%endmember) - allocate(eqlista(ieq)%complist(jl)%endmember(iz)) - eqlista(ieq)%complist(jl)%endmember=firsteq%complist(jl)%endmember - endif - else - eqlista(ieq)%complist(jl)%refstate=firsteq%complist(jl)%refstate - endif - enddo -! these records keep calculated values of G and derivatives for each phase -! For phase lokph the index to phase_varres is in phlista(lokph)%cslink -! For phase lokph the index to phase_varres is in phlista(lokph)%linktocs(ics) -! for ieq>1 allocate the current number of phase_varres records plus 10 -! for extra composition sets added later - novarres=csfree-1 -! write(*,*)'25G: entereq 3: ',novarres -! BEWARE: allocation: calculating with one phase with 8 composition sets -! and disordered fractions sets !!! - iz=max(noofph,novarres) - allocate(eqlista(ieq)%phase_varres(2*iz)) -! write(*,*)'25G eqlista%phase_varres: ',size(eqlista(ieq)%phase_varres) -! now copy the current content of ceq%phase_varres to this equilibrium -! note, the SELECT_ELEMENT_REFERENCE phase has phase number 0 -! and phase_varres index 1, the number of phase_varres records is not the -! same as number of phases .... -! -! strange error here running STEP on bigfcc4: crash with message: -! Index "3" of dimension 1 of array "eqlista" above upper bound of 2 -! write(*,*)'25G 3737:',novarres,ieq,oldeq,size(eqlista(oldeq)%phase_varres) -! Ahhhh, there are 2 phase_varres records for each phase because of -! disordered fraction set, one for the ordered with 33 y-fractions, one for -! the disordered with 8 y-fractions. -! A simple dimensioning problem: 1 phase, 8 compsets, disordered fracset -! requires 17 phase_varres. Before the "max" above I had dimensioned for 2 - copypv: do ipv=1,novarres - eqlista(ieq)%phase_varres(ipv)=eqlista(oldeq)%phase_varres(ipv) - enddo copypv -900 continue -! write(*,*)'To copy conditions:' -! copy conditions (and experiments) !!! - lastcond=>eqlista(oldeq)%lastcondition - if(associated(lastcond)) then - jz=1 - call copy_condition(eqlista(ieq)%lastcondition,lastcond) -! write(*,770)'25G cc1: ',jz,lastcond%prescribed,& -! eqlista(ieq)%lastcondition%prescribed - newcond1=>eqlista(ieq)%lastcondition - bugcond=>newcond1 - oldcond=>lastcond%next - do while(.not.associated(oldcond,lastcond)) - jz=jz+1 - newcond2=>newcond1 - call copy_condition(newcond1%next,oldcond) - newcond1=>newcond1%next -! write(*,770)'25G cc2: ',jz,oldcond%prescribed,newcond1%prescribed -770 format(a,i2,6(1pe12.4)) - newcond1%previous=>newcond2 - oldcond=>oldcond%next - enddo - newcond1%next=>bugcond -! write(*,*)'Copied all condition',jz - else - nullify(eqlista(ieq)%lastcondition) - endif -! copy experiments) ... later -! - nullify(eqlista(ieq)%lastexperiment) -! -! copy TPfuns and symbols and current values -! write(*,*)'Copy tpval arrays' - eqlista(ieq)%tpval=ceq%tpval - allocate(eqlista(ieq)%eq_tpres(maxtpf)) -! write(*,*)'allocated tpres arrays' - eqlista(ieq)%eq_tpres=ceq%eq_tpres - allocate(eqlista(ieq)%svfunres(maxsvfun)) -! write(*,*)'allocated svfunres arrays' - eqlista(ieq)%svfunres=ceq%svfunres -! copy convergence criteria - eqlista(ieq)%xconv=ceq%xconv - eqlista(ieq)%maxiter=ceq%maxiter -! write(*,*)'finished copy equilibrium',ieq - eqlista(ieq)%eqno=ieq - neweq=>eqlista(ieq) -! write(*,*)'Assigned pointer to new equilibrium',neweq%eqno -1000 continue -! write(*,*)'exit copy_equilibrium' - return - end subroutine copy_equilibrium - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine copy_condition(newrec,oldrec) -! Creates a copy of the condition record "oldrec" and returns a link -! to the copy in newrec. The links to "next/previous" are nullified - implicit none - type(gtp_condition), pointer :: oldrec - type(gtp_condition), pointer :: newrec -!\end{verbatim} -! write(*,*)' *** In copy_condition: ',oldrec%prescribed - allocate(newrec) -! write(*,*)' *** Allocated' - newrec=oldrec -! write(*,*)' *** Copied old condition to new',newrec%prescribed -1000 continue - return - end subroutine copy_condition - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - logical function check_minimal_ford(lokph) -! some tests if the fcc/bcc permutation model can be applied to this phase -! The function returns FALSE if the user may set the FORD or BORD bit of lokph - implicit none - integer lokph -!\end{verbatim} - integer nsl,nc,jl,ll,j2,loksp,lokcs - logical notallowed - integer, dimension(:), allocatable :: const - double precision ss - notallowed=.true. - nsl=phlista(lokph)%noofsubl - if(btest(phlista(lokph)%status1,PHHASP)) then -! The PHASP bit is set if a parameter has been entered (never cleared) - write(kou,*)'Permutation must be set before parameters are entered' - goto 1000 - endif - if(nsl.lt.4) then - write(kou,*)'Phase with permutation must have 4 or more sublattices' - goto 1000 - else -! ordering assumed in first 4 sublattices, that is not really necessary -! ss=phlista(lokph)%sites(1) - lokcs=phlista(lokph)%linktocs(1) - ss=firsteq%phase_varres(lokcs)%sites(1) - nc=phlista(lokph)%nooffr(1) - allocate(const(nc)) - do jl=1,nc - loksp=phlista(lokph)%constitlist(jl) - const(jl)=splista(loksp)%alphaindex - enddo - jl=nc - do ll=2,4 -! if(abs(phlista(lokph)%sites(ll)-ss).gt.1.0D-12) then - if(abs(firsteq%phase_varres(lokcs)%sites(ll)-ss).gt.1.0D-12) then - write(kou,12) -12 format(' Permutation requires the same number of',& - ' sites in first 4 sublattices') - goto 1000 - endif - if(phlista(lokph)%nooffr(ll).ne.nc) then - write(kou,13) -13 format(' Permutation requires that the number of constituents',& - ' are equal'/' in all 4 sublattices for ordering') - goto 1000 - endif -! one must also check the constituents are identical - do j2=1,nc - loksp=phlista(lokph)%constitlist(jl+j2) - if(splista(loksp)%alphaindex.ne.const(j2)) then - write(kou,14) -14 format(' Permutation requires that the constituents in the',& - ' 4 sublattices for'/' ordering are identical') - goto 1000 - endif - enddo - jl=jl+nc - enddo - endif - notallowed=.false. -1000 continue - check_minimal_ford=notallowed - return - end function check_minimal_ford - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - +! +! gtp3B included in gtp3.F90 +! +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ +!> 6. Enter data +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine enter_element(symb,name,refstate,mass,h298,s298) +! Creates an element record after checks. +! symb: character*2, symbol (it can be a single character like H or V) +! name: character, free text name of the element +! refstate: character, free text name of reference state. +! mass: double, mass of element in g/mol +! h298: double, enthalpy difference between 0 and 298.14 K +! s298: double, entropy at 298.15 K + implicit none + CHARACTER*(*) symb,name,refstate + DOUBLE PRECISION mass,h298,s298 +!\end{verbatim} + CHARACTER symb2*2,symb24*24 + integer knr(1),jl,jjj,kkk,nsl,loksp,lokph,nycomp + double precision stoik(1) + character ch1*1,model*24,phname*24,const(1)*24 + if(.not.allowenter(1)) then + gx%bmperr=4125 + goto 1000 + endif +! check input data +100 continue + call capson(symb) + if(ucletter(symb(1:1))) then + if(len(symb).ge.2) then + if(ucletter(symb(2:2)) .or. symb(2:2).eq.' ') then + goto 200 + endif + else + goto 200 + endif + endif +! element name error, must be only letters (except /- already entered) +! write(6,*)'new element not allowed ',symb,gx%bmperr + gx%bmperr=4033 + goto 1000 +200 continue +! check element not already entered + symb2=symb(1:2) +! write(*,202)'new element 1: ',symb,symb2 +202 format(a,'"',a,'"',a,'"') + reallynew: do jl=0,noofel + if(symb2.eq.ellista(jl)%symbol) then + gx%bmperr=4034 + goto 1000 + endif + enddo reallynew +! element name is not really needed but must start with letter +! write(*,12)symb,name,refstate,mass,h298,s298 +!12 format('new_el: "',a,'"',a,'"',a,'"',3(1PE12.4)) + call capson(name) + if(name(1:1).ne.' ') then +! allow empty element state + if(.not.ucletter(name(1:1))) then + gx%bmperr=4035 + goto 1000 + endif + endif +300 continue +! reference state must start with letter, no other check + call capson(refstate) + if(refstate(1:1).ne.' ') then +! allow empty reference state + if(.not.ucletter(refstate(1:1))) then +! error here when 1/2_MOLE_O2(G) etc .... + refstate='GAS_'//refstate +! gx%bmperr=4036 +! goto 1000 + endif + endif +400 continue +! mass, h298-h0 and s298 must not be negative + if(mass.lt.zero) then + gx%bmperr=4037 + goto 1000 + endif + if(h298.lt.zero) then + gx%bmperr=4038 + goto 1000 + endif + if(s298.lt.zero) then + gx%bmperr=4039 + goto 1000 + endif +! All OK, increment noofel and store values in record noofel + noofel=noofel+1 + if(noofel.gt.maxel) then + gx%bmperr=4040 + goto 1000 + endif +! ensure that symbol has no strange characters +! write(*,202)'new element 1B: ',symb,symb2 + ellista(noofel)%symbol=' ' + ellista(noofel)%symbol=symb + ellista(noofel)%name=name + ellista(noofel)%ref_state=refstate + ellista(noofel)%mass=mass + ellista(noofel)%h298_h0=h298 + ellista(noofel)%s298=s298 + ellista(noofel)%status=0 + ellista(noofel)%alphaindex=noofel +! value 0 is H298, 1 H0, 2 G + ellista(noofel)%refstatesymbol=0 +! Now create corresponding species + noofsp=noofsp+1 + if(noofel.gt.maxsp) then + gx%bmperr=4041 + goto 1000 + endif + ellista(noofel)%splink=noofsp +! write(*,202)'new element 1C: ',symb,symb2 + symb24=' ' + symb24=symb2 +! write(*,77)symb,symb2,symb24 +!77 format('new element 77: ',a,'"',a,'"',a,'"') + splista(noofsp)%symbol=symb24 + splista(noofsp)%mass=mass + splista(noofsp)%charge=zero + splista(noofsp)%status=0 + splista(noofsp)%status=ibset(splista(noofsp)%status,SPEL) + splista(noofsp)%alphaindex=noofsp + splista(noofsp)%noofel=1 +! allocate + allocate(splista(noofsp)%ellinks(1)) + allocate(splista(noofsp)%stoichiometry(1)) + splista(noofsp)%ellinks(1)=noofel + splista(noofsp)%stoichiometry(1)=one +! return with error code 0 i.e. no error +! gx%bmperr=0 +! rearrange ELEMENTS and SPECIES to maintain these in alphabetical order + elements(noofel)=noofel + call alphaelorder + species(noofsp)=noofsp + call alphasporder +! As this is an element add the species to the component list of firsteq +! Beware that the alphabetical order may have changed. jjj used later + jjj=ellista(noofel)%alphaindex + if(jjj.lt.noofel) then +! write(*,*)'Fixing components in alphabetical order!!',jjj,noofel + do kkk=noofel,jjj+1,-1 + firsteq%complist(kkk)%splink=firsteq%complist(kkk-1)%splink + firsteq%complist(kkk)%phlink=firsteq%complist(kkk-1)%phlink + firsteq%complist(kkk)%refstate=firsteq%complist(kkk-1)%refstate + firsteq%complist(kkk)%tpref(1)=firsteq%complist(kkk-1)%tpref(1) + firsteq%complist(kkk)%tpref(2)=firsteq%complist(kkk-1)%tpref(2) + enddo + else + jjj=noofel + endif + firsteq%complist(jjj)%splink=noofsp + firsteq%complist(jjj)%phlink=0 +! do not copy element reference state name here + firsteq%complist(jjj)%refstate='SER (default)' + firsteq%complist(jjj)%tpref(1)=2.9815D2 + firsteq%complist(jjj)%tpref(2)=1.0D5 +! copy mass of component from species record + firsteq%complist(jjj)%mass=mass +! NOTE jjj is used below when adding this element to reference phase +! also set the stoichiometry matrix, just the diagonal. Also the inverse + firsteq%compstoi(noofel,noofel)=one + firsteq%invcompstoi(noofel,noofel)=one +! write(*,*)'new_el: ',noofel,name,symb24 + nycomp=noofel + if(noofel.eq.1) then +! create reference phase with index 0 +! phname='ELEMENT_REFERENCE_PHASE ' + phname='SELECT_ELEMENT_REFERENCE' + nsl=1 + knr(1)=1 +! const(1)=name + const(1)=symb24 + stoik(1)=one + model='NON_MIXING' + ch1='Z' + call enter_phase(phname,nsl,knr,const,stoik,model,ch1) + if(gx%bmperr.ne.0) goto 1000 +! set phase hidden as it should never be included in calculations + lokph=0 + phlista(lokph)%status1=ibset(phlista(lokph)%status1,phhid) +! add all additions ?? + else +! Add the element to the reference phase (phase 0) by extending the +! constituent list (and many other arrays) + loksp=firsteq%complist(jjj)%splink + call add_to_reference_phase(loksp) + if(gx%bmperr.ne.0) goto 1000 + endif + if(noofel.gt.0) then +! clear the nodata bit + globaldata%status=ibclr(globaldata%status,GSNODATA) + endif +! if(gx%bmperr.ne.0) goto 1000 +1000 continue +! write(*,*)'created new species: ',noofsp,splista(noofsp)%symbol + return + END subroutine enter_element + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine enter_species(symb,noelx,ellist,stoik) +! creates a new species +! symb: character*24, name of species, often equal to stoichimoetric formula +! noelx: integer, number of elements in stoichiometric formula (incl charge) +! ellist: character array, element names (electron is /-) +! stoik: double array, must be positive except for electron. + implicit none + character symb*(*),ellist(*)*(*) + integer noelx + double precision stoik(*) +!\end{verbatim} + double precision mass,charge + integer elindex(10) + integer loksp,noelxx,jl,jk + if(.not.allowenter(1)) then + gx%bmperr=4125 + goto 1000 + endif + call capson(symb) + if(.not.ucletter(symb(1:1))) then + gx%bmperr=4044 + goto 1000 + endif + if(noelx.le.0 .or. noelx.gt.10) then + gx%bmperr=4045 + goto 1000 + endif +! check symb is unique +! call find_species_record(symb,loksp) + call find_species_record_noabbr(symb,loksp) + if(gx%bmperr.eq.0) then +! strange error reading cadarache database + do jl=1,noofsp + write(*,*)'entered species ',jl,splista(jl)%symbol + enddo + gx%bmperr=4049; goto 1000 + endif + mass=zero + charge=zero + noelxx=noelx +! write(*,*)'enter_species 1A: ',noelx + checkel: do jl=1,noelx + loopel: do jk=-1,noofel + if(ellist(jl).eq.ellista(jk)%symbol) goto 200 + enddo loopel +! an unknown element + gx%bmperr=4046 + goto 1000 +200 continue + elindex(jl)=jk + if(jk.ge.0) then + if(stoik(jl).lt.zero) then + gx%bmperr=4047 + goto 1000 + else + mass=mass+stoik(jl)*ellista(jk)%mass + endif + else +! this is the electron, save negative of stoick as charge negative +! the electron is not counted as "element" when storing + charge=-stoik(jl) + noelxx=noelxx-1 + if(jl.ne.noelx) then +! this must be the last element .... otherwise problem storing stoik + gx%bmperr=4048 + goto 1000 + endif + endif +! write(6,*)'enter_species 2: ',symb,jl,mass,charge + enddo checkel + noofsp=noofsp+1 + if(noofsp.gt.maxsp) then + gx%bmperr=4125 + goto 1000 + endif +! store species data + splista(noofsp)%symbol=symb + splista(noofsp)%mass=mass + splista(noofsp)%charge=charge + splista(noofsp)%alphaindex=noofsp + splista(noofsp)%noofel=noelxx + splista(noofsp)%status=0 + if(charge.ne.zero) then + splista(noofsp)%status=ibset(splista(noofsp)%status,SPION) + endif +! allocate + allocate(splista(noofsp)%ellinks(noelxx)) + allocate(splista(noofsp)%stoichiometry(noelxx)) + loop2: do jl=1,noelxx + splista(noofsp)%ellinks(jl)=elindex(jl) + splista(noofsp)%stoichiometry(jl)=stoik(jl) + enddo loop2 +! return with no error + gx%bmperr=0 +! add species last and rearrange + species(noofsp)=noofsp + call alphasporder +! error: continue would be a nice use of non-digit labels .... +1000 continue + return + END subroutine enter_species + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine enter_phase(name,nsl,knr,const,sites,model,phtype) +! creates the data structure for a new phase +! name: character*24, name of phase +! nsl: integer, number of sublattices (range 1-9) +! knr: integer array, number of constituents in each sublattice +! const: character array, constituent (species) names in sequential order +! sites: double array, number of sites on the sublattices +! model: character, free text +! phtype: character*1, specifies G for gas, L for liquid + implicit none + character name*(*),model*(*),phtype*(*) + integer nsl + integer, dimension(*) :: knr + double precision, dimension(*) :: sites + character, dimension(*) :: const*(*) +!\end{verbatim} + character ch1*1 + double precision formalunits + integer kconlok(maxconst),kalpha(maxconst),iord(maxconst),klok(maxconst) + integer iva(maxconst) + logical externalchargebalance + integer iph,kkk,lokph,ll,nk,jl,jk,mm,lokcs,nkk,nyfas,loksp,tuple +! write(*,*)'enter enter_phase: ',model(1:len_trim(model)) + if(.not.allowenter(2)) then + gx%bmperr=4125 + goto 1000 + endif +! check input + call capson(name) +! if(.not.ucletter(name)) then + if(.not.proper_symbol_name(name,0)) then + write(*,*)'Error for phase name: ',name(1:min(24,len(name))) + gx%bmperr=4053; goto 1000 + endif +! name unique? + call find_phase_by_name_exact(name,iph,kkk) +! write(6,*)'new phase 1A ',name,nsl,gx%bmperr,const(1) + if(gx%bmperr.eq.0) then +! if phase found then error as name not unique ... but check explicitly + lokph=phases(iph) + if(name.eq.phlista(lokph)%name) then + gx%bmperr=4054 + goto 1000 + endif +! name was not exactly the same, accept this phase name also + else + gx%bmperr=0 + endif + if(nsl.lt.1 .or. nsl.gt.maxsubl) then + gx%bmperr=4056 + goto 1000 + endif + site1: do ll=1,nsl + if(sites(ll).le.zero) then +! write(6,*)' new phase 1B: ',name,ll,nsl,sites(ll) + gx%bmperr=4057 + goto 1000 + endif + enddo site1 + nk=0 + knrtest: do ll=1,nsl + if(knr(ll).lt.1 .or. knr(ll).gt.maxconst) then + write(*,*)'enter phase error:',ll,knr(ll),maxconst + gx%bmperr=4058; goto 1000 + endif + if(ll.ge.2 .and. knr(ll).gt.maxcons2) then + gx%bmperr=4059; goto 1000 + endif + nk=nk+knr(ll) + enddo knrtest + nkk=nk +! write(6,*)' enter_phase 3: ',name,nsl,nkk,noofsp +! check constituents exists as species + externalchargebalance=.false. + constest: do jl=1,nkk + if(jl.eq.1 .and. model(1:13).eq.'IONIC_LIQUID ') then +! in this case * is allowed on first sublattice!! + if(const(1)(1:2).eq.'* ') then + kalpha(jl)=-99 + kconlok(jl)=-99 + cycle constest + endif + endif + call capson(const(jl)) +! write(6,297)' enter_phase constituent: ',jl,const(jl),nkk + findspecies: do jk=1,noofsp + if(const(jl).eq.splista(jk)%symbol) then +! write(*,*)'at new 300: ',noofsp,jk,const(jl) + goto 300 + endif + enddo findspecies +! write(6,297)' enter_phase constituent error: ',jl,const(jl),jk,nkk +297 format(a,i3,'>',A,'<',2i3) +! write(*,*)'in enter new phase: ',const(jl) + gx%bmperr=4051 + goto 1000 +! found species, +300 continue +! check for duplicates in same sublattice + kalpha(jl)=splista(jk)%alphaindex + ll=1 + mm=1 + nk=knr(1) +310 continue + if(jl.gt.nk) then + if(ll.lt.nsl) then + ll=ll+1 + mm=nk+1 + nk=nk+knr(ll) + goto 310 + else + write(*,*)'Impossible: constituent index outside range!' + gx%bmperr=9999; goto 1000 + endif + else + do mm=mm,jl-1 +! write(*,314)mm,jl,kalpha(mm),kalpha(jl),& +! const(jl)(1:len_trim(const(jl))),name(1:len_trim(name)) +314 format('3B Species: ',4i4,' "',a,'" in ',a) + if(kalpha(mm).eq.kalpha(jl)) then + write(*,315)name(1:len_trim(name)),& + const(jl)(1:len_trim(const(jl))),ll +315 format(' *** Error, the ',a,' phase has constituent ',a,& + ' twice in sublattice ',i2) + gx%bmperr=8900; goto 1000 + endif + enddo + endif + kconlok(jl)=jk +! write(6,73)' enter_phase 4B: ',jl,const(jl),jk,kconlok(jl),kalpha(jl) +!73 format(A,i3,1x,A6,3I3) +! mark that PHEXCB bit must be set if species has a charge + if(splista(jk)%charge.ne.zero) then + externalchargebalance=.true. + endif + enddo constest +! reserve a new phase record and store data there and in other records +! the first phase entered is the reference phase created by init_gtp + if(noofph.eq.0 .and. phtype(1:1).eq.'Z') then +! phtyp=Z is the reference phase + nyfas=0 + else +! sort the phase in alphabetical order but always gas (if any) first +! then liquids specified by the phtype letter (G, L, etc) + noofph=noofph+1 + if(nyfas.gt.size(phlista)) then + write(*,*)'Too many phases: ',noofph + gx%bmperr=6699; goto 1000 + endif + nyfas=noofph + endif + phlista(nyfas)%name=name + phlista(nyfas)%status1=0 + ionliq: if(model(1:13).eq.'IONIC_LIQUID ') then +! the external charge balance set above, not needed +! write(*,*)' *** ionic liquid entered!!!' + externalchargebalance=.FALSE. +! ionic liquid may have phtype='Y', change that to L + if(phtype(1:1).eq.'Y') phtype(1:1)='L' + if(nsl.ne.2) then +! if entered with only one sublattice then no cations and only neutrals!! + write(*,*)'Ionic liquid must have 2 sublattices' + gx%bmperr=7777; goto 1000 + endif + phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHIONLIQ) +! constituents in ionic liquid must be sorted in a special way + call sort_ionliqconst(lokph,0,knr,kconlok,klok) + if(gx%bmperr.ne.0) goto 1000 + else ! else link is for all other phases except ionic liquid +! sort the constituents in each sublattice according to alphaspindex +! write(6,70)5,(kalpha(i),i=1,nkk) +! write(6,70)5,(kconlok(i),i=1,nkk) +!70 format('enter_phase ',I2,': ',20I3) + nk=1 + sort1: do ll=1,nsl + call sortin(kalpha(nk),knr(ll),iord(nk)) + if(buperr.ne.0) then + gx%bmperr=buperr + goto 1000 + endif +! iord(nk+1:nk+knr(ll)) has numbers 1..knr(ll), add on nk-1 to these +! to be in parity with index of kalpha(nk+1:nk+knr(ll)) + adjust: do mm=0,knr(ll)-1 + iord(nk+mm)=iord(nk+mm)+nk-1 + enddo adjust + nk=nk+knr(ll) + enddo sort1 +! write(6,70)6,(kalpha(i),i=1,nkk) +! write(6,70)6,(kconlok(iord(i)),i=1,nkk) +! in constituent record store kconlok(iord(i)) +! verify we can find species name ... +! test7: do kk=1,nkk +! write(6,71)kk,iord(kk),kconlok(iord(kk)),splista(kconlok(iord(kk)))%symbol +!71 format('enter_phase 7: ',3I3,1x,A) +! enddo test7 + do jl=1,nkk + klok(jl)=kconlok(iord(jl)) + enddo + endif ionliq +!---------------------------------------- +! write(6,79)8,name,(klok(kk),kk=1,nkk) +79 format('enter_phase ',I2,': ',A6,10I3) + ch1=phtype(1:1) + call capson(ch1) +! sort the phase in alphabetical but order but first gas, then liquid etc +! legal values of ch1 is G, L, S and C (gas, liquid, solution, compound) +! write(*,*)'3B phase byte: ',ch1 + if(ch1.eq.'G') then + phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHGAS) + model='ideal' + elseif(ch1.eq.'L') then + phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHLIQ) + endif +! I is used by TC to indicate charge balance needed, ignore + if(ch1.eq.' ' .or. ch1.eq.'I') ch1='S' +! ch1='S' + phlista(nyfas)%phletter=ch1 + phlista(nyfas)%models=model + if(nyfas.eq.0) then + continue + else + call alphaphorder(tuple) + phlista(nyfas)%nooffs=1 + endif + phlista(nyfas)%noofsubl=nsl + allocate(phlista(nyfas)%nooffr(nsl)) +! sites stored in phase_varres +! allocate(phlista(nyfas)%sites(nsl)) + formalunits=zero + do ll=1,nsl + phlista(nyfas)%nooffr(ll)=knr(ll) +! phlista(nyfas)%sites(ll)=sites(ll) + formalunits=formalunits+sites(ll) + enddo +! write(*,*)'enter_phase 8x: ',nyfas,nkk + phlista(nyfas)%tnooffr=nkk +! write(*,*)'enter_phase 8y: ',nyfas,phlista(nyfas)%tnooffr +! create consituent record + call create_constitlist(phlista(nyfas)%constitlist,nkk,klok) +! in phase_varres we will indicate the VA constituent, indicate in iva + valoop: do jl=1,nkk + iva(jl)=0 + loksp=phlista(nyfas)%constitlist(jl) + if(loksp.gt.0) then +! ionic liquid can have a wildcard */-99 as constituent in first sublattice + if(btest(splista(loksp)%status,SPVA)) iva(jl)=ibset(iva(jl),CONVA) + endif + enddo valoop +! write(*,32)'new_ph 14A: ',nyfas,(phlista(nyfas)%constitlist(iz),iz=1,nkk) +32 format(a,i3,50(i3)) +! write(*,33)nkk,(iva(i),i=1,nkk) +!33 format('enter_phase 14B: ',i3,2x,10i3) +! nprop=10 +! write(*,*)'enter_phase: ',lokcs,name + call create_parrecords(nyfas,lokcs,nsl,nkk,maxcalcprop,iva,firsteq) +! write(*,*)'enter_phase 15: ',nyfas,lokcs + if(gx%bmperr.ne.0) goto 1000 +! zero array of pointer to phase_varres record, then set first + phlista(nyfas)%linktocs=0 + phlista(nyfas)%linktocs(1)=lokcs + phlista(nyfas)%noofcs=1 + firsteq%phase_varres(lokcs)%phlink=nyfas + firsteq%phase_varres(lokcs)%prefix=' ' + firsteq%phase_varres(lokcs)%suffix=' ' + firsteq%phase_varres(lokcs)%abnorm(1)=formalunits +! ncc no longer part of this record +! firsteq%phase_varres%ncc=nkk +! zero the phstate + firsteq%phase_varres(lokcs)%phstate=0 +! sites must be stored in phase_varres + do ll=1,nsl + firsteq%phase_varres(lokcs)%sites(ll)=sites(ll) + enddo +! make sure status word and some other links are set to zero + firsteq%phase_varres(lokcs)%status2=0 +! Setting of phase tuple is done in alphaphorder +! tuple=nooftuples+1 +! phasetuple(tuple)%phase=nyfas +! phasetuple(tuple)%compset=1 +! nooftuples=tuple + firsteq%phase_varres(lokcs)%phtupx=tuple +! write(*,*)'3B new phase tuple: ',nyfas,lokcs,tuple +! If one has made NEW the links are not always zero +! set some phase bits (PHGAS and PHLIQ set above) +! external charge balance etc. + if(externalchargebalance) then + phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHEXCB) + endif + if(nsl.eq.1) then +! if no sublattices set ideal bit. Will be cleared if excess parameter entered + phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHID) + endif + if(nkk.eq.nsl) then +! as many constiuents as sublattice + phlista(nyfas)%status1=ibset(phlista(nyfas)%status1,PHNOCV) + endif +! nullify links + nullify(phlista(nyfas)%additions) + nullify(phlista(nyfas)%ordered) + nullify(phlista(nyfas)%disordered) +! initiate phcs, the phase composition set counter for nyfas redundant ?? +! (not for reference phase 0) +! if(nyfas.gt.0) phcs(nyfas)=1 + if(noofph.gt.0) then +! clear the nophase bit + globaldata%status=ibclr(globaldata%status,GSNOPHASE) + endif +1000 continue +! write(*,*)'end enter_phase' disfra + return + END subroutine enter_phase + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine sort_ionliqconst(lokph,mode,knr,kconlok,klok) +! sorts constituents in ionic liquid, both when entering phase +! and decoding parameter constituents +! order: 1st sublattice only cations +! 2nd: anions, VA, neutrals +! mode=0 at enter phase, wildcard ok in 1st sublattice if neiher anions nor Va +! mode=1 at enter parameter (wildcard allowed, i.e. some kconlok(i)=-1) +! some parameters not allowed, L(ion,A+:B,C), must be L(ion,*:B,C), check! + implicit none + integer lokph,knr(*),kconlok(*),klok(*),mode +!\end{verbatim} + integer nk,jl,jk,mm,kkk,ionva,byte + integer, dimension(:), allocatable :: kalpha,iord,iva,anion +! + allocate(kalpha(knr(1)+knr(2))) + allocate(iord(knr(1)+knr(2))) + allocate(iva(knr(1)+knr(2))) + allocate(anion(knr(1)+knr(2))) +! check1: constituents in sublattice 1 must all have positive charge +! if(mode.eq.1) then +! write(*,17)'sl2: ',knr(1),knr(2),(kconlok(mm),mm=1,knr(1)+knr(2)) +!17 format(a,2i3,2x,10i3) +! endif + do nk=1,knr(1) + if(kconlok(nk).lt.0) then +! wildcard give index -99. If mode=0 more checks later + kalpha(nk)=-99 + elseif(splista(kconlok(nk))%charge.le.zero) then + write(*,*)'In ionic_liquid only cations on first sublattice' + gx%bmperr=7777; goto 1000 + else + kalpha(nk)=splista(kconlok(nk))%alphaindex + endif + enddo +! write(*,69)'In 1: ',knr(1),(kconlok(mm),mm=1,knr(1)) + if(knr(1).gt.1) then + call sortin(kalpha,knr(1),iord) + if(buperr.ne.0) then + gx%bmperr=buperr + goto 1000 + endif + if(mode.eq.0 .and. kalpha(1).lt.0) then +! when entering phase a single wildcard allowed in first sublattice + write(*,*)'Illegal parameter with wildcard mixed with cations' + gx%bmperr=7777; goto 1000 + endif + do jl=1,knr(1) + klok(jl)=kconlok(iord(jl)) + enddo + else + klok(1)=kconlok(1) + endif +! write(*,69)'1st: ',knr(1),(kalpha(mm),mm=1,knr(1)) +! check2: constituents in sublattice 1 must be ANIONS, VA and NEUTRALS +! in that order + kkk=knr(1) + jl=0 + jk=0 + ionva=0 + do nk=1,knr(2) + if(mode.eq.0 .and. kconlok(nk+kkk).lt.0) then +! when entering phase no wildcards allowed in second sublattice + write(*,*)'You cannot enter phase with wildcard on 2nd sublattice' + gx%bmperr=7777; goto 1000 + elseif(kconlok(nk+kkk).lt.0) then +! wildcard, treat as anion ?? DO NOT ALLOW, what stoichiometry?? + write(*,*)'Ionic_liq parameter with wildcard on 2nd sublat. illegal' + gx%bmperr=7777; goto 1000 +! jk=jk+1 +! anion(jk)=nk + elseif(splista(kconlok(nk+kkk))%charge.gt.zero) then + write(*,*)'No cations allowed on second sublattice' + gx%bmperr=7777; goto 1000 + elseif(btest(splista(kconlok(nk+kkk))%status,SPVA)) then +! this is the hypothetical vacancy + ionva=nk + elseif(splista(kconlok(nk+kkk))%charge.eq.zero) then +! neutral species allowed, use iva, must be sorted after all anions and Va + jl=jl+1 + iva(jl)=nk + else +! anion + jk=jk+1 + anion(jk)=nk + endif + enddo +! write(*,88)'at 1: ',knr(2),(kconlok(knr(1)+mm),mm=1,knr(2)) +88 format(a,i4,2x,20i3) +! There are jl neutrals and jk anions, if vacancies set it as jk+1 +! if wildcard on first sublattice neither ainons nor Va allowed on 2nd + if(klok(1).lt.0 .and. (jk.gt.0 .or. ionva.ne.0)) then + write(*,*)'Only neutrals on second sublattice if wildcard on first' + gx%bmperr=7777; goto 1000 + endif + do nk=1,jk + if(anion(nk).gt.nk) then +! shift the anion to position nk, kconlok must be updated + if(ionva.eq.nk) then + byte=kconlok(kkk+nk) + kconlok(kkk+nk)=kconlok(kkk+anion(nk)) + ionva=anion(nk) + kconlok(kkk+ionva)=byte +! write(*,88)'byt 1: ',knr(2),(kconlok(knr(1)+mm),mm=1,knr(2)) + else + do mm=1,jl + if(iva(mm).eq.nk) exit + enddo + if(mm.gt.jl) stop 'big bug' + byte=kconlok(kkk+nk) + kconlok(kkk+nk)=kconlok(kkk+anion(nk)) + iva(mm)=anion(nk) + kconlok(kkk+iva(mm))=byte +! write(*,88)'byt 2: ',knr(2),(kconlok(knr(1)+mm),mm=1,knr(2)) + endif + anion(nk)=nk + endif + enddo +! write(*,88)'at 2: ',knr(2),(kconlok(knr(1)+mm),mm=1,knr(2)) +! now all ions should be in positions 1..jk. Fix position of vacancy +! by moving neiutrals + if(ionva.gt.jk+1) then + byte=kconlok(kkk+jk+1) + kconlok(kkk+jk+1)=kconlok(kkk+ionva) + kconlok(kkk+ionva)=byte + iva(ionva)=ionva + ionva=jk+1 + endif +! write(*,88)'at 3: ',knr(2),(kconlok(knr(1)+mm),mm=1,knr(2)) +! write(*,69)'2nda: ',jk,& +! (splista(kconlok(kkk+anion(mm)))%alphaindex,mm=1,jk) +! if(ionva.gt.0) & +! write(*,69)'2ndv: ',1,splista(kconlok(kkk+ionva))%alphaindex +! write(*,69)'2ndn: ',jl,& +! (splista(kconlok(kkk+iva(mm)))%alphaindex,mm=1,jl) +69 format(a,i3,2x,10i3,i5,10i3) + do mm=1,knr(2) + if(kconlok(kkk+mm).lt.0) then + kalpha(mm+kkk)=-99 + else + kalpha(mm+kkk)=splista(kconlok(kkk+mm))%alphaindex + endif + enddo + kkk=knr(1)+1 +! write(*,69)'2ndx: ',knr(2),(kalpha(mm+kkk-1),mm=1,knr(2)) + if(jk.gt.1) then +! write(*,69)'kalpha: ',jk,(kalpha(kkk+mm-1),mm=1,jk) + call sortin(kalpha(kkk),jk,iord) + if(buperr.ne.0) then + gx%bmperr=buperr; goto 1000 + endif +! write(*,69)'sort jk: ',jk,(iord(kkk+mm-1),mm=1,jk) + do mm=1,jk + klok(kkk+mm-1)=kconlok(kkk+iord(mm)-1) + enddo + elseif(jk.gt.0) then + klok(kkk)=kconlok(kkk) + endif + kkk=kkk+jk + if(ionva.gt.0) then + klok(kkk)=kconlok(kkk) + kkk=kkk+1 + endif + if(jl.gt.1) then + call sortin(kalpha(kkk),jl,iord) + if(buperr.ne.0) then + gx%bmperr=buperr; goto 1000 + endif + do mm=1,jl + klok(kkk+mm-1)=kconlok(kkk+iord(mm)-1) + enddo + elseif(jl.gt.0) then + klok(kkk)=kconlok(kkk) + endif + if(mode.eq.1) then +! final check for parameters: +! if only neutrals on sublatice 2 no interaction allowed on sublattice 1 + if(jk.eq.0 .and. ionva.eq.0) then + if(knr(1).gt.1) then + write(*,*)'Illegal interaction parameter' + gx%bmperr=7777; goto 1000 + else +! replace whatever constituent specified in sublattice 1 by wildcard + klok(1)=-99 + endif + endif + endif +! write(*,69)'al1: ',knr(1)+knr(2),& +! (klok(mm),mm=1,knr(1)+knr(2)) +! write(*,69)'al2: ',knr(1)+knr(2),& +! (splista(klok(mm))%alphaindex,mm=1,knr(1)+knr(2)) +!---------------------------------------------------------- +1000 continue + return + end subroutine sort_ionliqconst + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine enter_composition_set(iph,prefix,suffix,icsno) +! adds a composition set to a phase. +! iph: integer, phase index +! prefix: character*4, optional prefix to original phase name +! suffix: character*4, optional suffix to original phase name +! icsno: integer, returned composition set index (value 2-9) +! ceq: pointer, to current gtp_equilibrium_data +! +! BEWARE this must be done in all equilibria (also during parallel processes) +! There may still be problems with equilibria saved during STEP and MAP +! + implicit none + integer iph,icsno + character*(*) prefix,suffix +! TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} +! also update phasetuple array !! + TYPE(gtp_equilibrium_data), pointer :: ceq + integer lokph,ncs,nsl,nkk,lokcs,lokcs1,nprop,lastcs,jl,nyttcs + integer leq,nydis,tuple,nz + character*4 pfix,sfix + integer iva(maxconst) + TYPE(gtp_phase_varres), pointer :: peq,neq,ndeq +! + if(iph.le.0 .or. iph.gt.noofph) then + gx%bmperr=4050; goto 1000 + endif + lokph=phases(iph) + ncs=phlista(lokph)%noofcs + if(ncs.gt.8) then +! max 9 composition sets + gx%bmperr=4092; goto 1000 + endif + ceq=>firsteq + icsno=ncs+1 +! collect some data needed + nsl=phlista(lokph)%noofsubl + nkk=phlista(lokph)%tnooffr + lokcs=phlista(lokph)%linktocs(phlista(lokph)%noofcs) + lokcs1=lokcs + nprop=ceq%phase_varres(lokcs)%nprop + lastcs=phlista(lokph)%linktocs(phlista(lokph)%noofcs) +! one must set the VA bit in the constituent status array + ivaloop: do jl=1,nkk + iva(jl)=ceq%phase_varres(lastcs)%constat(jl) + enddo ivaloop +! check that prefix is empty or start with a letter + if(biglet(prefix(1:1)).ne.' ' .and. & + (biglet(prefix(1:1)).lt.'A' .or. biglet(prefix(1:1)).gt.'Z')) then + write(*,*)'Prefix of composition set must start with a letter' + gx%bmperr=4167; goto 1000 + endif + if(biglet(suffix(1:1)).ne.' ' .and. & + (biglet(suffix(1:1)).lt.'A' .or. biglet(suffix(1:1)).gt.'Z')) then + write(*,*)'Suffix of composition set must start with a letter' + gx%bmperr=4167; goto 1000 + endif +!------------------------------------------------------------------ +! begin threadprotected code >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! composition sets must be created in all equilibria +! note that indices to phase_varres same in all equilibria +! >>> beware not tested created composition sets with several equilibria +! maybe this call can be replaced by a simple assignment???? +! call create_parrecords(lokph,nyttcs,nsl,nkk,maxcalcprop,iva,ceq) +! call create_parrecords(lokph,nyttcs,nsl,nkk,maxcalcprop,iva,firsteq) + call create_parrecords(lokph,nyttcs,nsl,nkk,maxcalcprop,iva,firsteq) + if(gx%bmperr.ne.0) goto 1000 +! write(*,*)'add_cs: ',nyttcs +! add new tuple at the end and save tuple index + tuple=nooftuples+1 + phasetuple(tuple)%phase=iph + phasetuple(tuple)%compset=icsno + nooftuples=tuple +! write(*,*)'3B Adding phase tuple: ',tuple,lastcs,nyttcs +! save index of tuple in new phase_varres record + firsteq%phase_varres(nyttcs)%phtupx=tuple +! firsteq%phase_varres(lastcs)%phtupx=tuple +! peq=>eqlista(1)%phase_varres(lastcs) + peq=>firsteq%phase_varres(lastcs) +! write(*,*)'3B added compset: ',iph,icsno,noeq() + alleq: do leq=1,noeq() +! LOOP for all equilibria records to add this composition set to phase lokph +! lastcs is the previously last composition set, nyttcs is the new, +! same in all equilibria!! + neq=>eqlista(leq)%phase_varres(nyttcs) +! write(*,19)leq,eqlista(leq)%eqno +19 format('Equilibra: ',10i4) + phlista(lokph)%linktocs(icsno)=nyttcs + neq%phlink=lokph +! prefix and suffix, only letters and digits allowed but not checked ... + pfix=prefix; sfix=suffix; call capson(pfix); call capson(sfix) + neq%prefix=pfix + neq%suffix=sfix +! tuple index + neq%phtupx=tuple +! initiate the phstate as entered (value 0) + neq%phstate=PHENTERED +! increment composition set counter when leq=1, phlista same in all equilibria + if(leq.eq.1) then + phlista(lokph)%noofcs=phlista(lokph)%noofcs+1 + endif +! write(*,311)'3B sites: ',leq,iph,icsno,neq%sites +! sites, abnorm and amount formula units + if(.not.allocated(neq%sites)) allocate(neq%sites(nsl)) + neq%sites=peq%sites + neq%abnorm=peq%abnorm + neq%amfu=zero +! write(*,311)'3B amfu: ',leq,iph,icsno,neq%amfu,neq%abnorm,peq%abnorm +311 format(a,3i3,6(1pe12.4)) +! NOTE: these allocations below because create_parrecords does not work ... +! fractions and related + nz=size(peq%yfr) + if(.not.allocated(neq%yfr)) then + allocate(neq%yfr(nz)) + neq%yfr=peq%yfr + endif + if(.not.allocated(neq%mmyfr)) then + allocate(neq%mmyfr(nz)) + neq%mmyfr=peq%mmyfr + endif + if(.not.allocated(neq%constat)) then +! important!! constat has identification of the vacancy constituent !! + allocate(neq%constat(nz)) + neq%constat=peq%constat + endif +! copy status word but clear some bits CSDEFCON means default constitution + neq%status2=peq%status2 + neq%status2=ibclr(neq%status2,CSDEFCON) +! + if(.not.allocated(neq%gval)) then +! result arrays should have been allocated in create_parrecords ... +! but I do not call create_parrecords !! +! write(*,83)'3B gval: ',leq,lokph,nyttcs,nprop,nz +83 format(a,10i4) + allocate(neq%gval(6,nprop)) + allocate(neq%dgval(3,nz,nprop)) + allocate(neq%d2gval(nz*(nz+1)/2,nprop)) + allocate(neq%listprop(nprop)) + endif +!-------------------- +! write(*,88)'3B cs: ',nz,neq%status2,neq%constat +88 format(a,i2,2x,Z16,2x,10(1x,i3)) +! if there is a disordered fraction set one must copy the fraction set record +! and add a new parrecords to this. lokcs1 is first composition set + disordered: if(btest(phlista(lokph)%status1,phmfs)) then +! copy the old fraction set record to the new +!------------------------ does this work??? disfra has a lot of data + neq%disfra=peq%disfra +!------------------------- yes it works!! +! write(*,*)'disfra 1: ',peq%disfra%ndd,neq%disfra%ndd +! write(*,*)'disfra 2: ',peq%disfra%dxidyj(2),neq%disfra%dxidyj(2) +!-------------------------------------- + nsl=peq%disfra%ndd + nkk=peq%disfra%tnoofxfr +! write(*,*)'Creating disordered fraction set 1',lokcs1,nyttcs,nkk + do jl=1,nkk + iva(jl)=ceq%phase_varres(lokcs1)%constat(jl) + enddo + if(leq.eq.1) then +! allocate a parrecord for disordered fraction set for first equilibrium. +! Then use the same index: nydis, for all other equilibria. +! Maybe this can be made by a simple assignement???? + call create_parrecords(lokph,nydis,nsl,nkk,maxcalcprop,iva,firsteq) + if(gx%bmperr.ne.0) goto 1000 + else + write(*,*)'Using the same: ',leq,lokcs1,nydis + endif + ndeq=>eqlista(leq)%phase_varres(nydis) + ndeq%phlink=lokph + ndeq%prefix=' ' + ndeq%suffix=' ' +! sites must be copied to disordered phase_varres +! write(*,*)'3B dsites: ',size(neq%disfra%dsites),size(neq%sites) + ndeq%disfra%dsites=peq%disfra%dsites +! some status bits must be set + ndeq%status2=ibset(ndeq%status2,CSDFS) + neq%status2=ibset(neq%status2,CSDLNK) +! set the link from ordered disfra record to the disordered phase_varres record + neq%disfra%varreslink=nydis + endif disordered + enddo alleq +! end threadprotected code <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +!------------------------------------------------- +! write(*,*)'Link from ordred ',lastcs,& +! ' to disordered ',ceq%phase_varres(lastcs)%disfra%varreslink +! next=ceq%phase_varres(lastcs)%next +! write(*,*)'Link from ordred ',next,& +! ' to disordered ',ceq%phase_varres(next)%disfra%varreslink +1000 continue + return +! %status2 + end subroutine enter_composition_set + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine remove_composition_set(iph,force) +! the last composition set is deleted +! +! >>>>>>>>>>>>>>>>>>>>>>>>>>>> NOTE <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ! +! Not safe to remove composition sets when more than one equilibrium ! +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ! +! +! If force is TRUE delete anyway ... very dangerous ... +! + implicit none +! +! BEWARE must be for all equilibria but maybe not allowed when threaded +! + integer iph,jl,tuple + logical force +!\end{verbatim} + TYPE(gtp_phase_varres), pointer :: varres,disvarres + integer ics,lokph,lokcs,ncs,nsl,nkk,lastcs,nprop,idisvarres,kcs,leq +! + if(iph.le.0 .or. iph.gt.noofph) then + gx%bmperr=4050; goto 1000 + endif + lokph=phases(iph) + ncs=phlista(lokph)%noofcs + if(ncs.eq.1) then +! cannot remove composition set 1 or a nonexisting one + gx%bmperr=4093; goto 1000 + else + ics=ncs + endif + if(noeq().gt.1) then + if(force) then + write(*,*)' *** WARNING: deleting composition sets may cause errors' + else + write(*,*)'Cannot delete composition sets when several equilibria' + gx%bmperr=7777; goto 1000 + endif + endif +! find this tuple + do jl=1,nooftuples + if(phasetuple(jl)%phase.eq.iph) tuple=jl + enddo +! collect some data + nsl=phlista(lokph)%noofsubl + nkk=phlista(lokph)%tnooffr + lokcs=phlista(lokph)%linktocs(ics) + lastcs=lokcs + nprop=firsteq%phase_varres(lokcs)%nprop +! write(*,*)'3B Removing varres record: ',lastcs +!------------------------------------- +! begin threadprotected code to remove lastcs >>>>>>>>>>>>>>>>>>> +! delete compset ics, shift higher down (not necessary) +! deallocate data in lokcs and return records to free list +!------------------------------------- +! note that the index to phase_varres is the same in all equilibria!!!! + alleq: do leq=1,noeq() + varres=>eqlista(leq)%phase_varres(lastcs) + deallocate(varres%constat) + deallocate(varres%yfr) + deallocate(varres%mmyfr) + deallocate(varres%sites) +! these may not be allocated ... +! write(*,*)'delete varres dsitesdy: ',leq,lokcs,size(varres%dsitesdy) +! if(size(varres%dsitesdy).gt.1) deallocate(varres%dsitesdy) +! if(size(varres%d2sitesdy2).gt.1) deallocate(varres%d2sitesdy2) + deallocate(varres%listprop) + deallocate(varres%gval) + deallocate(varres%dgval) + deallocate(varres%d2gval) +! There is a disordered fraction record .... more to deallocate + disordered: if(allocated(varres%disfra%y2x)) then + deallocate(varres%disfra%dsites) + deallocate(varres%disfra%nooffr) + deallocate(varres%disfra%splink) + deallocate(varres%disfra%y2x) + deallocate(varres%disfra%dxidyj) +! now deallocate and release the phase_varres record with disordered fractions + idisvarres=varres%disfra%varreslink + disvarres=>eqlista(leq)%phase_varres(idisvarres) +! write(*,*)'3B Deallocationg disordered varres record ',idisvarres + deallocate(disvarres%constat) + deallocate(disvarres%yfr) + if(allocated(disvarres%mmyfr)) deallocate(disvarres%mmyfr) + deallocate(disvarres%sites) +! these may not be allocated ... +! write(*,*)'delete cs dsitesdy: ',leq,size(disvarres%dsitesdy) +! if(size(disvarres%dsitesdy).gt.1) deallocate(disvarres%dsitesdy) +! if(size(disvarres%d2sitesdy2).gt.1) deallocate(disvarres%d2sitesdy2) + deallocate(disvarres%listprop) + deallocate(disvarres%gval) + deallocate(disvarres%dgval) + deallocate(disvarres%d2gval) +! BOS 1401227: I do not think this is an error, just ignore ... +! if(size(disvarres%disfra%dsites).gt.0) then +! write(*,*)'ERROR, only one level of disordering allowed',leq,& +! size(disvarres%disfra%dsites) +! stop +! endif + else + idisvarres=0 + endif disordered + enddo alleq +! write(*,*)'Done all equilibrium records' +! decrement the composition set counter for this phase +! the phlista record is global, not part of the equilibria + phlista(lokph)%noofcs=phlista(lokph)%noofcs-1 +! link the released phase_varres record back to free list, +! maintained in firsteq only + if(idisvarres.ne.0) then +! there was a disordered phase_varres record, link it into free list +! BUT WE HAVE NOT DEALLOCATED ANYTHING .... +! write(*,*)'3B Free list 2: ',csfree,idisvarres + firsteq%phase_varres(idisvarres)%nextfree=csfree + csfree=idisvarres + endif +! link the free phase_varres into the free list +! write(*,*)'3B Free list 1: ',csfree,lastcs + firsteq%phase_varres(lastcs)%nextfree=csfree + csfree=lastcs +! finally shift all composition sets in phlista(lokph)%linktocs +! if last deleted then ics>phlista(lokph)%noofcs + do kcs=ics,phlista(lokph)%noofcs + phlista(lokph)%linktocs(kcs)=phlista(lokph)%linktocs(kcs+1) + enddo +! and zero the last pointer to composition set. + phlista(lokph)%linktocs(phlista(lokph)%noofcs+1)=0 +! write(*,*)'Free list 1: ',csfree,lokcs +! update phasetuple array, overwrite tuple. This means tuples may change phase +! NOTE the first tuple for a phase+compset will never change position. Only +! those created later may be shifted ... but that may be complicated enough ... +! write(*,*)'Shifting phase tuples above deleted: ',tuple + do jl=tuple+1,nooftuples + phasetuple(jl-1)%phase=phasetuple(jl)%phase + phasetuple(jl-1)%compset=phasetuple(jl)%compset +! we must change the link in the phase_varres record also!! + lokph=phases(phasetuple(jl-1)%phase) + lokcs=phlista(lokph)%linktocs(phasetuple(jl-1)%compset) +! write(*,*)'3B Shifting down ',jl +! in all equilibrium records, luckily the phase_varres record the same!! + do leq=1,noeq() + eqlista(leq)%phase_varres(lokcs)%phtupx=jl-1 + enddo + enddo + nooftuples=nooftuples-1 +! write(*,*)'3B Warning: phase tuples may have changed phase ...' +! end threadprotected code <<<<<<<<<<<<<<<<<<<<<<<< +!------------------------- +1000 continue + return + end subroutine remove_composition_set + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine enter_parameter(lokph,typty,fractyp,nsl,endm,nint,lint,ideg,& + lfun,refx) +! enter a parameter for a phase from database or interactivly +! typty is the type of property, 1=G, 2=TC, ... , n*100+icon MQ&const#subl +! fractyp is fraction type, 1 is site fractions, 2 disordered fractions +! nsl is number of sublattices +! endm has one constituent index for each sublattice +! constituents in endm and lint should be ordered so endm has lowest +! (done by decode_constarr) +! nint is number of interacting constituents (can be zero) +! lint is array of sublattice+constituent indices for interactions +! ideg is degree +! lfun is link to function (integer index) +! refx is reference (text) +! if this is a phase with permutations all interactions should be in +! the first or the first two identical sublattices (except interstitals) +! a value in endm can be negative to indicate wildcard +! for ionic liquid constituents must be sorted specially + implicit none + integer, dimension(*) :: endm + character refx*(*) + integer lokph,fractyp,typty,nsl,nint,ideg,lfun + integer, dimension(2,*) :: lint +!\end{verbatim} + character notext*20,funexp*512 + integer iord(maxsubl),jord(2,maxsubl) + integer again,kkk,ll,kk1,mint,kk,lokint,iz,it,kint,ib,jl,zz + integer lj,i1,i2,newint,ifri,lokcs,noperm,firstint,listfun + integer, dimension(24) :: intperm + integer, dimension(:,:), allocatable :: elinks + integer, dimension(:,:), allocatable :: intlinks + type(gtp_endmember), pointer :: newem,endmemrec,lastem + type(gtp_interaction), pointer :: intrec,lastint,newintrec +! type(gtp_interaction), allocatable, target :: newintrec + type(gtp_property), pointer :: proprec,lastprop + TYPE(gtp_fraction_set) :: disfra + logical ionliq +! + if(gx%bmperr.ne.0) then + write(*,*)'Error ',gx%bmperr,' already set entering enter_parameter!' + gx%bmperr=0 + endif +! listfun used when calling this routine just to list a parameter + listfun=0 + if(fractyp.eq.2) goto 50 +! this is for site fractions +! write(*,6)'enter_parameter 1: ',lokph,nsl,phlista(lokph)%noofsubl,nint,ideg +6 format(a,10i5) + if(nsl.ne.phlista(lokph)%noofsubl) then + gx%bmperr=4065; goto 1000 + endif + kkk=0 + jord=0 + sublloop: do ll=1,nsl + emloop: do kk=1,phlista(lokph)%nooffr(ll) + kk1=kkk+kk +! write(*,12)lokph,nsl,ll,endm(ll),kk1,phlista(lokph)%constitlist(kk1) +!12 format('enter_parameter 2A: '4I4,5x,2i5) + if(endm(ll).eq.phlista(lokph)%constitlist(kk1)) then + iord(ll)=kk1 + goto 17 + endif + enddo emloop + if(endm(ll).eq.-99) then +! wildcard, sorted at the end + iord(ll)=-99 + else +! write(*,*)'error in enter_parameter ',endm(ll) + gx%bmperr=4096; goto 1000 + endif +17 continue + kkk=kkk+phlista(lokph)%nooffr(ll) + enddo sublloop +! write(*,*)'enter_parameter 2B: ',(iord(ll),ll=1,nsl) +! if(nint.eq.2) write(*,*)'enter_parameter 2C: ************************ ' +! end member constituents found, check interaction +! interactions are in sublattice order in lint +!80 continue + mint=1 +23 continue + kkk=0 + if(mint.le.nint) then + do ll=1,nsl + if(lint(1,mint).eq.ll) then + intloop: do kk=1,phlista(lokph)%nooffr(ll) + kkk=kkk+1 +! write(*,15)mint,lint(2,mint),kkk,phlista(lokph)%constitlist(kkk) + if(lint(2,mint).eq.phlista(lokph)%constitlist(kkk)) then +! write(*,*)'enter_parameter jord: ',mint,ll,kkk +! write(*,*)'Int no, subl, const: ',mint,ll,kkk + jord(1,mint)=ll + jord(2,mint)=kkk + mint=mint+1 +! write(*,*)'enter_parameter mint1: ',mint,ll,kkk,nint + if(mint.gt.nint) goto 28 + goto 23 + endif + enddo intloop +! a constituent does not exist in sublattice ll +! write(*,16)ll,mint,lint(1,mint),lint(2,mint) + gx%bmperr=4066; goto 1000 + endif + kkk=kkk+phlista(lokph)%nooffr(ll) + enddo + endif +28 continue +! write(*,*)'enter_parameter mint2: ',mint,nint +15 format('enter_parameter x: ',4I4) +16 format('enter_parameter y: ',4I4) + if(mint.lt.nint) then +! write(*,*)'enter_parameter error: ',nint,mint,lint(1,mint),lint(2,mint) + gx%bmperr=4067; goto 1000 + endif +! write(*,33)'epar 1: ',nint,((lint(i,j),i=1,2),j=1,nint) +33 format(a,i3,' : ',3(2i3,2x)) + goto 90 +!---------------- +! code below is for disordered fraction types, use fractset record +! one could try to handle both fraction types in the same code but +! that would just make it very very messy +50 continue + if(.not.btest(phlista(lokph)%status1,PHMFS)) then +! there are no disordered fraction sets for this phase + gx%bmperr=4068; goto 1000 + endif + lokcs=phlista(lokph)%linktocs(1) + disfra=firsteq%phase_varres(lokcs)%disfra +! number of sublattices in the disordered set + if(nsl.ne.disfra%ndd) then + gx%bmperr=4069; goto 1000 + endif + kkk=0 +! write(*,*)'3B: disordered parameter: ',nsl + do ll=1,nsl + do kk=1,disfra%nooffr(ll) + kk1=kkk+kk +! write(*,12)ll,endm(ll),kk1,disfra%splink(kk1) + if(endm(ll).eq.disfra%splink(kk1)) then + iord(ll)=kk1 + goto 67 + endif + enddo + if(endm(ll).eq.-99) then +! wildcard + iord(ll)=-99 + else +! write(*,*)'in enter_parameter' + gx%bmperr=4051; goto 1000 + endif +67 continue + kkk=kkk+disfra%nooffr(ll) + enddo +! check interaction constituents + mint=1 +73 continue + kkk=0 + if(mint.le.nint) then + do ll=1,nsl + if(lint(1,mint).eq.ll) then + do kk=1,disfra%nooffr(ll) + kkk=kkk+1 + if(lint(2,mint).eq.disfra%splink(kkk)) then + jord(1,mint)=ll + jord(2,mint)=kkk +! write(*,75)mint,lint(1,mint),lint(2,mint),kkk,ll,jord(1,mint),jord(2,mint) +75 format('ep 75: ',8i4) + mint=mint+1 + if(mint.gt.nint) goto 78 + goto 73 + endif + enddo +! a constituent does not exist in sublattice ll + gx%bmperr=4066; goto 1000 + endif + kkk=kkk+disfra%nooffr(ll) + enddo + endif +78 continue + if(mint.lt.nint) then + gx%bmperr=4067; goto 1000 + endif +!--------------------------------------------------- +! we have found all constituents for the end member and interactions +! now look if there are parameter records, otherwise create them +! try to keep end member records in some order of constituents ... +90 continue +! if(fractyp.eq.2) then +! write(*,92)'3B: endmembers: ',(iord(ii),ii=1,nsl) +! write(*,92)'3B: interactions: ',(jord(2,ii),ii=1,nint) +! endif + nullify(lastem) +! check that interactions are in sublattice and alphabetical order!! + again=0 + intcheck: do lokint=2,nint + if(jord(1,lokint).lt.jord(1,lokint-1)) then + corrsubl: do iz=1,2 + it=jord(iz,lokint) + jord(iz,lokint)=jord(iz,lokint-1) + jord(iz,lokint-1)=it + enddo corrsubl + again=1 + elseif(jord(1,lokint).eq.jord(1,lokint-1)) then + if(jord(2,lokint).lt.jord(2,lokint-1)) then + it=jord(2,lokint) + jord(2,lokint)=jord(2,lokint-1) + jord(2,lokint-1)=it +! write(*,*)'interactions: ',jord(2,lokint),jord(2,lokint-1) + again=1 + elseif(jord(2,lokint).eq.jord(2,lokint-1)) then + write(*,656)'Illegal with same interaction constituent twice',& + phlista(lokph)%name +656 format(a/' phase: ',a) + gx%bmperr=7778; goto 1000 + endif + endif + enddo intcheck +! write(*,*)'Again: ',again + if(again.eq.1) goto 90 +! Make sure the endmember has the alphabetically lowest constituent +! and that the interaction is not the same as the endmember +! write(*,92)'endmembers: ',(iord(i),i=1,nsl) +92 format(a,10i4) +! write(*,92)'interactions: ',(jord(2,i),i=1,nint) + placeibloop: do kint=1,nint +! ll is the sublattice with interaction + ll=jord(1,kint) + placeib: if(jord(2,kint).eq.iord(ll)) then +! write(*,*)'pmod3B: Illegal with interaction with same constituent' +! subroutine enter_parameter(lokph,typty,fractyp,nsl,endm,nint,lint,ideg,& +! lfun,refx) + write(*,97)lokph,typty,fractyp,nsl,(endm(zz),zz=1,nsl),& + ideg,nint,(lint(1,zz),lint(2,zz),zz=1,nint) +97 format('pmod3B: Illegal with interaction with same constituent:'/& + 3i3,i4,2x,15(i5)) + gx%bmperr=7777; goto 1000 + elseif(jord(2,kint).lt.iord(ll)) then +! constituent in iord higher than that in jord, exchange jord and iord. + ib=iord(ll) + iord(ll)=jord(2,kint) + if(kint.eq.nint) then +! there are no more interactions, just put ib in the place of jord(2,kint) + jord(2,kint)=ib + else +! a bit problematic, we may have to shift constituents in jord + moreint: do mint=kint+1,nint + if(jord(1,mint).gt.ll) then +! next interaction in another sublattice, put ib in jord(2,mint-1) + jord(2,mint-1)=ib + else + shiftint: if(ib.lt.jord(2,mint)) then +! next interaction is higher, put ib in jord(2,mint-1) + jord(2,mint-1)=ib + else +! interacting constituent is lower, we must shift constituents down in jord +! It can be done one at a time?? Example: user enter: +! L(fcc,D,E,C,A,B): iord(1)='D', jord(2,*)='A', 'B', 'C', 'E' (ordered above) +! kint=1 replaces iord(1)='A'; look for the place for 'D'; ninit=4 +! loop mint=2 but 'D' is higher than 'B' so shift jord one step making +! jord(2,*)='B', 'C', 'C', 'E'; +! loop mint=3 but D is higher than 'C' so shift jord(2,*)='B', 'C', 'E', 'E'; +! Now 'D' is lesser than 'E' so place it in jord(2,3): +! jord(2,*)='B', 'C', 'D', 'E'; + jord(2,mint-1)=jord(2,mint) + if(mint.lt.nint .and. jord(1,mint+1).eq.ll) then + jord(2,mint)=jord(2,mint+1) + else + jord(2,mint)=ib + endif + endif shiftint + endif + enddo moreint + endif + endif placeib + enddo placeibloop +! there may be permutations for ordered phases ... implemented for fcc + intperm=0 + ftyp1: if(fractyp.eq.1) then + if(btest(phlista(lokph)%status1,PHFORD)) then +! These permutations may require 2 interaction records created ... + call fccpermuts(lokph,nsl,iord,noperm,elinks,nint,jord,& + intperm,intlinks) + if(gx%bmperr.ne.0) goto 1000 +! make sure iord is alphabtically ordered to find the correct parameter +! endm() are species index, iord() are constituent index (overal all subl) +! elinks are constituent index, iord(*,1) is identical to elinks(*,1) + do jl=1,nsl + iord(jl)=elinks(jl,1) + enddo + elseif(btest(phlista(lokph)%status1,PHBORD)) then + call bccpermuts(lokph,nsl,iord,noperm,elinks,nint,jord,& + intperm,intlinks) + if(gx%bmperr.ne.0) goto 1000 +! make sure iord is alphabtically ordered to find the correct parameter +! endm() are species index, iord() are constituent index (overal all subl) + do jl=1,nsl + iord(jl)=elinks(jl,1) + enddo + else + noperm=1 + endif + else +! fraction type 2 has no permutations + noperm=1 + endif ftyp1 +! parameters for site fractions + if(fractyp.eq.1) then + endmemrec=>phlista(lokph)%ordered + else + endmemrec=>phlista(lokph)%disordered + endif +! write(*,91)'enter_param 90: ',fractyp,nsl,(iord(ii),ii=1,nsl) +91 format(a,i2,i3,10i4) + ionliq=btest(phlista(lokph)%status1,PHIONLIQ) + findem: do while(associated(endmemrec)) + if(.NOT.ionliq) then + lika:do lj=1,nsl +! iord(lj) can be negative for wildcard. Wildcard endmedmemers at the end + i1=iord(lj) + i2=endmemrec%fraclinks(lj,1) + if(i1.gt.0) then + if(i2.lt.0 .or. i1.lt.i2) then +! The new end member record should be inserted before this record + goto 100 + elseif(i1.gt.i2) then +! continue searching for the end member or place to create it + lastem=>endmemrec + endmemrec=>endmemrec%nextem + cycle findem + endif +! here i1<0 + elseif(i2.gt.0) then +! continue searching for the end member or place to create it + lastem=>endmemrec + endmemrec=>endmemrec%nextem + cycle findem + endif +! It is the same "wildcard" value if both i1 and i2 are negative + enddo lika + else +! for ionic liquids insert endmembers in order of second sublattice ... +! This is important as we want to calculate all parameters with anions +! before we come to vacancy and neutrals which should be multiplied with Q + illika:do lj=nsl,1,-1 +! iord(lj) can be negative for wildcard. Wildcard endmedmemers at the end + i1=iord(lj) + i2=endmemrec%fraclinks(lj,1) + if(i1.gt.0) then + if(i2.lt.0 .or. i1.lt.i2) then +! The new end member record should be inserted before this record + goto 100 + elseif(i1.gt.i2) then +! continue searching for the end member or place to create it + lastem=>endmemrec + endmemrec=>endmemrec%nextem + cycle findem + endif +! here i1<0 + elseif(i2.gt.0) then +! continue searching for the end member or place to create it + lastem=>endmemrec + endmemrec=>endmemrec%nextem + cycle findem + endif +! It is the same "wildcard" value if both i1 and i2 are negative + enddo illika + endif +!------------------------------------------------- +! found end member record with same constituents + goto 200 + enddo findem +! +! if lfun=-1 we want to list the function and not create anything + if(lfun.lt.0) goto 900 +! +100 continue +! we have not found any endmember record so we have to insert a record here +! lokem may be nonzero if we exited from findem loop to this label + call create_endmember(lokph,newem,noperm,nsl,iord,elinks) +! write(*,*)'enter_par: created endmember ',new + if(gx%bmperr.ne.0) goto 1000 +! insert link to new from last end member record, lastem. + if(.not.associated(lastem)) then + if(fractyp.eq.1) then + phlista(lokph)%ordered=>newem + else + phlista(lokph)%disordered=>newem + endif + else +! emlista(lastem)%next=new + lastem%nextem=>newem + endif +! insert link from new to next (if lokem=0 this record is the last) + newem%nextem=>endmemrec + endmemrec=>newem +!--------------------------------------------------- +! Here we have found or created the endmember record +! look for or create interaction record, no wildcards in interactions +! Interacting elements should be in sublattice and alphabetical order!! +200 continue +! write(*,*)'enter_parameter mint3: ',mint,nint + lokint=0 + someint: if(nint.gt.0) then +! when there are interaction records the ideal bit must be cleared + phlista(lokph)%status1=ibclr(phlista(lokph)%status1,PHID) +! to locate interaction record, + nullify(lastint) + mint=1 + intrec=>endmemrec%intpointer +! write(*,202)'enter_parameter 12A: ',lokph,typty,nsl,ideg,typty,lokem,& +! (lint(1,i),i=1,nint),(lint(2,i),i=1,nint) +202 format(/a,7i4,4x,10i4) + if(.not.associated(intrec)) then +! no interaction record for this endmember, create one unless lfun=-1 + if(lfun.eq.-1) goto 900 + call create_interaction(newintrec,mint,jord,intperm,intlinks) + if(gx%bmperr.ne.0) goto 1000 +! write(*,*)'created interaction 9:',mint,nint + endmemrec%intpointer=>newintrec + intrec=>newintrec + lastint=>intrec +! mint=mint+1 + newint=1 +! write(*,*)'created interaction: ',newint,mint + else +! write(*,*)'existing interaction: ',intrec%status + newint=0 + firstint=0 + endif +300 continue +! write(*,303)' at 300A: ',lokph,newint,nint,mint,intrec%status +303 format(a,10i3) +! interaction records should be ordered according to the sublattice +! with the interaction. For interaction with permutations use the +! sublattice of the first permutation + findint: do while(mint.le.nint) +! write(*,*)'At findint: ',mint,nint,newint + if(intrec%sublattice(1).eq.jord(1,mint) .and. & + intrec%fraclink(1).eq.jord(2,mint)) then +! found an interaction with same constituent (maybe just created) + if(mint.eq.nint) then +! write(*,*)'same interaction, level: ',mint + goto 400 + endif + lastint=>intrec + intrec=>intrec%highlink + mint=mint+1 + newint=1 + if(.not.associated(intrec)) exit findint + else + if(mint.eq.nint) then +! error when storing permutations because newint=0 below. Moved it to the end +! but that gave error L(liq,C,Cr,V) was stored as L(Liq,C,Cr,Fe,V) +! Add a check on mint, if mint=nint one cannot store it as higher + newint=0 + endif +! we must store interactions in sublattice order and in order of constituent +! in jord(2,mint) otherwise we will never be able to find a permutation. + if(intrec%sublattice(1).gt.jord(1,mint)) then +! write(*,*)'insering interaction before existing' + exit findint + endif + lastint=>intrec + intrec=>intrec%nextlink + if(.not.associated(intrec)) exit findint + firstint=1 +! more records on this interaction level ? +! this worked for permutations but gave other errors, see above +! newint=0 + endif + enddo findint +! we can be here either because mint>nint or no more interaction records +! we must create at least one interactionrecord, newint=0 if same level +! If intrec is associated the nextint link should be set to this +310 continue +! write(*,*)'At 310',mint,nint + if(mint.le.nint) then +! if lfun=-1 and parameter does not exist just skip away + if(lfun.eq.-1) goto 900 +! write(*,303)' Linking at 310:',mint,nint,newint,firstint + call create_interaction(newintrec,mint,jord,intperm,intlinks) + if(gx%bmperr.ne.0) goto 1000 + if(newint.eq.1) then +! write(*,*)'Linking as higher' + lastint%highlink=>newintrec + elseif(associated(intrec)) then +! write(*,*)'Linking as previous' + newintrec%nextlink=>intrec +! write(*,*)'Ho ho said the sixth' + if(associated(lastint)) then + lastint%nextlink=>newintrec + else +! this should be linked from the endmember or lower order interaction +! write(*,*)'No previous interaction on this level' + endmemrec%intpointer=>newintrec + endif +! write(*,*)'Ho ho said the sixth' + else +! write(*,*)'Linking as next' + lastint%nextlink=>newintrec + endif +! redundant as newint set to 1 below ... +! newint=0 + intrec=>newintrec + lastint=>intrec + mint=mint+1 +! there may be more interaction records .... but they must all be created + newint=1 + goto 310 + endif +! Now we should have found or created the interaction record, +! check property list +400 continue + proprec=>intrec%propointer + if(.not.associated(proprec)) then +! do not create anything if lfun=-1 + if(lfun.eq.-1) goto 900 + call create_proprec(intrec%propointer,typty,ideg,lfun,refx) + else + goto 800 + endif +! write(*,*)'enter_parameter 17: ',lokint,lokem,link + else +! Found endmember and there is no interaction +! search the property list, there may not be the correct property! + proprec=>endmemrec%propointer + if(.not.associated(proprec)) then +! if on property record and lfun=-1 just list parameter equal to zero + if(lfun.lt.0) goto 900 + call create_proprec(endmemrec%propointer,typty,ideg,lfun,refx) + else + goto 800 + endif + endif someint +! all done + goto 1000 +!-------------------------------------------------------- +! we found correct parameter record with a property, now search property list +! This loop both for endmembers and interactions +800 continue + do while(associated(proprec)) + lastprop=>proprec + if(proprec%proptype.eq.typty) then +! found property record, one should delete old and insert new function +! one must alse change the reference !!! And add the reference if new. +! mode=0 means no change of reference text if reference already exists + call capson(refx) + notext='*** Not set by user' + call tdbrefs(refx,notext,0,ifri) + if(ideg.le.proprec%degree) then + if(lfun.eq.-1) then + listfun=proprec%degreelink(ideg) + else + proprec%degreelink(ideg)=lfun + proprec%reference=refx + endif + elseif(lfun.ge.0) then + call extend_proprec(proprec,ideg,lfun) + proprec%reference=refx + endif + if(lfun.eq.-1) goto 900 + goto 1000 + endif + proprec=>proprec%nextpr + enddo +! if lfun=-1 we just want to list a the parameter which is zero + if(lfun.lt.0) goto 900 +! no record for this property present, add a new property record + call create_proprec(lastprop%nextpr,typty,ideg,lfun,refx) +! all done and go home + goto 1000 +!-------------------------------------------------------- +! this is for listing parameter +900 continue + write(*,*)'3B list parameter ',lfun,listfun + if(listfun.gt.0) then + call list_tpfun(listfun,0,funexp) +! for the moment use the TPFUN symbol ... + call wrice2(kou,0,12,78,1,funexp) + else + write(kou,*)'Parameter is zero' + endif +!---------------------------------------------------------- +1000 continue + if(gx%bmperr.eq.0) then +! mark that the phase has at least one parameter + phlista(lokph)%status1=ibset(phlista(lokph)%status1,PHHASP) + endif +! write(*,*)'enter_parameter 99: ',gx%bmperr +! write(*,1010)'enter_parameter 77: ',(phlista(lokph)%constitlist(i),i=1,6) +!1010 format(A,6I3) + return + end subroutine enter_parameter +! lfun + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine fccpermuts(lokph,nsl,iord,noperm,elinks,nint,jord,intperm,intlinks) +! finds all fcc/hcp permutations needed for this parameter +! The order of elements in the sublattices is irrelevant when one has F or B +! ordering as all permutations are stored in one place (with some exceptions) +! Thus the endmembers are ordered alphabetically in the sublattices and also +! the interaction parameters. Max 2 levels of interactions allowed. + implicit none + integer, dimension(*) :: iord,intperm + integer, dimension(2,*) :: jord + integer lokph,nsl,noperm,nint +!\end{verbatim} %+ + integer l2,ll,ib,again,clink,lshift,mshift,a211 + integer odd,inz,ip,iqq1,iqq2,isp,jb,jp,jsp,l3,level1,level2 + integer level2perm,lj,loksp,lsp,niqq1,nl1,nl2,nll,np,nq,nz + integer, dimension(4) :: elal,esame + integer, dimension(:,:), allocatable :: elinks + integer, dimension(:,:), allocatable :: intlinks + logical notsame + character carr*64 +! integer, dimension(3) :: esame +! +!------------------------------------------------------------------- +! +! This is a very long and messy subroutine and it calls others that are +! equally complicated. It is important it is understandable and correct, +! all possible cases has not been tested. Do not try to simplify it by making +! it more messy, this subroutine is not important for calculating speed +! but the structure it creates is important for speed. +! The corresponing routine for bcc permutations is even worse ... +! +!------------------------------------------------------------------- +! +! if(nint.eq.2) then +! write(*,501)'fccpermuts1: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2) +! endif +! I assume the ordering is in the first 4 sublattices, that could be changed + if(nsl.lt.4) then + write(*,*)'There must be at least 4 sublattices for fcc/hcp option' + gx%bmperr=7777; goto 1000 + endif + if(nint.gt.2) then + write(*,*)'Maximum 2nd level interaction with option F' + gx%bmperr=7777; goto 1000 + endif +! rearrange constituents in alphabetcal order in the sublattices, +! change interactions also! +! write(*,11)'fp1: ',(iord(i),i=1,4),nint,((jord(j,k),j=1,2),k=1,nint) +11 format(a,4i4,' interactions: ',i2,4i4) + do l2=1,4 + if(iord(l2).gt.0) then + loksp=phlista(lokph)%constitlist(iord(l2)) + elal(l2)=splista(loksp)%alphaindex + else + elal(l2)=iord(l2) + endif + enddo +! write(*,11)'fp2: ',(elal(i),i=1,4),nint,((jord(j,k),j=1,2),k=1,nint) + again=1 + lagain: do while(again.ne.0) +! yet another messy sorting + again=0 + do l2=1,3 + do ll=l2+1,4 + equal: if(elal(ll).lt.elal(ll-1)) then + again=1 + ib=elal(ll) + elal(ll)=elal(ll-1) + elal(ll-1)=ib +! write(*,*)'call 1',ll-1,elal(ll-1) + call findconst(lokph,ll-1,elal(ll-1),iord(ll-1)) + if(gx%bmperr.ne.0) goto 1000 +! write(*,*)'call 2',ll,elal(ll) + call findconst(lokph,ll,elal(ll),iord(ll)) + if(gx%bmperr.ne.0) goto 1000 +! if there are interacting constituents in ll or ll-1 shift them also + do lj=1,nint + if(jord(1,lj).eq.ll) then +! write(*,21)'fpi1: ',lj,jord(1,lj),jord(2,lj) +21 format(a,i2,2i4) + jord(1,lj)=ll-1 + loksp=phlista(lokph)%constitlist(jord(2,lj)) + ib=splista(loksp)%alphaindex +! write(*,*)'call 3',ll-1,ib + call findconst(lokph,ll-1,ib,jord(2,lj)) + if(gx%bmperr.ne.0) goto 1000 +! write(*,21)'fpi2: ',lj,jord(1,lj),jord(2,lj) + elseif(jord(1,lj).eq.ll-1) then +! write(*,21)'fpi3: ',lj,jord(1,lj),jord(2,lj) + jord(1,lj)=ll + loksp=phlista(lokph)%constitlist(jord(2,lj)) + ib=splista(loksp)%alphaindex +! write(*,*)'call 4',ll,ib + call findconst(lokph,ll,ib,jord(2,lj)) + if(gx%bmperr.ne.0) goto 1000 +! write(*,21)'fpi4: ',lj,jord(1,lj),jord(2,lj) + else +! write(*,23)'No interactions in sublattice: ',jord(1,lj) +23 format(a,2i3) + endif + enddo + endif equal + enddo + enddo + enddo lagain +! elements are now ordered in alphabetical order over the sublattices +! find how many equal +! if(nint.eq.2) then +! write(*,501)'fccpermuts2A: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2) +! endif + esame=0 + ib=1 + esame(ib)=1 + do ll=2,4 + if(elal(ll).eq.elal(ll-1)) then + esame(ib)=esame(ib)+1 + else + ib=ib+1 + esame(ib)=1 + endif + enddo + if(jord(1,1).ne.jord(1,2)) then +! we can have a case AX:AY:A:A and it should not be changed to AXY:A:A:A + notsame=.true. + else + notsame=.false. + endif +! we must rearrange interactions so they are in the first sublattice with +! the same endmember element for each level separately +! This is probably redundant as decode_constarr also sorts + do l2=1,nint + ib=elal(jord(1,l2)) + do ll=1,jord(1,l2)-1 + if(elal(ll).eq.ib) then +! write(*,*)'Shifting interacting constituent to sublattice: ',ll + nll=ll + if(l2.eq.2 .and. notsame) then +! if interactions should not be in same sublattice but with the same element +! in the endmember, increment ll to interact in next sublattice. It should +! be the same endmember constituent there! + if(ll.eq.jord(1,1)) nll=ll+1 +! write(*,*)'nll: ',ll,nll + endif + jord(1,l2)=nll + loksp=phlista(lokph)%constitlist(jord(2,l2)) + ib=splista(loksp)%alphaindex +! write(*,*)'call 5',nll,ib + call findconst(lokph,nll,ib,jord(2,l2)) + if(gx%bmperr.ne.0) goto 1000 + endif + enddo + enddo +! if(nint.eq.2) then +! write(*,501)'fccpermuts2B: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2) +! endif +! write(*,11)'fp3: ',(elal(i),i=1,4),nint,((jord(j,k),j=1,2),k=1,nint) +! write(*,11)'fp4: ',(iord(i),i=1,4) +! make sure that any interaction is connected to the first possible endmember +! for example A:A,B:B:B should be changed to A,B:A:B:B +! Also A,C:A,B:A:A should be A,B:A,C:A:A to have a unique record + do l2=1,nint + lj=jord(1,l2) + do ll=1,lj-1 +! ll must be less than 4 in this loop + equalem: if(elal(ll).eq.elal(lj)) then + if(l2.eq.1 .or. .not.notsame) then + jord(1,l2)=ll + loksp=phlista(lokph)%constitlist(jord(2,l2)) + ib=splista(loksp)%alphaindex +! write(*,*)'call 6',ll,ib + call findconst(lokph,ll,ib,jord(2,l2)) + if(gx%bmperr.ne.0) goto 1000 + else +! l2 must be 2 here, i.e. second order interaction + loksp=phlista(lokph)%constitlist(jord(2,1)) + ib=splista(loksp)%alphaindex + loksp=phlista(lokph)%constitlist(jord(2,2)) + jb=splista(loksp)%alphaindex + if(jb.lt.ib) then +! change them so the lowest constituent comes first in sublattice order +! write(*,*)'call 7',ll,jb + call findconst(lokph,ll,jb,jord(2,1)) + if(gx%bmperr.ne.0) goto 1000 +! write(*,*)'call 8',lj,ib + call findconst(lokph,lj,ib,jord(2,2)) + if(gx%bmperr.ne.0) goto 1000 +! write(*,*)'exchange: ',ib,jb,jord(2,1),jord(2,2) + else +! The interactions should not be in same sublattice, the next sublattice +! must have the same endmember constituent as jord(1,1), put it there + if(ll.eq.jord(1,1)) then + nll=ll+1 + else + nll=ll + endif + jord(1,l2)=nll + loksp=phlista(lokph)%constitlist(jord(2,l2)) + ib=splista(loksp)%alphaindex +! write(*,*)'call 9',nll,ib + call findconst(lokph,nll,ib,jord(2,l2)) + if(gx%bmperr.ne.0) goto 1000 + endif + endif + endif equalem + enddo + enddo +! if(nint.eq.2) then +! write(*,501)'fccpermuts2C: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2) +! endif +!-------------------------------- +! now we can calculate the number of endmember permutations +! Generate also all endmember links in elinks to be stored in endmember record + lshift=phlista(lokph)%nooffr(1) + if(esame(1).eq.4) then +! all 4 equal + noperm=1 + allocate(elinks(nsl,noperm)) + do ll=1,nsl + elinks(ll,1)=iord(ll) + enddo + elseif(esame(1).eq.3) then +! first 3 equal, one different: A:A:A:B; A:A:B:A; A:B:A:A; B:A:A:A + noperm=4 + allocate(elinks(nsl,noperm)) + do np=1,noperm + do ll=1,nsl + elinks(ll,np)=iord(ll) + enddo + if(np.lt.4) then +! shift the single different element forward step by step + ib=iord(4-np)+lshift + iord(4-np)=iord(5-np)-lshift + iord(5-np)=ib + endif + enddo + elseif(esame(1).eq.2) then + if(esame(2).eq.2) then +! the two first equal and also last two: A:A:B:B +! A:B:A:B; A:B:B:A; B:A:B:A; B:B;A:A; B:A:A:B +! I have no idea how to make this into a loop so I handle each separately + noperm=6 + allocate(elinks(nsl,noperm)) + np=1 + do ll=1,nsl + elinks(ll,np)=iord(ll) + enddo +! shift sublattice 2 and 3: A:B:A:B + ib=iord(2)+lshift + iord(2)=iord(3)-lshift + iord(3)=ib + np=np+1 + do ll=1,nsl + elinks(ll,np)=iord(ll) + enddo +! shift sublattice 3 and 4: A:B:B:A + ib=iord(3)+lshift + iord(3)=iord(4)-lshift + iord(4)=ib + np=np+1 + do ll=1,nsl + elinks(ll,np)=iord(ll) + enddo +! shift sublattice 1 and 2: B:A:B:A + ib=iord(1)+lshift + iord(1)=iord(2)-lshift + iord(2)=ib + np=np+1 + do ll=1,nsl + elinks(ll,np)=iord(ll) + enddo +! shift sublattice 2 and 3: B:B:A:A + ib=iord(2)+lshift + iord(2)=iord(3)-lshift + iord(3)=ib + np=np+1 + do ll=1,nsl + elinks(ll,np)=iord(ll) + enddo +! shift sublattice 2 and 4 (double lenght): B:A:A:B + ib=iord(2)+2*lshift + iord(2)=iord(4)-2*lshift + iord(4)=ib + np=np+1 + do ll=1,nsl + elinks(ll,np)=iord(ll) + enddo + else +! the first two equal and last 2 different: A:A:B:C + a211=1 + noperm=12 + allocate(elinks(nsl,noperm)) + call fccpe211(1,elinks,nsl,lshift,iord) + endif + elseif(esame(2).eq.3) then +! first different and last 3 equal: A:B:B:B; B:A:B:B; B:B:A:B; B:B:B:A + noperm=4 + allocate(elinks(nsl,noperm)) + do np=1,noperm + do ll=1,nsl + elinks(ll,np)=iord(ll) + enddo + if(np.lt.4) then +! shift the single different element backward step by step + ib=iord(np)+lshift + iord(np)=iord(np+1)-lshift + iord(np+1)=ib + endif + enddo + elseif(esame(2).eq.2) then +! two equal but first and last different + a211=2 + noperm=12 + allocate(elinks(nsl,noperm)) + call fccpe211(2,elinks,nsl,lshift,iord) + elseif(esame(3).eq.2) then +! first two different but last two equal + a211=3 + noperm=12 + allocate(elinks(nsl,noperm)) + call fccpe211(3,elinks,nsl,lshift,iord) + else +! all 4 different + noperm=24 + allocate(elinks(nsl,noperm)) + call fccpe1111(elinks,nsl,lshift,iord) + endif +! always skip debug output of endmembers for interaction parameters + intperm(1)=0 +! if(nint.eq.2) then +! write(*,501)'fccpermuts3: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2) +! endif + if(nint.gt.0) goto 200 +! comment next line to have debug output +! goto 200 +!-------------------- +! debug output of endmembers after rearranging + carr='fp6: ' + ib=6 + l3=1 + do ll=1,4 + if(elal(ll).gt.0) then + l2=len_trim(splista(species(elal(ll)))%symbol) + write(carr(ib:),16)splista(species(elal(ll)))%symbol(1:l2) +16 format(a) + ib=ib+l2 + else + carr(ib:)='*' + ib=ib+1 + endif +17 continue + if(l3.le.nint) then + if(jord(1,l3).eq.ll) then + loksp=phlista(lokph)%constitlist(jord(2,l3)) + l2=len_trim(splista(loksp)%symbol) + write(carr(ib:),18)splista(loksp)%symbol(1:l2) +18 format(',',a) + ib=ib+l2+1 + l3=l3+1 + goto 17 + endif + endif + if(ll.lt.4) carr(ib:ib)=':' + ib=ib+1 + enddo +! write(*,19)carr(1:ib) +! write(*,19)'fp7: ',esame,noperm +19 format(a,4i3,i5) +! More debug output: all endmember permutations + do np=1,noperm +! listing indices in constituent list (stored in endmember record) +! write(*,31)np,(elinks(ll,np),ll=1,nsl) +31 format('elinks: ',i3,3x,10i4) + enddo + do np=1,noperm +! Easier to check listing of permutations using constituent names + carr=' ' + ib=1 + do ll=1,nsl + if(elinks(ll,np).gt.0) then + loksp=phlista(lokph)%constitlist(elinks(ll,np)) + l2=len_trim(splista(loksp)%symbol) + write(carr(ib:),32)splista(loksp)%symbol(1:l2) +32 format(a,':') + ib=ib+l2+1 + else + carr(ib:)='*:' + ib=ib+2 + endif + enddo +! write(*,33)np,carr +33 format('emperm ',i3,': ',a) + enddo +! debug output of endmembers end +!-------------------- +200 continue +! done arranging component array and permutations of endmembers + if(nint.eq.0) then + goto 1000 + endif +!=============================================== +! Now the 1st level interactions ... store in intlinks(1..2) + allocate(intlinks(2,100)) +! intperm(1)=number of interaction permutations on level 1 for each endmember +! on level 1 each endmember perumtation has the same +! intperm(2)=total number of permutation links for level 1 +! intperm(3..) used for 2nd level + select case(noperm) + case default ! error + write(*,*)'Unknown case for endmemeber permutations: ',noperm + gx%bmperr=7777 +!---------- + case(1) ! A:A:A:A +! if(nint.eq.2) then +! write(*,501)'fccpermuts4: ',jord(1,1),jord(2,1),jord(1,2),jord(2,2) +! endif + if(jord(1,1).ne.1) then + write(*,*)'Interaction must be in sublattice 1' + gx%bmperr=7777; goto 1000 + endif + intperm(1)=4 + intperm(2)=4 + clink=jord(2,1) +! set links to interaction with same element in all 4 sublattices + do l2=1,4 + intlinks(1,l2)=l2 + intlinks(2,l2)=clink + clink=clink+lshift + enddo + level1=1 +!---------- + case(4) ! A:A:A:B and A:B:B:B + if(esame(1).eq.3) then + if(jord(1,1).eq.1) then +! the interaction must be AX:A:A:B + call fccint31(jord,lshift,intperm,intlinks) + level1=2 + else +! the interaction must be A:A:A:BX + intperm(1)=1 + intperm(2)=4 + intlinks(1,1)=4 + intlinks(2,1)=jord(2,1) + do ll=2,4 + intlinks(1,ll)=5-ll + intlinks(2,ll)=intlinks(2,ll-1)-lshift + enddo + level1=3 + endif + elseif(jord(1,1).eq.2) then +! the interaction must be A:BX:B:B + call fccint31(jord,lshift,intperm,intlinks) + level1=4 + else +! the interaction must be AX:B:B:B + intperm(1)=1 + intperm(2)=4 + intlinks(1,1)=1 + intlinks(2,1)=jord(2,1) + do ll=2,4 + intlinks(1,ll)=ll + intlinks(2,ll)=intlinks(2,ll-1)+lshift + enddo + level1=5 + endif +!---------- + case(6) ! A:A:B:B + call fccint22(jord,lshift,intperm,intlinks) + level1=6 +!---------- + case(12) ! A:A:B:C; A:B:B:C; A:B:C:C + if(a211.eq.jord(1,1)) then + call fccint211(a211,jord,lshift,intperm,intlinks) + level1=7 + else +! interaction with one of the single constituents +! a single permutation follows the single different element in 4 sublattices +! starting from sublattice 1. There are 12 enemember permutations + intperm(1)=1 +! intperm(2)=12 + intperm(2)=noperm + l2=jord(1,1) + ib=phlista(lokph)%constitlist(elinks(l2,1)) + intlinks(1,1)=jord(1,1) + intlinks(2,1)=jord(2,1) + do ll=2,noperm + do l3=1,4 + jb=phlista(lokph)%constitlist(elinks(l3,ll)) + if(jb.eq.ib) goto 410 + enddo + write(*,*)'Cannot find endmember element for premutation ',ll,ib + gx%bmperr=7777; goto 1000 +410 continue + intlinks(1,ll)=l3 + mshift=(intlinks(1,ll)-intlinks(1,ll-1))*lshift + intlinks(2,ll)=intlinks(2,ll-1)+mshift +! write(*,422)ll,l3,jord(1,1),mshift,intlinks(1,ll),intlinks(2,ll) + enddo + level1=8 + endif +!---------- + case(24) ! A:B:C:D + write(*,77) +77 format(' *** CONGRATULATIONS, '/& + ' You must be the first to enter a parameter like this!!!') + intperm(1)=1 + intperm(2)=noperm + l2=jord(1,1) +! species number in endmember of interacting sublattice + ib=phlista(lokph)%constitlist(elinks(l2,1)) + intlinks(1,1)=l2 + intlinks(2,1)=jord(2,1) + do ll=2,24 + do l3=1,4 + jb=phlista(lokph)%constitlist(elinks(l3,ll)) + if(jb.eq.ib) goto 420 +! write(*,419)'elinks,ib: ',ll,l3,ib,jb,elinks(l3,ll) +!419 format(a,2i4,2x,3i4) + enddo + write(*,*)'Cannot find endmember element for premutation ',ll,ib + gx%bmperr=7777; goto 1000 +420 continue + intlinks(1,ll)=l3 + mshift=(intlinks(1,ll)-intlinks(1,ll-1))*lshift + intlinks(2,ll)=intlinks(2,ll-1)+mshift +! write(*,422)ll,l3,jord(1,1),mshift,intlinks(1,ll),intlinks(2,ll) +422 format('spec: ',3i3,2x,i10,2x,2i10) + enddo + level1=9 + end select +500 continue + if(nint.eq.1) goto 900 +!================================================================ +! 2nd level interaction permutations +! write(*,*)'First level interaction type: ',level1 +! write(*,502)' elinks and jord: ',elal,((jord(i,j),i=1,2),j=1,2) +501 format(a,2(2i4,2x)) +502 format(a,4(i4),' : ',2(2i4,2x)) +! +! The simplest 2nd level interaction is in the same sublattice as first + if(jord(1,2).eq.jord(1,1)) then +! AXY:B:C:D where X and Y are two different constituents (not A) and B, C, D +! can be any constituents. There are no new permutations, just add Y +! write(*,*)'shortcut' + intperm(3)=1 + intperm(4)=1 + nz=intperm(2) + loksp=phlista(lokph)%constitlist(jord(2,2)) + isp=splista(loksp)%alphaindex + do np=1,intperm(2) + intlinks(1,nz+np)=intlinks(1,np) + call findconst(lokph,intlinks(1,np),isp,intlinks(2,nz+np)) + if(gx%bmperr.ne.0) goto 1000 + enddo +! for debug output + goto 900 + endif +!----------------------------------------------------------- + select case(level1) + case default !error + write(*,*)'Unknown case for permutations on level 1: ',level1 + gx%bmperr=7777 +!----------------------------------------------------------- + case(1) ! AXY:A:A:A or AX:AX:A:A or AX:AY:A:A + call fccip2A(lokph,jord,intperm,intlinks) + if(gx%bmperr.ne.0) goto 1000 +!----------------------------------------------------------- + case(2) ! AXY:A:A:B or AX:AY:A:B or AX:A:A:BY +! write(*,*)'case 2: ',jord(1,2),jord(2,2) + if(jord(1,2).eq.4) then +! AX:A:A:BY, there should be 12 permutations, no new on second level + intperm(3)=1 + intperm(4)=1 + intperm(5)=12 + nz=intperm(2) + loksp=phlista(lokph)%constitlist(jord(2,2)) + isp=splista(loksp)%alphaindex + do np=1,4 +! sublattice for B the same for 3 permutations + do nq=1,3 + nz=nz+1 + intlinks(1,nz)=5-np + call findconst(lokph,5-np,isp,intlinks(2,nz)) + if(gx%bmperr.ne.0) goto 1000 + enddo + enddo + else +! AX:AY:A:B + call fccip2B(1,lokph,lshift,jord,intperm,intlinks) + if(gx%bmperr.ne.0) goto 1000 + endif +!----------------------------------------------------------- + case(3) ! A:A:A:BXY +! never hase as taken care by shortcut above + if(jord(1,2).ne.jord(1,1)) then + write(*,*)'Thinking error, restructure!' + gx%bmperr=7777; goto 1000 + endif +!----------------------------------------------------------- + case(4) ! A:BXY:B:B or A:BX:BY:B; no AY:BX:B:B as that would be case 5 +! A:BX:BY:B + call fccip2B(2,lokph,lshift,jord,intperm,intlinks) + if(gx%bmperr.ne.0) goto 1000 +!----------------------------------------------------------- + case(5) ! AX:BY:B:B +! This parameter has just 4 endmember permutations. On this level 3 more +! AX:B:B:B AX:BY:B:B AX:B:BY:B AX:B:B:BY +! B:AX:B:B B:AX:BY:B B:AX:B:BY BY:AX:B:B etc + intperm(3)=1 + intperm(4)=3 + intperm(5)=12 + loksp=phlista(lokph)%constitlist(jord(2,2)) + isp=splista(loksp)%alphaindex + nz=intperm(2) + do np=1,4 + nll=intlinks(1,np) + do ip=1,3 + nz=nz+1 + nll=nll+1 + if(nll.gt.4) nll=1 + intlinks(1,nz)=nll + call findconst(lokph,nll,isp,intlinks(2,nz)) + if(gx%bmperr.ne.0) goto 1000 + enddo + enddo +! endif +!----------------------------------------------------------- +! This is the important one as it includes the reciprocal excess parameter + case(6) ! AX:A:B:B or A:A:BX:B, 6 endmem and 2 level 1 permutations = 12 +! AX:A:B:B: AX:AX:B:B: 1; 0 totally 6 permutations +! AX:A:B:B: AX:AY:B:B and AY:AX:B:B; 2 additional permutations, totally 24 + loksp=phlista(lokph)%constitlist(jord(2,2)) + jsp=splista(loksp)%alphaindex + if(abs(jord(1,2)-jord(1,1)).gt.1) then +! level 2 interaction with another endmember constituent than level 1 +! AX:A:BY:B; 2 additional permutations, totally 24 +! The endmember permutations will put element B in sublattices: +! 3,4; 2,4; 2,3; 1,3; 1,2; 1,4; If that changes this must be changed too ... + intperm(3)=1 + intperm(4)=2 + intperm(5)=24 + nz=intperm(2) + nl1=3 + nl2=4 + do ip=1,6 + nz=nz+1 + intlinks(1,nz)=nl1 + call findconst(lokph,nl1,jsp,intlinks(2,nz)) + if(gx%bmperr.ne.0) goto 1000 + nz=nz+1 + intlinks(1,nz)=nl2 + call findconst(lokph,nl2,jsp,intlinks(2,nz)) + if(gx%bmperr.ne.0) goto 1000 + nz=nz+1 + intlinks(1,nz)=nl1 + call findconst(lokph,nl1,jsp,intlinks(2,nz)) + if(gx%bmperr.ne.0) goto 1000 + nz=nz+1 + intlinks(1,nz)=nl2 + call findconst(lokph,nl2,jsp,intlinks(2,nz)) + if(gx%bmperr.ne.0) goto 1000 + select case(nl1) + case default + write(*,*)'Error in fccpermut, case(lavel1=6), case(nl1)' + gx%bmperr=7777; goto 1000 + case(1) ! change nl2 to 2 or 4, nl1 should be 1 + if(nl2.eq.2) nl2=4 + if(nl2.eq.3) nl2=2 + case(2) ! change nl2 to 3 + if(nl2.eq.3) then + nl1=1 + nl2=3 + else + nl2=3 + endif + case(3) ! change nl1 to 2 + nl1=2 + end select + enddo + else +! interaction with same endmember element in 2 different sublattices +! write(*,*)'smart?' + loksp=phlista(lokph)%constitlist(jord(2,1)) + isp=splista(loksp)%alphaindex + if(isp.eq.jsp) then +! AX:AX:B:B or A:A:BX:BX, there are 12 permutations of AX:A:B:B on level 1 +! but there are only 6 second level interactions +! The endmember permutations will put element A in sublattices: +! 1,2; 1,3; 1,4; 2,4; 3,4; 2,3; and element B in sublattices: +! 3,4; 2,4; 2,3; 1,3; 1,2; 1,4; + intperm(3)=2 + intperm(4)=1 + intperm(5)=0 + intperm(6)=6 + nz=intperm(2) + if(jord(1,1).eq.1) then + nll=2 + else + nll=4 + endif + odd=1 + do np=1,12 + odd=1-odd + do jp=1,intperm(4+odd) +! this loop is done 1 or 0 times twice; nll=2,3,4; 4,4,3 // 4,4,3; 3,2,4 + nz=nz+1 + intlinks(1,nz)=nll + call findconst(lokph,nll,jsp,intlinks(2,nz)) + if(gx%bmperr.ne.0) goto 1000 +! nz= 13,14,15,16,17,18,19 +! nll= 2, 3, 4, 4, 4, 3, - if jord(1,1)=1 +! nll= 4, 4, 3, 3, 2, 4, - if jord(1,1)=2 + select case(nz) + case default + write(*,*)'Error in fccpermut, case(lavel1=6), nz=',nz + gx%bmperr=7777; goto 1000 + case(13) ! change nll to 3 if 2, else same + if(nll.eq.2) nll=3 ! 3 or same + case(14) +! the if .., +! if(nll.eq.4) then +! nll=3 +! else +! nll=4 +! endif +! is same as nll=7-nll + nll=7-nll + case(15,18) ! no change!! + continue + case(16) + if(nll.eq.3) nll=2 + case(17) + if(nll.eq.4) nll=3 + if(nll.eq.2) nll=4 + end select + enddo + enddo +! if the case and loops above works they are smart and easy to understand ??? + else +! AX:AY:B:B or A:A:BX:BY +! In this case we have the sume number of level2 permutations as level1 +! Just add an interaction on the other sublattice with same endmember +! The endmember permutations will put element A in sublattices: +! 1,2; 1,3; 1,4; 2,4; 3,4; 2,3; and element B in sublattices: +! 3,4; 2,4; 2,3; 1,3; 1,2; 1,4; +! The first interaction will be with the first of the sublattices, the +! second in the second, just switch + intperm(3)=1 + intperm(4)=1 + intperm(5)=intperm(2) + nz=intperm(2) + do np=1,6 +! Here AX:AY:B:B and AY:AX:B:B + nz=nz+1 + nll=intlinks(1,nz-11) + nl2=intlinks(1,nz-12) + intlinks(1,nz)=nll + write(*,73)'loop 6B: ',np,nll,nl2,nz +73 format(a,10i4) + call findconst(lokph,nll,jsp,intlinks(2,nz)) + if(gx%bmperr.ne.0) goto 1000 +! set the second interaction in sublattice with level 1 interaction + nz=nz+1 + intlinks(1,nz)=nl2 + call findconst(lokph,nl2,jsp,intlinks(2,nz)) + if(gx%bmperr.ne.0) goto 1000 + enddo +! if the case and loops above works they are smart and easy to understand ??? + endif + endif +!----------------------------------------------------------- +! Maybe this can wait a little ... + case(7) ! AX:A:B:C or A:BX:B:C or A:B:CX:C + write(*,*)'Not implemented yet 7' + gx%bmperr=7777 +!----------------------------------------------------------- +! Maybe this can wait a little ... + case(8) ! A:A:BX;C or similar + write(*,*)'Not implemented yet 8' + gx%bmperr=7777 +!----------------------------------------------------------- +! Maybe this can wait a little ... + case(9) ! AX:B:C:D or similar + write(*,*)'Not implemented yet 9' + gx%bmperr=7777 + end select +!----------------------------------------------------------- +! done permutations of interactions +! write(*,510)'510: ',(intperm(j),j=1,7) +510 format(a,10i4) +!------- debug output of first level interaction permutations +900 continue +! to skip remove comment on next line +! goto 1000 + if(nint.eq.2) then +! write(*,905)'Permutations of endmem and intlevel 1: ',noperm,& +! intperm(1),intperm(2) +! write(*,905)'Permutations of intlevel 2: ',intperm(3),& +! (intperm(3+i),i=1,intperm(3)) +905 format(a,i5,2x,10i4) + endif +! these are the base pointers to first and second level permutations + iqq1=0 + iqq2=intperm(2)+1 + inz=0 + emdmem: do np=1,noperm +! for each endmember permutation there are intperm(1) level 1 permutations + intlev1: do niqq1=1,intperm(1) + iqq1=iqq1+1 + if(nint.eq.2) then + level2=1 + if(intperm(3).eq.1) then +! there is a fixed number of 2nd level permutations + level2perm=intperm(4) + else +! the number of 2nd level interaction varies with the first level, it can be 0 + level2perm=intperm(3+niqq1) + if(level2perm.eq.0) cycle intlev1 + endif + else +! no 2nd level interaction + iqq2=0 + endif +910 continue + carr=' ' + ib=1 + subl: do ll=1,nsl +! endmember constituent, can be wildcard + loksp=elinks(ll,np) + if(loksp.gt.0) then + loksp=phlista(lokph)%constitlist(loksp) + lsp=len_trim(splista(loksp)%symbol) + carr(ib:)=splista(loksp)%symbol(1:lsp) + ib=ib+lsp + else + carr(ib:ib)='*' + ib=ib+1 + endif +920 continue + if(intlinks(1,iqq1).eq.ll) then +! level 1 interaction constituent +! NOTE: For error checks output of intlinks is more important than the +! constituent name in carr as the link also indicates the sublattice!!! +! if(nint.eq.2) & +! write(*,922)1,iqq1,intlinks(1,iqq1),intlinks(2,iqq1) +922 format('intlinks: ',2i5,2x,2i5,2x,3i5) + loksp=phlista(lokph)%constitlist(intlinks(2,iqq1)) + lsp=len_trim(splista(loksp)%symbol) + carr(ib:)=','//splista(loksp)%symbol(1:lsp) + ib=ib+lsp+1 + endif + if(iqq2.gt.0) then + if(intlinks(1,iqq2).eq.ll) then +! level 2 interaction constituent +! NOTE: For error checks output of intlinks is more important than the +! constituent name in carr as the link also indicates the sublattice!!! +! write(*,922)2,iqq2,intlinks(1,iqq2),intlinks(2,iqq2),jord(2,2) + loksp=phlista(lokph)%constitlist(intlinks(2,iqq2)) + lsp=len_trim(splista(loksp)%symbol) + carr(ib:)=','//splista(loksp)%symbol(1:lsp) + ib=ib+lsp+1 + endif + endif + if(ll.lt.nsl) then + carr(ib:)=': ' + ib=ib+2 + endif + enddo subl + inz=inz+1 +! write(*,925)inz,carr(1:len_trim(carr)) +925 format('inter perm ',i3,': ',a) + if(iqq2.gt.0) then +! there are level2perm number of 2nd order permutations + level2=level2+1 + iqq2=iqq2+1 + if(level2.le.level2perm) goto 910 + endif + enddo intlev1 + enddo emdmem +!------- debug output end +1000 continue + return + end subroutine fccpermuts + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine fccip2A(lokph,jord,intperm,intlinks) +! 2nd level interaction permutations for fcc + implicit none + integer, dimension(*) :: intperm + integer, dimension(2,*) :: jord,intlinks + integer lokph +!\end{verbatim} %+ + integer loksp,isp,jsp,ij,nll,ll,iqq,nz,ik +! AX:A:A:A, 2nd level can be AXY:A:A:A, AX:AX:A:A or AX:AY:A:A + loksp=phlista(lokph)%constitlist(jord(2,2)) + isp=splista(loksp)%alphaindex +! write(*,2)'fccip2A1: ',((jord(i,j),i=1,2),j=1,2) +!2 format(a,2(2i3,2x)) +! 2nd level interaction in another sublattice, AX:AX:A:A or AX:AY:A:A + loksp=phlista(lokph)%constitlist(jord(2,1)) + jsp=splista(loksp)%alphaindex +! write(*,*)'fccip2A2: ',isp,jsp + if(isp.eq.jsp) then +! 2nd level interacting constituent same as first level constituent: +! Level 1: Level2: +! AX:A:A:A; AX:AX:A:A; AX:A:AX:A; AX:A:A:AX 3 permutations +! A:AX:A:A; A:AX:AX:A; A:AX:A:AX 2 permutations +! A:A:AX:A; A:A:AX:AX 1 permutations +! A:A:A:AX; none 0 permutations +! write(*,*)'same interaction constituent in different sublattices' + intperm(3)=4 + intperm(4)=3 + intperm(5)=2 + intperm(6)=1 + intperm(7)=0 + intperm(8)=24 + iqq=intperm(2) + do ij=1,3 +! loop only to 3 as there is no 2nd level permutation for ij=4 + nll=intlinks(1,ij) + do ll=1,intperm(3+ij) + iqq=iqq+1 + nll=nll+1 + intlinks(1,iqq)=nll + if(nll.gt.4) then + write(*,*)'Error in 2nd level interaction of AX:AX:A:A' + gx%bmperr=7777; goto 1000 + endif + call findconst(lokph,intlinks(1,iqq),isp,intlinks(2,iqq)) + if(gx%bmperr.ne.0) goto 1000 +! write(*,76)'loop: ',ij,nll,iqq,intlinks(1,iqq),intlinks(2,iqq) +76 format(a,3i3,2x,2i4) + enddo + enddo +! debug output +! nc=0 +! nc1=0 +! nc2=intperm(2) +! do lj=1,4 +! do ljj=1,intperm(3+lj) +! nc=nc+1 +! nc1=nc1+1 +! nc2=nc2+1 +! write(*,77)nc,lj,ljj,& +! (intlinks(i,nc1),i=1,2),(intlinks(i,nc2),i=1,2) +77 format('AX:AX:A:A: ',i3,2x,2i3,2x,2(2i4,2x)) +! enddo +! enddo + else +! If 2nd level interacting element different +! Level 1: Level2: +! AX:A:A:A; AX:AY:A:A; AX:A:AY:A; AX:A:A:AY 3 permutations +! A:AX:A:A; AY:AX:A:A; A:AX:AY:A; A:AX:A:AY 3 permutations +! A:A:AX:A; AY:A:AX:A; A:AY:AX:A; A:A:AX:AY 3 permutations +! A:A:A:AX; AY:A:A:AX; A:AY:A:AX; A:A:AY:AX 3 permutations +! write(*,*)'different interaction constituent in different sublattices' + intperm(3)=1 + intperm(4)=3 + intperm(5)=12 + nz=intperm(2) + do ik=1,4 +! Note that these permutations include AY:AX:A:A linked from AX:A:A:A +! A first level interaction AY:A:A:A is stored in another interaction record +! with no link to this 2nd level interaction. + nll=intlinks(1,ik) + do ll=1,3 + nll=nll+1 + if(nll.gt.4) nll=1 + nz=nz+1 + intlinks(1,nz)=nll + call findconst(lokph,nll,isp,intlinks(2,nz)) + if(gx%bmperr.ne.0) goto 1000 +! write(*,88)nz,ik,ll,intlinks(1,nz),intlinks(2,nz) +88 format('loop: ',3i3,2x,2i5) + enddo + enddo + endif +1000 continue + return + end subroutine fccip2A + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine fccip2B(lq,lokph,lshift,jord,intperm,intlinks) +! 2nd level interaction permutations for fcc + implicit none + integer lq,lokph,lshift + integer, dimension(*) :: intperm + integer, dimension(2,*) :: jord,intlinks +!\end{verbatim} %+ + integer loksp,isp,jsp,ny,nz,mp,isub2,nll,ip,np +! lq=1 means AX:AY:A:B or AX:AX:A:B +! lq=2 means A:BX:BY:B or A:BX:BX:B +! This parameter has 4 endmember permuts each with 3 permuts on level 1 +! if X is same as Y only 2; 1; 0 + loksp=phlista(lokph)%constitlist(jord(2,1)) + isp=splista(loksp)%alphaindex + loksp=phlista(lokph)%constitlist(jord(2,2)) + jsp=splista(loksp)%alphaindex +! write(*,*)'fccip2B3: ',isp,jsp + if(isp.eq.jsp) then +! Endmember Level 1 Level 2 2; 1; 0; +! A:A:A:B AX:A:A:B AX:AX:A:B AX:A:AX:B +! A:AX:A:B A:AX:AX:B +! A:A:AX:B none +! A:A:B:A AX:A:B:A AX:AX:B:A AX:A:B:AX +! A:AX:B:A A:AX:B:AX +! A:A:B:AX none +! A:B:A:A AX:B:A:A AX:B:AX:A AX:B:A:AX +! A:B:AX:A A:B:AX:AX +! A:B:A:AX none +! B:A:A:A B:AX:A:A B:AX:AX:A B:AX:A:AX +! B:A:AX:A B:A:AX:AX +! B:A:A:AX none +! or the same for endmember A:B:B:B + intperm(3)=3 + intperm(4)=2 + intperm(5)=1 + intperm(6)=0 + intperm(7)=intperm(2) + ny=0 + nz=intperm(2) + mp=3 +! these loops are frustratingly messy .... but they seem to work ... + nploop: do np=1,intperm(2) + mp=mp+1 + if(lq.eq.1) then +! isub2 is the endmember sublattice occupied by the "different" constituent +! isub2=(20-np)/4 + isub2=(15-np)/3 + else +! isub2=(3+np)/4 + isub2=(2+np)/3 + endif +! nll is the sublattice with 1st level interaction + ny=ny+1 + nll=intlinks(1,ny) +! np = 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12 +! mp = 4, 5, 6, 4, 5, 6, 4, ... +! intperm(mp) = 2, 1, 0, 2, 1, 0, 2, 1, 0, 2, 1, 0 + do ip=1,intperm(mp) + nll=nll+1 + if(nll.eq.isub2) nll=nll+1 + nz=nz+1 + intlinks(1,nz)=nll +! write(*,13)'AX:AX:A:B: ',np,mp,ip,isub2,nz,nll,jsp +13 format(a,4i3,2x,i3,2i5) + call findconst(lokph,nll,jsp,intlinks(2,nz)) + if(gx%bmperr.ne.0) goto 1000 + enddo + if(mod(np,3).eq.0) mp=3 + enddo nploop + else +! Endmember Level 1 Level 2 2; +! A:A:A:B AX:A:A:B AX:AY:A:B AX:A:AY:B +! A:AX:A:B A:AX:AY:B AY:AX:A:B +! A:A:AX:B AY:A:AX:B A:AY:AX:B +! A:A:B:A AX:A:B:A AX:AY:B:A AX:A:B:AY etc +! There are 2 additional permutations for each of the 12 existing, the problem +! is mainly to know in which sublattice to add the interaction + intperm(3)=1 + intperm(4)=2 + intperm(5)=2*intperm(2) + ny=0 + nz=intperm(2) + do np=1,intperm(2) + if(lq.eq.1) then +! isub2 is the endmember sublattice occupied by the "different" constituent + isub2=(15-np)/3 + else +! isub2 should be 1 for np=1..4, 2 for np=4..7 etc + isub2=(np+2)/3 + endif +! nll is the sublattice with 1st level interaction + ny=ny+1 + nll=intlinks(1,ny) + do ip=1,2 +! set 2nd interaction in sublattice after first interaction. If that +! sublattice is >4 set it in first. If the endmember is the single other +! constituent set it in next. If that is >4 set it in first + nll=nll+1 + if(nll.gt.4) nll=1 + if(nll.eq.isub2) nll=nll+1 + if(nll.gt.4) nll=1 + nz=nz+1 + intlinks(1,nz)=nll +! write(*,13)'AX:AY:A:B: ',np,ip,0,isub2,nz,nll,jsp + call findconst(lokph,nll,jsp,intlinks(2,nz)) + if(gx%bmperr.ne.0) goto 1000 + enddo + enddo + endif +1000 continue + return + end subroutine fccip2B + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine fccint31(jord,lshift,intperm,intlinks) +! 1st level interaction in sublattice l1 with endmember A:A:A:B or A:B:B:B +! set the sublattice and link to constituent for each endmember permutation +! 1st permutation of endmember: AX:A:A:B; A:AX:A:B; A:A:AX;B 4 0 1 2 +! 2nd permutation of endmember: AX:A:B:A; A:AX:B:A; A:A:B:AX 3 0 1 3 +! 3rd permutation of endmember: AX:B:A:A; A:B:AX:A; A:B:A:AX 3 0 2 3 +! 4th permutation of endmember: B:AX:A:A; B:A:AX:A; B:A:A:AX 1 or 1 2 3 +! 1st permutation of endmember: A:BX:B:B; A:B:BX:B; A:B:B:BX 4 0 1 2 +! 2nd permutation of endmember: BX:A:B:B; B:A:BX:B; B:A:B:BX 1 etc -1 1 2 +! 3rd -1 0 2 ; -1 0 1 +! suck + implicit none + integer lshift + integer, dimension(2,*) :: jord,intlinks + integer, dimension(*) :: intperm +!\end{verbatim} %+ + integer l2,shift0,shift1,shift2,clink,idis,np +! + intperm(1)=3 + intperm(2)=12 + l2=jord(1,1) + clink=jord(2,1) + idis=0 + shift0=0 + shift1=1 + shift2=2 + do np=1,4 + intlinks(1,idis+1)=l2+shift0 + intlinks(2,idis+1)=clink+shift0*lshift + intlinks(1,idis+2)=l2+shift1 + intlinks(2,idis+2)=clink+shift1*lshift + intlinks(1,idis+3)=l2+shift2 + intlinks(2,idis+3)=clink+shift2*lshift + idis=idis+3 + subl: if(l2.eq.1) then + if(np.eq.1) then + shift2=3 + elseif(np.eq.2) then + shift1=2 + elseif(np.eq.3) then + shift0=1 + endif + else + if(np.eq.1) then + shift0=-1 + elseif(np.eq.2) then + shift1=0 + else + shift2=1 + endif + endif subl + enddo +1000 return + end subroutine fccint31 + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine fccint22(jord,lshift,intperm,intlinks) +! 1st level for endmember A:A:B:B with interaction in sublattice jord(1,1) +! 6 permutations of endmember, 2 permutations of interactions, 12 in total +! 1st endmemperm: AX:A:B:B; A:AX:B:B 0 1 +! 2nd endmemperm: AX:B:A:B; A:B:AX:B 0 2 +! 3rd endmemperm: AX:B:B:A; A:B:B:AX 0 3 +! 4th endmemperm: B:AX:B:A; B:A:B:AX 1 3 +! 5th endmemperm: B:B:AX:A; B:B:A:AX 2 3 +! 6th endmemperm: B:AX:A:B; B:A:AX:B or 1 2 +! 1th endmemperm: A:A:BX:B; A:A:B:BX 0 1 +! 2nd endmemperm: A:BX:A:B; A:B:A:BX -1 1 +! 3rd endmemperm: A:BX:B:A; A:B:BX:A -1 0 +! 4th endmemperm: BX:A:B:A; B:A:BX:A -2 0 +! 5th endmemperm: BX:B:A:A; B:BX:A:A -2 -1 +! 6th endmemperm: BX:A:A:B; B:A:A:BX -2 1 + implicit none + integer lshift + integer, dimension(2,*) :: jord,intlinks + integer, dimension(*) :: intperm +!\end{verbatim} %+ + integer shift0,shift1,l2,clink,idis,np +! + intperm(1)=2 + intperm(2)=12 + l2=jord(1,1) + clink=jord(2,1) + idis=0 + shift0=0 + shift1=1 + do np=1,6 + intlinks(1,idis+1)=l2+shift0 + intlinks(2,idis+1)=clink+shift0*lshift + intlinks(1,idis+2)=l2+shift1 + intlinks(2,idis+2)=clink+shift1*lshift + idis=idis+2 + subl: if(l2.eq.1) then + select case(np) + case default + write(*,*)'Case error in fccint22: ',np + case(1) !A:B:A:B is next endmember + shift1=2 + case(2) !A:B:B:A + shift1=3 + case(3) !B:A:B:A + shift0=1 + case(4) !B:B:A:A + shift0=2 + case(5) !B:A:A:B + shift0=1 + shift1=2 + case(6) ! no more + end select + else + select case(np) + case default + write(*,*)'Case error in fccint22: ',np + case(1) !A:B:A:B is next endmember + shift0=-1 + case(2) !A:B:B:A + shift1=0 + case(3) !B:A:B:A + shift0=-2 + case(4) !B:B:A:A + shift1=-1 + case(5) !B:A:A:B + shift1=1 + case(6) ! no more + end select + endif subl + enddo +1000 continue + return + end subroutine fccint22 + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine fccint211(a211,jord,lshift,intperm,intlinks) +! 1st level interaction in sublattice l1 with endmember like A:A:B:C +! 12 endmember permutations of AABC; ABBC; or ABCC +! 2 interaction permutations for each, 24 in total + implicit none + integer a211,lshift + integer, dimension(2,*) :: jord,intlinks + integer, dimension(*) :: intperm +!\end{verbatim} %+ + integer l2,clink,idis,shift0,shift1,np + intperm(1)=2 + intperm(2)=24 + l2=jord(1,1) + if(l2.ne.a211) then + write(*,*)'Error calling fccint211',a211,l2 + gx%bmperr=7777; goto 1000 + endif + clink=jord(2,1) + idis=0 + shift0=0 + shift1=1 +! endmemeber A:A:B:C; first permutation interactions: AX:A:B:C; A:AX:B:C +! endmemeber A:B:B:C; first permutation interactions: A:BX:B:C; A;B:BX:C +! endmemeber A:B:C:C; first permutation interactions: A:B:CX:C; A:B:C:CX + do np=1,12 + intlinks(1,idis+1)=l2+shift0 + intlinks(2,idis+1)=clink+shift0*lshift + intlinks(1,idis+2)=l2+shift1 + intlinks(2,idis+2)=clink+shift1*lshift + idis=idis+2 + subl: if(l2.eq.1) then +! endmember A:A:B:C + select case(np) + case default + write(*,*)'Case error in fccint211: ',np,a211 + case(1) !A:A:C:B is next endmember + continue + case(2) !A:C:A:B + shift1=2 + case(3) !A:C:B:A + shift1=3 + case(4) !A:B:C:A + continue + case(5) !A:B:A:C + shift1=2 + case(6) !B:A:A:C + shift0=1 + case(7) !B:A:C:A + shift1=3 + case(8) !B:C:A:A + shift0=2 + case(9) !C:B:A:A + continue + case(10) !C:A:B:A + shift0=1 + case(11) !C:A:A:B + shift1=2 + case(12) ! no more + end select + elseif(l2.eq.2) then +! endmember A:B:B:C + select case(np) + case default + write(*,*)'Case error in fccint211: ',np,a211 + case(1) !A:B:C:B is next endmember + shift1=2 + case(2) !C:B:A;B + continue + case(3) !C:B:B:A + shift1=1 + case(4) !B:B:C:A + shift0=-1 + shift1=0 + case(5) !B:B:A:C + continue + case(6) !B:A:B:C + shift1=1 + case(7) !B:A:C:B + shift1=2 + case(8) !C:A:B:B + shift0=1 + case(9) !A:C:B:B + continue + case(10) !B:C:A:B + shift0=-1 + case(11) !B:C:B:A + shift1=1 + case(12) ! no more + end select + else +! endmember A:B:C:C + select case(np) + case default + write(*,*)'Case error in fccint211: ',np,a211 + case(1) !A:C:B:C is next endmember + shift0=-1 + case(2) !C:A:B:C + shift1=0 + case(3) !C:B:A:C + shift0=-2 + case(4) !B:C:A:C + shift1=-1 + case(5) !B:A:C:C + shift1=1 + case(6) !B:C:C:A + shift1=1 + case(7) !C:B:C:A + shift1=1 + case(8) !C:C:B:A + shift1=1 + case(9) !C:C:A:B + shift1=1 + case(10) !C:A:C:B + shift1=1 + case(11) !A:C:C:B + shift1=1 + case(12) ! no more + end select + endif subl + enddo +1000 continue + return + end subroutine fccint211 + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine fccpe211(l1,elinks,nsl,lshift,iord) +! sets appropriate links to constituents for the 12 perumations of +! A:A:B:C (l1=1), A:B:B:C (l1=2) and A:B:C:C (l1=3) + implicit none + integer, dimension(nsl,*) :: elinks + integer, dimension(*) :: iord + integer l1,nsl,lshift +!\end{verbatim} %+ + integer odd,np,ll,ib +! l1=1; keep 1 and change 3o4 and 2o3 6 times; then change 1o2 and +! loop 2 times +! changing 3o4 and 2o3; then change 1o2 and loop 2 times changing 2o3 +! and 3o4 +! AABC; AACB; ACAB; ACBA; ABCA; ABAC; ! BAAC; BACA; BCAA; ! CBAA; +! CABA; CAAB; +! l1=2; keep 2 and change 3o4 and 1o3 6 times; then change 2o3 and +! loop 2 times +! changing 3o4 and 1o3; then change +! ABBC; ABCB; CBAB; CBBA; BBCA; BBAC; ! BABC; BACB; CABB; ! ACBB; +! BCAB; BCBA; +! l1=3; keep 4 and change 2o3 and 1o2 6 times; then change +! ABCC; ACBC; CABC; CBAC; BCAC; BACC; ! +! write(*,*)'fccpe211: ',l1 + odd=0 + loop12: do np=0,11 + do ll=1,nsl + if(iord(ll).lt.0) iord(ll)=-99 + elinks(ll,np+1)=iord(ll) + enddo +! note l1 and ll are different !!! + if(l1.eq.1) then +! AABC. Keep constituent in sublattice 1 first 6 loops; then for 3 and 3 + if(np.eq.5) then + ib=iord(1)+lshift + iord(1)=iord(2)-lshift + iord(2)=ib + odd=1-odd + elseif(np.eq.8) then + ib=iord(1)+lshift + iord(1)=iord(2)-lshift + iord(2)=ib + odd=1-odd + elseif(odd.eq.0) then + ib=iord(3)+lshift + iord(3)=iord(4)-lshift + iord(4)=ib + odd=1-odd + else + ib=iord(2)+lshift + iord(2)=iord(3)-lshift + iord(3)=ib + odd=1-odd + endif + elseif(l1.eq.2) then +! ABBC. Keep constituent in sublattice 2 for first 6; then for 3 and 3 + if(np.eq.5) then + ib=iord(2)+lshift + iord(2)=iord(3)-lshift + iord(3)=ib + odd=1-odd + elseif(np.eq.8) then + ib=iord(1)+lshift + iord(1)=iord(2)-lshift + iord(2)=ib + odd=1-odd + elseif(odd.eq.0) then + ib=iord(3)+lshift + iord(3)=iord(4)-lshift + iord(4)=ib + odd=1-odd + else + ib=iord(1)+2*lshift + iord(1)=iord(3)-2*lshift + iord(3)=ib + odd=1-odd + endif + else +! ABCC. Keep constituent in sublattice 4 for first 6; then for 3 and 3 + if(np.eq.5) then + ib=iord(2)+2*lshift + iord(2)=iord(4)-2*lshift + iord(4)=ib + elseif(np.eq.8) then + ib=iord(3)+lshift + iord(3)=iord(4)-lshift + iord(4)=ib + odd=1-odd + elseif(odd.eq.0) then + ib=iord(2)+lshift + iord(2)=iord(3)-lshift + iord(3)=ib + odd=1-odd + else + ib=iord(1)+lshift + iord(1)=iord(2)-lshift + iord(2)=ib + odd=1-odd + endif + endif + enddo loop12 +1000 continue + return + end subroutine fccpe211 + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine fccpe1111(elinks,nsl,lshift,iord) +! sets appropriate links to 24 permutations when all 4 constituents different +! A:B:C:D +! The do loop keeps the same constituent in first sublattice 6 times, changing +! the other 3 sublattice, then changes the constituent in the first sublattice +! and goes on changing in the other 3 until all configurations done + implicit none + integer, dimension(nsl,*) :: elinks + integer, dimension(*) :: iord + integer nsl,lshift +!\end{verbatim} + integer np,ll,odd,ib +! odd is either 0 or 1 + odd=1 + loop24: do np=0,23 + do ll=1,nsl + if(iord(ll).lt.0) iord(ll)=-99 + elinks(ll,np+1)=iord(ll) + enddo +! keep the same constituent in sublattice 1 for 6 endmembers, then shift + if(np.eq.5) then +! shift 1 and 2, change odd + ib=iord(2)-lshift + iord(2)=iord(1)+lshift + iord(1)=ib + odd=1-odd + elseif(np.eq.11) then +! shift 1 and 4, keep odd + ib=iord(3)-2*lshift + iord(3)=iord(1)+2*lshift + iord(1)=ib + elseif(np.eq.17) then +! shift 1 and 4, change odd + ib=iord(4)-3*lshift + iord(4)=iord(1)+3*lshift + iord(1)=ib + odd=1-odd + elseif(odd.eq.0) then + odd=1-odd +! shift 3 and 4 + ib=iord(4)-lshift + iord(4)=iord(3)+lshift + iord(3)=ib + else + odd=1-odd +! shift 2 and 3 + ib=iord(3)-lshift + iord(3)=iord(2)+lshift + iord(2)=ib + endif + enddo loop24 +1000 continue + return + end subroutine fccpe1111 + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine bccpermuts(lokph,nsl,iord,noperm,elinks,nint,jord,intperm,intlinks) +! finds all bcc permutations needed for this parameter + implicit none + integer lokph,nsl,noperm,nint + integer, dimension(*) :: iord,intperm + integer, dimension(2,*) :: jord + integer, dimension(:,:), allocatable :: elinks + integer, dimension(:,:), allocatable :: intlinks +!\end{verbatim} +! I assume the ordering is in the first 4 sublattices, that could be changed + if(nsl.lt.4) then + write(*,*)'There must be at least 4 sublattices for bcc option' + gx%bmperr=7777; goto 1000 + endif +! unifinished + write(*,*)'BCC permutations not implemented yet' + gx%bmperr=7777 +1000 continue + return + end subroutine bccpermuts + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine findconst(lokph,ll,spix,constix) +! locates the constituent index of species with index spix in sublattice ll +! and returns it in constix. For wildcards spix is -99; return -99 +! THERE MAY ALREADY BE A SIMULAR SUBROUTINE ... CHECK + implicit none + integer lokph,ll,spix,constix +!\end{verbatim} + integer nc,l2,loksp + if(spix.eq.-99) then + constix=-99 + goto 1000 + endif + nc=1 + do l2=1,ll-1 +! The number of constituents in each sublattice can vary, add together + nc=nc+phlista(lokph)%nooffr(l2) + enddo + constix=0 + do l2=nc,nc+phlista(lokph)%nooffr(ll)-1 + loksp=phlista(lokph)%constitlist(l2) + if(splista(loksp)%alphaindex.eq.spix) then + constix=l2; exit + endif + enddo + if(constix.eq.0) then + write(*,90)spix,nc +90 format('No such constituent with index ',i5,' in sublattice',i3) + gx%bmperr=7777; goto 1000 + endif +1000 continue + return + end subroutine findconst + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine tdbrefs(refid,line,mode,iref) +! store a reference from a TDB file or given interactivly +! If refid already exist and mode=1 then amend the reference text + implicit none + character*(*) refid,line + integer mode,iref +!\end{verbatim} + integer ip,ml,nr,mc,nc,jl +! make sure refid is left adjusted + ip=0 +10 ip=ip+1 + if(ip.gt.len(refid)) then + gx%bmperr=4154; goto 1000 + endif + if(refid(ip:ip).eq.' ') goto 10 + if(ip.gt.1) refid=refid(ip:) +! make it upper case + call capson(refid) +! look if refid already exist + do iref=1,reffree-1 + if(refid.eq.bibrefs(iref)%reference) then + if(mode.eq.1) then +! write(*,70)i,refid,bibrefs(i)%refspec +!70 format('tdbrefs: ',i4,a,a) + deallocate(bibrefs(iref)%refspec) + goto 200 + else +! reference already exist and no changes needed + goto 1000 + endif + endif + enddo +! if bibliographic reference does not exist do not create + if(mode.eq.1) goto 1000 + iref=reffree + reffree=reffree+1 + bibrefs(iref)%reference=refid +200 continue + ml=len_trim(line) + nr=(ml+63)/64 + allocate(bibrefs(iref)%refspec(nr)) + mc=1 + nc=0 +! write(*,202)'3B newref: ',iref,refid,nr,line(1:min(32,len_trim(line))) +!202 format(a,i4,1x,a,i3,1x,a) + do jl=1,nr +! 1-64 mc=1, nc=64 +! 65-122 + bibrefs(iref)%refspec(jl)=' ' + nc=nc+min(ml,64) + bibrefs(iref)%refspec(jl)=line(mc:nc) + mc=nc+1 + ml=ml-64 + enddo +1000 continue + return + end subroutine tdbrefs + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine enter_equilibrium(name,number) +! creates a new equilibrium. Allocates arrayes for conditions, +! components, phase data and results etc. +! returns index to new equilibrium record +! THIS CAN PROBABLY BE SIMPLIFIED, especially phase_varres array can be +! copied as a whole, not each record structure separately ... ??? + implicit none + character name*(*) + integer number +!\end{verbatim} + TYPE(gtp_phase_varres), pointer :: cpv,cp1 + character name2*64 + integer ieq,ipv,nc,jz,iz,jl,jk,novarres + if(.not.allowenter(3)) then + write(*,*)'3B: not allowed enter equilibrium: ',name + gx%bmperr=4153; goto 1000 + endif + name2=name + call capson(name2) + if(ocv()) write(*,*)'3B In routine to enter equilibria: ',& + name,noofph,eqfree + if(.not.proper_symbol_name(name2,0)) then +! the name must start with a letter A-Z and contain letters, numbers and _ + gx%bmperr=4122 + goto 1000 + endif +! check if name already used + call findeq(name2,ieq) + if(gx%bmperr.eq.0) then + gx%bmperr=4123 + goto 1000 + else +! reset error code + gx%bmperr=0 + endif + if(eqfree.le.maxeq) then + ieq=eqfree + eqfree=eqfree+1 + endif + number=ieq + if(ocv()) write(*,*)'3B create eq',eqfree,maxeq,ieq +! allocate data arrayes in equilibrium record + eqlista(ieq)%next=0 + eqlista(ieq)%eqname=name2 + eqlista(ieq)%eqno=ieq +! component list and matrix, if second or higher equilibrium copy content + if(ocv()) write(*,*)'3B: entereq 1: ',maxel,ieq,noofel + if(ieq.eq.1) then + allocate(eqlista(ieq)%complist(maxel)) + allocate(eqlista(ieq)%compstoi(maxel,maxel)) + allocate(eqlista(ieq)%invcompstoi(maxel,maxel)) + allocate(eqlista(ieq)%cmuval(maxel)) +! this is a bit meaningless but skipping it has given raise to strange errors + eqlista(ieq)%compstoi=zero + eqlista(ieq)%invcompstoi=zero + do jl=1,maxel + eqlista(ieq)%compstoi(jl,jl)=one + eqlista(ieq)%invcompstoi(jl,jl)=one + enddo + else + allocate(eqlista(ieq)%complist(noofel)) + allocate(eqlista(ieq)%compstoi(noofel,noofel)) + allocate(eqlista(ieq)%invcompstoi(noofel,noofel)) + allocate(eqlista(ieq)%cmuval(noofel)) + eqlista(ieq)%cmuval=zero + if(ocv()) write(*,*)'3B: entereq 1B: ' + do jl=1,noofel + eqlista(ieq)%complist(jl)%splink=firsteq%complist(jl)%splink + eqlista(ieq)%complist(jl)%phlink=firsteq%complist(jl)%phlink + eqlista(ieq)%complist(jl)%status=firsteq%complist(jl)%status +! if(firsteq%complist(jl)%phlink.gt.0) then +! only if there is a defined reference state + eqlista(ieq)%complist(jl)%refstate=firsteq%complist(jl)%refstate + eqlista(ieq)%complist(jl)%tpref=firsteq%complist(jl)%tpref + eqlista(ieq)%complist(jl)%chempot=zero + do jk=1,noofel + eqlista(ieq)%compstoi(jl,jk)=firsteq%compstoi(jl,jk) + eqlista(ieq)%invcompstoi(jl,jk)=firsteq%invcompstoi(jl,jk) + enddo + if(allocated(firsteq%complist(jl)%endmember)) then + iz=size(firsteq%complist(jl)%endmember) + if(ocv()) write(*,*)'3B: entereq 1E: ',iz + allocate(eqlista(ieq)%complist(jl)%endmember(iz)) + eqlista(ieq)%complist(jl)%endmember=& + firsteq%complist(jl)%endmember + endif +! endif + enddo + endif +! these records keep calculated values of G and derivatives for each phase +! For phase lokph the index to phase_varres is in phlista(lokph)%cslink +! For phase lokph the index to phase_varres is in phlista(lokph)%linktocs(ics) + if(ocv()) write(*,*)'3B: entereq 2: ',maxph + if(ieq.eq.1) then +! %multiuse is used for axis and direction of a start equilibrium + allocate(eqlista(ieq)%phase_varres(2*maxph)) + firsteq=>eqlista(ieq) + firsteq%multiuse=0 + goto 900 + else +! for ieq>1 allocate the current number of phase_varres records plus 10 +! for extra composition sets added later + eqlista(ieq)%multiuse=0 + novarres=csfree-1 + iz=noofph +! allocate(eqlista(ieq)%phase_varres(iz+10)) + allocate(eqlista(ieq)%phase_varres(2*maxph)) + if(ocv()) write(*,*)'3B varres: ',ieq,size(eqlista(ieq)%phase_varres) +! now copy the current content of firsteq%phase_varres to this equilibrium +! note, the SELECT_ELEMENT_REFERENCE phase has phase number 0 +! and phase_varres index 1, the number of phase_varres records is not the +! same as number of phases .... + copypv: do ipv=1,novarres +! note eqlista(1) is identical to firsteq + cp1=>eqlista(1)%phase_varres(ipv) + cpv=>eqlista(ieq)%phase_varres(ipv) + cpv%nextfree=cp1%nextfree + cpv%phlink=cp1%phlink + cpv%status2=cp1%status2 + cpv%abnorm=cp1%abnorm + cpv%prefix=cp1%prefix + cpv%suffix=cp1%suffix +! allocate and copy arrays + nc=size(cp1%yfr) +! note SIZE gives rubbish unless array is allocated + if(ocv()) write(*,*)'copy yfr 1: ',nc + allocate(cpv%yfr(nc)) + cpv%yfr=cp1%yfr +! problems with phase_varres in equilibrium 2 ... +! write(*,46)'1: ',cp1%yfr +! write(*,46)'v: ',cpv%yfr +46 format('yfr ',a,10(F7.3)) + allocate(cpv%constat(nc)) + cpv%constat=cp1%constat + if(allocated(cp1%mmyfr)) then +! problem with mmyfr??? .... no +! if(ocv()) write(*,*)'3B mmyfr 1: ',ipv,cpv%phlink,nc + allocate(cpv%mmyfr(nc)) + cpv%mmyfr=cp1%mmyfr +! write(*,34)'3B mmyfr 2: ',(cpv%mmyfr(jz),jz=1,nc) +34 format(1x,a,10(F7.3)) +! else +! write(*,*)'3B mmyfr not allocated' + endif + jz=size(cp1%sites) + allocate(cpv%sites(jz)) + cpv%sites=cp1%sites +! these are currently not allocated (ionic liquid model) Maybe not needed?? +! jz=size(cp1%dsitesdy) +! allocate(cpv%dsitesdy(jz)) +! cpv%dsitesdy=cp1%dsitesdy +! jz=size(cp1%d2sitesdy2) +! allocate(cpv%d2sitesdy2(jz)) +! cpv%d2sitesdy2=cp1%d2sitesdy2 +! the values in the following arrays are irrelevant, just allocate and zero + cpv%nprop=cp1%nprop + allocate(cpv%listprop(cp1%nprop)) + allocate(cpv%gval(6,cp1%nprop)) + allocate(cpv%dgval(3,nc,cp1%nprop)) + allocate(cpv%d2gval(nc*(nc+1)/2,cp1%nprop)) + cpv%listprop=0 + cpv%amfu=zero + cpv%dgm=zero + cpv%phstate=PHENTERED + cpv%netcharge=zero + cpv%gval=zero + cpv%dgval=zero + cpv%d2gval=zero +! copy the disordered fraction record, that should take care of all +! array allocations inside the disfra record ??? + cpv%disfra=cp1%disfra +! disordered: if(cpv%disfra%varreslink.gt.0) then +! if there is a disordered phase_varres record that must be taken care of +! lokdis=cpv%disfra%varreslink +! eqlista(ieq)%phase_varres(lokdis)%abnorm=& +! eqlista(1)%phase_varres(lokdis)%abnorm +! !!!! WOW it really seems to copy a whole tructure just by = !!! +! eqlista(ieq)%phase_varres(lokdis)=eqlista(1)%phase_varres(lokdis) +! BUT THEN I HAVE TO CHANGE EVERYTHING ABOVE ... NEXT RELEASE ... +! write(*,*)'copied dis: ',lokdis +! write(*,77)eqlista(ieq)%phase_varres(lokdis)%yfr(2),& +! eqlista(1)%phase_varres(lokdis)%yfr(2) +!77 format('enter eq: ',2(1pe15.6)) +! continue +! endif disordered + enddo copypv + endif +! From here also for first equilibria +900 continue + if(ocv()) write(*,*)'3B: entereq 3: ' +! nullify condition links, otherwise "if(associated(..)" does not work + nullify(eqlista(ieq)%lastcondition) + nullify(eqlista(ieq)%lastexperiment) + if(ocv()) write(*,*)'3B set T and P',ieq +! also set default local values of T and P (not conditions) + eqlista(ieq)%tpval(1)=1.0D3; eqlista(ieq)%tpval(2)=1.0D5 +! allocate and copy tpfun result array also for first equilibria +! jz=size(firsteq%eq_tpres) + jz=maxtpf + if(ocv()) write(*,*)'3B: entereq 4: ',jz,maxsvfun +! write(*,*)'create equil tpres size ',jz,notpf() + allocate(eqlista(ieq)%eq_tpres(jz)) +! allocate result array for state variable functions (svfunres) + if(ocv()) write(*,*)'3B maxsvfun: ',ieq,maxsvfun,jz + allocate(eqlista(ieq)%svfunres(maxsvfun)) +! convergence criteria + eqlista(ieq)%xconv=firsteq%xconv + eqlista(ieq)%maxiter=firsteq%maxiter +1000 continue + if(ocv()) write(*,*)'3B finished enter equilibrium',ieq + return + end subroutine enter_equilibrium + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine delete_equilibrium(name,ceq) +! deletes an equilibrium (needed when repeated step/map) +! name can be an abbreviation line "_MAP*" +! deallocates all data. Minimal checks ... one cannot delete "ceq" + implicit none + character name*(*) + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + type(gtp_condition), pointer :: lastcond,pcond,qcond + integer cureq,ieq,ik,novarres,ipv +! + cureq=ceq%eqno + ik=index(name,'*')-1 + if(ik.lt.0) ik=min(24,len(name)) + do ieq=eqfree-1,1,-1 +! we cannot have "holes" in the free list?? Delete from the end... + if(ieq.eq.cureq) exit + if(eqlista(ieq)%eqname(1:ik).ne.name(1:ik)) exit + if(ocv()) write(*,*)'Deleting: ',eqlista(ieq)%eqname,ieq + eqlista(ieq)%eqname=' ' + deallocate(eqlista(ieq)%complist) + deallocate(eqlista(ieq)%compstoi) + deallocate(eqlista(ieq)%invcompstoi) + deallocate(eqlista(ieq)%cmuval) +! + novarres=csfree-1 +! write(*,*)'deallocationg phase_varres' + do ipv=1,novarres + deallocate(eqlista(ieq)%phase_varres(ipv)%yfr) + deallocate(eqlista(ieq)%phase_varres(ipv)%constat) + if(allocated(eqlista(ieq)%phase_varres(ipv)%mmyfr)) & + deallocate(eqlista(ieq)%phase_varres(ipv)%mmyfr) + deallocate(eqlista(ieq)%phase_varres(ipv)%sites) + deallocate(eqlista(ieq)%phase_varres(ipv)%listprop) + deallocate(eqlista(ieq)%phase_varres(ipv)%gval) + deallocate(eqlista(ieq)%phase_varres(ipv)%dgval) + deallocate(eqlista(ieq)%phase_varres(ipv)%d2gval) +! do not deallocate explicitly disfra as it is another phase_varres record ... + enddo + deallocate(eqlista(ieq)%phase_varres) +! condition list +! write(*,*)'deleting conditions' + lastcond=>eqlista(ieq)%lastcondition + if(associated(lastcond)) then + pcond=>lastcond%next + do while(.not.associated(pcond,lastcond)) + qcond=>pcond + pcond=>pcond%next + deallocate(qcond) + enddo + endif +! + deallocate(eqlista(ieq)%eq_tpres) + deallocate(eqlista(ieq)%svfunres) + enddo +! we have deleted all equilibria until ieq+1 + if(ocv()) write(*,900)ieq+1,eqfree-1 +900 format('Deleted equilibra from ',i3,' to ',i3) + eqfree=ieq+1 +1000 continue + return + end subroutine delete_equilibrium + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine copy_equilibrium(neweq,name,ceq) +! creates a new equilibrium which is a copy of ceq. +! Allocates arrayes for conditions, +! components, phase data and results etc. from equilibrium ceq +! returns a pointer to the new equilibrium record +! THIS CAN PROBABLY BE SIMPLIFIED, especially phase_varres array can be +! copied as a whole, not each record structure separately ... ??? + implicit none + character name*(*) + integer number + type(gtp_equilibrium_data), pointer ::neweq,ceq +!\end{verbatim} + type(gtp_condition), pointer :: oldcond,lastcond + type(gtp_condition), pointer :: newcond1,newcond2 + type(gtp_condition), pointer :: bugcond + character name2*64 + integer ieq,ipv,jz,iz,jl,jk,novarres,oldeq + logical okname +! +! write(*,*)'In copy_equilibrium',len_trim(name) + nullify(neweq) + if(.not.allowenter(3)) then +! write(*,*)'Not allowed enter a copy' + gx%bmperr=4153; goto 1000 + endif +! write(*,*)'allow enter OK' +! not allowed to enter equilibria if there are no phases +! if(btest(globaldata%status,GSNOPHASE)) then +! write(*,*)'Meaningless to copy equilibria with no phase data' +! gx%bmperr=7777; goto 1000 +! endif +! equilibrium names starting with _ are automatically created by mapping +! and in some other cases. + if(name(1:1).eq.'_') then + name2=name(2:) + jk=1 + elseif(name(1:1).eq.' ') then + write(*,*)'A name must start with a letter' + gx%bmperr=8888; goto 1000 + else + name2=name + jk=0 + endif + call capson(name2) +! write(*,*)'3B Entering copy equilibria: ',name2,jk +! program crashed with this construction +! if(.not.proper_symbol_name(name2,0)) then + okname=proper_symbol_name(name2,0) + if(.not.okname) then +! the name must start with a letter A-Z and contain letters, numbers and _ + gx%bmperr=4122 + goto 1000 + endif +! write(*,*)'3B name check ok: ',jk +! remove initial "_" used for automatically created equilibria + if(jk.eq.1) then +! changing this cause a lot of trouble ... but I do not understand + name2='_'//name2 +! name2=name2(2:) + endif +! check if name already used +! write(*,*)'3B check if name unique: ',name2 + call findeq(name2,ieq) + if(gx%bmperr.eq.0) then + gx%bmperr=4123 + goto 1000 + else +! reset error code + gx%bmperr=0 + endif +! write(*,*)'3B check if name unique: ',eqfree + if(eqfree.le.maxeq) then + ieq=eqfree + eqfree=eqfree+1 + else + write(*,*)'Too many equilibrium required, increase dimension',eqfree + gx%bmperr=9999; goto 1000 + endif + number=ieq + if(ieq.eq.1) then + write(*,*)'Cannot copy to default equilibria' + gx%bmperr=7777; goto 1000 + endif +! write(*,*)'copy eq',eqfree,maxeq,ieq +! allocate data arrayes in equilibrium record + eqlista(ieq)%next=0 + eqlista(ieq)%eqname=name2 + eqlista(ieq)%eqno=ieq +! component list and matrix, if second or higher equilibrium copy content +! write(*,*)'3B: entereq 1A: ',maxel,noofel + allocate(eqlista(ieq)%complist(noofel)) + allocate(eqlista(ieq)%compstoi(noofel,noofel)) + allocate(eqlista(ieq)%invcompstoi(noofel,noofel)) + allocate(eqlista(ieq)%cmuval(noofel)) +! write(*,*)'3B: entereq 1B: ',noofel +! careful here because FIRSTEQ has other dimensions than the other + do jl=1,noofel + eqlista(ieq)%complist(jl)=ceq%complist(jl) + eqlista(ieq)%cmuval(jl)=ceq%cmuval(jl) + do jk=1,noofel + eqlista(ieq)%compstoi(jk,jl)=ceq%compstoi(jk,jl) + eqlista(ieq)%invcompstoi(jk,jl)=ceq%invcompstoi(jk,jl) + enddo + enddo + oldeq=ceq%eqno +! write(*,*)'3B: entereq 2: ',noofel + do jl=1,noofel + eqlista(ieq)%complist(jl)%splink=eqlista(oldeq)%complist(jl)%splink + eqlista(ieq)%complist(jl)%phlink=firsteq%complist(jl)%phlink + eqlista(ieq)%complist(jl)%status=firsteq%complist(jl)%status + if(firsteq%complist(jl)%phlink.gt.0) then +! only if there is a defined reference state + eqlista(ieq)%complist(jl)%refstate=firsteq%complist(jl)%refstate + eqlista(ieq)%complist(jl)%tpref=firsteq%complist(jl)%tpref + eqlista(ieq)%complist(jl)%chempot=zero + do jk=1,noofel + eqlista(ieq)%compstoi(jl,jk)=firsteq%compstoi(jl,jk) + eqlista(ieq)%invcompstoi(jl,jk)=firsteq%invcompstoi(jl,jk) + enddo + if(.not.allocated(eqlista(ieq)%complist(jl)%endmember)) then + iz=size(firsteq%complist(jl)%endmember) + allocate(eqlista(ieq)%complist(jl)%endmember(iz)) + eqlista(ieq)%complist(jl)%endmember=firsteq%complist(jl)%endmember + endif + else + eqlista(ieq)%complist(jl)%refstate=firsteq%complist(jl)%refstate + endif + enddo +! these records keep calculated values of G and derivatives for each phase +! For phase lokph the index to phase_varres is in phlista(lokph)%cslink +! For phase lokph the index to phase_varres is in phlista(lokph)%linktocs(ics) +! for ieq>1 allocate the current number of phase_varres records plus 10 +! for extra composition sets added later + novarres=csfree-1 +! write(*,*)'3B: entereq 3: ',novarres +! BEWARE: allocation: calculating with one phase with 8 composition sets +! and disordered fractions sets !!! + iz=max(noofph,novarres) + allocate(eqlista(ieq)%phase_varres(2*iz)) +! write(*,*)'3B eqlista%phase_varres: ',size(eqlista(ieq)%phase_varres) +! now copy the current content of ceq%phase_varres to this equilibrium +! note, the SELECT_ELEMENT_REFERENCE phase has phase number 0 +! and phase_varres index 1, the number of phase_varres records is not the +! same as number of phases .... +! +! strange error here running STEP on bigfcc4: crash with message: +! Index "3" of dimension 1 of array "eqlista" above upper bound of 2 +! write(*,*)'3B 3737:',novarres,ieq,oldeq,size(eqlista(oldeq)%phase_varres) +! Ahhhh, there are 2 phase_varres records for each phase because of +! disordered fraction set, one for the ordered with 33 y-fractions, one for +! the disordered with 8 y-fractions. +! A simple dimensioning problem: 1 phase, 8 compsets, disordered fracset +! requires 17 phase_varres. Before the "max" above I had dimensioned for 2 + copypv: do ipv=1,novarres + eqlista(ieq)%phase_varres(ipv)=eqlista(oldeq)%phase_varres(ipv) + enddo copypv +900 continue +! write(*,*)'To copy conditions:' +! copy conditions (and experiments) !!! + lastcond=>eqlista(oldeq)%lastcondition + if(associated(lastcond)) then + jz=1 + call copy_condition(eqlista(ieq)%lastcondition,lastcond) +! write(*,770)'3B cc1: ',jz,lastcond%prescribed,& +! eqlista(ieq)%lastcondition%prescribed + newcond1=>eqlista(ieq)%lastcondition + bugcond=>newcond1 + oldcond=>lastcond%next + do while(.not.associated(oldcond,lastcond)) + jz=jz+1 + newcond2=>newcond1 + call copy_condition(newcond1%next,oldcond) + newcond1=>newcond1%next +! write(*,770)'3B cc2: ',jz,oldcond%prescribed,newcond1%prescribed +770 format(a,i2,6(1pe12.4)) + newcond1%previous=>newcond2 + oldcond=>oldcond%next + enddo + newcond1%next=>bugcond +! write(*,*)'Copied all condition',jz + else + nullify(eqlista(ieq)%lastcondition) + endif +! copy experiments) ... later +! + nullify(eqlista(ieq)%lastexperiment) +! +! copy TPfuns and symbols and current values +! write(*,*)'Copy tpval arrays' + eqlista(ieq)%tpval=ceq%tpval + allocate(eqlista(ieq)%eq_tpres(maxtpf)) +! write(*,*)'allocated tpres arrays' + eqlista(ieq)%eq_tpres=ceq%eq_tpres + allocate(eqlista(ieq)%svfunres(maxsvfun)) +! write(*,*)'allocated svfunres arrays' + eqlista(ieq)%svfunres=ceq%svfunres +! copy convergence criteria + eqlista(ieq)%xconv=ceq%xconv + eqlista(ieq)%maxiter=ceq%maxiter +! write(*,*)'finished copy equilibrium',ieq + eqlista(ieq)%eqno=ieq + neweq=>eqlista(ieq) +! write(*,*)'Assigned pointer to new equilibrium',neweq%eqno +1000 continue +! write(*,*)'exit copy_equilibrium' + return + end subroutine copy_equilibrium + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine copy_condition(newrec,oldrec) +! Creates a copy of the condition record "oldrec" and returns a link +! to the copy in newrec. The links to "next/previous" are nullified + implicit none + type(gtp_condition), pointer :: oldrec + type(gtp_condition), pointer :: newrec +!\end{verbatim} +! write(*,*)' *** In copy_condition: ',oldrec%prescribed + allocate(newrec) +! write(*,*)' *** Allocated' + newrec=oldrec +! write(*,*)' *** Copied old condition to new',newrec%prescribed +1000 continue + return + end subroutine copy_condition + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + logical function check_minimal_ford(lokph) +! some tests if the fcc/bcc permutation model can be applied to this phase +! The function returns FALSE if the user may set the FORD or BORD bit of lokph + implicit none + integer lokph +!\end{verbatim} + integer nsl,nc,jl,ll,j2,loksp,lokcs + logical notallowed + integer, dimension(:), allocatable :: const + double precision ss + notallowed=.true. + nsl=phlista(lokph)%noofsubl + if(btest(phlista(lokph)%status1,PHHASP)) then +! The PHASP bit is set if a parameter has been entered (never cleared) + write(kou,*)'Permutation must be set before parameters are entered' + goto 1000 + endif + if(nsl.lt.4) then + write(kou,*)'Phase with permutation must have 4 or more sublattices' + goto 1000 + else +! ordering assumed in first 4 sublattices, that is not really necessary +! ss=phlista(lokph)%sites(1) + lokcs=phlista(lokph)%linktocs(1) + ss=firsteq%phase_varres(lokcs)%sites(1) + nc=phlista(lokph)%nooffr(1) + allocate(const(nc)) + do jl=1,nc + loksp=phlista(lokph)%constitlist(jl) + const(jl)=splista(loksp)%alphaindex + enddo + jl=nc + do ll=2,4 +! if(abs(phlista(lokph)%sites(ll)-ss).gt.1.0D-12) then + if(abs(firsteq%phase_varres(lokcs)%sites(ll)-ss).gt.1.0D-12) then + write(kou,12) +12 format(' Permutation requires the same number of',& + ' sites in first 4 sublattices') + goto 1000 + endif + if(phlista(lokph)%nooffr(ll).ne.nc) then + write(kou,13) +13 format(' Permutation requires that the number of constituents',& + ' are equal'/' in all 4 sublattices for ordering') + goto 1000 + endif +! one must also check the constituents are identical + do j2=1,nc + loksp=phlista(lokph)%constitlist(jl+j2) + if(splista(loksp)%alphaindex.ne.const(j2)) then + write(kou,14) +14 format(' Permutation requires that the constituents in the',& + ' 4 sublattices for'/' ordering are identical') + goto 1000 + endif + enddo + jl=jl+nc + enddo + endif + notallowed=.false. +1000 continue + check_minimal_ford=notallowed + return + end function check_minimal_ford + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + diff --git a/models/pmod25E.F90 b/models/gtp3C.F90 similarity index 79% rename from models/pmod25E.F90 rename to models/gtp3C.F90 index f30fe86..6e443c3 100644 --- a/models/pmod25E.F90 +++ b/models/gtp3C.F90 @@ -1,3072 +1,3548 @@ -! -! included in pmod25.F90 -! -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ -!> 10. List things -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine list_all_elements(unit) -! lists elements - implicit none - integer unit -!\end{verbatim} %+ - integer jl,ipos - character line*80 - line=' ' - write(unit,10) -10 format(/'List of elements'/ & - ' No Sym Name',10X,'Reference state',12X,& - 'Mass H298-H0 S298 Status') - loop1: do jl=-1,noofel - ipos=1 - call list_element_data(line,ipos,elements(jl)) - if(gx%bmperr.ne.0) goto 1000 - write(unit,100)jl,line(1:ipos) - enddo loop1 -100 format(i3,2x,A) -1000 continue - return - END subroutine list_all_elements - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine list_all_elements2(unit) -! lists elements - implicit none - integer unit -!\end{verbatim} - integer jl - character line*80 - line=' ' - loop1: do jl=-1,noofel - write(unit,100) ellista(jl)%symbol,ellista(jl)%ref_state,& - ellista(jl)%mass,ellista(jl)%h298_h0,ellista(jl)%s298 - enddo loop1 -100 format('ELEMENT ',A,' ',A,3(1pe12.4),' !') -1000 continue - return - END subroutine list_all_elements2 - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine list_all_components(unit,ceq) -! lists the components for an equilibrium - implicit none - integer unit - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer jl,loksp - character symbol*24 - double precision moles,masspercent,chempot - moles=zero - masspercent=zero - chempot=zero - write(unit,10) -10 format('List of components'/ & - 'No Symbol',19X,'Moles',6x,'Mass %',5x,'Chem pot',3x,'Ref. state') - loop1: do jl=1,noofel - loksp=ceq%complist(jl)%splink - symbol=splista(loksp)%symbol - write(unit,100)jl,symbol,moles,masspercent,chempot,& - ceq%complist(jl)%refstate - enddo loop1 -100 format(i2,1x,A,3(1PE11.3),1X,A) -1000 continue - return - end subroutine list_all_components - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine list_element_data(text,ipos,elno) - implicit none - character text*(*) - integer ipos,elno -!\end{verbatim} - if(elno.lt.-1 .or. elno.gt.noofel) then - gx%bmperr=4042 - goto 1000 - endif - if(ipos.lt.1 .or. ipos.ge.len(text)) then - gx%bmperr=4043 - goto 1000 - endif - text(ipos:ipos+2)=ellista(elno)%symbol - text(ipos+3:ipos+16)=ellista(elno)%name - text(ipos+17:ipos+40)=ellista(elno)%ref_state - write(text(ipos+41:ipos+73),100)ellista(elno)%mass,& - ellista(elno)%h298_h0,ellista(elno)%s298,ellista(elno)%status -100 format(1x,f7.3,1x,f7.2,1x,f7.3,1x,z8) - ipos=len_trim(text) -! write(*,*)'x:',text(1:79) -1000 continue - return - END subroutine list_element_data - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine list_species_data(text,ipos,spno) - implicit none - character text*(*) - integer ipos,spno -!\end{verbatim} %+ - character dummy*48 - integer jpos - if(spno.lt.1 .or. spno.gt.noofsp) then -! write(*,*)'in list_species_data' - gx%bmperr=4051 - goto 1000 - endif - if(ipos.lt.1 .or. ipos.ge.len(text)) then - gx%bmperr=4043 - goto 1000 - endif - text(ipos:ipos+24)=splista(spno)%symbol - text(ipos+25:ipos+25)=' ' - dummy=' ' - call encode_stoik(dummy,jpos,spno) - text(ipos+26:ipos+48)=dummy(1:min(23,jpos)) - if(jpos.gt.23) text(ipos+46:ipos+48)='<.>' - text(ipos+49:ipos+49)=' ' - write(text(ipos+50:ipos+59),100)splista(spno)%mass - write(text(ipos+60:ipos+65),105)splista(spno)%charge -100 format(F10.3) -105 format(F6.1) - text(ipos+66:)=' ' -! write(*,120)splista(spno)%status - write(text(ipos+66:ipos+73),120)splista(spno)%status -120 format(Z8) - ipos=ipos+73 -1000 continue - return - END subroutine list_species_data - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine list_species_data2(text,ipos,spno) - implicit none - character text*(*) - integer ipos,spno -!\end{verbatim} - character dummy*24 - integer jpos - if(spno.lt.1 .or. spno.gt.noofsp) then -! write(*,*)'in list_species_data' - gx%bmperr=4051 - goto 1000 - endif - if(ipos.lt.1 .or. ipos.ge.len(text)) then - gx%bmperr=4043 - goto 1000 - endif - text(ipos:ipos+24)=splista(spno)%symbol - text(ipos+25:ipos+25)=' ' - dummy=' ' - call encode_stoik(dummy,jpos,spno) - text(ipos+26:ipos+48)=dummy(1:jpos) -! text(ipos+49:ipos+49)=' ' -! write(text(ipos+50:ipos+59),100)splista(spno)%mass -! write(text(ipos+60:ipos+65),105)splista(spno)%charge -100 format(F10.3) -105 format(F6.1) -! text(ipos+66:)=' ' -! write(*,120)splista(spno)%status -! write(text(ipos+66:ipos+73),120)splista(spno)%status -120 format(Z8) -! ipos=ipos+73 -1000 continue - return - END subroutine list_species_data2 - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine list_all_species(unit) - implicit none - integer unit -!\end{verbatim} - integer jl,ipos - character line*80 - write(unit,10) -10 format(/'List of species'/ & - ' No Symbol',20X,'Stoichiometry',12X,'Mass Charge Status') - loop1: do jl=1,noofsp - ipos=1 - call list_species_data(line,ipos,species(jl)) - if(gx%bmperr.ne.0) goto 1000 - write(unit,100)jl,line(1:ipos) - enddo loop1 -100 format(i4,1x,A) -1000 continue - return - END subroutine list_all_species - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine list_all_phases(unit,ceq) -! short list with one line for each phase - implicit none - integer unit - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} -! separate entered/fixed form suspended/dormant - integer jl,jk,ics,lokph,lokcs,kp,ndorm - character line*80,phname*24,trailer*28,chs*1,csname*36 -! type(gtp_phasetuple), allocatable :: dormant - TYPE(gtp_phase_varres), pointer :: csrec - write(unit,10) -10 format(/'List of entered phases'/ & - ' No tup Name',22x,'Mol.comp. At/F.U. dGm/RT Status1 Status2') - jl=0 - trailer=' ' -! write(*,*)'In list_all_phases',noofph -! allocate(dormant(noofph)) -! dormant=0 - ndorm=0 -! come back here with dormant listing -20 continue -! - phloop: do jk=1,noofph - line=' ' -! list in alphabetical order except gas and liquid first - lokph=phases(jk) - csloop: do ics=1,phlista(lokph)%noofcs - lokcs=phlista(lokph)%linktocs(ics) - csrec=>ceq%phase_varres(lokcs) -! write(*,*)'lpd: 69: ',jk,ics,lokph,lokcs - if(ndorm.ge.0) then - if(csrec%phstate.le.PHDORM) then - ndorm=ndorm+1 -! dormant%phase=jk -! dormant%compset=ics - cycle - endif - elseif(csrec%phstate.gt.PHDORM) then - cycle - endif - phname=phlista(lokph)%name - jl=jl+1 -! write(*,70)'lpd: 70:',phname,phlista(lokph)%noofcs -!70 format(a,a24,5i6) - if(phlista(lokph)%noofcs.gt.1) then - chs=char(ichar('0')+ics) - kp=len_trim(csrec%prefix) - if(kp.gt.0) then - csname=csrec%prefix(1:kp)//'_'//phname - else - csname=phname - endif - kp=len_trim(csrec%suffix) - if(kp.gt.0) & - csname=csname(1:len_trim(csname))//'_'//csrec%suffix(1:kp) - csname=csname(1:len_trim(csname))//'#'//chs//trailer - else - csname=phname - endif -! phase names for composition sets can be larger than 24 - jl=len_trim(csname) - if(jl.gt.24) then - csname=csname(1:12)//'..'//csname(jl-9:jl) - endif - if(csrec%amfu.ne.zero) then - if(csrec%dgm.eq.zero) then -! write(unit,110)jk,ics,csname, & - write(unit,110)jk,csrec%phtupx,csname, & - csrec%amfu*csrec%abnorm(1),& - csrec%abnorm(1),& - phlista(lokph)%status1,ceq%phase_varres(lokcs)%status2 -110 format(2i4,1x,a24,1PE10.2,1x,0PF9.2,' 0.0',2(0p,z8)) - else -! write(unit,112)jk,ics,csname, & - write(unit,112)jk,csrec%phtupx,csname, & - csrec%amfu*csrec%abnorm(1),& - csrec%abnorm(1),csrec%dgm,& - phlista(lokph)%status1,ceq%phase_varres(lokcs)%status2 -112 format(2i4,1x,a24,1PE10.2,1x,0PF9.2,1PE10.2,2(0p,z8)) - endif - else -! write(unit,111)jk,ics,csname, & - write(unit,111)jk,csrec%phtupx,csname, & - csrec%abnorm(1),csrec%dgm,& - phlista(lokph)%status1,ceq%phase_varres(lokcs)%status2 -111 format(2i4,1x,a24,' 0.0',1x0PF9.2,1PE10.2,2(0p,z8)) - endif - enddo csloop - enddo phloop - if(ndorm.le.0) goto 1000 - write(unit,200) -200 format(/'List of dormant/suspended phases'/ & - ' No tup Name',22x,'Mol.comp. At/F.U. dGm/RT Status1 Status2') - ndorm=-1 - goto 20 - -1000 continue -! temporary list all phase tuples -! do jl=1,nooftuples -! lokph=phases(phasetuple(jl)%phase) -! lokcs=phlista(lokph)%linktocs(phasetuple(jl)%compset) -! write(*,600)jl,phasetuple(jl)%phase,phasetuple(jl)%compset,lokcs,& -! firsteq%phase_varres(lokcs)%phtupx -!600 format('Phase tuple: ',3i4,' backlink: ',5i4) -! enddo - return - END subroutine list_all_phases - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine list_global_results(lut,ceq) -! list G, T, P, V and some other things - implicit none - integer lut - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - character encoded*64 - double precision x1,x2,x3,xn,rtn - call get_state_var_value('T ',x1,encoded,ceq) - call get_state_var_value('P ',x2,encoded,ceq) - call get_state_var_value('V ',x3,encoded,ceq) - if(gx%bmperr.ne.0) goto 1000 - write(lut,10)x1,x1-273.15,x2,x3 -10 format('T= ',F9.2,' K (',F9.2,' C), P= ',1pe11.4,& - ' Pa, V= ',1pe11.4,' m3') - rtn=globaldata%rgas*x1 -! problem with N, should not take into account the atoms/formula units? - call get_state_var_value('N ',xn,encoded,ceq) - call get_state_var_value('B ',x2,encoded,ceq) - if(gx%bmperr.ne.0) goto 1000 - write(lut,11)xn,x2,rtn -11 format('N= ',1pe12.4,' moles, B= ',1pe12.4,' g, RT= ',1pe12.4,' J/mol') - call get_state_var_value('G ',x1,encoded,ceq) - call get_state_var_value('H ',x2,encoded,ceq) - call get_state_var_value('S ',x3,encoded,ceq) - if(gx%bmperr.ne.0) goto 1000 - write(lut,12)x1,x1/xn,x2,x3 -12 format('G= ',1pe11.4,' J, G/N= ',1pe11.4,' J/mol, H= ',1pe11.4,& - ' J, S= ',1pe11.4,' J/K') -1000 continue - return - end subroutine list_global_results - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine list_components_result(lut,mode,ceq) -! list one line per component (name, moles, x/w-frac, chem.pot. reference state -! mode 1=mole fractions, 2=mass fractions - implicit none - integer lut,mode - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - character svtext*64,encoded*64,name*24 - integer ie,kl - double precision x1,x2,x3,x4,rtn - if(mode.eq.1) then - write(lut,7) -!7 format('Component name',11x,'Moles',7x,'Mole-fracs Chem.potent. ',& -7 format('Component name',4x,'Moles',6x,'Mole-fr Chem.pot/RT ',& - 'Activities Ref.state') - elseif(mode.eq.2) then - write(lut,9) -9 format('Component name',4x,'Moles',6x,'Mass-fr Chem.pot/RT ',& - 'Activities Ref.state') - endif - call get_state_var_value('T ',x1,encoded,ceq) - rtn=globaldata%rgas*x1 - do ie=1,noofel - call get_component_name(ie,name,ceq) - kl=len_trim(name) - svtext='N('//name(1:kl)//') ' -! write(*,*)'state variable :',svtext - call get_state_var_value(svtext,x1,encoded,ceq) - if(gx%bmperr.ne.0) goto 1000 -! - if(mode.eq.1) then - svtext='X('//name(1:kl)//') ' - elseif(mode.eq.2) then - svtext='W('//name(1:kl)//') ' - endif - call get_state_var_value(svtext,x2,encoded,ceq) - if(gx%bmperr.ne.0) goto 1000 -! This should be read from component record .... ???? YES - svtext='MU('//name(1:kl)//') ' -! write(*,*)'state variable :',svtext - call get_state_var_value(svtext,x3,encoded,ceq) -! divide mu with RT - x3=x3/rtn - x4=exp(x3) - if(gx%bmperr.ne.0) then - write(*,*)'25E Error: ',gx%bmperr - gx%bmperr=0; x3=1.0D36 - endif -! reference state, by default "SER (default)" take from component record -! if(ceq%complist(ie)%phlink.gt.0) then - encoded=ceq%complist(ie)%refstate -! else -! default name of reference state -! encoded='SER (default)' -! endif - write(lut,10)name(1:16),x1,x2,x3,x4,encoded(1:16) -!10 format(a,3(1pe12.4),2x,a) -10 format(a,1pe12.4,0pf9.5,2(1pe12.4),2x,a) - enddo -1000 continue - return - end subroutine list_components_result - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine list_phases_with_positive_dgm(mode,lut,ceq) -! list one line for each phase+comp.set with positive dgm on device lut -! The phases must be dormant or the result is in error. mode is not used - implicit none - integer mode,lut - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - character name*24 -! character*10, dimension(-3:2) :: status=& -! ['SuspendedEntered ','Fix ','Dormant ','Suspended '] - integer once,iph,lokph,ics,lokcs,kkz - double precision xxx - once=0 - do iph=1,noofph - lokph=phases(iph) - csloop: do ics=1,phlista(lokph)%noofcs - lokcs=phlista(lokph)%linktocs(ics) - if(ceq%phase_varres(lokcs)%phstate.lt.PHDORM) cycle csloop - if(abs(ceq%phase_varres(lokcs)%netcharge).gt.1.0d-6) then -! write(*,*)'ignoring phase with net charge: ',iph,ics - cycle csloop - endif - if(ceq%phase_varres(lokcs)%dgm.gt.1.0D-12) then - if(once.eq.0) then - once=1 - write(lut,110) -110 format(/' *** Phases which would like to be stable:') - endif - call get_phase_name(iph,ics,name) - kkz=test_phase_status(iph,ics,xxx,ceq) -! write(*,*)'25E: error: ',name,lokcs,kkz -! old kkz.le.2 means entered or fixed -! if(kkz.le.3) then -! now: kkz= -3, -2, -1, 0, 1, 2 -! means SUSPEND, DORMANT, ENTENTED/UNST, ENTERED, ENTERD/STABLE, FIXED - if(kkz.ge.PHDORM) then - write(lut,120)name,phstate(kkz),ceq%phase_varres(lokcs)%dgm -120 format('Phase: ',a,' Status: ',a,' Driving force:',1pe12.4) - endif - endif - enddo csloop - enddo -1000 continue - return - end subroutine list_phases_with_positive_dgm - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine list_phase_results(iph,jcs,mode,lut,ceq) -! list results for a phase+comp.set on lut -! mode specifies the type and amount of results, -! unit digit: 0=mole fraction, othewise mass fractions -! 10th digit: 0=only composition, 10=also constitution -! 100th digit: 0=value order, 100=alphabetical order -! 1000th digit: 0=only stable phases, 1000=all phases - implicit none - integer iph,jcs,mode,lut - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - character text*256,phname*24,status*10 - character (len=24), dimension(:), allocatable :: consts -! character*24, allocatable (:) :: consts - double precision xmol(maxel),wmass(maxel),totmol,totmass,amount,abv,mindgm - double precision, dimension(:), allocatable :: ymol - integer lokph,lokcs,kode,nz,jl,nk,ll,ip,kstat - mindgm=1.0D-10 - if(ocv()) write(*,*)'mode: ',mode - if(iph.lt.1 .or. iph.gt.noofph) then -! write(*,*)'lpr ',iph,jcs,mode - gx%bmperr=4050; goto 1000 - endif - lokph=phases(iph) - if(btest(phlista(lokph)%status1,phhid)) then -! phase is hidden - gx%bmperr=4119; goto 1000 - endif -! -! .gt.9 -! - if(jcs.lt.0 .or. jcs.gt.phlista(lokph)%noofcs) then - gx%bmperr=4072; goto 1000 - elseif(jcs.eq.0) then - jcs=1 - endif - lokcs=phlista(lokph)%linktocs(jcs) -! write(*,*)'lpr 2: ',jcs,phlista(lokph)%noofcs,lokcs -! get name with pre- and suffix - call get_phase_name(iph,jcs,phname) - if(gx%bmperr.ne.0) goto 1000 -! write(*,11)'Phase name: ',iph,jcs,phname -!11 format(a,2i3,'"',a,'"') - if(mode.ge.1000) then -! if mode>=1000 list stable phases only (dgm<0 ) -! if(ceq%phase_varres(lokcs)%amount(1).eq.zero) then - if(abs(ceq%phase_varres(lokcs)%netcharge).gt.1.0d-6) goto 1000 - if(ceq%phase_varres(lokcs)%amfu.eq.zero) then -! skip phases with zero amount unless expcitly stable or positive dgm - if(ceq%phase_varres(lokcs)%dgm.eq.zero) then -! if(ceq%phase_varres(lokcs)%phstate.ne.PHFIXED) goto 1000 - if(ceq%phase_varres(lokcs)%phstate.lt.PHENTSTAB) goto 1000 - elseif(ceq%phase_varres(lokcs)%dgm.lt.mindgm) then - goto 1000 - endif - endif - endif -! phase status (except hidden) .... use get_phase_status instead ??? -! if(btest(ceq%phase_varres(lokcs)%status2,cssus)) then -! if(btest(ceq%phase_varres(lokcs)%status2,csfixdorm)) then - if(ceq%phase_varres(lokcs)%phstate.eq.PHDORM) then - status='Dormant' - kstat=4 -! skip dormant phases unless positive driving force -! if(ceq%phase_varres(lokcs)%dgm.le.mindgm) goto 1000 - elseif(ceq%phase_varres(lokcs)%phstate.eq.PHSUS) then -! skip suspended phases - status='Suspended' - goto 1000 -! if(btest(ceq%phase_varres(lokcs)%status2,csfixdorm)) then - elseif(ceq%phase_varres(lokcs)%phstate.eq.PHFIXED) then - status='Fixed' - kstat=2 - else - status='Entered' - kstat=1 -! skip phase with net charge -! if(abs(ceq%phase_varres(lokcs)%netcharge).gt.1.0D-6) goto 1000 -! skip entered phases that have positive driving force, why?? -! if(ceq%phase_varres(lokcs)%dgm.gt.zero) goto 1000 - endif - if(phname(1:1).lt.'A' .or. phname(1:1).gt.'Z') then -! in some cases unprintable phase names appears!! - write(lut,19)iph,jcs,lokph,lokcs -19 format('Illegal phase name: ',10i5) - endif - write(lut,20)phname,status,ceq%phase_varres(lokcs)%dgm -20 format(/'Phase: ',A,' Status: 'A,' Driving force: ',1PE12.4) -!------------------------ -! xmol=zero -! wmass=zero - call calc_phase_molmass(iph,jcs,xmol,wmass,totmol,totmass,amount,ceq) - if(gx%bmperr.ne.0) then - write(*,*)'Error: ',gx%bmperr; goto 1000 - endif -! write(*,99)'xmol: ',xmol -!99 format(a,6(1pe12.4)) - kode=mod(mode,10) -! write(*,*)'lpr: ',mode,kode - abv=ceq%phase_varres(lokcs)%abnorm(1) - if(kode.eq.0) then -! The volume value here is WRONG: ceq%phase_varres(lokcs)%gval(3,1) !!! ??? - if(abs(ceq%phase_varres(lokcs)%netcharge).gt.1.0D-6) then - write(lut,28)totmol,totmass*0.001, & - amount*ceq%rtn*ceq%phase_varres(lokcs)%gval(3,1),& - ceq%phase_varres(lokcs)%netcharge - else - write(lut,25)totmol,totmass*0.001, & - amount*ceq%rtn*ceq%phase_varres(lokcs)%gval(3,1) - endif - write(lut,21)ceq%phase_varres(lokcs)%amfu,abv -21 format('Formula Units: ',1pe12.4,', Moles of atoms/FU: ',1pe12.4,& - ', Molar content:') - else - write(lut,25)totmol,totmass*0.001,& - amount*ceq%rtn*ceq%phase_varres(lokcs)%gval(3,1) - write(lut,22)ceq%phase_varres(lokcs)%amfu,abv -22 format('Formula Units: ',1pe12.4,', Moles of atoms/FU: ',1pe12.4,& - ', Mass fractions:') - endif -25 format('Moles',1PE12.4,', Mass',1PE12.4,' kg, Volume',1PE12.4,' m3') -28 format('Moles',1PE12.4,', Mass',1PE12.4,' kg, Volume',1PE12.4,' m3',& - ' Charge: ',1pe10.2) -! composition - nz=noofel - allocate(consts(nz)) - consts=' ' - do jl=1,nz - consts(jl)=splista(ceq%complist(jl)%splink)%symbol - enddo -! write(*,187)'lpr: ',consts -!187 format(a,20(1x,a2)) - if(kode.eq.0) then - call format_phase_composition(mode,nz,consts,xmol,lut) - else - call format_phase_composition(mode,nz,consts,wmass,lut) - endif - deallocate(consts) - if(gx%bmperr.ne.0) goto 1000 -!------------------------------------- -! constitution only if nonzero tenth-digit of mode or if GAS -300 continue - if(.not.btest(phlista(lokph)%status1,PHGAS)) then - if(mod(mode/10,10).le.0) goto 1000 - endif - write(lut,310) -310 format('Constitution: ') -!--------------- - nk=0 - sublatloop: do ll=1,phlista(lokph)%noofsubl - nz=phlista(lokph)%nooffr(ll) - if(phlista(lokph)%noofsubl.gt.1) then -! write(lut,320)ll,nz,phlista(lokph)%sites(ll) - write(lut,320)ll,nz,ceq%phase_varres(lokcs)%sites(ll) -320 format('Sublattice ',i2,' with ',i5,' constituents and ',& - F12.6,' sites') -! elseif(phlista(lokph)%sites(ll).eq.one) then - elseif(ceq%phase_varres(lokcs)%sites(ll).eq.one) then - write(lut,321)nz -321 format('There are ',i5,' constituents:') - else -! write(lut,322)nz,phlista(lokph)%sites(ll) - write(lut,322)nz,ceq%phase_varres(lokcs)%sites(ll) -322 format('Single lattice with ',i5,' constituents and ',& - F12.6,' sites') - endif - text=' '; ip=1 - allocate(consts(nz)) - allocate(ymol(nz)) - consts=' ' - do jl=1,nz -! jcons=splista(phlista(lokph)%constitlist(nk+jl))%alphaindex - consts(jl)=' ' - if(phlista(lokph)%constitlist(nk+jl).gt.0) then - consts(jl)=splista(phlista(lokph)%constitlist(nk+jl))%symbol - else - consts(jl)='*' - endif - ymol(jl)=ceq%phase_varres(lokcs)%yfr(nk+jl) - enddo - call format_phase_composition(mode,nz,consts,ymol,lut) - deallocate(consts) - deallocate(ymol) - if(gx%bmperr.ne.0) goto 1000 - nk=nk+nz - enddo sublatloop -1000 continue - return - end subroutine list_phase_results - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine format_phase_composition(mode,nv,consts,vals,lut) -! list composition/constitution in alphabetical or value order -! entalsiffra 0 mole fraction, 1 mass fraction, 3 mole percent, 4 mass percent -! tiotalsiffra ? -! mode >100 else alphanetical order -! nv is number of components/constitunents (in alphabetical order in consts) -! components/constituents in consts, fractions in vals - implicit none - integer nv,mode,lut - character consts(nv)*(*) - double precision vals(nv) -!\end{verbatim} - integer maxl,jl,kp,ncol,nrow2,nvrest,n1,nempty,n3r,n4r - character names(4)*12 - integer, dimension(:), allocatable :: isort -! 3-13 position name, 12 positions value (1pe12.5), 2 positions separator -! NOTE components can have negative fractions but not constituents -! so leave one blank after component names -! Constituents with names longer than 13 will be written A23456..12345 -! with 6 initial characters, two dots and then the 5 last characters -! Max 4 columns with 18 positions(=72) plus 3*2=6 position separator, -! min 3 columns with 24 positions(=72) plus 2*2=4 position separator -! -! max length of names and number of columns - maxl=0 - do jl=1,nv - kp=len_trim(consts(jl)) - if(kp.gt.maxl) then - maxl=kp - endif - enddo - if(maxl.le.4) then -! use 4 columns if names are short - ncol=4 - else - ncol=3 - endif -! number of rows is needed to have valuses in columns decending like: -! FE 0.75 SI 0.05 Ti 0.02 C 0.01 -! CR 0.20 Mn 0.04 V 0.01 -!----------------------------------- - nrow2=(nv+ncol-1)/ncol -! always use isort for the order, if alphabetical isort(i)=i - allocate(isort(nv+4)) - if(mode.ge.100) then -! value order if mode >100, sort vals and use isort to find component name - call sortrdd(vals,nv,isort) - if(buperr.ne.0) then - write(*,*)'Error sorting fractions',buperr - gx%bmperr=buperr; goto 1000 - endif - else -! if alphabetical order just set isort(i)=i, same index as for vals - do jl=1,nv - isort(jl)=jl - enddo - endif -! list constituents in the order of isort - if(ncol.eq.4) then -! All names max 4 characters, 4 columns: 1 + 4+1+13+2 +20 +20 +18 = 79 - nvrest=nv - n1=1 -! number of empty colums in last row is 4*nrow2-nv - nempty=4*nrow2-nv -! 3rd and 4th column may start from one or two indices less - n3r=2*nrow2 - n4r=3*nrow2 - if(nempty.eq.3) then - n3r=n3r-1 - n4r=n4r-2 - elseif(nempty.eq.2) then - n4r=n4r-1 - endif -100 continue -! this can be quite complicated as last row may be partially empty as - if(nvrest.ge.4) then - names(1)=consts(isort(n1)) - names(2)=consts(isort(n1+nrow2)) - names(3)=consts(isort(n1+n3r)) -! 4th column may be empty after first row - if(n1+n4r.le.nv) then - names(4)=consts(isort(n1+n4r)) - write(lut,110)names(1)(1:4),vals(n1),& - names(2)(1:4),vals(n1+nrow2),names(3)(1:4),vals(n1+n3r),& - names(4)(1:4),vals(n1+n4r) -110 format(1x,a,1x,1pe13.5,3(2x,a,1x,1pe13.5)) - nvrest=nvrest-4 - else - write(lut,110)names(1)(1:4),vals(n1),& - names(2)(1:4),vals(n1+nrow2),names(3)(1:4),vals(n1+n3r) - nvrest=nvrest-3 - endif - n1=n1+1 - else -! last row can be 1 to 3 columns - names(1)=consts(isort(n1)) - if(nvrest.gt.1) then - names(2)=consts(isort(n1+nrow2)) - if(nvrest.gt.2) then - names(3)=consts(isort(n1+n3r)) - write(lut,110)names(1)(1:4),vals(n1),& - names(2)(1:4),vals(n1+nrow2),names(3)(1:4),vals(n1+n3r) - else - write(lut,110)names(1)(1:4),vals(n1),& - names(2)(1:4),vals(n1+nrow2) - endif - else - write(lut,110)names(1)(1:4),vals(n1) - endif - nvrest=0 - endif - if(nvrest.gt.0) goto 100 - else -! All listed names have max 13 characters, longer names are truncated - nvrest=nv - n1=1 -! number of empty columns in last row - nempty=3*nrow2-nv -! 3rd column may start from an indices less - n3r=2*nrow2 - if(nempty.eq.2) then - n3r=n3r-1 - endif -200 continue - if(nvrest.ge.3) then - names(1)=consts(isort(n1)) - names(2)=consts(isort(n1+nrow2)) - if(n1+2*nrow2.le.nv) then - names(3)=consts(isort(n1+n3r)) - write(lut,210)names(1),vals(n1),names(2),vals(n1+nrow2),& - names(3),vals(n1+n3r) -210 format(1x,a,1pe12.5,2(2x,a,1pe12.5)) - nvrest=nvrest-3 - else - write(lut,210)names(1),vals(n1),names(2),vals(n1+nrow2) - nvrest=nvrest-2 - endif - n1=n1+1 - else -! last row can be 1 or 2 columns - names(1)=consts(isort(n1)) - if(nvrest.gt.1) then - names(2)=consts(isort(n1+nrow2)) - write(lut,210)names(1),vals(n1),names(2),vals(n1+nrow2) - else - write(lut,210)names(1),vals(n1) - endif - nvrest=0 - endif - if(nvrest.gt.0) goto 200 - endif -! -1000 continue - return - end subroutine format_phase_composition - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine list_many_formats(ftyp,unit) -! lists all data in different formats -! unfinished - implicit none - integer unit,ftyp -!\end{verbatim} - integer iph,ipos - character text*64, text2*2000 - select case(ftyp) - case default - write(kou,*)'No such format' -!---------------------------------------------------------- - case(1) ! ftyp=1 SCREEN format - call list_all_elements(kou) - if(gx%bmperr.ne.0) goto 1000 - call list_all_species(kou) - if(gx%bmperr.ne.0) goto 1000 - call list_all_funs(kou) - if(gx%bmperr.ne.0) goto 1000 - do iph=1,noph() - call list_phase_data(iph,kou) - if(gx%bmperr.ne.0) goto 1000 - enddo -! list reference phase last - iph=0 - call list_phase_data(0,kou) -! finally list data references - write(kou,*) - call list_bibliography(kou) -!-------------------------------------------------------------- - case(2) ! ftyp=2 TDB format - call list_all_elements2(kou) - write(kou,*) - do iph=1, nosp() - ipos=1 - call list_species_data2(text,ipos,iph) - write(kou,110)text -110 format('SPECIES ',A,' !') - end do - write(kou,*) - do iph=1, notpf()! freetpfun-1 - text2='FUNCTION ' - call list_tpfun(iph,0,text2(10:)) -! write(kou,120)text2 -120 format(A,' !') - ipos=len_trim(text2) - text2(ipos+1:)=' !' - call wrice2(kou,0,8,78,1,text2) - end do - write(kou,130) -130 format(/'TYPE_DEFINITION % SEQ !'/ & - ' DEFINE_SYSTEM_DEFAULT ELEMENT 2 !'/ & - 'DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !'/) - do iph=1, noph() - call list_phase_data2(iph,kou) - end do - write(kou,140) -140 format(/' LIST_OF_REFERENCES'/ ' NUMBER SOURCE') - call list_bibliography(kou) -!-------------------------------------------------------------- - case(3) ! ftyp=3 MACRO format - write(kou,*)'Not implemented yet' -!-------------------------------------------------------------- - case(4) ! ftyp=2 LATEX format - write(kou,*)'Not implemented yet' - end select -!-------------------------------------------------------------- -1000 continue - return - end subroutine list_many_formats - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine list_phase_model(iph,ics,lut,ceq) -! list model (no parameters) for a phase on lut - implicit none - integer iph,ics,lut - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - character phname*24,l78*78 -! integer, dimension(maxsubl) :: endm,ilist - integer lokcs,knr,kmr,ll,ip,lokph - TYPE(gtp_fraction_set) :: disfra - type(gtp_phase_add), pointer :: addrec - double precision rl -! if ics=0 list fractions for all composition sets - lokph=phases(iph) -! name, model name -! sublattices, status, -! additions -! sites, constituents and fractions in each disordered constituents -! number of disordered sublattices -! sites, constituents and fractions in each disordered constituents - if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then - write(*,*)'No subch composition set' - gx%bmperr=7777; goto 1000 - elseif(ics.eq.0) then - ics=1 - endif - lokcs=phlista(lokph)%linktocs(ics) - call get_phase_name(iph,ics,phname) - write(lut,110)phname,phlista(lokph)%models(1:40),& - phlista(lokph)%noofsubl,phlista(lokph)%status1,& - ceq%phase_varres(lokcs)%status2 -110 format(a,', model: ',a/'Number of sublattices: ',i2,& - ', status: ',z8,1x,z8,5x) - addrec=>phlista(lokph)%additions - lastadd: do while(associated(addrec)) - call list_addition(lut,lokph,addrec) - addrec=>addrec%nextadd - enddo lastadd -! return here if more composition sets -200 continue - rl=zero - knr=0 - kmr=0 -! return here for each sublattice - do ll=1,phlista(lokph)%noofsubl - rl=rl+one - kmr=kmr+phlista(lokph)%nooffr(ll) - l78='Subl. '; ip=7 - call wrinum(l78,ip,2,0,rl) - l78(ip:)=', sites: '; ip=ip+9 -! call wrinum(l78,ip,6,0,phlista(lokph)%sites(ll)) - call wrinum(l78,ip,6,0,ceq%phase_varres(lokcs)%sites(ll)) - l78(ip:)=', const.: '; ip=ip+10 -! return here for each new constituent in this sublattice -320 continue - knr=knr+1 - if(phlista(lokph)%constitlist(knr).gt.0) then - l78(ip:)=splista(phlista(lokph)%constitlist(knr))%symbol - else - l78(ip:)='*' - endif - ip=len_trim(l78)+2 - l78(ip-1:ip-1)='=' -! The fractions for normal sublattice done by list result or list phase-const - call wrinum(l78,ip,6,0,ceq%phase_varres(lokcs)%yfr(knr)) - l78(ip:ip+1)=', ' - ip=ip+2 - if(ip.gt.60) then - write(lut,330)l78(1:ip-3) -330 format(a) - l78=' ' - ip=4 - endif - if(knr.lt.kmr) goto 320 - if(ip.gt.4) write(lut,330)l78(1:ip-3) - enddo - if(btest(phlista(lokph)%status1,PHMFS)) then -! the phase has disordered fractions -! ?? does the = here make a copy? I just want a pointer ... - disfra=ceq%phase_varres(lokcs)%disfra - lokcs=disfra%varreslink - if(disfra%ndd.eq.1) then - write(lut,410)disfra%latd -410 format('Disordred fractions adding all fractions from all ',& - i2,' sublattices together') - else - write(lut,420)disfra%latd -420 format('Disordred fractions adding fractions from first ',i2,& - ' sublattices together'/& - ' in the first disordered sublattice',& - ' and the remaining fractions in the second.') - endif -! write the disordered constituents and fractions - ll=0 - rl=zero - knr=0 - kmr=0 -! return here for second sublattice (if any) -430 continue - ll=ll+1 - rl=rl+one - kmr=kmr+disfra%nooffr(ll) - l78='Subl. '; ip=7 - call wrinum(l78,ip,2,0,rl) - l78(ip:)=', sites: '; ip=ip+9 - call wrinum(l78,ip,6,0,disfra%dsites(ll)) - l78(ip:)=', const.: '; ip=ip+10 -! return here for each new constituent in this sublattice -440 continue - knr=knr+1 - l78(ip:)=splista(disfra%splink(knr))%symbol -! list fractions in disordered sublattice as this is the only place for that - ip=len_trim(l78)+2 - l78(ip-1:ip-1)='=' - call wrinum(l78,ip,6,0,ceq%phase_varres(lokcs)%yfr(knr)) - l78(ip:)=',' - ip=ip+2 - if(ip.gt.60) then - write(lut,330)l78(1:ip-3) - l78=' ' - ip=4 - endif - if(knr.lt.kmr) goto 440 - if(ip.gt.4) write(lut,330)l78(1:ip-3) - if(ll.lt.disfra%ndd) goto 430 - endif -1000 continue - return - end subroutine list_phase_model - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine list_phase_data(iph,lut) -! list parameter data for a phase on unit lut - implicit none - integer iph,lut -!\end{verbatim} %+ - integer typty,parlist,typspec,lokph,nsl,nk,ip,ll,jnr,ics,lokcs - integer nint,ideg,ij,kk,iel,ncsum,kkx,kkk,jdeg,iqnext,iqhigh,lqq,nz,ik - integer intpq,linkcon - character text*1024,phname*24,prop*32,funexpr*512 - character special*8 - integer, dimension(2,3) :: lint - integer, dimension(maxsubl) :: endm,ilist - logical subref,noelin1 - type(gtp_fraction_set), pointer :: disfrap -! a smart way to have an array of pointers - TYPE intrecarray - type(gtp_interaction), pointer :: p1 - end TYPE intrecarray - type(intrecarray), dimension(20) :: intrecstack - type(gtp_property), pointer :: proprec - type(gtp_interaction), pointer :: intrec - type(gtp_endmember), pointer :: endmemrec - TYPE(gtp_fraction_set) :: disfra - TYPE(gtp_phase_add), pointer :: addrec -! - if(iph.lt.0 .or. iph.gt.noofph) then - gx%bmperr=4050; goto 1000 - elseif(noofel.eq.0) then -! this needed as there is a reference phase with iph=0 when there are elements - goto 1000 - endif -! write(*,*)'lpd 1:',iph,phases(iph) - if(iph.gt.0) then - lokph=phases(iph) - else - lokph=0 - endif - ics=1 - phname=phlista(lokph)%name - nsl=phlista(lokph)%noofsubl - special=' ' -! indicate some status bit specially - if(btest(phlista(lokph)%status1,PHFORD)) special(1:1)='F' - if(btest(phlista(lokph)%status1,PHBORD)) special(1:1)='B' - if(btest(phlista(lokph)%status1,PHSORD)) special(1:1)='S' - if(btest(phlista(lokph)%status1,PHIONLIQ)) special(1:1)='I' - if(btest(phlista(lokph)%status1,PHMFS)) special(2:2)='D' -! This subroutine is independent of current equilibrium, use firsteq -! write(lut,10)phname,phlista(lokph)%status1,special,& -! nsl,(phlista(lokph)%sites(ll),ll=1,nsl) - lokcs=phlista(lokph)%linktocs(ics) - write(lut,10)phname,phlista(lokph)%status1,special,& - nsl,(firsteq%phase_varres(lokcs)%sites(ll),ll=1,nsl) -10 format(/'Phase: ',A,', Status: ',Z8,2x,a/' Subl:',I3,10(1x,F7.3)) - nk=0 - text='Constituents: ' - ip=15 - sublatloop: do ll=1,nsl - constloop: do ik=1,phlista(lokph)%nooffr(ll) - nk=nk+1 - jnr=phlista(lokph)%constitlist(nk) - if(jnr.gt.0) then - text(ip:)=splista(jnr)%symbol - else - text(ip:)='*' - endif - ip=len_trim(text)+1 -! text(ip:ip)=',' - text(ip:ip)=' ' - ip=ip+1 - enddo constloop - text(ip-1:ip)=': ' - ip=ip+1 - enddo sublatloop - call wrice2(lut,2,4,78,-1,text) -! write(lut,17)text(1:ip) -!17 format(A) -! additions - addrec=>phlista(lokph)%additions - lastadd: do while(associated(addrec)) - call list_addition(lut,lokph,addrec) - addrec=>addrec%nextadd - enddo lastadd -60 continue -! parameters for end members using site fractions - if(btest(phlista(lokph)%status1,PHMFS)) then - subref=.FALSE. - else - subref=.TRUE. - endif - parlist=1 -!-------------------------------------------------- -! return here to list disordered parameters -100 continue -! parlist changed below for disordered fraction set - if(parlist.eq.1) then - endmemrec=>phlista(lokph)%ordered - else - if(ocv()) write(*,*)'Listing disordred parameters ',nsl - endmemrec=>phlista(lokph)%disordered - disfrap=>firsteq%phase_varres(lokcs)%disfra - endif - endmemberlist: do while(associated(endmemrec)) - do ll=1,nsl -! ilist(ll)=emlista(lokem)%fraclinks(ll,1) - ilist(ll)=endmemrec%fraclinks(ll,1) - if(ilist(ll).gt.0) then - if(parlist.eq.2) then -! what is disfra here??!! - endm(ll)=disfra%splink(ilist(ll)) - else - endm(ll)=phlista(lokph)%constitlist(ilist(ll)) - endif - else -! wildcard, write '*' - endm(ll)=-99 - endif - enddo - nint=0 - ideg=0 - call encode_constarr(text,nsl,endm,nint,lint,ideg) - if(gx%bmperr.ne.0) goto 1000 - proprec=>endmemrec%propointer - ptyloop: do while(associated(proprec)) - ij=proprec%proptype - if(ij.ge.100) then - typty=ij/100 - typspec=mod(ij,100) - else - typty=ij - endif - if(typty.gt.0 .and. typty.le.ndefprop) then - prop=propid(typty)%symbol - if(parlist.eq.2) then -! disordered endmember parameter - kk=len_trim(prop)+1 - prop(kk:kk)='D' - endif - if(btest(propid(typty)%status,IDELSUFFIX)) then -! property like ZZ&(phase,constituent array) -! the element index should be in typsepc - iel=typspec - if(iel.ge.0 .and. iel.le.noofel) then -! prop=propid(typty)%symbol - prop=prop(1:len_trim(prop))//'&'& - //ellista(elements(iel))%symbol - else - gx%bmperr=4082; goto 1000 - endif - elseif(btest(propid(typty)%status,IDCONSUFFIX)) then -! property like mobility, MQ&(phase,constituent array) -! the suffix is a constituent - iel=typspec - if(iel.gt.0 .and. iel.le.phlista(lokph)%tnooffr) then - if(parlist.eq.2) then -! we must consider parlist, take disordered constituent list -! we have no current equilibrium record but can use firsteq!! -! lokcs=phlista(lokph)%linktocs(1) -! write(*,*)'25E: endmember typspec 1: ',iel - linkcon=disfrap%splink(iel) -! write(*,*)'25E: endmember typspec 2: ',linkcon - ll=1 - if(linkcon.gt.disfrap%nooffr(1)) ll=2 - prop=prop(1:len_trim(prop))//'&'& - //splista(linkcon)%symbol - goto 120 - else - linkcon=phlista(lokph)%constitlist(iel) - if(linkcon.le.0) then - write(*,*)'Illegal use of wildcard 1' - gx%bmperr=7777; goto 1000 - endif - prop=prop(1:len_trim(prop))//'&'& - //splista(linkcon)%symbol -! also add the sublattice number ... - ncsum=0 - do ll=1,phlista(lokph)%noofsubl - ncsum=ncsum+phlista(lokph)%nooffr(ll) - if(iel.le.ncsum) goto 120 - enddo - endif -! error if sublattice not found - write(kou,*)'Error in constituent depended parameter id' - gx%bmperr=7777; goto 1000 -! jump here to append sublattice -120 continue -! write(*,*)'property 1: ',prop(1:10),ll - prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0')) - else - write(kou,*)'lpd 7B: ',iel,typty - gx%bmperr=4082; goto 1000 - endif - endif - else -! unknown property ... - write(*,*)'unknown property type xx: ',ij,typty,typspec - prop='ZZ' - endif -! if disordered fraction set add D, already done above -! if(parlist.eq.2) then -! prop=prop(1:len_trim(prop))//'D' -! endif -! note changes here must be repeated for interaction parameters below - write(funexpr,200)prop(1:len_trim(prop)),& - phname(1:len_trim(phname)),text(1:len_trim(text)) -200 format(A,'(',A,',',A,') ') - ip=len_trim(funexpr)+1 -! subtract reference states - if(subref .and. typty.eq.1) then - call subrefstates(funexpr,ip,lokph,parlist,endm,noelin1) - if(noelin1) then -! this can happen for ionic liquids with just neutrals in sublattice 2 -! replace the constituent in sublattice 1 with "*" !!! -! write(*,*)'before: ',funexpr(1:ip) - kk=index(funexpr,',') - ik=index(funexpr,':') - funexpr(kk+1:)='*'//funexpr(ik:) - ip=len_trim(funexpr)+2 -! write(*,*)'after: ',funexpr(1:ip) - endif - endif -! this writes the expression - call list_tpfun(proprec%degreelink(0),1,funexpr(ip:)) - ip=len_trim(funexpr) - funexpr(ip+1:)=' '//proprec%reference - ip=len_trim(funexpr) -! nice output over several lines if needed with indentation 12 spaces - call wrice2(lut,2,12,78,1,funexpr(1:ip)) - proprec=>proprec%nextpr - enddo ptyloop - if(endmemrec%noofpermut.gt.1) then - intpq=0 - if(associated(endmemrec%intpointer)) then - intpq=endmemrec%intpointer%antalint - endif -! write(kou,207)endmemrec%antalem,endmemrec%noofpermut,intpq -207 format('@$ Endmember, permutations, interaction: ',3i5) - endif - endmemrec=>endmemrec%nextem - enddo endmemberlist -!----------------------------------------------------------------------- -! parameters for interactions using site fractions - if(parlist.eq.1) then - endmemrec=>phlista(lokph)%ordered - else - endmemrec=>phlista(lokph)%disordered - endif - intlist1: do while(associated(endmemrec)) - intrec=>endmemrec%intpointer - if(associated(intrec)) then -! write(*,*)'intlist 1B: ',intrec%status - do ll=1,nsl - kkx=endmemrec%fraclinks(ll,1) - if(kkx.eq.-99) then -! wildcard - endm(ll)=-99 - elseif(parlist.eq.2) then - endm(ll)=disfra%splink(kkx) - else - endm(ll)=phlista(lokph)%constitlist(kkx) - endif - enddo - endif - nint=0 - intlist2: do while(associated(intrec)) - nint=nint+1 - intrecstack(nint)%p1=>intrec - lint(1,nint)=intrec%sublattice(1) - kkk=intrec%fraclink(1) - if(parlist.eq.2) then - lint(2,nint)=disfra%splink(kkk) - else - lint(2,nint)=phlista(lokph)%constitlist(kkk) - endif - proprec=>intrec%propointer - ptyloop2: do while(associated(proprec)) -! typty=proprec%proptype - ij=proprec%proptype - if(ij.ge.100) then - typty=ij/100 - typspec=mod(ij,100) - else - typty=ij - endif -! typspec=proprec%proptype -! if(typspec.gt.100) then -! typty=typspec/100 -! typspec=mod(typty,100) -! else -! typty=typspec -! endif - if(typty.gt.0 .and. typty.le.ndefprop) then - prop=propid(typty)%symbol - if(parlist.eq.2) then -! disordered interaction parameter - kk=len_trim(prop)+1 - prop(kk:kk)='D' - endif - if(btest(propid(typty)%status,IDELSUFFIX)) then -! property like ZZ&(phase,constituent array) -! the element index should be in typsepc - iel=typspec - if(iel.ge.0 .and. iel.le.noofel) then - prop=prop(1:len_trim(prop))//'&'& - //ellista(elements(iel))%symbol - else -! write(*,*)'lpd 7: ',iel,typty - gx%bmperr=4082; goto 1000 - endif - elseif(btest(propid(typty)%status,IDCONSUFFIX)) then -! property like mobility MQ&(phase,constituent array) -! the suffix is a constituent - iel=typspec - if(iel.gt.0 .and. iel.le.phlista(lokph)%tnooffr) then - if(parlist.eq.2) then -! we must consider parlist, take disordered constituent list -! we have no current equilibrium record but can use firsteq!! -! write(*,*)'25E: typspec: 3 ',typty,iel,prop(1:10) - linkcon=disfrap%splink(iel) -! write(*,*)'25E: typspec: 4 ',typty,linkcon,prop(1:10) - ll=1 - if(iel.gt.disfrap%nooffr(1)) ll=2 - prop=prop(1:len_trim(prop))//'&'& - //splista(linkcon)%symbol - goto 220 - else - linkcon=phlista(lokph)%constitlist(iel) - if(linkcon.le.0) then - write(*,*)'Illegal use of wildcard 2' - gx%bmperr=7777; goto 1000 - endif - prop=prop(1:len_trim(prop))//'&'& - //splista(linkcon)%symbol -! also add the sublattice number ... - ncsum=0 - do ll=1,phlista(lokph)%noofsubl - ncsum=ncsum+phlista(lokph)%nooffr(ll) - if(iel.le.ncsum) goto 220 - enddo - endif -! there cannot be any errors here .... - write(*,*)'Never never error 2' - gx%bmperr=7777; goto 1000 -220 continue -! write(*,*)'property 2: ',prop(1:10),ll - prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0')) - else -! write(*,*)'lpd 7: ',iel,typty - gx%bmperr=4082; goto 1000 - endif - endif - else -! unknown property ... - write(*,*)'unknown property type yy: ',typty - prop='ZZ' - endif -! if disordered fraction set add D, already set above ??!! -! if(parlist.eq.2) then -! prop=prop(1:len_trim(prop))//'D' -! endif -! note changes here must be repeated for endmember parameters above - do jdeg=0,proprec%degree - call encode_constarr(text,nsl,endm,nint,lint,jdeg) - write(funexpr,300)prop(1:len_trim(prop)), & - phname(1:len_trim(phname)),text(1:len_trim(text)) -300 format(A,'(',A,',',A,') ') - ip=len_trim(funexpr)+1 - call list_tpfun(proprec%degreelink(jdeg),1,funexpr(ip:)) - ip=len_trim(funexpr) - funexpr(ip+1:)=' '//proprec%reference - ip=len_trim(funexpr) - call wrice2(lut,4,12,78,1,funexpr(1:ip)) - enddo - proprec=>proprec%nextpr - enddo ptyloop2 -! list temporarily the number of permutations - if(intrec%noofip(1).gt.1 .or. intrec%noofip(2).gt.1) then - if(nint.eq.1) then - nz=intrec%noofip(2) - else - nz=size(intrec%sublattice) - lqq=intrec%noofip(size(intrec%noofip)) - if(lqq.ne.nz) then - write(*,*)'Not same: ',intrec%antalint,nz,lqq - endif -! write(*,301)nz,intrec%noofip -301 format('noofip: ',10i3) -! nz=intrec%noofip(intrec%noofip(1)+2) - endif - iqnext=0 - iqhigh=0 - if(associated(intrec%highlink)) then - iqhigh=intrec%highlink%antalint - endif - if(associated(intrec%nextlink)) then - iqnext=intrec%nextlink%antalint - endif - write(*,302)intrec%antalint,nz,nint,iqhigh,iqnext -302 format('@$ Interaction, permutations, level, high, next: ',5i5) - endif - intrec=>intrec%highlink - empty: do while(.not.associated(intrec)) - if(nint.gt.0) then -! restore pointers in same clumsy way - intrec=>intrecstack(nint)%p1 - intrec=>intrec%nextlink -! write(*,*)'poping a pointer from intrecstack',ninit - nint=nint-1 - else - exit intlist2 - endif - enddo empty - enddo intlist2 - endmemrec=>endmemrec%nextem - enddo intlist1 -! check if there are other fraction lists -! parlist=parlist+1, hm parlist can only be 1 or 2 -! write(*,*)'checking for disordered parameters' - if(parlist.eq.1 .and. associated(phlista(lokph)%disordered)) then - subref=.TRUE. -! lokcs=phlista(lokph)%cslink - lokcs=phlista(lokph)%linktocs(ics) -! does this make a copy? Maybe it should be a pointer - disfra=firsteq%phase_varres(lokcs)%disfra - write(lut,810)disfra%fsites -810 format('Disordered fraction parameters: ',F10.4,2x,20('-')) - nsl=disfra%ndd - parlist=2 - if(ocv()) write(*,*)'Jump back to list disordered',nsl,parlist - goto 100 - endif -1000 continue - return - END subroutine list_phase_data - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine list_phase_data2(iph,lut) -! list parameter data for a phase on unit lut in TDB format - implicit none - integer iph,lut -!\end{verbatim} - integer typty,parlist,typspec,lokph,nsl,nk,ip,ll,jnr,ics,lokcs - integer nint,ideg,ij,kk,iel,ncsum,kkx,kkk,jdeg,iqnext,iqhigh,lqq,nz,ik - integer intpq,linkcon - character text*1024,phname*24,prop*32,funexpr*512 - character special*8 - integer, dimension(2,3) :: lint - integer, dimension(maxsubl) :: endm,ilist - logical subref,noelin1 - type(gtp_fraction_set), pointer :: disfrap -! a smart way to have an array of pointers - TYPE intrecarray - type(gtp_interaction), pointer :: p1 - end TYPE intrecarray - type(intrecarray), dimension(20) :: intrecstack - type(gtp_property), pointer :: proprec - type(gtp_interaction), pointer :: intrec - type(gtp_endmember), pointer :: endmemrec - TYPE(gtp_fraction_set) :: disfra - TYPE(gtp_phase_add), pointer :: addrec -! - if(iph.lt.0 .or. iph.gt.noofph) then - gx%bmperr=4050; goto 1000 - elseif(noofel.eq.0) then -! this needed as there is a reference phase with iph=0 when there are elements - goto 1000 - endif -! write(*,*)'lpd 1:',iph,phases(iph) - if(iph.gt.0) then - lokph=phases(iph) - else - lokph=0 - endif - ics=1 - phname=phlista(lokph)%name - nsl=phlista(lokph)%noofsubl - special=' ' -! indicate some status bit specially - if(btest(phlista(lokph)%status1,PHFORD)) special(1:1)='F' - if(btest(phlista(lokph)%status1,PHBORD)) special(1:1)='B' - if(btest(phlista(lokph)%status1,PHSORD)) special(1:1)='S' - if(btest(phlista(lokph)%status1,PHIONLIQ)) special(1:1)='I' - if(btest(phlista(lokph)%status1,PHMFS)) special(2:2)='D' -! This subroutine is independent of current equilibrium, use firsteq -! write(lut,10)phname,phlista(lokph)%status1,special,& -! nsl,(phlista(lokph)%sites(ll),ll=1,nsl) - lokcs=phlista(lokph)%linktocs(ics) - write(lut,10)phname,& - nsl,(firsteq%phase_varres(lokcs)%sites(ll),ll=1,nsl) -10 format(/'PHASE ',A,' %',I3,10(1x,F7.3)) - nk=0 - text=' CONSTITUENT '//phname//' :' - ip=len_trim(text)+1 - sublatloop: do ll=1,nsl - constloop: do ik=1,phlista(lokph)%nooffr(ll) - nk=nk+1 - jnr=phlista(lokph)%constitlist(nk) - if(jnr.gt.0) then - text(ip:)=splista(jnr)%symbol - else - text(ip:)='*' - endif - ip=len_trim(text)+1 -! text(ip:ip)=',' - text(ip:ip)=' ' - ip=ip+1 - enddo constloop - text(ip-1:ip)=': ' - ip=ip+1 - enddo sublatloop - text(ip-2:)=':!' - call wrice2(lut,2,4,78,-1,text) -! write(lut,17)text(1:ip) -!17 format(A) -! additions - addrec=>phlista(lokph)%additions - lastadd: do while(associated(addrec)) - call list_addition(lut,lokph,addrec) - addrec=>addrec%nextadd - enddo lastadd -60 continue -! parameters for end members using site fractions - if(btest(phlista(lokph)%status1,PHMFS)) then - subref=.FALSE. - else - subref=.TRUE. - endif - parlist=1 -!-------------------------------------------------- -! return here to list disordered parameters -100 continue -! parlist changed below for disordered fraction set - if(parlist.eq.1) then - endmemrec=>phlista(lokph)%ordered - else - if(ocv()) write(*,*)'Listing disordred parameters ',nsl - endmemrec=>phlista(lokph)%disordered - disfrap=>firsteq%phase_varres(lokcs)%disfra - endif - endmemberlist: do while(associated(endmemrec)) - do ll=1,nsl -! ilist(ll)=emlista(lokem)%fraclinks(ll,1) - ilist(ll)=endmemrec%fraclinks(ll,1) - if(ilist(ll).gt.0) then - if(parlist.eq.2) then -! what is disfra here??!! - endm(ll)=disfra%splink(ilist(ll)) - else - endm(ll)=phlista(lokph)%constitlist(ilist(ll)) - endif - else -! wildcard, write '*' - endm(ll)=-99 - endif - enddo - nint=0 - ideg=0 - call encode_constarr(text,nsl,endm,nint,lint,ideg) - if(gx%bmperr.ne.0) goto 1000 - proprec=>endmemrec%propointer - ptyloop: do while(associated(proprec)) - ij=proprec%proptype - if(ij.ge.100) then - typty=ij/100 - typspec=mod(ij,100) - else - typty=ij - endif - if(typty.gt.0 .and. typty.le.ndefprop) then - prop=propid(typty)%symbol - if(parlist.eq.2) then -! disordered endmember parameter - kk=len_trim(prop)+1 - prop(kk:kk)='D' - endif - if(btest(propid(typty)%status,IDELSUFFIX)) then -! property like ZZ&(phase,constituent array) -! the element index should be in typsepc - iel=typspec - if(iel.ge.0 .and. iel.le.noofel) then -! prop=propid(typty)%symbol - prop=prop(1:len_trim(prop))//'&'& - //ellista(elements(iel))%symbol - else - gx%bmperr=4082; goto 1000 - endif - elseif(btest(propid(typty)%status,IDCONSUFFIX)) then -! property like mobility, MQ&(phase,constituent array) -! the suffix is a constituent - iel=typspec - if(iel.gt.0 .and. iel.le.phlista(lokph)%tnooffr) then - if(parlist.eq.2) then -! we must consider parlist, take disordered constituent list -! we have no current equilibrium record but can use firsteq!! -! lokcs=phlista(lokph)%linktocs(1) -! write(*,*)'25E: endmember typspec 1: ',iel - linkcon=disfrap%splink(iel) -! write(*,*)'25E: endmember typspec 2: ',linkcon - ll=1 - if(linkcon.gt.disfrap%nooffr(1)) ll=2 - prop=prop(1:len_trim(prop))//'&'& - //splista(linkcon)%symbol - goto 120 - else - linkcon=phlista(lokph)%constitlist(iel) - if(linkcon.le.0) then - write(*,*)'Illegal use of wildcard 1' - gx%bmperr=7777; goto 1000 - endif - prop=prop(1:len_trim(prop))//'&'& - //splista(linkcon)%symbol -! also add the sublattice number ... - ncsum=0 - do ll=1,phlista(lokph)%noofsubl - ncsum=ncsum+phlista(lokph)%nooffr(ll) - if(iel.le.ncsum) goto 120 - enddo - endif -! error if sublattice not found - write(kou,*)'Error in constituent depended parameter id' - gx%bmperr=7777; goto 1000 -! jump here to append sublattice -120 continue -! write(*,*)'property 1: ',prop(1:10),ll - prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0')) - else - write(kou,*)'lpd 7B: ',iel,typty - gx%bmperr=4082; goto 1000 - endif - endif - else -! unknown property ... - write(*,*)'unknown property type xx: ',ij,typty,typspec - prop='ZZ' - endif -! if disordered fraction set add D, already done above -! if(parlist.eq.2) then -! prop=prop(1:len_trim(prop))//'D' -! endif -! note changes here must be repeated for interaction parameters below - write(funexpr,200)prop(1:len_trim(prop)),& - phname(1:len_trim(phname)),text(1:len_trim(text)) -200 format(' PARAMETER ',A,'(',A,',',A,') ') - ip=len_trim(funexpr)+1 -! subtract reference states - if(subref .and. typty.eq.1) then - call subrefstates(funexpr,ip,lokph,parlist,endm,noelin1) - if(noelin1) then -! this can happen for ionic liquids with just neutrals in sublattice 2 -! replace the constituent in sublattice 1 with "*" !!! -! write(*,*)'before: ',funexpr(1:ip) - kk=index(funexpr,',') - ik=index(funexpr,':') - funexpr(kk+1:)='*'//funexpr(ik:) - ip=len_trim(funexpr)+2 -! write(*,*)'after: ',funexpr(1:ip) - endif - endif -! this writes the expression - call list_tpfun(proprec%degreelink(0),1,funexpr(ip:)) - ip=len_trim(funexpr) - funexpr(ip+1:)=' '//proprec%reference - ip=len_trim(funexpr) - funexpr(ip+1:)=' !' -! nice output over several lines if needed with indentation 12 spaces - call wrice2(lut,2,12,78,1,funexpr(1:ip+2)) - proprec=>proprec%nextpr - enddo ptyloop - if(endmemrec%noofpermut.gt.1) then - intpq=0 - if(associated(endmemrec%intpointer)) then - intpq=endmemrec%intpointer%antalint - endif -! write(kou,207)endmemrec%antalem,endmemrec%noofpermut,intpq -207 format('@$ Endmember, permutations, interaction: ',3i5) - endif - endmemrec=>endmemrec%nextem - enddo endmemberlist -!----------------------------------------------------------------------- -! parameters for interactions using site fractions - if(parlist.eq.1) then - endmemrec=>phlista(lokph)%ordered - else - endmemrec=>phlista(lokph)%disordered - endif - intlist1: do while(associated(endmemrec)) - intrec=>endmemrec%intpointer - if(associated(intrec)) then -! write(*,*)'intlist 1B: ',intrec%status - do ll=1,nsl - kkx=endmemrec%fraclinks(ll,1) - if(kkx.eq.-99) then -! wildcard - endm(ll)=-99 - elseif(parlist.eq.2) then - endm(ll)=disfra%splink(kkx) - else - endm(ll)=phlista(lokph)%constitlist(kkx) - endif - enddo - endif - nint=0 - intlist2: do while(associated(intrec)) - nint=nint+1 - intrecstack(nint)%p1=>intrec - lint(1,nint)=intrec%sublattice(1) - kkk=intrec%fraclink(1) - if(parlist.eq.2) then - lint(2,nint)=disfra%splink(kkk) - else - lint(2,nint)=phlista(lokph)%constitlist(kkk) - endif - proprec=>intrec%propointer - ptyloop2: do while(associated(proprec)) -! typty=proprec%proptype - ij=proprec%proptype - if(ij.ge.100) then - typty=ij/100 - typspec=mod(ij,100) - else - typty=ij - endif -! typspec=proprec%proptype -! if(typspec.gt.100) then -! typty=typspec/100 -! typspec=mod(typty,100) -! else -! typty=typspec -! endif - if(typty.gt.0 .and. typty.le.ndefprop) then - prop=propid(typty)%symbol - if(parlist.eq.2) then -! disordered interaction parameter - kk=len_trim(prop)+1 - prop(kk:kk)='D' - endif - if(btest(propid(typty)%status,IDELSUFFIX)) then -! property like ZZ&(phase,constituent array) -! the element index should be in typsepc - iel=typspec - if(iel.ge.0 .and. iel.le.noofel) then - prop=prop(1:len_trim(prop))//'&'& - //ellista(elements(iel))%symbol - else -! write(*,*)'lpd 7: ',iel,typty - gx%bmperr=4082; goto 1000 - endif - elseif(btest(propid(typty)%status,IDCONSUFFIX)) then -! property like mobility MQ&(phase,constituent array) -! the suffix is a constituent - iel=typspec - if(iel.gt.0 .and. iel.le.phlista(lokph)%tnooffr) then - if(parlist.eq.2) then -! we must consider parlist, take disordered constituent list -! we have no current equilibrium record but can use firsteq!! -! write(*,*)'25E: typspec: 3 ',typty,iel,prop(1:10) - linkcon=disfrap%splink(iel) -! write(*,*)'25E: typspec: 4 ',typty,linkcon,prop(1:10) - ll=1 - if(iel.gt.disfrap%nooffr(1)) ll=2 - prop=prop(1:len_trim(prop))//'&'& - //splista(linkcon)%symbol - goto 220 - else - linkcon=phlista(lokph)%constitlist(iel) - if(linkcon.le.0) then - write(*,*)'Illegal use of wildcard 2' - gx%bmperr=7777; goto 1000 - endif - prop=prop(1:len_trim(prop))//'&'& - //splista(linkcon)%symbol -! also add the sublattice number ... - ncsum=0 - do ll=1,phlista(lokph)%noofsubl - ncsum=ncsum+phlista(lokph)%nooffr(ll) - if(iel.le.ncsum) goto 220 - enddo - endif -! there cannot be any errors here .... - write(*,*)'Never never error 2' - gx%bmperr=7777; goto 1000 -220 continue -! write(*,*)'property 2: ',prop(1:10),ll - prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0')) - else -! write(*,*)'lpd 7: ',iel,typty - gx%bmperr=4082; goto 1000 - endif - endif - else -! unknown property ... - write(*,*)'unknown property type yy: ',typty - prop='ZZ' - endif -! if disordered fraction set add D, already set above ??!! -! if(parlist.eq.2) then -! prop=prop(1:len_trim(prop))//'D' -! endif -! note changes here must be repeated for endmember parameters above - do jdeg=0,proprec%degree - call encode_constarr(text,nsl,endm,nint,lint,jdeg) - write(funexpr,300)prop(1:len_trim(prop)), & - phname(1:len_trim(phname)),text(1:len_trim(text)) -300 format('PARAMETER ',A,'(',A,',',A,') ') - ip=len_trim(funexpr)+1 - call list_tpfun(proprec%degreelink(jdeg),1,funexpr(ip:)) - ip=len_trim(funexpr) - funexpr(ip+1:)=' '//proprec%reference - ip=len_trim(funexpr) - funexpr(ip+1:)=' !' - call wrice2(lut,4,12,78,1,funexpr(1:ip+2)) - enddo - proprec=>proprec%nextpr - enddo ptyloop2 -! list temporarily the number of permutations - if(intrec%noofip(1).gt.1 .or. intrec%noofip(2).gt.1) then - if(nint.eq.1) then - nz=intrec%noofip(2) - else - nz=size(intrec%sublattice) - lqq=intrec%noofip(size(intrec%noofip)) - if(lqq.ne.nz) then - write(*,*)'Not same: ',intrec%antalint,nz,lqq - endif -! write(*,301)nz,intrec%noofip -301 format('noofip: ',10i3) -! nz=intrec%noofip(intrec%noofip(1)+2) - endif - iqnext=0 - iqhigh=0 - if(associated(intrec%highlink)) then - iqhigh=intrec%highlink%antalint - endif - if(associated(intrec%nextlink)) then - iqnext=intrec%nextlink%antalint - endif - write(*,302)intrec%antalint,nz,nint,iqhigh,iqnext -302 format('@$ Interaction, permutations, level, high, next: ',5i5) - endif - intrec=>intrec%highlink - empty: do while(.not.associated(intrec)) - if(nint.gt.0) then -! restore pointers in same clumsy way - intrec=>intrecstack(nint)%p1 - intrec=>intrec%nextlink -! write(*,*)'poping a pointer from intrecstack',ninit - nint=nint-1 - else - exit intlist2 - endif - enddo empty - enddo intlist2 - endmemrec=>endmemrec%nextem - enddo intlist1 -! check if there are other fraction lists -! parlist=parlist+1, hm parlist can only be 1 or 2 -! write(*,*)'checking for disordered parameters' - if(parlist.eq.1 .and. associated(phlista(lokph)%disordered)) then - write(lut,810) -810 format('Disordered fraction parameters:',20('-')) - subref=.TRUE. -! lokcs=phlista(lokph)%cslink - lokcs=phlista(lokph)%linktocs(ics) -! does this make a copy? Maybe it should be a pointer - disfra=firsteq%phase_varres(lokcs)%disfra - nsl=disfra%ndd - parlist=2 - if(ocv()) write(*,*)'Jump back to list disordered',nsl,parlist - goto 100 - endif -1000 continue - return - END subroutine list_phase_data2 - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine subrefstates(funexpr,jp,lokph,parlist,endm,noelin1) -! list a sum of reference states for a G parameter -! like "-H298(BCC_A2,FE)-3*H298(GRAPITE,C)" - implicit none - integer jp,lokph,parlist,endm(*) - character funexpr*(*) - logical noelin1 -!\end{verbatim} -! special care for ionic liquid as sites varies ... - character text*80,els*2 - integer element(maxel),lokel - double precision coef(maxel),xx,pqval(2) - TYPE(gtp_fraction_set) :: disfra - integer nsl,lokcs,ie,ll,jsp,nrel,ik,je,more,is,ip -! - noelin1=.FALSE. - lokcs=phlista(lokph)%linktocs(1) - if(btest(phlista(lokph)%status1,PHIONLIQ)) goto 210 - if(parlist.eq.1) then - nsl=phlista(lokph)%noofsubl - else -! should disfra be a pointer?? It seems to work like this .... - disfra=firsteq%phase_varres(lokcs)%disfra - nsl=disfra%ndd - endif - ie=0 - sublat: do ll=1,nsl - jsp=endm(ll) - if(jsp.gt.0) then - nrel=splista(jsp)%noofel - elem: do ik=1,nrel - do je=1,ie - if(splista(jsp)%ellinks(ik).eq.element(je)) then - if(parlist.eq.1) then - coef(je)=coef(je)+& - firsteq%phase_varres(lokcs)%sites(ll)*& - splista(jsp)%stoichiometry(ik) -! phlista(lokph)%sites(ll)*splista(jsp)%stoichiometry(ik) - else - coef(je)=coef(je)+& - disfra%dsites(ll)*splista(jsp)%stoichiometry(ik) - endif - goto 200 - endif - enddo -! new element, increment ie and initiate coef -! ignore the element VA with element index 0 - if(splista(jsp)%ellinks(ik).eq.0) goto 200 - ie=ie+1 - element(ie)=splista(jsp)%ellinks(ik) - if(parlist.eq.1) then - coef(ie)=& - firsteq%phase_varres(lokcs)%sites(ll)*& - splista(jsp)%stoichiometry(ik) -! phlista(lokph)%sites(ll)*splista(jsp)%stoichiometry(ik) - else - coef(ie)=disfra%dsites(ll)*splista(jsp)%stoichiometry(ik) - endif -200 continue - enddo elem - else -! wildcard, ignore references - continue - endif - enddo sublat - goto 300 -!------------------------------------------------------------ -! ionic liquid special, 2 sublattices but sites varies with charges -210 continue - ie=0 - jsp=endm(1) - if(jsp.gt.0) then - pqval(2)=splista(jsp)%charge - else - pqval(2)=one - endif - jsp=endm(2) - if(jsp.gt.0) then - if(btest(splista(jsp)%status,SPVA)) then - pqval(1)=one - else - pqval(1)=-splista(jsp)%charge - if(pqval(1).eq.zero) then - noelin1=.TRUE. - pqval(2)=one - endif - endif - else - write(*,*)'Illegal with wildcards in 2nd sublattice' - gx%bmperr=7777; goto 1000 - endif - ionsl: do ll=1,2 - jsp=endm(ll) - if(jsp.lt.0) cycle - nrel=splista(jsp)%noofel - ionel: do ik=1,nrel - do je=1,ie - if(splista(jsp)%ellinks(ik).eq.element(je)) then - coef(je)=coef(je)+& - pqval(ll)*splista(jsp)%stoichiometry(ik) - cycle ionel - endif - enddo -! new element, increment ie and initiate coef -! ignore the element VA with element index 0 - if(splista(jsp)%ellinks(ik).ne.0) then - ie=ie+1 - element(ie)=splista(jsp)%ellinks(ik) - coef(ie)=& - pqval(ll)*splista(jsp)%stoichiometry(ik) - endif - enddo ionel - enddo ionsl -!------------------------------------------------------------ -! sort the elements -300 continue - more=0 - do je=1,ie-1 - if(element(je).gt.element(je+1)) then - is=element(je) - element(je)=element(je+1) - element(je+1)=is - xx=coef(je) - coef(je)=coef(je+1) - coef(je+1)=xx - more=1 - endif - enddo - if(more.gt.0) goto 300 -! list the elemsnts as -10*H298(SER,element) -! write(*,*)'subrefstate 2:',ie,(element(i),i=1,ie) - ip=1 - text=' ' - do je=1,ie - if(coef(je).ne.one) then - call wrinum(text,ip,10,6,-coef(je)) - text(ip:ip)='*' - else - text(ip:ip)='-' - endif - ip=ip+1 - lokel=element(je) - els=ellista(lokel)%symbol - if(ellista(lokel)%refstatesymbol.eq.0) then - text(ip:)='H298(SER,'//els(1:len_trim(els))//')' - else - text(ip:)='G(SER,'//els(1:len_trim(els))//')' - endif - ip=len_trim(text)+1 - enddo -! write(*,*)'subrefstate 9: ',ip,text(1:ip) - funexpr(jp:)=text - jp=jp+ip -1000 continue - return - end subroutine subrefstates - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine encode_stoik(text,ipos,spno) -! generate a stoichiometric formula of species from element list - implicit none - integer ipos,spno - character text*(*) -!\end{verbatim} - character elnam*2,ltext*60 - integer eli,noelx,iel,isto,jpos,ich,nlen - double precision stoi,charge - if(spno.lt.1 .or. spno.gt.noofsp) then -! write(*,*)'in encode_stoik' - gx%bmperr=4051 - goto 1000 - endif - ipos=1 - noelx=splista(spno)%noofel -! write(6,*)'encode_stoik 1: ',spno,noelx - loop1: do iel=1,noelx - eli=splista(spno)%ellinks(iel) - elnam=ellista(eli)%symbol -! write(6,*)'encode_stoik 2: ',eli,elnam - if(elnam(2:2).ne.' ') then - ltext(ipos:ipos+1)=elnam - nlen=2 - else - ltext(ipos:ipos)=elnam - nlen=1 - endif - ipos=ipos+nlen - stoi=splista(spno)%stoichiometry(iel) - isto=int(stoi) - if(abs(dble(isto)-stoi).lt.1.0D-3) then -! handle integer stoichiometries nicely - if(isto.gt.99) then - write(ltext(ipos:ipos+2),200)isto -200 format(I3) - ipos=ipos+3 - elseif(isto.gt.9) then - write(ltext(ipos:ipos+1),205)isto -205 format(I2) - ipos=ipos+2 - elseif(isto.gt.1) then - write(ltext(ipos:ipos),210)isto -210 format(i1) - ipos=ipos+1 -! write(6,*)'encode_stoik 4B: ',ltext(ipos-3:ipos) - elseif(nlen.eq.1 .and. iel.ne.noelx) then - ltext(ipos:ipos)='1' - ipos=ipos+1 - endif - else -! stoichiometry is a non-integer value - jpos=ipos - call wrinum(ltext,ipos,8,0,stoi) - if(buperr.ne.0) then - gx%bmperr=buperr; goto 1000 - endif -! remove trailing zeroes -300 continue - if(ltext(ipos:ipos).eq.'0') then - ipos=ipos-1; goto 300 - endif - endif - enddo loop1 - charge=splista(spno)%charge - ich=int(charge) -! write(6,*)'encode_stoik 5: ',ich,charge - if(ich.lt.zero) then -! limit output to integer charges <10 - ltext(ipos:ipos+3)='/-'//char(ichar('0')-ich) - ipos=ipos+3 - elseif(charge.gt.zero) then - ltext(ipos:ipos+3)='/+'//char(ichar('0')+ich) - ipos=ipos+3 - endif - text=ltext - ipos=ipos-1 -! write(6,*)'encode_stoik 6: ',ipos,ltext(1:ipos) -1000 continue - return - END subroutine encode_stoik - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine decode_stoik(name,noelx,elsyms,stoik) -! decode a species stoichiometry in name to element index and stoichiometry -! all in upper case - implicit none - character name*(*),elsyms(*)*2 - double precision stoik(*) - integer noelx -!\end{verbatim} - character lname*72,ch2*2 - double precision xx - integer ip,jp - lname=name - call capson(lname) - noelx=0 - ip=1 -! expect element symbol - if(eolch(lname,ip)) then -! empty line, expected species stoichiometry - gx%bmperr=4083; goto 1000 - endif -! write(*,*)'decode_stoik 1: ',lname -100 continue - ch2=lname(ip:ip+1) -! write(*,*)'Looking for element: ',ip,ch2 - if(ch2(2:2).ge.'A' .and. ch2(2:2).le.'Z') then - noelx=noelx+1 - elsyms(noelx)=ch2 - ip=ip+2 - elseif(ch2(1:1).ge.'A' .and. ch2(1:1).le.'Z') then - noelx=noelx+1 - elsyms(noelx)=ch2(1:1) - ip=ip+1 - elseif(ch2(1:1).eq.'/') then -! electron is always /-, if /+ is given change sign in lname - noelx=noelx+1 - elsyms(noelx)='/-' - if(ch2(2:2).eq.'+') then - lname(ip+1:ip+1)='-' - ip=ip+1 - elseif(ch2(2:2).eq.'-') then - ip=ip+2 - else -! do not accept Fe/2 for Fe/+2, always require + or - - write(*,*)'Charge must always be given as /+ or /-' - gx%bmperr=7777; goto 1000 - endif -! write(*,*)'Found charge: ',ip,noelx,'>',lname(ip:ip+5),'<' - else - goto 900 - endif -! an element found, no stoichiometry number means stoik=1 -! write(*,17)'decode_stoik 2: ',ip,ch2,lname(ip:ip+5) -17 format(a,i3,'>',a,'<>',a,'<') - if(lname(ip:ip).eq.' ') then - stoik(noelx)=one - else - jp=ip - call getrel(lname,ip,xx) -! write(*,*)'decode_stoik 3: ',jp,ip,buperr,xx - if(buperr.eq.0) then - stoik(noelx)=xx - else -! accept missing stoichiometry value as 1, it is accepted to write cao as cao - stoik(noelx)=one -! buperr=0 -! the error can be due to another element follows directly, restore ip an check -! ip=jp -! goto 100 - endif -! in one case of missing stoichiometry ip exceeded length of lname -! write(*,*)'decode_stoik 4: ',stoik(noelx) - fraction: if(buperr.eq.0 .and. lname(ip:ip).eq.'/') then -! a stoichiometric factor followed by / without sign will be interpreted -! as a fraction like AL2/3O. Note AL2/+3 means AL2 with charge +3 - jp=ip+1 - if(.not.(lname(jp:jp).eq.'+' .or. lname(jp:jp).eq.'-')) then - call getrel(lname,jp,xx) -! write(*,*)'decode_stoik 4: ',ip,jp,buperr,xx - if(buperr.eq.0) then - stoik(noelx)=stoik(noelx)/xx - ip=jp - else - buperr=0 - endif -! else -! write(*,*)'Interpret / as charge!' - endif - else - buperr=0 - endif fraction - if(ip.lt.len(lname)) goto 100 - endif -900 continue - if(noelx.eq.0) then - gx%bmperr=4084 - endif -! write(*,19)(stoik(i),i=1,noelx) -!19 format('decode_stoik 5: ',5(1PE12.3)) -1000 continue - return - end subroutine decode_stoik - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine encode_constarr(constarr,nsl,endm,nint,lint,ideg) -! creates a constituent array - implicit none - character constarr*(*) - integer, dimension(*) :: endm - integer nsl,nint,ideg - integer, dimension(2,*) :: lint -!\end{verbatim} - integer ip,mint,ll,l2 - ip=1 - constarr=' ' - mint=1 -! if(nint.gt.0) then -! write(*,*)'encode_contarr ',lint(1,1),lint(2,1) -! endif - do ll=1,nsl - if(endm(ll).gt.0) then - constarr(ip:)=splista(endm(ll))%symbol - else - constarr(ip:)='*' - endif - ip=len_trim(constarr) - if(mint.le.nint) then -! write(*,*)'encode_contarr ',lint(1,1),lint(2,1) - do l2=mint,nint - if(lint(1,mint).eq.ll) then - constarr(ip+1:ip+1)=',' - ip=ip+2 - constarr(ip:)=splista(lint(2,mint))%symbol - ip=len_trim(constarr) - mint=mint+1 - endif - enddo - endif - constarr(ip+1:ip+1)=':' - ip=ip+2 - enddo - constarr(ip-1:ip-1)=';' - constarr(ip:ip)=char(ideg+ichar('0')) - return - end subroutine encode_constarr - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine decode_constarr(lokph,constarr,nsl,endm,nint,lint,ideg) -! deconde a text string with a constituent array -! a constituent array has separated by , or : and ; before degree - implicit none - character constarr*(*) - integer endm(*),lint(2,*) - integer nsl,nint,ideg,lokph,lord -!\end{verbatim} - character const*24,ch1*1 - integer ll,ip,jp,isep,loksp,mord,isp,jsp,nord - integer constlist(5),klok(5),knr(2) -! - nint=0; ideg=0; ll=1 - endm(ll)=0 - ip=1 -! write(*,*)'decode_constarr 1: ',ip,constarr - if(eolch(constarr,ip)) then - gx%bmperr=4061; goto 1000 - endif - jp=ip-1 -! write(*,*)'decode_constarr 2: ',ip,jp - loop: do while(.true.) -! find separators between constituents, no spaces allowed - jp=jp+1 - ch1=biglet(constarr(jp:jp)) -! write(*,*)'decode_constarr 3: ',jp,ch1 - letter: if(ch1.eq.',') then - isep=1 - elseif(ch1.eq.':') then - isep=2 - elseif(ch1.eq.';') then - isep=3 - elseif(ch1.eq.' ') then - isep=4 - elseif(.not.(ch1.ge.'A' .and. ch1.le.'Z')) then -! write(*,*)'decode_constarr 3B: ',jp,ip,ch1 - if(jp.gt.ip) then -! accept 0-9 and _ and . and / and + and - -! after the first character of a constituent -! write(*,24)'decode constarr 24A: "',ch1 - if(.not.((ch1.ge.'0' .and. ch1.le.'9') .or. & - ch1.eq.'_' .or. ch1.eq.'.' .or. & - ch1.eq.'/' .or. ch1.eq.'+' .or. ch1.eq.'-')) then -! write(*,24)'25E: decode constarr 24B: "',ch1 -24 format(a,a,'"') - gx%bmperr=4062; goto 1000 - endif - elseif(ch1.ne.'*') then -! last possibility: wildcard -! write(*,24)'decode constarr 24C: "',ch1 - gx%bmperr=4062; goto 1000 - endif -! write(*,24)'decode constarr 24D: "',ch1 - cycle - else - cycle - endif letter -! we have a species name between ip and jp - const=constarr(ip:jp-1) - call find_species_record_exact(const,loksp) - if(gx%bmperr.ne.0) then - if(const(1:2).eq.'* ') then -! wildcard, the parameter is independent of the fraction in this sublattice - loksp=-99; gx%bmperr=0 - else - goto 1000 - endif - endif -! write(*,11)'decode constarr 11: ',ip,jp,loksp,const -!11 format(a,3i4,'"',a,'"') - place: if(endm(ll).eq.0) then -! first constituent of sublattice ll independent of separator - endm(ll)=loksp - else - lint(1,nint)=ll - lint(2,nint)=loksp - endif place - next: if(isep.eq.1) then -! separator was a , next constituent an interaction - nint=nint+1 - elseif(isep.eq.2) then -! separator was a ":" meaning new sublattice - ll=ll+1 - endm(ll)=0 - elseif(isep.eq.3) then -! this is end of constituent array, followed ba a degree 0-9 - ideg=ichar(constarr(jp+1:jp+1))-ichar('0') - if(ideg.lt.0 .or. ideg.gt.9) then -! a degree must be between 0 and 9 - gx%bmperr=4063; goto 1000 - endif - exit loop - elseif(isep.eq.4) then - exit loop - endif next -! beginning of next constituent - ip=jp+1 - enddo loop -! number of sublattices - nsl=ll -! make sure the constituents are in alphabetcal order for each sublattice. -!-------------------------------------------------------- -! Special order of constituents for ionic liquid .... - if(btest(phlista(lokph)%status1,PHIONLIQ)) then - constlist(1)=endm(1) - if(nsl.ne.2) then - if(nsl.eq.1) then -! when ionic liquid parameters entered from TDB-TC files parameters -! with just neutrals may have only one sublattice. Error cleared by -! the readtdb subroutine. -! BUT we must sort constituents on the sublattice, must be only neutrals ... -! I hope that will be chacked later ... - do jsp=1,nint - constlist(1+jsp)=lint(2,jsp) - enddo -! simple bubble sort of constlist -44 continue - do jsp=1,nint - if(constlist(jsp+1).lt.constlist(jsp)) then - lord=constlist(jsp) - constlist(jsp)=constlist(jsp+1) - constlist(jsp+1)=lord - goto 44 - endif - enddo - endif - endm(1)=constlist(1) - do jsp=1,nint - lint(2,jsp)=constlist(1+jsp) - enddo - if(ocv()) write(*,*)'Ionic liquid has always 2 sublattices' - gx%bmperr=7777; goto 1000 - endif - lord=1 - do jsp=1,nint - if(lint(1,jsp).eq.1) then - lord=lord+1 - constlist(lord)=lint(2,jsp) - endif - enddo - knr(1)=lord - lord=lord+1 - constlist(lord)=endm(2) - do jsp=1,nint - if(lint(1,jsp).eq.2) then - lord=lord+1 - constlist(lord)=lint(2,jsp) - endif - enddo - knr(2)=lord-knr(1) - call sort_ionliqconst(lokph,1,knr,constlist,klok) - if(gx%bmperr.ne.0) then - write(*,*)'Error return from sort_ionliqconst ',gx%bmperr - goto 1000 - endif -! write(*,65)lord,(klok(ll),ll=1,lord) -65 format('from sort: ',i5,5x,5i3) - lord=0 - endm(1)=klok(1) - do jsp=2,knr(1) - lord=lord+1 - lint(1,lord)=1 - lint(2,lord)=klok(lord+1) - enddo - endm(2)=klok(lord+2) - do jsp=2,knr(2) - lord=lord+1 - lint(1,lord)=2 - lint(2,lord)=klok(lord+2) - enddo -! write(*,66)endm(1),endm(2),(lint(1,ll),lint(2,ll),ll=1,nint) -66 format('decode: ',2i5,5x,3(2i3,2x)) - goto 1000 - endif -!-------------------------------------------------------- -! first the endmember must be in order of the constituents, except wildcard - order1: do mord=1,nint - ll=lint(1,mord) - isp=lint(2,mord) - jsp=endm(ll) -! we can have isp or jsp or both negative if wildcard, WILDCARD ALWAYS IN ENDM - if(isp.lt.0 .and. jsp.lt.0) then -! only one wildcard in each sublattice - gx%bmperr=4032; goto 1000 - elseif(isp.lt.0 .and. jsp.gt.0) then - endm(ll)=isp - lint(2,mord)=jsp - elseif(isp.gt.0 .and. jsp.lt.0) then - endm(ll)=jsp - lint(2,mord)=isp - elseif(splista(isp)%alphaindex.lt.splista(jsp)%alphaindex) then - endm(ll)=isp - lint(2,mord)=jsp - endif - enddo order1 -! then order if there are two interacting in same sublattice -! There are almost never more than 3 constituents interacting in one sublattice - order2: do mord=1,nint - ll=lint(1,mord) - order3: do nord=mord+1,nint - if(lint(1,nord).eq.ll) then - isp=lint(2,nord) - jsp=lint(2,mord) - if(isp.lt.0 .or. jsp.lt.0) then - gx%bmperr=4032; goto 1000 - endif - if(splista(isp)%alphaindex.lt.splista(jsp)%alphaindex) then - lint(2,mord)=isp - lint(2,nord)=jsp - endif - endif - enddo order3 - enddo order2 -! write(*,77)(splista(endm(i))%alphaindex,i=1,nsl), & -! (lint(1,j),lint(2,j),j=1,nint) -!77 format('decode_contarr 7: ',3I3,5x,2i2) -1000 continue - return - end subroutine decode_constarr - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} -! changed from list_references(lut) - subroutine list_bibliography(lut) -! list bibliographic references - implicit none - integer lut -!\end{verbatim} - character longline*2048 - integer ir,jp,nl,ll - write(lut,10)reffree-1 -10 format('There are ',i5,' bibliographic references') - do ir=1,reffree-1 - longline=bibrefs(ir)%reference - jp=17 - nl=size(bibrefs(ir)%refspec) -! write(*,11)nl,bibrefs(ir)%reference -!11 format('refslist 1: ',i2,1x,a) - do ll=1,nl - longline(jp:)=bibrefs(ir)%refspec(ll) -! write(*,12)ll,bibrefs(ir)%refspec(ll) -!12 format('refslist 2: ',i2,1x,a) - jp=jp+64 - enddo - jp=len_trim(longline) - call wrice(lut,0,17,78,longline(1:jp)) - enddo -1000 continue - return - end subroutine list_bibliography - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine list_conditions(lut,ceq) -! lists conditions on lut - implicit none - integer lut - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - character*1024 text - integer kl - text=' ' - call get_all_conditions(text,0,ceq) - if(gx%bmperr.ne.0) goto 1000 - kl=index(text,'CRLF') - if(kl.gt.1) then - call wrice2(lut,2,4,78,1,text(1:kl-1)) - endif - write(lut,50)text(kl+4:len_trim(text)) -50 format(a) -1000 continue - return - end subroutine list_conditions - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine get_one_condition(ip,text,seqz,ceq) -! list the condition with the index seqz into text -! It lists also fix phases and conditions that are not active - implicit none - integer ip,seqz - character text*(*) - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer jl,iterm,indx(4) - TYPE(gtp_condition), pointer :: last,current - type(gtp_state_variable), pointer :: svrrec - double precision wone -! - if(ip.le.0) ip=1 - text(ip:)=' ' - if(.not.associated(ceq%lastcondition)) then - write(*,*)'No conditions at all' - gx%bmperr=8887; goto 1000 - endif - last=>ceq%lastcondition - current=>last -70 continue - if(current%seqz.eq.seqz) goto 100 - current=>current%next - if(.not.associated(current,last)) goto 70 -! no condition with this index found - gx%bmperr=4131; goto 1000 -! -100 continue - iterm=1 -! return here for each term if several -150 continue - do jl=1,4 - indx(jl)=current%indices(jl,iterm) - enddo - if(abs(current%condcoeff(iterm)-one).gt.1.0D-10) then - wone=current%condcoeff(iterm)+one - if(abs(wone).lt.1.0D-10) then - text(ip:ip)='-' - ip=ip+1 - else -! not +1 or -1, write number - call wrinum(text,ip,8,1,current%condcoeff(iterm)) - text(ip:ip)='*' - ip=ip+1 - endif - elseif(iterm.gt.1) then -! must be a + in front of second and later terms - text(ip:ip)='+' - ip=ip+1 - endif -! why is ceq needed?? BECAUSE COMPONENTS CAN BE DIFFERENT ... hm?? !! -! call encode_state_variable2(text,ip,current%statev,indx,& -! current%iunit,current%iref,ceq) - svrrec=>current%statvar(1) - call encode_state_variable(text,ip,svrrec,ceq) - if(iterm.lt.current%noofterms) then - iterm=iterm+1; goto 150 - endif -! write = followed by the value - if(text(ip:ip).ne.' ') ip=ip+1 - text(ip:)='=' - ip=ip+1 - if(current%symlink1.gt.0) then -! the value is a symbol - text(ip:)=svflista(current%symlink1)%name - ip=len_trim(text)+1 - else - call wrinum(text,ip,10,0,current%prescribed) - endif -1000 continue - return - end subroutine get_one_condition - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine get_all_conditions(text,mode,ceq) -! list all conditions if mode=0, experiments if mode=1 - implicit none - integer mode - character text*(*) - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - TYPE(gtp_condition), pointer :: last,current,first - type(gtp_state_variable), pointer :: svrrec - character phname*32 - integer ntot,nc,ip,iterm,iph,ics,jl - double precision value,wone - integer indx(4) - ntot=0 - text=' ' - if(mode.eq.1) then -! cannot enter experiments yet - goto 1000 - endif - if(noofel.eq.0) then - text='CRLF No elements' - goto 1000 - endif - last=>ceq%lastcondition - if(.not.associated(last)) then -! The CRLF indicates CR+LF at output - write(text,50)noofel+2 -50 format('CRLF Degrees of freedom are ',i3) - goto 1000 - endif - current=>last%next - first=>current - nc=1 - ip=1 -100 continue -! conditions can also be fixed phases !!! - ntot=ntot+1 - if(current%active.ne.0) then -! if active is nonzero the condition is not active - goto 200 - endif -! call wrinum(text,ip,3,0,dble(nc)) - call wriint(text,ip,nc) -! number the conditions - text(ip:)=':' -! ip=ip+2 -! No space after : - ip=ip+1 - iterm=1 - if(current%statev.lt.0) then -! handle FIX phases - iph=-current%statev - ics=current%iref - call get_phase_name(iph,ics,phname) - if(gx%bmperr.ne.0) then - write(*,*)'list condition error for phase ',iph,ics - gx%bmperr=4178; goto 1000 - endif - text(ip:)='<'//phname - ip=len_trim(text)+3 - text(ip-2:ip-1)='>=' - value=current%prescribed - if(value.lt.1.0d-8) then - value=zero - endif - call wrinum(text,ip,4,0,value) - goto 190 - endif -! return here for each term if several -150 continue - do jl=1,4 - indx(jl)=current%indices(jl,iterm) - enddo - if(abs(current%condcoeff(iterm)-one).gt.1.0D-10) then - wone=current%condcoeff(iterm)+one - if(abs(wone).lt.1.0D-10) then - text(ip:ip)='-' - ip=ip+1 - else -! not +1 or -1, write number -! write(*,*)'list cond: ',current%condcoeff(iterm),one,wone - call wrinum(text,ip,8,1,current%condcoeff(iterm)) - text(ip:ip)='*' - ip=ip+1 - endif - elseif(iterm.gt.1) then -! must be a + in front of second and later terms - text(ip:ip)='+' - ip=ip+1 - endif -! why is ceq needed?? BECAUSE COMPONENTS CAN BE DIFFERENT ... hm?? !! -! write(*,*)'25E encode: ',current%statev,indx -! call encode_state_variable2(text,ip,current%statev,indx,& -! current%iunit,current%iref,ceq) - svrrec=>current%statvar(1) - call encode_state_variable(text,ip,svrrec,ceq) - if(iterm.lt.current%noofterms) then - iterm=iterm+1; goto 150 - endif -! problem with current position ... LNAC(CR) had the last ) overwritten ... -! write(*,157)ip,text(1:ip) -!157 format('25E gc: ',i2,'"',a,'"') - if(text(ip:ip).ne.' ') ip=ip+1 - text(ip:)='=' - ip=ip+1 - if(current%symlink1.gt.0) then -! the value is a symbol - text(ip:)=svflista(current%symlink1)%name - ip=len_trim(text)+1 - else - call wrinum(text,ip,10,0,current%prescribed) - endif -190 continue - text(ip:ip)=', ' - ip=ip+2 - nc=nc+1 -200 continue - current=>current%next - if(.not.associated(current,first)) goto 100 -! there can be non-active conditions only - if(nc.gt.1) then -! write without the last , - text(ip-2:)=' ' -! write(kou,99)text(1:ip-3) -!99 format(a) - endif - write(text(ip:),50)noofel+3-nc -1000 return - end subroutine get_all_conditions - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine list_defined_properties(lut) -! lists all parameter identifiers allowed - implicit none - integer lut -!\end{verbatim} - character special*32,tdep*1,pdep*1 - integer typty,kk - write(lut,10) -10 format('Index Ident T P Specification',23x,' Status Note') -!10 format('Index Symbol Specification',26x,' Status Note') - do typty=1,ndefprop - special=' ' - if(btest(propid(typty)%status,IDELSUFFIX)) then - special='&' - elseif(btest(propid(typty)%status,IDCONSUFFIX)) then - special='&' - endif - kk=len_trim(special) - if(kk.gt.0) then - special(kk+1:)=';' - kk=kk+2 - else - kk=1 - endif - tdep='T' - pdep='P' - if(btest(propid(typty)%status,IDNOTP)) then -! special(kk:)='Not T- and P-dependent' - tdep='-' - pdep='-' - elseif(btest(propid(typty)%status,IDONLYP)) then -! special(kk:)='Not T-dependant' - tdep='-' - endif - write(lut,50)typty,propid(typty)%symbol,tdep,pdep,special,& - propid(typty)%status,propid(typty)%note -50 format(i5,2x,a,2x,a,1x,a,2x,a,2x,z8,1x,a) - enddo -1000 continue - return - end subroutine list_defined_properties - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine find_defined_property(symbol,mode,typty,iph,ics) -! searches the propid list for one with symbol or identifiction typty -! if mode=0 then symbol given, if mode=1 then typty given -! symbol can be TC(BCC), BM(FCC), MQ&FE(HCP) etc, the phase must be -! given in symbol as otherwise it is impossible to find the consititent!!! -! A constituent may have a sublattice specifier, MQ&FE#3(SIGMA) - implicit none - integer mode,typty,iph,ics - character symbol*(*) -!\end{verbatim} - character phsym*24,specid*24,nude*4 - integer splink,k1,k2,lattice,lokph,ityp,iel,kk,ll,jj - integer jtyp -! write(*,7)'25E fdp 1: ',symbol(1:5),mode,typty,iph,ics -7 format(a,a,5i5) - if(mode.eq.0) then -! symbol given, can include & # and ( ) like MQ&FE#3(SIGMA) - lattice=0 - nude=' ' - specid=' ' - k1=index(symbol,'&') - if(k1.gt.0) then - nude=symbol(1:k1-1) - k2=index(symbol,'#') - if(k2.eq.0) then - k2=index(symbol,'(') - if(k2.eq.0) then -! write(*,*)'25E: Missing phase specifier in property symbol 1' - write(*,*)'Error in symbol: ',symbol - gx%bmperr=7777; goto 1000 - endif - else - lattice=ichar(symbol(k2+1:k2+1))-ichar('0') - if(lattice.le.0 .or. lattice.gt.9) then - write(*,*)'Sublattice outside range in property symbol' - gx%bmperr=7777; goto 1000 - endif - endif - specid=symbol(k1+1:k2-1) - call capson(specid) - endif -! there must be a phase name within ( ) - k1=index(symbol,'(') - if(k1.gt.0) then - k2=index(symbol,')') - if(k2.lt.k1) then - write(*,*)'25E Missing phase specifier in property symbol 2' - write(*,*)'Symbol: ',symbol - gx%bmperr=7777; goto 1000 - endif - phsym=symbol(k1+1:k2-1) - call find_phase_by_name(phsym,iph,ics) - if(gx%bmperr.ne.0) goto 1000 - lokph=phases(iph) - if(nude(1:1).eq.' ') nude=symbol(1:k1-1) - elseif(mode.ne.0) then - write(*,*)'25E Missing phase specifier in property symbol 3' - write(*,*)'Symbol: ',symbol,mode - gx%bmperr=7777; goto 1000 -! else -! mode=0 means just ignore -! write(*,*)'25E mode: ',mode,iph,ics -! goto 1000 - endif -! now nude is the property id, lokph is phase location, specid is element or -! constituent symbol, lattice is sublattice number -! skip index 1 as G is a state variable - call capson(nude) -! write(*,*)'fdp 2: ',iph,ics,nude - do ityp=2,ndefprop -! write(*,*)'fdp 3: ',ityp,nude,propid(ityp)%symbol - if(propid(ityp)%symbol.ne.nude) cycle - if(btest(propid(ityp)%status,IDELSUFFIX)) then -! element specifier, IBM&CR(BCC) (when we have element specific Bohr magnetons) -! write(*,*)'fdp 4: element: ',specid - call find_element_by_name(specid,iel) - if(gx%bmperr.ne.0) goto 1000 - typty=100*ityp+iel - goto 200 - elseif(btest(propid(ityp)%status,IDCONSUFFIX)) then -! constituent specifier, for example: MQ&FE#3(SIGMA) -! write(*,*)'fdp 5: constituent: ',specid - kk=0 - do ll=1,phlista(lokph)%noofsubl - do jj=1,phlista(lokph)%nooffr(ll) - kk=kk+1 - splink=phlista(lokph)%constitlist(kk) - if(splink.le.0) then - write(*,*)'Illegal use of woildcard 3' - gx%bmperr=7777; goto 1000 - endif - if(specid.eq.splista(splink)%symbol .and. & - (lattice.eq.0 .or. lattice.eq.ll)) then - typty=100*ityp+kk - goto 200 - endif - enddo - enddo - else -! property without specifier like TC(FCC) - typty=ityp - goto 200 - endif - enddo -! if we come here we have not found the constituent or element or property -! it may be OK anyway if this is a call to test if symbol exists ?? -! write(*,*)'25E Illegal property symbol' - gx%bmperr=7777; goto 1000 -! we must return property number, phase location, element -! the value TYPTY stored in property records is "idprop" or -! if IDELSUFFIX set then 100*"idprop"+ellista index of element -! if IDCONSUFFIX set then 100*"idprop"+constituent index -200 continue - else -! indices given, typty, iph and ics, construct the symbol -! if typty>100 there is also an element or constituent specifier - lokph=phases(iph) -! write(*,*)'fdp 10: ',typty,iph,ics,lokph - ityp=typty - jtyp=-1 - if(ityp.gt.100) then - ityp=typty/100 - jtyp=typty-100*ityp - endif - if(ityp.le.1 .or. ityp.gt.ndefprop) then - write(*,*)'Property number outside range ',typty - gx%bmperr=7777; goto 1000 - endif - symbol=propid(ityp)%symbol - if(btest(propid(ityp)%status,IDELSUFFIX)) then -! could one have /- as specifier??? NO !! But maye Va - if(jtyp.lt.0) then - write(*,*)'Missing element index in property symbol' - gx%bmperr=7777; goto 1000 - endif - if(jtyp.lt.0 .or. jtyp.gt.noofel) then - write(*,*)'Too high element index in property symbol' - gx%bmperr=7777; goto 1000 - endif - symbol=symbol(1:len_trim(symbol))//'&'//ellista(jtyp)%symbol - elseif(btest(propid(ityp)%status,IDCONSUFFIX)) then - if(jtyp.lt.0) then - write(*,*)'Missing constituent index in property symbol' - gx%bmperr=7777; goto 1000 - endif - if(iph.le.0 .or. iph.gt.noofph) then - write(*,*)'Illegal phase location in property symbol' - gx%bmperr=7777; goto 1000 - endif - kk=0 - do ll=1,phlista(lokph)%noofsubl - do jj=1,phlista(lokph)%nooffr(ll) - kk=kk+1 - if(kk.eq.jtyp) then - splink=phlista(lokph)%constitlist(kk) - if(splink.le.0) then - write(*,*)'Illegal use of woildcard 4' - gx%bmperr=7777; goto 1000 - endif - specid=splista(splink)%symbol - if(ll.gt.1) then - specid=specid(1:len_trim(specid))//& - '#'//char(ichar('0')+ll) - endif - goto 400 - endif - enddo - enddo -! we come here is we failed to find the constituent - write(*,*)'Illegal constituent index in property symbol' - gx%bmperr=7777; goto 1000 -400 continue - symbol=symbol(1:len_trim(symbol))//'&'//specid - elseif(jtyp.gt.0) then - write(*,*)'This property has no specifier' - gx%bmperr=7777; goto 1000 - endif -! add the phase -! write(*,*)'fdp 11: ',lokph,ics - symbol=symbol(1:len_trim(symbol))//'('//phlista(lokph)%name - if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then - write(*,*)'No such composition set' - gx%bmperr=7777; goto 1000 - endif - if(ics.gt.1) symbol=symbol(1:len_trim(symbol))//'#'//char(ichar('0')+ics) - symbol=symbol(1:len_trim(symbol))//')' -! write(*,*)'fdp 12: ',symbol(1:20) - endif -1000 continue - return - end subroutine find_defined_property - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine list_equilibria_details(mode,teq) - implicit none - TYPE(gtp_equilibrium_data), pointer :: teq - integer mode -!\end{verbatim} - TYPE(gtp_equilibrium_data), pointer :: ceq -! TYPE(gtp_phase_varres) :: varres - integer ieq,noofeq,iph - noofeq=noeq() - select case(mode) - case default - write(*,*)'No such mode: ',mode -!-------------------------------------------------- - case(1) ! list equilibria and some general data - write(*,10)noofeq -10 format('Number of equilibria: ',i3) - do ieq=1,noofeq - ceq=>eqlista(ieq) - write(*,11)ceq%eqno,ceq%eqname -11 format('Equilibrium ',i3,', ',a) - enddo -!-------------------------------------------------- - case(100:199) ! list phase varres data for phase mod(mode,100) - iph=mod(mode,100) - if(iph.eq.0) then - write(*,*)'all phases' - else - write(*,*)'phase ',iph - endif - end select -1000 continue - return - end subroutine list_equilibria_details - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - +! +! gtp3C included in gtp3.F90 +! +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ +!> 7. List data +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine list_all_elements(unit) +! lists elements + implicit none + integer unit +!\end{verbatim} %+ + integer jl,ipos + character line*80 + line=' ' + write(unit,10) +10 format(/'List of elements'/ & + ' No Sym Name',10X,'Reference state',12X,& + 'Mass H298-H0 S298 Status') + loop1: do jl=-1,noofel + ipos=1 + call list_element_data(line,ipos,elements(jl)) + if(gx%bmperr.ne.0) goto 1000 + write(unit,100)jl,line(1:ipos) + enddo loop1 +100 format(i3,2x,A) +1000 continue + return + end subroutine list_all_elements + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine list_all_elements2(unit) +! lists elements + implicit none + integer unit +!\end{verbatim} + integer jl + character line*80 + line=' ' + loop1: do jl=-1,noofel + write(unit,100) ellista(jl)%symbol,ellista(jl)%ref_state,& + ellista(jl)%mass,ellista(jl)%h298_h0,ellista(jl)%s298 + enddo loop1 +100 format('ELEMENT ',A,' ',A,3(1pe12.4),' !') +1000 continue + return + END subroutine list_all_elements2 + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine list_all_components(unit,ceq) +! lists the components for an equilibrium + implicit none + integer unit + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer jl,loksp + character symbol*24 + double precision moles,masspercent,chempot + moles=zero + masspercent=zero + chempot=zero + write(unit,10) +10 format('List of components'/ & + 'No Symbol',19X,'Moles',6x,'Mass %',5x,'Chem pot',3x,'Ref. state') + loop1: do jl=1,noofel + loksp=ceq%complist(jl)%splink + symbol=splista(loksp)%symbol + write(unit,100)jl,symbol,moles,masspercent,chempot,& + ceq%complist(jl)%refstate + enddo loop1 +100 format(i2,1x,A,3(1PE11.3),1X,A) +1000 continue + return + end subroutine list_all_components + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine list_element_data(text,ipos,elno) + implicit none + character text*(*) + integer ipos,elno +!\end{verbatim} + if(elno.lt.-1 .or. elno.gt.noofel) then + gx%bmperr=4042 + goto 1000 + endif + if(ipos.lt.1 .or. ipos.ge.len(text)) then + gx%bmperr=4043 + goto 1000 + endif + text(ipos:ipos+2)=ellista(elno)%symbol + text(ipos+3:ipos+16)=ellista(elno)%name + text(ipos+17:ipos+40)=ellista(elno)%ref_state + write(text(ipos+41:ipos+73),100)ellista(elno)%mass,& + ellista(elno)%h298_h0,ellista(elno)%s298,ellista(elno)%status +100 format(1x,f7.3,1x,f7.2,1x,f7.3,1x,z8) + ipos=len_trim(text) +! write(*,*)'x:',text(1:79) +1000 continue + return + END subroutine list_element_data + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine list_species_data(text,ipos,spno) + implicit none + character text*(*) + integer ipos,spno +!\end{verbatim} %+ + character dummy*48 + integer jpos + if(spno.lt.1 .or. spno.gt.noofsp) then +! write(*,*)'in list_species_data' + gx%bmperr=4051 + goto 1000 + endif + if(ipos.lt.1 .or. ipos.ge.len(text)) then + gx%bmperr=4043 + goto 1000 + endif + text(ipos:ipos+24)=splista(spno)%symbol + text(ipos+25:ipos+25)=' ' + dummy=' ' + call encode_stoik(dummy,jpos,spno) + text(ipos+26:ipos+48)=dummy(1:min(23,jpos)) + if(jpos.gt.23) text(ipos+46:ipos+48)='<.>' + text(ipos+49:ipos+49)=' ' + write(text(ipos+50:ipos+59),100)splista(spno)%mass + write(text(ipos+60:ipos+65),105)splista(spno)%charge +100 format(F10.3) +105 format(F6.1) + text(ipos+66:)=' ' +! write(*,120)splista(spno)%status + write(text(ipos+66:ipos+73),120)splista(spno)%status +120 format(Z8) + ipos=ipos+73 +1000 continue + return + END subroutine list_species_data + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine list_species_data2(text,ipos,loksp) +! loksp is species record ... + implicit none + character text*(*) + integer ipos,loksp +!\end{verbatim} + character dummy*24 + integer jpos + if(loksp.lt.1 .or. loksp.gt.noofsp) then +! write(*,*)'in list_species_data' + gx%bmperr=4051 + goto 1000 + endif + if(ipos.lt.1 .or. ipos.ge.len(text)) then + gx%bmperr=4043 + goto 1000 + endif + text(ipos:ipos+24)=splista(loksp)%symbol + text(ipos+25:ipos+25)=' ' + dummy=' ' + call encode_stoik(dummy,jpos,loksp) + text(ipos+26:ipos+48)=dummy(1:jpos) +! text(ipos+49:ipos+49)=' ' +! write(text(ipos+50:ipos+59),100)splista(loksp)%mass +! write(text(ipos+60:ipos+65),105)splista(loksp)%charge +100 format(F10.3) +105 format(F6.1) +! text(ipos+66:)=' ' +! write(*,120)splista(loksp)%status +! write(text(ipos+66:ipos+73),120)splista(loksp)%status +120 format(Z8) +! ipos=ipos+73 +1000 continue + return + END subroutine list_species_data2 + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine list_all_species(unit) + implicit none + integer unit +!\end{verbatim} + integer jl,ipos + character line*80 + write(unit,10) +10 format(/'List of species'/ & + ' No Symbol',20X,'Stoichiometry',12X,'Mass Charge Status') + loop1: do jl=1,noofsp + ipos=1 + call list_species_data(line,ipos,species(jl)) + if(gx%bmperr.ne.0) goto 1000 + write(unit,100)jl,line(1:ipos) + enddo loop1 +100 format(i4,1x,A) +1000 continue + return + END subroutine list_all_species + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine list_sorted_phases(unit,ceq) +! short list with one line for each phase +! suspended phases merged into one line +! stable first, then entered ordered in driving force order, then dormat +! also in driving force order. Only 10 of each, the others lumped together + implicit none + integer unit + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer jl,jk,ics,lokph,lokcs,kp,ndorm,nsusp,nent,nstab,iph,jph + character line*80,phname*24,trailer*28,chs*1,csname*36,susph*4096,ch1*1 + integer, dimension(:), allocatable :: entph,dorph + TYPE(gtp_phase_varres), pointer :: csrec +! + allocate(entph(nooftuples)) + allocate(dorph(nooftuples)) + nstab=0; nent=0; ndorm=0; nsusp=1 + susph=' ' + phloop: do jk=1,noofph + lokph=phases(jk) + csloop: do ics=1,phlista(lokph)%noofcs +! write(*,17)'3C sort1: ',nent,(entph(iph),iph=1,nent) +17 format(a,i3,2x,20i4) + lokcs=phlista(lokph)%linktocs(ics) + csrec=>ceq%phase_varres(lokcs) + if(csrec%phstate.ge.PHENTSTAB) then + if(nent.eq.0) then + nent=1; + entph(nent)=lokcs +! write(*,*)'3C stable phase: ',nent,nent,lokcs + else +! FIX and STABLE phases first in order of amount + do iph=1,nent + if(csrec%amfu.lt.ceq%phase_varres(entph(iph))%amfu) cycle +! this is the place for this phase, shift later down + do jph=nent,iph,-1 + entph(jph+1)=entph(jph) + enddo + exit + enddo +! according to new fortran standard loop variable at exit is high limit+1 +! write(*,18)'3C inserted stable phase ',iph,lokcs,csrec%amfu +18 format(a,2i4,1pe12.4) + entph(iph)=lokcs + nent=nent+1 +! write(*,*)'3C stable phase: ',nent,lokcs + endif + elseif(csrec%phstate.eq.PHENTERED .or. & + csrec%phstate.eq.PHENTUNST) then + if(nent.eq.0) then + nent=1 + entph(nent)=lokcs +! write(*,*)'3C unstable phase: ',nent,nent,lokcs + else +! ENTERED, not stable, sort after all stable phase and with smallest DGM first + do iph=1,nent + if(ceq%phase_varres(entph(iph))%amfu.gt.zero) cycle + if(csrec%dgm.lt.ceq%phase_varres(entph(iph))%dgm) cycle +! this is the place for this phase, shift later phases down + do jph=nent,iph,-1 + entph(jph+1)=entph(jph) + enddo + exit + enddo +! according to new fortran standard loop variable at exit is high limit+1 +! write(*,18)'3C inserted entered phase ',iph,lokcs,csrec%dgm + entph(iph)=lokcs + nent=nent+1 +! write(*,*)'3C unstable phase: ',iph,nent,lokcs + endif + elseif(csrec%phstate.eq.PHDORM) then + if(ndorm.eq.0) then + ndorm=ndorm+1 + dorph(ndorm)=lokcs +! write(*,*)'3C dormant phase: ',ndorm,ndorm,lokcs + else +! DORMANT sort after with smallest (least nagative) DGM first + do iph=1,ndorm + if(csrec%dgm.lt.ceq%phase_varres(dorph(iph))%dgm) cycle +! this is the place for this phase, shift later down + do jph=ndorm,iph,-1 + dorph(jph+1)=dorph(jph) + enddo + exit + enddo +! according to new fortran standard loop variable at exit is high limit+1 + dorph(iph)=lokcs + ndorm=ndorm+1 +! write(*,*)'3C dormant phase: ',iph,ndorm,lokcs + endif + elseif(csrec%phstate.eq.PHSUS) then +! skip composition set number and pre/suffixes at present .... + susph(nsusp:)=phlista(lokph)%name(1:& + len_trim(phlista(lokph)%name))//', ' + nsusp=len_trim(susph)+2 + endif + enddo csloop + enddo phloop +! we have now sorted stable, entered and dormant phases + write(unit,10) +10 format(/'List of stable and entered phases'/ & + ' No tup Name',22x,'Mol.comp. At/F.U. dGm/RT Status1 Status2') +! come back here for dormant phases +200 continue + jph=0 + entlist: do iph=1,nent + trailer=' ' + lokcs=entph(iph) + csrec=>ceq%phase_varres(lokcs) + lokph=csrec%phlink + phname=phlista(lokph)%name +! how do I to know composition set number??? +! Aha!! in phasetuple(phase_varres(lokcs)%phtupx)%compset + if(phlista(lokph)%noofcs.gt.1) then + ics=phasetuple(ceq%phase_varres(lokcs)%phtupx)%compset + chs=char(ichar('0')+ics) + kp=len_trim(csrec%prefix) + if(kp.gt.0) then + csname=csrec%prefix(1:kp)//'_'//phname + else + csname=phname + endif + kp=len_trim(csrec%suffix) + if(kp.gt.0) csname=csname(1:len_trim(csname))//'_'//csrec%suffix(1:kp) + csname=csname(1:len_trim(csname))//'#'//chs//trailer + else + csname=phname + endif +! phase names for composition sets can be larger than 24, remove middle part + jl=len_trim(csname) + if(jl.gt.24) then + csname=csname(1:12)//'..'//csname(jl-9:jl) + endif + write(unit,112)phlista(lokph)%alphaindex,csrec%phtupx,csname, & + csrec%amfu*csrec%abnorm(1),& + csrec%abnorm(1),csrec%dgm,phlista(lokph)%status1,& + ceq%phase_varres(lokcs)%status2,ch1 +112 format(2i4,1x,a24,1PE10.2,1x,0PF8.2,1PE10.2,2(0p,z8),a1) +! write(unit,111)jk,csrec%phtupx,csname, & +! csrec%abnorm(1),csrec%dgm,& +! phlista(lokph)%status1,ceq%phase_varres(lokcs)%status2,ch1 +!111 format(2i4,1x,a24,' 0.0',1x0PF8.2,1PE10.2,2(0p,z8),a1) + if(csrec%dgm.lt.zero) then + jph=jph+1 + if(jph.gt.10) then + write(unit,*)' ... remaining phases further from stability' + exit entlist + endif + endif + enddo entlist +! + if(ndorm.eq.0) goto 400 + write(unit,210) +210 format(/'List of dormant phases'/ & + ' No tup Name',22x,'Mol.comp. At/F.U. dGm/RT Status1 Status2') + jph=0 + dorlist: do iph=1,ndorm + trailer=' ' + lokcs=dorph(iph) + csrec=>ceq%phase_varres(lokcs) + lokph=csrec%phlink + phname=phlista(lokph)%name +! how do I to know composition set number??? +! Aha!! in phasetuple(phase_varres(lokcs)%phtupx)%compset + if(phlista(lokph)%noofcs.gt.1) then + ics=phasetuple(ceq%phase_varres(lokcs)%phtupx)%compset + chs=char(ichar('0')+ics) + kp=len_trim(csrec%prefix) + if(kp.gt.0) then + csname=csrec%prefix(1:kp)//'_'//phname + else + csname=phname + endif + kp=len_trim(csrec%suffix) + if(kp.gt.0) csname=csname(1:len_trim(csname))//'_'//csrec%suffix(1:kp) + csname=csname(1:len_trim(csname))//'#'//chs//trailer + else + csname=phname + endif +! phase names for composition sets can be larger than 24, remove middle part + jl=len_trim(csname) + if(jl.gt.24) then + csname=csname(1:12)//'..'//csname(jl-9:jl) + endif + write(unit,112)phlista(lokph)%alphaindex,csrec%phtupx,csname, & + csrec%amfu*csrec%abnorm(1),& + csrec%abnorm(1),csrec%dgm,phlista(lokph)%status1,& + ceq%phase_varres(lokcs)%status2,ch1 + jph=jph+1 + if(jph.gt.10) then + write(unit,*)' ... other phases further from stability' + exit dorlist + endif + enddo dorlist +! list suspended phases without composition set numbers +400 continue + if(nsusp.gt.1) then + write(unit,300) +300 format(/'List of suspended phases:') +! First indentation 4, for 2nd and later lines 4 also + call wrice2(unit,2,4,78,1,susph(1:nsusp-3)) + endif +1000 continue + return + end subroutine list_sorted_phases + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine list_all_phases(unit,ceq) +! short list with one line for each phase +! suspended phases merged into one line + implicit none + integer unit + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} +! separate entered/fixed form suspended/dormant + integer jl,jk,ics,lokph,lokcs,kp,ndorm,nsusp + character line*80,phname*24,trailer*28,chs*1,csname*36,susph*4096,ch1*1 +! type(gtp_phasetuple), allocatable :: dormant + TYPE(gtp_phase_varres), pointer :: csrec + susph=' ' + nsusp=1 + write(unit,10) +10 format(/'List of entered phases'/ & + ' No tup Name',22x,'Mol.comp. At/F.U. dGm/RT Status1 Status2') +! ' No tup Name',22x,'Mol.comp. At/F.U. dGm/RT Status1 Status2') + jl=0 + trailer=' ' +! write(*,*)'In list_all_phases',noofph +! allocate(dormant(noofph)) +! dormant=0 + ndorm=0 +! come back here for listing dormant phases +20 continue +! + phloop: do jk=1,noofph + line=' ' +! list in alphabetical order except gas and liquid(s) first + lokph=phases(jk) + csloop: do ics=1,phlista(lokph)%noofcs + lokcs=phlista(lokph)%linktocs(ics) + csrec=>ceq%phase_varres(lokcs) +! write(*,*)'lpd: 69: ',jk,ics,lokph,lokcs + if(ndorm.ge.0) then + if(csrec%phstate.eq.PHDORM) then + ndorm=ndorm+1 + cycle + elseif(csrec%phstate.eq.PHSUS) then +! skip composition set number and pre/suffixes at present .... + susph(nsusp:)=phlista(lokph)%name(1:& + len_trim(phlista(lokph)%name))//', ' + nsusp=len_trim(susph)+2 + cycle + endif + elseif(csrec%phstate.ne.PHDORM) then +! when ndorm<0 skip all ohases that are suspended, entered or fix + cycle + endif + phname=phlista(lokph)%name + jl=jl+1 +! write(*,70)'lpd: 70:',phname,phlista(lokph)%noofcs +!70 format(a,a24,5i6) + if(phlista(lokph)%noofcs.gt.1) then + chs=char(ichar('0')+ics) + kp=len_trim(csrec%prefix) + if(kp.gt.0) then + csname=csrec%prefix(1:kp)//'_'//phname + else + csname=phname + endif + kp=len_trim(csrec%suffix) + if(kp.gt.0) & + csname=csname(1:len_trim(csname))//'_'//csrec%suffix(1:kp) + csname=csname(1:len_trim(csname))//'#'//chs//trailer + else + csname=phname + endif +! phase names for composition sets can be larger than 24, remove middle part + jl=len_trim(csname) + if(jl.gt.24) then + csname=csname(1:12)//'..'//csname(jl-9:jl) + endif + if(ceq%phase_varres(lokcs)%phstate.eq.phfixed) then + ch1='F' + elseif(ceq%phase_varres(lokcs)%phstate.eq.phentstab) then + ch1='S' + elseif(ceq%phase_varres(lokcs)%phstate.eq.phentered) then + ch1='E' + elseif(ceq%phase_varres(lokcs)%phstate.eq.phentunst) then + ch1='U' + elseif(ceq%phase_varres(lokcs)%phstate.eq.phdorm) then + ch1='D' + elseif(ceq%phase_varres(lokcs)%phstate.eq.phsus) then + ch1='X' + else + write(*,*)'3C unknown state: ',ceq%phase_varres(lokcs)%phstate + endif +! + if(csrec%amfu.ne.zero) then + if(csrec%dgm.eq.zero) then +! write(unit,110)jk,ics,csname, & + write(unit,110)jk,csrec%phtupx,csname, & + csrec%amfu*csrec%abnorm(1),& + csrec%abnorm(1),phlista(lokph)%status1,& + ceq%phase_varres(lokcs)%status2,ch1 +110 format(2i4,1x,a24,1PE10.2,1x,0PF8.2,' 0.0',2(0p,z8),a1) +!110 format(2i4,1x,a24,1PE10.2,1x,0PF9.2,' 0.0',2(0p,z8)) + else +! write(unit,112)jk,ics,csname, & + write(unit,112)jk,csrec%phtupx,csname, & + csrec%amfu*csrec%abnorm(1),& + csrec%abnorm(1),csrec%dgm,& + phlista(lokph)%status1,ceq%phase_varres(lokcs)%status2,ch1 +112 format(2i4,1x,a24,1PE10.2,1x,0PF8.2,1PE10.2,2(0p,z8),a1) +!112 format(2i4,1x,a24,1PE10.2,1x,0PF9.2,1PE10.2,2(0p,z8)) + endif + else +! write(unit,111)jk,ics,csname, & + write(unit,111)jk,csrec%phtupx,csname, & + csrec%abnorm(1),csrec%dgm,& + phlista(lokph)%status1,ceq%phase_varres(lokcs)%status2,ch1 +111 format(2i4,1x,a24,' 0.0',1x0PF8.2,1PE10.2,2(0p,z8),a1) +!111 format(2i4,1x,a24,' 0.0',1x0PF9.2,1PE10.2,2(0p,z8)) + endif + enddo csloop + enddo phloop + if(ndorm.gt.0) then + write(unit,200) +200 format(/'List of dormant phases'/ & + ' No tup Name',22x,'Mol.comp. At/F.U. dGm/RT Status1 Status2') + ndorm=-1 + goto 20 + endif +! list suspended phases without composition set numbers + if(nsusp.gt.1) then + write(unit,300) +300 format(/'List of suspended phases:') +! First indentation 4, for 2nd and later lines 4 also + call wrice2(unit,2,4,78,1,susph(1:nsusp-3)) + endif +1000 continue +! temporary list all phase tuples +! do jl=1,nooftuples +! lokph=phases(phasetuple(jl)%phase) +! lokcs=phlista(lokph)%linktocs(phasetuple(jl)%compset) +! write(*,600)jl,phasetuple(jl)%phase,phasetuple(jl)%compset,lokcs,& +! firsteq%phase_varres(lokcs)%phtupx +!600 format('Phase tuple: ',3i4,' backlink: ',5i4) +! enddo + return + END subroutine list_all_phases + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine list_global_results(lut,ceq) +! list G, T, P, V and some other things + implicit none + integer lut + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + character encoded*64 + double precision x1,x2,x3,xn,rtn +! +! write(kou,*)'gtp3C: output unit: ',lut + call get_state_var_value('T ',x1,encoded,ceq) + call get_state_var_value('P ',x2,encoded,ceq) +! We must use VS to get SER reference + call get_state_var_value('VS ',x3,encoded,ceq) +! this will write error message if any and reset the code + if(.not.gtp_error_message(0)) then +! no error, list the data + write(lut,10)x1,x1-273.15,x2,x3 +10 format('T= ',F9.2,' K (',F9.2,' C), P= ',1pe11.4,& + ' Pa, V= ',1pe11.4,' m3') + rtn=globaldata%rgas*x1 + endif +! problem with N, should not take into account the atoms/formula units? + call get_state_var_value('N ',xn,encoded,ceq) + call get_state_var_value('B ',x2,encoded,ceq) + if(.not.gtp_error_message(0)) then + write(lut,11)xn,x2,rtn +11 format('N= ',1pe12.4,' moles, B= ',1pe12.4,' g, RT= ',1pe12.4,' J/mol') + endif +! we must use suffix S to have values referred to SER + call get_state_var_value('GS ',x1,encoded,ceq) + call get_state_var_value('HS ',x2,encoded,ceq) + call get_state_var_value('SS ',x3,encoded,ceq) + if(.not.gtp_error_message(0)) then + write(lut,12)x1,x1/xn,x2,x3 +12 format('G= ',1pe11.4,' J, G/N= ',1pe11.4,' J/mol, H= ',1pe11.4,& + ' J, S= ',1pe11.4,' J/K') + endif +1000 continue + return + end subroutine list_global_results + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine list_components_result(lut,mode,ceq) +! list one line per component (name, moles, x/w-frac, chem.pot. reference state +! mode 1=mole fractions, 2=mass fractions + implicit none + integer lut,mode + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + character svtext*64,encoded*64,name*24 + integer ie,kl + double precision x1,x2,x3,x4,rtn + if(mode.eq.1) then + write(lut,7) +!7 format('Component name',11x,'Moles',7x,'Mole-fracs Chem.potent. ',& +7 format('Component name',4x,'Moles',6x,'Mole-fr Chem.pot/RT ',& + 'Activities Ref.state') + elseif(mode.eq.2) then + write(lut,9) +9 format('Component name',4x,'Moles',6x,'Mass-fr Chem.pot/RT ',& + 'Activities Ref.state') + endif + call get_state_var_value('T ',x1,encoded,ceq) + rtn=globaldata%rgas*x1 + do ie=1,noofel + call get_component_name(ie,name,ceq) + kl=len_trim(name) + svtext='N('//name(1:kl)//') ' +! write(*,*)'state variable :',svtext + call get_state_var_value(svtext,x1,encoded,ceq) + if(gx%bmperr.ne.0) goto 1000 +! + if(mode.eq.1) then + svtext='X('//name(1:kl)//') ' + elseif(mode.eq.2) then + svtext='W('//name(1:kl)//') ' + endif + call get_state_var_value(svtext,x2,encoded,ceq) + if(gx%bmperr.ne.0) goto 1000 +! This should be read from component record .... ???? YES + svtext='MU('//name(1:kl)//') ' +! write(*,*)'state variable :',svtext + call get_state_var_value(svtext,x3,encoded,ceq) +! divide mu with RT + x3=x3/rtn + x4=exp(x3) + if(gx%bmperr.ne.0) then + write(*,*)'3C Error: ',gx%bmperr + gx%bmperr=0; x3=1.0D36 + endif +! reference state, by default "SER (default)" take from component record +! if(ceq%complist(ie)%phlink.gt.0) then + encoded=ceq%complist(ie)%refstate +! else +! default name of reference state +! encoded='SER (default)' +! endif + write(lut,10)name(1:16),x1,x2,x3,x4,encoded(1:16) +!10 format(a,3(1pe12.4),2x,a) +10 format(a,1pe12.4,0pf9.5,2(1pe12.4),2x,a) + enddo +1000 continue + return + end subroutine list_components_result + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine list_phases_with_positive_dgm(mode,lut,ceq) +! list one line for each phase+comp.set with positive dgm on device lut +! The phases must be dormant or the result is in error. mode is not used + implicit none + integer mode,lut + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + character name*24 +! character*10, dimension(-3:2) :: status=& +! ['SuspendedEntered ','Fix ','Dormant ','Suspended '] + integer once,iph,lokph,ics,lokcs,kkz,jd + integer, dimension(:), allocatable :: phtupx + integer, dimension(:), allocatable :: isort + double precision xxx +! write(*,*)'In list_phases_with_positive_dgm' + once=0 + do iph=1,noofph + lokph=phases(iph) + csloop: do ics=1,phlista(lokph)%noofcs + lokcs=phlista(lokph)%linktocs(ics) + if(ceq%phase_varres(lokcs)%phstate.lt.PHDORM) cycle csloop +! if(abs(ceq%phase_varres(lokcs)%netcharge).gt.1.0d-6) then +! write(*,*)'ignoring phase with net charge: ',iph,ics +! cycle csloop +! endif + if(ceq%phase_varres(lokcs)%dgm.gt.1.0D-3) then + if(once.eq.0) then + allocate(phtupx(nooftuples)) + endif + once=once+1 + if(once.eq.1) write(lut,109) +109 format(/' *** Phases which would like to be stable') + phtupx(once)=ceq%phase_varres(lokcs)%phtupx + write(*,98)once,phtupx(once),phasetuple(phtupx(once))%phase,iph,& + lokcs,ceq%phase_varres(lokcs)%dgm,& + ceq%phase_varres(lokcs)%netcharge +98 format('3C dgm: ',5i4,2(1pe12.4)) + endif + enddo csloop + enddo + goto 1000 + if(once.gt.0) then + write(lut,110)once +110 format(/' *** ',i3,' Phases which would like to be stable in order') + allocate(isort(once)) +! call sortrdd(pdgm,once,isort) +! if(buperr.ne.0) then +! write(*,*)'Error sorting fractions',buperr +! goto 1000 +! endif + do jd=1,once +! add next line when we have sorted +! isort(jd)=jd + isort(jd)=phtupx(jd) +! This is getting messy again, the phase tuple index is at present +! the index to phase_varres +1 (as index 1 is the stable reference phase) + iph=phasetuple(phtupx(isort(jd)))%phase + ics=phasetuple(phtupx(isort(jd)))%compset + call get_phase_compset(iph,ics,lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 + write(*,117)jd,isort(jd),iph,ics,lokcs,phtupx(isort(jd)),& + ceq%phase_varres(lokcs)%dgm +117 format('3C Phase: ',2i3,2i5,2i7,1pe10.2) +! call get_phasetup_name(phasetuple(isort(jd)),name) +! kkz=test_phase_status(iph,ics,xxx,ceq) +! write(*,*)'3C: error: ',name,lokcs,kkz +! old kkz.le.2 means entered or fixed +! if(kkz.le.3) then +! now: kkz= -3, -2, -1, 0, 1, 2 +! means SUSPEND, DORMANT, ENTENTED/UNST, ENTERED, ENTERD/STABLE, FIXED + kkz=ceq%phase_varres(lokcs+1)%phstate +! if(kkz.ge.PHDORM) then +! write(lut,120)name,phstate(kkz),ceq%phase_varres(lokcs+1)%dgm +120 format('Phase: ',a,' Status: ',a,' Driving force:',1pe12.4) +! endif + enddo + endif +1000 continue + return + end subroutine list_phases_with_positive_dgm + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine list_phase_results(iph,jcs,mode,lut,ceq) +! list results for a phase+comp.set on lut +! mode specifies the type and amount of results, +! unit digit: 0=mole fraction, othewise mass fractions +! 10th digit: 0=only composition, 10=also constitution +! 100th digit: 0=value order, 100=alphabetical order +! 1000th digit: 0=only stable phases, 1000=all phases + implicit none + integer iph,jcs,mode,lut + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + character text*256,phname*24,status*10 + character (len=24), dimension(:), allocatable :: consts +! character*24, allocatable (:) :: consts + double precision xmol(maxel),wmass(maxel),totmol,totmass,amount,abv,mindgm + double precision, dimension(:), allocatable :: ymol + integer lokph,lokcs,kode,nz,jl,nk,ll,ip,kstat + mindgm=1.0D-10 + if(ocv()) write(*,*)'mode: ',mode + if(iph.lt.1 .or. iph.gt.noofph) then +! write(*,*)'lpr ',iph,jcs,mode + gx%bmperr=4050; goto 1000 + endif + lokph=phases(iph) + if(btest(phlista(lokph)%status1,phhid)) then +! phase is hidden + gx%bmperr=4119; goto 1000 + endif +! +! .gt.9 +! + if(jcs.lt.0 .or. jcs.gt.phlista(lokph)%noofcs) then + gx%bmperr=4072; goto 1000 + elseif(jcs.eq.0) then + jcs=1 + endif + lokcs=phlista(lokph)%linktocs(jcs) +! write(*,*)'lpr 2: ',jcs,phlista(lokph)%noofcs,lokcs +! get name with pre- and suffix + call get_phase_name(iph,jcs,phname) + if(gx%bmperr.ne.0) goto 1000 +! write(*,11)'Phase name: ',iph,jcs,phname +!11 format(a,2i3,'"',a,'"') + if(mode.ge.1000) then +! if mode>=1000 list stable phases only (dgm<0 ) +! if(ceq%phase_varres(lokcs)%amount(1).eq.zero) then + if(abs(ceq%phase_varres(lokcs)%netcharge).gt.1.0d-6) then + if(ceq%phase_varres(lokcs)%phstate.gt.phentered) then + write(lut,18)phname(1:len_trim(phname)),& + ceq%phase_varres(lokcs)%netcharge +18 format('Phase: ',a,' has stable status with net charge: ',F6.3) + goto 1000 + endif + endif + if(ceq%phase_varres(lokcs)%amfu.eq.zero) then +! skip phases with zero amount unless expcitly stable or positive dgm + if(ceq%phase_varres(lokcs)%dgm.eq.zero) then +! if(ceq%phase_varres(lokcs)%phstate.ne.PHFIXED) goto 1000 + if(ceq%phase_varres(lokcs)%phstate.lt.PHENTSTAB) goto 1000 + elseif(ceq%phase_varres(lokcs)%dgm.lt.mindgm) then + goto 1000 + endif + endif + endif +! phase status (except hidden) .... use get_phase_status instead ??? +! if(btest(ceq%phase_varres(lokcs)%status2,cssus)) then +! if(btest(ceq%phase_varres(lokcs)%status2,csfixdorm)) then + if(ceq%phase_varres(lokcs)%phstate.eq.PHDORM) then + status='Dormant' + kstat=4 +! skip dormant phases unless positive driving force +! if(ceq%phase_varres(lokcs)%dgm.le.mindgm) goto 1000 + elseif(ceq%phase_varres(lokcs)%phstate.eq.PHSUS) then +! skip suspended phases + status='Suspended' + goto 1000 +! if(btest(ceq%phase_varres(lokcs)%status2,csfixdorm)) then + elseif(ceq%phase_varres(lokcs)%phstate.eq.PHFIXED) then + status='Fixed' + kstat=2 + else + status='Entered' + kstat=1 +! skip phase with net charge +! if(abs(ceq%phase_varres(lokcs)%netcharge).gt.1.0D-6) goto 1000 +! skip entered phases that have positive driving force, why?? +! if(ceq%phase_varres(lokcs)%dgm.gt.zero) goto 1000 + endif + if(phname(1:1).lt.'A' .or. phname(1:1).gt.'Z') then +! in some cases unprintable phase names appears!! + write(lut,19)iph,jcs,lokph,lokcs +19 format('Illegal phase name: ',10i5) + endif + write(lut,20)phname,status,ceq%phase_varres(lokcs)%dgm +20 format(/'Phase: ',A,' Status: 'A,' Driving force: ',1PE12.4) +!------------------------ +! xmol=zero +! wmass=zero + call calc_phase_molmass(iph,jcs,xmol,wmass,totmol,totmass,amount,ceq) + if(gx%bmperr.ne.0) then + write(*,*)'Error: ',gx%bmperr; goto 1000 + endif +! write(*,99)'xmol: ',xmol +!99 format(a,6(1pe12.4)) + kode=mod(mode,10) +! write(*,*)'lpr: ',mode,kode + abv=ceq%phase_varres(lokcs)%abnorm(1) + if(kode.eq.0) then +! The volume value here is WRONG: ceq%phase_varres(lokcs)%gval(3,1) !!! ??? + if(abs(ceq%phase_varres(lokcs)%netcharge).gt.1.0D-6) then + write(lut,28)totmol,totmass*0.001, & + amount*ceq%rtn*ceq%phase_varres(lokcs)%gval(3,1),& + ceq%phase_varres(lokcs)%netcharge + else + write(lut,25)totmol,totmass*0.001, & + amount*ceq%rtn*ceq%phase_varres(lokcs)%gval(3,1) + endif + write(lut,21)ceq%phase_varres(lokcs)%amfu,abv +21 format('Formula Units: ',1pe12.4,', Moles of atoms/FU: ',1pe12.4,& + ', Molar content:') + else + write(lut,25)totmol,totmass*0.001,& + amount*ceq%rtn*ceq%phase_varres(lokcs)%gval(3,1) + write(lut,22)ceq%phase_varres(lokcs)%amfu,abv +22 format('Formula Units: ',1pe12.4,', Moles of atoms/FU: ',1pe12.4,& + ', Mass fractions:') + endif +25 format('Moles',1PE12.4,', Mass',1PE12.4,' kg, Volume',1PE12.4,' m3') +28 format('Moles',1PE11.3,' Mass',1PE11.3,' kg, Volume',1PE11.3,' m3,',& + ' Charge: ',1pe11.3) +! composition + nz=noofel + allocate(consts(nz)) + consts=' ' + do jl=1,nz + consts(jl)=splista(ceq%complist(jl)%splink)%symbol + enddo +! write(*,187)'lpr: ',consts +!187 format(a,20(1x,a2)) + if(kode.eq.0) then + call format_phase_composition(mode,nz,consts,xmol,lut) + else + call format_phase_composition(mode,nz,consts,wmass,lut) + endif + deallocate(consts) + if(gx%bmperr.ne.0) goto 1000 +!------------------------------------- +! constitution only if nonzero tenth-digit of mode or if GAS +300 continue + if(.not.btest(phlista(lokph)%status1,PHGAS)) then + if(mod(mode/10,10).le.0) goto 1000 + endif + write(lut,310) +310 format('Constitution: ') +!--------------- + nk=0 + sublatloop: do ll=1,phlista(lokph)%noofsubl + nz=phlista(lokph)%nooffr(ll) + if(phlista(lokph)%noofsubl.gt.1) then +! write(lut,320)ll,nz,phlista(lokph)%sites(ll) + write(lut,320)ll,nz,ceq%phase_varres(lokcs)%sites(ll) +320 format('Sublattice ',i2,' with ',i5,' constituents and ',& + F12.6,' sites') +! elseif(phlista(lokph)%sites(ll).eq.one) then + elseif(ceq%phase_varres(lokcs)%sites(ll).eq.one) then + write(lut,321)nz +321 format('There are ',i5,' constituents:') + else +! write(lut,322)nz,phlista(lokph)%sites(ll) + write(lut,322)nz,ceq%phase_varres(lokcs)%sites(ll) +322 format('Single lattice with ',i5,' constituents and ',& + F12.6,' sites') + endif + text=' '; ip=1 + allocate(consts(nz)) + allocate(ymol(nz)) + consts=' ' + do jl=1,nz +! jcons=splista(phlista(lokph)%constitlist(nk+jl))%alphaindex + consts(jl)=' ' + if(phlista(lokph)%constitlist(nk+jl).gt.0) then + consts(jl)=splista(phlista(lokph)%constitlist(nk+jl))%symbol + else + consts(jl)='*' + endif + ymol(jl)=ceq%phase_varres(lokcs)%yfr(nk+jl) + enddo + call format_phase_composition(mode,nz,consts,ymol,lut) + deallocate(consts) + deallocate(ymol) + if(gx%bmperr.ne.0) goto 1000 + nk=nk+nz + enddo sublatloop +1000 continue + return + end subroutine list_phase_results + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine format_phase_composition(mode,nv,consts,vals,lut) +! list composition/constitution in alphabetical or value order +! entalsiffra 0 mole fraction, 1 mass fraction, 3 mole percent, 4 mass percent +! tiotalsiffra ? +! mode >100 else alphanetical order +! nv is number of components/constitunents (in alphabetical order in consts) +! components/constituents in consts, fractions in vals + implicit none + integer nv,mode,lut + character consts(nv)*(*) + double precision vals(nv) +!\end{verbatim} + integer maxl,jl,kp,ncol,nrow2,nvrest,n1,nempty,n3r,n4r + character names(4)*12 + integer, dimension(:), allocatable :: isort +! 3-13 position name, 12 positions value (1pe12.5), 2 positions separator +! NOTE components can have negative fractions but not constituents +! so leave one blank after component names +! Constituents with names longer than 13 will be written A23456..12345 +! with 6 initial characters, two dots and then the 5 last characters +! Max 4 columns with 18 positions(=72) plus 3*2=6 position separator, +! min 3 columns with 24 positions(=72) plus 2*2=4 position separator +! +! max length of names and number of columns + maxl=0 + do jl=1,nv + kp=len_trim(consts(jl)) + if(kp.gt.maxl) then + maxl=kp + endif + enddo + if(maxl.le.4) then +! use 4 columns if names are short + ncol=4 + else + ncol=3 + endif +! number of rows is needed to have valuses in columns decending like: +! FE 0.75 SI 0.05 Ti 0.02 C 0.01 +! CR 0.20 Mn 0.04 V 0.01 +!----------------------------------- + nrow2=(nv+ncol-1)/ncol +! always use isort for the order, if alphabetical isort(i)=i + allocate(isort(nv+4)) + if(mode.ge.100) then +! value order if mode >100, sort vals and use isort to find component name + call sortrdd(vals,nv,isort) + if(buperr.ne.0) then + write(*,*)'Error sorting fractions',buperr + gx%bmperr=buperr; goto 1000 + endif + else +! if alphabetical order just set isort(i)=i, same index as for vals + do jl=1,nv + isort(jl)=jl + enddo + endif +! list constituents in the order of isort + if(ncol.eq.4) then +! All names max 4 characters, 4 columns: 1 + 4+1+13+2 +20 +20 +18 = 79 + nvrest=nv + n1=1 +! number of empty colums in last row is 4*nrow2-nv + nempty=4*nrow2-nv +! 3rd and 4th column may start from one or two indices less + n3r=2*nrow2 + n4r=3*nrow2 + if(nempty.eq.3) then + n3r=n3r-1 + n4r=n4r-2 + elseif(nempty.eq.2) then + n4r=n4r-1 + endif +100 continue +! this can be quite complicated as last row may be partially empty as + if(nvrest.ge.4) then + names(1)=consts(isort(n1)) + names(2)=consts(isort(n1+nrow2)) + names(3)=consts(isort(n1+n3r)) +! 4th column may be empty after first row + if(n1+n4r.le.nv) then + names(4)=consts(isort(n1+n4r)) + write(lut,110)names(1)(1:4),vals(n1),& + names(2)(1:4),vals(n1+nrow2),names(3)(1:4),vals(n1+n3r),& + names(4)(1:4),vals(n1+n4r) +110 format(1x,a,1x,1pe13.5,3(2x,a,1x,1pe13.5)) + nvrest=nvrest-4 + else + write(lut,110)names(1)(1:4),vals(n1),& + names(2)(1:4),vals(n1+nrow2),names(3)(1:4),vals(n1+n3r) + nvrest=nvrest-3 + endif + n1=n1+1 + else +! last row can be 1 to 3 columns + names(1)=consts(isort(n1)) + if(nvrest.gt.1) then + names(2)=consts(isort(n1+nrow2)) + if(nvrest.gt.2) then + names(3)=consts(isort(n1+n3r)) + write(lut,110)names(1)(1:4),vals(n1),& + names(2)(1:4),vals(n1+nrow2),names(3)(1:4),vals(n1+n3r) + else + write(lut,110)names(1)(1:4),vals(n1),& + names(2)(1:4),vals(n1+nrow2) + endif + else + write(lut,110)names(1)(1:4),vals(n1) + endif + nvrest=0 + endif + if(nvrest.gt.0) goto 100 + else +! All listed names have max 13 characters, longer names are truncated + nvrest=nv + n1=1 +! number of empty columns in last row + nempty=3*nrow2-nv +! 3rd column may start from an indices less + n3r=2*nrow2 + if(nempty.eq.2) then + n3r=n3r-1 + endif +200 continue + if(nvrest.ge.3) then + names(1)=consts(isort(n1)) + names(2)=consts(isort(n1+nrow2)) + if(n1+2*nrow2.le.nv) then + names(3)=consts(isort(n1+n3r)) + write(lut,210)names(1),vals(n1),names(2),vals(n1+nrow2),& + names(3),vals(n1+n3r) +210 format(1x,a,1pe12.5,2(2x,a,1pe12.5)) + nvrest=nvrest-3 + else + write(lut,210)names(1),vals(n1),names(2),vals(n1+nrow2) + nvrest=nvrest-2 + endif + n1=n1+1 + else +! last row can be 1 or 2 columns + names(1)=consts(isort(n1)) + if(nvrest.gt.1) then + names(2)=consts(isort(n1+nrow2)) + write(lut,210)names(1),vals(n1),names(2),vals(n1+nrow2) + else + write(lut,210)names(1),vals(n1) + endif + nvrest=0 + endif + if(nvrest.gt.0) goto 200 + endif +! +1000 continue + return + end subroutine format_phase_composition + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine list_many_formats(cline,last,ftyp,unit1) +! lists all data in different formats: SCREEN/TDB/MACRO/LaTeX/ODB +! 1 2 3 4 5 +! unfinished + implicit none + character cline*(*) + integer last,unit1,ftyp +!\end{verbatim} + integer iph,ipos,kousave,unit,isp + character text*64, text2*2000,fil*64 + character date*8,ch1*1 +! if not screen then ask for file name +! for screen outpot of file use /option= ... + if(ftyp.ne.1) then + call gparcd('Output file: ',cline,last,1,fil,'database',q1help) + ipos=len_trim(fil) +! it is impossible to have a blank name here, check if there is an extension + iph=index(fil,'.') + if(iph.gt.0) then +! do not allow empty extensions + if(fil(iph+1:iph+1).ne.' ') ipos=0 + endif + if(ipos.gt.0) then + if(ftyp.eq.2) then +! TDB file a la TC + fil(ipos+1:)='.TDB' + elseif(ftyp.eq.3) then + fil(ipos:)='.OCM' + elseif(ftyp.eq.4) then + fil(ipos:)='.tex' + elseif(ftyp.eq.5) then +! TDB file a la Open Calphad + fil(ipos:)='.ODB' + endif + endif +! check if file exists ... overwriting not allowed ... + open(unit=31,file=fil,access='sequential',status='new',err=900) + kousave=unit + unit=31 + endif + call date_and_time(date) + select case(ftyp) + case default + write(kou,*)'No such format' +!---------------------------------------------------------- +! This can be written to file using the /output option + case(1) ! ftyp=1 SCREEN format + call list_all_elements(kou) + if(gx%bmperr.ne.0) goto 1000 + call list_all_species(kou) + if(gx%bmperr.ne.0) goto 1000 + call list_all_funs(kou) + if(gx%bmperr.ne.0) goto 1000 + do iph=1,noph() + call list_phase_data(iph,kou) + if(gx%bmperr.ne.0) goto 1000 + enddo +! list reference phase last + iph=0 + call list_phase_data(0,kou) +! finally list the data bibliography + write(kou,*) + call list_bibliography(' ',kou) +!-------------------------------------------------------------- +! write on unit + case(2) ! ftyp=2 TDB format +! ch1 keeps track of type definitions, note: incremented before use + ch1='%' + write(unit,106)date(1:4),date(5:6),date(7:8) +106 format('$ Database file written by Open Calphad ',a,'-',a,'-',a/) + call list_all_elements2(unit) + write(unit,107) +107 format(/'$ =================',/) + text=' ' + sploop: do isp=1, nosp() +! skip vacancy species and species that are elements + iph=species(isp) + ipos=1 + call list_species_data2(text,ipos,iph) +! not very logical, using species index below and location above ... suck + if(testspstat(isp,SPEL) .or. testspstat(isp,SPVA)) then + cycle sploop + endif + write(unit,110)text(1:len_trim(text)) +110 format('SPECIES ',A,' !') + end do sploop + write(unit,107) + text2=' ' +! skip the first two functions which are R and RTLNP (using R) +! write RTLNP in correct TDB form here + text2='FUNCTION RTLNP 10 8.31451*R*LN(1.0D-5*P); 20000 N !' + write(unit,112)text2(1:len_trim(text2)) +112 format(a) +! + tpfuns: do iph=3, notpf()! freetpfun-1 + text2='FUNCTION ' + call list_tpfun(iph,0,text2(10:)) +! skip functions with names staring with _ as they are parameters + if(text2(10:10).eq.'_') cycle tpfuns +! for the remaining functions OC writes them with = T_low ... +! and for TC one must remove the = sign + ipos=index(text2,'=') + text2(ipos:ipos)=' ' +! then add a ! at the end + ipos=len_trim(text2) + text2(ipos+1:)=' !' + call wrice2(unit,0,8,78,1,text2) + end do tpfuns + write(unit,107) + write(unit,130) +130 format(/'TYPE_DEFINITION % SEQ * !'/ & + 'DEFINE_SYSTEM_DEFAULT ELEMENT 2 !'/ & + 'DEFAULT_COMMAND DEF_SYS_ELEMENT VA /- !'/) + write(unit,107) + do iph=1, noph() + call list_phase_data2(iph,ftyp,ch1,unit) + enddo + write(unit,107) + write(unit,140) +140 format(/' LIST_OF_REFERENCES'/ ' NUMBER SOURCE') + call list_bibliography(' ',unit) + write(unit,141) +141 format('!') + close(unit) +!-------------------------------------------------------------- + case(3) ! ftyp=3 MACRO format + write(kou,*)'MACRO not implemented yet' +!-------------------------------------------------------------- + case(4) ! ftyp=4 LATEX format + write(kou,*)'LaTeX not implemented yet' +!-------------------------------------------------------------- + case(5) ! ftyp=5 Open Calphad TDB format + write(kou,*)'ODB not implemented yet' + end select +!-------------------------------------------------------------- + goto 1000 +! error +900 write(kou,*)'File already exist, overwriting not allowed' +! close(31) +1000 continue + unit=kousave + return + end subroutine list_many_formats + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine list_phase_model(iph,ics,lut,ceq) +! list model (no parameters) for a phase on lut + implicit none + integer iph,ics,lut + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + character phname*24,l78*78,ch1*1 +! integer, dimension(maxsubl) :: endm,ilist + integer lokcs,knr,kmr,ll,ip,lokph,ftyp + TYPE(gtp_fraction_set) :: disfra + type(gtp_phase_add), pointer :: addrec + double precision rl +! screen + ftyp=1 +! if ics=0 list fractions for all composition sets + lokph=phases(iph) +! name, model name +! sublattices, status, +! additions +! sites, constituents and fractions in each disordered constituents +! number of disordered sublattices +! sites, constituents and fractions in each disordered constituents + if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then + write(*,*)'No subch composition set' + gx%bmperr=7777; goto 1000 + elseif(ics.eq.0) then + ics=1 + endif + lokcs=phlista(lokph)%linktocs(ics) + call get_phase_name(iph,ics,phname) + write(lut,110)phname,phlista(lokph)%models(1:40),& + phlista(lokph)%noofsubl,phlista(lokph)%status1,& + ceq%phase_varres(lokcs)%status2 +110 format(a,', model: ',a/'Number of sublattices: ',i2,& + ', status: ',z8,1x,z8,5x) + addrec=>phlista(lokph)%additions + lastadd: do while(associated(addrec)) + call list_addition(lut,ch1,phname,ftyp,addrec) + addrec=>addrec%nextadd + enddo lastadd +! return here if more composition sets +200 continue + rl=zero + knr=0 + kmr=0 +! return here for each sublattice + do ll=1,phlista(lokph)%noofsubl + rl=rl+one + kmr=kmr+phlista(lokph)%nooffr(ll) + l78='Subl. '; ip=7 + call wrinum(l78,ip,2,0,rl) + l78(ip:)=', sites: '; ip=ip+9 +! call wrinum(l78,ip,6,0,phlista(lokph)%sites(ll)) + call wrinum(l78,ip,6,0,ceq%phase_varres(lokcs)%sites(ll)) + l78(ip:)=', const.: '; ip=ip+10 +! return here for each new constituent in this sublattice +320 continue + knr=knr+1 + if(phlista(lokph)%constitlist(knr).gt.0) then + l78(ip:)=splista(phlista(lokph)%constitlist(knr))%symbol + else + l78(ip:)='*' + endif + ip=len_trim(l78)+2 + l78(ip-1:ip-1)='=' +! The fractions for normal sublattice done by list result or list phase-const + call wrinum(l78,ip,6,0,ceq%phase_varres(lokcs)%yfr(knr)) + l78(ip:ip+1)=', ' + ip=ip+2 + if(ip.gt.60) then + write(lut,330)l78(1:ip-3) +330 format(a) + l78=' ' + ip=4 + endif + if(knr.lt.kmr) goto 320 + if(ip.gt.4) write(lut,330)l78(1:ip-3) + enddo + if(btest(phlista(lokph)%status1,PHMFS)) then +! the phase has disordered fractions +! ?? does the = here make a copy? I just want a pointer ... + disfra=ceq%phase_varres(lokcs)%disfra + lokcs=disfra%varreslink + if(disfra%ndd.eq.1) then + write(lut,410)disfra%latd +410 format('Disordred fractions adding all fractions from all ',& + i2,' sublattices together') + else + write(lut,420)disfra%latd +420 format('Disordred fractions adding fractions from first ',i2,& + ' sublattices together'/& + ' in the first disordered sublattice',& + ' and the remaining fractions in the second.') + endif +! write the disordered constituents and fractions + ll=0 + rl=zero + knr=0 + kmr=0 +! return here for second sublattice (if any) +430 continue + ll=ll+1 + rl=rl+one + kmr=kmr+disfra%nooffr(ll) + l78='Subl. '; ip=7 + call wrinum(l78,ip,2,0,rl) + l78(ip:)=', sites: '; ip=ip+9 + call wrinum(l78,ip,6,0,disfra%dsites(ll)) + l78(ip:)=', const.: '; ip=ip+10 +! return here for each new constituent in this sublattice +440 continue + knr=knr+1 + l78(ip:)=splista(disfra%splink(knr))%symbol +! list fractions in disordered sublattice as this is the only place for that + ip=len_trim(l78)+2 + l78(ip-1:ip-1)='=' + call wrinum(l78,ip,6,0,ceq%phase_varres(lokcs)%yfr(knr)) + l78(ip:)=',' + ip=ip+2 + if(ip.gt.60) then + write(lut,330)l78(1:ip-3) + l78=' ' + ip=4 + endif + if(knr.lt.kmr) goto 440 + if(ip.gt.4) write(lut,330)l78(1:ip-3) + if(ll.lt.disfra%ndd) goto 430 + endif +1000 continue + return + end subroutine list_phase_model + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine list_phase_data(iph,lut) +! list parameter data for a phase on unit lut + implicit none + integer iph,lut +!\end{verbatim} %+ + integer typty,parlist,typspec,lokph,nsl,nk,ip,ll,jnr,ics,lokcs + integer nint,ideg,ij,kk,iel,ncsum,kkx,kkk,jdeg,iqnext,iqhigh,lqq,nz,ik + integer intpq,linkcon,ftyp + character text*2048,phname*24,prop*32,funexpr*512 + character special*8,ch1*1 + integer, dimension(2,3) :: lint + integer, dimension(maxsubl) :: endm,ilist + logical subref,noelin1 + type(gtp_fraction_set), pointer :: disfrap +! a smart way to have an array of pointers + TYPE intrecarray + type(gtp_interaction), pointer :: p1 + end TYPE intrecarray + type(intrecarray), dimension(20) :: intrecstack + type(gtp_property), pointer :: proprec + type(gtp_interaction), pointer :: intrec + type(gtp_endmember), pointer :: endmemrec + TYPE(gtp_fraction_set) :: disfra + TYPE(gtp_phase_add), pointer :: addrec +! +! output on screen + ftyp=1 + if(iph.lt.0 .or. iph.gt.noofph) then + gx%bmperr=4050; goto 1000 + elseif(noofel.eq.0) then +! this needed as there is a reference phase with iph=0 when there are elements + goto 1000 + endif +! write(*,*)'lpd 1:',iph,phases(iph) + if(iph.gt.0) then + lokph=phases(iph) + else + lokph=0 + endif + ics=1 + phname=phlista(lokph)%name + nsl=phlista(lokph)%noofsubl + special=' ' +! indicate some status bit specially + if(btest(phlista(lokph)%status1,PHFORD)) special(1:1)='F' + if(btest(phlista(lokph)%status1,PHBORD)) special(1:1)='B' + if(btest(phlista(lokph)%status1,PHSORD)) special(1:1)='S' + if(btest(phlista(lokph)%status1,PHIONLIQ)) special(1:1)='I' + if(btest(phlista(lokph)%status1,PHMFS)) special(2:2)='D' +! This subroutine is independent of current equilibrium, use firsteq +! write(lut,10)phname,phlista(lokph)%status1,special,& +! nsl,(phlista(lokph)%sites(ll),ll=1,nsl) + lokcs=phlista(lokph)%linktocs(ics) + write(lut,10)phname,phlista(lokph)%status1,special,& + nsl,(firsteq%phase_varres(lokcs)%sites(ll),ll=1,nsl) +10 format(/'Phase: ',A,', Status: ',Z8,2x,a/' Subl:',I3,10(1x,F7.3)) + nk=0 + text='Constituents: ' + ip=15 + sublatloop: do ll=1,nsl + constloop: do ik=1,phlista(lokph)%nooffr(ll) + nk=nk+1 + jnr=phlista(lokph)%constitlist(nk) + if(jnr.gt.0) then + text(ip:)=splista(jnr)%symbol + else + text(ip:)='*' + endif + ip=len_trim(text)+1 +! text(ip:ip)=',' + text(ip:ip)=' ' + ip=ip+1 + enddo constloop + text(ip-1:ip)=': ' + ip=ip+1 + enddo sublatloop + call wrice2(lut,2,4,78,-1,text) +! write(lut,17)text(1:ip) +!17 format(A) +! additions + addrec=>phlista(lokph)%additions + lastadd: do while(associated(addrec)) + call list_addition(lut,ch1,phname,ftyp,addrec) + addrec=>addrec%nextadd + enddo lastadd +60 continue +! parameters for end members using site fractions + if(btest(phlista(lokph)%status1,PHMFS)) then + subref=.FALSE. + else + subref=.TRUE. + endif + parlist=1 +!-------------------------------------------------- +! return here to list disordered parameters +100 continue +! parlist changed below for disordered fraction set + if(parlist.eq.1) then + endmemrec=>phlista(lokph)%ordered + else + if(ocv()) write(*,*)'Listing disordred parameters ',nsl + endmemrec=>phlista(lokph)%disordered + disfrap=>firsteq%phase_varres(lokcs)%disfra + endif + endmemberlist: do while(associated(endmemrec)) + do ll=1,nsl +! ilist(ll)=emlista(lokem)%fraclinks(ll,1) + ilist(ll)=endmemrec%fraclinks(ll,1) + if(ilist(ll).gt.0) then + if(parlist.eq.2) then +! what is disfra here??!! + endm(ll)=disfra%splink(ilist(ll)) + else + endm(ll)=phlista(lokph)%constitlist(ilist(ll)) + endif + else +! wildcard, write '*' + endm(ll)=-99 + endif + enddo + nint=0 + ideg=0 + call encode_constarr(text,nsl,endm,nint,lint,ideg) + if(gx%bmperr.ne.0) goto 1000 + proprec=>endmemrec%propointer + ptyloop: do while(associated(proprec)) + ij=proprec%proptype + if(ij.ge.100) then + typty=ij/100 + typspec=mod(ij,100) + else + typty=ij + endif + if(typty.gt.0 .and. typty.le.ndefprop) then + prop=propid(typty)%symbol + if(parlist.eq.2) then +! disordered endmember parameter + kk=len_trim(prop)+1 + prop(kk:kk)='D' + endif + if(btest(propid(typty)%status,IDELSUFFIX)) then +! property like ZZ&(phase,constituent array) +! the element index should be in typsepc + iel=typspec + if(iel.ge.0 .and. iel.le.noofel) then +! prop=propid(typty)%symbol + prop=prop(1:len_trim(prop))//'&'& + //ellista(elements(iel))%symbol + else + gx%bmperr=4082; goto 1000 + endif + elseif(btest(propid(typty)%status,IDCONSUFFIX)) then +! property like mobility, MQ&(phase,constituent array) +! the suffix is a constituent + iel=typspec + if(iel.gt.0 .and. iel.le.phlista(lokph)%tnooffr) then + if(parlist.eq.2) then +! we must consider parlist, take disordered constituent list +! we have no current equilibrium record but can use firsteq!! +! lokcs=phlista(lokph)%linktocs(1) +! write(*,*)'3C: endmember typspec 1: ',iel + linkcon=disfrap%splink(iel) +! write(*,*)'3C: endmember typspec 2: ',linkcon + ll=1 + if(linkcon.gt.disfrap%nooffr(1)) ll=2 + prop=prop(1:len_trim(prop))//'&'& + //splista(linkcon)%symbol + goto 120 + else + linkcon=phlista(lokph)%constitlist(iel) + if(linkcon.le.0) then + write(*,*)'Illegal use of wildcard 1' + gx%bmperr=7777; goto 1000 + endif + prop=prop(1:len_trim(prop))//'&'& + //splista(linkcon)%symbol +! also add the sublattice number ... + ncsum=0 + do ll=1,phlista(lokph)%noofsubl + ncsum=ncsum+phlista(lokph)%nooffr(ll) + if(iel.le.ncsum) goto 120 + enddo + endif +! error if sublattice not found + write(kou,*)'Error in constituent depended parameter id' + gx%bmperr=7777; goto 1000 +! jump here to append sublattice +120 continue +! write(*,*)'property 1: ',prop(1:10),ll + prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0')) + else + write(kou,*)'lpd 7B: ',iel,typty + gx%bmperr=4082; goto 1000 + endif + endif + else +! unknown property ... + write(*,*)'unknown property type xx: ',ij,typty,typspec + prop='ZZ' + endif +! if disordered fraction set add D, already done above +! if(parlist.eq.2) then +! prop=prop(1:len_trim(prop))//'D' +! endif +! note changes here must be repeated for interaction parameters below + write(funexpr,200)prop(1:len_trim(prop)),& + phname(1:len_trim(phname)),text(1:len_trim(text)) +200 format(A,'(',A,',',A,') ') + ip=len_trim(funexpr)+1 +! subtract reference states + if(subref .and. typty.eq.1) then + call subrefstates(funexpr,ip,lokph,parlist,endm,noelin1) + if(noelin1) then +! this can happen for ionic liquids with just neutrals in sublattice 2 +! replace the constituent in sublattice 1 with "*" !!! +! write(*,*)'before: ',funexpr(1:ip) + kk=index(funexpr,',') + ik=index(funexpr,':') + funexpr(kk+1:)='*'//funexpr(ik:) + ip=len_trim(funexpr)+2 +! write(*,*)'after: ',funexpr(1:ip) + endif + endif +! this writes the expression + call list_tpfun(proprec%degreelink(0),1,funexpr(ip:)) + ip=len_trim(funexpr) + funexpr(ip+1:)=' '//proprec%reference + ip=len_trim(funexpr) +! nice output over several lines if needed with indentation 12 spaces + call wrice2(lut,2,12,78,1,funexpr(1:ip)) + proprec=>proprec%nextpr + enddo ptyloop + if(endmemrec%noofpermut.gt.1) then + intpq=0 + if(associated(endmemrec%intpointer)) then + intpq=endmemrec%intpointer%antalint + endif +! write(kou,207)endmemrec%antalem,endmemrec%noofpermut,intpq +207 format('@$ Endmember, permutations, interaction: ',3i5) + endif + endmemrec=>endmemrec%nextem + enddo endmemberlist +!----------------------------------------------------------------------- +! parameters for interactions using site fractions + if(parlist.eq.1) then + endmemrec=>phlista(lokph)%ordered + else + endmemrec=>phlista(lokph)%disordered + endif + intlist1: do while(associated(endmemrec)) + intrec=>endmemrec%intpointer + if(associated(intrec)) then +! write(*,*)'intlist 1B: ',intrec%status + do ll=1,nsl + kkx=endmemrec%fraclinks(ll,1) + if(kkx.eq.-99) then +! wildcard + endm(ll)=-99 + elseif(parlist.eq.2) then + endm(ll)=disfra%splink(kkx) + else + endm(ll)=phlista(lokph)%constitlist(kkx) + endif + enddo + endif + nint=0 + intlist2: do while(associated(intrec)) + nint=nint+1 + intrecstack(nint)%p1=>intrec + lint(1,nint)=intrec%sublattice(1) + kkk=intrec%fraclink(1) + if(parlist.eq.2) then + lint(2,nint)=disfra%splink(kkk) + else + lint(2,nint)=phlista(lokph)%constitlist(kkk) + endif + proprec=>intrec%propointer + ptyloop2: do while(associated(proprec)) +! typty=proprec%proptype + ij=proprec%proptype + if(ij.ge.100) then + typty=ij/100 + typspec=mod(ij,100) + else + typty=ij + endif +! typspec=proprec%proptype +! if(typspec.gt.100) then +! typty=typspec/100 +! typspec=mod(typty,100) +! else +! typty=typspec +! endif + if(typty.gt.0 .and. typty.le.ndefprop) then + prop=propid(typty)%symbol + if(parlist.eq.2) then +! disordered interaction parameter + kk=len_trim(prop)+1 + prop(kk:kk)='D' + endif + if(btest(propid(typty)%status,IDELSUFFIX)) then +! property like ZZ&(phase,constituent array) +! the element index should be in typsepc + iel=typspec + if(iel.ge.0 .and. iel.le.noofel) then + prop=prop(1:len_trim(prop))//'&'& + //ellista(elements(iel))%symbol + else +! write(*,*)'lpd 7: ',iel,typty + gx%bmperr=4082; goto 1000 + endif + elseif(btest(propid(typty)%status,IDCONSUFFIX)) then +! property like mobility MQ&(phase,constituent array) +! the suffix is a constituent + iel=typspec + if(iel.gt.0 .and. iel.le.phlista(lokph)%tnooffr) then + if(parlist.eq.2) then +! we must consider parlist, take disordered constituent list +! we have no current equilibrium record but can use firsteq!! +! write(*,*)'3C: typspec: 3 ',typty,iel,prop(1:10) + linkcon=disfrap%splink(iel) +! write(*,*)'3C: typspec: 4 ',typty,linkcon,prop(1:10) + ll=1 + if(iel.gt.disfrap%nooffr(1)) ll=2 + prop=prop(1:len_trim(prop))//'&'& + //splista(linkcon)%symbol + goto 220 + else + linkcon=phlista(lokph)%constitlist(iel) + if(linkcon.le.0) then + write(*,*)'Illegal use of wildcard 2' + gx%bmperr=7777; goto 1000 + endif + prop=prop(1:len_trim(prop))//'&'& + //splista(linkcon)%symbol +! also add the sublattice number ... + ncsum=0 + do ll=1,phlista(lokph)%noofsubl + ncsum=ncsum+phlista(lokph)%nooffr(ll) + if(iel.le.ncsum) goto 220 + enddo + endif +! there cannot be any errors here .... + write(*,*)'Never never error 2' + gx%bmperr=7777; goto 1000 +220 continue +! write(*,*)'property 2: ',prop(1:10),ll + prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0')) + else +! write(*,*)'lpd 7: ',iel,typty + gx%bmperr=4082; goto 1000 + endif + endif + else +! unknown property ... + write(*,*)'unknown property type yy: ',typty + prop='ZZ' + endif +! if disordered fraction set add D, already set above ??!! +! if(parlist.eq.2) then +! prop=prop(1:len_trim(prop))//'D' +! endif +! note changes here must be repeated for endmember parameters above + degree: do jdeg=0,proprec%degree + if(proprec%degreelink(jdeg).eq.0) then +! write(*,*)'Ignoring function link' + cycle degree + endif + call encode_constarr(text,nsl,endm,nint,lint,jdeg) + write(funexpr,300)prop(1:len_trim(prop)), & + phname(1:len_trim(phname)),text(1:len_trim(text)) +300 format(A,'(',A,',',A,') ') + ip=len_trim(funexpr)+1 + call list_tpfun(proprec%degreelink(jdeg),1,funexpr(ip:)) + ip=len_trim(funexpr) + funexpr(ip+1:)=' '//proprec%reference + ip=len_trim(funexpr) + call wrice2(lut,4,12,78,1,funexpr(1:ip)) + enddo degree + proprec=>proprec%nextpr + enddo ptyloop2 +! list temporarily the number of permutations + if(intrec%noofip(1).gt.1 .or. intrec%noofip(2).gt.1) then + if(nint.eq.1) then + nz=intrec%noofip(2) + else + nz=size(intrec%sublattice) + lqq=intrec%noofip(size(intrec%noofip)) + if(lqq.ne.nz) then + write(*,*)'Not same: ',intrec%antalint,nz,lqq + endif +! write(*,301)nz,intrec%noofip +301 format('noofip: ',10i3) +! nz=intrec%noofip(intrec%noofip(1)+2) + endif + iqnext=0 + iqhigh=0 + if(associated(intrec%highlink)) then + iqhigh=intrec%highlink%antalint + endif + if(associated(intrec%nextlink)) then + iqnext=intrec%nextlink%antalint + endif + write(*,302)intrec%antalint,nz,nint,iqhigh,iqnext +302 format('@$ Interaction, permutations, level, high, next: ',5i5) + endif + intrec=>intrec%highlink + empty: do while(.not.associated(intrec)) + if(nint.gt.0) then +! restore pointers in same clumsy way + intrec=>intrecstack(nint)%p1 + intrec=>intrec%nextlink +! write(*,*)'poping a pointer from intrecstack',ninit + nint=nint-1 + else + exit intlist2 + endif + enddo empty + enddo intlist2 + endmemrec=>endmemrec%nextem + enddo intlist1 +! check if there are other fraction lists +! parlist=parlist+1, hm parlist can only be 1 or 2 +! write(*,*)'checking for disordered parameters' + if(parlist.eq.1 .and. associated(phlista(lokph)%disordered)) then + subref=.TRUE. +! lokcs=phlista(lokph)%cslink + lokcs=phlista(lokph)%linktocs(ics) +! does this make a copy? Maybe it should be a pointer + disfra=firsteq%phase_varres(lokcs)%disfra + write(lut,810)disfra%fsites +810 format('Disordered fraction parameters, factor: ',F10.4,2x,10('-')) + nsl=disfra%ndd + parlist=2 + if(ocv()) write(*,*)'Jump back to list disordered',nsl,parlist + goto 100 + endif +1000 continue + return + END subroutine list_phase_data + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine list_phase_data2(iph,ftyp,ch1,lut) +! list parameter data for a phase on unit lut in ftyp format, ftyp=2 is TDB + implicit none + integer iph,lut,ftyp + character ch1*1 +!\end{verbatim} + integer typty,parlist,typspec,lokph,nsl,nk,ip,ll,jnr,ics,lokcs,isp + integer nint,ideg,ij,kk,iel,ncsum,kkx,kkk,jdeg,iqnext,iqhigh,lqq,nz,ik + integer intpq,linkcon + character text*1024,phname*24,prop*32,funexpr*512 + character special*8 + integer, dimension(2,3) :: lint + integer, dimension(maxsubl) :: endm,ilist + logical subref,noelin1 + type(gtp_fraction_set), pointer :: disfrap +! a smart way to have an array of pointers + TYPE intrecarray + type(gtp_interaction), pointer :: p1 + end TYPE intrecarray + type(intrecarray), dimension(20) :: intrecstack + type(gtp_property), pointer :: proprec + type(gtp_interaction), pointer :: intrec + type(gtp_endmember), pointer :: endmemrec + TYPE(gtp_fraction_set) :: disfra + TYPE(gtp_phase_add), pointer :: addrec +! an empty line first + write(lut,*) +! for type definitions + if(iph.lt.0 .or. iph.gt.noofph) then + gx%bmperr=4050; goto 1000 + elseif(noofel.eq.0) then +! this needed as there is a reference phase with iph=0 when there are elements + goto 1000 + endif +! write(*,*)'lpd 1:',iph,phases(iph) + if(iph.gt.0) then + lokph=phases(iph) + else + lokph=0 + endif + ics=1 + phname=phlista(lokph)%name + nsl=phlista(lokph)%noofsubl + special=' ' + special(1:1)='%' + isp=1 +! indicate some status bit specially, not useful for TDB files ... +! if(btest(phlista(lokph)%status1,PHFORD)) then +! special(2:2)='F' +! isp=2 +! elseif(btest(phlista(lokph)%status1,PHBORD)) then +! special(2:2)='B' +! isp=2 +! elseif(btest(phlista(lokph)%status1,PHSORD)) then +! special(2:2)='S' +! isp=2 +! elseif(btest(phlista(lokph)%status1,PHIONLIQ)) then +! special(2:2)='I' +! isp=2 +! endif +! here isp can be 1 or 2 +! if(btest(phlista(lokph)%status1,PHMFS)) then +! isp=isp+1 +! special(isp:isp)='D' +! endif + if(btest(phlista(lokph)%status1,PHIONLIQ)) then + lokcs=len_trim(phname)+1 + phname(lokcs:)=':Y' + elseif(btest(phlista(lokph)%status1,PHGAS)) then + phname='GAS:G' + elseif(btest(phlista(lokph)%status1,PHLIQ)) then + phname='LIQUID:L' + endif + if(btest(phlista(lokph)%status1,PHMFS)) then + ch1=char(ichar(ch1)+1) + isp=isp+1 + special(isp:isp)=ch1 + write(*,*)' *** Warning: disordered fraction sets need manual editing!' + write(lut,55)ch1,phname(1:len_trim(phname)),phname(1:len_trim(phname)) +55 format('$ *** Warning: disordered fraction sets need manual editing!'/& + ' TYPE_DEFINITION ',a,' GES A_P_D ',a,' DIS_PART DIS_',a,' !') + endif +! additions + addrec=>phlista(lokph)%additions + lastadd: do while(associated(addrec)) +! increment ch1 and position in special for each addition + ch1=char(ichar(ch1)+1) + isp=isp+1 + special(isp:isp)=ch1 + call list_addition(lut,ch1,phname,ftyp,addrec) + addrec=>addrec%nextadd + enddo lastadd +60 continue +! This subroutine is independent of current equilibrium, use firsteq +! write(lut,10)phname,phlista(lokph)%status1,special,& +! nsl,(phlista(lokph)%sites(ll),ll=1,nsl) +! write(*,*)'3C phase: ',phname,special + lokcs=phlista(lokph)%linktocs(ics) + write(lut,10,advance='no')phname(1:len_trim(phname)),special(1:isp),& + nsl,(firsteq%phase_varres(lokcs)%sites(ll),ll=1,nsl) +10 format(' PHASE ',A,1x,a,1x,I2,10(1x,F7.3)) + write(lut,11) +11 format('!') + nk=0 + text=' CONSTITUENT '//phname(1:len_trim(phname))//' :' + ip=len_trim(text)+1 + sublatloop: do ll=1,nsl + constloop: do ik=1,phlista(lokph)%nooffr(ll) + nk=nk+1 + jnr=phlista(lokph)%constitlist(nk) + if(jnr.gt.0) then + text(ip:)=splista(jnr)%symbol + else + text(ip:)='*' + endif + ip=len_trim(text)+1 +! text(ip:ip)=',' + text(ip:ip)=' ' + ip=ip+1 + enddo constloop + text(ip-1:ip)=': ' + ip=ip+1 + enddo sublatloop + text(ip-2:)=':!' + call wrice2(lut,2,4,78,-1,text) +! write(lut,17)text(1:ip) +!17 format(A) +! remove any :Y, :L or :G + ip=index(phname,':') + if(ip.gt.0) phname(ip:)=' ' +! parameters for end members using site fractions + if(btest(phlista(lokph)%status1,PHMFS)) then + subref=.FALSE. + else + subref=.TRUE. + endif + parlist=1 +!-------------------------------------------------- +! return here to list disordered parameters +100 continue +! parlist changed below for disordered fraction set + if(parlist.eq.1) then + endmemrec=>phlista(lokph)%ordered + else + if(ocv()) write(*,*)'Listing disordred parameters ',nsl + endmemrec=>phlista(lokph)%disordered + disfrap=>firsteq%phase_varres(lokcs)%disfra + endif + endmemberlist: do while(associated(endmemrec)) + do ll=1,nsl +! ilist(ll)=emlista(lokem)%fraclinks(ll,1) + ilist(ll)=endmemrec%fraclinks(ll,1) + if(ilist(ll).gt.0) then + if(parlist.eq.2) then +! what is disfra here??!! + endm(ll)=disfra%splink(ilist(ll)) + else + endm(ll)=phlista(lokph)%constitlist(ilist(ll)) + endif + else +! wildcard, write '*' + endm(ll)=-99 + endif + enddo + nint=0 + ideg=0 + call encode_constarr(text,nsl,endm,nint,lint,ideg) + if(gx%bmperr.ne.0) goto 1000 + proprec=>endmemrec%propointer + ptyloop: do while(associated(proprec)) + ij=proprec%proptype + if(ij.ge.100) then + typty=ij/100 + typspec=mod(ij,100) + else + typty=ij + endif + if(typty.gt.0 .and. typty.le.ndefprop) then + prop=propid(typty)%symbol + if(parlist.eq.2) then +! disordered endmember parameter + kk=len_trim(prop)+1 + prop(kk:kk)='D' + endif + if(btest(propid(typty)%status,IDELSUFFIX)) then +! property like ZZ&(phase,constituent array) +! the element index should be in typsepc + iel=typspec + if(iel.ge.0 .and. iel.le.noofel) then +! prop=propid(typty)%symbol + prop=prop(1:len_trim(prop))//'&'& + //ellista(elements(iel))%symbol + else + gx%bmperr=4082; goto 1000 + endif + elseif(btest(propid(typty)%status,IDCONSUFFIX)) then +! property like mobility, MQ&(phase,constituent array) +! the suffix is a constituent + iel=typspec + if(iel.gt.0 .and. iel.le.phlista(lokph)%tnooffr) then + if(parlist.eq.2) then +! we must consider parlist, take disordered constituent list +! we have no current equilibrium record but can use firsteq!! +! lokcs=phlista(lokph)%linktocs(1) +! write(*,*)'3C: endmember typspec 1: ',iel + linkcon=disfrap%splink(iel) +! write(*,*)'3C: endmember typspec 2: ',linkcon + ll=1 + if(linkcon.gt.disfrap%nooffr(1)) ll=2 + prop=prop(1:len_trim(prop))//'&'& + //splista(linkcon)%symbol + goto 120 + else + linkcon=phlista(lokph)%constitlist(iel) + if(linkcon.le.0) then + write(*,*)'Illegal use of wildcard 1' + gx%bmperr=7777; goto 1000 + endif + prop=prop(1:len_trim(prop))//'&'& + //splista(linkcon)%symbol +! also add the sublattice number ... + ncsum=0 + do ll=1,phlista(lokph)%noofsubl + ncsum=ncsum+phlista(lokph)%nooffr(ll) + if(iel.le.ncsum) goto 120 + enddo + endif +! error if sublattice not found + write(kou,*)'Error in constituent depended parameter id' + gx%bmperr=7777; goto 1000 +! jump here to append sublattice +120 continue +! write(*,*)'property 1: ',prop(1:10),ll + prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0')) + else + write(kou,*)'lpd 7B: ',iel,typty + gx%bmperr=4082; goto 1000 + endif + endif + else +! unknown property ... + write(*,*)'unknown property type xx: ',ij,typty,typspec + prop='ZZ' + endif +! if disordered fraction set add D, already done above +! if(parlist.eq.2) then +! prop=prop(1:len_trim(prop))//'D' +! endif +! note changes here must be repeated for interaction parameters below + write(funexpr,200)prop(1:len_trim(prop)),& + phname(1:len_trim(phname)),text(1:len_trim(text)) +200 format(' PARAMETER ',A,'(',A,',',A,') ') + ip=len_trim(funexpr)+1 +!-------------------------------- this is not done for TDB files +! subtract reference states +! if(subref .and. typty.eq.1) then +! call subrefstates(funexpr,ip,lokph,parlist,endm,noelin1) +! if(noelin1) then +! this can happen for ionic liquids with just neutrals in sublattice 2 +! replace the constituent in sublattice 1 with "*" !!! +! write(*,*)'before: ',funexpr(1:ip) +! kk=index(funexpr,',') +! ik=index(funexpr,':') +! funexpr(kk+1:)='*'//funexpr(ik:) +! ip=len_trim(funexpr)+2 +! write(*,*)'after: ',funexpr(1:ip) +! endif +! endif +! this writes the expression, problem if function is zero + call list_tpfun(proprec%degreelink(0),1,funexpr(ip:)) +! remove = sign + ip=index(funexpr,'=') + funexpr(ip:ip)=' ' + ip=len_trim(funexpr) + funexpr(ip+1:)=' '//proprec%reference + ip=len_trim(funexpr) + funexpr(ip+1:)=' !' +! nice output over several lines if needed with indentation 12 spaces + call wrice2(lut,2,12,78,1,funexpr(1:ip+2)) + proprec=>proprec%nextpr + enddo ptyloop + if(endmemrec%noofpermut.gt.1) then + intpq=0 + if(associated(endmemrec%intpointer)) then + intpq=endmemrec%intpointer%antalint + endif +! write(kou,207)endmemrec%antalem,endmemrec%noofpermut,intpq +207 format('@$ Endmember, permutations, interaction: ',3i5) + endif + endmemrec=>endmemrec%nextem + enddo endmemberlist +!----------------------------------------------------------------------- +! parameters for interactions using site fractions + if(parlist.eq.1) then + endmemrec=>phlista(lokph)%ordered + else + endmemrec=>phlista(lokph)%disordered + endif + intlist1: do while(associated(endmemrec)) + intrec=>endmemrec%intpointer + if(associated(intrec)) then +! write(*,*)'intlist 1B: ',intrec%status + do ll=1,nsl + kkx=endmemrec%fraclinks(ll,1) + if(kkx.eq.-99) then +! wildcard + endm(ll)=-99 + elseif(parlist.eq.2) then + endm(ll)=disfra%splink(kkx) + else + endm(ll)=phlista(lokph)%constitlist(kkx) + endif + enddo + endif + nint=0 + intlist2: do while(associated(intrec)) + nint=nint+1 + intrecstack(nint)%p1=>intrec + lint(1,nint)=intrec%sublattice(1) + kkk=intrec%fraclink(1) + if(parlist.eq.2) then + lint(2,nint)=disfra%splink(kkk) + else + lint(2,nint)=phlista(lokph)%constitlist(kkk) + endif + proprec=>intrec%propointer + ptyloop2: do while(associated(proprec)) +! typty=proprec%proptype + ij=proprec%proptype + if(ij.ge.100) then + typty=ij/100 + typspec=mod(ij,100) + else + typty=ij + endif +! typspec=proprec%proptype +! if(typspec.gt.100) then +! typty=typspec/100 +! typspec=mod(typty,100) +! else +! typty=typspec +! endif + if(typty.gt.0 .and. typty.le.ndefprop) then + prop=propid(typty)%symbol + if(parlist.eq.2) then +! disordered interaction parameter + kk=len_trim(prop)+1 + prop(kk:kk)='D' + endif + if(btest(propid(typty)%status,IDELSUFFIX)) then +! property like ZZ&(phase,constituent array) +! the element index should be in typsepc + iel=typspec + if(iel.ge.0 .and. iel.le.noofel) then + prop=prop(1:len_trim(prop))//'&'& + //ellista(elements(iel))%symbol + else +! write(*,*)'lpd 7: ',iel,typty + gx%bmperr=4082; goto 1000 + endif + elseif(btest(propid(typty)%status,IDCONSUFFIX)) then +! property like mobility MQ&(phase,constituent array) +! the suffix is a constituent + iel=typspec + if(iel.gt.0 .and. iel.le.phlista(lokph)%tnooffr) then + if(parlist.eq.2) then +! we must consider parlist, take disordered constituent list +! we have no current equilibrium record but can use firsteq!! +! write(*,*)'3C: typspec: 3 ',typty,iel,prop(1:10) + linkcon=disfrap%splink(iel) +! write(*,*)'3C: typspec: 4 ',typty,linkcon,prop(1:10) + ll=1 + if(iel.gt.disfrap%nooffr(1)) ll=2 + prop=prop(1:len_trim(prop))//'&'& + //splista(linkcon)%symbol + goto 220 + else + linkcon=phlista(lokph)%constitlist(iel) + if(linkcon.le.0) then + write(*,*)'Illegal use of wildcard 2' + gx%bmperr=7777; goto 1000 + endif + prop=prop(1:len_trim(prop))//'&'& + //splista(linkcon)%symbol +! also add the sublattice number ... + ncsum=0 + do ll=1,phlista(lokph)%noofsubl + ncsum=ncsum+phlista(lokph)%nooffr(ll) + if(iel.le.ncsum) goto 220 + enddo + endif +! there cannot be any errors here .... + write(*,*)'Never never error 2' + gx%bmperr=7777; goto 1000 +220 continue +! write(*,*)'property 2: ',prop(1:10),ll + prop=prop(1:len_trim(prop))//'#'//char(ll+ichar('0')) + else +! write(*,*)'lpd 7: ',iel,typty + gx%bmperr=4082; goto 1000 + endif + endif + else +! unknown property ... + write(*,*)'unknown property type yy: ',typty + prop='ZZ' + endif +! if disordered fraction set add D, already set above ??!! +! if(parlist.eq.2) then +! prop=prop(1:len_trim(prop))//'D' +! endif +! note changes here must be repeated for endmember parameters above + degree: do jdeg=0,proprec%degree + if(proprec%degreelink(jdeg).eq.0) then +! write(*,*)'Ignoring function link' + cycle degree + endif + call encode_constarr(text,nsl,endm,nint,lint,jdeg) + write(funexpr,300)prop(1:len_trim(prop)), & + phname(1:len_trim(phname)),text(1:len_trim(text)) +300 format('PARAMETER ',A,'(',A,',',A,') ') + ip=len_trim(funexpr)+1 + call list_tpfun(proprec%degreelink(jdeg),1,funexpr(ip:)) +! remove = sign + ip=index(funexpr,'=') + funexpr(ip:ip)=' ' + ip=len_trim(funexpr) + funexpr(ip+1:)=' '//proprec%reference + ip=len_trim(funexpr) + funexpr(ip+1:)=' !' + call wrice2(lut,4,12,78,1,funexpr(1:ip+2)) + enddo degree + proprec=>proprec%nextpr + enddo ptyloop2 +! list temporarily the number of permutations + if(intrec%noofip(1).gt.1 .or. intrec%noofip(2).gt.1) then + if(nint.eq.1) then + nz=intrec%noofip(2) + else + nz=size(intrec%sublattice) + lqq=intrec%noofip(size(intrec%noofip)) + if(lqq.ne.nz) then + write(*,*)'Not same: ',intrec%antalint,nz,lqq + endif +! write(*,301)nz,intrec%noofip +301 format('noofip: ',10i3) +! nz=intrec%noofip(intrec%noofip(1)+2) + endif + iqnext=0 + iqhigh=0 + if(associated(intrec%highlink)) then + iqhigh=intrec%highlink%antalint + endif + if(associated(intrec%nextlink)) then + iqnext=intrec%nextlink%antalint + endif + write(*,302)intrec%antalint,nz,nint,iqhigh,iqnext +302 format('@$ Interaction, permutations, level, high, next: ',5i5) + endif + intrec=>intrec%highlink + empty: do while(.not.associated(intrec)) + if(nint.gt.0) then +! restore pointers in same clumsy way + intrec=>intrecstack(nint)%p1 + intrec=>intrec%nextlink +! write(*,*)'poping a pointer from intrecstack',ninit + nint=nint-1 + else + exit intlist2 + endif + enddo empty + enddo intlist2 + endmemrec=>endmemrec%nextem + enddo intlist1 +! check if there are other fraction lists +! parlist=parlist+1, hm parlist can only be 1 or 2 +! write(*,*)'checking for disordered parameters' + if(parlist.eq.1 .and. associated(phlista(lokph)%disordered)) then + write(lut,810) +810 format('$ Disordered fraction parameters:',20('-')) + subref=.TRUE. +! lokcs=phlista(lokph)%cslink + lokcs=phlista(lokph)%linktocs(ics) +! does this make a copy? Maybe it should be a pointer + disfra=firsteq%phase_varres(lokcs)%disfra + nsl=disfra%ndd + parlist=2 + if(ocv()) write(*,*)'Jump back to list disordered',nsl,parlist + goto 100 + endif +1000 continue + return + END subroutine list_phase_data2 + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine subrefstates(funexpr,jp,lokph,parlist,endm,noelin1) +! list a sum of reference states for a G parameter +! like "-H298(BCC_A2,FE)-3*H298(GRAPITE,C)" + implicit none + integer jp,lokph,parlist,endm(*) + character funexpr*(*) + logical noelin1 +!\end{verbatim} +! special care for ionic liquid as sites varies ... + character text*80,els*2 + integer element(maxel),lokel + double precision coef(maxel),xx,pqval(2) + TYPE(gtp_fraction_set) :: disfra + integer nsl,lokcs,ie,ll,jsp,nrel,ik,je,more,is,ip +! + noelin1=.FALSE. + lokcs=phlista(lokph)%linktocs(1) + if(btest(phlista(lokph)%status1,PHIONLIQ)) goto 210 + if(parlist.eq.1) then + nsl=phlista(lokph)%noofsubl + else +! should disfra be a pointer?? It seems to work like this .... + disfra=firsteq%phase_varres(lokcs)%disfra + nsl=disfra%ndd + endif + ie=0 + sublat: do ll=1,nsl + jsp=endm(ll) + if(jsp.gt.0) then + nrel=splista(jsp)%noofel + elem: do ik=1,nrel + do je=1,ie + if(splista(jsp)%ellinks(ik).eq.element(je)) then + if(parlist.eq.1) then + coef(je)=coef(je)+& + firsteq%phase_varres(lokcs)%sites(ll)*& + splista(jsp)%stoichiometry(ik) +! phlista(lokph)%sites(ll)*splista(jsp)%stoichiometry(ik) + else + coef(je)=coef(je)+& + disfra%dsites(ll)*splista(jsp)%stoichiometry(ik) + endif + goto 200 + endif + enddo +! new element, increment ie and initiate coef +! ignore the element VA with element index 0 + if(splista(jsp)%ellinks(ik).eq.0) goto 200 + ie=ie+1 + element(ie)=splista(jsp)%ellinks(ik) + if(parlist.eq.1) then + coef(ie)=& + firsteq%phase_varres(lokcs)%sites(ll)*& + splista(jsp)%stoichiometry(ik) +! phlista(lokph)%sites(ll)*splista(jsp)%stoichiometry(ik) + else + coef(ie)=disfra%dsites(ll)*splista(jsp)%stoichiometry(ik) + endif +200 continue + enddo elem + else +! wildcard, ignore references + continue + endif + enddo sublat + goto 300 +!------------------------------------------------------------ +! ionic liquid special, 2 sublattices but sites varies with charges +210 continue + ie=0 + jsp=endm(1) + if(jsp.gt.0) then + pqval(2)=splista(jsp)%charge + else + pqval(2)=one + endif + jsp=endm(2) + if(jsp.gt.0) then + if(btest(splista(jsp)%status,SPVA)) then + pqval(1)=one + else + pqval(1)=-splista(jsp)%charge + if(pqval(1).eq.zero) then + noelin1=.TRUE. + pqval(2)=one + endif + endif + else + write(*,*)'Illegal with wildcards in 2nd sublattice' + gx%bmperr=7777; goto 1000 + endif + ionsl: do ll=1,2 + jsp=endm(ll) + if(jsp.lt.0) cycle + nrel=splista(jsp)%noofel + ionel: do ik=1,nrel + do je=1,ie + if(splista(jsp)%ellinks(ik).eq.element(je)) then + coef(je)=coef(je)+& + pqval(ll)*splista(jsp)%stoichiometry(ik) + cycle ionel + endif + enddo +! new element, increment ie and initiate coef +! ignore the element VA with element index 0 + if(splista(jsp)%ellinks(ik).ne.0) then + ie=ie+1 + element(ie)=splista(jsp)%ellinks(ik) + coef(ie)=& + pqval(ll)*splista(jsp)%stoichiometry(ik) + endif + enddo ionel + enddo ionsl +!------------------------------------------------------------ +! sort the elements +300 continue + more=0 + do je=1,ie-1 + if(element(je).gt.element(je+1)) then + is=element(je) + element(je)=element(je+1) + element(je+1)=is + xx=coef(je) + coef(je)=coef(je+1) + coef(je+1)=xx + more=1 + endif + enddo + if(more.gt.0) goto 300 +! list the elemsnts as -10*H298(SER,element) +! write(*,*)'subrefstate 2:',ie,(element(i),i=1,ie) + ip=1 + text=' ' + do je=1,ie + if(coef(je).ne.one) then + call wrinum(text,ip,10,6,-coef(je)) + text(ip:ip)='*' + else + text(ip:ip)='-' + endif + ip=ip+1 + lokel=element(je) + els=ellista(lokel)%symbol + if(ellista(lokel)%refstatesymbol.eq.0) then + text(ip:)='H298(SER,'//els(1:len_trim(els))//')' + else + text(ip:)='G(SER,'//els(1:len_trim(els))//')' + endif + ip=len_trim(text)+1 + enddo +! write(*,*)'subrefstate 9: ',ip,text(1:ip) + funexpr(jp:)=text + jp=jp+ip +1000 continue + return + end subroutine subrefstates + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine encode_stoik(text,ipos,spno) +! generate a stoichiometric formula of species from element list + implicit none + integer ipos,spno + character text*(*) +!\end{verbatim} + character elnam*2,ltext*60 + integer eli,noelx,iel,isto,jpos,ich,nlen + double precision stoi,charge + if(spno.lt.1 .or. spno.gt.noofsp) then +! write(*,*)'in encode_stoik' + gx%bmperr=4051 + goto 1000 + endif + ipos=1 + noelx=splista(spno)%noofel +! write(6,*)'encode_stoik 1: ',spno,noelx + loop1: do iel=1,noelx + eli=splista(spno)%ellinks(iel) + elnam=ellista(eli)%symbol +! write(6,*)'encode_stoik 2: ',eli,elnam + if(elnam(2:2).ne.' ') then + ltext(ipos:ipos+1)=elnam + nlen=2 + else + ltext(ipos:ipos)=elnam + nlen=1 + endif + ipos=ipos+nlen + stoi=splista(spno)%stoichiometry(iel) + isto=int(stoi) + if(abs(dble(isto)-stoi).lt.1.0D-3) then +! handle integer stoichiometries nicely + if(isto.gt.99) then + write(ltext(ipos:ipos+2),200)isto +200 format(I3) + ipos=ipos+3 + elseif(isto.gt.9) then + write(ltext(ipos:ipos+1),205)isto +205 format(I2) + ipos=ipos+2 + elseif(isto.gt.1) then + write(ltext(ipos:ipos),210)isto +210 format(i1) + ipos=ipos+1 +! write(6,*)'encode_stoik 4B: ',ltext(ipos-3:ipos) + elseif(nlen.eq.1 .and. iel.ne.noelx) then + ltext(ipos:ipos)='1' + ipos=ipos+1 + endif + else +! stoichiometry is a non-integer value + jpos=ipos + call wrinum(ltext,ipos,8,0,stoi) + if(buperr.ne.0) then + gx%bmperr=buperr; goto 1000 + endif +! remove trailing zeroes +300 continue + if(ltext(ipos:ipos).eq.'0') then + ipos=ipos-1; goto 300 + endif + endif + enddo loop1 + charge=splista(spno)%charge + ich=int(charge) +! write(6,*)'encode_stoik 5: ',ich,charge + if(ich.lt.zero) then +! limit output to integer charges <10 + ltext(ipos:ipos+3)='/-'//char(ichar('0')-ich) + ipos=ipos+3 + elseif(charge.gt.zero) then + ltext(ipos:ipos+3)='/+'//char(ichar('0')+ich) + ipos=ipos+3 + endif + text=ltext + ipos=ipos-1 +! write(6,*)'encode_stoik 6: ',ipos,ltext(1:ipos) +1000 continue + return + END subroutine encode_stoik + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine decode_stoik(name,noelx,elsyms,stoik) +! decode a species stoichiometry in name to element index and stoichiometry +! all in upper case + implicit none + character name*(*),elsyms(*)*2 + double precision stoik(*) + integer noelx +!\end{verbatim} + character lname*72,ch2*2 + double precision xx + integer ip,jp + lname=name + call capson(lname) + noelx=0 + ip=1 +! expect element symbol + if(eolch(lname,ip)) then +! empty line, expected species stoichiometry + gx%bmperr=4083; goto 1000 + endif +! write(*,*)'decode_stoik 1: ',lname +100 continue + ch2=lname(ip:ip+1) +! write(*,*)'Looking for element: ',ip,ch2 + if(ch2(2:2).ge.'A' .and. ch2(2:2).le.'Z') then + noelx=noelx+1 + elsyms(noelx)=ch2 + ip=ip+2 + elseif(ch2(1:1).ge.'A' .and. ch2(1:1).le.'Z') then + noelx=noelx+1 + elsyms(noelx)=ch2(1:1) + ip=ip+1 + elseif(ch2(1:1).eq.'/') then +! electron is always /-, if /+ is given change sign in lname + noelx=noelx+1 + elsyms(noelx)='/-' + if(ch2(2:2).eq.'+') then + lname(ip+1:ip+1)='-' + ip=ip+1 + elseif(ch2(2:2).eq.'-') then + ip=ip+2 + else +! do not accept Fe/2 for Fe/+2, always require + or - + write(*,*)'Charge must always be given as /+ or /-' + gx%bmperr=7777; goto 1000 + endif +! write(*,*)'Found charge: ',ip,noelx,'>',lname(ip:ip+5),'<' + else + goto 900 + endif +! an element found, no stoichiometry number means stoik=1 +! write(*,17)'decode_stoik 2: ',ip,ch2,lname(ip:ip+5) +17 format(a,i3,'>',a,'<>',a,'<') + if(lname(ip:ip).eq.' ') then + stoik(noelx)=one + else + jp=ip + call getrel(lname,ip,xx) +! write(*,*)'decode_stoik 3: ',jp,ip,buperr,xx + if(buperr.eq.0) then + stoik(noelx)=xx + else +! accept missing stoichiometry value as 1, it is accepted to write cao as cao + stoik(noelx)=one +! buperr=0 +! the error can be due to another element follows directly, restore ip an check +! ip=jp +! goto 100 + endif +! in one case of missing stoichiometry ip exceeded length of lname +! write(*,*)'decode_stoik 4: ',stoik(noelx) + fraction: if(buperr.eq.0 .and. lname(ip:ip).eq.'/') then +! a stoichiometric factor followed by / without sign will be interpreted +! as a fraction like AL2/3O. Note AL2/+3 means AL2 with charge +3 + jp=ip+1 + if(.not.(lname(jp:jp).eq.'+' .or. lname(jp:jp).eq.'-')) then + call getrel(lname,jp,xx) +! write(*,*)'decode_stoik 4: ',ip,jp,buperr,xx + if(buperr.eq.0) then + stoik(noelx)=stoik(noelx)/xx + ip=jp + else + buperr=0 + endif +! else +! write(*,*)'Interpret / as charge!' + endif + else + buperr=0 + endif fraction + if(ip.lt.len(lname)) goto 100 + endif +900 continue + if(noelx.eq.0) then + gx%bmperr=4084 + endif +! write(*,19)(stoik(i),i=1,noelx) +!19 format('decode_stoik 5: ',5(1PE12.3)) +1000 continue + return + end subroutine decode_stoik + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine encode_constarr(constarr,nsl,endm,nint,lint,ideg) +! creates a constituent array + implicit none + character constarr*(*) + integer, dimension(*) :: endm + integer nsl,nint,ideg + integer, dimension(2,*) :: lint +!\end{verbatim} + integer ip,mint,ll,l2 + ip=1 + constarr=' ' + mint=1 +! if(nint.gt.0) then +! write(*,*)'encode_contarr ',lint(1,1),lint(2,1) +! endif + do ll=1,nsl + if(endm(ll).gt.0) then + constarr(ip:)=splista(endm(ll))%symbol + else + constarr(ip:)='*' + endif + ip=len_trim(constarr) + if(mint.le.nint) then +! write(*,*)'encode_contarr ',lint(1,1),lint(2,1) + do l2=mint,nint + if(lint(1,mint).eq.ll) then + constarr(ip+1:ip+1)=',' + ip=ip+2 + constarr(ip:)=splista(lint(2,mint))%symbol + ip=len_trim(constarr) + mint=mint+1 + endif + enddo + endif + constarr(ip+1:ip+1)=':' + ip=ip+2 + enddo + constarr(ip-1:ip-1)=';' + constarr(ip:ip)=char(ideg+ichar('0')) + return + end subroutine encode_constarr + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine decode_constarr(lokph,constarr,nsl,endm,nint,lint,ideg) +! deconde a text string with a constituent array +! a constituent array has separated by , or : and ; before degree + implicit none + character constarr*(*) + integer endm(*),lint(2,*) + integer nsl,nint,ideg,lokph,lord +!\end{verbatim} + character const*24,ch1*1 + integer ll,ip,jp,isep,loksp,mord,isp,jsp,nord + integer constlist(5),klok(5),knr(2) +! + nint=0; ideg=0; ll=1 + endm(ll)=0 + ip=1 +! write(*,*)'decode_constarr 1: ',ip,constarr + if(eolch(constarr,ip)) then + gx%bmperr=4061; goto 1000 + endif + jp=ip-1 +! write(*,*)'decode_constarr 2: ',ip,jp + loop: do while(.true.) +! find separators between constituents, no spaces allowed + jp=jp+1 + ch1=biglet(constarr(jp:jp)) +! write(*,*)'decode_constarr 3: ',jp,ch1 + letter: if(ch1.eq.',') then + isep=1 + elseif(ch1.eq.':') then + isep=2 + elseif(ch1.eq.';') then + isep=3 + elseif(ch1.eq.' ') then + isep=4 + elseif(.not.(ch1.ge.'A' .and. ch1.le.'Z')) then +! write(*,*)'decode_constarr 3B: ',jp,ip,ch1 + if(jp.gt.ip) then +! accept 0-9 and _ and . and / and + and - +! after the first character of a constituent +! write(*,24)'decode constarr 24A: "',ch1 + if(.not.((ch1.ge.'0' .and. ch1.le.'9') .or. & + ch1.eq.'_' .or. ch1.eq.'.' .or. & + ch1.eq.'/' .or. ch1.eq.'+' .or. ch1.eq.'-')) then +! write(*,24)'3C: decode constarr 24B: "',ch1 +24 format(a,a,'"') + gx%bmperr=4062; goto 1000 + endif + elseif(ch1.ne.'*') then +! last possibility: wildcard +! write(*,24)'decode constarr 24C: "',ch1 + gx%bmperr=4062; goto 1000 + endif +! write(*,24)'decode constarr 24D: "',ch1 + cycle + else + cycle + endif letter +! we have a species name between ip and jp + const=constarr(ip:jp-1) + call find_species_record_exact(const,loksp) + if(gx%bmperr.ne.0) then + if(const(1:2).eq.'* ') then +! wildcard, the parameter is independent of the fraction in this sublattice + loksp=-99; gx%bmperr=0 + else + goto 1000 + endif + endif +! write(*,11)'decode constarr 11: ',ip,jp,loksp,const +!11 format(a,3i4,'"',a,'"') + place: if(endm(ll).eq.0) then +! first constituent of sublattice ll independent of separator + endm(ll)=loksp + else + lint(1,nint)=ll + lint(2,nint)=loksp + endif place + next: if(isep.eq.1) then +! separator was a , next constituent an interaction + nint=nint+1 + elseif(isep.eq.2) then +! separator was a ":" meaning new sublattice + ll=ll+1 + endm(ll)=0 + elseif(isep.eq.3) then +! this is end of constituent array, followed ba a degree 0-9 + ideg=ichar(constarr(jp+1:jp+1))-ichar('0') + if(ideg.lt.0 .or. ideg.gt.9) then +! a degree must be between 0 and 9 + gx%bmperr=4063; goto 1000 + endif + exit loop + elseif(isep.eq.4) then + exit loop + endif next +! beginning of next constituent + ip=jp+1 + enddo loop +! number of sublattices + nsl=ll +! make sure the constituents are in alphabetcal order for each sublattice. +!-------------------------------------------------------- +! Special order of constituents for ionic liquid .... + if(btest(phlista(lokph)%status1,PHIONLIQ)) then + constlist(1)=endm(1) + if(nsl.ne.2) then + if(nsl.eq.1) then +! when ionic liquid parameters entered from TDB-TC files parameters +! with just neutrals may have only one sublattice. Error cleared by +! the readtdb subroutine. +! BUT we must sort constituents on the sublattice, must be only neutrals ... +! I hope that will be chacked later ... + do jsp=1,nint + constlist(1+jsp)=lint(2,jsp) + enddo +! simple bubble sort of constlist +44 continue + do jsp=1,nint + if(constlist(jsp+1).lt.constlist(jsp)) then + lord=constlist(jsp) + constlist(jsp)=constlist(jsp+1) + constlist(jsp+1)=lord + goto 44 + endif + enddo + endif + endm(1)=constlist(1) + do jsp=1,nint + lint(2,jsp)=constlist(1+jsp) + enddo + if(ocv()) write(*,*)'Ionic liquid has always 2 sublattices' + gx%bmperr=7777; goto 1000 + endif + lord=1 + do jsp=1,nint + if(lint(1,jsp).eq.1) then + lord=lord+1 + constlist(lord)=lint(2,jsp) + endif + enddo + knr(1)=lord + lord=lord+1 + constlist(lord)=endm(2) + do jsp=1,nint + if(lint(1,jsp).eq.2) then + lord=lord+1 + constlist(lord)=lint(2,jsp) + endif + enddo + knr(2)=lord-knr(1) + call sort_ionliqconst(lokph,1,knr,constlist,klok) + if(gx%bmperr.ne.0) then + write(*,*)'Error return from sort_ionliqconst ',gx%bmperr + goto 1000 + endif +! write(*,65)lord,(klok(ll),ll=1,lord) +65 format('from sort: ',i5,5x,5i3) + lord=0 + endm(1)=klok(1) + do jsp=2,knr(1) + lord=lord+1 + lint(1,lord)=1 + lint(2,lord)=klok(lord+1) + enddo + endm(2)=klok(lord+2) + do jsp=2,knr(2) + lord=lord+1 + lint(1,lord)=2 + lint(2,lord)=klok(lord+2) + enddo +! write(*,66)endm(1),endm(2),(lint(1,ll),lint(2,ll),ll=1,nint) +66 format('decode: ',2i5,5x,3(2i3,2x)) + goto 1000 + endif +!-------------------------------------------------------- +! first the endmember must be in order of the constituents, except wildcard + order1: do mord=1,nint + ll=lint(1,mord) + isp=lint(2,mord) + jsp=endm(ll) +! we can have isp or jsp or both negative if wildcard, WILDCARD ALWAYS IN ENDM + if(isp.lt.0 .and. jsp.lt.0) then +! only one wildcard in each sublattice + gx%bmperr=4032; goto 1000 + elseif(isp.lt.0 .and. jsp.gt.0) then + endm(ll)=isp + lint(2,mord)=jsp + elseif(isp.gt.0 .and. jsp.lt.0) then + endm(ll)=jsp + lint(2,mord)=isp + elseif(splista(isp)%alphaindex.lt.splista(jsp)%alphaindex) then + endm(ll)=isp + lint(2,mord)=jsp + endif + enddo order1 +! then order if there are two interacting in same sublattice +! There are almost never more than 3 constituents interacting in one sublattice + order2: do mord=1,nint + ll=lint(1,mord) + order3: do nord=mord+1,nint + if(lint(1,nord).eq.ll) then + isp=lint(2,nord) + jsp=lint(2,mord) + if(isp.lt.0 .or. jsp.lt.0) then + gx%bmperr=4032; goto 1000 + endif + if(splista(isp)%alphaindex.lt.splista(jsp)%alphaindex) then + lint(2,mord)=isp + lint(2,nord)=jsp + endif + endif + enddo order3 + enddo order2 +! write(*,77)(splista(endm(i))%alphaindex,i=1,nsl), & +! (lint(1,j),lint(2,j),j=1,nint) +!77 format('decode_contarr 7: ',3I3,5x,2i2) +1000 continue + return + end subroutine decode_constarr + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine list_bibliography(bibid,lut) +! list bibliographic references + implicit none + integer lut + character bibid*(*) +!\end{verbatim} + character longline*2048 + integer ir,jp,nl,ll + if(lut.eq.kou) then + write(lut,10)reffree-1 +! else +! write(lut,11)reffree-1 + endif +10 format('There are ',i5,' bibliographic references') +11 format('$ There are ',i5,' bibliographic references') + do ir=1,reffree-1 + if(bibid(1:1).ne.' ' .and. & + .not.compare_abbrev(bibid,bibrefs(ir)%reference)) cycle + longline=bibrefs(ir)%reference + longline(17:17)="'" + jp=18 + nl=size(bibrefs(ir)%refspec) + do ll=1,nl + longline(jp:)=bibrefs(ir)%refspec(ll) + jp=jp+64 + enddo + jp=len_trim(longline)+1 + longline(jp:jp)="'" + call wrice(lut,0,17,78,longline(1:jp)) + enddo +1000 continue + return + end subroutine list_bibliography + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine list_conditions(lut,ceq) +! lists conditions on lut + implicit none + integer lut + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + character*1024 text + integer kl + text=' ' + call get_all_conditions(text,0,ceq) + if(gx%bmperr.ne.0) goto 1000 + kl=index(text,'CRLF') + if(kl.gt.1) then + call wrice2(lut,2,4,78,1,text(1:kl-1)) + endif + write(lut,50)text(kl+4:len_trim(text)) +50 format(a) +1000 continue + return + end subroutine list_conditions + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine get_one_condition(ip,text,seqz,ceq) +! list the condition with the index seqz into text +! It lists also fix phases and conditions that are not active + implicit none + integer ip,seqz + character text*(*) + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer jl,iterm,indx(4) + TYPE(gtp_condition), pointer :: last,current + type(gtp_state_variable), pointer :: svrrec + double precision wone +! + if(ip.le.0) ip=1 + text(ip:)=' ' + if(.not.associated(ceq%lastcondition)) then + write(*,*)'No conditions at all' + gx%bmperr=8887; goto 1000 + endif + last=>ceq%lastcondition + current=>last +70 continue + if(current%seqz.eq.seqz) goto 100 + current=>current%next + if(.not.associated(current,last)) goto 70 +! no condition with this index found + gx%bmperr=4131; goto 1000 +! +100 continue + iterm=1 +! return here for each term if several +150 continue + do jl=1,4 + indx(jl)=current%indices(jl,iterm) + enddo + if(abs(current%condcoeff(iterm)-one).gt.1.0D-10) then + wone=current%condcoeff(iterm)+one + if(abs(wone).lt.1.0D-10) then + text(ip:ip)='-' + ip=ip+1 + else +! not +1 or -1, write number + call wrinum(text,ip,8,1,current%condcoeff(iterm)) + text(ip:ip)='*' + ip=ip+1 + endif + elseif(iterm.gt.1) then +! must be a + in front of second and later terms + text(ip:ip)='+' + ip=ip+1 + endif +! why is ceq needed?? BECAUSE COMPONENTS CAN BE DIFFERENT ... hm?? !! +! call encode_state_variable2(text,ip,current%statev,indx,& +! current%iunit,current%iref,ceq) + svrrec=>current%statvar(1) + call encode_state_variable(text,ip,svrrec,ceq) + if(iterm.lt.current%noofterms) then + iterm=iterm+1; goto 150 + endif +! write = followed by the value + if(text(ip:ip).ne.' ') ip=ip+1 + text(ip:)='=' + ip=ip+1 + if(current%symlink1.gt.0) then +! the value is a symbol + text(ip:)=svflista(current%symlink1)%name + ip=len_trim(text)+1 + else + call wrinum(text,ip,10,0,current%prescribed) + endif +1000 continue + return + end subroutine get_one_condition + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine get_all_conditions(text,mode,ceq) +! list all conditions if mode=0, experiments if mode=1 + implicit none + integer mode + character text*(*) + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + TYPE(gtp_condition), pointer :: last,current,first + type(gtp_state_variable), pointer :: svrrec + character phname*32 + integer ntot,nc,ip,iterm,iph,ics,jl + double precision value,wone + integer indx(4) + ntot=0 + text=' ' + if(mode.eq.1) then +! cannot enter experiments yet + goto 1000 + endif + if(noofel.eq.0) then + text='CRLF No elements' + goto 1000 + endif + last=>ceq%lastcondition + if(.not.associated(last)) then +! The CRLF indicates CR+LF at output + write(text,50)noofel+2 +50 format('CRLF Degrees of freedom are ',i3) + goto 1000 + endif + current=>last%next + first=>current + nc=1 + ip=1 +100 continue +! conditions can also be fixed phases !!! + ntot=ntot+1 + if(current%active.ne.0) then +! if active is nonzero the condition is not active + goto 200 + endif +! call wrinum(text,ip,3,0,dble(nc)) + call wriint(text,ip,nc) +! number the conditions + text(ip:)=':' +! ip=ip+2 +! No space after : + ip=ip+1 + iterm=1 + if(current%statev.lt.0) then +! handle FIX phases + iph=-current%statev + ics=current%iref + call get_phase_name(iph,ics,phname) + if(gx%bmperr.ne.0) then + write(*,*)'list condition error for phase ',iph,ics + gx%bmperr=4178; goto 1000 + endif + text(ip:)='<'//phname + ip=len_trim(text)+3 + text(ip-2:ip-1)='>=' + value=current%prescribed + if(value.lt.1.0d-8) then + value=zero + endif + call wrinum(text,ip,4,0,value) + goto 190 + endif +! return here for each term if several +150 continue + do jl=1,4 + indx(jl)=current%indices(jl,iterm) + enddo + if(abs(current%condcoeff(iterm)-one).gt.1.0D-10) then + wone=current%condcoeff(iterm)+one + if(abs(wone).lt.1.0D-10) then + text(ip:ip)='-' + ip=ip+1 + else +! not +1 or -1, write number +! write(*,*)'list cond: ',current%condcoeff(iterm),one,wone + call wrinum(text,ip,8,1,current%condcoeff(iterm)) + text(ip:ip)='*' + ip=ip+1 + endif + elseif(iterm.gt.1) then +! must be a + in front of second and later terms + text(ip:ip)='+' + ip=ip+1 + endif +! why is ceq needed?? BECAUSE COMPONENTS CAN BE DIFFERENT ... hm?? !! +! write(*,*)'3C encode: ',current%statev,indx +! call encode_state_variable2(text,ip,current%statev,indx,& +! current%iunit,current%iref,ceq) + svrrec=>current%statvar(1) + call encode_state_variable(text,ip,svrrec,ceq) + if(iterm.lt.current%noofterms) then + iterm=iterm+1; goto 150 + endif +! problem with current position ... LNAC(CR) had the last ) overwritten ... +! write(*,157)ip,text(1:ip) +!157 format('3C gc: ',i2,'"',a,'"') + if(text(ip:ip).ne.' ') ip=ip+1 + text(ip:)='=' + ip=ip+1 + if(current%symlink1.gt.0) then +! the value is a symbol + text(ip:)=svflista(current%symlink1)%name + ip=len_trim(text)+1 + else + call wrinum(text,ip,10,0,current%prescribed) + endif +190 continue + text(ip:ip)=', ' + ip=ip+2 + nc=nc+1 +200 continue + current=>current%next + if(.not.associated(current,first)) goto 100 +! there can be non-active conditions only + if(nc.gt.1) then +! write without the last , + text(ip-2:)=' ' +! write(kou,99)text(1:ip-3) +!99 format(a) + endif + write(text(ip:),50)noofel+3-nc +1000 return + end subroutine get_all_conditions + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine list_defined_properties(lut) +! lists all parameter identifiers allowed + implicit none + integer lut +!\end{verbatim} + character special*32,tdep*1,pdep*1 + integer typty,kk + write(lut,10) +10 format('Index Ident T P Specification',23x,' Status Note') +!10 format('Index Symbol Specification',26x,' Status Note') + do typty=1,ndefprop + special=' ' + if(btest(propid(typty)%status,IDELSUFFIX)) then + special='&' + elseif(btest(propid(typty)%status,IDCONSUFFIX)) then + special='&' + endif + kk=len_trim(special) + if(kk.gt.0) then + special(kk+1:)=';' + kk=kk+2 + else + kk=1 + endif + tdep='T' + pdep='P' + if(btest(propid(typty)%status,IDNOTP)) then +! special(kk:)='Not T- and P-dependent' + tdep='-' + pdep='-' + elseif(btest(propid(typty)%status,IDONLYP)) then +! special(kk:)='Not T-dependant' + tdep='-' + endif + write(lut,50)typty,propid(typty)%symbol,tdep,pdep,special,& + propid(typty)%status,propid(typty)%note +50 format(i5,2x,a,2x,a,1x,a,2x,a,2x,z8,1x,a) + enddo +1000 continue + return + end subroutine list_defined_properties + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine find_defined_property(symbol,mode,typty,iph,ics) +! searches the propid list for one with symbol or identifiction typty +! if mode=0 then symbol given, if mode=1 then typty given +! symbol can be TC(BCC), BM(FCC), MQ&FE(HCP) etc, the phase must be +! given in symbol as otherwise it is impossible to find the consititent!!! +! A constituent may have a sublattice specifier, MQ&FE#3(SIGMA) + implicit none + integer mode,typty,iph,ics + character symbol*(*) +!\end{verbatim} + character phsym*24,specid*24,nude*4 + integer splink,k1,k2,lattice,lokph,ityp,iel,kk,ll,jj + integer jtyp +! write(*,7)'3C fdp 1: ',symbol(1:5),mode,typty,iph,ics +7 format(a,a,5i5) + if(mode.eq.0) then +! symbol given, can include & # and ( ) like MQ&FE#3(SIGMA) + lattice=0 + nude=' ' + specid=' ' + k1=index(symbol,'&') + if(k1.gt.0) then + nude=symbol(1:k1-1) + k2=index(symbol,'#') + if(k2.eq.0) then + k2=index(symbol,'(') + if(k2.eq.0) then +! write(*,*)'3C: Missing phase specifier in property symbol 1' + write(*,*)'Error in symbol: ',symbol + gx%bmperr=7777; goto 1000 + endif + else + lattice=ichar(symbol(k2+1:k2+1))-ichar('0') + if(lattice.le.0 .or. lattice.gt.9) then + write(*,*)'Sublattice outside range in property symbol' + gx%bmperr=7777; goto 1000 + endif + endif + specid=symbol(k1+1:k2-1) + call capson(specid) + endif +! there must be a phase name within ( ) + k1=index(symbol,'(') + if(k1.gt.0) then + k2=index(symbol,')') + if(k2.lt.k1) then + write(*,*)'3C Missing phase specifier in property symbol 2' + write(*,*)'Symbol: ',symbol + gx%bmperr=7777; goto 1000 + endif + phsym=symbol(k1+1:k2-1) + call find_phase_by_name(phsym,iph,ics) + if(gx%bmperr.ne.0) goto 1000 + lokph=phases(iph) + if(nude(1:1).eq.' ') nude=symbol(1:k1-1) + elseif(mode.ne.0) then + write(*,*)'3C Missing phase specifier in property symbol 3' + write(*,*)'Symbol: ',symbol,mode + gx%bmperr=7777; goto 1000 +! else +! mode=0 means just ignore +! write(*,*)'3C mode: ',mode,iph,ics +! goto 1000 + endif +! now nude is the property id, lokph is phase location, specid is element or +! constituent symbol, lattice is sublattice number +! skip index 1 as G is a state variable + call capson(nude) +! write(*,*)'fdp 2: ',iph,ics,nude + do ityp=2,ndefprop +! write(*,*)'fdp 3: ',ityp,nude,propid(ityp)%symbol + if(propid(ityp)%symbol.ne.nude) cycle + if(btest(propid(ityp)%status,IDELSUFFIX)) then +! element specifier, IBM&CR(BCC) (when we have element specific Bohr magnetons) +! write(*,*)'fdp 4: element: ',specid + call find_element_by_name(specid,iel) + if(gx%bmperr.ne.0) goto 1000 + typty=100*ityp+iel + goto 200 + elseif(btest(propid(ityp)%status,IDCONSUFFIX)) then +! constituent specifier, for example: MQ&FE#3(SIGMA) +! write(*,*)'fdp 5: constituent: ',specid + kk=0 + do ll=1,phlista(lokph)%noofsubl + do jj=1,phlista(lokph)%nooffr(ll) + kk=kk+1 + splink=phlista(lokph)%constitlist(kk) + if(splink.le.0) then + write(*,*)'Illegal use of woildcard 3' + gx%bmperr=7777; goto 1000 + endif + if(specid.eq.splista(splink)%symbol .and. & + (lattice.eq.0 .or. lattice.eq.ll)) then + typty=100*ityp+kk + goto 200 + endif + enddo + enddo + else +! property without specifier like TC(FCC) + typty=ityp + goto 200 + endif + enddo +! if we come here we have not found the constituent or element or property +! it may be OK anyway if this is a call to test if symbol exists ?? +! write(*,*)'3C Illegal property symbol' + gx%bmperr=7777; goto 1000 +! we must return property number, phase location, element +! the value TYPTY stored in property records is "idprop" or +! if IDELSUFFIX set then 100*"idprop"+ellista index of element +! if IDCONSUFFIX set then 100*"idprop"+constituent index +200 continue + else +! indices given, typty, iph and ics, construct the symbol +! if typty>100 there is also an element or constituent specifier + lokph=phases(iph) +! write(*,*)'fdp 10: ',typty,iph,ics,lokph + ityp=typty + jtyp=-1 + if(ityp.gt.100) then + ityp=typty/100 + jtyp=typty-100*ityp + endif + if(ityp.le.1 .or. ityp.gt.ndefprop) then + write(*,*)'Property number outside range ',typty + gx%bmperr=7777; goto 1000 + endif + symbol=propid(ityp)%symbol + if(btest(propid(ityp)%status,IDELSUFFIX)) then +! could one have /- as specifier??? NO !! But maye Va + if(jtyp.lt.0) then + write(*,*)'Missing element index in property symbol' + gx%bmperr=7777; goto 1000 + endif + if(jtyp.lt.0 .or. jtyp.gt.noofel) then + write(*,*)'Too high element index in property symbol' + gx%bmperr=7777; goto 1000 + endif + symbol=symbol(1:len_trim(symbol))//'&'//ellista(jtyp)%symbol + elseif(btest(propid(ityp)%status,IDCONSUFFIX)) then + if(jtyp.lt.0) then + write(*,*)'Missing constituent index in property symbol' + gx%bmperr=7777; goto 1000 + endif + if(iph.le.0 .or. iph.gt.noofph) then + write(*,*)'Illegal phase location in property symbol' + gx%bmperr=7777; goto 1000 + endif + kk=0 + do ll=1,phlista(lokph)%noofsubl + do jj=1,phlista(lokph)%nooffr(ll) + kk=kk+1 + if(kk.eq.jtyp) then + splink=phlista(lokph)%constitlist(kk) + if(splink.le.0) then + write(*,*)'Illegal use of woildcard 4' + gx%bmperr=7777; goto 1000 + endif + specid=splista(splink)%symbol + if(ll.gt.1) then + specid=specid(1:len_trim(specid))//& + '#'//char(ichar('0')+ll) + endif + goto 400 + endif + enddo + enddo +! we come here is we failed to find the constituent + write(*,*)'Illegal constituent index in property symbol' + gx%bmperr=7777; goto 1000 +400 continue + symbol=symbol(1:len_trim(symbol))//'&'//specid + elseif(jtyp.gt.0) then + write(*,*)'This property has no specifier' + gx%bmperr=7777; goto 1000 + endif +! add the phase +! write(*,*)'fdp 11: ',lokph,ics + symbol=symbol(1:len_trim(symbol))//'('//phlista(lokph)%name + if(ics.lt.0 .or. ics.gt.phlista(lokph)%noofcs) then + write(*,*)'No such composition set' + gx%bmperr=7777; goto 1000 + endif + if(ics.gt.1) symbol=symbol(1:len_trim(symbol))//'#'//char(ichar('0')+ics) + symbol=symbol(1:len_trim(symbol))//')' +! write(*,*)'fdp 12: ',symbol(1:20) + endif +1000 continue + return + end subroutine find_defined_property + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine list_equilibria_details(mode,teq) +! not used yet ... + implicit none + TYPE(gtp_equilibrium_data), pointer :: teq + integer mode +!\end{verbatim} + TYPE(gtp_equilibrium_data), pointer :: ceq +! TYPE(gtp_phase_varres) :: varres + integer ieq,noofeq,iph + noofeq=noeq() + select case(mode) + case default + write(*,*)'No such mode: ',mode +!-------------------------------------------------- + case(1) ! list equilibria and some general data + write(*,10)noofeq +10 format('Number of equilibria: ',i3) + do ieq=1,noofeq + ceq=>eqlista(ieq) + write(*,11)ceq%eqno,ceq%eqname +11 format('Equilibrium ',i3,', ',a) + enddo +!-------------------------------------------------- + case(100:199) ! list phase varres data for phase mod(mode,100) + iph=mod(mode,100) + if(iph.eq.0) then + write(*,*)'all phases' + else + write(*,*)'phase ',iph + endif + end select +1000 continue + return + end subroutine list_equilibria_details + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + logical function gtp_error_message(reset) +! tests the error code and writes the error message (if any) +! and reset error code if reset=0 +! if reset >0 that is set as new error message +! if reset <0 the error code is not changed +! return TRUE if error code set, FALSE if error code is zero + implicit none + integer reset +!\end{verbatim} + if(gx%bmperr.ne.0) then + if(gx%bmperr.ge.4000 .and. gx%bmperr.le.nooferm) then + write(kou,10)gx%bmperr,bmperrmess(gx%bmperr) +10 format(' *** Error ',i5/a) + elseif(gx%bmperr.ne.0) then + write(*,20)gx%bmperr +20 format('Error without message: ',i7) + endif + if(reset.eq.0) then +! if reset zero reset error code + gx%bmperr=0 + elseif(gx%bmperr.gt.0) then +! if reset positive set this as error code + gx%bmperr=reset + endif +! if reset negative do not change error code. Set function to TRUE + gtp_error_message=.TRUE. + else +! no error, return false + gtp_error_message=.FALSE. + endif +1000 continue + return + end function gtp_error_message + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + diff --git a/models/pmod25D.F90 b/models/gtp3D.F90 similarity index 71% rename from models/pmod25D.F90 rename to models/gtp3D.F90 index 9fd316c..c63b928 100644 --- a/models/pmod25D.F90 +++ b/models/gtp3D.F90 @@ -1,2382 +1,1899 @@ -! -! included in pmod25.F90 -! -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ -!> 8. State variable functions -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine enter_svfun(cline,last,ceq) -! enter a state variable function - implicit none - integer last - character cline*(*) - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} %+ - integer, parameter :: npfs=20 - integer ks,maxsym,ipos,jt,js,kdot,nsymb - character name2*16,pfsym(npfs)*60,string*128,pfsymdenom*60 -! integer istv(npfs),indstv(4,npfs),iref(npfs),iunit(npfs),lokv(npfs) - integer iarr(10,npfs),lokv(npfs) - type(gtp_state_variable), pointer :: svr - type(putfun_node), pointer :: lrot -! -! maxsym is negative to allow the user to enter abs(maxs) symbols -! pfsym are the entered symbols -! lokv is only internal strage in putfun -! lrot is the root node of expression -! nsymb is the number of user entered symbols -! write(kou,17)'enter svgun ',last,cline(1:20),nsvfun -17 format(a,i3,2x,a,i3) - call gparc('Symbol name: ',cline,last,ichar('='),name2,' ',q1help) - call capson(name2) -! write(*,*)'enter_svfun: ',last,name2,':',cline(1:10) - if(.not.proper_symbol_name(name2,0)) goto 1000 - do ks=1,nsvfun - if(name2.eq.svflista(ks)%name) then - gx%bmperr=4136; goto 1000 - endif - enddo -! TO BE IMPLEMENTED: enter symbols with dummy arguments like CP(@P1)=HM(@P1).T -! where @Pi is a phase, @Ci is a component and @Si is a species -! these dummy variables must be defined in symbol name ?? why ?? maybe not - call gparc('Expression, end with ";" :',cline,last,6,string,';',q1help) - maxsym=-npfs - ipos=1 - call putfun(string,ipos,maxsym,pfsym,lokv,lrot,nsymb) - if(pfnerr.ne.0) then - pfnerr=0; gx%bmperr=4134; goto 1000 - endif -! on return nsymb is the number of external symbols used in the function -! these can be other functions or state variables or used defined identifiers -! like Curie temperature etc. The symbols are in pfsym(1..nsymb) -! -! write(*,11)nsymb,(pfsym(js)(1:len_trim(pfsym(js))),js=1,nsymb) -11 format('25D: args ',i2,': ',10(1x,a,',')) -! identify symbols as state variables, if derivative there is a dot - iarr=0 - jt=0 - do js=1,nsymb - kdot=index(pfsym(js),'.') - if(kdot.gt.0) then -! derivatives must be stored as two state variables -! write(*,*)'Found dot derivative: ',kdot,pfsym(js) -! Only allow a single symbol in this case!!! - if(nsymb.gt.1) then - write(*,*)'Only a single symbol allowed!' - gx%bmperr=7777; goto 1000 - endif - jt=1 -! denominator, variable after . for with the derivative is taken - pfsymdenom=pfsym(js)(kdot+1:) - pfsym(js)(kdot:)=' ' - call decode_state_variable(pfsym(js),svr,ceq) - if(gx%bmperr.ne.0) goto 1000 -! store in the old way in iarr for two state variables - iarr(1,js)=svr%oldstv - iarr(2,js)=svr%norm - iarr(3,js)=svr%unit - iarr(4,js)=svr%phref - iarr(5,js)=svr%argtyp - iarr(6,js)=svr%phase - iarr(7,js)=svr%compset - iarr(8,js)=svr%component - iarr(9,js)=svr%constituent - iarr(10,js)=jt - call decode_state_variable(pfsymdenom,svr,ceq) - if(gx%bmperr.ne.0) goto 1000 -! store in the old way in iarr for two state variables - iarr(1,js+1)=svr%oldstv - iarr(2,js+1)=svr%norm - iarr(3,js+1)=svr%unit - iarr(4,js+1)=svr%phref - iarr(5,js+1)=svr%argtyp - iarr(6,js+1)=svr%phase - iarr(7,js+1)=svr%compset - iarr(8,js+1)=svr%component - iarr(9,js+1)=svr%constituent - else - call decode_state_variable(pfsym(js),svr,ceq) - if(gx%bmperr.ne.0) then -! symbol not a state variable, may be another function -! write(*,*)'25D not state variable: ',gx%bmperr,' "',& -! pfsym(js)(1:len_trim(pfsym(js))),'"' - gx%bmperr=0 - do ks=1,nsvfun - if(pfsym(js).eq.svflista(ks)%name) then -! write(*,*)'25D found other function: ',& -! pfsym(js)(1:len_trim(pfsym(js))) - iarr(1,js)=-ks - goto 390 - endif - enddo - write(*,*)'25D not a function: "',& - pfsym(js)(1:len_trim(pfsym(js))),'"' - gx%bmperr=4135; goto 1000 - else -! write(*,*)'25D decoded 1: ',pfsym(js) -! write(*,*)'25D decoded 2: ',svr%statev -! Store in the old way in iarr - iarr(1,js)=svr%oldstv - iarr(2,js)=svr%norm - iarr(3,js)=svr%unit - iarr(4,js)=svr%phref - iarr(5,js)=svr%argtyp - iarr(6,js)=svr%phase - iarr(7,js)=svr%compset - iarr(8,js)=svr%component - iarr(9,js)=svr%constituent - endif - endif -390 continue - enddo -! for derivatives two iarr arrays -! Found bug in store_putfun if just a variable entered, coefficient set to 0.0 - call store_putfun(name2,lrot,nsymb+jt,iarr) -1000 continue - return - end subroutine enter_svfun - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ -!\begin{verbatim} %- - subroutine store_putfun(name,lrot,nsymb,iarr) -! enter an expression of state variables with name name with address lrot -! nsymb is number of formal arguments -! iarr identifies these -! idot if derivative - implicit none - character name*(*) - type(putfun_node), pointer :: lrot - integer nsymb,idot - integer iarr(10,*) -!\end{verbatim} %+ - integer jf,jg -! write(*,*)'25D: store_putfun ',nsvfun - nsvfun=nsvfun+1 - if(nsymb.gt.0) then - allocate(svflista(nsvfun)%formal_arguments(10,nsymb)) - idot=10 -! dot derivatives have two consequtive symbols for the variable before/after - do jf=1,nsymb -! the order is: 1: state variable (negative means index to another symbol) -! 2-5: norm, unit, phref, argtyp, -! 6-10: phase, compset, component, constituent, derivative - do jg=1,idot - svflista(nsvfun)%formal_arguments(jg,jf)=iarr(jg,jf) - enddo -! write(*,77)(iarr(jg,jf),jg=1,idot) -77 format('25F: store_putfun: ',20i3) - enddo - endif - svflista(nsvfun)%name=name - svflista(nsvfun)%linkpnode=>lrot - svflista(nsvfun)%status=0 - svflista(nsvfun)%narg=nsymb -! this is the number of actual argument needed (like @P, @C and @S) - svflista(nsvfun)%nactarg=0 -! eqnoval indicate which equilibrium to use to get its value. -! default is 0 meaning current equilibria, can be changed by AMEND SYMBOL - svflista(nsvfun)%eqnoval=0 -1000 continue - return - end subroutine store_putfun - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine store_putfun_old(name,lrot,nsymb,& - istv,indstv,iref,iunit,idot) -! enter an expression of state variables -! name: character, name of state variable function -! lrot: pointer, to a putfun_node that is the root of the stored expression -! nsymb: integer, number of formal arguments -! istv: integer array, formal argument state variables typ -! indstv: 2D integer array, indices for the formal state variables -! iref: integer array, reference for the formal state variables -! iunit: integer array, unit of the formal state variables - implicit none - type(putfun_node), pointer :: lrot - integer nsymb - integer, dimension(*) :: istv,iref,iunit,idot - integer, dimension(4,*) :: indstv - character name*(*) -!\end{verbatim} - integer jf -! write(*,*)'store_putfun ',nsvfun - nsvfun=nsvfun+1 - if(nsymb.gt.0) then - allocate(svflista(nsvfun)%formal_arguments(10,nsymb)) - do jf=1,nsymb - svflista(nsvfun)%formal_arguments(1,jf)=istv(jf) - svflista(nsvfun)%formal_arguments(2,jf)=indstv(1,jf) - svflista(nsvfun)%formal_arguments(3,jf)=indstv(2,jf) - svflista(nsvfun)%formal_arguments(4,jf)=indstv(3,jf) - svflista(nsvfun)%formal_arguments(5,jf)=indstv(4,jf) - svflista(nsvfun)%formal_arguments(6,jf)=iref(jf) - svflista(nsvfun)%formal_arguments(7,jf)=iunit(jf) - svflista(nsvfun)%formal_arguments(8,jf)=idot(jf) - enddo - endif - svflista(nsvfun)%name=name - svflista(nsvfun)%linkpnode=>lrot - svflista(nsvfun)%status=0 - svflista(nsvfun)%narg=nsymb -! this is the number of actual argument needed (like @P, @C and @S) - svflista(nsvfun)%nactarg=0 -! eqnoval indicate which equilibrium to use to get its value. -! default is 0 meaning current equilibria, can be changed by AMEND SYMBOL - svflista(nsvfun)%eqnoval=0 -1000 continue - return - end subroutine store_putfun_old - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine find_svfun(name,lrot,ceq) -! finds a state variable function called name (no abbreviations) - implicit none - character name*(*) - integer lrot - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} %+ -! name must be in UPPER CASE and exact match required - do lrot=1,nsvfun - if(name.eq.svflista(lrot)%name) goto 500 - enddo - write(*,*)'No such symbol: ',name - gx%bmperr=8888; goto 1000 -! -500 continue -! nothing more to do! -1000 continue - return - end subroutine find_svfun - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} %- - subroutine list_svfun(text,ipos,lrot,ceq) -! list a state variable function - implicit none - character text*(*) - integer ipos,lrot - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} -! copied svflista(lrot)%formal_arguments(2..5,jt) to indices as gfortran error -! integer indstv(4) - type(gtp_state_variable), pointer :: svr - character symbols(20)*32,afterdot*32 - integer js,jt,ip,istv,kl -! write(*,*)'list_svfun 1:',svflista(lrot)%narg - if(lrot.le.0 .or. lrot.gt.nsvfun) then - gx%bmperr=4140; goto 1000 - endif - if(svflista(lrot)%narg.eq.0) goto 500 - js=0 - jt=0 -100 continue - jt=jt+1 - js=js+1 - ip=1 - symbols(js)=' ' - istv=svflista(lrot)%formal_arguments(1,jt) - if(istv.lt.0) then -! function refer to another function - symbols(js)=svflista(-istv)%name - else -! the 1:10 was a new bug discovered in GNU fortran 4.7 and later - call make_stvrec(svr,svflista(lrot)%formal_arguments(1:10,jt)) - call encode_state_variable(symbols(js),ip,svr,ceq) - if(svflista(lrot)%formal_arguments(10,jt).ne.0) then -! a derivative!!! -! write(*,111)'A dot derivative of ',js,jt,symbols(js) -111 format(a,2i3,': ',a) - jt=jt+1 - afterdot=' ' - ip=1 - call make_stvrec(svr,svflista(lrot)%formal_arguments(1:10,jt)) - call encode_state_variable(afterdot,ip,svr,ceq) -! write(*,111)'wrt state variable ',js,jt,afterdot - symbols(js)=symbols(js)(1:len_trim(symbols(js)))//'.'//afterdot -! write(*,111)'alltogether ',js,jt,symbols(js) - endif - endif - if(jt.lt.svflista(lrot)%narg) goto 100 -500 continue - kl=len_trim(svflista(lrot)%name) - text(ipos:ipos+kl+1)=svflista(lrot)%name(1:kl)//'= ' - ipos=ipos+kl+2 - call wrtfun(text,ipos,svflista(lrot)%linkpnode,symbols) -! where is pfnerr defined?? - if(pfnerr.ne.0) then - write(kou,*)'Putfun error listing funtion ',pfnerr - gx%bmperr=4142; goto 1000 - endif -! text(ipos:ipos)=';' -! ipos=ipos+1 -1000 continue - return - end subroutine list_svfun - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine make_stvrec(svr,iarr) -! stores appropriate values from a formal argument list to a state variable -! function in a state variable record - implicit none - type(gtp_state_variable), pointer :: svr - integer iarr(10) -!\end{verbatim} - integer jt,norm -! - allocate(svr) - if(iarr(1).lt.10) then -! This is T, P, MU, AC, LNAC -! 1 2 3 4 5 - svr%statevarid=iarr(1) - else -! This is U, S, V, H, A, G, NP, BP, DG, Q, N, X, B, W, Y symbol -! 6 7 8 9 10, 11, 12, 13, 14, 15, 16, 17, 18, 19. 20 new code -! 10 20 30 40 50 60 70 80 90 100 110 111 120 122 130 old code -! dvs iarr()=10 means U etc. - jt=iarr(1)/10+5 - norm=mod(iarr(1),10) -! special for x and w, note norm is set to normallizing - if(jt.eq.16 .and. norm.eq.1) jt=17 - if(jt.eq.18 .and. norm.eq.2) jt=19 - svr%statevarid=jt -! write(*,*)'25D make: ',iarr(1),jt - endif -! write(*,11)iarr -11 format('Arguments: ',10i5) -! Not implemented handling of property symbols like TC, BMAGN etc - svr%oldstv=iarr(1) - svr%norm=iarr(2) - svr%unit=iarr(3) - svr%phref=iarr(4) - svr%argtyp=iarr(5) - svr%phase=iarr(6) - svr%compset=iarr(7) - svr%component=iarr(8) - svr%constituent=iarr(9) -1000 continue - return - end subroutine make_stvrec - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine list_all_svfun(kou,ceq) -! list all state variable funtions - implicit none - integer kou - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - character text*256 - integer ks,ipos - write(kou,17) -17 format('List of all state variable symbols'/' No Name = expression ;') - do ks=1,nsvfun - ipos=1 - call list_svfun(text,ipos,ks,ceq) - if(pfnerr.ne.0) then - gx%bmperr=4142; pfnerr=0; goto 1000 - endif - write(kou,76)ks,text(1:ipos-1) -76 format(i3,2x,a) - enddo -1000 continue - return - end subroutine list_all_svfun - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine evaluate_all_svfun_old(kou,ceq) -! THIS SUBROUTINE MOVED TO MINIMIZER -! evaluate and list values of all functions - implicit none - integer kou - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} %+ - character actual_arg(10)*24 - integer kf - double precision val - write(kou,75) -75 format('No Name ',12x,'Value') - do kf=1,nsvfun -! actual arguments needed if svflista(kf)%nactarg>0 - val=evaluate_svfun_old(kf,actual_arg,0,ceq) - if(gx%bmperr.ne.0) goto 1000 - write(kou,77)kf,svflista(kf)%name,val -77 format(i3,1x,a,1x,1PE15.8) - enddo -1000 continue - return - end subroutine evaluate_all_svfun_old - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} %- - double precision function evaluate_svfun_old(lrot,actual_arg,mode,ceq) -! THIS SUBROUTINE MOVED TO MINIMIZER -! but needed in some cases in this module ... ??? -! envaluate all funtions as they may depend on each other -! actual_arg are names of phases, components or species as @Pi, @Ci and @Si -! needed in some deferred formal parameters (NOT IMPLEMENTED YET) - implicit none - integer lrot,mode - character actual_arg(*)*(*) - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - double precision argval(20) - type(gtp_state_variable), pointer :: svr,svr2 - integer jv,jt,istv,ieq - double precision value - argval=zero -! write(*,*)'evaluate_svfun ',lrot,svflista(lrot)%narg,svflista(lrot)%name -! locate function - if(lrot.le.0 .or. lrot.gt.nsvfun) then - gx%bmperr=4140; goto 1000 - endif - if(svflista(lrot)%narg.eq.0) goto 300 -! get values of arguments - jv=0 - jt=0 -100 continue - jt=jt+1 - istv=svflista(lrot)%formal_arguments(1,jt) - if(istv.lt.0) then -! if eqnoval nonzero it indicates from which equilibrium to get its value - ieq=svflista(lrot)%eqnoval - if(ieq.eq.0) then - value=ceq%svfunres(-istv) - else - value=eqlista(ieq)%svfunres(-istv) - endif -! write(*,*)'evaluate_svfun symbol',ieq,value - else -! the 1:10 was a new bug discovered in GNU fortran 4.7 and later - call make_stvrec(svr,svflista(lrot)%formal_arguments(1:10,jt)) - if(gx%bmperr.ne.0) goto 1000 - if(svflista(lrot)%formal_arguments(10,jt).eq.0) then -! get state variable value - call state_variable_val(svr,value,ceq) - else -! state variable derivative, error code here should be handelled by calling -! routine and use meq_evaluate_evaluate -! write(*,*)'In evaluate_svfun_old!!!' -! write(*,*)'Use "calculate symbol" for state variable derivatives!' - gx%bmperr=8888 -! call make_stvrec(svr2,svflista(lrot)%formal_arguments(1:10,jt)) -! call state_var_value_derivative(svr,svr2,value,ceq) -! call meq_state_var_value_derivative(svr,svr2,value,ceq) - endif - if(gx%bmperr.ne.0) goto 1000 - endif - jv=jv+1 - argval(jv)=value - if(jt.lt.svflista(lrot)%narg) goto 100 -! all arguments evaluated (or no arguments needed) -300 continue -! write(*,333)'evaluate_svfun ',svflista(lrot)%name,argval(1),argval(2) -!333 format(a,a,2(1PE15.6)) -! write(*,340)'evaluate svfun 1: ',mode,lrot -340 format(a,5i4) - modeval: if(mode.eq.0 .and. btest(svflista(lrot)%status,SVFVAL)) then -! If mode=0 and SVFVAL set return the stored value - value=ceq%svfunres(lrot) -! write(*,350)'evaluate svfun 2: ',0,lrot,value - elseif(mode.eq.0 .and. btest(svflista(lrot)%status,SVFEXT)) then -! if mode=0 and SVFEXT set use value from equilibrium eqno - ieq=svflista(lrot)%eqnoval - if(ceq%eqno.eq.ieq) then - value=evalf(svflista(lrot)%linkpnode,argval) - if(pfnerr.ne.0) then - write(*,*)'evaluate_svfun putfunerror ',pfnerr - gx%bmperr=4141; goto 1000 - endif - ceq%svfunres(lrot)=value -! write(*,350)'evaluate svfun 3: ',ieq,lrot,value - else - value=eqlista(ieq)%svfunres(lrot) - endif -! write(*,350)'evaluate svfun 4: ',ieq,lrot,value -350 format(a,2i3,1pe12.4) - else -! if mode=1 always evaluate - value=evalf(svflista(lrot)%linkpnode,argval) - if(pfnerr.ne.0) then - write(*,*)'evaluate_svfun putfunerror ',pfnerr - gx%bmperr=4141; goto 1000 - endif - endif modeval -! save value in current equilibrium -! write(*,*)'25D eval_svfun: ',lrot,value,size(ceq%svfunres) - ceq%svfunres(lrot)=value - evaluate_svfun_old=value -1000 continue - return - end function evaluate_svfun_old - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ -!> 9. Interactive things -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine ask_phase_constitution(cline,last,iph,ics,lokcs,ceq) -! interactive input constitution of phase iph - implicit none - integer last,iph,ics,lokcs - character cline*(*) -!\end{verbatim} - character name1*24,quest*32 - double precision yarr(maxcons2),sites(maxsubl),qq(5),yyy,xxx,sss,ydef - integer knl(maxsubl),knr(maxcons2) - character line*64,ch1*1 - character*1 :: chd='Y' - integer qph,lokph,nsl,kkk,loksp,ip,ll,nr - TYPE(gtp_equilibrium_data), pointer :: ceq - logical once -! save here to use the same default as last time - save chd - call gparc('Phase name: ',cline,last,1,name1,' ',q1help) - if(name1(1:2).eq.'* ') then -! this means all phases and composition sets - qph=-1 - iph=1 - ics=1 - call get_phase_name(iph,ics,name1) - if(gx%bmperr.ne.0) goto 1000 - else - qph=0 - call find_phase_by_name(name1,iph,ics) - if(gx%bmperr.ne.0) goto 1000 - endif -100 continue -! write(*,*)'spc 1',qph,iph,ics,name1 -! skip hidden and suspended phases, test_phase_status return -! old 1=entered, 2=fix, 3=dormant, 4=suspended, 5=hidden -! if(qph.lt.0 .and. test_phase_status(iph,ics,xxx,ceq).gt.3) goto 200 -! -4 hidden, -3 suspend, -2 dormant, -1,0, entered, 2 fixed - if(qph.lt.0 .and. test_phase_status(iph,ics,xxx,ceq).le.PHDORM) goto 200 -! if(qph.lt.0 .and. (phase_status(iph,ics,PHHID,ceq) .or.& -! phase_status(iph,ics,PHIMHID,ceq) .or.& -! (phase_status(iph,ics,CSSUS,ceq) .and. & -! .not.phase_status(iph,ics,CSFIXDORM,ceq)))) goto 200 -! lokph=phases(iph) - call get_phase_compset(iph,ics,lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 - call get_phase_data(iph,ics,nsl,knl,knr,yarr,sites,qq,ceq) - if(gx%bmperr.ne.0) goto 1000 -! ask for amount of formula units, default is current amount - yyy=ceq%phase_varres(lokcs)%amfu - quest='Amount of '//name1 - call gparrd(quest,cline,last,xxx,yyy,q1help) -! if input error quit asking more - if(buperr.ne.0) then - buperr=0; goto 1000 - endif - ceq%phase_varres(lokcs)%amfu=xxx -! ask if we should set the default constitution - call gparcd('Default constitution?',cline,last,1,ch1,chd,q1help) - if(ch1.eq.'Y' .or. ch1.eq.'y') then - call set_default_constitution(iph,ics,ceq) - if(gx%bmperr.ne.0) goto 1000 - chd='Y' - goto 200 - else - chd='N' - endif -! ask for constitution - kkk=0 - nylat: do ll=1,nsl - sss=one - ydef=one - nycon: do nr=1,knl(ll)-1 - kkk=kkk+1 - loksp=phlista(lokph)%constitlist(kkk) - line='Fraction of '//splista(loksp)%symbol - ip=len_trim(line)+1 - if(ll.gt.1) then - line(ip:)='#'//char(ll+ichar('0')) - ip=ip+2 - endif - once=.true. -20 continue - ydef=min(yarr(kkk),ydef) - call gparrd(line(1:ip+2),cline,last,xxx,ydef,q1help) - if(xxx.lt.zero) then - if(once) then - write(*,*)'A Fraction must be greater than zero' - yarr(kkk)=1.0D-12 - once=.false. - goto 20 - else - gx%bmperr=4146; goto 1000 - endif - endif - sss=sss-xxx - if(sss.lt.zero) then - xxx=max(sss+xxx,1.0D-12) - sss=-1.0D12 - write(*,21)'Sum of fractions larger 1.0, fraction set to: ',xxx -21 format(a,1pe12.4) - ydef=1.0D-12 - else - ydef=sss - endif -! write(*,*)'ydef: ',ydef,sss - yarr(kkk)=xxx - enddo nycon -! the last constituent is set to the rest - kkk=kkk+1 - yarr(kkk)=max(sss,1.0D-12) - write(*,21)'Last fraction set to: ',yarr(kkk) - enddo nylat -! set the new constitution - call set_constitution(iph,ics,yarr,qq,ceq) -! if all phases loop -200 continue - if(qph.lt.0) then - if(gx%bmperr.eq.4050) then -! error no such phase, quit - gx%bmperr=0; goto 1000 - elseif(gx%bmperr.eq.4072) then -! error no such composition set, take next phase - gx%bmperr=0 - iph=iph+1 - ics=1 - else - ics=ics+1 - endif - call get_phase_name(iph,ics,name1) - if(gx%bmperr.ne.0) goto 200 - goto 100 - endif -1000 continue -! return -1 as phase number of loop for all phases made - if(qph.lt.0) iph=-1 - return - end subroutine ask_phase_constitution - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine enter_parameter_interactivly(cline,ip) -! enter a parameter from terminal or macro -! NOTE both for ordered and disordered fraction set !! - implicit none - integer ip - character cline*(*) -!\end{verbatim} - character name1*24,name2*24,longline*256,refx*16,elnam*24 - character name3*64,ch1*1,line*64,parname*64 - integer typty,lint(2,5),fractyp,typty1,kp,lp1,kel,kq,iel,isp,lk3,lp2 - integer jph,ics,lokph,ll,k4,nint,jp,lsc,ideg,kk,lfun,nsl,loksp - integer, dimension(maxsubl) :: endm(maxsubl) - double precision xxx -! -10 continue - call gparc('Parameter name: ',cline,ip,7,parname,' ',q1help) -! simple parameter names are like G(SIGMA,FE:CR:FE,CR;1) - kp=index(parname,' ') - parname(kp:)=' ' -! extract symbol, normally G or L but TC and others can occur -! for example a mobility like MQ&FE+2#3 where FE+2#3 is a constinuent -! in sublattice 3 - lp1=index(parname,'(') - if(lp1.le.1) then - gx%bmperr=4027; goto 1000 - endif -! name1 is everything up to ( - name1=parname(1:lp1-1) - call capson(name1) -! It can be a mobility with a & inside - kel=index(name1,'&') - if(kel.gt.0) then -! note that elnam may contain sublattice specification like Fe+2#2 - elnam=name1(kel+1:) - name1=name1(1:kel-1) - endif - kq=len_trim(name1) -! write(*,*)'25D: fractyp: ',kq,name1(1:kq) - if(name1(kq:kq).eq.'D') then -! A final "D" on the paramer symbol indicates fractyp=2 - name1(kq:kq)=' ' - fractyp=2 - else - fractyp=1 - endif -! find the property associated with this symbol - do typty=1,ndefprop -! write(*,*)'Property symbol: "',propid(typty)%symbol,'"' - if(name1(1:4).eq.propid(typty)%symbol) then - goto 70 - endif - enddo -! no matching symbol - write(kou,*)'unknown parameter type, please reenter: ',& - name1(1:len_trim(name1)) - parname=' '; goto 10 -! -70 continue - typty1=typty - iel=0; isp=0 - if(kel.gt.0) then -! there is a specifier, check if correct element or species - kel=index(elnam,'#') - if(kel.gt.0) then -! extract sublattice number 1-9 specification - lk3=ichar(elnam(kel+1:kel+1))-ichar('0') -! write(*,73)elnam(kel+1:kel+1),kel,elnam,lk3 -!73 format('25D sublattice: "',a,'" position: ',i3,' in ',a,' : ',i3) - elnam(kel:)=' ' - endif - if(btest(propid(typty)%status,IDELSUFFIX)) then -! write(*,*)'25D: elnam: ',kel,lk3,typty,elnam - call find_element_by_name(elnam,iel) - if(gx%bmperr.ne.0) then - write(kou,*)'Unknown element ',elnam,& - ' in parameter type MQ, please reenter' - parname=' '; gx%bmperr=0; goto 10 - endif - typty=100*typty+iel - elseif(btest(propid(typty)%status,IDCONSUFFIX)) then -! to know the constituents we must know the phase but as we do not know -! the phase name yet but check the species exists !!! -! write(*,*)'25D: conname: ',kel,lk3,typty,elnam - call find_species_by_name(elnam,isp) - if(gx%bmperr.ne.0) then - write(kou,*)'Unknown species ',elnam,& - ' in parameter type MQ, please reenter',gx%bmperr - parname=' '; gx%bmperr=0; goto 10 - endif -! convert from index to location, loksp - loksp=species(isp) -! extract sublattice after # - else - write(kou,*)'This property has no specifier' - gx%bmperr=4168; goto 1000 - endif -! this is the property type stored in property record - else -! check if there should be a specifier !! - if(btest(propid(typty)%status,IDELSUFFIX) .or. & - btest(propid(typty)%status,IDCONSUFFIX)) then - write(*,*)'Parameter specifier missing' - gx%bmperr=4169; goto 1000 - endif - endif -! -! extract phase name and constituent array - lp1=index(parname,'(') - lp2=index(parname,',') - if(lp2.lt.lp1) then - gx%bmperr=4028; goto 1000 - endif - name2=parname(lp1+1:lp2-1) -! write(*,*)'enter_parameter_inter 1: ',lp1,lp2,name2 - call find_phase_by_name_exact(name2,jph,ics) - if(gx%bmperr.ne.0) then -! special case for reference phase - gx%bmperr=0; - call capson(name2) - if(name2.eq.'SELECT_ELEMENT_REFERENCE') then - jph=0; ics=1 - else - write(kou,*)'unknown phase name, please reenter' - kp=len(cline) - goto 10 - endif - endif - lokph=phases(jph) -! if the parameter symbol has a constituent specification check that now - if(isp.gt.0) then - k4=0 - do ll=1,phlista(lokph)%noofsubl - if(lk3.eq.0 .or. lk3.eq.ll) then - do kk=1,phlista(lokph)%nooffr(ll) - k4=k4+1 - if(phlista(lokph)%constitlist(k4).eq.loksp) goto 80 - enddo - elseif(ll.lt.lk3) then - k4=k4+phlista(lokph)%nooffr(ll) - endif - enddo -! constituent not found - write(kou,*)'No such constituent' - gx%bmperr=4066; goto 1000 -! constituent found in right sublattice -80 continue - typty=100*typty+k4 -! write(*,81)'25D: found: ',typty1,typty,lk3,k4,loksp -81 format(a,10i4) - endif -! write(*,*)'enter_parameter_inter 2: ',jph,lokph -! extract constituent array, remove final ) and decode - name3=parname(lp2+1:) - lp1=len_trim(name3) -! this removes the final ) - name3(lp1:)=' ' -! - call decode_constarr(lokph,name3,nsl,endm,nint,lint,ideg) - if(gx%bmperr.ne.0) goto 1000 -! write(*,83)'after d_c: ',name3(1:lp1),nint,(lint(2,kp),kp=1,nint) -83 format(a,a,i5,2x,5i4) -! finally remove all non-alphabetical characters in the function name by _ - kp=0 -100 continue - kp=kp+1 -105 continue - ch1=parname(kp:kp) -! should use ?? -! if(ucletter(ch1)) goto 100 - if(ch1.ge.'A' .and. ch1.le.'Z') goto 100 - if(ch1.ne.' ') then - parname(kp:)=parname(kp+1:) - goto 105 - endif - parname='_'//parname -!------------------------------------------------- -! If parameter has no T dependendence just ask for value - if(btest(propid(typty1)%status,IDNOTP)) then - write(kou,*)'This parameter can only be a constant' - call gparr('Value: ',cline,ip,xxx,zero,q1help) - if(buperr.ne.0) then - xxx=zero; buperr=0 - endif -! the tpfun always want a low T, expression; high T N - write(longline,110)xxx -110 format(' 1 ',1pe16.7,'; 20000 N ') - jp=len_trim(longline)+2 - goto 200 - endif - if(btest(propid(typty1)%status,IDONLYP)) then - write(kou,*)'This parameter may not depend on T, only on P' - endif -!------------------------------------------------- -! now read the function. - call gparr('Low temperature limit /298.15/:',cline,ip,xxx,2.9815D2,q1help) - if(buperr.ne.0) then - buperr=0; longline=' 298.15 ' - jp=8 - else - longline=' ' - jp=1 - call wrinum(longline,jp,8,0,xxx) - if(buperr.ne.0) goto 1000 - jp=jp+1 - endif -! write(*,152)-1,jp,longline(1:jp) -!----------------------------------------------- -! return here for new expression in another range - lsc=1 -115 continue - call gparc('Expression, end with ";":',cline,ip,6,line,';',q1help) - if(buperr.ne.0) then - buperr=0; line=';' - endif -120 continue - longline(jp:)=line - jp=len_trim(longline)+1 -! write(*,152)0,jp,longline(1:jp) - if(index(longline(lsc:),';').le.0) then - call gparc('&',cline,ip,6,line,';',q1help) - if(buperr.ne.0) then - buperr=0; line=';' - endif - goto 120 -! else -! write(*,*)'Found ; at ',index(longline,';') - endif -150 continue - jp=jp+1 -! write(*,152)0,jp,longline(1:jp) -! lsc is positioned after the ; of previous ranges - lsc=jp -! write(*,152)1,ip,cline(1:ip) - call gparr('Upper temperature limit /6000/:',cline,ip,xxx,6.0D3,q1help) - if(buperr.ne.0) then - buperr=0; xxx=6.0D3 - endif - call wrinum(longline,jp,8,0,xxx) - if(buperr.ne.0) goto 1000 - call gparcd('Any more ranges',cline,ip,1,ch1,'N',q1help) - if(ch1.eq.'n' .or. ch1.eq.'N') then - longline(jp:)=' N' - jp=jp+3 - else - longline(jp:)='Y' - jp=jp+2 - goto 115 - endif -! jump here for parameters that are constants -200 continue - call gparcd('Reference symbol:',cline,ip,1,refx,'UNKNOWN',q1help) - call capson(refx) - longline(jp:)=refx - jp=len_trim(longline)+1 -! write(*,252)2,jp,longline(1:jp) -252 format('ep: ',2i3,'>',a,'<') -! - call capson(longline(1:jp)) -! write(*,*)'epi: ',longline(1:jp) - call enter_tpfun(parname,longline,lfun,.FALSE.) - if(gx%bmperr.ne.0) goto 1000 -! write(*,290)'enter_par 7: ',lokph,nsl,nint,ideg,lfun,refx -290 format(a,5i4,1x,a) -! - call enter_parameter(lokph,typty,fractyp,nsl,endm,nint,lint,ideg,lfun,refx) -! -1000 continue - return - end subroutine enter_parameter_interactivly - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine amend_global_data(cline,ipos) - implicit none - character cline*(*) - integer ipos -!\end{verbatim} - character name*24,current*24,ch1*1,chd*1 - current=globaldata%name -! write(*,*)'entering amend_global_data: ',cline(1:30) - call gparcd('System name: ',cline,ipos,1,name,current,q1help) - if(proper_symbol_name(name,0)) then - globaldata%name=name - else - write(kou,*)'Illegal name ignored' - goto 1000 - endif -100 continue - chd='N' - if(btest(globaldata%status,GSBEG)) then - chd='B' - elseif(btest(globaldata%status,GSADV)) then - chd='E' - else - chd='F' - endif - call gparcd('I am a beginner (B), freqent user (F) or expert (E): ',& - cline,ipos,1,ch1,chd,q1help) - call capson(ch1) - globaldata%status=ibclr(globaldata%status,GSBEG) - globaldata%status=ibclr(globaldata%status,GSADV) - globaldata%status=ibclr(globaldata%status,GSOCC) - if(ch1.eq.'B') then - globaldata%status=ibset(globaldata%status,GSBEG) - elseif(ch1.eq.'E') then - globaldata%status=ibset(globaldata%status,GSADV) - else - globaldata%status=ibset(globaldata%status,GSOCC) - endif -120 continue -! is global minimization allowed? - chd='Y' - if(btest(globaldata%status,GSNOGLOB)) chd='N' - call gparcd('Global gridminimization allowed: ',& - cline,ipos,1,ch1,chd,q1help) - if(ch1.eq.'Y' .or. ch1.eq.'y') then - globaldata%status=ibclr(globaldata%status,GSNOGLOB) - else - globaldata%status=ibset(globaldata%status,GSNOGLOB) - endif -! allow merging gridpoints after global? - chd='Y' - if(btest(globaldata%status,GSNOMERGE)) chd='N' - call gparcd('Merging gridpoints in same phase allowed: ',& - cline,ipos,1,ch1,chd,q1help) - if(ch1.eq.'Y' .or. ch1.eq.'y') then - globaldata%status=ibclr(globaldata%status,GSNOMERGE) - else - globaldata%status=ibset(globaldata%status,GSNOMERGE) - endif -! GSNOACS can be changed interactivly, 0 means allowed - chd='Y' - if(btest(globaldata%status,GSNOACS)) chd='N' - call gparcd('Composition sets can be created automatically? ',& - cline,ipos,1,ch1,chd,q1help) - if(ch1.eq.'Y' .or. ch1.eq.'y') then - globaldata%status=ibclr(globaldata%status,GSNOACS) - else - globaldata%status=ibset(globaldata%status,GSNOACS) - endif -! GSNOREMCS can be changed interactivly, 0 means not remove - chd='Y' - if(btest(globaldata%status,GSNOREMCS)) chd='N' - call gparcd('Delete unnecessary composition sets automatically? ',& - cline,ipos,1,ch1,chd,q1help) - if(ch1.eq.'Y' .or. ch1.eq.'y') then - globaldata%status=ibclr(globaldata%status,GSNOREMCS) - else - globaldata%status=ibset(globaldata%status,GSNOREMCS) - endif -1000 continue - return - end subroutine amend_global_data - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine enter_reference_interactivly(cline,last,mode,iref) -! enter a reference for a parameter interactivly -! this should be modified to allow amending an existing reference - implicit none - character cline*(*) - integer last,mode,iref -!\end{verbatim} -! stupid with a variable called L80 - character line*256,refid*16,L80*80 - integer jl,ip - call gparc('Reference identifier:',cline,last,1,refid,' ',q1help) - if(buperr.ne.0 .or. refid(1:1).eq.' ') then -! write(kou,*)'There must be an identifier' - gx%bmperr=4155; goto 1000 - endif - call capson(refid) -! check if unique, if mode=0 illegal - do jl=1,reffree-1 - if(refid.eq.bibrefs(jl)%reference) then - if(mode.eq.0) then -! write(kou,*)'Reference identifier not unique' - gx%bmperr=4156;goto 1000 - else - goto 70 - endif - endif - enddo -! if mode=1 one should have found the reference - if(mode.eq.1) then - write(kou,*)'No such reference' - goto 1000 - endif -70 continue - ip=1 - line=' ' -100 continue - call gparc('Reference text, end with ";":',cline,last,5,l80,';',q1help) - line(ip:)=l80 - ip=len_trim(line) - if(ip.le.1) then - write(kou,*)'There must be some reference text!' - ip=1; goto 100 - elseif(line(ip:ip).ne.';') then - ip=ip+1; goto 100 - else - line(ip:)=' ' - endif - call tdbrefs(refid,line,1,iref) -1000 continue - return - end subroutine enter_reference_interactivly - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine set_condition(cline,ip,ceq) -! decode an equilibrium condition, can be an expression with + and - -! the expression should be terminated with an = or value supplied on next line -! like "T=1000", "x(liq,s)-x(pyrrh,s)=0", "2*mu(cr)-3*mu(o)=muval" -! It can also be a "NOFIX=" or "FIX= value" -! The routine should also accept conditions identified with the ":" -! where is that preceeding each condition in a list_condition -! It should also accept changing conditions by :=new_value - implicit none - integer ip - character cline*(*) - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer nterm,kolon,iqz,krp,jp,istv,iref,iunit,jstv,jref,junit,jl,ks - integer linkix,norem,ics,kstv,iph,nidfirst,nidlast,nidpre,qp - character stvexp*80,stvrest*80,textval*32,c4*4 - character svtext*60,encoded*60,defval*18 - integer indices(4),allterms(4,10),condno,seqz - double precision coeffs(10),xxx,value - logical inactivate - type(gtp_state_variable), pointer :: svr - type(gtp_state_variable), dimension(10), target :: svrarr - TYPE(gtp_condition), pointer :: temp,new -50 continue -! extract symbol like T, X(FCC,CR), MU(C) etc up to space, +, - or = sign - stvexp=' ' - call gparcd('State variable: ',cline,ip,ichar('='),stvexp,'T',q1help) -! can there be any error return?? - if(buperr.ne.0) goto 1000 -! write(*,*)'in set_condition: ',ip,stvexp(1:20) -! is the line empty? - if(stvexp(1:1).eq.' ') then - gx%bmperr=4126; goto 1000 - endif -! write(*,*)'set_cond 0: ',stvexp(1:20) - nterm=0 -! check if there is a ":" in stvexp -! write(*,*)'set_condition: ',stvexp(1:40),ip - condno=0 - kolon=index(stvexp,':') - if(kolon.gt.0) then -! write(*,*)'25D: Found colon: ',kolon,stvexp(1:20) -! if(len_trim(stvexp).gt.kolon) then -! is there any text after : ignore the text before ": " WHY???? -! stvexp=stvexp(kolon+2:) -! else -! the user specifies the condition by giving its number like "5:=none" - iqz=1 - call getrel(stvexp,iqz,xxx) - if(buperr.ne.0) then - gx%bmperr=buperr; goto 1000 - endif - condno=int(xxx) -! write(*,*)'25D: Found condition number: ',condno,ip -! We cannot provide any default value - defval=' ' - goto 157 -! goto 155 -! endif - endif - if(stvexp(1:1).eq.'*') then -! user can remove all conditions (except phase status) by the line -! *=NONE - condno=-1 - goto 157 - endif -! check for phase status FIX or NOFIX, these are generated by change_status -! not given by user - if(stvexp(1:3).eq.'FIX') then - inactivate=.FALSE. - goto 300 - elseif(stvexp(1:5).eq.'NOFIX') then - inactivate=.TRUE. -! write(*,*)'25D Inactivate phase fix condition' - goto 300 - endif -! check if it is an expression with + or - -100 continue -! look for a ) followed by + or - - krp=index(stvexp,')') - if(krp.gt.0) then - if(stvexp(krp+1:krp+1).eq.'+' .or. stvexp(krp+1:krp+1).eq.'-') then - stvrest=stvexp(krp+1:) - stvexp(krp+1:)=' ' - else - stvrest=' ' - endif - else - stvrest=' ' - endif -! write(*,*)'set_cond 2: ',krp,stvexp(1:20),':',stvrest(1:20) -! there can be a factor in front of the state variable - jp=1 - call getrel(stvexp,jp,xxx) - if(buperr.ne.0) then -! write(*,*)'buperr ',buperr,jp -! 1035 and 1036 means a sign not followed by digits - if(buperr.eq.1035) then - xxx=one - stvexp=stvexp(2:) - elseif(buperr.eq.1036) then - xxx=-one - stvexp=stvexp(2:) - else - xxx=one - endif - buperr=0 - else - if(stvexp(jp:jp).eq.'*') then - stvexp=stvexp(jp+1:) - else - gx%bmperr=4130; goto 1000 - endif - endif -! decode state variable expression -! write(*,*)'25D, calling decode ',stvexp(1:20) -! call decode_state_variable(stvexp,istv,indices,iref,iunit,svr,ceq) - call decode_state_variable(stvexp,svr,ceq) - if(gx%bmperr.ne.0) goto 1000 - svtext=stvexp -! convert to old format -! if(svr%oldstv.ge.10) then -! istv=10*(svr%oldstv-5)+svr%norm -! else - istv=svr%oldstv -! endif - iref=svr%phref - iunit=svr%unit -! svr%argtyp specifies values in indices: -! svr%argtyp: 0=no arguments; 1=comp; 2=ph+cs; 3=ph+cs+comp; 4=ph+cs+const - indices=0 - if(svr%argtyp.eq.1) then - indices(1)=svr%component - elseif(svr%argtyp.eq.2) then - indices(1)=svr%phase - indices(2)=svr%compset - elseif(svr%argtyp.eq.3) then - indices(1)=svr%phase - indices(2)=svr%compset - indices(3)=svr%component - elseif(svr%argtyp.eq.4) then - indices(1)=svr%phase - indices(2)=svr%compset - indices(3)=svr%constituent -! else -! write(*,*)'state variable has illegal argtyp: ',svr%argtyp -! gx%bmperr=7775; goto 1000 - endif -! - if(istv.lt.0) then -! istv < 0 means it is a parameter property symbol like TC, illegal as cond - gx%bmperr=4127; goto 1000 - endif -! Use kstv=(istv+1)/10+5 as check - kstv=(istv+1)/10+5 -! write(*,*)'condition code: ',istv,kstv -! if(kstv.eq.14 .or. kstv.eq.15 .or. kstv.ge.19) then - if(kstv.eq.14 .or. kstv.eq.15) then -! the state variables Q and DG are illegal as conditions - gx%bmperr=4127; goto 1000 - endif -! write(*,117)stvexp(1:10),istv,indices -!117 format('25D, sc: ',a,i7,5x,4i3) - if(istv.ge.3 .and. istv.le.5) then -! this is MU, AC and LNAC, do not allow phase index (at present) - if(indices(2).ne.0) then - write(*,*)'Phase specific chemical potentials not allowed as conditions' - gx%bmperr=7777; goto 1000 - endif - endif - if(nterm.gt.0) then -! it must be the same state variable in all terms - if(istv.ne.jstv .or. iref.ne.jref .or. iunit.ne.junit) then - gx%bmperr=4128; goto 1000 - endif - else - jstv=istv - jref=iref - junit=iunit - endif - nterm=nterm+1 -! save svr record if several terms - svrarr(nterm)=svr - coeffs(nterm)=xxx - do jl=1,4 - allterms(jl,nterm)=indices(jl) - enddo - stvexp=stvrest -! write(*,*)'set_cond rest "',stvrest(1:20),'"' - jp=1 - if(.not.eolch(stvexp,jp)) goto 100 -!--------------- -150 continue -! the expression (or single variable) is decoded, get value after = sign -! provide the current value as default - encoded=' ' - call get_state_var_value(svtext,xxx,encoded,ceq) - if(gx%bmperr.ne.0) then -! This error occurs when setting the first compositions before any calculations -! write(*,152)gx%bmperr,svtext(1:len_trim(svtext)) -!152 format('Cannot get current value of: ',a,', error: ',i5/& -! 'Setting default value to zero') - gx%bmperr=0; xxx=zero - endif -! jump here if we have found a : specifying a condition number -! Do not expect any = sign -155 continue -! write(*,*)'25D we are here',ip - qp=1 - defval=' ' - call wrinum(defval,qp,10,0,xxx) - if(buperr.ne.0) then - buperr=0; defval=' ' - endif -157 continue -! write(*,*)'25D we are here: ',defval - call gparcd('Value: ',cline,ip,1,textval,defval,q1help) -! if(buperr.ne.0) then -! gx%bmperr=4129; buperr=0; goto 1000 -! endif -! value can be a symbol or a numeric value. Symbols not allowed yet -! write(*,*)'set_condition value ',textval(1:20) - inactivate=.false. - jp=1 - c4=textval(jp:jp+3) - call capson(c4) - if(c4.eq.'NONE') then -! value NONE means inactivate -! Problem when setting T=NONE, ceq%tpval(1) could have any value afterwards - inactivate=.true. -! write(*,*)'Inactivate condition: ',condno,value,xxx - value=xxx - else -! write(*,*)'Textval: ',textval - call getrel(textval,jp,value) - if(buperr.ne.0) then -! here one should look for a symbol - buperr=0 - call capson(textval) - do ks=1,nsvfun - if(textval(1:16).eq.svflista(ks)%name) then -! found symbol, insert link - linkix=ks - goto 170 - endif - enddo -! neither numeric value nor symbol, give error -! Some symbols must not be allowed for values ..... - gx%bmperr=4129; buperr=0; goto 1000 - else - linkix=-1 - endif -170 continue - endif -! check if condition already exists. If condno>0 it must exist or error - temp=>ceq%lastcondition -! write(*,*)'25D condno: ',condno,value,buperr - if(condno.eq.0) then -! call get_condition(nterm,coeffs,jstv,allterms,iref,iunit,temp) - call get_condition(nterm,svr,temp) - elseif(condno.lt.0) then - if(inactivate) then -! user has given *=NONE, remove all conditions except phase status FIX -! as inactive conditions are ignored just remove first acive until error - norem=1 -210 continue - temp=>ceq%lastcondition -! call get_condition(0,coeffs,norem,allterms,iref,iunit,temp) - call get_condition(nterm,svr,temp) - if(gx%bmperr.ne.0) then - gx%bmperr=0; goto 1000 - endif - if(temp%statev.gt.0) then -! write(*,*)'inactivate ',norem,temp%statev - temp%active=1 - endif - goto 210 -! no else path needed - endif - else -! user has given "5:= ..." and condition 5 must exist, otherwise error -! call get_condition(0,coeffs,condno,allterms,iref,iunit,temp) - qp=-condno -! write(*,*)'25D calling get_condition ',qp - call get_condition(qp,svr,temp) - if(gx%bmperr.ne.0) then - write(*,*)'Condition number error ',gx%bmperr - goto 1000 - endif - endif -277 continue -! write(*,*)'At label 277: ',gx%bmperr - newcond: if(gx%bmperr.ne.0) then -! condition does not exist, but if set equal to NONE just ignore it - gx%bmperr=0 - if(inactivate) goto 900 - else !newcond - if(inactivate) then -! remove condition - temp%active=1 -! write(*,*)'inactivating: ',ceq%tpval(1) - else -! condition already exist, just change value and activate - temp%active=0 - if(linkix.lt.0) then - temp%prescribed=value - temp%symlink1=-1 -! special for T and P, change the local value also -! write(*,*)'set condition ',istv,value - if(istv.eq.1) then - ceq%tpval(1)=value - elseif(istv.eq.2) then - ceq%tpval(2)=value - endif - else - temp%symlink1=linkix - endif - endif - goto 900 - endif newcond - goto 500 -!----------------------------------------------------------------- -! handle fix/nofix of a phase, a condition should be set inactive. -300 continue - ip=ip+1 -! write(*,*)'25D fix phase: ',ip,cline(ip:40) - call find_phase_by_name(cline(ip:),iph,ics) - if(gx%bmperr.ne.0) goto 1000 - nterm=1 - jstv=-iph - iref=ics - iunit=0 - linkix=-1 - coeffs(1)=1.0D0 - do jl=1,4 - allterms(jl,1)=0 - enddo -! convert to state variable -! write(*,*)'25D Setting svrarr(1) values' - svrarr(1)%statevarid=jstv - svrarr(1)%oldstv=jstv - svrarr(1)%phase=ics - svrarr(1)%unit=0 - svrarr(1)%argtyp=0 - svrarr(1)%phase=iph - svrarr(1)%compset=ics - svrarr(1)%component=0 - svrarr(1)%constituent=0 -! - temp=>ceq%lastcondition -! write(*,*)'25D calling get_condition' - svr=>svrarr(1) - call get_condition(nterm,svr,temp) -! write(*,*)'25D Back from get_condition ',gx%bmperr - if(gx%bmperr.eq.0) then - if(inactivate) then -! inactivate condition - temp%active=1 - else -! set new value of prescribed amount, must be numerical, not symbol - temp%active=0 - ip=index(cline,'==')+2 - call getrel(cline,ip,value) - if(buperr.ne.0) then -! write(*,*)'error setting fix amount old cond',ip,cline(1:40) - gx%bmperr=4100; goto 1000 - endif - temp%prescribed=value - temp%symlink1=-1 - endif - goto 1000 - else -! if inactivate it is an error not finding the condition -! write(*,*)'Finding condition error ',gx%bmperr - if(inactivate) then - write(*,*)'We should have found a condition ',gx%bmperr - goto 1000 - endif - gx%bmperr=0 - endif -! Here we create a new condition !!! -! get the value for the new condition - ip=index(cline,'==')+2 - call getrel(cline,ip,value) - if(buperr.ne.0) then - write(*,*)'error setting fix amount ',ip,cline(1:40) - gx%bmperr=4100; goto 1000 - endif -! write(*,*)'25D Set fix phase amount: ',value -!----------------------------------------------- -! create a new condition record for this equilibrium (can be the first) -500 continue - if(associated(ceq%lastcondition)) then - seqz=ceq%lastcondition%seqz+1 - else - seqz=1 - endif - temp=>ceq%lastcondition -! write(*,*)'25D allocating condition',seqz - allocate(ceq%lastcondition) - new=>ceq%lastcondition - new%noofterms=nterm - new%statev=jstv - new%iunit=iunit - new%iref=iref - new%active=0 - new%seqz=seqz -! write(*,*)'allocating terms',nterm - allocate(new%condcoeff(nterm)) - allocate(new%indices(4,nterm)) -! write(*,*)'allocations ok' - do jl=1,nterm - new%condcoeff(jl)=coeffs(jl) - do ks=1,4 - new%indices(ks,jl)=allterms(ks,jl) - enddo - enddo - if(linkix.lt.0) then - new%prescribed=value - new%symlink1=-1 -! special for T and P, change the local value -! write(*,*)'set condition ',istv,jstv,value - if(istv.eq.1) then - ceq%tpval(1)=value - elseif(istv.eq.2) then - ceq%tpval(2)=value - endif - else - new%symlink1=linkix - endif -! store the state variable record in the condition - allocate(new%statvar(nterm)) - do jl=1,nterm - new%statvar(jl)=svrarr(jl) - enddo -! link the new record into the condition list -! write(*,*)'linking condition' - if(associated(temp)) then -! write(*,*)'Second or later condition' - nidlast=temp%next%nid - nidfirst=temp%nid - nidpre=temp%previous%nid - new%nid=nidlast+1 - temp%next%previous=>new - new%next=>temp%next - temp%next=>new - new%previous=>temp - else -! create the circular list - new%nid=1 - new%next=>new - new%previous=>new - endif -900 continue - if(.not.eolch(cline,ip)) then -! look for more conditions. Note that gparc increment ip by 1 at start -! write(*,901)cline(ip-1:ip+20) -901 format(' >',a,"<") - if(cline(ip:ip).ne.',') ip=ip-1 - goto 50 - endif -! finally, for conditions on T and P copy value to ceq%tpval -! This may be a bit inconsistent .... but?? - if(jstv.eq.1 .and. iunit.eq.0 .and. iref.eq.0) then - ceq%tpval(1)=value - elseif(jstv.eq.2 .and. iunit.eq.0 .and. iref.eq.0) then - ceq%tpval(2)=value - endif -! mark that any current results may be inconsistent with new conditions -! globaldata%status=ibset(globaldata%status,GSINCON) - ceq%status=ibset(ceq%status,EQINCON) -1000 continue -! write(*,*)'exit set_condition, T= ',ceq%tpval(1) - return - end subroutine set_condition - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine get_condition(nterm,svr,pcond) -! finds a condition record with the given state variable expression -! If nterm<0 the absolute value of nterm is condition number, svr is irrelevant - implicit none - integer nterm - type(gtp_state_variable), pointer :: svr -! NOTE: pcond must have been set to ceq%lastcondition before calling this -! pcond: pointer, to a gtp_condition record for this equilibrium - type(gtp_condition), pointer :: pcond -!\end{verbatim} %+ - type(gtp_condition), pointer :: last - type(gtp_state_variable), pointer :: condvar - integer j1,num - if(.not.associated(pcond)) goto 900 -! write(*,*)'25D in get_condition: ',svr%statevarid,svr%oldstv,svr%argtyp -! if(nterm.lt.0) write(*,*)'25D Condition number: ',-nterm - last=>pcond - num=0 -100 continue -! search for condition abs(nterm) - if(nterm.lt.0 .and. num+nterm.eq.0) goto 1000 - num=num+1 - if(pcond%noofterms.eq.nterm) then - do j1=1,nterm - condvar=>pcond%statvar(j1) -! write(*,*)'25D get_condition: ',num,condvar%oldstv,condvar%argtyp -! dissapointment, one cannot compare two structures ... unless pointers same -! if(condvar.ne.svr) goto 200 -! j2=1 - if(condvar%oldstv.ne.svr%oldstv) goto 200 -! j2=2 - if(condvar%argtyp.ne.svr%argtyp) goto 200 -! j2=3 - if(condvar%phase.ne.svr%phase) goto 200 -! j2=4 - if(condvar%compset.ne.svr%compset) goto 200 - if(condvar%statevarid.lt.0) goto 1000 -! for fix phase the remaining have no importance -! j2=5 - if(condvar%component.ne.svr%component) goto 200 -! j2=6 - if(condvar%constituent.ne.svr%constituent) goto 200 -! j2=7 - if(condvar%norm.ne.svr%norm) goto 200 -! j2=8 - if(condvar%unit.ne.svr%unit) goto 200 - enddo -! we have found a condition with these state variables -! write(*,*)'25D Found condition',pcond%active - goto 1000 - endif -200 continue -! write(*,*)'Failed at argument: ',j2 - pcond=>pcond%next - if(.not.associated(pcond,last)) goto 100 -900 continue -! write(*,*)'25D get_condition: No such condition' - gx%bmperr=7779; goto 1000 -1000 continue - return -end subroutine get_condition - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine get_condition2(nterm,coeffs,istv,indices,iref,iunit,pcond) -! finds a condition record with the given state variable expression -! nterm: integer, number of terms in the condition expression -! istv: integer, state variable used in the condition -! indices: 2D integer array, state variable indices used in the condition -! iref: integer, reference state of the condition (if applicable) -! iunit: integer, unit of the condition value -! NOTE: pcond must have been set to ceq%lastcond before calling this routine!!! -! pcond: pointer, to a gtp_condition record for this equilibrium -! NOTE: conditions like expressions x(mg)-2*x(si)=0 not implemeneted -! fix phases as conditions have negative condition variable - implicit none - TYPE(gtp_condition), pointer :: pcond - integer, dimension(4,*) :: indices - integer nterm,istv,iref,iunit - double precision coeffs(*) -!\end{verbatim} %+ - TYPE(gtp_condition), pointer :: current,first -! integer, dimension(4) :: indx - integer ncc,nac,j1,j2 -! write(*,*)'looking for condition' -! pcond must have been set to ceq%lastcond before calling this routine!!! - if(.not.associated(pcond)) goto 900 - first=>pcond%next - current=>first -! write(*,*)'get_condition start: ',current%statev,current%active - ncc=1 - nac=0 - if(ocv()) write(*,98)'new:',0,nterm,istv,(indices(j1,1),j1=1,4),iref,iunit -98 format(a,2x,i2,5x,2i4,5x,4i4,5x,2i3) -100 continue - if(ocv()) write(*,98)'old:' ,current%nid,current%noofterms,current%statev,& - (current%indices(j1,1),j1=1,4),current%iref,current%iunit - if(nterm.eq.0) then -! why nterm=0? Check!!! - if(ocv()) write(*,*)'get_condition: ',istv,ncc,nac - if(current%active.eq.0) then -! this call just looks for active condition istv - nac=nac+1 -! why should fix phase conditions have istv=nac?? Check!! - if(nac.eq.istv) then -! a condition specified like this must not be a phase status change - if(current%statev.lt.0) then - write(kou,*)'You must use "set phase status" to change fix status' - else - goto 150 - endif - endif - endif - goto 200 - endif - if(ocv()) write(*,103)'Checking terms, istv, iref and unit ',& - nac,ncc,nterm,current%noofterms -103 format(a,6i5) - if(current%noofterms.ne.nterm .or. current%statev.ne.istv .or. & - current%iref.ne.iref .or. current%iunit.ne.iunit) goto 200 - if(ocv()) write(*,*)'Checking indices' - do j1=1,nterm - do j2=1,4 - if(current%indices(j2,j1).ne.indices(j2,j1)) goto 200 - enddo - enddo -150 continue -! found condition - pcond=>current -! write(*,*)'Found condition: ',pcond%nid,ncc - goto 1000 -200 continue - current=>current%next - ncc=ncc+1 - if(.not. associated(current,first)) goto 100 -900 continue -! no such condition - gx%bmperr=4131; goto 1000 -1000 continue - return - end subroutine get_condition2 - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} %- - subroutine extract_stvr_of_condition(pcond,nterm,coeffs,statevar) -! finds a condition record with the given state variable record -! returns it as a state variable record !!! -! nterm: integer, number of terms in the condition expression -! pcond: pointer, to a gtp_condition record - implicit none - TYPE(gtp_condition), pointer :: pcond -! ONE CANNOT HAVE ARRAYS OF POINTERS!!! STUPID -! TYPE(gtp_state_variable), dimension(*), pointer :: statevar - TYPE(gtp_state_variable), dimension(*) :: statevar - integer nterm - double precision coeffs(*) -!\end{verbatim} - TYPE(gtp_condition), pointer :: current,first -! integer, dimension(4) :: indx - integer ncc,nac,j1,istv,iref,iunit -! - write(*,*)'not implemented!!' - gx%bmperr=7777; goto 1000 -!-------------------------------------------------------- - if(.not.associated(pcond)) goto 900 - first=>pcond%next - current=>first -! write(*,*)'get_condition start: ',current%statev,current%active - ncc=1 - nac=0 -! write(*,98)'new:',0,nterm,istv,(indices(i,1),i=1,4),iref,iunit -98 format(a,2x,i2,5x,2i4,5x,4i4,5x,2i3) -100 continue -! write(*,98)'old:' ,current%nid,current%noofterms,current%statev,& -! (current%indices(i,1),i=1,4),current%iref,current%iunit - if(nterm.eq.0) then -! write(*,*)'get_condition: ',istv,ncc,nac - if(current%active.eq.0) then -! this call just looks for active condition istv - nac=nac+1 -! why should fix phase conditions have istv=nac?? Check!! - if(nac.eq.istv) then -! a condition specified like this must not be a phase status change - if(current%statev.lt.0) then - write(kou,*)'You must use "set phase status" to change fix status' - else - goto 150 - endif - endif - endif - goto 200 - endif - if(current%noofterms.ne.nterm .or. current%statev.ne.istv .or. & - current%iref.ne.iref .or. current%iunit.ne.iunit) goto 200 - do j1=1,nterm -! do j2=1,4 -! if(current%indices(j2,j1).ne.indices(j2,j1)) goto 200 -! enddo - enddo -150 continue -! found condition - pcond=>current -! write(*,*)'Found condition: ',pcond%nid,ncc - goto 1000 -200 continue - current=>current%next - ncc=ncc+1 - if(.not. associated(current,first)) goto 100 -900 continue -! no such condition - gx%bmperr=4131; goto 1000 -1000 continue - return - end subroutine extract_stvr_of_condition - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine locate_condition(seqz,pcond,ceq) -! locate a condition using a sequential number - implicit none - integer seqz - type(gtp_condition), pointer :: pcond - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer ij - pcond=>ceq%lastcondition - do ij=1,seqz - pcond=>pcond%next - if(seqz.gt.ij .and. associated(pcond,ceq%lastcondition)) then - write(*,*)'Locate condition called with too high index: ',seqz - gx%bmperr=7777; goto 1000 - endif - enddo -1000 continue - return - end subroutine locate_condition - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine apply_condition_value(current,what,value,cmix,ceq) -! This is called when calculating an equilibrium. -! It returns a condition at each call, at first call current must be nullified? -! When all conditions done the current is nullified again -! If what=-1 then return degrees of freedoms and maybe something more -! what=0 means calculate current values of conditions -! calculate the value of a condition, used in minimizing G - implicit none - integer what,cmix(*) - double precision value - TYPE(gtp_equilibrium_data), pointer :: ceq - TYPE(gtp_condition), pointer :: current -!\end{verbatim} %+ -! ceq is actually redundant as current is a pointer to condition list in ceq - integer, dimension(4) :: indices - integer iref,iunit,jl,istv,ip - character encoded*60,actual_arg*60 -! -100 continue - if(current%active.ne.0) then -! return 0 for inactive conditions - cmix(1)=0; goto 1000 - endif - if(what.ge.0) goto 200 -!---------------------------------------------------------- -! Here we should return information about conditions on potentials (T, P, MU) -! and fix phases - cmix(1)=0 - if(current%noofterms.gt.1) then -! cannot hanlde conditions with several terms - write(*,*)'Found condition with several terms' - gx%bmperr=7777; goto 900 - endif -! for debugging - istv=current%statev - do jl=1,4 - indices(jl)=current%indices(jl,1) - enddo - iref=current%iref - iunit=current%iunit - ip=1 - encoded=' ' - actual_arg=' ' -!------------------ - if(current%statev.lt.0) then -! a fix phase cpndition has state variable equal to -iph, ics is stored in iref - cmix(1)=4 - cmix(2)=-current%statev - cmix(3)=current%iref - value=current%prescribed -! write(*,*)'25D Fix phase: ',-current%statev,current%iref,value - elseif(current%statev.eq.1) then -! temperature - cmix(1)=1 - value=current%prescribed -! write(*,*)'conditon on T' - elseif(current%statev.eq.2) then -! pressure - cmix(1)=2 - value=current%prescribed -! write(*,*)'conditon on P' - elseif(current%statev.le.5) then -! potentials has statev=1..5 (T, P, MU, AC, LNAC) - cmix(1)=3 - cmix(2)=current%statev - cmix(3)=current%indices(1,1) - value=current%prescribed -! write(*,*)'condition on MU/AC/LNAC' - elseif(current%statev.ge.10) then -! other condition must be on extensive properties (N, X, H etc) - cmix(1)=5 -! write(*,*)'Extensive condition: ',current%statev - else - write(*,*)'Illegal condition',current%statev - gx%bmperr=7777; goto 1000 - endif - goto 900 -!-------------------------------------- -! Here we should return extensive condition, maybe calculate value -200 if(what.ne.0) goto 300 - cmix(1)=0 - if(current%noofterms.gt.1) then -! ignore conditions with several terms - write(*,*)'Found condition with several terms' - gx%bmperr=8888; goto 1000 - endif -! for debugging - istv=current%statev - do jl=1,4 - indices(jl)=current%indices(jl,1) - enddo - iref=current%iref - iunit=current%iunit - ip=1 - encoded=' ' - actual_arg=' ' -!------------------ - if(current%statev.lt.10) goto 900 -! condition must be on extensive properties (N, X, H etc) - cmix(1)=5 - cmix(2)=current%statev -! indices are dimensioned (4,nterms) - cmix(3)=current%indices(1,1) - cmix(4)=current%indices(2,1) - cmix(5)=current%indices(3,1) - cmix(6)=current%indices(4,1) - value=current%prescribed - goto 900 -!-------------------------------------- -! this part is redundant .... -300 continue - write(*,*)'Calling apply_condition with illegal option' - gx%bmperr=8888; goto 1000 -!----------------------------------------------------------- -! maybe something common -900 continue -! -1000 continue - return - end subroutine apply_condition_value - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine condition_value(mode,pcond,value,ceq) -! set (mode=0) or get (mode=1) a new value of a condition. Used in mapping - implicit none - integer mode - type(gtp_condition), pointer :: pcond - type(gtp_equilibrium_data), pointer :: ceq - double precision value -!\end{verbatim} - if(mode.eq.0) then -! set the value - pcond%prescribed=value -! special for T and P - if(pcond%statev.eq.1) then - ceq%tpval(1)=value - elseif(pcond%statev.eq.2) then - ceq%tpval(2)=value - endif - elseif(mode.eq.1) then - value=pcond%prescribed - else - write(*,*)'Condition value called with illegal mode' - endif -1000 continue - return - end subroutine condition_value - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - - -!\begin{verbatim} - subroutine amend_components(cline,last,ceq) -! enter a new set of components for equilibrium ceq - implicit none - integer last - character cline*(*) - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - character symb*24 - integer lokic(maxel),ielno(10) - double precision stoi(maxel,maxel+1),invstoi(maxel,maxel),spst(10) - integer ic,loksp,nspel,jl,j2,ierr - double precision spmass,qsp -! input is a list of species name, same as number of elements - stoi=zero - ic=0 -100 continue - call gparc('Give all components: ',cline,last,1,symb,' ',q1help) - call find_species_record(symb,loksp) - if(gx%bmperr.ne.0) goto 1000 -! check not same species twice - do jl=1,ic - if(loksp.eq.lokic(jl)) then -! write(*,*)'Same species twice' - gx%bmperr=4162; goto 1000 - endif - enddo - ic=ic+1 - lokic(ic)=loksp -! get the stoichiometry and save it in row in stoi - call get_species_data(loksp,nspel,ielno,spst,spmass,qsp) - if(gx%bmperr.ne.0) goto 1000 - do jl=1,nspel - stoi(ic,ielno(jl))=spst(jl) - enddo - if(ic.lt.noofel) goto 100 -! check that stoichiometry matrix not singular, should calculate the inverse -! do i=1,ic -! write(*,200)(stoi(i,j),j=1,ic) -!200 format('X: ',6(1PE12.4)) -! enddo -! lukasnum routine to invert matrix - call mdinv(maxel,maxel+1,stoi,invstoi,ic,ierr) -! check the matrix and its inverse -! do i=1,ic -! write(*,200)(invstoi(i,j),j=1,ic) -! enddo - if(ierr.eq.0) then -! write(*,*)'Component matrix singular' - gx%bmperr=4163; goto 1000 - endif - if(allocated(ceq%compstoi)) then - deallocate(ceq%compstoi) - deallocate(ceq%invcompstoi) - endif - allocate(ceq%compstoi(ic,ic)) - allocate(ceq%invcompstoi(ic,ic)) -! write(*,*)(lokic(i),i=1,ic) - do jl=1,ic - ceq%complist(jl)%splink=lokic(jl) -! phlink=0 means no user defined reference state - ceq%complist(jl)%phlink=0 - ceq%complist(jl)%status=0 - ceq%complist(jl)%tpref=zero - ceq%complist(jl)%chempot=zero - ceq%complist(jl)%mass=spmass - do j2=1,ic - ceq%compstoi(jl,j2)=stoi(jl,j2) - ceq%invcompstoi(jl,j2)=invstoi(jl,j2) - enddo - enddo -1000 continue - return - end subroutine amend_components - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine ask_default_constitution(cline,last,iph,ics,ceq) -! set values of default constitution interactivly -! phase and composition set already given - implicit none - character cline*(*) - integer last,iph,ics - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer lokph,lokcs,ky,ll,iy,jy,is,ip,abel - real mmyfr(maxconst) - character quest*32,name*24,vdef*4,fdef*8 - double precision xxx - call get_phase_compset(iph,ics,lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 -! if PHNOCV set the composition is fixed - if(btest(phlista(lokph)%status1,PHNOCV)) goto 1000 - write(*,10) -10 format('Give min or max fractions (< or negative value as max)',& - ' or NONE for no default') - name=' ' - ky=0 - do ll=1,phlista(lokph)%noofsubl - if(phlista(lokph)%nooffr(ll).gt.1) then -! more than one constituent - do iy=1,phlista(lokph)%nooffr(ll) - ky=ky+1 -! call get_species_name(phlista(lokph)%constitlist(ky),name) - call get_phase_constituent_name(iph,ky,name) - if(gx%bmperr.ne.0) then - write(*,*)'default: ',iph,ky,iy - goto 1000 - endif - quest='Default for '//name(1:len_trim(name))//& - '#'//char(ichar('0')+ll) -! use current value as default if nonzero - vdef=' ' - abel=10*abs(ceq%phase_varres(lokcs)%mmyfr(ky)) -! write(*,*)'25D abel:',ky,abel,ceq%phase_varres(lokcs)%mmyfr(ky) - if(abel.ge.10) then - vdef=' 1.0' - elseif(abel.le.0) then - vdef=' 0.1' - else - vdef=' 0.'//char(ichar('0')+abel) - endif - if(ceq%phase_varres(lokcs)%mmyfr(ky).lt.0.0) then - vdef(1:1)='<' - elseif(ceq%phase_varres(lokcs)%mmyfr(ky).gt.0.0) then - vdef(1:1)='>' - else - vdef='NONE' - endif -! - call gparcd(quest,cline,last,1,fdef,vdef,q1help) - jy=1 - if(fdef.eq.'NONE') then - xxx=0 - is=1 - elseif(eolch(fdef,jy)) then - xxx=-1.0D-1 - else - is=1 - if(fdef(jy:jy).eq.'<') then - is=-1 - jy=jy+1 - elseif(fdef(jy:jy).eq.'>') then - jy=jy+1 - endif -! write(*,*)'25D def1: ',fdef,jy - call getrel(fdef,jy,xxx) - if(is.lt.0) xxx=-xxx - endif - if(abs(xxx).gt.one) xxx=sign(xxx,one) -! write(*,*)'25D default: ',xxx - mmyfr(ky)=real(xxx) - enddo - else -! a single constituent, we must increment ky as there may be more - ky=ky+1 - mmyfr(ky)=1.0 - endif - enddo - call enter_default_constitution(iph,ics,mmyfr,ceq) - write(*,99)(mmyfr(jy),jy=1,ky) -99 format('25D: ',15(f5.1)) -1000 continue - return - end subroutine ask_default_constitution - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine set_input_amounts(cline,lpos,ceq) -! set amounts like n(specie)=value or b(specie)=value -! value can be negative removing amounts -! values are converted to moles and set or added to conditions - implicit none - integer lpos - character cline*(*) - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - TYPE(gtp_state_variable), pointer :: svr - TYPE(gtp_condition), pointer :: current,first,last - character species*32,cval*16,statevar*4,condline*32 - integer ielno(10) - double precision addval(maxel) - integer k,loksp,istv,jel,ip - double precision xval,sumstoi,xmols -! repeat reading until empty line -100 continue - addval=zero - call gparc('Species amount as N(..) or B(...): ',& - cline,lpos,1,species,' ',q1help) - call capson(species) - statevar=species(1:1) - if(statevar.ne.' ') then - if(.not.(statevar(1:1).ne.'N' .or. statevar(1:1).ne.'B')) then - write(*,*)'Illegal state variable for input amounts' - goto 1000 - endif - k=index(species,')') - if(k.le.3) then - write(*,*)'Species must be surrounded by ( )' - gx%bmperr=7777; goto 1000 - endif - cval=species(k+1:) - species=species(3:k-1) - if(index(species,',').gt.0 .or. index(species,'(').gt.0) then - write(*,*)'Use only N(species) or B(species) in input amounts' - goto 1000 - endif - else - goto 1000 - endif - call find_species_record(species,loksp) -! not needed as we can access splista -! call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp) - if(gx%bmperr.ne.0) goto 1000 -! if user writes N(C)=2 the =2 will be in cval, if a space after = in cline - if(cval(1:2).eq.'= ') goto 200 - goto 300 -200 continue -! the user can also give values without = or with a space before = -! but no space allowed after = - call gparc('Amount: ',cline,lpos,1,cval,' ',q1help) -300 continue - if(cval(1:1).eq.'=') cval(1:1)=' ' - ip=1 - call getrel(cval,ip,xval) - if(buperr.ne.0) then - write(*,*)'Amount must be a real number' - goto 1000 - endif -! this return the internal code for N -! call decode_state_variable('N ',istv,indices,iref,iunit,svr,ceq) - call decode_state_variable('N ',svr,ceq) - if(gx%bmperr.ne.0) then - write(*,*)'Error decoding N in set_input_amounts' - goto 1000 - endif - istv=svr%oldstv -! if B convert to N: moles of species = input_mass/mass_of_species -! moles of element = stoiciometry_of_element/total_number_of_elements - if(statevar(1:1).eq.'B') then - xmols=xval/splista(loksp)%mass - else - xmols=xval - endif - sumstoi=zero - do jel=1,splista(loksp)%noofel - ielno(jel)=splista(loksp)%ellinks(jel) - addval(ielno(jel))=splista(loksp)%stoichiometry(jel)*xmols - sumstoi=sumstoi+splista(loksp)%stoichiometry(jel) - enddo -! now create or att to existing conditions - last=>ceq%lastcondition - jel=1 - if(.not.associated(last)) goto 600 -! return here to look for condition for another element -500 continue -! write(*,*)'At 500',last%nid,last%next%nid - first=>last%next - current=>first -! loop for all condition -510 continue -! write(*,*)'loop: ',current%nid,current%indices(1,1),ielno(jel) -! check if this condition match amount of element jel - if(current%noofterms.eq.1) then - if(current%statev.eq.istv) then - if(current%indices(1,1).eq.ielno(jel) .and. & - current%indices(2,1).eq.0) then -! we have found an identical contition, add the new amount -! if condition not active (active=/=0) then activate and zero prescibed amount - if(current%active.ne.0) then - current%active=0 - current%prescribed=zero - endif - current%prescribed=current%prescribed+addval(ielno(jel)) - goto 700 - endif - endif - endif - current=>current%next -! write(*,*)'next: ',current%nid,first%nid - if(.not.associated(current,first)) goto 510 -600 continue -! new condition needed - condline='N('//ellista(ielno(jel))%symbol& - (1:len_trim(ellista(ielno(jel))%symbol))//')=' - ip=len_trim(condline)+1 - call wrinum(condline,ip,10,0,addval(ielno(jel))) -! write(*,*)'new condition: ',condline -! set_condition starts by incementing ip - ip=0 - call set_condition(condline,ip,ceq) - if(gx%bmperr.ne.0) goto 1000 - if(.not.associated(last)) then -! if ceq%lastcondition was not associated above the call to set_condition -! will have set link in ceq%lastcondition - last=>ceq%lastcondition -! write(*,*)'condition id: ',last%nid - endif -700 continue - jel=jel+1 - if(jel.le.splista(loksp)%noofel) goto 500 -! all elements for this species set as conditions, check if any more - if(.not.eolch(cline,lpos)) goto 100 -! -1000 continue - return - end subroutine set_input_amounts - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine get_parameter_typty(name1,lokph,typty,fractyp) -! interpret parameter identifiers like MQ&C#2 in MQ&C#2(FCC_A1,FE:C) ... -! find the property associated with this symbol - integer typty,fractyp,lokph - character name1*(*) -!\end{verbatim} - integer nr,typty1,iel,isp,kel,loksp,lk3,kq,k4,kk,ll - character elnam*24 -! It can be a mobility with a & inside - kel=index(name1,'&') - if(kel.gt.0) then -! note that elnam may contain sublattice specification like Fe+2#2 - elnam=name1(kel+1:) - name1=name1(1:kel-1) - endif - kq=len_trim(name1) -! write(*,*)'25D: fractyp: ',kq,name1(1:kq) - if(name1(kq:kq).eq.'D') then -! A final "D" on the paramer symbol indicates fractyp=2 - name1(kq:kq)=' ' - fractyp=2 - else - fractyp=1 - endif -!---------------------- -! write(*,*)'Property symbol: "',propid(nr)%symbol,'" >',name1(1:4),'<' - do nr=1,ndefprop - if(name1(1:4).eq.propid(nr)%symbol) then - goto 70 - endif - enddo -! no matching symbol - gx%bmperr=7777; goto 1000 -! -70 continue - typty=nr - typty1=nr - iel=0; isp=0 - if(kel.gt.0) then -! there is a specifier, check if correct element or species - kel=index(elnam,'#') - if(kel.gt.0) then -! extract sublattice number 1-9 specification - lk3=ichar(elnam(kel+1:kel+1))-ichar('0') -! write(*,73)elnam(kel+1:kel+1),kel,elnam,lk3 -!73 format('25D sublattice: "',a,'" position: ',i3,' in ',a,' : ',i3) - elnam(kel:)=' ' - else - lk3=0 - endif - if(btest(propid(typty)%status,IDELSUFFIX)) then -! write(*,*)'25D: elnam: ',kel,lk3,typty,elnam - call find_element_by_name(elnam,iel) - if(gx%bmperr.ne.0) then - write(kou,*)'Unknown element ',elnam,& - ' in parameter type MQ, please reenter' - gx%bmperr=0; goto 1000 - endif - typty=100*typty+iel - elseif(btest(propid(typty)%status,IDCONSUFFIX)) then -! to know the constituents we must know the phase but as we do not know -! the phase name yet but check the species exists !!! - call find_species_by_name(elnam,isp) - if(gx%bmperr.ne.0) then - write(kou,*)'Unknown species ',elnam,& - ' in parameter type MQ, please reenter',gx%bmperr - gx%bmperr=0; goto 1000 - endif -! convert from index to location, loksp - loksp=species(isp) -! write(*,69)'25D: conname: ',kel,lk3,typty,isp,loksp,elnam -69 format(a,5i4,a) -! extract sublattice after # - else -! write(kou,*)'This property has no specifier' - gx%bmperr=4168; goto 1000 - endif -! this is the property type stored in property record - else -! check if there should be a specifier !! - if(btest(propid(typty)%status,IDELSUFFIX) .or. & - btest(propid(typty)%status,IDCONSUFFIX)) then - write(*,*)'Parameter specifier missing' - gx%bmperr=4169; goto 1000 - endif - endif -! if the parameter symbol has a constituent specification check that now - if(isp.gt.0) then - k4=0 - do ll=1,phlista(lokph)%noofsubl - if(lk3.eq.0 .or. lk3.eq.ll) then - do kk=1,phlista(lokph)%nooffr(ll) - k4=k4+1 - if(phlista(lokph)%constitlist(k4).eq.loksp) goto 80 - enddo - elseif(ll.lt.lk3) then - k4=k4+phlista(lokph)%nooffr(ll) - endif - enddo -! constituent not found - write(kou,*)'No such constituent' - gx%bmperr=4066; goto 1000 -! constituent found in right sublattice -80 continue - typty=100*typty+k4 -! write(*,81)'25D: found: ',typty1,typty,lk3,k4,loksp -81 format(a,10i4) - endif -1000 continue - return - end subroutine get_parameter_typty -! -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - +! +! gtp3D included in gtp3.F90 +! +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ +!> 8. Interactive things +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine ask_phase_constitution(cline,last,iph,ics,lokcs,ceq) +! interactive input of a constitution of phase iph + implicit none + integer last,iph,ics,lokcs + character cline*(*) +!\end{verbatim} + character name1*24,quest*32 + double precision yarr(maxcons2),sites(maxsubl),qq(5),yyy,xxx,sss,ydef + integer knl(maxsubl),knr(maxcons2) + character line*64,ch1*1 + character*1 :: chd='Y' + integer qph,lokph,nsl,kkk,loksp,ip,ll,nr + TYPE(gtp_equilibrium_data), pointer :: ceq + logical once +! save here to use the same default as last time + save chd + call gparc('Phase name: ',cline,last,1,name1,' ',q1help) + if(name1(1:2).eq.'* ') then +! this means all phases and composition sets + qph=-1 + iph=1 + ics=1 + call get_phase_name(iph,ics,name1) + if(gx%bmperr.ne.0) goto 1000 + else + qph=0 + call find_phase_by_name(name1,iph,ics) + if(gx%bmperr.ne.0) goto 1000 + endif +100 continue +! write(*,*)'spc 1',qph,iph,ics,name1 +! skip hidden and suspended phases, test_phase_status return +! -4 hidden, -3 suspend, -2 dormant, -1,0, entered, 2 fixed + if(qph.lt.0 .and. test_phase_status(iph,ics,xxx,ceq).le.PHDORM) goto 200 +! if(qph.lt.0 .and. (phase_status(iph,ics,PHHID,ceq) .or.& +! phase_status(iph,ics,PHIMHID,ceq) .or.& +! (phase_status(iph,ics,CSSUS,ceq) .and. & +! .not.phase_status(iph,ics,CSFIXDORM,ceq)))) goto 200 +! lokph=phases(iph) + call get_phase_compset(iph,ics,lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 + call get_phase_data(iph,ics,nsl,knl,knr,yarr,sites,qq,ceq) + if(gx%bmperr.ne.0) goto 1000 +! ask for amount of formula units, default is current amount + yyy=ceq%phase_varres(lokcs)%amfu + quest='Amount of '//name1 + call gparrd(quest,cline,last,xxx,yyy,q1help) +! if input error quit asking more + if(buperr.ne.0) then + buperr=0; goto 1000 + endif + ceq%phase_varres(lokcs)%amfu=xxx +! ask if we should set the default constitution + call gparcd('Default constitution?',cline,last,1,ch1,chd,q1help) + if(ch1.eq.'Y' .or. ch1.eq.'y') then + call set_default_constitution(iph,ics,ceq) + if(gx%bmperr.ne.0) goto 1000 + chd='Y' + goto 200 + else + chd='N' + endif +! ask for constitution + kkk=0 + nylat: do ll=1,nsl + sss=one + ydef=one + nycon: do nr=1,knl(ll)-1 + kkk=kkk+1 + loksp=phlista(lokph)%constitlist(kkk) + line='Fraction of '//splista(loksp)%symbol + ip=len_trim(line)+1 + if(ll.gt.1) then + line(ip:)='#'//char(ll+ichar('0')) + ip=ip+2 + endif + once=.true. +20 continue + ydef=min(yarr(kkk),ydef) + call gparrd(line(1:ip+2),cline,last,xxx,ydef,q1help) + if(xxx.lt.zero) then + if(once) then + write(*,*)'A Fraction must be greater than zero' + yarr(kkk)=1.0D-12 + once=.false. + goto 20 + else + gx%bmperr=4146; goto 1000 + endif + endif + sss=sss-xxx + if(sss.lt.zero) then + xxx=max(sss+xxx,1.0D-12) + sss=-1.0D12 + write(*,21)'Sum of fractions larger 1.0, fraction set to: ',xxx +21 format(a,1pe12.4) + ydef=1.0D-12 + else + ydef=sss + endif +! write(*,*)'ydef: ',ydef,sss + yarr(kkk)=xxx + enddo nycon +! the last constituent is set to the rest + kkk=kkk+1 + yarr(kkk)=max(sss,1.0D-12) + write(*,21)'Last fraction set to: ',yarr(kkk) + enddo nylat +! set the new constitution + call set_constitution(iph,ics,yarr,qq,ceq) +! if all phases loop +200 continue + if(qph.lt.0) then + if(gx%bmperr.eq.4050) then +! error no such phase, quit + gx%bmperr=0; goto 1000 + elseif(gx%bmperr.eq.4072) then +! error no such composition set, take next phase + gx%bmperr=0 + iph=iph+1 + ics=1 + else + ics=ics+1 + endif + call get_phase_name(iph,ics,name1) + if(gx%bmperr.ne.0) goto 200 + goto 100 + endif +1000 continue +! return -1 as phase number of loop for all phases made + if(qph.lt.0) iph=-1 + return + end subroutine ask_phase_constitution + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine enter_parameter_interactivly(cline,ip,mode) +! enter a parameter from terminal or macro +! NOTE both for ordered and disordered fraction set !! +! mode = 0 for entering +! 1 for listing on screen (kou) + implicit none + integer ip,mode + character cline*(*) +!\end{verbatim} + character name1*24,name2*24,longline*256,refx*16,elnam*24 + character name3*64,ch1*1,line*64,parname*64 + integer typty,lint(2,5),fractyp,typty1,kp,lp1,kel,kq,iel,isp,lk3,lp2 + integer jph,ics,lokph,ll,k4,nint,jp,lsc,ideg,kk,lfun,nsl,loksp + integer, dimension(maxsubl) :: endm(maxsubl) + double precision xxx +! +10 continue + call gparc('Parameter name: ',cline,ip,7,parname,' ',q1help) +! simple parameter names are like G(SIGMA,FE:CR:FE,CR;1) + kp=index(parname,' ') + parname(kp:)=' ' +! extract symbol, normally G or L but TC and others can occur +! for example a mobility like MQ&FE+2#3 where FE+2#3 is a constinuent +! in sublattice 3 + lp1=index(parname,'(') + if(lp1.le.1) then + gx%bmperr=4027; goto 1000 + endif +! name1 is everything up to ( + name1=parname(1:lp1-1) + call capson(name1) +! It can be a mobility with a & inside + kel=index(name1,'&') + if(kel.gt.0) then +! note that elnam may contain sublattice specification like Fe+2#2 + elnam=name1(kel+1:) + name1=name1(1:kel-1) + endif + kq=len_trim(name1) +! write(*,*)'3D: fractyp: ',kq,name1(1:kq) + if(name1(kq:kq).eq.'D') then +! A final "D" on the paramer symbol indicates fractyp=2 + name1(kq:kq)=' ' + fractyp=2 + else + fractyp=1 + endif +! find the property associated with this symbol + do typty=1,ndefprop +! write(*,*)'Property symbol: "',propid(typty)%symbol,'"' + if(name1(1:4).eq.propid(typty)%symbol) then + goto 70 + endif + enddo +! no matching symbol + write(kou,*)'unknown parameter type, please reenter: ',& + name1(1:len_trim(name1)) + parname=' '; goto 10 +! +70 continue + typty1=typty + iel=0; isp=0 + if(kel.gt.0) then +! there is a specifier, check if correct element or species + kel=index(elnam,'#') + if(kel.gt.0) then +! extract sublattice number 1-9 specification + lk3=ichar(elnam(kel+1:kel+1))-ichar('0') +! write(*,73)elnam(kel+1:kel+1),kel,elnam,lk3 +!73 format('3D sublattice: "',a,'" position: ',i3,' in ',a,' : ',i3) + elnam(kel:)=' ' + endif + if(btest(propid(typty)%status,IDELSUFFIX)) then +! write(*,*)'3D: elnam: ',kel,lk3,typty,elnam + call find_element_by_name(elnam,iel) + if(gx%bmperr.ne.0) then + write(kou,*)'Unknown element ',elnam,& + ' in parameter type MQ, please reenter' + parname=' '; gx%bmperr=0; goto 10 + endif + typty=100*typty+iel + elseif(btest(propid(typty)%status,IDCONSUFFIX)) then +! to know the constituents we must know the phase but as we do not know +! the phase name yet but check the species exists !!! +! write(*,*)'3D: conname: ',kel,lk3,typty,elnam + call find_species_by_name(elnam,isp) + if(gx%bmperr.ne.0) then + write(kou,*)'Unknown species ',elnam,& + ' in parameter type MQ, please reenter',gx%bmperr + parname=' '; gx%bmperr=0; goto 10 + endif +! convert from index to location, loksp + loksp=species(isp) +! extract sublattice after # + else + write(kou,*)'This property has no specifier' + gx%bmperr=4168; goto 1000 + endif +! this is the property type stored in property record + else +! check if there should be a specifier !! + if(btest(propid(typty)%status,IDELSUFFIX) .or. & + btest(propid(typty)%status,IDCONSUFFIX)) then + write(*,*)'Parameter specifier missing' + gx%bmperr=4169; goto 1000 + endif + endif +! +! extract phase name and constituent array + lp1=index(parname,'(') + lp2=index(parname,',') + if(lp2.lt.lp1) then + gx%bmperr=4028; goto 1000 + endif + name2=parname(lp1+1:lp2-1) +! write(*,*)'enter_parameter_inter 1: ',lp1,lp2,name2 + call find_phase_by_name_exact(name2,jph,ics) + if(gx%bmperr.ne.0) then +! special case for reference phase + gx%bmperr=0; + call capson(name2) + if(name2.eq.'SELECT_ELEMENT_REFERENCE') then + jph=0; ics=1 + else + write(kou,*)'unknown phase name, please reenter' + kp=len(cline) + goto 10 + endif + endif + lokph=phases(jph) +! if the parameter symbol has a constituent specification check that now + if(isp.gt.0) then + k4=0 + do ll=1,phlista(lokph)%noofsubl + if(lk3.eq.0 .or. lk3.eq.ll) then + do kk=1,phlista(lokph)%nooffr(ll) + k4=k4+1 + if(phlista(lokph)%constitlist(k4).eq.loksp) goto 80 + enddo + elseif(ll.lt.lk3) then + k4=k4+phlista(lokph)%nooffr(ll) + endif + enddo +! constituent not found + write(kou,*)'No such constituent' + gx%bmperr=4066; goto 1000 +! constituent found in right sublattice +80 continue + typty=100*typty+k4 +! write(*,81)'3D: found: ',typty1,typty,lk3,k4,loksp +81 format(a,10i4) + endif +! write(*,*)'enter_parameter_inter 2: ',jph,lokph +! extract constituent array, remove final ) and decode + name3=parname(lp2+1:) + lp1=len_trim(name3) +! this removes the final ) + name3(lp1:)=' ' +! + call decode_constarr(lokph,name3,nsl,endm,nint,lint,ideg) + if(gx%bmperr.ne.0) goto 1000 +! write(*,83)'3D after d_c: ',name3(1:lp1),nint,(lint(2,kp),kp=1,nint) +83 format(a,a,i5,2x,5i4) +! finally remove all non-alphabetical characters in the function name by _ + kp=0 +100 continue + kp=kp+1 +105 continue + ch1=parname(kp:kp) +! should use ?? +! if(ucletter(ch1)) goto 100 + if(ch1.ge.'A' .and. ch1.le.'Z') goto 100 + if(ch1.ne.' ') then + parname(kp:)=parname(kp+1:) + goto 105 + endif + parname='_'//parname +!------------------------------------------------- +! if mode=0 enter the parameter, +! if mode=1 just list the parameter +! if mode=2 maybe amending (does FOOLED) work? + if(mode.eq.1) then + lfun=-1 +! write(*,*)'3D calling enter_parameter with lfun=',lfun + call enter_parameter(lokph,typty,fractyp,nsl,endm,nint,lint,ideg,& + lfun,refx) + goto 1000 + endif +! continue here to enter the parameter +! If parameter has no T dependendence just ask for value + if(btest(propid(typty1)%status,IDNOTP)) then + write(kou,*)'This parameter can only be a constant' + call gparr('Value: ',cline,ip,xxx,zero,q1help) + if(buperr.ne.0) then + xxx=zero; buperr=0 + endif +! the tpfun always want a low-T, expression; high-T N + write(longline,110)xxx +110 format(' 1 ',1pe16.7,'; 20000 N ') + jp=len_trim(longline)+2 + goto 200 + endif + if(btest(propid(typty1)%status,IDONLYP)) then + write(kou,*)'This parameter may not depend on T, only on P' + endif +!------------------------------------------------- +! now read the function. + call gparr('Low temperature limit /298.15/:',cline,ip,xxx,2.9815D2,q1help) + if(buperr.ne.0) then + buperr=0; longline=' 298.15 ' + jp=8 + else + longline=' ' + jp=1 + call wrinum(longline,jp,8,0,xxx) + if(buperr.ne.0) goto 1000 + jp=jp+1 + endif +! write(*,152)-1,jp,longline(1:jp) +!----------------------------------------------- +! return here for new expression in another range + lsc=1 +115 continue + call gparc('Expression, end with ";":',cline,ip,6,line,';',q1help) + if(buperr.ne.0) then + buperr=0; line=';' + endif +120 continue + longline(jp:)=line + jp=len_trim(longline)+1 +! write(*,152)0,jp,longline(1:jp) + if(index(longline(lsc:),';').le.0) then + call gparc('&',cline,ip,6,line,';',q1help) + if(buperr.ne.0) then + buperr=0; line=';' + endif + goto 120 +! else +! write(*,*)'Found ; at ',index(longline,';') + endif +150 continue + jp=jp+1 +! write(*,152)0,jp,longline(1:jp) +! lsc is positioned after the ; of previous ranges + lsc=jp +! write(*,152)1,ip,cline(1:ip) + call gparr('Upper temperature limit /6000/:',cline,ip,xxx,6.0D3,q1help) + if(buperr.ne.0) then + buperr=0; xxx=6.0D3 + endif + call wrinum(longline,jp,8,0,xxx) + if(buperr.ne.0) goto 1000 + call gparcd('Any more ranges',cline,ip,1,ch1,'N',q1help) + if(ch1.eq.'n' .or. ch1.eq.'N') then + longline(jp:)=' N' + jp=jp+3 + else + longline(jp:)='Y' + jp=jp+2 + goto 115 + endif +! jump here for parameters that are constants +200 continue + call gparcd('Reference symbol:',cline,ip,1,refx,'UNKNOWN',q1help) + call capson(refx) + longline(jp:)=refx + jp=len_trim(longline)+1 +! write(*,252)2,jp,longline(1:jp) +252 format('ep: ',2i3,'>',a,'<') +! + call capson(longline(1:jp)) +! write(*,*)'epi: ',longline(1:jp) + call enter_tpfun(parname,longline,lfun,.FALSE.) + if(gx%bmperr.ne.0) goto 1000 +! write(*,290)'enter_par 7: ',lokph,nsl,nint,ideg,lfun,refx +290 format(a,5i4,1x,a) +! + call enter_parameter(lokph,typty,fractyp,nsl,endm,nint,lint,ideg,lfun,refx) +! +1000 continue + return + end subroutine enter_parameter_interactivly + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine amend_global_data(cline,ipos) + implicit none + character cline*(*) + integer ipos +!\end{verbatim} + character name*24,current*24,ch1*1,chd*1 + current=globaldata%name +! write(*,*)'entering amend_global_data: ',cline(1:30) + call gparcd('System name: ',cline,ipos,1,name,current,q1help) + if(proper_symbol_name(name,0)) then + globaldata%name=name + else + write(kou,*)'Illegal name ignored' + goto 1000 + endif +100 continue + chd='N' + if(btest(globaldata%status,GSBEG)) then + chd='B' + elseif(btest(globaldata%status,GSADV)) then + chd='E' + else + chd='F' + endif + call gparcd('I am a beginner (B), freqent user (F) or expert (E): ',& + cline,ipos,1,ch1,chd,q1help) + call capson(ch1) + globaldata%status=ibclr(globaldata%status,GSBEG) + globaldata%status=ibclr(globaldata%status,GSADV) + globaldata%status=ibclr(globaldata%status,GSOCC) + if(ch1.eq.'B') then + globaldata%status=ibset(globaldata%status,GSBEG) + elseif(ch1.eq.'E') then + globaldata%status=ibset(globaldata%status,GSADV) + else + globaldata%status=ibset(globaldata%status,GSOCC) + endif +120 continue +! is global minimization allowed? + chd='Y' + if(btest(globaldata%status,GSNOGLOB)) chd='N' + call gparcd('Global gridminimization allowed: ',& + cline,ipos,1,ch1,chd,q1help) + if(ch1.eq.'Y' .or. ch1.eq.'y') then + globaldata%status=ibclr(globaldata%status,GSNOGLOB) + else + globaldata%status=ibset(globaldata%status,GSNOGLOB) + endif +! allow merging gridpoints after global? + chd='Y' + if(btest(globaldata%status,GSNOMERGE)) chd='N' + call gparcd('Merging gridpoints in same phase allowed: ',& + cline,ipos,1,ch1,chd,q1help) + if(ch1.eq.'Y' .or. ch1.eq.'y') then + globaldata%status=ibclr(globaldata%status,GSNOMERGE) + else + globaldata%status=ibset(globaldata%status,GSNOMERGE) + endif +! GSNOACS can be changed interactivly, 0 means allowed + chd='Y' + if(btest(globaldata%status,GSNOACS)) chd='N' + call gparcd('Composition sets can be created automatically? ',& + cline,ipos,1,ch1,chd,q1help) + if(ch1.eq.'Y' .or. ch1.eq.'y') then + globaldata%status=ibclr(globaldata%status,GSNOACS) + else + globaldata%status=ibset(globaldata%status,GSNOACS) + endif +! GSNOREMCS can be changed interactivly, 0 means not remove + chd='Y' + if(btest(globaldata%status,GSNOREMCS)) chd='N' + call gparcd('Delete unnecessary composition sets automatically? ',& + cline,ipos,1,ch1,chd,q1help) + if(ch1.eq.'Y' .or. ch1.eq.'y') then + globaldata%status=ibclr(globaldata%status,GSNOREMCS) + else + globaldata%status=ibset(globaldata%status,GSNOREMCS) + endif +1000 continue + return + end subroutine amend_global_data + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine enter_reference_interactivly(cline,last,mode,iref) +! enter a reference for a parameter interactivly +! this should be modified to allow amending an existing reference + implicit none + character cline*(*) + integer last,mode,iref +!\end{verbatim} +! stupid with a variable called L80 + character line*256,refid*16,L80*80 + integer jl,ip + call gparc('Reference identifier:',cline,last,1,refid,' ',q1help) + if(buperr.ne.0 .or. refid(1:1).eq.' ') then +! write(kou,*)'There must be an identifier' + gx%bmperr=4155; goto 1000 + endif + call capson(refid) +! check if unique, if mode=0 illegal + do jl=1,reffree-1 + if(refid.eq.bibrefs(jl)%reference) then + if(mode.eq.0) then +! write(kou,*)'Reference identifier not unique' + gx%bmperr=4156;goto 1000 + else + goto 70 + endif + endif + enddo +! if mode=1 one should have found the reference + if(mode.eq.1) then + write(kou,*)'No such reference' + goto 1000 + endif +70 continue + ip=1 + line=' ' +100 continue + call gparc('Reference text, end with ";":',cline,last,5,l80,';',q1help) + line(ip:)=l80 + ip=len_trim(line) + if(ip.le.1) then + write(kou,*)'There must be some reference text!' + ip=1; goto 100 + elseif(line(ip:ip).ne.';') then + ip=ip+1; goto 100 + else + line(ip:)=' ' + endif + call tdbrefs(refid,line,1,iref) +1000 continue + return + end subroutine enter_reference_interactivly + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine set_condition(cline,ip,ceq) +! decode an equilibrium condition, can be an expression with + and - +! the expression should be terminated with an = or value supplied on next line +! like "T=1000", "x(liq,s)-x(pyrrh,s)=0", "2*mu(cr)-3*mu(o)=muval" +! It can also be a "NOFIX=" or "FIX= value" +! The routine should also accept conditions identified with the ":" +! where is that preceeding each condition in a list_condition +! It should also accept changing conditions by :=new_value + implicit none + integer ip + character cline*(*) + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer nterm,kolon,iqz,krp,jp,istv,iref,iunit,jstv,jref,junit,jl,ks + integer linkix,norem,ics,kstv,iph,nidfirst,nidlast,nidpre,qp + character stvexp*80,stvrest*80,textval*32,c4*4 + character svtext*60,encoded*60,defval*18 + integer indices(4),allterms(4,10),condno,seqz + double precision coeffs(10),xxx,value + logical inactivate + type(gtp_state_variable), pointer :: svr + type(gtp_state_variable), dimension(10), target :: svrarr + TYPE(gtp_condition), pointer :: temp,new +50 continue +! extract symbol like T, X(FCC,CR), MU(C) etc up to space, +, - or = sign + stvexp=' ' + call gparcd('State variable: ',cline,ip,ichar('='),stvexp,'T',q1help) +! can there be any error return?? + if(buperr.ne.0) goto 1000 +! write(*,*)'in set_condition: ',ip,stvexp(1:20) +! is the line empty? + if(stvexp(1:1).eq.' ') then + gx%bmperr=4126; goto 1000 + endif +! write(*,*)'set_cond 0: ',stvexp(1:20) + nterm=0 +! check if there is a ":" in stvexp +! write(*,*)'set_condition: ',stvexp(1:40),ip + condno=0 + kolon=index(stvexp,':') + if(kolon.gt.0) then +! write(*,*)'3D: Found colon: ',kolon,stvexp(1:20) +! if(len_trim(stvexp).gt.kolon) then +! is there any text after : ignore the text before ": " WHY???? +! stvexp=stvexp(kolon+2:) +! else +! the user specifies the condition by giving its number like "5:=none" + iqz=1 + call getrel(stvexp,iqz,xxx) + if(buperr.ne.0) then + gx%bmperr=buperr; goto 1000 + endif + condno=int(xxx) +! write(*,*)'3D: Found condition number: ',condno,ip +! We cannot provide any default value + defval=' ' + goto 157 +! goto 155 +! endif + endif + if(stvexp(1:1).eq.'*') then +! user can remove all conditions (except phase status) by the line +! *=NONE + condno=-1 + goto 157 + endif +! check for phase status FIX or NOFIX, these are generated by change_status +! not given by user + if(stvexp(1:3).eq.'FIX') then + inactivate=.FALSE. + goto 300 + elseif(stvexp(1:5).eq.'NOFIX') then + inactivate=.TRUE. +! write(*,*)'3D Inactivate phase fix condition' + goto 300 + endif +! check if it is an expression with + or - +100 continue +! look for a ) followed by + or - + krp=index(stvexp,')') + if(krp.gt.0) then + if(stvexp(krp+1:krp+1).eq.'+' .or. stvexp(krp+1:krp+1).eq.'-') then + stvrest=stvexp(krp+1:) + stvexp(krp+1:)=' ' + else + stvrest=' ' + endif + else + stvrest=' ' + endif +! write(*,*)'set_cond 2: ',krp,stvexp(1:20),':',stvrest(1:20) +! there can be a factor in front of the state variable + jp=1 + call getrel(stvexp,jp,xxx) + if(buperr.ne.0) then +! write(*,*)'buperr ',buperr,jp +! 1035 and 1036 means a sign not followed by digits + if(buperr.eq.1035) then + xxx=one + stvexp=stvexp(2:) + elseif(buperr.eq.1036) then + xxx=-one + stvexp=stvexp(2:) + else + xxx=one + endif + buperr=0 + else + if(stvexp(jp:jp).eq.'*') then + stvexp=stvexp(jp+1:) + else + gx%bmperr=4130; goto 1000 + endif + endif +! decode state variable expression +! write(*,*)'3D, calling decode ',stvexp(1:20) +! call decode_state_variable(stvexp,istv,indices,iref,iunit,svr,ceq) + call decode_state_variable(stvexp,svr,ceq) + if(gx%bmperr.ne.0) goto 1000 + svtext=stvexp +! convert to old format +! if(svr%oldstv.ge.10) then +! istv=10*(svr%oldstv-5)+svr%norm +! else + istv=svr%oldstv +! endif + iref=svr%phref + iunit=svr%unit +! svr%argtyp specifies values in indices: +! svr%argtyp: 0=no arguments; 1=comp; 2=ph+cs; 3=ph+cs+comp; 4=ph+cs+const + indices=0 + if(svr%argtyp.eq.1) then + indices(1)=svr%component + elseif(svr%argtyp.eq.2) then + indices(1)=svr%phase + indices(2)=svr%compset + elseif(svr%argtyp.eq.3) then + indices(1)=svr%phase + indices(2)=svr%compset + indices(3)=svr%component + elseif(svr%argtyp.eq.4) then + indices(1)=svr%phase + indices(2)=svr%compset + indices(3)=svr%constituent +! else +! write(*,*)'state variable has illegal argtyp: ',svr%argtyp +! gx%bmperr=7775; goto 1000 + endif +! + if(istv.lt.0) then +! istv < 0 means it is a parameter property symbol like TC, illegal as cond + gx%bmperr=4127; goto 1000 + endif +! Use kstv=(istv+1)/10+5 as check + kstv=(istv+1)/10+5 +! write(*,*)'condition code: ',istv,kstv +! if(kstv.eq.14 .or. kstv.eq.15 .or. kstv.ge.19) then + if(kstv.eq.14 .or. kstv.eq.15) then +! the state variables Q and DG are illegal as conditions + gx%bmperr=4127; goto 1000 + endif +! write(*,117)stvexp(1:10),istv,indices +!117 format('3D, sc: ',a,i7,5x,4i3) + if(istv.ge.3 .and. istv.le.5) then +! this is MU, AC and LNAC, do not allow phase index (at present) + if(indices(2).ne.0) then + write(*,*)'Phase specific chemical potentials not allowed as conditions' + gx%bmperr=7777; goto 1000 + endif + endif + if(nterm.gt.0) then +! it must be the same state variable in all terms + if(istv.ne.jstv .or. iref.ne.jref .or. iunit.ne.junit) then + gx%bmperr=4128; goto 1000 + endif + else + jstv=istv + jref=iref + junit=iunit + endif + nterm=nterm+1 +! save svr record if several terms + svrarr(nterm)=svr + coeffs(nterm)=xxx + do jl=1,4 + allterms(jl,nterm)=indices(jl) + enddo + stvexp=stvrest +! write(*,*)'set_cond rest "',stvrest(1:20),'"' + jp=1 + if(.not.eolch(stvexp,jp)) goto 100 +!--------------- +150 continue +! the expression (or single variable) is decoded, get value after = sign +! provide the current value as default + encoded=' ' + call get_state_var_value(svtext,xxx,encoded,ceq) + if(gx%bmperr.ne.0) then +! This error occurs when setting the first compositions before any calculations +! write(*,152)gx%bmperr,svtext(1:len_trim(svtext)) +!152 format('Cannot get current value of: ',a,', error: ',i5/& +! 'Setting default value to zero') + gx%bmperr=0; xxx=zero + endif +! jump here if we have found a : specifying a condition number +! Do not expect any = sign +155 continue +! write(*,*)'3D we are here',ip + qp=1 + defval=' ' + call wrinum(defval,qp,10,0,xxx) + if(buperr.ne.0) then + buperr=0; defval=' ' + endif +157 continue +! write(*,*)'3D we are here: ',defval + call gparcd('Value: ',cline,ip,1,textval,defval,q1help) +! if(buperr.ne.0) then +! gx%bmperr=4129; buperr=0; goto 1000 +! endif +! value can be a symbol or a numeric value. Symbols not allowed yet +! write(*,*)'set_condition value ',textval(1:20) + inactivate=.false. + jp=1 + c4=textval(jp:jp+3) + call capson(c4) + if(c4.eq.'NONE') then +! value NONE means inactivate +! Problem when setting T=NONE, ceq%tpval(1) could have any value afterwards + inactivate=.true. +! write(*,*)'Inactivate condition: ',condno,value,xxx + value=xxx + else +! write(*,*)'gtp3D textval: ',textval + call getrel(textval,jp,value) + if(buperr.ne.0) then +! here one should look for a symbol + buperr=0 + call capson(textval) + do ks=1,nsvfun + if(textval(1:16).eq.svflista(ks)%name) then +! found symbol, insert link + linkix=ks + goto 170 + endif + enddo +! neither numeric value nor symbol, give error +! Some symbols must not be allowed for values ..... + gx%bmperr=4129; buperr=0; goto 1000 + else + linkix=-1 + endif +170 continue +! write(*,*)'gtp3D value: ',value + endif +! check if condition already exists. If condno>0 it must exist or error + temp=>ceq%lastcondition +! write(*,*)'3D condno: ',condno,value,buperr + if(condno.eq.0) then +! call get_condition(nterm,coeffs,jstv,allterms,iref,iunit,temp) + call get_condition(nterm,svr,temp) + elseif(condno.lt.0) then + if(inactivate) then +! user has given *=NONE, remove all conditions except phase status FIX +! as inactive conditions are ignored just remove first acive until error + norem=1 +210 continue + temp=>ceq%lastcondition +! call get_condition(0,coeffs,norem,allterms,iref,iunit,temp) + call get_condition(nterm,svr,temp) + if(gx%bmperr.ne.0) then + gx%bmperr=0; goto 1000 + endif + if(temp%statev.gt.0) then +! write(*,*)'inactivate ',norem,temp%statev + temp%active=1 + endif + goto 210 +! no else path needed + endif + else +! user has given "5:= ..." and condition 5 must exist, otherwise error +! call get_condition(0,coeffs,condno,allterms,iref,iunit,temp) + qp=-condno +! write(*,*)'3D calling get_condition ',qp + call get_condition(qp,svr,temp) + if(gx%bmperr.ne.0) then + write(*,*)'Condition number error ',gx%bmperr + goto 1000 + endif + endif +277 continue +! write(*,*)'At label 277: ',gx%bmperr + newcond: if(gx%bmperr.ne.0) then +! condition does not exist, but if set equal to NONE just ignore it + gx%bmperr=0 + if(inactivate) goto 900 + else !newcond + if(inactivate) then +! remove condition + temp%active=1 +! write(*,*)'inactivating: ',ceq%tpval(1) + else +! condition already exist, just change value and activate + temp%active=0 + temp%symlink1=-1 + if(linkix.lt.0) then +! special for T and P, change the local value also +! write(*,*)'set condition ',istv,value + if(istv.eq.1) then + if(value.lt.1.0D-1) then +! illegal value of T + write(*,*)'Temparure must be larger than 0.1 K' + gx%bmperr=4187; goto 1000 + endif + ceq%tpval(1)=value + temp%prescribed=value + elseif(istv.eq.2) then + if(value.lt.1.0D-1) then +! illegal value of P + write(*,*)'Pressure must be larger than 0.1 Pa' + gx%bmperr=4187; goto 1000 + endif + ceq%tpval(2)=value + temp%prescribed=value + else +! write(*,*)'gtp3D: condition',value + temp%prescribed=value + endif + else + temp%symlink1=linkix + endif + endif + goto 900 + endif newcond + goto 500 +!----------------------------------------------------------------- +! handle fix/nofix of a phase, a condition should be set inactive. +300 continue + ip=ip+1 +! write(*,*)'3D fix phase: ',ip,cline(ip:40) + call find_phase_by_name(cline(ip:),iph,ics) + if(gx%bmperr.ne.0) goto 1000 + nterm=1 + jstv=-iph + iref=ics + iunit=0 + linkix=-1 + coeffs(1)=1.0D0 + do jl=1,4 + allterms(jl,1)=0 + enddo +! convert to state variable +! write(*,*)'3D Setting svrarr(1) values' + svrarr(1)%statevarid=jstv + svrarr(1)%oldstv=jstv + svrarr(1)%phase=ics + svrarr(1)%unit=0 + svrarr(1)%argtyp=0 + svrarr(1)%phase=iph + svrarr(1)%compset=ics + svrarr(1)%component=0 + svrarr(1)%constituent=0 +! + temp=>ceq%lastcondition +! write(*,*)'3D calling get_condition' + svr=>svrarr(1) + call get_condition(nterm,svr,temp) +! write(*,*)'3D Back from get_condition ',gx%bmperr + if(gx%bmperr.eq.0) then + if(inactivate) then +! inactivate condition + temp%active=1 + else +! set new value of prescribed amount, must be numerical, not symbol + temp%active=0 + ip=index(cline,'==')+2 + call getrel(cline,ip,value) + if(buperr.ne.0) then +! write(*,*)'error setting fix amount old cond',ip,cline(1:40) + gx%bmperr=4100; goto 1000 + endif + temp%prescribed=value + temp%symlink1=-1 + endif + goto 1000 + else +! if inactivate it is an error not finding the condition +! write(*,*)'Finding condition error ',gx%bmperr + if(inactivate) then + write(*,*)'We should have found a condition ',gx%bmperr + goto 1000 + endif + gx%bmperr=0 + endif +! Here we create a new condition !!! +! get the value for the new condition + ip=index(cline,'==')+2 + call getrel(cline,ip,value) + if(buperr.ne.0) then + write(*,*)'error setting fix amount ',ip,cline(1:40) + gx%bmperr=4100; goto 1000 + endif +! write(*,*)'3D Set fix phase amount: ',value +!----------------------------------------------- +! create a new condition record for this equilibrium (can be the first) +500 continue +! first test if condition on P or T is larger than 0.1 + if(jstv.eq.1 .or. jstv.eq.2) then + if(value.lt.0.1D0) then + gx%bmperr=4187; goto 1000 + endif + endif + if(associated(ceq%lastcondition)) then + seqz=ceq%lastcondition%seqz+1 + else + seqz=1 + endif + temp=>ceq%lastcondition +! write(*,*)'3D allocating condition',seqz + allocate(ceq%lastcondition) + new=>ceq%lastcondition + new%noofterms=nterm + new%statev=jstv + new%iunit=iunit + new%iref=iref + new%active=0 + new%seqz=seqz +! write(*,*)'allocating terms',nterm + allocate(new%condcoeff(nterm)) + allocate(new%indices(4,nterm)) +! write(*,*)'allocations ok' + do jl=1,nterm + new%condcoeff(jl)=coeffs(jl) + do ks=1,4 + new%indices(ks,jl)=allterms(ks,jl) + enddo + enddo + if(linkix.lt.0) then + new%prescribed=value + new%symlink1=-1 +! special for T and P, change the local value +! write(*,*)'set condition ',istv,jstv,value + if(istv.eq.1) then + ceq%tpval(1)=value + elseif(istv.eq.2) then + ceq%tpval(2)=value + endif + else + new%symlink1=linkix + endif +! store the state variable record in the condition + allocate(new%statvar(nterm)) + do jl=1,nterm + new%statvar(jl)=svrarr(jl) + enddo +! link the new record into the condition list +! write(*,*)'linking condition' + if(associated(temp)) then +! write(*,*)'Second or later condition' + nidlast=temp%next%nid + nidfirst=temp%nid + nidpre=temp%previous%nid + new%nid=nidlast+1 + temp%next%previous=>new + new%next=>temp%next + temp%next=>new + new%previous=>temp + else +! create the circular list + new%nid=1 + new%next=>new + new%previous=>new + endif +900 continue + if(.not.eolch(cline,ip)) then +! look for more conditions. Note that gparc increment ip by 1 at start +! write(*,901)cline(ip-1:ip+20) +901 format(' >',a,"<") + if(cline(ip:ip).ne.',') ip=ip-1 + goto 50 + endif +! finally, for conditions on T and P copy value to ceq%tpval +! This may be a bit inconsistent .... but?? + if(jstv.eq.1 .and. iunit.eq.0 .and. iref.eq.0) then + ceq%tpval(1)=value + elseif(jstv.eq.2 .and. iunit.eq.0 .and. iref.eq.0) then + ceq%tpval(2)=value + endif +! mark that any current results may be inconsistent with new conditions +! globaldata%status=ibset(globaldata%status,GSINCON) + ceq%status=ibset(ceq%status,EQINCON) +1000 continue +! write(*,*)'exit set_condition, T= ',ceq%tpval(1) + return + end subroutine set_condition + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine get_condition(nterm,svr,pcond) +! finds a condition record with the given state variable expression +! If nterm<0 the absolute value of nterm is condition number, svr is irrelevant + implicit none + integer nterm + type(gtp_state_variable), pointer :: svr +! NOTE: pcond must have been set to ceq%lastcondition before calling this +! pcond: pointer, to a gtp_condition record for this equilibrium + type(gtp_condition), pointer :: pcond +!\end{verbatim} %+ + type(gtp_condition), pointer :: last + type(gtp_state_variable), pointer :: condvar + integer j1,num + if(.not.associated(pcond)) goto 900 +! write(*,*)'3D in get_condition: ',svr%statevarid,svr%oldstv,svr%argtyp +! if(nterm.lt.0) write(*,*)'3D Condition number: ',-nterm + last=>pcond + num=0 +100 continue +! search for condition abs(nterm) + if(nterm.lt.0 .and. num+nterm.eq.0) goto 1000 + num=num+1 + if(pcond%noofterms.eq.nterm) then + do j1=1,nterm + condvar=>pcond%statvar(j1) +! write(*,*)'3D get_condition: ',num,condvar%oldstv,condvar%argtyp +! dissapointment, one cannot compare two structures ... unless pointers same +! if(condvar.ne.svr) goto 200 +! j2=1 + if(condvar%oldstv.ne.svr%oldstv) goto 200 +! j2=2 + if(condvar%argtyp.ne.svr%argtyp) goto 200 +! j2=3 + if(condvar%phase.ne.svr%phase) goto 200 +! j2=4 + if(condvar%compset.ne.svr%compset) goto 200 + if(condvar%statevarid.lt.0) goto 1000 +! for fix phase the remaining have no importance +! j2=5 + if(condvar%component.ne.svr%component) goto 200 +! j2=6 + if(condvar%constituent.ne.svr%constituent) goto 200 +! j2=7 + if(condvar%norm.ne.svr%norm) goto 200 +! j2=8 + if(condvar%unit.ne.svr%unit) goto 200 + enddo +! we have found a condition with these state variables +! write(*,*)'3D Found condition',pcond%active + goto 1000 + endif +200 continue +! write(*,*)'Failed at argument: ',j2 + pcond=>pcond%next + if(.not.associated(pcond,last)) goto 100 +900 continue +! write(*,*)'3D get_condition: No such condition' + gx%bmperr=7779; goto 1000 +1000 continue + return +end subroutine get_condition + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine get_condition2(nterm,coeffs,istv,indices,iref,iunit,pcond) +! finds a condition record with the given state variable expression +! nterm: integer, number of terms in the condition expression +! istv: integer, state variable used in the condition +! indices: 2D integer array, state variable indices used in the condition +! iref: integer, reference state of the condition (if applicable) +! iunit: integer, unit of the condition value +! NOTE: pcond must have been set to ceq%lastcond before calling this routine!!! +! pcond: pointer, to a gtp_condition record for this equilibrium +! NOTE: conditions like expressions x(mg)-2*x(si)=0 not implemeneted +! fix phases as conditions have negative condition variable + implicit none + TYPE(gtp_condition), pointer :: pcond + integer, dimension(4,*) :: indices + integer nterm,istv,iref,iunit + double precision coeffs(*) +!\end{verbatim} %+ + TYPE(gtp_condition), pointer :: current,first +! integer, dimension(4) :: indx + integer ncc,nac,j1,j2 +! write(*,*)'looking for condition' +! pcond must have been set to ceq%lastcond before calling this routine!!! + if(.not.associated(pcond)) goto 900 + first=>pcond%next + current=>first +! write(*,*)'get_condition start: ',current%statev,current%active + ncc=1 + nac=0 + if(ocv()) write(*,98)'new:',0,nterm,istv,(indices(j1,1),j1=1,4),iref,iunit +98 format(a,2x,i2,5x,2i4,5x,4i4,5x,2i3) +100 continue + if(ocv()) write(*,98)'old:' ,current%nid,current%noofterms,current%statev,& + (current%indices(j1,1),j1=1,4),current%iref,current%iunit + if(nterm.eq.0) then +! why nterm=0? Check!!! + if(ocv()) write(*,*)'get_condition: ',istv,ncc,nac + if(current%active.eq.0) then +! this call just looks for active condition istv + nac=nac+1 +! why should fix phase conditions have istv=nac?? Check!! + if(nac.eq.istv) then +! a condition specified like this must not be a phase status change + if(current%statev.lt.0) then + write(kou,*)'You must use "set phase status" to change fix status' + else + goto 150 + endif + endif + endif + goto 200 + endif + if(ocv()) write(*,103)'Checking terms, istv, iref and unit ',& + nac,ncc,nterm,current%noofterms +103 format(a,6i5) + if(current%noofterms.ne.nterm .or. current%statev.ne.istv .or. & + current%iref.ne.iref .or. current%iunit.ne.iunit) goto 200 + if(ocv()) write(*,*)'Checking indices' + do j1=1,nterm + do j2=1,4 + if(current%indices(j2,j1).ne.indices(j2,j1)) goto 200 + enddo + enddo +150 continue +! found condition + pcond=>current +! write(*,*)'Found condition: ',pcond%nid,ncc + goto 1000 +200 continue + current=>current%next + ncc=ncc+1 + if(.not. associated(current,first)) goto 100 +900 continue +! no such condition + gx%bmperr=4131; goto 1000 +1000 continue + return + end subroutine get_condition2 + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} %- + subroutine extract_stvr_of_condition(pcond,nterm,coeffs,statevar) +! finds a condition record with the given state variable record +! returns it as a state variable record !!! +! nterm: integer, number of terms in the condition expression +! pcond: pointer, to a gtp_condition record + implicit none + TYPE(gtp_condition), pointer :: pcond +! ONE CANNOT HAVE ARRAYS OF POINTERS!!! STUPID +! TYPE(gtp_state_variable), dimension(*), pointer :: statevar + TYPE(gtp_state_variable), dimension(*) :: statevar + integer nterm + double precision coeffs(*) +!\end{verbatim} + TYPE(gtp_condition), pointer :: current,first +! integer, dimension(4) :: indx + integer ncc,nac,j1,istv,iref,iunit +! + write(*,*)'not implemented!!' + gx%bmperr=7777; goto 1000 +!-------------------------------------------------------- + if(.not.associated(pcond)) goto 900 + first=>pcond%next + current=>first +! write(*,*)'get_condition start: ',current%statev,current%active + ncc=1 + nac=0 +! write(*,98)'new:',0,nterm,istv,(indices(i,1),i=1,4),iref,iunit +98 format(a,2x,i2,5x,2i4,5x,4i4,5x,2i3) +100 continue +! write(*,98)'old:' ,current%nid,current%noofterms,current%statev,& +! (current%indices(i,1),i=1,4),current%iref,current%iunit + if(nterm.eq.0) then +! write(*,*)'get_condition: ',istv,ncc,nac + if(current%active.eq.0) then +! this call just looks for active condition istv + nac=nac+1 +! why should fix phase conditions have istv=nac?? Check!! + if(nac.eq.istv) then +! a condition specified like this must not be a phase status change + if(current%statev.lt.0) then + write(kou,*)'You must use "set phase status" to change fix status' + else + goto 150 + endif + endif + endif + goto 200 + endif + if(current%noofterms.ne.nterm .or. current%statev.ne.istv .or. & + current%iref.ne.iref .or. current%iunit.ne.iunit) goto 200 + do j1=1,nterm +! do j2=1,4 +! if(current%indices(j2,j1).ne.indices(j2,j1)) goto 200 +! enddo + enddo +150 continue +! found condition + pcond=>current +! write(*,*)'Found condition: ',pcond%nid,ncc + goto 1000 +200 continue + current=>current%next + ncc=ncc+1 + if(.not. associated(current,first)) goto 100 +900 continue +! no such condition + gx%bmperr=4131; goto 1000 +1000 continue + return + end subroutine extract_stvr_of_condition + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine locate_condition(seqz,pcond,ceq) +! locate a condition using a sequential number + implicit none + integer seqz + type(gtp_condition), pointer :: pcond + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer ij + pcond=>ceq%lastcondition + do ij=1,seqz + pcond=>pcond%next + if(seqz.gt.ij .and. associated(pcond,ceq%lastcondition)) then + write(*,*)'Locate condition called with too high index: ',seqz + gx%bmperr=7777; goto 1000 + endif + enddo +1000 continue + return + end subroutine locate_condition + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine apply_condition_value(current,what,value,cmix,ceq) +! This is called when calculating an equilibrium. +! It returns a condition at each call, at first call current must be nullified? +! When all conditions done the current is nullified again +! If what=-1 then return degrees of freedoms and maybe something more +! what=0 means calculate current values of conditions +! calculate the value of a condition, used in minimizing G + implicit none + integer what,cmix(*) + double precision value + TYPE(gtp_equilibrium_data), pointer :: ceq + TYPE(gtp_condition), pointer :: current +!\end{verbatim} %+ +! ceq is actually redundant as current is a pointer to condition list in ceq + integer, dimension(4) :: indices + integer iref,iunit,jl,istv,ip + character encoded*60,actual_arg*60 +! +100 continue + if(current%active.ne.0) then +! return 0 for inactive conditions + cmix(1)=0; goto 1000 + endif + if(what.ge.0) goto 200 +!---------------------------------------------------------- +! Here we should return information about conditions on potentials (T, P, MU) +! and fix phases + cmix(1)=0 + if(current%noofterms.gt.1) then +! cannot hanlde conditions with several terms + write(*,*)'Found condition with several terms' + gx%bmperr=7777; goto 900 + endif +! for debugging + istv=current%statev + do jl=1,4 + indices(jl)=current%indices(jl,1) + enddo + iref=current%iref + iunit=current%iunit + ip=1 + encoded=' ' + actual_arg=' ' +!------------------ + if(current%statev.lt.0) then +! a fix phase cpndition has state variable equal to -iph, ics is stored in iref + cmix(1)=4 + cmix(2)=-current%statev + cmix(3)=current%iref + value=current%prescribed +! write(*,*)'3D Fix phase: ',-current%statev,current%iref,value + elseif(current%statev.eq.1) then +! temperature + cmix(1)=1 + value=current%prescribed +! write(*,*)'conditon on T' + elseif(current%statev.eq.2) then +! pressure + cmix(1)=2 + value=current%prescribed +! write(*,*)'conditon on P' + elseif(current%statev.le.5) then +! potentials has statev=1..5 (T, P, MU, AC, LNAC) + cmix(1)=3 + cmix(2)=current%statev + cmix(3)=current%indices(1,1) + value=current%prescribed +! write(*,*)'condition on MU/AC/LNAC' + elseif(current%statev.ge.10) then +! other condition must be on extensive properties (N, X, H etc) + cmix(1)=5 +! write(*,*)'Extensive condition: ',current%statev + else + write(*,*)'Illegal condition',current%statev + gx%bmperr=7777; goto 1000 + endif + goto 900 +!-------------------------------------- +! Here we should return extensive condition, maybe calculate value +200 if(what.ne.0) goto 300 + cmix(1)=0 + if(current%noofterms.gt.1) then +! ignore conditions with several terms + write(*,*)'Found condition with several terms' + gx%bmperr=8888; goto 1000 + endif +! for debugging + istv=current%statev + do jl=1,4 + indices(jl)=current%indices(jl,1) + enddo + iref=current%iref + iunit=current%iunit + ip=1 + encoded=' ' + actual_arg=' ' +!------------------ + if(current%statev.lt.10) goto 900 +! condition must be on extensive properties (N, X, H etc) + cmix(1)=5 + cmix(2)=current%statev +! indices are dimensioned (4,nterms) + cmix(3)=current%indices(1,1) + cmix(4)=current%indices(2,1) + cmix(5)=current%indices(3,1) + cmix(6)=current%indices(4,1) + value=current%prescribed + goto 900 +!-------------------------------------- +! this part is redundant .... +300 continue + write(*,*)'Calling apply_condition with illegal option' + gx%bmperr=8888; goto 1000 +!----------------------------------------------------------- +! maybe something common +900 continue +! +1000 continue + return + end subroutine apply_condition_value + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine condition_value(mode,pcond,value,ceq) +! set (mode=0) or get (mode=1) a new value of a condition. Used in mapping + implicit none + integer mode + type(gtp_condition), pointer :: pcond + type(gtp_equilibrium_data), pointer :: ceq + double precision value +!\end{verbatim} + if(mode.eq.0) then +! set the value + pcond%prescribed=value +! special for T and P + if(pcond%statev.eq.1) then + ceq%tpval(1)=value + elseif(pcond%statev.eq.2) then + ceq%tpval(2)=value + endif + elseif(mode.eq.1) then + value=pcond%prescribed + else + write(*,*)'Condition value called with illegal mode' + endif +1000 continue + return + end subroutine condition_value + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + + +!\begin{verbatim} + subroutine amend_components(cline,last,ceq) +! enter a new set of components for equilibrium ceq + implicit none + integer last + character cline*(*) + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + character symb*24 + integer lokic(maxel),ielno(10) + double precision stoi(maxel,maxel+1),invstoi(maxel,maxel),spst(10) + integer ic,loksp,nspel,jl,j2,ierr + double precision spmass,qsp +! input is a list of species name, same as number of elements + stoi=zero + ic=0 +100 continue + call gparc('Give all components: ',cline,last,1,symb,' ',q1help) + call find_species_record(symb,loksp) + if(gx%bmperr.ne.0) goto 1000 +! check not same species twice + do jl=1,ic + if(loksp.eq.lokic(jl)) then +! write(*,*)'Same species twice' + gx%bmperr=4162; goto 1000 + endif + enddo + ic=ic+1 + lokic(ic)=loksp +! get the stoichiometry and save it in row in stoi + call get_species_data(loksp,nspel,ielno,spst,spmass,qsp) + if(gx%bmperr.ne.0) goto 1000 + do jl=1,nspel + stoi(ic,ielno(jl))=spst(jl) + enddo + if(ic.lt.noofel) goto 100 +! check that stoichiometry matrix not singular, should calculate the inverse +! do i=1,ic +! write(*,200)(stoi(i,j),j=1,ic) +!200 format('X: ',6(1PE12.4)) +! enddo +! lukasnum routine to invert matrix + call mdinv(maxel,maxel+1,stoi,invstoi,ic,ierr) +! check the matrix and its inverse +! do i=1,ic +! write(*,200)(invstoi(i,j),j=1,ic) +! enddo + if(ierr.eq.0) then +! write(*,*)'Component matrix singular' + gx%bmperr=4163; goto 1000 + endif + if(allocated(ceq%compstoi)) then + deallocate(ceq%compstoi) + deallocate(ceq%invcompstoi) + endif + allocate(ceq%compstoi(ic,ic)) + allocate(ceq%invcompstoi(ic,ic)) +! write(*,*)(lokic(i),i=1,ic) + do jl=1,ic + ceq%complist(jl)%splink=lokic(jl) +! phlink=0 means no user defined reference state + ceq%complist(jl)%phlink=0 + ceq%complist(jl)%status=0 + ceq%complist(jl)%tpref=zero + ceq%complist(jl)%chempot=zero + ceq%complist(jl)%mass=spmass + do j2=1,ic + ceq%compstoi(jl,j2)=stoi(jl,j2) + ceq%invcompstoi(jl,j2)=invstoi(jl,j2) + enddo + enddo +1000 continue + return + end subroutine amend_components + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine ask_default_constitution(cline,last,iph,ics,ceq) +! set values of default constitution interactivly +! phase and composition set already given + implicit none + character cline*(*) + integer last,iph,ics + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer lokph,lokcs,ky,ll,iy,jy,is,ip,abel,subl + real mmyfr(maxconst) + character quest*32,name*24,vdef*4,fdef*8 + double precision xxx + call get_phase_compset(iph,ics,lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 +! if PHNOCV set the composition is fixed + if(btest(phlista(lokph)%status1,PHNOCV)) goto 1000 + write(*,10) +10 format('Give min or max fractions (< or negative value as max)',& + ' or NONE for no default') + name=' ' + ky=0 + do ll=1,phlista(lokph)%noofsubl + if(phlista(lokph)%nooffr(ll).gt.1) then +! more than one constituent + do iy=1,phlista(lokph)%nooffr(ll) + ky=ky+1 + call get_phase_constituent_name(iph,ky,name,subl) + if(gx%bmperr.ne.0) then + write(*,*)'3D default: ',iph,ky,iy + goto 1000 + endif + quest='Default for '//name(1:len_trim(name))//& + '#'//char(ichar('0')+ll) +! use current value as default if nonzero + vdef=' ' + abel=10*abs(ceq%phase_varres(lokcs)%mmyfr(ky)) +! write(*,*)'3D abel:',ky,abel,ceq%phase_varres(lokcs)%mmyfr(ky) + if(abel.ge.10) then + vdef=' 1.0' + elseif(abel.le.0) then + vdef=' 0.1' + else + vdef=' 0.'//char(ichar('0')+abel) + endif + if(ceq%phase_varres(lokcs)%mmyfr(ky).lt.0.0) then + vdef(1:1)='<' + elseif(ceq%phase_varres(lokcs)%mmyfr(ky).gt.0.0) then + vdef(1:1)='>' + else + vdef='NONE' + endif +! + call gparcd(quest,cline,last,1,fdef,vdef,q1help) + jy=1 + if(fdef(1:4).eq.'NONE') then + xxx=0 + is=1 + elseif(eolch(fdef,jy)) then + xxx=-1.0D-1 + else + is=1 + if(fdef(jy:jy).eq.'<') then + is=-1 + jy=jy+1 + elseif(fdef(jy:jy).eq.'>') then + jy=jy+1 + endif +! write(*,*)'3D def1: ',fdef,jy + call getrel(fdef,jy,xxx) + if(buperr.ne.0) then +! write(*,*)'3D buperr ',buperr + buperr=0 + endif + if(is.lt.0) xxx=-xxx + endif + if(abs(xxx).gt.one) xxx=sign(xxx,one) +! write(*,*)'3D default: ',xxx + mmyfr(ky)=real(xxx) + enddo + else +! a single constituent, we must increment ky as there may be more + ky=ky+1 + mmyfr(ky)=1.0 + endif + enddo + call enter_default_constitution(iph,ics,mmyfr,ceq) +! write(*,99)(mmyfr(jy),jy=1,ky) +99 format('3D: ',15(f5.1)) +1000 continue + return + end subroutine ask_default_constitution + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine set_input_amounts(cline,lpos,ceq) +! set amounts like n(specie)=value or b(specie)=value +! value can be negative removing amounts +! values are converted to moles and set or added to conditions + implicit none + integer lpos + character cline*(*) + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + TYPE(gtp_state_variable), pointer :: svr + TYPE(gtp_condition), pointer :: current,first,last + character species*32,cval*16,statevar*4,condline*32 + integer ielno(10) + double precision addval(maxel) + integer k,loksp,istv,jel,ip + double precision xval,sumstoi,xmols +! repeat reading until empty line +100 continue + addval=zero + call gparc('Species amount as N(..) or B(...): ',& + cline,lpos,1,species,' ',q1help) + call capson(species) + statevar=species(1:1) + if(statevar.ne.' ') then + if(.not.(statevar(1:1).ne.'N' .or. statevar(1:1).ne.'B')) then + write(*,*)'Illegal state variable for input amounts' + goto 1000 + endif + k=index(species,')') + if(k.le.3) then + write(*,*)'Species must be surrounded by ( )' + gx%bmperr=7777; goto 1000 + endif + cval=species(k+1:) + species=species(3:k-1) +! write(*,*)'3D Species: ',species + if(index(species,',').gt.0 .or. index(species,'(').gt.0) then + write(*,*)'Use only N(species) or B(species) in input amounts' + goto 1000 + endif + else + goto 1000 + endif + call find_species_record(species,loksp) +! not needed as we can access splista +! call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp) + if(gx%bmperr.ne.0) goto 1000 +! if user writes N(C)=2 the =2 will be in cval, if a space after = in cline + if(cval(1:2).eq.'= ') goto 200 + goto 300 +200 continue +! the user can also give values without = or with a space before = +! but no space allowed after = + call gparc('Amount: ',cline,lpos,1,cval,' ',q1help) +300 continue + if(cval(1:1).eq.'=') cval(1:1)=' ' + ip=1 + call getrel(cval,ip,xval) + if(buperr.ne.0) then + write(*,*)'Amount must be a real number' + goto 1000 + endif +! this return the internal code for N +! call decode_state_variable('N ',istv,indices,iref,iunit,svr,ceq) + call decode_state_variable('N ',svr,ceq) + if(gx%bmperr.ne.0) then + write(*,*)'Error decoding N in set_input_amounts' + goto 1000 + endif + istv=svr%oldstv +! if B convert to N: moles of species = input_mass/mass_of_species +! moles of element = stoiciometry_of_element/total_number_of_elements + if(statevar(1:1).eq.'B') then + write(kou,*)'Note: set input in mass converted to moles' + xmols=xval/splista(loksp)%mass + else + xmols=xval + endif + sumstoi=zero + do jel=1,splista(loksp)%noofel + ielno(jel)=splista(loksp)%ellinks(jel) + addval(ielno(jel))=splista(loksp)%stoichiometry(jel)*xmols + sumstoi=sumstoi+splista(loksp)%stoichiometry(jel) + enddo +! now create or att to existing conditions + last=>ceq%lastcondition + jel=1 + if(.not.associated(last)) goto 600 +! return here to look for condition for another element +500 continue +! write(*,*)'At 500',last%nid,last%next%nid + first=>last%next + current=>first +! loop for all condition +510 continue +! write(*,*)'loop: ',current%nid,current%indices(1,1),ielno(jel) +! check if this condition match amount of element jel + if(current%noofterms.eq.1) then + if(current%statev.eq.istv) then + if(current%indices(1,1).eq.ielno(jel) .and. & + current%indices(2,1).eq.0) then +! we have found an identical contition, add the new amount +! if condition not active (active=/=0) then activate and zero prescibed amount + if(current%active.ne.0) then + current%active=0 + current%prescribed=zero + endif + current%prescribed=current%prescribed+addval(ielno(jel)) + goto 700 + endif + endif + endif + current=>current%next +! write(*,*)'next: ',current%nid,first%nid + if(.not.associated(current,first)) goto 510 +600 continue +! new condition needed + condline='N('//ellista(ielno(jel))%symbol& + (1:len_trim(ellista(ielno(jel))%symbol))//')=' + ip=len_trim(condline)+1 + call wrinum(condline,ip,10,0,addval(ielno(jel))) +! write(*,*)'new condition: ',condline +! set_condition starts by incementing ip + ip=0 + call set_condition(condline,ip,ceq) + if(gx%bmperr.ne.0) goto 1000 + if(.not.associated(last)) then +! if ceq%lastcondition was not associated above the call to set_condition +! will have set link in ceq%lastcondition + last=>ceq%lastcondition +! write(*,*)'condition id: ',last%nid + endif +700 continue + jel=jel+1 + if(jel.le.splista(loksp)%noofel) goto 500 +! all elements for this species set as conditions, check if any more + if(.not.eolch(cline,lpos)) goto 100 +! +1000 continue + return + end subroutine set_input_amounts + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine get_parameter_typty(name1,lokph,typty,fractyp) +! interpret parameter identifiers like MQ&C#2 in MQ&C#2(FCC_A1,FE:C) ... +! find the property associated with this symbol + integer typty,fractyp,lokph + character name1*(*) +!\end{verbatim} + integer nr,typty1,iel,isp,kel,loksp,lk3,kq,k4,kk,ll + character elnam*24 +! It can be a mobility with a & inside + kel=index(name1,'&') + if(kel.gt.0) then +! note that elnam may contain sublattice specification like Fe+2#2 + elnam=name1(kel+1:) + name1=name1(1:kel-1) + endif + kq=len_trim(name1) +! write(*,*)'3D: fractyp: ',kq,name1(1:kq) + if(name1(kq:kq).eq.'D') then +! A final "D" on the paramer symbol indicates fractyp=2 + name1(kq:kq)=' ' + fractyp=2 + else + fractyp=1 + endif +!---------------------- +! write(*,*)'Property symbol: "',propid(nr)%symbol,'" >',name1(1:4),'<' + do nr=1,ndefprop + if(name1(1:4).eq.propid(nr)%symbol) then + goto 70 + endif + enddo +! no matching symbol + gx%bmperr=7777; goto 1000 +! +70 continue + typty=nr + typty1=nr + iel=0; isp=0 + if(kel.gt.0) then +! there is a specifier, check if correct element or species + kel=index(elnam,'#') + if(kel.gt.0) then +! extract sublattice number 1-9 specification + lk3=ichar(elnam(kel+1:kel+1))-ichar('0') +! write(*,73)elnam(kel+1:kel+1),kel,elnam,lk3 +!73 format('3D sublattice: "',a,'" position: ',i3,' in ',a,' : ',i3) + elnam(kel:)=' ' + else + lk3=0 + endif + if(btest(propid(typty)%status,IDELSUFFIX)) then +! write(*,*)'3D: elnam: ',kel,lk3,typty,elnam + call find_element_by_name(elnam,iel) + if(gx%bmperr.ne.0) then + write(kou,*)'Unknown element ',elnam,& + ' in parameter type MQ, please reenter' + gx%bmperr=0; goto 1000 + endif + typty=100*typty+iel + elseif(btest(propid(typty)%status,IDCONSUFFIX)) then +! to know the constituents we must know the phase but as we do not know +! the phase name yet but check the species exists !!! + call find_species_by_name(elnam,isp) + if(gx%bmperr.ne.0) then + write(kou,*)'Unknown species ',elnam,& + ' in parameter type MQ, please reenter',gx%bmperr + gx%bmperr=0; goto 1000 + endif +! convert from index to location, loksp + loksp=species(isp) +! write(*,69)'3D: conname: ',kel,lk3,typty,isp,loksp,elnam +69 format(a,5i4,a) +! extract sublattice after # + else +! write(kou,*)'This property has no specifier' + gx%bmperr=4168; goto 1000 + endif +! this is the property type stored in property record + else +! check if there should be a specifier !! + if(btest(propid(typty)%status,IDELSUFFIX) .or. & + btest(propid(typty)%status,IDCONSUFFIX)) then + write(*,*)'Parameter specifier missing' + gx%bmperr=4169; goto 1000 + endif + endif +! if the parameter symbol has a constituent specification check that now + if(isp.gt.0) then + k4=0 + do ll=1,phlista(lokph)%noofsubl + if(lk3.eq.0 .or. lk3.eq.ll) then + do kk=1,phlista(lokph)%nooffr(ll) + k4=k4+1 + if(phlista(lokph)%constitlist(k4).eq.loksp) goto 80 + enddo + elseif(ll.lt.lk3) then + k4=k4+phlista(lokph)%nooffr(ll) + endif + enddo +! constituent not found + write(kou,*)'No such constituent' + gx%bmperr=4066; goto 1000 +! constituent found in right sublattice +80 continue + typty=100*typty+k4 +! write(*,81)'3D: found: ',typty1,typty,lk3,k4,loksp +81 format(a,10i4) + endif +1000 continue + return + end subroutine get_parameter_typty +! +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + diff --git a/models/pmod25F.F90 b/models/gtp3E.F90 similarity index 90% rename from models/pmod25F.F90 rename to models/gtp3E.F90 index 21d772d..952269f 100644 --- a/models/pmod25F.F90 +++ b/models/gtp3E.F90 @@ -1,2936 +1,3127 @@ -! -! included in pmod25.F90 -! -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ -!> 11. Save and read things from files -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine gtpsave(filename,str) -! save all data on file, unformatted, TDB or macro -! header -! element list -! species list -! phase list with sublattices, endmembers, interactions and parameters etc -! tpfuns -! state variable functions -! references -! - implicit none - character*(*) filename,str -!\end{verbatim} -! separate UNFORMATTED, TDB and MACRO - if(str(1:1).eq.'U') then - call gtpsaveu(filename,str(3:)) -! else -! call gtpsavetm(filename,str) - endif -1000 continue - return - end subroutine gtpsave - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine gtpsaveu(filename,specification) -! save all data unformatted on an file -! header -! element list -! species list -! phase list with sublattices, endmembers, interactions and parameters etc -! tpfuns -! state variable functions -! references -! equilibrium record(s) with conditions, componenets, phase_varres records etc -! anything else? - implicit none - character*(*) filename,specification -!\end{verbatim} -! - character id*40,comment*72,endoffile*16,mark*8 - integer i,isp,jph,kontroll,lokph,lut -! - if(index(filename,'.').eq.0) then - filename(len_trim(filename)+1:)='.ocu' - endif - lut=21 - open(lut,file=filename,access='sequential',status='unknown',& - form='unformatted',iostat=gx%bmperr,err=1000) - id='This is a save file for OC version: ' - comment=specification -! this control number will be written regularly on the file and checked on read - kontroll=175638 - mark=' MARK '//char(13)//char(10) -!>>>>> 1: write first some id, version etc. - write(lut)id,savefile,comment,globaldata - write(lut)noofel,noofsp,noofph,nooftuples - write(lut)1,kontroll,mark -!---------------------------------------------------------------------- -! note the use of gtp_xxx_version to handle versions -!---------------------------------------------------------------------- -! -! it is extremely important to keep the order of the records as they -! are linked using indices -! -!>>>>> 2: elementlist - if(ocv()) write(*,*)'Writing elements' - write(lut)gtp_element_version - do i=1,noofel - write(lut)ellista(i) - enddo -!----------- - write(lut)2,kontroll,mark -!>>>>> 3: specieslist - if(ocv()) write(*,*)'Writing species' - write(lut)gtp_species_version - do isp=1,noofsp - write(lut)splista(isp)%symbol,splista(isp)%mass,splista(isp)%charge - write(lut)splista(isp)%noofel,splista(isp)%status, & - splista(isp)%alphaindex - write(lut)(splista(isp)%ellinks(i),i=1,splista(isp)%noofel) - write(lut)(splista(isp)%stoichiometry(i),i=1,splista(isp)%noofel) - enddo - write(lut)3,kontroll,mark -!>>>>> 4: phaselist, start from 0 (reference phase) -! including sublattces, endmembers, interactions, properties etc -! save version of various records - if(ocv()) write(*,*)'Writing phases' - write(lut)gtp_phase_version,gtp_endmember_version,gtp_interaction_version,& - gtp_property_version - if(noofph.gt.0) then - do jph=0,noofph - lokph=phases(jph) - call savephase(lut,lokph) - if(gx%bmperr.ne.0) goto 1000 - if(ocv()) write(*,*)'Saved phase: ',jph - enddo - endif - write(lut)(phasetuple(i),i=1,nooftuples) - write(lut)4,kontroll,mark -!------------- tpfuns -!>>>>> 20: tpfuns - if(ocv()) write(*,*)'Writing tpfuns' - call tpfunsave(lut,.FALSE.) - write(lut)5,kontroll,mark -!------------- state variable functions -!>>>>> 30: svfuns - if(ocv()) write(*,*)'Writing state variable functions' - call svfunsave(lut,firsteq) - write(lut)6,kontroll,mark -! write(*,*)'Writing mark: ',6,kontroll,mark -!------------- references -!>>>>> 40: bibliographic references - if(ocv()) write(*,*)'Writing references' - call bibliosave(lut) - write(lut)7,kontroll,mark -!------------------------------------------------------- -! write the equilibrium records, at present for FIRSTEQ only -! conditions, components, phase_varres for all composition sets etc -!>>>>> 50: equilibria - if(ocv()) write(*,*)'Writing equilibria' - write(lut)gtp_equilibrium_data_version,gtp_component_version,& - gtp_phase_varres_version - call saveequil(lut,firsteq) - write(lut)8,kontroll,mark -!------------------------------------------------------- - endoffile='- END OF DATA - ' - write(lut)endoffile -900 continue - close(lut) -1000 continue - return - end subroutine gtpsaveu - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine savephase(lut,lokph) -! save data for phase at location lokph (except data in the equilibrium record) -! For phases with disordered set of parameters we must access the number of -! sublattices via firsteq - implicit none - integer lut,lokph -!\end{verbatim} - integer doneord,i,j,level,lokcs,nem,noi,nop,nox,nsl,nup,noendm,fipsize - type(gtp_endmember), pointer :: emrec - type(gtp_interaction), pointer :: intrec - type(gtp_property), pointer :: proprec -! to keep track of interaction records - type saveint - type(gtp_interaction), pointer :: p1 - end type saveint - type(saveint), dimension(:), pointer :: stack - type(gtp_phase_add), pointer :: addlink - if(ocv()) write(*,*)'In savephase' - allocate(stack(5)) -!>>>>> 5: phase header - write(lut)lokph,phlista(lokph)%name,& - phlista(lokph)%models,phlista(lokph)%phletter,& - phlista(lokph)%status1,& - phlista(lokph)%alphaindex,phlista(lokph)%noofcs,phlista(lokph)%nooffs - nsl=phlista(lokph)%noofsubl - emrec=>phlista(lokph)%ordered - if(.not.associated(emrec)) then - noendm=0 - else - noendm=1 - endif -!>>>>> 6: sublattice info - j=phlista(lokph)%tnooffr - if(ocv()) write(*,10)j,lokph,size(phlista(lokph)%constitlist) -10 format('25F: ',3i20) - if(ocv()) write(*,11)(phlista(lokph)%constitlist(i),i=1,j) -11 format('25F: ',20i3) - write(lut)nsl,phlista(lokph)%linktocs,phlista(lokph)%tnooffr - write(lut)(phlista(lokph)%nooffr(i),i=1,nsl),& - (phlista(lokph)%constitlist(i),i=1,j),noendm -!--------- endmember list, interaction tree and property records -! save all parameter data starting from the endmember list - doneord=0 - if(ocv()) write(*,*)'listing endmembers',doneord,nsl,noendm -! there can be phases without any ordered parameters ... - if(.not.associated(emrec)) goto 400 -! we come back here if there are disordered parameters -200 continue -! if doneord=1 then we have listed the ordered parameters - if(doneord.eq.1) then - emrec=>phlista(lokph)%disordered - if(ocv()) write(*,*)'Saving disordered parameters' - endif - if(ocv()) write(*,*)'any endmember: ',doneord - emlista: do while(associated(emrec)) - proprec=>emrec%propointer - intrec=>emrec%intpointer - nop=0 - noi=0 - nem=0 - if(associated(proprec)) nop=1 - if(associated(intrec)) noi=1 - if(associated(emrec%nextem)) nem=1 - if(ocv()) write(*,55)'writing endmember: ',nsl,emrec%noofpermut,& - emrec%phaselink,emrec%antalem,nop,noi,nem -55 format(a,7i5) -!>>>>> 7: endmember record (basic or disordered) - write(lut)emrec%noofpermut,emrec%phaselink,emrec%antalem,nop,noi,nem - do j=1,emrec%noofpermut - write(lut)(emrec%fraclinks(i,j),i=1,nsl) - enddo - emproplista: do while(associated(proprec)) - nox=0 - if(associated(proprec%nextpr)) nox=1 -!>>>>> 8: endmember property record (loop) - write(lut)proprec%reference,proprec%proptype,& - proprec%degree,proprec%extra,proprec%antalprop,nox - do i=0,proprec%degree - call save1tpfun(lut,.FALSE.,proprec%degreelink(i)) - enddo - proprec=>proprec%nextpr - enddo emproplista -! interaction tree - level=0 -300 continue - intlista: do while(associated(intrec)) -! noi is next, nup is higher, nop is property - noi=0 - nup=0 - nop=0 - if(associated(intrec%nextlink)) noi=1 - if(associated(intrec%highlink)) nup=1 - if(associated(intrec%propointer)) nop=1 -310 continue -!>>>>> 9: interaction record -! look in pmod25H, create_interaction for use of intec%noofip - fipsize=size(intrec%noofip) - write(lut)fipsize - write(lut)intrec%noofip,intrec%status,noi,nup,nop - do i=1,intrec%noofip(2) - write(lut)intrec%sublattice(i),intrec%fraclink(i) - enddo -! interaction property - proprec=>intrec%propointer - intproplista: do while(associated(proprec)) - nox=0 - if(associated(proprec%nextpr)) nox=1 -!>>>>> 10: interaction property record (loop) - write(lut)proprec%reference,proprec%proptype,& - proprec%degree,proprec%extra,proprec%antalprop,nox - do i=0,proprec%degree - call save1tpfun(lut,.FALSE.,proprec%degreelink(i)) - enddo - proprec=>proprec%nextpr - enddo intproplista -! take link to higher higher interaction - level=level+1 - if(level.gt.5) then -! write(*,*)'Too many interaction levels' - gx%bmperr=4164; goto 1000 - endif - stack(level)%p1=>intrec - intrec=>intrec%highlink - enddo intlista -! pop previous intrec and take link to next interaction - if(level.gt.0) then - intrec=>stack(level)%p1 - intrec=>intrec%nextlink - level=level-1 - goto 300 - endif -!---- next endmember - emrec=>emrec%nextem - enddo emlista -! no more endmembers, check if the disordered (if any) has been written -400 continue - if(doneord.eq.0) then - if(ocv()) write(*,*)'any disordered endmembers?' - if(associated(phlista(lokph)%disordered)) then -! there are some disordered parameters -! the disfra record is written in saveequil?? -! we have to change nsl ...three % vojvoj - doneord=1 - lokcs=phlista(lokph)%linktocs(1) - nsl=firsteq%phase_varres(lokcs)%disfra%ndd -!>>>>> 11A: write disordered endmemebers - write(lut)2,nsl -! emrec should already be null but for security .... - nullify(emrec) - goto 200 - else -! we must mark that there are no disordered parameters -!>>>>> 11B: no moe endmemebers - write(lut)0,0 - endif - endif -!------ additions list -500 continue - addlink=>phlista(lokph)%additions - addition: do while(associated(addlink)) - if(addlink%type.eq.1) then -!>>>>> 12A: additions id - write(lut)addlink%type,addlink%addrecno,addlink%aff - else - write(*,*)'Not saving unknown addition record type ',addlink%type - endif - addlink=>addlink%nextadd - enddo addition -!>>>>> 12B: mark end of data for phase - write(lut)-1,-1,-1 -1000 continue - return - end subroutine savephase - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine saveequil(lut,ceq) -! save data for an equilibrium record - implicit none - integer lut - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - character text*512 - type(gtp_phase_varres), pointer :: firstvarres - TYPE(gtp_fraction_set), pointer :: fslink -! TYPE(gtp_condition), pointer :: condrec - integer i,isp,j,k,kl,lokcs,lokph,mc,mc2,nsl -!>>>>> 50: - write(lut)ceq%eqname,ceq%eqno,ceq%status,ceq%next -! ignore svfunres and eq_tpres -!---- components -!>>>>> 51: - do i=1,noofel - isp=ceq%complist(i)%splink - write(lut)isp - write(lut)ceq%complist(i)%phlink,ceq%complist(i)%status,& - ceq%complist(i)%refstate,ceq%complist(i)%tpref,& - ceq%complist(i)%mass - enddo - do i=1,noofel - if(ocv()) write(*,99)'comp.matrix: ',(ceq%invcompstoi(j,i),j=1,noofel) - enddo -99 format(a,7e11.3) - do i=1,noofel - write(lut)(ceq%compstoi(j,i),j=1,noofel) - enddo -!---- varres records, one for each composition set -!>>>>> 54: - write(lut)highcs - compset: do j=1,highcs-1 -! loop for all composition sets - firstvarres=>ceq%phase_varres(j) - if(btest(firstvarres%status2,CSDFS)) then -! this phase_varres/parres records belong to disordered fraction_set -! A big tricky to find the number of sublattices and constituents .... - lokph=firstvarres%phlink - lokcs=phlista(lokph)%linktocs(1) - nsl=ceq%phase_varres(lokcs)%disfra%ndd - mc=ceq%phase_varres(lokcs)%disfra%tnoofxfr - else - lokph=0; lokcs=0 - nsl=phlista(firstvarres%phlink)%noofsubl - mc=phlista(firstvarres%phlink)%tnooffr - endif - mc2=mc*(mc+1)/2 -!>>>>> 55: - write(lut)firstvarres%nextfree,firstvarres%phlink,& - firstvarres%status2,firstvarres%phstate - write(lut)firstvarres%prefix,firstvarres%suffix - write(lut)firstvarres%abnorm -!>>>>> 56: - write(lut)(firstvarres%constat(i),i=1,mc) - write(lut)(firstvarres%yfr(i),i=1,mc) - write(lut)(firstvarres%mmyfr(i),i=1,mc) - write(lut)(firstvarres%sites(i),i=1,nsl) -! We do not save the cmuval array -! These should only be interesting for ionic liquids and in that case -! only the dimension, not the values -! write(lut)(firstvarres%dsitesdy(i),i=1,mc) -! write(lut)(firstvarres%d2sitesdy2(i),i=1,mc2) - lokph=firstvarres%phlink - fsrec: if(btest(firstvarres%status2,CSDLNK)) then -! we must indicate on the file a disordered fraction_set record follows! - fslink=>firstvarres%disfra - if(ocv()) write(*,*)'Disordered fraction set linked from: ',& - j,fslink%varreslink -!>>>>> 57A: write disordered record, is is inside the phase_varres record - write(lut)1 -!>>>>> 58: - write(lut)fslink%latd,fslink%ndd,fslink%tnoofxfr,& - fslink%tnoofyfr,fslink%totdis,fslink%varreslink,fslink%id - write(lut)fslink%nooffr,fslink%splink - write(lut)fslink%dsites - write(lut)fslink%y2x - write(lut)fslink%dxidyj - else -! no disordered fraction set record -!>>>>> 57B: - write(lut)0 - endif fsrec -!>>>>> 59: - write(lut)firstvarres%amfu,firstvarres%netcharge,firstvarres%dgm,& - firstvarres%nprop -! only G values saved ???? well maybe not even those ... -!>>>>> 60: - write(lut)(firstvarres%gval(i,1),i=1,6) - do k=1,mc - write(lut)(firstvarres%dgval(i,k,1),i=1,3) - enddo -!>>>>> 61: - write(lut)(firstvarres%d2gval(i,1),i=1,mc2) - enddo compset -!---- conditions, write as text and recreate when reading file - call get_all_conditions(text,0,ceq) - if(gx%bmperr.ne.0) goto 1000 - kl=index(text,'CRLF') -!>>>>> 62: - write(lut)kl-1 - if(kl.gt.1) then - write(lut)' SET CONDITIONS ',text(1:kl-1) - endif -!---- experiments - call get_all_conditions(text,1,ceq) - if(gx%bmperr.ne.0) goto 1000 - kl=len_trim(text) -!>>>>> 63: - write(lut)kl-1 - if(kl.gt.1) then - write(lut)' EXPERIMENTS ',text(1:kl-1) - endif -!>>>>>> 64: savesysmat - write(lut)ceq%sysmatdim,ceq%nfixmu,ceq%nfixph - if(ceq%nfixmu.gt.0) write(lut)(ceq%fixmu(kl),kl=1,ceq%nfixmu) - if(ceq%nfixph.gt.0) write(lut)& - (ceq%fixph(1,kl),ceq%fixph(2,kl),kl=1,ceq%nfixph) - if(ceq%sysmatdim.gt.0) then - do mc=1,ceq%sysmatdim - write(lut)(ceq%savesysmat(mc,kl),kl=1,ceq%sysmatdim) - enddo - endif -1000 continue - return - end subroutine saveequil - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine svfunsave(lut,ceq) -! saves all state variable functions on a file - implicit none - integer lut - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - character text*512,symbols(20)*32,afterdot*32 - integer ip,ipos,istv,js,jt,kl,ks,lrot - type(gtp_state_variable), pointer :: svrrec - write(lut)nsvfun - do lrot=1,nsvfun - ipos=1 - if(svflista(lrot)%narg.eq.0) goto 500 - js=0 - jt=0 -100 continue - jt=jt+1 - js=js+1 - ip=1 - symbols(js)=' ' - istv=svflista(lrot)%formal_arguments(1,jt) - if(istv.lt.0) then -! function refer to another function - symbols(js)=svflista(-istv)%name - else -! the 1:10 was a new bug discovered in GNU fortran 4.7 and later - call make_stvrec(svrrec,svflista(lrot)%formal_arguments(1:10,jt)) -! do ii=1,4 -! indices(ii)=svflista(lrot)%formal_arguments(1+ii,jt) -! enddo -! call encode_state_variable2(symbols(js),ip,istv,indices,& -! svflista(lrot)%formal_arguments(6,jt), & -! svflista(lrot)%formal_arguments(7,jt),ceq) - call encode_state_variable(symbols(js),ip,svrrec,ceq) - if(svflista(lrot)%formal_arguments(10,jt).ne.0) then -! a derivative!!! - jt=jt+1 - afterdot=' ' - ip=1 - write(*,*)'What? Derivatives not implemented' -! call encode_state_variable2(afterdot,ip,& -! svflista(lrot)%formal_arguments(1,jt),indices,& -! svflista(lrot)%formal_arguments(6,jt), & -! svflista(lrot)%formal_arguments(7,jt),ceq) -! symbols(js)=symbols(js)(1:len_trim(symbols(js)))//'.'//afterdot - endif - endif - if(jt.lt.svflista(lrot)%narg) goto 100 -500 continue - kl=len_trim(svflista(lrot)%name) - text(ipos:ipos+kl+1)=svflista(lrot)%name(1:kl)//'= ' - ipos=ipos+kl+2 - call wrtfun(text,ipos,svflista(lrot)%linkpnode,symbols) - if(pfnerr.ne.0) then - write(kou,*)'Putfun error listing funtion ',ks,pfnerr - gx%bmperr=4142; goto 1000 - endif - write(lut)ipos-1 - write(lut)text(1:ipos-1) - enddo -1000 continue - return - end subroutine svfunsave - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine bibliosave(lut) -! saves references on a file - implicit none - integer lut -!\end{verbatim} - character longline*2048 - integer ir,jp,ll,nl -!>>>>> 40: -! write(*,*)'Saving reference version and number of:',& -! gtp_biblioref_version,reffree-1 - write(lut)gtp_biblioref_version,reffree-1 - do ir=1,reffree-1 - longline=bibrefs(ir)%reference - jp=17 - nl=size(bibrefs(ir)%refspec) - do ll=1,nl - longline(jp:)=bibrefs(ir)%refspec(ll) - jp=jp+64 - enddo - jp=len_trim(longline) -!>>>>> 41: - write(lut)jp -!>>>>> 42: - write(lut)longline(1:jp) - enddo -1000 continue - return - end subroutine bibliosave - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine gtpread(filename,str) -! read unformatted all data in the following order -! header -! element list -! species list -! phase list with sublattices, endmembers, interactions and parameters etc -! tpfuns -! state variable functions -! references -! equilibrium record(s) with conditions, componenets, phase_varres records etc -! - implicit none - character*(*) filename,str -!\end{verbatim} - character id*40,endoffile*16,version*8,comment*72,mark*8 - integer i,i1,i2,i3,isp,jph,kontroll,nel,ivers,lin -10 format(i8) - if(index(filename,'.').eq.0) then - filename(len_trim(filename)+1:)='.ocu' - endif - kontroll=175638 - lin=21 - open(lin,file=filename,access='sequential',status='old',& - form='unformatted',iostat=gx%bmperr,err=1100) - if(ocv()) write(*,*)'Opening file: ',filename(1:len_trim(filename)),& - ' for unformatted read' -!>>>>> 1: read some identification etc, SAVE VERBOSE option! - if(ocv()) then - i1=1 - else - i1=0 - endif - read(lin)id,version,comment,globaldata - if(i1.eq.1) then - globaldata%status=ibset(globaldata%status,GSVERBOSE) - endif - if(version.ne.savefile) then - write(*,11)id,version,savefile -11 format('File not same version as program: ',A/a,' : ',a) - gx%bmperr=2901; goto 1000 - endif -! write(*,*)'comment: ',comment(1:len_trim(comment)) - str=comment - read(lin)noofel,noofsp,noofph,nooftuples - if(ocv()) write(*,*)'4 numbers: ',noofel,noofsp,noofph,nooftuples -!------- - read(lin)i1,i2,mark - if(i1.ne.1 .and. i2.ne.kontroll) then - write(*,*)'Read error at control 1' - gx%bmperr=4165; goto 1000 - elseif(ocv()) then - write(*,*)'Control 1 OK' - endif -!>>>>> 2: elementlist - read(lin)ivers - if(ivers.ne.gtp_element_version) then - write(*,17)'Element',ivers,gtp_element_version -17 format(a,' record version error: ',2i4) - gx%bmperr=7777; goto 1000 - endif - do i=1,noofel - read(lin)ellista(i) - enddo - do i=1,noofel - elements(ellista(i)%alphaindex)=i - enddo - if(ocv()) write(*,19)(ellista(i)%alphaindex,i=1,noofel) -19 format('Ellista: ',100i3) -!------- - read(lin)i1,i2,mark - if(i1.ne.2 .and. i2.ne.kontroll) then - write(*,*)'Read error at control 2' - gx%bmperr=4165; goto 1000 - elseif(ocv()) then - write(*,*)'Control 2 OK' - endif -!>>>>> 3: specieslist - read(lin)ivers - if(ivers.ne.gtp_species_version) then - write(*,17)'Species',ivers,gtp_species_version - gx%bmperr=7777; goto 1000 - endif - do isp=1,noofsp - read(lin)splista(isp)%symbol,splista(isp)%mass,splista(isp)%charge - read(lin)splista(isp)%noofel,splista(isp)%status, & - splista(isp)%alphaindex - if(isp.gt.1) then - nel=splista(isp)%noofel - allocate(splista(isp)%ellinks(nel)) - allocate(splista(isp)%stoichiometry(nel)) - endif - read(lin)(splista(isp)%ellinks(i),i=1,splista(isp)%noofel) - read(lin)(splista(isp)%stoichiometry(i),i=1,splista(isp)%noofel) - enddo - do i=1,noofsp - species(splista(i)%alphaindex)=i - enddo -! write(*,22)(splista(i)%alphaindex,i=1,noofsp) -!22 format('25F splista: ',20i3) -!------- - read(lin)i1,i2,mark - if(i1.ne.3 .and. i2.ne.kontroll) then - write(*,*)'Read error at control 3' - gx%bmperr=4165; goto 1000 - elseif(ocv()) then - write(*,*)'Control 3 OK' - endif -!>>>>> 5: phaselist, starting from 0, the reference phase - read(lin)ivers,i1,i2,i3 - if(ivers.ne.gtp_phase_version) then - write(*,17)'Phase',ivers,gtp_phase_version - gx%bmperr=7777; goto 1000 - endif - if(i1.ne.gtp_endmember_version) then - write(*,17)'Endmember',i1,gtp_endmember_version - gx%bmperr=7777; goto 1000 - endif - if(i2.ne.gtp_interaction_version) then - write(*,17)'Interaction',i2,gtp_interaction_version - gx%bmperr=7777; goto 1000 - endif - if(i3.ne.gtp_property_version) then - write(*,17)'Property',i3,gtp_property_version - gx%bmperr=7777; goto 1000 - endif - noofem=0 - noofint=0 - noofprop=0 - if(noofph.gt.0) then - do jph=0,noofph -!>>>>> 5..12 inside readphase - call readphase(lin,jph) - if(gx%bmperr.ne.0) goto 1000 - if(ocv()) write(*,*)'Done reading phase: ',jph,' out of: ',noofph - enddo - do i=1,noofph - phases(phlista(i)%alphaindex)=i - enddo - endif - read(lin)(phasetuple(i),i=1,nooftuples) -!-------- - read(lin)i1,i2,mark - if(i1.ne.4 .and. i2.ne.kontroll) then - write(*,*)'Read error at control 4' - gx%bmperr=4165; goto 1000 - elseif(ocv()) then - write(*,*)'Control 4 OK' - endif -!---------- tpfuns -!>>>>> 20.. inside tpfunread, skip functions already read - call tpfunread(lin,.TRUE.) -! write(*,*)'return with error code: ',gx%bmperr - if(gx%bmperr.ne.0) then -! many functions already entered when reading parameters - write(*,*)'Error reading TP functiona: ',gx%bmperr - goto 1000 - endif -!-------- - read(lin)i1,i2,mark - if(i1.ne.5 .and. i2.ne.kontroll) then - write(*,*)'Read error at control 5' - gx%bmperr=4165; goto 1000 - elseif(ocv()) then - write(*,*)'read TPFUNS OK' - endif -!---------- state variable functions -!>>>>> 30... inside svfunread - call svfunread(lin) - if(gx%bmperr.ne.0) goto 1000 -!-------- - read(lin)i1,i2,mark - if(i1.ne.6 .and. i2.ne.kontroll) then - write(*,*)'Read error at control 6' - gx%bmperr=4165; goto 1000 - elseif(ocv()) then - write(*,*)'read state variable functions OK at mark ',i1,i2,mark - endif -!---------- bibliographic references -!>>>>> 40.. inside refread - call biblioread(lin) - if(gx%bmperr.ne.0) goto 1000 -!-------- - read(lin)i1,i2,mark - if(i1.ne.7 .and. i2.ne.kontroll) then - write(*,*)'Read error at control 7' - gx%bmperr=4165; goto 1000 - elseif(ocv()) then - write(*,*)'read references OK' - endif -!---------- equilibrium record -!>>>>> 50.. inside readequil - read(lin)i1,i2,i3 - if(i1.ne.gtp_equilibrium_data_version) then - write(*,*)'Wrong version of equilibrium data record: ',i1,& - gtp_equilibrium_data_version - gx%bmperr=7777; goto 1000 - endif - if(i2.ne.gtp_component_version) then - write(*,*)'Wrong version of component record: ',i2,& - gtp_component_version - gx%bmperr=7777; goto 1000 - endif - if(i3.ne.gtp_phase_varres_version) then - write(*,*)'Wrong version of phase_varres record: ',i3,& - gtp_phase_varres_version - gx%bmperr=7777; goto 1000 - endif - call readequil(lin,firsteq) - if(gx%bmperr.ne.0) goto 900 -! if(gx%bmperr.ne.0) goto 1000 -!-------- - read(lin)i1,i2,mark - if(i1.ne.8 .and. i2.ne.kontroll) then - write(*,*)'Read error at control 8' - gx%bmperr=4165; goto 1000 - elseif(ocv()) then - write(*,*)'read equilibrium records OK' - endif -!------ read all ?? - endoffile=' ' - read(lin,end=800,err=800)endoffile -800 continue - if(endoffile.ne.'- END OF DATA - ') then - write(kou,811)endoffile -811 format('Unexpected end of file mark: '/'>',A,'<') - gx%bmperr=4166; goto 1000 - elseif(ocv()) then - write(kou,812)endoffile -812 format('Expected end of file mark found: '/'>',A,'<') - endif -! emergency exit -900 continue - close(lin) -! -1000 continue - return -! error opening files -1100 continue - write(*,1110)gx%bmperr,filename(1:len_trim(filename)) -1110 format('I/O error: ',i5,', opening file; ',a) - goto 1000 - end subroutine gtpread - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine readphase(lin,jdum) -! read data for phlista and all endmembers etc -! works for test case without disordered fraction test - implicit none - integer lin,jdum -!\end{verbatim} - integer firstendmem,i,i1,i2,i3,jph,level,nem,noi,nop,nox,nup,nsl,mult - type(gtp_endmember), pointer :: emrec - type(gtp_interaction), pointer :: intrec - type(gtp_property), pointer :: proprec - type saveint - type(gtp_interaction), pointer :: p1 - integer noi - end type saveint - type(saveint), dimension(:), pointer :: stack - type(gtp_phase_add), pointer :: addlink -! - allocate(stack(5)) - if(ocv()) write(*,*)'in readphase:' -! as the phlista record contain pointers each item must be read separately -!>>>>> 5: phase header - read(lin)jph,phlista(jph)%name,& - phlista(jph)%models,phlista(jph)%phletter,phlista(jph)%status1,& - phlista(jph)%alphaindex,phlista(jph)%noofcs,phlista(jph)%nooffs -!>>>>> 6: sublattice info - read(lin)phlista(jph)%noofsubl,phlista(jph)%linktocs,phlista(jph)%tnooffr - nsl=phlista(jph)%noofsubl - allocate(phlista(jph)%nooffr(nsl)) - allocate(phlista(jph)%constitlist(phlista(jph)%tnooffr)) - read(lin)(phlista(jph)%nooffr(i),i=1,nsl),& - (phlista(jph)%constitlist(i),i=1,phlista(jph)%tnooffr),nem -!------ endmember records, these must be allocated and linked now - nullify(phlista(jph)%ordered) - nullify(phlista(jph)%disordered) - nullify(emrec) - if(associated(emrec)) then - write(*,*)'nullify does not work' - stop - endif - if(ocv()) write(*,*)'read endmember data',nsl,nem -! if nem=0 now there are no basic (ordered) endmember (can that happen?) -! return here when endmember list empty and there is a disordered list - firstendmem=1 -200 continue - if(ocv()) write(*,202)'reading parameters: ',phlista(jph)%name,& - nsl,firstendmem,nem -202 format(a,a,10i4) -! newendmem: do while(nem.eq.1) - newendmem: do while(nem.gt.0) - if(associated(emrec)) then -!>>>>> 7C: the second or later endmember in the same list - call readendmem(lin,nsl,emrec%nextem,nop,noi,nem) - emrec=>emrec%nextem - elseif(firstendmem.eq.1) then -!>>>>> 7A: the first (only or ordered) endmember - call readendmem(lin,nsl,phlista(jph)%ordered,nop,noi,nem) - emrec=>phlista(jph)%ordered - elseif(firstendmem.eq.2) then -!>>>>> 7B: the first disordered endmember - if(ocv()) write(*,*)'Reading isordered parameter list' - call readendmem(lin,nsl,phlista(jph)%disordered,nop,noi,nem) - emrec=>phlista(jph)%disordered - firstendmem=0 - endif - if(nop.eq.1) then -!>>>>> 8A: endmember property (lookp) - call readproprec(lin,emrec%propointer,nox) - proprec=>emrec%propointer - do while(nox.eq.1) - call readproprec(lin,proprec%nextpr,nox) - proprec=>proprec%nextpr - enddo - endif - inttree: if(noi.eq.1) then -!>>>>> 9A: interaction record - level=0 - call readintrec(lin,emrec%intpointer,mult,noi,nup,nop) - intrec=>emrec%intpointer - if(ocv()) write(*,13)'read interaction: ',intrec%status,noi,nup,nop -13 format(a,10i4) -300 continue - if(nop.eq.1) then -!>>>>> 10A: interaction property record - call readproprec(lin,intrec%propointer,nox) - proprec=>intrec%propointer - do while(nox.eq.1) - call readproprec(lin,proprec%nextpr,nox) - proprec=>proprec%nextpr - enddo - endif -! push before going to higher -330 continue - level=level+1 - stack(level)%p1=>intrec - stack(level)%noi=noi - if(ocv()) write(*,13)'pushed interaction: ',intrec%status,0,0,0,level - higher: if(nup.eq.1) then -!>>>>> 9B: go to higher level and save intrec - call readintrec(lin,intrec%highlink,mult,noi,nup,nop) - intrec=>intrec%highlink -! write(*,13)'read higher interaction: ',intrec%status,noi,nup,nop - if(nop.eq.1) then -!>>>>> 10B: there are some property records !! - call readproprec(lin,intrec%propointer,nox) - proprec=>intrec%propointer - do while(nox.eq.1) - call readproprec(lin,proprec%nextpr,nox) - proprec=>proprec%nextpr - enddo - endif - goto 330 - endif higher -! we come here when no higher records, pop records from stack -350 continue - pop: if(level.gt.0) then - intrec=>stack(level)%p1 - noi=stack(level)%noi - level=level-1 - if(ocv())write(*,13)'poped interaction: ',intrec%status,0,0,0,level - if(noi.eq.1) then -!>>>>> 9C: - call readintrec(lin,intrec%nextlink,mult,noi,nup,nop) - intrec=>intrec%nextlink - if(ocv()) write(*,13)'read interaction: ',intrec%status,& - noi,nup,nop - goto 300 - else - goto 350 - endif - endif pop - endif inttree - enddo newendmem -! we come nere when no more endmembers in this list - if(firstendmem.eq.1) then -!>>>>> 11: if nem read here is zero there are no disordered endmembers - if(ocv()) write(*,*)'checking for disordered endmembers' - read(lin)nem,nsl -! we must nullify emrec to start a new list of endmembers - nullify(emrec) - if(nem.ne.0) then - firstendmem=2 - if(ocv()) write(*,*)'Reading disordered parameters',nem,nsl - goto 200 - endif - endif -!------ additions list -!500 continue - nullify(phlista(jph)%additions) -510 continue - read(lin)i1,i2,i3 - if(ocv()) write(*,*)'Reading any addition; ',i1 - if(i1.eq.1) then -! here addition record should be created but as I have not managed to -! save the functions I just skip this for the moment and use create_magrec - call create_magrec_inden(addlink,i3) - if(gx%bmperr.ne.0) goto 1000 - if(.not.associated(phlista(jph)%additions)) then - phlista(jph)%additions=>addlink - else - addlink%nextadd=>addlink - addlink=>addlink%nextadd - endif - goto 510 - elseif(i1.eq.-1) then -! end of addition list - continue - if(i2.ne.i1 .and. i3.ne.i1) write(*,*)'end of phase error:',i2,i3 - endif -1000 continue - return - end subroutine readphase - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine readendmem(lin,nsl,emrec,nop,noi,nem) -! allocates and reads an endmember record - implicit none - integer lin,nsl,nop,noi,nem - type(gtp_endmember), pointer :: emrec -!\end{verbatim} - integer i,j - allocate(emrec) -! write(*,*)'Going to read endmember record' -!>>>>> 7D: actually reading .... - read(lin)emrec%noofpermut,emrec%phaselink,emrec%antalem,nop,noi,nem - if(ocv()) write(*,17)'readendmem: ',nsl,emrec%noofpermut,emrec%phaselink,& - emrec%antalem,nop,noi,nem -17 format(a,7i5) - allocate(emrec%fraclinks(nsl,emrec%noofpermut)) - do j=1,emrec%noofpermut - read(lin)(emrec%fraclinks(i,j),i=1,nsl) - enddo - nullify(emrec%nextem) - nullify(emrec%propointer) - nullify(emrec%intpointer) - noofem=noofem+1 - return - end subroutine readendmem - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine readproprec(lin,proprec,nox) -! allocates and reads a property record - implicit none - integer lin,nox - type(gtp_property), pointer :: proprec -!\end{verbatim} - integer i - allocate(proprec) -!>>>>> 8B: actually reading property record (endmember) -!>>>>> 10B: actually reading property record (interaction) -! write(*,*)'Going to read property record' - read(lin)proprec%reference,proprec%proptype,& - proprec%degree,proprec%extra,proprec%antalprop,nox - allocate(proprec%degreelink(0:proprec%degree)) - if(ocv()) write(*,17)'readprop: ',proprec%proptype,proprec%degree,& - proprec%antalprop,nox -17 format(a,6i5) -! write(*,*)'To read TP functions: ',proprec%degree,proprec%degreelink(0) - do i=0,proprec%degree - call read1tpfun(21,proprec%degreelink(i)) - enddo - if(ocv()) write(*,*)'Read TP functions: ',proprec%degree,& - proprec%degreelink(0) - nullify(proprec%nextpr) - noofprop=noofprop+1 - return - end subroutine readproprec - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine readintrec(lin,intrec,mult,noi,nup,nop) -! allocates and reads an interaction record UNFINISHED - integer lin,mult,noi,nup,nop - type(gtp_interaction), pointer :: intrec -!\end{verbatim} - integer fipsize,noofperm,i -! the storage of permutations in interaction records is complex ... one must -! take into account the number of permutations in lower order intecations ... -! for an fcc endmember A:A:A:B (4 perm) the binary interaction A:A:A,B:B has -! 3; 3; 3 and 3 perms and the ternary A:A,B:A,B:B has 2; 2; 2; 2 -! mult may not be needed ... - allocate(intrec) -!>>>>> 9D: actually read the interaction record - read(lin)fipsize - allocate(intrec%noofip(fipsize)) - read(lin)intrec%noofip,intrec%status,noi,nup,nop -! write(*,17)'25F readint: ',fipsize,intrec%status,noi,nup,nop,& -! (intrec%noofip,i=1,fipsize) -17 format(a,5i4,2x,10i3) - noofperm=intrec%noofip(2) - allocate(intrec%sublattice(noofperm)) - allocate(intrec%fraclink(noofperm)) - do i=1,intrec%noofip(1) - read(lin)intrec%sublattice(i),intrec%fraclink(i) - enddo - nullify(intrec%nextlink) - nullify(intrec%highlink) - nullify(intrec%propointer) - return - end subroutine readintrec - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine readequil(lin,ceq) -! Read equilibria records from a file - implicit none - integer lin - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - character text*512,dum16*16 - type(gtp_phase_varres), pointer :: firstvarres - TYPE(gtp_fraction_set) :: fslink - integer i,ierr,ip,isp,ivar,j,jp,k,lokcs,lokph,mc,mc2,nprop,nsl,kp - double precision, dimension(:,:), allocatable :: ca,ci -! containing conditions, components and phase varres records for wach compset -!>>>>> 50: - read(lin)ceq%eqname,ceq%eqno,ceq%status,ceq%next - if(ocv()) write(*,*)'Reading equilibrium: ',ceq%eqname -!----- components -! allocate(ceq%complist(noofel)) already allocated for 20 -! write(*,*)'Size of component array: ',size(ceq%complist) -!>>>>> 51: - do i=1,noofel - read(lin)isp - ceq%complist(i)%splink=isp - read(lin)ceq%complist(i)%phlink,& - ceq%complist(i)%status,& - ceq%complist(i)%refstate,ceq%complist(i)%tpref,ceq%complist(1)%mass - if(isp.gt.0) then -! user defined reference state only allocated if necessary - read(lin)j - allocate(ceq%complist(i)%endmember(j)) - read(lin)ceq%complist(i)%endmember - read(lin)ceq%complist(i)%molat - endif - enddo -! stoichiometry conversion matrix, already allocated?? where?? - ceq%compstoi=zero -! calculate the inverse stoichiometry matrix -! write(*,*)'Reading component stoichiometry matrix',noofel,maxel - do j=1,noofel - read(lin)(ceq%compstoi(j,i),i=1,noofel) - enddo - ! this because mdinv did strange things inverting a larger matrix - allocate(ca(noofel,noofel+1)) - allocate(ci(noofel,noofel)) - do i=1,noofel - do j=1,noofel - ca(i,j)=ceq%compstoi(i,j) - enddo - enddo -! do j=1,noofel -! write(*,99)'ca: ',(ca(j,i),i=1,noofel) -! enddo -99 format(a,7e11.3) -! call mdinv(maxel-1,maxel,ceq%compstoi,ceq%invcompstoi,noofel,ierr) - call mdinv(noofel,noofel+1,ca,ci,noofel,ierr) -! write(*,*)'Inverting matrix',ierr - do j=1,noofel -! write(*,99)'ci: ',(ci(i,j),i=1,noofel) - do i=1,noofel - ceq%invcompstoi(i,j)=ci(i,j) - enddo - enddo - deallocate(ca) - deallocate(ci) -!----------- phase_varres record -!>>>>> 54: - read(lin)highcs - if(ocv()) then - write(*,*)'Number of phase_varres records: ',highcs-1 - write(*,*)'phase_varres size: ',size(ceq%phase_varres) - endif - do j=1,highcs-1 -! write(*,*)'reading phase_varres ',j -!------------------------------------------ -! DEBUGPROBLEM BEWARE, using = instead of => below took 2 days to find -!------------------------------------------ -! >>> firstvarres=ceq%phase_varres(j) <<< error - firstvarres=>ceq%phase_varres(j) -!>>>>> 55: - read(lin)firstvarres%nextfree,firstvarres%phlink,& - firstvarres%status2,firstvarres%phstate - read(lin)firstvarres%prefix,firstvarres%suffix - read(lin)firstvarres%abnorm -! check interconecctions, firstvarres%phlink is phase record index -! from phlista(firstvarres%phlink)%clink one should find this record (j) -! jxph=firstvarres%phlink - if(btest(firstvarres%status2,CSDFS)) then -! this phase_varres records belong to a disordered fraction_set - lokph=firstvarres%phlink -! lokcs=phlista(lokph)%cslink - lokcs=phlista(lokph)%linktocs(1) - nsl=ceq%phase_varres(lokcs)%disfra%ndd - mc=ceq%phase_varres(lokcs)%disfra%tnoofxfr - else - nsl=phlista(firstvarres%phlink)%noofsubl - mc=phlista(firstvarres%phlink)%tnooffr - endif -! write(*,*)'bmpread 78: ',j,nsl,mc - mc2=mc*(mc+1)/2 -! added integer status array constat -! write(*,*)'Allocate constat 1: ',nsl,mc - allocate(firstvarres%constat(mc)) - allocate(firstvarres%yfr(mc)) - allocate(firstvarres%sites(nsl)) -! for ionic liquids allocate dpqdy - if(btest(phlista(firstvarres%phlink)%status1,PHIONLIQ)) then - if(ocv()) write(*,*)'Allocate dpqdy: ',mc - allocate(firstvarres%dpqdy(mc)) - endif -!>>>>> 56: - read(lin)(firstvarres%constat(i),i=1,mc) - read(lin)(firstvarres%yfr(i),i=1,mc) - allocate(firstvarres%mmyfr(mc)) - read(lin)(firstvarres%mmyfr(i),i=1,mc) - read(lin)(firstvarres%sites(i),i=1,nsl) -! these are ignored, values not important but must be allocated -! for ionic liquid as (2,mc) and (2,mc2) -! read(lin)(firstvarres%dsitesdy(2,i),i=1,mc) -! read(lin)(firstvarres%d2sitesdy2(2,i),i=1,mc2) -!>>>>> 57: - read(lin)ivar - if(ivar.eq.1) then -! extra fraction set - if(ocv()) write(*,*)'reading extra fraction set for ',j -!>>>>> 58: - read(lin)fslink%latd,fslink%ndd,fslink%tnoofxfr,& - fslink%tnoofyfr,fslink%totdis,fslink%varreslink,fslink%id - allocate(fslink%nooffr(fslink%ndd)) - allocate(fslink%dsites(fslink%ndd)) - allocate(fslink%splink(fslink%tnoofxfr)) - allocate(fslink%y2x(fslink%tnoofyfr)) - allocate(fslink%dxidyj(fslink%tnoofyfr)) - read(lin)fslink%nooffr,fslink%splink - read(lin)fslink%dsites - read(lin)fslink%y2x - read(lin)fslink%dxidyj -! now copy fslink to the correct record and then deallocate fslink arrays - call copy_fracset_record(j,fslink,ceq) - deallocate(fslink%nooffr) - deallocate(fslink%dsites) - deallocate(fslink%splink) - deallocate(fslink%y2x) - deallocate(fslink%dxidyj) - endif -! The result data -!>>>>> 59: - read(lin)firstvarres%amfu,firstvarres%netcharge,firstvarres%dgm, & - firstvarres%nprop - nprop=firstvarres%nprop - allocate(firstvarres%listprop(nprop)) - allocate(firstvarres%gval(6,nprop)) - allocate(firstvarres%dgval(3,mc,nprop)) - allocate(firstvarres%d2gval(mc2,nprop)) -!>>>>> 60: - read(lin)(firstvarres%gval(i,1),i=1,6) - do k=1,mc - read(21)(firstvarres%dgval(i,k,1),i=1,3) - enddo -!>>>>> 61: - read(lin)(firstvarres%d2gval(i,1),i=1,mc2) - if(ocv()) write(*,*)'phase_varres size: ',j,size(ceq%phase_varres) - enddo -!----- conditions, can be empty, NOTE: entered after phase_varres -!>>>>> 62: - read(lin)ip - if(ip.gt.0) then - read(lin)dum16,text(1:ip) -! set the conditions, ip will be incremented by 1 in enter_condition -! the text contains " number: variable=value, " -! we have to set each condition variable separately - jp=1 - if(ocv()) write(*,*)'Conditions >',text(1:ip),'<',jp,ip - cloop: do while(jp.lt.ip) - k=index(text(jp:ip),':') - if(k.le.0) exit cloop - jp=jp+k - kp=min(jp+index(text(jp+1:),' '),ip) - if(kp.gt.jp) then -! remove , as that indicates more conditions on same line - if(text(kp-1:kp-1).eq.',') then - text(kp-1:kp-1)=' ' - endif - else - kp=ip - endif -! write(*,*)'condition >',text(jp:kp),'<' - call set_condition(text(1:kp),jp,firsteq) -! jp automatically update inside set_condition - if(gx%bmperr.ne.0) then - write(*,*)'Error setting conditions' - write(*,*)ip,' >',text(1:ip),'<' - goto 1000 - endif - enddo cloop - endif -!---- experiments -!>>>>> 63: - read(lin)ip - if(ip.gt.0) then - read(lin)dum16,text(1:ip) - endif -!>>>>>> 64: restore savesysmat - read(lin)ceq%sysmatdim,ceq%nfixmu,ceq%nfixph - if(ceq%nfixmu.gt.0) read(lin)(ceq%fixmu(kp),kp=1,ceq%nfixmu) - if(ceq%nfixph.gt.0) read(lin)& - (ceq%fixph(1,kp),ceq%fixph(2,kp),kp=1,ceq%nfixph) - if(ceq%sysmatdim.gt.0) then - do mc=1,ceq%sysmatdim - read(lin)(ceq%savesysmat(mc,kp),kp=1,ceq%sysmatdim) - enddo - endif -! allocate and zero the array with current chemical potentials - if(.not.allocated(ceq%cmuval)) allocate(ceq%cmuval(noofel)) - ceq%cmuval=zero -! - csfree=highcs -1000 continue - return - end subroutine readequil - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine svfunread(lin) -! read a state variable function from save file and store it. -! by default there are some state variable functions, make sure -! they are deleted. Done here just by setting nsvfun=0 - implicit none - integer lin -!\end{verbatim} - integer nsvfun,i,ip,nsvfunfil - character*512 text - nsvfun=0 - read(lin)nsvfunfil - if(ocv()) write(*,*)'Number of state variable functions: ',nsvfunfil - do i=1,nsvfunfil - read(lin)ip -! write(*,*)'Number of characters: ',ip - text=' ' - read(lin)text(2:ip) -! write(*,*)text(2:ip) - ip=1 - call enter_svfun(text,ip,firsteq) - if(gx%bmperr.ne.0) then -! write(*,*)'Error entering svf from file',gx%bmperr - if(gx%bmperr.ne.4136) goto 1000 - gx%bmperr=0 - endif - enddo -1000 continue - return - end subroutine svfunread - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine biblioread(lin) -! read references from save file - implicit none - integer lin -!\end{verbatim} - character text*512 - integer i,iref,jp,nrefs -!>>>>> 40: number of references -! write(*,*)'Reading reference version and nummer of' - read(lin)i,nrefs -! write(*,*)i,nrefs - if(i.ne.gtp_biblioref_version) then - write(*,*)'Warning, the bibliographic references version not same' - endif - if(ocv()) write(*,*)'Reading bibligraphic references: ',nrefs,reffree -! reffree=nrefs+1 - reffree=1 - do i=1,nrefs -!>>>>> 41: number characters to read - read(lin)jp -! write(*,*)'Length of text: ',i,jp -!>>>>> 42: text - if(jp.gt.512) then - write(*,*)'Too long bibliographic reference text',jp - gx%bmperr=7777; goto 1000 - endif - read(lin)text(1:jp) -! write(*,*)text(1:jp) - call tdbrefs(text(1:16),text(17:jp),0,iref) - if(gx%bmperr.ne.0) goto 1000 - enddo -1000 continue - return - end subroutine biblioread - -!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! - -!\begin{verbatim} - subroutine new_gtp -! -! DELETES ALL DATA so a new TDB file can be read -! -! this is needed before reading a new unformatted file (or same file again) -! we must go through all records and delete and deallocate each -! separately. Very similar to gtpread - implicit none -!\end{verbatim} - integer isp,j,nel,intv(10) - double precision dblv(10) - TYPE(gtp_equilibrium_data), pointer :: ceq -! TYPE(gtp_fraction_set) :: fslink - if(ocv()) write(*,*)'Removing current data' -!---------- elementlist, no need to delete, just deallocate below -!>>>>> 2: -!---------- specieslist, we have to deallocate ?? maybe not ?? -!>>>>> 3: - if(btest(globaldata%status,GSNODATA)) then - if(ocv()) write(*,*)'No thermodynamic data to delete' - goto 600 - endif - if(gtp_species_version.ne.1) then - if(ocv()) write(*,17)'Species',1,gtp_species_version -17 format(a,' record version error: ',2i4) - gx%bmperr=7777; goto 1000 - endif - ceq=>firsteq - do isp=1,noofsp - nel=splista(isp)%noofel - deallocate(splista(isp)%ellinks) - deallocate(splista(isp)%stoichiometry) - enddo -!---------- phases, many records, here we travese all endmembers etc -!>>>>> 4 - if(gtp_phase_version.ne.1) then - if(ocv()) write(*,17)'Phase',1,gtp_phase_version - gx%bmperr=7777; goto 1000 - endif - if(gtp_endmember_version.ne.1) then - if(ocv()) write(*,17)'Endmember',1,gtp_endmember_version - gx%bmperr=7777; goto 1000 - endif - if(gtp_interaction_version.ne.1) then - if(ocv()) write(*,17)'Interaction',1,gtp_interaction_version - gx%bmperr=7777; goto 1000 - endif - if(gtp_property_version.ne.1) then - if(ocv()) write(*,17)'Property',1,gtp_property_version - gx%bmperr=7777; goto 1000 - endif - do j=0,noofph - call delphase(j) - if(gx%bmperr.ne.0) goto 1000 - enddo -!----------- jump here if no thermodynamic data -600 continue -!---------- equilibrium records -!>>>>> 50: equilibrium records -! call delete_equil(ceq) -! do j=1,noofeq -! this loop was added in an attempt to get rid of an error occuring with -! 64 bit version, the TP functions was not cleared correctly - do j=1,eqfree-1 - ceq=>eqlista(j) - deallocate(ceq%svfunres) - deallocate(ceq%eq_tpres) - enddo -! I am not sure if this really releases all memory, how to check .... ??? - deallocate(eqlista) -!------- deallocate elements, species and phases, will be allocated in init_gtp - deallocate(ellista) - deallocate(elements) - deallocate(splista) - deallocate(species) - deallocate(phlista) - deallocate(phases) - deallocate(phasetuple) -!------ tpfunction expressions and other lists -!>>>>> 20: delete tpfuns -! write(*,*)'Delete TP funs, just deallocate??' - call delete_all_tpfuns -! write(*,*)'Back from deleting all TP funs, this is fun!!' -!------ tpfunction expressions and other lists -!>>>>> 30: delete state variable functions - deallocate(svflista) -! call delete_svfuns -!---------- delete bibliographic references -!>>>>> 40: references - deallocate(bibrefs) -! call delete_biblio -!------ parameter property records - deallocate(propid) -! deallocate( .... any more ??? -!--------------------------- -! now initiate all lists and a little more - if(ocv()) write(*,*)'All data structures will be reinitiated' -! intv(1) negative means reinititate with same values as before - intv(1)=-1 - call init_gtp(intv,dblv) -! after return firsteq must ve initiated ... maybe it should be done here ?? -! -1000 continue - return - end subroutine new_gtp - -!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! - -!\begin{verbatim} - subroutine delphase(lokph) -! save data for phase at location lokph (except data in the equilibrium record) -! For phases with disordered set of parameters we must access the number of -! sublattices via firsteq - implicit none - integer lokph -!\end{verbatim} - integer level,nsl,noendm - type(gtp_endmember), pointer :: emrec,nextem - type(gtp_interaction), pointer :: intrec,nextint - type(gtp_property), pointer :: proprec,nextprop -! to keep track of interaction records - type saveint - type(gtp_interaction), pointer :: p1 - end type saveint - type(saveint), dimension(:), pointer :: stack - type(gtp_phase_add), pointer :: addlink,nextadd -! write(*,*)'In delphase',lokph - allocate(stack(5)) - nsl=phlista(lokph)%noofsubl -!>>>>> 6: - deallocate(phlista(lokph)%nooffr) - deallocate(phlista(lokph)%constitlist) - emrec=>phlista(lokph)%ordered - noendm=0 -!>>>>> 6: sublattice info -! we come back here if there are disordered parameters -200 continue -! there can be phases without any parameters ... - emlista: do while(associated(emrec)) - proprec=>emrec%propointer - intrec=>emrec%intpointer - nextem=>emrec%nextem -!>>>>> 7: after saving links deallocate endmember record with all its content -! write(*,*)'deallocate endmember record' - deallocate(emrec) -! nextem do not need to be declared as target?? - emrec=>nextem - emproplista: do while(associated(proprec)) - nextprop=>proprec%nextpr -!>>>>> 8: endmember property records -! functions and references deallocated separately -! write(*,*)'deallocate endmember property record' - deallocate(proprec) - proprec=>nextprop - enddo emproplista -! interaction tree - level=0 -300 continue - intlista: do while(associated(intrec)) -!>>>>> 9: interaction record - level=level+1 - if(level.gt.5) then - gx%bmperr=4164; goto 1000 - endif -! write(*,*)'Pushing ',level - stack(level)%p1=>intrec%nextlink - nextint=>intrec%highlink - proprec=>intrec%propointer -! write(*,*)'deallocate interaction record' - deallocate(intrec) - intproplista: do while(associated(proprec)) - nextprop=>proprec%nextpr -!>>>>> 10: interaction properties -! write(*,*)'deallocate interaction property record' - deallocate(proprec) - proprec=>nextprop - enddo intproplista - intrec=>nextint - enddo intlista -! pop the link to next interaction if any - pop: if(level.gt.0) then -! write(*,*)'popping interaction record',level - intrec=>stack(level)%p1 - nullify(stack(level)%p1) - level=level-1 - goto 300 - endif pop -!---- next endmember - emrec=>nextem - enddo emlista -! no more endmembers, check if the disordered (if any) has been written - if(noendm.eq.0) then -! we do not have to care about that nsl is different .... -!>>>>> 11: disordered endmembers -! write(*,*)'disordered endmembers' - emrec=>phlista(lokph)%disordered - noendm=1 - goto 200 - endif -! write(*,*)'finished parameter records' -!------ additions list -500 continue - addlink=>phlista(lokph)%additions - addition: do while(associated(addlink)) -!>>>>> 12: additions - nextadd=>addlink%nextadd - if(addlink%type.eq.1) then -!>>>>> 12A: delete magnetic addition ... - deallocate(addlink) - else - write(*,*)'Cannot delete unknown addition type ',addlink%type - endif - addlink=>nextadd - enddo addition -! write(*,*)'phase location: ',lokph,size(phlista(lokph)%nooffr),& -! size(phlista(lokph)%constitlist) -! if(lokph.ne.0) then -! problem with phases, cannot deallocate these arrays, why?? -! deallocate(phlista(lokph)%nooffr) -! deallocate(phlista(lokph)%constitlist) -! endif - phlista(lokph)%noofcs=0 - phlista(lokph)%nooffs=0 -! write(*,*)'all done' -1000 continue - return - end subroutine delphase - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - logical function iskeyword(text,keyword,nextc) -! compare a text with a given keyword. Abbreviations allowed -! but the keyword and abbreviation must be surrounded by spaces -! nextc set to space character in text after the (abbreviated) keyword - implicit none - character text*(*),keyword*(*),key*64 - integer nextc -!\end{verbatim} - character word*64 - logical ok - integer kl,ks,kt -! extract the first word of text - ks=1 - if(eolch(text,ks)) then -! if empty line, just exit - ok=.false.; goto 1000 - else -! find the space after the first word - kt=ks+index(text(ks:),' ')-1 -! the abbreviation of the keyword must be at least 3 character !!! - if(kt-ks.lt.3 .or. kt-ks.ge.64) then - ok=.false.; goto 1000 - endif - endif - word=text(ks:kt) - kt=kt-ks - key=keyword - kl=len_trim(key) -! check if word is an abbreviation of key - if(word(1:kt).eq.key(1:kt)) then -! found keyword at start of line, set nextc to be positioned at the final space - nextc=ks+kt - ok=.true. - else - ok=.false. - endif -! write(*,100)ok,text(1:15),word(1:15),key(1:15),nextc,ks,kt,kl -!100 format('iskeyword: ',l1,' >',a,'<>',a,'<>',a,'<',5i3) -1000 continue - iskeyword=ok - return - end function iskeyword - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - integer function istdbkeyword(text,nextc) -! compare a text with a given keyword. Abbreviations allowed (not within _) -! but the keyword and abbreviation must be surrounded by spaces -! nextc set to space character in text after the (abbreviated) keyword - implicit none - character text*(*) - integer nextc -!\end{verbatim} -! only those currently implemented ... rest ignored - integer, parameter :: kwl=20 - character (len=kwl), dimension(12), parameter :: keyword=& - ['ELEMENT ','SPECIES ',& - 'PHASE ','CONSTITUENT ',& - 'FUNCTION ','PARAMETER ',& - 'TYPE_DEFINITION ','LIST_OF_REFERENCES ',& - 'ADD_REFERENCES ','ASSESSED_SYSTEMS ',& - 'DATABASE_INFORMATION','VERSION '] -! - character word*64 - integer j,ks,kt -! extract the first word of text - ks=1 - if(eolch(text,ks)) then -! if empty line, just exit - j=0; goto 1000 - else -! find the space after the first word - kt=ks+index(text(ks:),' ')-1 -! the abbreviation of the keyword must be at least 3 character, max kwl - if(kt-ks.lt.3 .or. kt-ks.ge.kwl) then - j=0; goto 1000 - endif - endif - word=text(ks:kt) - kt=kt-ks -! check if word is an abbreviation of a keyword -! write(*,*)'abbreviation: ',kt,'>',word(1:kt),'<' - do j=1,10 - if(word(1:kt).eq.keyword(j)(1:kt)) goto 100 - enddo - j=0 - goto 1000 -! found keyword at start of line, set nextc to be positioned at the final space -100 continue - nextc=ks+kt -! write(*,101)j,nextc,text(1:nextc) -!101 format('Found keyword: ',2i3,'>',a,'<') -1000 continue - istdbkeyword=j - return - end function istdbkeyword - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine readtdb(filename,nel,selel) -! reading data from a TDB file with selection of elements -!------------------------------------------------------- -! Not all TYPE_DEFS implemented -!------------------------------------------------------- - implicit none - integer nel - character filename*(*),selel(*)*2 -!\end{verbatim} - character line*100,elsym*2,name1*24,name2*24,elsyms(10)*2 - character longline*10000,reftext*512 - character phtype*1,ch1*1,const(maxsp)*24,name3*24,funname*60 - character refx*16 - character (len=1), dimension(20) :: typedefchar - integer, dimension(20) :: typedefaction - integer, dimension(5) :: addphasetypedef - double precision mass,h298,s298 - integer, dimension(10) :: knr,endm -! lint(1,*) is sublattice, lint(2,*) is species - double precision stoik(10),xsl,xxx - integer lint(2,3),noofphasetype,nytypedef,nextc,keyw,tdbv - integer typty,fractyp,lp1,lp2,ix,jph,kkk,lcs,nint,noelx - logical onlyfun,nophase,ionliq,notent - integer norew,newfun,nfail,nooftypedefs,nl,ipp,jp,jss,lrot,ip,jt - integer nsl,ll,kp,nr,nrr,mode,lokph,lokcs,km,nrefs,ideg,iph,ics -! disparttc and dispartph to handle phases with disordered parts - integer nofunent,disparttc,dodis,jl,nd1,thisdis - character*24 dispartph(5),ordpartph(5) -! set to TRUE if element present in database - logical, allocatable :: present(:) -! - if(ocv()) write(*,*)'reading a TDB file' - if(.not.(index(filename,'.tdb').gt.0 & - .or. index(filename,'.TDB').gt.0)) then -! no extention provided - filename(len_trim(filename)+1:)='.TDB' - endif - if(nel.gt.0) then - allocate(present(nel)) - present=.FALSE. - endif -! disparttc counts the number of disordered phases to read, the -! phase names are in dispartph(1..disparttc) -! dodis is nonzero only when reading the disordered part of phases. - disparttc=0 - dodis=0 - open(21,file=filename,access='sequential',form='formatted',& - err=1010,iostat=gx%bmperr,status='old') - onlyfun=.FALSE. - tdbv=1 - norew=0 - newfun=0 - nfail=0 - nrefs=0 - nooftypedefs=0 -! nophase set false after reading a PHASE keyword, -! expecting next keyword to be CONSTITUENT - nophase=.TRUE. -! return here after rewind -90 continue - nl=0 -! return here to look for a new keyword, end-of-file OK here -100 continue - read(21,110,end=2000)line -110 format(a) - nl=nl+1 -! One should remove TAB characters !! ?? -! if(line(1:1).eq.'$') goto 100 - ipp=1 - if(eolch(line,ipp)) goto 100 - if(line(ipp:ipp).eq.'$') goto 100 - goto 120 -!----- this part moved to the end .... - funfirst: if(onlyfun) then -! first read only functions until all has been read -! if(line(2:10).eq.'FUNCTION ') then -! write(*,*)'Input line >',line(1:20),'<' - ipp=istdbkeyword(line,nextc) - if(ipp.eq.5) then -!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 -! FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) -! name1=line(11:18) -! special case, error in TDB file, UN_ASS is only 6 characters -! if(name1(1:6).eq.'UN_ASS') then -! name1=line(11:16); ipp=18 -! else -! ipp=20 -! endif - if(eolch(line,nextc)) then - write(*,*)'Function name must be on same line as FUNCTION' - gx%bmperr=4000; goto 1000 - endif - ipp=nextc+index(line(nextc:),' ') - name1=line(nextc:ipp-1) -! write(*,18)'function >',name1,'< ',nextc,ipp -!18 format(a,a,a,2i4) -! old code - longline=' ' - longline=line(ipp:) -111 continue - jp=len_trim(longline) - if(longline(jp:jp).eq.'!') then -! replace # by ' ' -112 continue - jss=index(longline(1:jp),'#') - if(jss.gt.0) then - longline(jss:jss)=' ' - goto 112 - endif -! write(*,*)'25F Entering function 1: ',name1,len_trim(longline) -! lrot=0 - call enter_tpfun(name1,longline,lrot,.TRUE.) - if(gx%bmperr.ne.0) then -! one may have error here if function calls other functions not entered, 4002 -! or if the function is already entered, 4026 - if(gx%bmperr.eq.4002.or. gx%bmperr.eq.4026) then - if(gx%bmperr.eq.4002) nfail=nfail+1 - gx%bmperr=0; goto 100 - endif - write(*,*)'Failed entering function: ',name1 - goto 1000 - endif - if(ocv()) write(*,*)'Entered function: ',name1 - newfun=newfun+1 - else - nl=nl+1 - read(21,110)line -! write(kou,101)'readtdb 2: ',nl,line(1:40) - longline=longline(1:jp)//line - goto 111 - endif - elseif(ipp.gt.0) then -! skip lines until !. There can be a ! on the line with the keyword! -77 continue - if(index(line,'!').le.0) then - read(21,110,end=2000)line - nl=nl+1 - goto 77 - endif - endif - goto 100 - endif funfirst -!--------------------------------------------------------- -! handle all TDB keywords except function -120 continue - keyw=istdbkeyword(line,nextc) - if(keyw.eq.0) then - ip=1 - if(.not.eolch(line,ip)) then - if(ocv()) write(*,*)'Ignoring line: ',nl,ip,line(ip:ip+20) - endif - goto 100 - elseif(onlyfun) then - if(keyw.eq.5) goto 800 - goto 100 - endif - if(.not.nophase .and. keyw.ne.4) then -! after a PHASE keyword one should have a CONSTITUENT - write(*,*)'expeciting CONSTITUENT: ',line(1:30) - endif -! check there is a ! in line, otherwise read until we find an exclamation mark - ip=1 - longline(ip:)=line - ip=len_trim(longline)+1 -! write(*,*)'new keyword ',ip,'>',longline(1:40) - do while(index(longline,'!').le.0) - read(21,110,err=2200)line - nl=nl+1 - if(line(1:1).ne.'$') then - longline(ip:)=line - ip=len_trim(longline)+1 - if(ip.gt.len(longline)-80) then - write(*,69)nl,ip,longline(1:72) -69 format('Overflow in longline ',2i5,' for line starting:'/a) - gx%bmperr=7777; goto 1000 - endif - endif - enddo - if(dodis.eq.1) then -! if dodis=1 only read data for disordred phases -! PHASE=3, CONSTITUENT=4, PARAMETER=6 ... any more? - if(keyw.lt.3 .or. keyw.eq.5 .or. keyw.gt.6) goto 100 - endif -! - select case(keyw) - case default - if(ocv()) write(*,*)'default case: ',keyw,line(1:30) -!--------------------------------------------------------------------- -!101 format('readtdb 1: ',i3,'>',a,'<') -! if(line(2:9).eq.'ELEMENT ') then - case(1) !element ------------------------------------------------ -!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 -! ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01! - ip=nextc - if(eolch(longline,ip)) then - write(*,*)'No element name after ELEMENT keyword on line ',nl - gx%bmperr=7777; goto 1000 - endif - elsym=longline(ip:ip+1) - if(elsym.eq.'/-' .or. elsym.eq.'VA') goto 100 -! allow lower case in TDB file ... - call capson(elsym) - if(nel.gt.0) then -! check if element among selected, if nel=0 accept all - do jt=1,nel - if(elsym.eq.selel(jt)) goto 76 - enddo -! ignore this element as not selected - if(ocv()) write(*,*)'Skipping database element: ',elsym -! write(*,*)'Skipping database element: ',elsym -! write(*,*)'Select: ',nel,(selel(jt),jt=1,nel) - goto 100 - endif -! mark we found a selected element -76 continue - if(allocated(present)) then - present(jt)=.TRUE. - endif - ip=ip+len_trim(elsym) - if(eolch(longline,ip)) then - name1='DUMMY' - mass=one - h298=zero - s298=zero - else - name1=longline(ip:) - ip=ip+len_trim(name1) - call getrel(longline,ip,mass) - if(buperr.ne.0) then - mass=one; buperr=0 - endif - call getrel(longline,ip,h298) - if(buperr.ne.0) then - h298=zero; buperr=0 - endif - call getrel(longline,ip,s298) - if(buperr.ne.0) then - s298=zero; buperr=0 - endif - name2=elsym - endif - call new_element(elsym,name2,name1,mass,h298,s298) - if(gx%bmperr.ne.0) goto 1000 - case(2) !SPECIES ------------------------------------------------- -! elseif(line(2:9).eq.'SPECIES ') then -!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 -! SPECIES O3PU2 O3PU2! - ip=nextc - if(eolch(longline,ip)) then - write(*,*)'Line after SPECIES keyword empty' - gx%bmperr=7777; goto 1000 - endif - name1=longline(ip:) -! find first space after non-space - jp=index(name1,' ') - name1(jp:)=' ' - ip=ip+jp - if(eolch(longline,ip)) then - write(*,*)'No stoichiometry for species: ',name1 - goto 100 - endif - name2=longline(ip:) - jp=index(name2,' ') - name2(jp:)=' ' - call decode_stoik(name2,noelx,elsyms,stoik) - if(gx%bmperr.ne.0) goto 1000 -! check elements exist - call new_species(name1,noelx,elsyms,stoik) -! write(*,*)'25F: entering species error: ',gx%bmperr - if(gx%bmperr.ne.0) then -! if element not selected just skip the species - if(gx%bmperr.eq.4046) then - gx%bmperr=0; goto 100 - else - write(*,*)'Error entering species: ',name1,name2 - goto 1000 - endif - endif -!----------------------------------------------------------------------- - case(5) ! function -! elseif(line(2:10).eq.'FUNCTION ') then -!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 -! FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) -! name1=line(11:18) -! longline=' ' -! longline=line(20:) -!300 continue -! jp=len_trim(longline) -! if(longline(jp:jp).eq.'!') then -! write(*,*)'Skipping function: ',name1 -! all functions entered at the end, skip until ! -! do while(index(longline,'!').le.0) - if(index(longline,'!').le.0) then - write(*,*)' Error, terminating ! not found for funtion!!',nl - gx%bmperr=7777; goto 1000 - endif -!------------------------------------------------------------------------- -! elseif(line(2:7).eq.'PHASE ') then - case(3) ! PHASE -!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 -! PHASE LIQUID:L % 1 1.0 ! - if(nophase) then - nophase=.false. -! give a warning if any selected element is not present - if(allocated(present)) then - funname=' ' - kkk=1 - do jt=1,nel - if(.not.present(jt)) then - funname(kkk:)=selel(jt) - kkk=len_trim(funname)+2 - endif - enddo - if(kkk.gt.1) then - write(kou,68)funname(1:kkk) -68 format(/' *** Warning, elements not present in database: ',a/) - endif - deallocate(present) - endif - else - write(*,*)'Error, a PHASE keyword must be followed by its CONSTIT' - gx%bmperr=7777; goto 1000 - endif - ip=nextc - if(eolch(longline,ip)) then - write(*,*)'line after PHASE empty' - goto 100 - endif - name1=longline(ip:) - jp=index(name1,' ') - ip=nextc+jp - if(jp.gt.0) then - name1(jp:)=' ' - endif - jp=index(name1,':') -! write(*,*)'readtdb 11: ',name1,ip,jp -! phytype - if(jp.gt.0) then - phtype=name1(jp+1:jp+1) - name1(jp:)=' ' - else - phtype=' ' - endif -! write(*,*)'nophase set to false, phase: ',name1 -! phase type code - noofphasetype=0 - ip=ip+1 - jp=ip - name2=longline(ip:jp) - thisdis=0 - phdis: if(dodis.eq.1) then -! special when reading disordered parts, check phase name equail -! write(*,*)'Check if disordered part: ',dodis,name1 - do jt=1,disparttc - if(name1.eq.dispartph(jt)) goto 307 - enddo -! not a disordered part - goto 100 -307 continue - thisdis=jt -! write(*,*)'Found disordered part: ',name1,thisdis -! we skip the rest of the phase line ... - goto 100 - elseif(dodis.eq.0 .and. disparttc.gt.0) then -! we must not enter phases that are disordered parts - do jt=1,disparttc - if(name1.eq.dispartph(jt)) then -! write(*,*)'Skip phase that is a disordered part: ',name1 - thisdis=-1 - goto 100 - endif - enddo - endif phdis -! write(*,*)'Entering phase: ',name1 -! write(*,*)'Checking phase types for phase: ',name1,jp -310 jp=jp+1 -! NOTE and FIX: type code expected to be after a single space: be flexible ?? - typedefcheck: if(longline(jp:jp).ne.' ') then - ch1=longline(jp:jp) -! write(*,*)'typedef: ',ch1,jp - do jt=1,nooftypedefs - if(ch1.eq.typedefchar(jt)) goto 320 - enddo - goto 310 -320 continue - if(typedefaction(jt).eq.99) then -! ignore TYPE_DEF SEQ - continue - elseif(typedefaction(jt).eq.-1 .or. & - typedefaction(jt).eq.-3) then -! magnetic addition, save for after phase created - noofphasetype=noofphasetype+1 - addphasetypedef(noofphasetype)=typedefaction(jt) - else - continue - endif - goto 310 - endif typedefcheck - name2='TDB file model: '//name2 -! sublattices -! write(*,*)'25F buperr: ',buperr ,jp - call getrel(longline,jp,xsl) - if(buperr.ne.0) then - write(*,*)'25F tdb: "',longline(1:jp),'"',buperr - gx%bmperr=buperr; goto 1000 - endif - nsl=int(xsl) - do ll=1,nsl - call getrel(longline,jp,stoik(ll)) - if(buperr.ne.0) then - gx%bmperr=buperr; goto 1000 - endif - enddo -! write(*,*)'readtdb 3A: ',nsl,(stoik(ll),ll=1,nsl) -!--------------------------------------------------------------------- -! The constituent line must follow PHASE before any new phase - case(4) ! CONSTITUENT LIQUID:L :CR,FE,MO : ! -! the phase must have been defined - if(nophase) then - write(*,*)'A CONSTITUENT keyword not directly preceeded by PHASE!' - gx%bmperr=7777; goto 1000 - endif - nophase=.true. - condis1: if(dodis.eq.1) then - if(thisdis.eq.0) goto 100 -! we skip the constituent line and go directly to create disordered fractions - goto 395 - elseif(disparttc.gt.0 .and. thisdis.lt.0) then -! this is a disordered part, skip - goto 100 - endif condis1 -!360 continue - jp=len_trim(longline) -! write(*,*)'readtdb gas1: ',nl,jp,longline(1:jp) -! eliminate all after the exclamation mark -! longline(jp+1:)=' ' -! - ip=index(longline,' :')+2 -! write(*,*)'readtdb gas2: ',jp,longline(1:jp) - ll=0 - nr=0 - nrr=0 -! write(*,*)'readtdb 3C: ',ll,nr,nsl,longline(ip:jp) -! mode=1 indicates to getname that / + - are allowed in species names - mode=1 -370 continue - if(ll.ge.1) then - knr(ll)=nr - if(nr.le.0) then - if(ocv()) then - write(*,*)'Skipping phase due to missing constituents: ',name1 -! write(*,378)name1,ll -378 format('Phase ',a,' has no constituents in sublattice ',i2) -! Not a fatal error when elements have been selected but skip this phase -! gx%bmperr=7777; goto 1000 - endif - goto 100 - endif - endif - ll=ll+1 -! write(*,*)'start sublat ',ll,nsl,nr,ip - if(ll.gt.nsl) goto 390 - nr=0 -380 continue - if(eolch(longline,ip)) then - write(*,*)'Error extracting constituents 1' - gx%bmperr=7777; goto 1000 - endif - nr=nr+1 - nrr=nrr+1 -! write(*,379)'readtdb 3CXX: ',ip,nr,longline(ip:ip+10) -379 format(a,2i4,' >',a,'< >',a,'< >',a,'<') - call getname(longline,ip,name3,mode,ch1) -! write(*,379)'readtdb 3CY: ',ip,nr,longline(ip:ip+10),name3,ch1 - if(buperr.ne.0) then -! write(*,381)'readtdb 3E: ',ll,nr,longline(1:ip+5),ip,name3 -381 format(a,2i4,' "',a,'" ',i5,1x,a,'"',a) - gx%bmperr=buperr; goto 1000 - endif -! write(*,381)'readtdb 3E: ',ll,nr,longline(1:ip+5),ip,name3,ch1 - const(nrr)=name3 -! bypass any "major" indicator % - if(ch1.eq.'%') ip=ip+1 - if(eolch(longline,ip)) then - write(*,*)'Error extracting constituents 2' - gx%bmperr=7777; goto 1000 - endif -! check that const(nrr) among the selected elements ... -! write(*,*)'Testing constituent: ',name3,nr - call find_species_record_noabbr(name3,lp1) - if(gx%bmperr.ne.0) then -! this species is not present, not a fatal error, skip it and continue -! write(*,*)'Skipping constituent: ',name3 - gx%bmperr=0; nrr=nrr-1; nr=nr-1 - endif - ch1=longline(ip:ip) - if(ch1.eq.',') then - ip=ip+1; goto 380 - elseif(ch1.eq.':') then - ip=ip+1; goto 370 - endif - if(ch1.ne.'!') goto 380 -! when an ! found the list of constutents is finished. But we -! should have found a : before the ! - write(*,*)'Found "!" before terminating ":"' - gx%bmperr=7777; goto 1000 -! write(*,*)'Species terminator error: ',ch1,nl -! gx%bmperr=4157; goto 1000 -390 continue -! name2 is model, ignored on reading TDB - ionliq=.FALSE. - if(phtype(1:1).eq.'Y') then - name2='IONIC_LIQUID ' - ionliq=.TRUE. - else - name2='CEF-TDB-RKM? ' - endif - if(ocv()) write(*,*)'readtdb 9: ',name1,nsl,knr(1),knr(2),phtype -395 continue - condis2: if(dodis.eq.1) then -! if we have a disordered part do not enter the phase, add disordered fracs! -! the ordered phase name is ordpart(thisdis) - call find_phase_by_name(ordpartph(thisdis),iph,ics) - if(gx%bmperr.ne.0) then - write(*,396)thisdis,ordpartph(thisdis) -396 format('25F Cannot find ordered phase: ',i3,'"',a,'"') - goto 1000 - else - write(*,*)'Adding disordered fraction set: ',ordpartph(thisdis) - endif -! we are creating the phase, only one composition set - call get_phase_compset(iph,1,lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 -! ch1 is suffix for parameters, always D - ch1='D' -! jl=0 if NDM (sigma) -! jl=1 if phase can be totally disordered (but can have interstitials) -! nd1 is the number of sublattices to sum into disordered set - write(*,399) -399 format('Phase names for disordered parts of FCC, BCC and HCP must',& - ' start with:'/' A1_ , A2_ and A3_ respectivly!'/& - ' and have an interstitial sublattice') - if(dispartph(thisdis)(1:3).eq.'A1_' .or. & - dispartph(thisdis)(1:3).eq.'A2_' .or. & - dispartph(thisdis)(1:3).eq.'A3_') then -! if disordred phase is FCC, BCC or HCP then set jl=1 and nd1 to 2 or 4 - if(phlista(lokph)%noofsubl.le.5) nd1=4 - if(phlista(lokph)%noofsubl.le.3) nd1=2 - write(kou,397)ordpartph(thisdis)(1:len_trim(ordpartph(thisdis))),& - nd1 -397 format('The phase ',a,& - ' set to have an order/disorder partition model summing ',i2) - jl=1 - else -! disordered part of sigma, mu etc. - jl=0; nd1=phlista(lokph)%noofsubl - write(kou,398)'Phase assumed to be NODT',nd1,& - ordpartph(thisdis)(1:len_trim(ordpartph(thisdis))) -398 format(a,i3,2x,a) - endif -! add DIS_PART from TDB - call add_fraction_set(iph,ch1,nd1,jl) - if(gx%bmperr.ne.0) then - write(*,*)'25F Error entering disordered fraction set: ',gx%bmperr - goto 1000 - endif - if(jl.eq.0) then -! we must set the correct formula unit of the disordered phase, on the -! TDB file it is unity. Sum up the sites for the ordered phase in lokcs - xxx=zero - do ll=1,nd1 - xxx=xxx+firsteq%phase_varres(lokcs)%sites(ll) - enddo - firsteq%phase_varres(lokcs)%disfra%fsites=xxx - else - xxx=one - endif - write(kou,601)dispartph(thisdis)(1:len_trim(dispartph(thisdis))),& - ch1,nd1,jl,xxx -601 format('Parameters from disordered part added: ',a,5x,a,2x,2i3,F12.4) - else - call new_phase(name1,nsl,knr,const,stoik,name2,phtype) -! write(*,*)'readtdb 9A: ',gx%bmperr - if(gx%bmperr.ne.0) goto 1000 -! any typedefs? only magnetic handelled at present - call find_phase_by_name(name1,iph,lcs) -! write(*,*)'readtdb 9X: ',gx%bmperr - if(gx%bmperr.ne.0) goto 1000 - lokph=phases(iph) -! write(*,*)'typedefs for ',name1(1:20),lokph,noofphasetype - phasetypes: do jt=1,noofphasetype -! write(*,*)'typedef ',jt,addphasetypedef(jt) - if(addphasetypedef(jt).eq.-1) then - call add_magrec_inden(lokph,1,-1) - elseif(addphasetypedef(jt).eq.-3) then - call add_magrec_inden(lokph,1,-3) - endif - if(gx%bmperr.ne.0) goto 1000 - enddo phasetypes - endif condis2 -! write(*,*)'readtdb 9B:',name1,nsl,phtype -!------------------------------------------------------------------- - case(6) ! PARAMETER -------------------------------------------- -! elseif(line(4:13).eq.'PARAMETER ') then -!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 -! PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T - if(eolch(longline,nextc)) then - write(*,*)'Empty line after PARAMETER' - gx%bmperr=7777; goto 1000 - endif -! if(dodis.eq.1) write(*,*)'Reading disordered parameters' - ip=nextc - funname=longline(ip:) - kp=index(funname,' ') -! save position after parameter name in nextc - nextc=ip+kp - funname(kp:)=' ' -! extract symbol, normally G or L but TC, BMAGN and others can occur - lp1=index(funname,'(') - name1=funname(1:lp1-1) - typty=0 -! this is kept for compatibility with TDB files generated by TC - if(name1(1:2).eq.'G ' .or. name1(1:2).eq.'L ') then - typty=1 - elseif(name1(1:3).eq.'TC ') then - typty=2 - elseif(name1(1:6).eq.'BMAGN ') then - typty=3 - endif -! we should handle also other parameter types - if(typty.eq.0) then -! find the property associated with this symbol -! write(*,*)'psym1: ',name1(1:len_trim(name1)) - call get_parameter_typty(name1,lokph,typty,fractyp) - if(gx%bmperr.ne.0) then - write(*,*)' *** Illegal parameter identifier on line: ',nl - gx%bmperr=0; typty=0 - endif -! write(*,*)'psym2: ',typty,fractyp - endif -! only fractyp 1 on TDB files until I implemented disordered part - fractyp=1 -! write(*,*)'readtdb: PAR',name1,typty -! extract phase name and constituent array - lp1=index(funname,'(') - lp2=index(funname,',') - name2=funname(lp1+1:lp2-1) - dispar: if(dodis.eq.1) then -! first check if phase name is a disordered part, if not skip -! then change phase name to ordered phase and set fractyp=2 -! and add a suffix D to parameter symbol - do jl=1,disparttc - if(name2.eq.dispartph(jl)) goto 710 - enddo -! not disordered phase, skip this parameter - goto 100 -!----------------------- -710 continue - write(*,*)'Entering disordered parameter to: ',ordpartph(thisdis) - write(*,*)'> ',longline(1:len_trim(longline)) - name2=ordpartph(jl) - fractyp=2 - endif dispar - call find_phase_by_name_exact(name2,jph,kkk) -! write(*,*)'readtdb 19: ',jph,gx%bmperr,name2 - if(gx%bmperr.ne.0) then -! write(*,*)'Skipping parameter due to phase: ',name2 - gx%bmperr=0; goto 100 -! goto 1000 - endif -! extract constituent array, remove final ) and decode - lokph=phases(jph) - name3=funname(lp2+1:) -! find terminating ) - lp1=index(name3,')') - if(lp1.le.0) then - write(*,*)'Possible error in constituent array? ',name3,', line:',nl - goto 100 - else - name3(lp1:)=' ' - endif -297 continue -! - call decode_constarr(lokph,name3,nsl,endm,nint,lint,ideg) - if(ocv()) write(*,303)'readtdb 303: ',name3(1:len_trim(name3)),& - nsl,endm(1),endm(2),nint,((lint(ip,jp),ip=1,2),jp=1,nint) -303 format(a,a,2i4,2x,2i3,' : ',3(2i3,2x)) - if(gx%bmperr.ne.0) then -! error here can mean parameter with un-selected constituent, i.e. no error -! write(*,*)'25F: decode',ionliq,tdbv,nsl,gx%bmperr - if(ionliq .and. tdbv.eq.1 .and. nsl.eq.1) then -! handle parameters in ionic liquids with only neutrals in second sublattice -! in TC one can have no constituent there or an arbitrary constituent, -! in OC the constituent in sublattice 1 must be a * - nsl=2 - endm(2)=endm(1) - endm(1)=-99 -! shift any interaction from sublattice 1 to 2 - do ip=1,nint -! write(*,*)'25F lint: ',lint(1,ip),lint(2,ip) - lint(2,ip)=2 - enddo - if(ocv()) write(*,303)'modif endmem: ',name3(1:len_trim(name3)),& - nsl,endm(1),endm(2),nint,((lint(ip,jp),ip=1,2),jp=1,nint) - gx%bmperr=0 - else - if(ocv()) write(*,*)'Skipping parameter: ',name3(1:len_trim(name3)) - gx%bmperr=0; goto 100 -! write(*,*)'readtdb error: ',gx%bmperr,name3 -! goto 1000 - endif - endif - if(nint.gt.1) then -! lint(1,1) is species of first, lint(1,2) in second interaction -! write(*,305)'readtdb 305: ',endm(1),nint,lint(2,1),lint(2,2) - endif -305 format(a,5i4) -!---------------- encode function -! if(dodis.eq.1) write(*,*)'We are here 1' - ip=0 - jp=0 -400 continue - ip=ip+1 -405 continue - ch1=funname(ip:ip) -! accept the first 8 letters and numbers of phase name - if((ch1.ge.'A' .and. ch1.le.'Z') .or. & - (ch1.ge.'0' .and. ch1.le.'9')) goto 400 - if(ch1.ne.' ') then - funname(ip:)=funname(ip+1:) - jp=jp+1 - if(jp.lt.8) goto 405 - funname(ip+1:)=' ' - endif - funname='_'//funname -!------------------------------------------------- -! now read the function, start from position nextc - longline=longline(nextc:) -!410 continue - jp=len_trim(longline) - if(longline(jp:jp).ne.'!') then - write(*,410)nl,ip,longline(1:ip) -410 format('Error, parameter line not ending with !',2i5/a) - gx%bmperr=7777; goto 1000 - endif -! extract reference if any -! NOTE: a legal ending is ;,,,! - refx='none' - kp=jp-1 - do while(longline(kp:kp).ne.';') - kp=kp-1 - if(kp.lt.1) then -! illegal termination of function in TDB file - write(*,417)nl -417 format('No final ; of function in TDB file, around line: ',i5) - gx%bmperr=4013; goto 1000 - endif - enddo - kp=kp+2 -! longline(kp:kp) is character after "; " or ";," -! next is upper temperature limit or , meaning default. We have a "!" at end -430 continue - if(eolch(longline,kp)) continue - if(longline(kp:kp).eq.',') then - kp=kp+1 - elseif(longline(kp:kp).eq.'!') then - goto 433 - else -! ; 6000 N 91DIN ! -! kp=^ => index(...,' ')=5; kp=kp+4 - kp=kp+index(longline(kp:),' ')-1 - endif -! next is N or , - if(eolch(longline,kp)) continue - if(longline(kp:kp).ne.'!') then - kp=kp+1 - endif - if(eolch(longline,kp)) continue - if(kp.lt.jp) refx=longline(kp:jp-1) -! ------------------- we found the reference, continue with the expression -433 continue -! replace any # by ' ' -412 continue - jss=index(longline(1:jp),'#') - if(jss.gt.0) then - longline(jss:jss)=' ' - goto 412 - endif -! write(*,*)'25F Entering function 2: ',funname,len_trim(longline) -! lrot=0 - call enter_tpfun(funname,longline,lrot,.TRUE.) -! write(*,17)lokph,typty,nsl,lrot,(endm(i),i=1,nsl) -17 format('readtdb 17: '4i3,5x,10i3) -! write(*,404)'readtdb entpar: ',refx,fractyp,nint,ideg -404 format(a,a,i3,2x,10i3) - if(gx%bmperr.ne.0) then - write(*,*)'Error set: ',gx%bmperr,lrot,' ',& - funname(1:len_trim(funname)),' around line: ',nl - goto 1000 - else -! if(dodis.eq.1) write(*,*)'We are here 2' - call enter_parameter(lokph,typty,fractyp,nsl,endm,nint,lint,ideg,& - lrot,refx) - if(ocv()) write(*,407)'Entered parameter: ',lokph,typty,gx%bmperr -407 format(a,3i5) - if(gx%bmperr.ne.0) then - if(dodis.eq.1) write(*,*)'error ',gx%bmperr - if(.not.(gx%bmperr.ne.4096 .or. gx%bmperr.ne.4066)) goto 1000 -! ignore error 4096 meaning "no such constituent" or "... in a sublattice" -! write(*,*)'readtdb entparerr: ',gx%bmperr,' >',& -! funname(1:len_trim(funname)) - gx%bmperr=0 - elseif(dodis.eq.1) then - write(*,*)'Disordered parameter should be entered ok' - endif - endif - if(gx%bmperr.ne.0) write(*,*)'25F errorcode 1: ',gx%bmperr -!------------------------------------------------------------------ -! elseif(line(2:17).eq.'TYPE_DEFINITION ') then - case(7) !TYPE_DEFINITION -!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 -! TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! - nytypedef=nooftypedefs+1 - nooftypedefs=nytypedef - typedefchar(nytypedef)=longline(nextc+1:nextc+1) - ip=nextc+3 - newtypedef: if(longline(ip:ip+2).eq.'SEQ') then - typedefaction(nytypedef)=100 - else - km=index(longline,' MAGNETIC ') - magnetic: if(km.gt.0) then - ip=km+9 -!73 format(a,i3,' "',a,'"') - call getrel(longline,ip,xxx) - if(buperr.ne.0) then - gx%bmperr=buperr; goto 1000 - endif -! this can be -1 for BCC or -3 for FCC, HCP and other phases - typedefaction(nytypedef)=int(xxx) - else - km=index(longline,' DIS_PART ') - if(km.gt.0) then -! disordered part, several checks - disparttc=disparttc+1 -! find the ordered phase name, we have to go backwrds from km - ip=km-1 -81 continue - if(longline(ip:ip).eq.' ') then -! ordpartph(disparttc)=' ' - ordpartph(disparttc)=longline(ip+1:km) - else - ip=ip-1 - goto 81 - endif -! extract the disordered part phase name - ip=index(longline(km+2:),' ') - dispartph(disparttc)=longline(km+2+ip:) -! find the end of phase name, a space or a , there is always a space ... - ip=index(dispartph(disparttc),' ') - km=index(dispartph(disparttc),',') - if(km.lt.ip) ip=km - dispartph(disparttc)(ip:)=' ' - write(*,82)disparttc,ordpartph(disparttc),dispartph(disparttc) -! longline(1:len_trim(longline)) -!82 format('Found a type_def DIS_PART:',a,' : ',a) -82 format('Found a type_def DIS_PART:',i2,1x,a,1x,a) -! if the disordered part phase already entered give advice - call find_phase_by_name(dispartph(disparttc),iph,ics) - if(gx%bmperr.ne.0) then - gx%bmperr=0 - else - write(*,83)dispartph(disparttc) -83 format(' *** Warning, the disordered phase is already',& - ' entered ***'/' Please rearrange the TDB file so',& - ' this TYPE_DEF comes before'/& - ' the PHASE keyword for the disordered phase: ',a/& - ' *** The disordordered part ignored ***') - disparttc=disparttc-1 - endif - else - typedefaction(nytypedef)=99 - write(kou,87)nl,longline(1:min(78,len_trim(longline))) -87 format('Skipping this TYPE_DEFINITION on line ',i5,':'/a) - endif - endif magnetic - endif newtypedef -!--------------------------------------------------------------------- -! elseif(line(2:20).eq.'LIST_OF_REFERENCES ' .or. & -! line(2:16).eq.'ADD_REFERENCES ') then - case(8,9) ! LIST_OF_REFERENCES and ADD_REFERENCES -!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 -! LIST_OF_REFERENCES -! NUMBER SOURCE -! REF283 'Alan Dinsdale, SGTE Data for Pure Elements, -! Calphad Vol 15(1991) p 317-425, -! also in NPL Report DMA(A)195 Rev. August 1990' -! write(kou,*)'Does not handle REFERENCES' -! skip the line with "NUMBER SOURCE" -! position ip after "NUMBER SOURCE" - ip=index(longline,'NUMBER SOURCE')+14 - if(eolch(longline,ip)) then - write(*,*)'Empty reference line',nl - gx%bmperr=7777; goto 1000 - endif - if(longline(ip:ip).eq.'!') then -! write(*,*)'No references at all' - goto 100 - endif -! write(*,*)'list_of_references text length: ',len_trim(longline),ip -! some reference lists like those from SSUB has no single quotes - kp=index(longline(ip:),"'") - citationmarks: if(kp.gt.0) then -775 continue -! reference symbol is refx; reference text in reftext - refx=longline(ip:ip+kp-2) - if(longline(ip+kp:ip+kp).eq."'") then -! two ' after each other, a dummy reference - reftext=' ' - ip=ip+kp+1 - kkk=1 -! write(*,*)'dummy: ',refx,' next >',longline(ip:ip+20),'<' - else - jp=ip+kp+1+index(longline(ip+kp+1:),"'") - reftext=longline(ip+kp:jp-2) - ip=jp -! when all works replace multiple spaces by a single one in reftext - kkk=len_trim(reftext) - kp=index(reftext(1:kkk),' ') - do while(kp.gt.0) - reftext(kp:)=reftext(kp+1:) - kkk=kkk-1 - kp=index(reftext(1:kkk),' ') - enddo - endif -! write(*,776)refx,nrefs,ip,jp,reftext(1:kkk) -776 format('Reference: ',a,3i5/a) -! this will not create bibliographic references that has not been referenced - call tdbrefs(refx,reftext(1:kkk),1,ix) - nrefs=nrefs+1 -! write(*,*)'added biblio ',refx,'>',longline(ip-5:ip+5),'<' - if(eolch(longline,ip)) then - gx%bmperr=7777; goto 1000 - endif - if(longline(ip:ip).ne.'!') then - kp=index(longline(ip:),"'") - goto 775 - endif - else -! references without citation marks -! ip is at the start of the reference id, look for space - write(*,*)'Cannot handle references without citation marks',nl - gx%bmperr=7777; goto 1000 - endif citationmarks -777 continue -! write(*,*)'Read ',nrefs,' references, ending at',nl -!---------------------------------------------------------------- - case(10) ! ASSESSED_SYSTEMS - write(*,*)'Cannot handle ASSESSED_SYSTEMS ending at ',nl -! skip lines until ! - do while(index(line,'!').le.0) - read(21,110)line - nl=nl+1 - enddo -!------------------------------------------------------------------ - case(11) ! DATABASE_INFORMATION - write(*,*)'Cannot handle DATABASE_INFORMATION at ',nl -! skip lines until ! - do while(index(line,'!').le.0) - read(21,110)line - nl=nl+1 - enddo -!------------------------------------------------------------------ - case(12) ! VERSION, recognize OC1 -780 continue - if(eolch(line,ip)) then - read(21,110)line - nl=nl+1 - goto 780 - else - if(line(ip:ip).eq.'!') then - write(*,*)'Found VERSION keyword but no specification' - else - if(line(ip:ip+3).eq.'OC1 ') tdbv=2 - endif - endif -! skip lines until ! - do while(index(line,'!').le.0) - read(21,110)line - nl=nl+1 - enddo - end select - if(gx%bmperr.ne.0) write(*,*)'25F errorcode 2: ',gx%bmperr -! look for next KEYWORD - goto 100 -!-------------------------------------------------------- -!----- reading functions at the end -800 continue -! barafun: if(onlyfun) then -! enter only functions that are undefined -! if(line(2:10).eq.'FUNCTION ') then -! write(*,*)'Input line >',line(1:20),'<' -! ipp=istdbkeyword(line,nextc) -! if(ipp.eq.5) then -!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 -! FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) -! name1=line(11:18) -! special case, error in TDB file, UN_ASS is only 6 characters -! if(name1(1:6).eq.'UN_ASS') then -! name1=line(11:16); ipp=18 -! else -! ipp=20 -! endif - if(eolch(line,nextc)) then - write(*,*)'Function name must be on same line as FUNCTION' - gx%bmperr=4000; goto 1000 - endif - ipp=nextc+index(line(nextc:),' ') - name1=line(nextc:ipp-1) -! write(*,18)'function >',name1,'< ',nextc,ipp -!18 format(a,a,a,2i4) -! old code - longline=' ' - longline=line(ipp:) -810 continue - jp=len_trim(longline) - if(longline(jp:jp).eq.'!') then -! replace # by ' ' -820 continue - jss=index(longline(1:jp),'#') - if(jss.gt.0) then - longline(jss:jss)=' ' - goto 820 - endif -! check if function is entered as undefined, exact match of name required - call find_tpfun_by_name_exact(name1,nr,notent) - if(gx%bmperr.eq.0) then - if(notent) then -! write(*,*)'Entering function: ',name1 -! entering a function may add new unentered functions ... last argument TRUE -! write(*,*)'25F Entering function 3: ',name1,len_trim(longline) -! lrot=0 - call enter_tpfun(name1,longline,lrot,.TRUE.) - if(gx%bmperr.ne.0) then -! one may have error here - write(*,*)'Failed entering function: ',name1 - goto 1000 - endif - if(ocv()) write(*,*)'Entered function: ',name1 - nofunent=nofunent+1 - endif - else -! reset error code - gx%bmperr=0 - endif - else - nl=nl+1 - read(21,110)line -! write(kou,101)'readtdb 2: ',nl,line(1:40) - longline=longline(1:jp)//line - goto 810 - endif - goto 100 -! endif barafun -!--------------------------------------------------------- -! We have now read all -!-------------------------------------------------------- -1000 continue - if(buperr.ne.0 .or. gx%bmperr.ne.0) then - if(gx%bmperr.eq.0) gx%bmperr=buperr - write(*,1005)gx%bmperr,nl -1005 format('Error ',i5', occured at TDB file line ',i7) - endif - close(21) -! read numbers, value after / is maximum -! endmember, interactions, property, -! tpfuns, composition sets, equilibria -! state variable functions, references, additions - if(ocv()) write(*,1007)noofel,maxel,noofsp,maxsp,noofph,maxph,& - noofem,100000,noofint,100000,noofprop,100000,& - notpf(),maxtpf,csfree-1,2*maxph,eqfree-1,maxeq,& - nsvfun,maxsvfun,reffree-1,maxrefs,addrecs,100000 -1007 format('Created records for elements, species, phases: ',2x,& - 3(i4,'/',i4,1x)/& - 'end members, interactions, properties: ',10x,& - 3(i4,'/',i4,1x)/& - 'TP-funs, composition sets, equilibria: ',10x,& - 3(i4,'/',i4,1x)/& - 'state variable functions, references, additions: ',& - 3(i4,'/',i4,1x)/) - return -1010 continue - write(*,*)'I/O error opening file: ',gx%bmperr - return -!----------------------------------------------------- -! end of file found, act differently if reading functions -2000 continue - rewind: if(dodis.eq.0 .and. disparttc.gt.0) then -! rewind to read disordred parts - write(*,*)'Rewind to read disordered parts of phases: ',disparttc - rewind(21) - dodis=1 - goto 100 - elseif(.not.onlyfun) then -! rewind to read referenced functions - dodis=2 - rewind(21) - onlyfun=.TRUE. - nofunent=0 -! write(*,2002)gx%bmperr -2002 format('Found end-of-file, rewind to find functions',i5) - goto 100 - elseif(nofunent.gt.0) then -! rewind if there were functions entered last time - rewind(21) - norew=norew+1 -! write(*,*)'Found functions: ',nofunent,' rewinding again',norew,gx%bmperr -! if(newfun.gt.0) then -! write(*,*)'Read ',newfun+nfail,' functions, entered ',newfun,& -! ' rewinding ',norew -! newfun=0 - nofunent=0 - goto 100 - else -! check if there are any unentered functions - call list_unentered_funs(kou,nr) - if(nr.gt.0) then - write(kou,*)'Number of missing function: ',nr - gx%bmperr=4186 - endif -! check if any function not entered - onlyfun=.FALSE. - endif rewind - goto 1000 -! end of file while looking for ! terminating a keyword -2200 continue - write(*,2210)nl,longline(1:72) -2210 format('End of file at ',i5,' looking for end of keyword:'/a) - gx%bmperr=7777 - goto 1000 - end subroutine readtdb - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine checktdb(filename,nel,selel) -! checking a TDB file exists and return the elements -!------------------------------------------------------- -! Not all TYPE_DEFS implemented -!------------------------------------------------------- - implicit none - integer nel - character filename*(*),selel(*)*2 -!\end{verbatim} - character line*256 - integer ipp,nl,kk -! - if(.not.(index(filename,'.tdb').gt.0 & - .or. index(filename,'.TDB').gt.0)) then -! no extention provided - filename(len_trim(filename)+1:)='.TDB' - endif - open(21,file=filename,access='sequential',form='formatted',& - err=1010,iostat=gx%bmperr,status='old') -! just check for ELEMENT keywords -! return here to look for a new keyword, end-of-file OK here - nl=0 - nel=0 -100 continue - read(21,110,end=2000)line -110 format(a) - nl=nl+1 -! One should remove TAB characters !! ?? - ipp=1 - if(eolch(line,ipp)) goto 100 - if(line(ipp:ipp).eq.'$') goto 100 -! look for ELEMENT keyword, ipp=1 - ipp=istdbkeyword(line,kk) - if(ipp.ne.1) goto 100 -! -! ignore /- and VA - if(line(kk+1:kk+2).eq.'/-' .or. line(kk+1:kk+2).eq.'VA') goto 100 - nel=nel+1 - selel(nel)=line(kk+1:kk+2) -! write(*,111)nl,line(1:20) -!111 format('Read line ',i5,': ',a) - goto 100 -!--------- -1000 continue - return -! error -1010 continue - goto 1000 -! end of file -2000 continue - close(21) - goto 1000 - return - end subroutine checktdb - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!-\begin{verbatim} - subroutine gtpsavetm(filename,str) -! save all data on file in a modified TDB format. Also as macro and LaTeX -! header -! element list -! species list -! phase list with sublattices, endmembers, interactions and parameters etc -! tpfuns -! state variable functions -! references -! - implicit none - character*(*) filename,str -!-\end{verbatim} - logical tdbmode - if(str(1:1).eq.'T') then -! TDB file - tdbmode=.true. - else -! MACRO mode - tdbmode=.false. - endif - write(*,*)'TDB and MACRO save not implemented yet' - goto 1000 -! unfinished .... -! open file and write (either as TDB, MACRO or LaTeX): -! header -! element list -! species list -! phase list with sublattices, endmembers, interactions and parameters etc -! tpfuns -! state variable functions -! references -! -! For inspiration look at the LIST subroutines in pmod25E.F90 -! -1000 continue - return - end subroutine gtpsavetm -! -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ -! - +! +! gtp3E included in gtp3.F90 +! +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ +!> 9. Save and read things from files +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine gtpsave(filename,str) +! save all data on file, unformatted, TDB or macro +! header +! element list +! species list +! phase list with sublattices, endmembers, interactions and parameters etc +! tpfuns +! state variable functions +! references +! + implicit none + character*(*) filename,str +!\end{verbatim} +! separate UNFORMATTED, DIRECT, TDB, MACRO or LaTeX + if(str(1:1).eq.'U') then + call gtpsaveu(filename,str(3:)) + elseif(str(1:1).eq.'D') then + call gtpsavedir(filename,str(3:)) + elseif(str(1:1).eq.'T') then + call gtpsavetdb(filename,str(3:)) + elseif(str(1:1).eq.'L') then + call gtpsavelatex(filename,str(3:)) + else + call gtpsavetm(filename,str) + endif +1000 continue + return + end subroutine gtpsave + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine gtpsavelatex(filename,specification) +! save all data on LaTeX format on a file (for publishing) +! header +! element list +! species list +! phase list with sublattices, endmembers, interactions and parameters etc +! tpfuns +! state variable functions +! references +! equilibrium record(s) with conditions, componenets, phase_varres records etc +! anything else? + implicit none + character*(*) filename,specification +!\end{verbatim} +1000 continue + return + end subroutine gtpsavelatex + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine gtpsavedir(filename,specification) +! save all data on a direct file (random access) +! header +! element list +! species list +! phase list with sublattices, endmembers, interactions and parameters etc +! tpfuns +! state variable functions +! references +! equilibrium record(s) with conditions, componenets, phase_varres records etc +! anything else? + implicit none + character*(*) filename,specification +!\end{verbatim} +1000 continue + return + end subroutine gtpsavedir + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine gtpsavetdb(filename,specification) +! save all data in TDB format on an file +! header +! element list +! species list +! phase list with sublattices, endmembers, interactions and parameters etc +! tpfuns +! state variable functions +! references +! equilibrium record(s) with conditions, componenets, phase_varres records etc +! anything else? + implicit none + character*(*) filename,specification +!\end{verbatim} +1000 continue + return + end subroutine gtpsavetdb + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine gtpsaveu(filename,specification) +! save all data unformatted on an file +! header +! element list +! species list +! phase list with sublattices, endmembers, interactions and parameters etc +! tpfuns +! state variable functions +! references +! equilibrium record(s) with conditions, componenets, phase_varres records etc +! anything else? + implicit none + character*(*) filename,specification +!\end{verbatim} +! + character id*40,comment*72,endoffile*16,mark*8 + integer i,isp,jph,kontroll,lokph,lut +! + if(index(filename,'.').eq.0) then + filename(len_trim(filename)+1:)='.ocu' + endif + lut=21 + open(lut,file=filename,access='sequential',status='unknown',& + form='unformatted',iostat=gx%bmperr,err=1000) + id='This is a save file for OC version: ' + comment=specification +! this control number will be written regularly on the file and checked on read + kontroll=175638 + mark=' MARK '//char(13)//char(10) +!>>>>> 1: write first some id, version etc. + write(lut)id,savefile,comment,globaldata + write(lut)noofel,noofsp,noofph,nooftuples + write(lut)1,kontroll,mark +!---------------------------------------------------------------------- +! note the use of gtp_xxx_version to handle versions +!---------------------------------------------------------------------- +! +! it is extremely important to keep the order of the records as they +! are linked using indices +! +!>>>>> 2: elementlist + if(ocv()) write(*,*)'Writing elements' + write(lut)gtp_element_version + do i=1,noofel + write(lut)ellista(i) + enddo +!----------- + write(lut)2,kontroll,mark +!>>>>> 3: specieslist + if(ocv()) write(*,*)'Writing species' + write(lut)gtp_species_version + do isp=1,noofsp + write(lut)splista(isp)%symbol,splista(isp)%mass,splista(isp)%charge + write(lut)splista(isp)%noofel,splista(isp)%status, & + splista(isp)%alphaindex + write(lut)(splista(isp)%ellinks(i),i=1,splista(isp)%noofel) + write(lut)(splista(isp)%stoichiometry(i),i=1,splista(isp)%noofel) + enddo + write(lut)3,kontroll,mark +!>>>>> 4: phaselist, start from 0 (reference phase) +! including sublattces, endmembers, interactions, properties etc +! save version of various records + if(ocv()) write(*,*)'Writing phases' + write(lut)gtp_phase_version,gtp_endmember_version,gtp_interaction_version,& + gtp_property_version + if(noofph.gt.0) then + do jph=0,noofph + lokph=phases(jph) + call savephase(lut,lokph) + if(gx%bmperr.ne.0) goto 1000 + if(ocv()) write(*,*)'Saved phase: ',jph + enddo + endif + write(lut)(phasetuple(i),i=1,nooftuples) + write(lut)4,kontroll,mark +!------------- tpfuns +!>>>>> 20: tpfuns + if(ocv()) write(*,*)'Writing tpfuns' + call tpfunsave(lut,.FALSE.) + write(lut)5,kontroll,mark +!------------- state variable functions +!>>>>> 30: svfuns + if(ocv()) write(*,*)'Writing state variable functions' + call svfunsave(lut,firsteq) + write(lut)6,kontroll,mark +! write(*,*)'Writing mark: ',6,kontroll,mark +!------------- references +!>>>>> 40: bibliographic references + if(ocv()) write(*,*)'Writing references' + call bibliosave(lut) + write(lut)7,kontroll,mark +!------------------------------------------------------- +! write the equilibrium records, at present for FIRSTEQ only +! conditions, components, phase_varres for all composition sets etc +!>>>>> 50: equilibria + if(ocv()) write(*,*)'Writing equilibria' + write(lut)gtp_equilibrium_data_version,gtp_component_version,& + gtp_phase_varres_version + call saveequil(lut,firsteq) + write(lut)8,kontroll,mark +!------------------------------------------------------- + endoffile='- END OF DATA - ' + write(lut)endoffile +900 continue + close(lut) +1000 continue + return + end subroutine gtpsaveu + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine savephase(lut,lokph) +! save data for phase at location lokph (except data in the equilibrium record) +! For phases with disordered set of parameters we must access the number of +! sublattices via firsteq + implicit none + integer lut,lokph +!\end{verbatim} + integer doneord,i,j,level,lokcs,nem,noi,nop,nox,nsl,nup,noendm,fipsize + type(gtp_endmember), pointer :: emrec + type(gtp_interaction), pointer :: intrec + type(gtp_property), pointer :: proprec +! to keep track of interaction records + type saveint + type(gtp_interaction), pointer :: p1 + end type saveint + type(saveint), dimension(:), pointer :: stack + type(gtp_phase_add), pointer :: addlink + if(ocv()) write(*,*)'In savephase' + allocate(stack(5)) +!>>>>> 5: phase header + write(lut)lokph,phlista(lokph)%name,& + phlista(lokph)%models,phlista(lokph)%phletter,& + phlista(lokph)%status1,& + phlista(lokph)%alphaindex,phlista(lokph)%noofcs,phlista(lokph)%nooffs + nsl=phlista(lokph)%noofsubl + emrec=>phlista(lokph)%ordered + if(.not.associated(emrec)) then + noendm=0 + else + noendm=1 + endif +!>>>>> 6: sublattice info + j=phlista(lokph)%tnooffr + if(ocv()) write(*,10)j,lokph,size(phlista(lokph)%constitlist) +10 format('3E: ',3i20) + if(ocv()) write(*,11)(phlista(lokph)%constitlist(i),i=1,j) +11 format('3E: ',20i3) + write(lut)nsl,phlista(lokph)%linktocs,phlista(lokph)%tnooffr + write(lut)(phlista(lokph)%nooffr(i),i=1,nsl),& + (phlista(lokph)%constitlist(i),i=1,j),noendm +!--------- endmember list, interaction tree and property records +! save all parameter data starting from the endmember list + doneord=0 + if(ocv()) write(*,*)'listing endmembers',doneord,nsl,noendm +! there can be phases without any ordered parameters ... + if(.not.associated(emrec)) goto 400 +! we come back here if there are disordered parameters +200 continue +! if doneord=1 then we have listed the ordered parameters + if(doneord.eq.1) then + emrec=>phlista(lokph)%disordered + if(ocv()) write(*,*)'Saving disordered parameters' + endif + if(ocv()) write(*,*)'any endmember: ',doneord + emlista: do while(associated(emrec)) + proprec=>emrec%propointer + intrec=>emrec%intpointer + nop=0 + noi=0 + nem=0 + if(associated(proprec)) nop=1 + if(associated(intrec)) noi=1 + if(associated(emrec%nextem)) nem=1 + if(ocv()) write(*,55)'writing endmember: ',nsl,emrec%noofpermut,& + emrec%phaselink,emrec%antalem,nop,noi,nem +55 format(a,7i5) +!>>>>> 7: endmember record (basic or disordered) + write(lut)emrec%noofpermut,emrec%phaselink,emrec%antalem,nop,noi,nem + do j=1,emrec%noofpermut + write(lut)(emrec%fraclinks(i,j),i=1,nsl) + enddo + emproplista: do while(associated(proprec)) + nox=0 + if(associated(proprec%nextpr)) nox=1 +!>>>>> 8: endmember property record (loop) + write(lut)proprec%reference,proprec%proptype,& + proprec%degree,proprec%extra,proprec%antalprop,nox + do i=0,proprec%degree + call save1tpfun(lut,.FALSE.,proprec%degreelink(i)) + enddo + proprec=>proprec%nextpr + enddo emproplista +! interaction tree + level=0 +300 continue + intlista: do while(associated(intrec)) +! noi is next, nup is higher, nop is property + noi=0 + nup=0 + nop=0 + if(associated(intrec%nextlink)) noi=1 + if(associated(intrec%highlink)) nup=1 + if(associated(intrec%propointer)) nop=1 +310 continue +!>>>>> 9: interaction record +! look in gtp3H, create_interaction for use of intec%noofip + fipsize=size(intrec%noofip) + write(lut)fipsize + write(lut)intrec%noofip,intrec%status,noi,nup,nop + do i=1,intrec%noofip(2) + write(lut)intrec%sublattice(i),intrec%fraclink(i) + enddo +! interaction property + proprec=>intrec%propointer + intproplista: do while(associated(proprec)) + nox=0 + if(associated(proprec%nextpr)) nox=1 +!>>>>> 10: interaction property record (loop) + write(lut)proprec%reference,proprec%proptype,& + proprec%degree,proprec%extra,proprec%antalprop,nox + do i=0,proprec%degree + call save1tpfun(lut,.FALSE.,proprec%degreelink(i)) + enddo + proprec=>proprec%nextpr + enddo intproplista +! take link to higher higher interaction + level=level+1 + if(level.gt.5) then +! write(*,*)'Too many interaction levels' + gx%bmperr=4164; goto 1000 + endif + stack(level)%p1=>intrec + intrec=>intrec%highlink + enddo intlista +! pop previous intrec and take link to next interaction + if(level.gt.0) then + intrec=>stack(level)%p1 + intrec=>intrec%nextlink + level=level-1 + goto 300 + endif +!---- next endmember + emrec=>emrec%nextem + enddo emlista +! no more endmembers, check if the disordered (if any) has been written +400 continue + if(doneord.eq.0) then + if(ocv()) write(*,*)'any disordered endmembers?' + if(associated(phlista(lokph)%disordered)) then +! there are some disordered parameters +! the disfra record is written in saveequil?? +! we have to change nsl ...three % vojvoj + doneord=1 + lokcs=phlista(lokph)%linktocs(1) + nsl=firsteq%phase_varres(lokcs)%disfra%ndd +!>>>>> 11A: write disordered endmemebers + write(lut)2,nsl +! emrec should already be null but for security .... + nullify(emrec) + goto 200 + else +! we must mark that there are no disordered parameters +!>>>>> 11B: no moe endmemebers + write(lut)0,0 + endif + endif +!------ additions list +500 continue + addlink=>phlista(lokph)%additions + addition: do while(associated(addlink)) + if(addlink%type.eq.1) then +!>>>>> 12A: additions id + write(lut)addlink%type,addlink%addrecno,addlink%aff + else + write(*,*)'Not saving unknown addition record type ',addlink%type + endif + addlink=>addlink%nextadd + enddo addition +!>>>>> 12B: mark end of data for phase + write(lut)-1,-1,-1 +1000 continue + return + end subroutine savephase + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine saveequil(lut,ceq) +! save data for an equilibrium record + implicit none + integer lut + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + character text*512 + type(gtp_phase_varres), pointer :: firstvarres + TYPE(gtp_fraction_set), pointer :: fslink +! TYPE(gtp_condition), pointer :: condrec + integer i,isp,j,k,kl,lokcs,lokph,mc,mc2,nsl +!>>>>> 50: + write(lut)ceq%eqname,ceq%eqno,ceq%status,ceq%next +! ignore svfunres and eq_tpres +!---- components +!>>>>> 51: + do i=1,noofel + isp=ceq%complist(i)%splink + write(lut)isp + write(lut)ceq%complist(i)%phlink,ceq%complist(i)%status,& + ceq%complist(i)%refstate,ceq%complist(i)%tpref,& + ceq%complist(i)%mass + enddo + do i=1,noofel + if(ocv()) write(*,99)'comp.matrix: ',(ceq%invcompstoi(j,i),j=1,noofel) + enddo +99 format(a,7e11.3) + do i=1,noofel + write(lut)(ceq%compstoi(j,i),j=1,noofel) + enddo +!---- varres records, one for each composition set +!>>>>> 54: + write(lut)highcs + compset: do j=1,highcs-1 +! loop for all composition sets + firstvarres=>ceq%phase_varres(j) + if(btest(firstvarres%status2,CSDFS)) then +! this phase_varres/parres records belong to disordered fraction_set +! A big tricky to find the number of sublattices and constituents .... + lokph=firstvarres%phlink + lokcs=phlista(lokph)%linktocs(1) + nsl=ceq%phase_varres(lokcs)%disfra%ndd + mc=ceq%phase_varres(lokcs)%disfra%tnoofxfr + else + lokph=0; lokcs=0 + nsl=phlista(firstvarres%phlink)%noofsubl + mc=phlista(firstvarres%phlink)%tnooffr + endif + mc2=mc*(mc+1)/2 +!>>>>> 55: + write(lut)firstvarres%nextfree,firstvarres%phlink,& + firstvarres%status2,firstvarres%phstate + write(lut)firstvarres%prefix,firstvarres%suffix + write(lut)firstvarres%abnorm +!>>>>> 56: + write(lut)(firstvarres%constat(i),i=1,mc) + write(lut)(firstvarres%yfr(i),i=1,mc) + write(lut)(firstvarres%mmyfr(i),i=1,mc) + write(lut)(firstvarres%sites(i),i=1,nsl) +! We do not save the cmuval array +! These should only be interesting for ionic liquids and in that case +! only the dimension, not the values +! write(lut)(firstvarres%dsitesdy(i),i=1,mc) +! write(lut)(firstvarres%d2sitesdy2(i),i=1,mc2) + lokph=firstvarres%phlink + fsrec: if(btest(firstvarres%status2,CSDLNK)) then +! we must indicate on the file a disordered fraction_set record follows! + fslink=>firstvarres%disfra + if(ocv()) write(*,*)'Disordered fraction set linked from: ',& + j,fslink%varreslink +!>>>>> 57A: write disordered record, is is inside the phase_varres record + write(lut)1 +!>>>>> 58: + write(lut)fslink%latd,fslink%ndd,fslink%tnoofxfr,& + fslink%tnoofyfr,fslink%totdis,fslink%varreslink,fslink%id + write(lut)fslink%nooffr,fslink%splink + write(lut)fslink%dsites + write(lut)fslink%y2x + write(lut)fslink%dxidyj + else +! no disordered fraction set record +!>>>>> 57B: + write(lut)0 + endif fsrec +!>>>>> 59: + write(lut)firstvarres%amfu,firstvarres%netcharge,firstvarres%dgm,& + firstvarres%nprop +! only G values saved ???? well maybe not even those ... +!>>>>> 60: + write(lut)(firstvarres%gval(i,1),i=1,6) + do k=1,mc + write(lut)(firstvarres%dgval(i,k,1),i=1,3) + enddo +!>>>>> 61: + write(lut)(firstvarres%d2gval(i,1),i=1,mc2) + enddo compset +!---- conditions, write as text and recreate when reading file + call get_all_conditions(text,0,ceq) + if(gx%bmperr.ne.0) goto 1000 + kl=index(text,'CRLF') +!>>>>> 62: + write(lut)kl-1 + if(kl.gt.1) then + write(lut)' SET CONDITIONS ',text(1:kl-1) + endif +!---- experiments + call get_all_conditions(text,1,ceq) + if(gx%bmperr.ne.0) goto 1000 + kl=len_trim(text) +!>>>>> 63: + write(lut)kl-1 + if(kl.gt.1) then + write(lut)' EXPERIMENTS ',text(1:kl-1) + endif +!>>>>>> 64: savesysmat +! NOTE:: ceq%sysmatdim negative, not initiallized?? +! NOTE:: phasetuples not saved !!! + write(lut)ceq%sysmatdim,ceq%nfixmu,ceq%nfixph + if(ceq%nfixmu.gt.0) write(lut)(ceq%fixmu(kl),kl=1,ceq%nfixmu) + if(ceq%nfixph.gt.0) write(lut)& + (ceq%fixph(1,kl),ceq%fixph(2,kl),kl=1,ceq%nfixph) + if(ceq%sysmatdim.gt.0) then + do mc=1,ceq%sysmatdim + write(lut)(ceq%savesysmat(mc,kl),kl=1,ceq%sysmatdim) + enddo + endif +1000 continue + return + end subroutine saveequil + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine svfunsave(lut,ceq) +! saves all state variable functions on a file + implicit none + integer lut + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + character text*512,symbols(20)*32,afterdot*32 + integer ip,ipos,istv,js,jt,kl,ks,lrot + type(gtp_state_variable), pointer :: svrrec + write(lut)nsvfun + do lrot=1,nsvfun + ipos=1 + if(svflista(lrot)%narg.eq.0) goto 500 + js=0 + jt=0 +100 continue + jt=jt+1 + js=js+1 + ip=1 + symbols(js)=' ' + istv=svflista(lrot)%formal_arguments(1,jt) + if(istv.lt.0) then +! function refer to another function + symbols(js)=svflista(-istv)%name + else +! the 1:10 was a new bug discovered in GNU fortran 4.7 and later + call make_stvrec(svrrec,svflista(lrot)%formal_arguments(1:10,jt)) +! do ii=1,4 +! indices(ii)=svflista(lrot)%formal_arguments(1+ii,jt) +! enddo +! call encode_state_variable2(symbols(js),ip,istv,indices,& +! svflista(lrot)%formal_arguments(6,jt), & +! svflista(lrot)%formal_arguments(7,jt),ceq) + call encode_state_variable(symbols(js),ip,svrrec,ceq) + if(svflista(lrot)%formal_arguments(10,jt).ne.0) then +! a derivative!!! + jt=jt+1 + afterdot=' ' + ip=1 + write(*,*)'What? Derivatives not implemented' +! call encode_state_variable2(afterdot,ip,& +! svflista(lrot)%formal_arguments(1,jt),indices,& +! svflista(lrot)%formal_arguments(6,jt), & +! svflista(lrot)%formal_arguments(7,jt),ceq) +! symbols(js)=symbols(js)(1:len_trim(symbols(js)))//'.'//afterdot + endif + endif + if(jt.lt.svflista(lrot)%narg) goto 100 +500 continue + kl=len_trim(svflista(lrot)%name) + text(ipos:ipos+kl+1)=svflista(lrot)%name(1:kl)//'= ' + ipos=ipos+kl+2 + call wrtfun(text,ipos,svflista(lrot)%linkpnode,symbols) + if(pfnerr.ne.0) then + write(kou,*)'Putfun error listing funtion ',ks,pfnerr + gx%bmperr=4142; goto 1000 + endif + write(lut)ipos-1 + write(lut)text(1:ipos-1) + enddo +1000 continue + return + end subroutine svfunsave + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine bibliosave(lut) +! saves references on a file + implicit none + integer lut +!\end{verbatim} + character longline*2048 + integer ir,jp,ll,nl +!>>>>> 40: +! write(*,*)'Saving reference version and number of:',& +! gtp_biblioref_version,reffree-1 + write(lut)gtp_biblioref_version,reffree-1 + do ir=1,reffree-1 + longline=bibrefs(ir)%reference + jp=17 + nl=size(bibrefs(ir)%refspec) + do ll=1,nl + longline(jp:)=bibrefs(ir)%refspec(ll) + jp=jp+64 + enddo + jp=len_trim(longline) +!>>>>> 41: + write(lut)jp +!>>>>> 42: + write(lut)longline(1:jp) + enddo +1000 continue + return + end subroutine bibliosave + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine gtpread(filename,str) +! read unformatted all data in the following order +! header +! element list +! species list +! phase list with sublattices, endmembers, interactions and parameters etc +! tpfuns +! state variable functions +! references +! equilibrium record(s) with conditions, componenets, phase_varres records etc +! + implicit none + character*(*) filename,str +!\end{verbatim} + character id*40,endoffile*16,version*8,comment*72,mark*8 + integer i,i1,i2,i3,isp,jph,kontroll,nel,ivers,lin +10 format(i8) + if(index(filename,'.').eq.0) then + filename(len_trim(filename)+1:)='.ocu' + endif + kontroll=175638 + lin=21 + open(lin,file=filename,access='sequential',status='old',& + form='unformatted',iostat=gx%bmperr,err=1100) + if(ocv()) write(*,*)'Opening file: ',filename(1:len_trim(filename)),& + ' for unformatted read' +!>>>>> 1: read some identification etc, SAVE VERBOSE option! + if(ocv()) then + i1=1 + else + i1=0 + endif + read(lin)id,version,comment,globaldata + if(i1.eq.1) then + globaldata%status=ibset(globaldata%status,GSVERBOSE) + endif + if(version.ne.savefile) then + write(*,11)id,version,savefile +11 format('File not same version as program: ',A/a,' : ',a) + gx%bmperr=2901; goto 1000 + endif +! write(*,*)'comment: ',comment(1:len_trim(comment)) + str=comment + read(lin)noofel,noofsp,noofph,nooftuples + if(ocv()) write(*,*)'4 numbers: ',noofel,noofsp,noofph,nooftuples +!------- + read(lin)i1,i2,mark + if(i1.ne.1 .and. i2.ne.kontroll) then + write(*,*)'Read error at control 1' + gx%bmperr=4165; goto 1000 + elseif(ocv()) then + write(*,*)'Control 1 OK' + endif +!>>>>> 2: elementlist + read(lin)ivers + if(ivers.ne.gtp_element_version) then + write(*,17)'Element',ivers,gtp_element_version +17 format(a,' record version error: ',2i4) + gx%bmperr=7777; goto 1000 + endif + do i=1,noofel + read(lin)ellista(i) + enddo + do i=1,noofel + elements(ellista(i)%alphaindex)=i + enddo + if(ocv()) write(*,19)(ellista(i)%alphaindex,i=1,noofel) +19 format('Ellista: ',100i3) +!------- + read(lin)i1,i2,mark + if(i1.ne.2 .and. i2.ne.kontroll) then + write(*,*)'Read error at control 2' + gx%bmperr=4165; goto 1000 + elseif(ocv()) then + write(*,*)'Control 2 OK' + endif +!>>>>> 3: specieslist + read(lin)ivers + if(ivers.ne.gtp_species_version) then + write(*,17)'Species',ivers,gtp_species_version + gx%bmperr=7777; goto 1000 + endif + do isp=1,noofsp + read(lin)splista(isp)%symbol,splista(isp)%mass,splista(isp)%charge + read(lin)splista(isp)%noofel,splista(isp)%status, & + splista(isp)%alphaindex + if(isp.gt.1) then + nel=splista(isp)%noofel + allocate(splista(isp)%ellinks(nel)) + allocate(splista(isp)%stoichiometry(nel)) + endif + read(lin)(splista(isp)%ellinks(i),i=1,splista(isp)%noofel) + read(lin)(splista(isp)%stoichiometry(i),i=1,splista(isp)%noofel) + enddo + do i=1,noofsp + species(splista(i)%alphaindex)=i + enddo +! write(*,22)(splista(i)%alphaindex,i=1,noofsp) +!22 format('3E splista: ',20i3) +!------- + read(lin)i1,i2,mark + if(i1.ne.3 .and. i2.ne.kontroll) then + write(*,*)'Read error at control 3' + gx%bmperr=4165; goto 1000 + elseif(ocv()) then + write(*,*)'Control 3 OK' + endif +!>>>>> 5: phaselist, starting from 0, the reference phase + read(lin)ivers,i1,i2,i3 + if(ivers.ne.gtp_phase_version) then + write(*,17)'Phase',ivers,gtp_phase_version + gx%bmperr=7777; goto 1000 + endif + if(i1.ne.gtp_endmember_version) then + write(*,17)'Endmember',i1,gtp_endmember_version + gx%bmperr=7777; goto 1000 + endif + if(i2.ne.gtp_interaction_version) then + write(*,17)'Interaction',i2,gtp_interaction_version + gx%bmperr=7777; goto 1000 + endif + if(i3.ne.gtp_property_version) then + write(*,17)'Property',i3,gtp_property_version + gx%bmperr=7777; goto 1000 + endif + noofem=0 + noofint=0 + noofprop=0 + if(noofph.gt.0) then + do jph=0,noofph +!>>>>> 5..12 inside readphase + call readphase(lin,jph) + if(gx%bmperr.ne.0) goto 1000 + if(ocv()) write(*,*)'Done reading phase: ',jph,' out of: ',noofph + enddo + do i=1,noofph + phases(phlista(i)%alphaindex)=i + enddo + endif + read(lin)(phasetuple(i),i=1,nooftuples) +!-------- + read(lin)i1,i2,mark + if(i1.ne.4 .and. i2.ne.kontroll) then + write(*,*)'Read error at control 4' + gx%bmperr=4165; goto 1000 + elseif(ocv()) then + write(*,*)'Control 4 OK' + endif +!---------- tpfuns +!>>>>> 20.. inside tpfunread, skip functions already read + call tpfunread(lin,.TRUE.) +! write(*,*)'return with error code: ',gx%bmperr + if(gx%bmperr.ne.0) then +! many functions already entered when reading parameters + write(*,*)'Error reading TP functiona: ',gx%bmperr + goto 1000 + endif +!-------- + read(lin)i1,i2,mark + if(i1.ne.5 .and. i2.ne.kontroll) then + write(*,*)'Read error at control 5' + gx%bmperr=4165; goto 1000 + elseif(ocv()) then + write(*,*)'read TPFUNS OK' + endif +!---------- state variable functions +!>>>>> 30... inside svfunread + call svfunread(lin) + if(gx%bmperr.ne.0) goto 1000 +!-------- + read(lin)i1,i2,mark + if(i1.ne.6 .and. i2.ne.kontroll) then + write(*,*)'Read error at control 6' + gx%bmperr=4165; goto 1000 + elseif(ocv()) then + write(*,*)'read state variable functions OK at mark ',i1,i2,mark + endif +!---------- bibliographic references +!>>>>> 40.. inside refread + call biblioread(lin) + if(gx%bmperr.ne.0) goto 1000 +!-------- + read(lin)i1,i2,mark + if(i1.ne.7 .and. i2.ne.kontroll) then + write(*,*)'Read error at control 7' + gx%bmperr=4165; goto 1000 + elseif(ocv()) then + write(*,*)'read references OK' + endif +!---------- equilibrium record +!>>>>> 50.. inside readequil + read(lin)i1,i2,i3 + if(i1.ne.gtp_equilibrium_data_version) then + write(*,*)'Wrong version of equilibrium data record: ',i1,& + gtp_equilibrium_data_version + gx%bmperr=7777; goto 1000 + endif + if(i2.ne.gtp_component_version) then + write(*,*)'Wrong version of component record: ',i2,& + gtp_component_version + gx%bmperr=7777; goto 1000 + endif + if(i3.ne.gtp_phase_varres_version) then + write(*,*)'Wrong version of phase_varres record: ',i3,& + gtp_phase_varres_version + gx%bmperr=7777; goto 1000 + endif + call readequil(lin,firsteq) + if(gx%bmperr.ne.0) goto 900 +! if(gx%bmperr.ne.0) goto 1000 +!-------- + read(lin)i1,i2,mark + if(i1.ne.8 .and. i2.ne.kontroll) then + write(*,*)'Read error at control 8' + gx%bmperr=4165; goto 1000 + elseif(ocv()) then + write(*,*)'read equilibrium records OK' + endif +!------ read all ?? + endoffile=' ' + read(lin,end=800,err=800)endoffile +800 continue + if(endoffile.ne.'- END OF DATA - ') then + write(kou,811)endoffile +811 format('Unexpected end of file mark: '/'>',A,'<') + gx%bmperr=4166; goto 1000 + elseif(ocv()) then + write(kou,812)endoffile +812 format('Expected end of file mark found: '/'>',A,'<') + endif +! emergency exit +900 continue + close(lin) +! +1000 continue + return +! error opening files +1100 continue + write(*,1110)gx%bmperr,filename(1:len_trim(filename)) +1110 format('I/O error: ',i5,', opening file; ',a) + goto 1000 + end subroutine gtpread + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine readphase(lin,jdum) +! read data for phlista and all endmembers etc +! works for test case without disordered fraction test + implicit none + integer lin,jdum +!\end{verbatim} + integer firstendmem,i,i1,i2,i3,jph,level,nem,noi,nop,nox,nup,nsl,mult + type(gtp_endmember), pointer :: emrec + type(gtp_interaction), pointer :: intrec + type(gtp_property), pointer :: proprec + type saveint + type(gtp_interaction), pointer :: p1 + integer noi + end type saveint + type(saveint), dimension(:), pointer :: stack + type(gtp_phase_add), pointer :: addlink +! + allocate(stack(5)) + if(ocv()) write(*,*)'in readphase:' +! as the phlista record contain pointers each item must be read separately +!>>>>> 5: phase header + read(lin)jph,phlista(jph)%name,& + phlista(jph)%models,phlista(jph)%phletter,phlista(jph)%status1,& + phlista(jph)%alphaindex,phlista(jph)%noofcs,phlista(jph)%nooffs +!>>>>> 6: sublattice info + read(lin)phlista(jph)%noofsubl,phlista(jph)%linktocs,phlista(jph)%tnooffr + nsl=phlista(jph)%noofsubl + allocate(phlista(jph)%nooffr(nsl)) + allocate(phlista(jph)%constitlist(phlista(jph)%tnooffr)) + read(lin)(phlista(jph)%nooffr(i),i=1,nsl),& + (phlista(jph)%constitlist(i),i=1,phlista(jph)%tnooffr),nem +!------ endmember records, these must be allocated and linked now + nullify(phlista(jph)%ordered) + nullify(phlista(jph)%disordered) + nullify(emrec) + if(associated(emrec)) then + write(*,*)'nullify does not work' + stop + endif + if(ocv()) write(*,*)'read endmember data',nsl,nem +! if nem=0 now there are no basic (ordered) endmember (can that happen?) +! return here when endmember list empty and there is a disordered list + firstendmem=1 +200 continue + if(ocv()) write(*,202)'reading parameters: ',phlista(jph)%name,& + nsl,firstendmem,nem +202 format(a,a,10i4) +! newendmem: do while(nem.eq.1) + newendmem: do while(nem.gt.0) + if(associated(emrec)) then +!>>>>> 7C: the second or later endmember in the same list + call readendmem(lin,nsl,emrec%nextem,nop,noi,nem) + emrec=>emrec%nextem + elseif(firstendmem.eq.1) then +!>>>>> 7A: the first (only or ordered) endmember + call readendmem(lin,nsl,phlista(jph)%ordered,nop,noi,nem) + emrec=>phlista(jph)%ordered + elseif(firstendmem.eq.2) then +!>>>>> 7B: the first disordered endmember + if(ocv()) write(*,*)'Reading isordered parameter list' + call readendmem(lin,nsl,phlista(jph)%disordered,nop,noi,nem) + emrec=>phlista(jph)%disordered + firstendmem=0 + endif + if(nop.eq.1) then +!>>>>> 8A: endmember property (lookp) + call readproprec(lin,emrec%propointer,nox) + proprec=>emrec%propointer + do while(nox.eq.1) + call readproprec(lin,proprec%nextpr,nox) + proprec=>proprec%nextpr + enddo + endif + inttree: if(noi.eq.1) then +!>>>>> 9A: interaction record + level=0 + call readintrec(lin,emrec%intpointer,mult,noi,nup,nop) + intrec=>emrec%intpointer + if(ocv()) write(*,13)'read interaction: ',intrec%status,noi,nup,nop +13 format(a,10i4) +300 continue + if(nop.eq.1) then +!>>>>> 10A: interaction property record + call readproprec(lin,intrec%propointer,nox) + proprec=>intrec%propointer + do while(nox.eq.1) + call readproprec(lin,proprec%nextpr,nox) + proprec=>proprec%nextpr + enddo + endif +! push before going to higher +330 continue + level=level+1 + stack(level)%p1=>intrec + stack(level)%noi=noi + if(ocv()) write(*,13)'pushed interaction: ',intrec%status,0,0,0,level + higher: if(nup.eq.1) then +!>>>>> 9B: go to higher level and save intrec + call readintrec(lin,intrec%highlink,mult,noi,nup,nop) + intrec=>intrec%highlink +! write(*,13)'read higher interaction: ',intrec%status,noi,nup,nop + if(nop.eq.1) then +!>>>>> 10B: there are some property records !! + call readproprec(lin,intrec%propointer,nox) + proprec=>intrec%propointer + do while(nox.eq.1) + call readproprec(lin,proprec%nextpr,nox) + proprec=>proprec%nextpr + enddo + endif + goto 330 + endif higher +! we come here when no higher records, pop records from stack +350 continue + pop: if(level.gt.0) then + intrec=>stack(level)%p1 + noi=stack(level)%noi + level=level-1 + if(ocv())write(*,13)'poped interaction: ',intrec%status,0,0,0,level + if(noi.eq.1) then +!>>>>> 9C: + call readintrec(lin,intrec%nextlink,mult,noi,nup,nop) + intrec=>intrec%nextlink + if(ocv()) write(*,13)'read interaction: ',intrec%status,& + noi,nup,nop + goto 300 + else + goto 350 + endif + endif pop + endif inttree + enddo newendmem +! we come nere when no more endmembers in this list + if(firstendmem.eq.1) then +!>>>>> 11: if nem read here is zero there are no disordered endmembers + if(ocv()) write(*,*)'checking for disordered endmembers' + read(lin)nem,nsl +! we must nullify emrec to start a new list of endmembers + nullify(emrec) + if(nem.ne.0) then + firstendmem=2 + if(ocv()) write(*,*)'Reading disordered parameters',nem,nsl + goto 200 + endif + endif +!------ additions list +!500 continue + nullify(phlista(jph)%additions) +510 continue + read(lin)i1,i2,i3 + if(ocv()) write(*,*)'Reading any addition; ',i1 + if(i1.eq.1) then +! here addition record should be created but as I have not managed to +! save the functions I just skip this for the moment and use create_magrec + call create_magrec_inden(addlink,i3) + if(gx%bmperr.ne.0) goto 1000 + if(.not.associated(phlista(jph)%additions)) then + phlista(jph)%additions=>addlink + else + addlink%nextadd=>addlink + addlink=>addlink%nextadd + endif + goto 510 + elseif(i1.eq.-1) then +! end of addition list + continue + if(i2.ne.i1 .and. i3.ne.i1) write(*,*)'end of phase error:',i2,i3 + endif +1000 continue + return + end subroutine readphase + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine readendmem(lin,nsl,emrec,nop,noi,nem) +! allocates and reads an endmember record + implicit none + integer lin,nsl,nop,noi,nem + type(gtp_endmember), pointer :: emrec +!\end{verbatim} + integer i,j + allocate(emrec) +! write(*,*)'Going to read endmember record' +!>>>>> 7D: actually reading .... + read(lin)emrec%noofpermut,emrec%phaselink,emrec%antalem,nop,noi,nem + if(ocv()) write(*,17)'readendmem: ',nsl,emrec%noofpermut,emrec%phaselink,& + emrec%antalem,nop,noi,nem +17 format(a,7i5) + allocate(emrec%fraclinks(nsl,emrec%noofpermut)) + do j=1,emrec%noofpermut + read(lin)(emrec%fraclinks(i,j),i=1,nsl) + enddo + nullify(emrec%nextem) + nullify(emrec%propointer) + nullify(emrec%intpointer) + noofem=noofem+1 + return + end subroutine readendmem + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine readproprec(lin,proprec,nox) +! allocates and reads a property record + implicit none + integer lin,nox + type(gtp_property), pointer :: proprec +!\end{verbatim} + integer i + allocate(proprec) +!>>>>> 8B: actually reading property record (endmember) +!>>>>> 10B: actually reading property record (interaction) +! write(*,*)'Going to read property record' + read(lin)proprec%reference,proprec%proptype,& + proprec%degree,proprec%extra,proprec%antalprop,nox + allocate(proprec%degreelink(0:proprec%degree)) + if(ocv()) write(*,17)'readprop: ',proprec%proptype,proprec%degree,& + proprec%antalprop,nox +17 format(a,6i5) +! write(*,*)'To read TP functions: ',proprec%degree,proprec%degreelink(0) + do i=0,proprec%degree + call read1tpfun(21,proprec%degreelink(i)) + enddo + if(ocv()) write(*,*)'Read TP functions: ',proprec%degree,& + proprec%degreelink(0) + nullify(proprec%nextpr) + noofprop=noofprop+1 + return + end subroutine readproprec + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine readintrec(lin,intrec,mult,noi,nup,nop) +! allocates and reads an interaction record UNFINISHED + implicit none + integer lin,mult,noi,nup,nop + type(gtp_interaction), pointer :: intrec +!\end{verbatim} + integer fipsize,noofperm,i +! the storage of permutations in interaction records is complex ... one must +! take into account the number of permutations in lower order intecations ... +! for an fcc endmember A:A:A:B (4 perm) the binary interaction A:A:A,B:B has +! 3; 3; 3 and 3 perms and the ternary A:A,B:A,B:B has 2; 2; 2; 2 +! mult may not be needed ... + allocate(intrec) +!>>>>> 9D: actually read the interaction record + read(lin)fipsize + allocate(intrec%noofip(fipsize)) + read(lin)intrec%noofip,intrec%status,noi,nup,nop +! write(*,17)'3E readint: ',fipsize,intrec%status,noi,nup,nop,& +! (intrec%noofip,i=1,fipsize) +17 format(a,5i4,2x,10i3) + noofperm=intrec%noofip(2) + allocate(intrec%sublattice(noofperm)) + allocate(intrec%fraclink(noofperm)) + do i=1,intrec%noofip(1) + read(lin)intrec%sublattice(i),intrec%fraclink(i) + enddo + nullify(intrec%nextlink) + nullify(intrec%highlink) + nullify(intrec%propointer) + return + end subroutine readintrec + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine readequil(lin,ceq) +! Read equilibria records from a file + implicit none + integer lin + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + character text*512,dum16*16 + type(gtp_phase_varres), pointer :: firstvarres + TYPE(gtp_fraction_set) :: fslink + integer i,ierr,ip,isp,ivar,j,jp,k,lokcs,lokph,mc,mc2,nprop,nsl,kp + double precision, dimension(:,:), allocatable :: ca,ci +! containing conditions, components and phase varres records for wach compset +!>>>>> 50: + read(lin)ceq%eqname,ceq%eqno,ceq%status,ceq%next + if(ocv()) write(*,*)'Reading equilibrium: ',ceq%eqname +!----- components +! allocate(ceq%complist(noofel)) already allocated for 20 +! write(*,*)'Size of component array: ',size(ceq%complist) +!>>>>> 51: + do i=1,noofel + read(lin)isp + ceq%complist(i)%splink=isp + read(lin)ceq%complist(i)%phlink,& + ceq%complist(i)%status,& + ceq%complist(i)%refstate,ceq%complist(i)%tpref,ceq%complist(1)%mass +! ============ never written ??? +! if(isp.gt.0) then +! user defined reference state only allocated if necessary +! read(lin)j +! allocate(ceq%complist(i)%endmember(j)) +! read(lin)ceq%complist(i)%endmember +! read(lin)ceq%complist(i)%molat +! endif + enddo +!================================== +! stoichiometry conversion matrix, already allocated?? where?? + ceq%compstoi=zero +! calculate the inverse stoichiometry matrix +! write(*,*)'Reading component stoichiometry matrix',noofel,maxel + do j=1,noofel + read(lin)(ceq%compstoi(j,i),i=1,noofel) + enddo + ! this because mdinv did strange things inverting a larger matrix + allocate(ca(noofel,noofel+1)) + allocate(ci(noofel,noofel)) + do i=1,noofel + do j=1,noofel + ca(i,j)=ceq%compstoi(i,j) + enddo + enddo +! do j=1,noofel +! write(*,99)'ca: ',(ca(j,i),i=1,noofel) +! enddo +99 format(a,7e11.3) +! call mdinv(maxel-1,maxel,ceq%compstoi,ceq%invcompstoi,noofel,ierr) + call mdinv(noofel,noofel+1,ca,ci,noofel,ierr) +! write(*,*)'Inverting matrix',ierr + do j=1,noofel +! write(*,99)'ci: ',(ci(i,j),i=1,noofel) + do i=1,noofel + ceq%invcompstoi(i,j)=ci(i,j) + enddo + enddo + deallocate(ca) + deallocate(ci) +!----------- phase_varres record +!>>>>> 54: + read(lin)highcs + if(ocv()) then + write(*,*)'Number of phase_varres records: ',highcs-1 + write(*,*)'phase_varres size: ',size(ceq%phase_varres) + endif + do j=1,highcs-1 +! write(*,*)'reading phase_varres ',j +!------------------------------------------ +! DEBUGPROBLEM BEWARE, using = instead of => below took 2 days to find +!------------------------------------------ +! >>> firstvarres=ceq%phase_varres(j) <<< error + firstvarres=>ceq%phase_varres(j) +!>>>>> 55: + read(lin)firstvarres%nextfree,firstvarres%phlink,& + firstvarres%status2,firstvarres%phstate + read(lin)firstvarres%prefix,firstvarres%suffix + read(lin)firstvarres%abnorm +! check interconecctions, firstvarres%phlink is phase record index +! from phlista(firstvarres%phlink)%clink one should find this record (j) +! jxph=firstvarres%phlink + if(btest(firstvarres%status2,CSDFS)) then +! this phase_varres records belong to a disordered fraction_set + lokph=firstvarres%phlink +! lokcs=phlista(lokph)%cslink + lokcs=phlista(lokph)%linktocs(1) + nsl=ceq%phase_varres(lokcs)%disfra%ndd + mc=ceq%phase_varres(lokcs)%disfra%tnoofxfr + else + nsl=phlista(firstvarres%phlink)%noofsubl + mc=phlista(firstvarres%phlink)%tnooffr + endif +! write(*,*)'bmpread 78: ',j,nsl,mc + mc2=mc*(mc+1)/2 +! added integer status array constat +! write(*,*)'Allocate constat 1: ',nsl,mc + allocate(firstvarres%constat(mc)) + allocate(firstvarres%yfr(mc)) + allocate(firstvarres%sites(nsl)) +! for ionic liquids allocate dpqdy + if(btest(phlista(firstvarres%phlink)%status1,PHIONLIQ)) then + if(ocv()) write(*,*)'Allocate dpqdy: ',mc + allocate(firstvarres%dpqdy(mc)) + endif +!>>>>> 56: + read(lin)(firstvarres%constat(i),i=1,mc) + read(lin)(firstvarres%yfr(i),i=1,mc) + allocate(firstvarres%mmyfr(mc)) + read(lin)(firstvarres%mmyfr(i),i=1,mc) + read(lin)(firstvarres%sites(i),i=1,nsl) +! these are ignored, values not important but must be allocated +! for ionic liquid as (2,mc) and (2,mc2) +! read(lin)(firstvarres%dsitesdy(2,i),i=1,mc) +! read(lin)(firstvarres%d2sitesdy2(2,i),i=1,mc2) +!>>>>> 57: + read(lin)ivar + if(ivar.eq.1) then +! extra fraction set + if(ocv()) write(*,*)'reading extra fraction set for ',j +!>>>>> 58: + read(lin)fslink%latd,fslink%ndd,fslink%tnoofxfr,& + fslink%tnoofyfr,fslink%totdis,fslink%varreslink,fslink%id + allocate(fslink%nooffr(fslink%ndd)) + allocate(fslink%dsites(fslink%ndd)) + allocate(fslink%splink(fslink%tnoofxfr)) + allocate(fslink%y2x(fslink%tnoofyfr)) + allocate(fslink%dxidyj(fslink%tnoofyfr)) + read(lin)fslink%nooffr,fslink%splink + read(lin)fslink%dsites + read(lin)fslink%y2x + read(lin)fslink%dxidyj +! now copy fslink to the correct record and then deallocate fslink arrays + call copy_fracset_record(j,fslink,ceq) + deallocate(fslink%nooffr) + deallocate(fslink%dsites) + deallocate(fslink%splink) + deallocate(fslink%y2x) + deallocate(fslink%dxidyj) + endif +! The result data +!>>>>> 59: + read(lin)firstvarres%amfu,firstvarres%netcharge,firstvarres%dgm, & + firstvarres%nprop + nprop=firstvarres%nprop + allocate(firstvarres%listprop(nprop)) + allocate(firstvarres%gval(6,nprop)) + allocate(firstvarres%dgval(3,mc,nprop)) + allocate(firstvarres%d2gval(mc2,nprop)) +!>>>>> 60: + read(lin)(firstvarres%gval(i,1),i=1,6) + do k=1,mc + read(21)(firstvarres%dgval(i,k,1),i=1,3) + enddo +!>>>>> 61: + read(lin)(firstvarres%d2gval(i,1),i=1,mc2) + if(ocv()) write(*,*)'phase_varres size: ',j,size(ceq%phase_varres) + enddo +!----- conditions, can be empty, NOTE: entered after phase_varres +!>>>>> 62: + read(lin)ip + if(ip.gt.0) then + read(lin)dum16,text(1:ip) +! set the conditions, ip will be incremented by 1 in enter_condition +! the text contains " number: variable=value, " +! we have to set each condition variable separately + jp=1 + if(ocv()) write(*,*)'Conditions >',text(1:ip),'<',jp,ip + cloop: do while(jp.lt.ip) + k=index(text(jp:ip),':') + if(k.le.0) exit cloop + jp=jp+k + kp=min(jp+index(text(jp+1:),' '),ip) + if(kp.gt.jp) then +! remove , as that indicates more conditions on same line + if(text(kp-1:kp-1).eq.',') then + text(kp-1:kp-1)=' ' + endif + else + kp=ip + endif + jp=jp-1 +! write(*,*)'condition 1 >',text(jp:kp),'<',jp + call set_condition(text(1:kp),jp,firsteq) +! jp automatically update inside set_condition + if(gx%bmperr.ne.0) then + write(*,*)'Error setting conditions' + write(*,*)ip,' >',text(jp:kp),'<' + goto 1000 + endif + enddo cloop + endif +!---- experiments +!>>>>> 63: + read(lin)ip + if(ip.gt.0) then + read(lin)dum16,text(1:ip) + endif +!>>>>>> 64: restore savesysmat + read(lin)ceq%sysmatdim,ceq%nfixmu,ceq%nfixph +! write(*,*)'savesysmat: ',ceq%sysmatdim,ceq%nfixmu,ceq%nfixph + if(ceq%nfixmu.gt.0) then + allocate(ceq%fixmu(ceq%nfixmu)) + read(lin)(ceq%fixmu(kp),kp=1,ceq%nfixmu) + endif + if(ceq%nfixph.gt.0) then + allocate(ceq%fixph(2,ceq%nfixph)) + read(lin)(ceq%fixph(1,kp),ceq%fixph(2,kp),kp=1,ceq%nfixph) + endif + if(ceq%sysmatdim.gt.0) then + allocate(ceq%savesysmat(ceq%sysmatdim,ceq%sysmatdim)) + do mc=1,ceq%sysmatdim + read(lin)(ceq%savesysmat(mc,kp),kp=1,ceq%sysmatdim) + enddo + endif +! allocate and zero the array with current chemical potentials + if(.not.allocated(ceq%cmuval)) allocate(ceq%cmuval(noofel)) + ceq%cmuval=zero +! + csfree=highcs +1000 continue + return + end subroutine readequil + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine svfunread(lin) +! read a state variable function from save file and store it. +! by default there are some state variable functions, make sure +! they are deleted. Done here just by setting nsvfun=0 + implicit none + integer lin +!\end{verbatim} + integer nsvfun,i,ip,nsvfunfil + character*512 text + nsvfun=0 + read(lin)nsvfunfil + if(ocv()) write(*,*)'Number of state variable functions: ',nsvfunfil + do i=1,nsvfunfil + read(lin)ip +! write(*,*)'Number of characters: ',ip + text=' ' + read(lin)text(2:ip) +! write(*,*)text(2:ip) + ip=1 + call enter_svfun(text,ip,firsteq) + if(gx%bmperr.ne.0) then +! write(*,*)'Error entering svf from file',gx%bmperr + if(gx%bmperr.ne.4136) goto 1000 + gx%bmperr=0 + endif + enddo +1000 continue + return + end subroutine svfunread + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine biblioread(lin) +! read references from save file + implicit none + integer lin +!\end{verbatim} + character text*512 + integer i,iref,jp,nrefs +!>>>>> 40: number of references +! write(*,*)'Reading reference version and nummer of' + read(lin)i,nrefs +! write(*,*)i,nrefs + if(i.ne.gtp_biblioref_version) then + write(*,*)'Warning, the bibliographic references version not same' + endif + if(ocv()) write(*,*)'Reading bibligraphic references: ',nrefs,reffree +! reffree=nrefs+1 + reffree=1 + do i=1,nrefs +!>>>>> 41: number characters to read + read(lin)jp +! write(*,*)'Length of text: ',i,jp +!>>>>> 42: text + if(jp.gt.512) then + write(*,*)'Too long bibliographic reference text',jp + gx%bmperr=7777; goto 1000 + endif + read(lin)text(1:jp) +! write(*,*)text(1:jp) + call tdbrefs(text(1:16),text(17:jp),0,iref) + if(gx%bmperr.ne.0) goto 1000 + enddo +1000 continue + return + end subroutine biblioread + +!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! + +!\begin{verbatim} + subroutine new_gtp +! +! DELETES ALL DATA so a new TDB file can be read +! +! this is needed before reading a new unformatted file (or same file again) +! we must go through all records and delete and deallocate each +! separately. Very similar to gtpread + implicit none +!\end{verbatim} + integer isp,j,nel,intv(10) + double precision dblv(10) + TYPE(gtp_equilibrium_data), pointer :: ceq +! TYPE(gtp_fraction_set) :: fslink + if(ocv()) write(*,*)'Removing current data' +!---------- elementlist, no need to delete, just deallocate below +!>>>>> 2: +!---------- specieslist, we have to deallocate ?? maybe not ?? +!>>>>> 3: + if(btest(globaldata%status,GSNODATA)) then + if(ocv()) write(*,*)'No thermodynamic data to delete' + goto 600 + endif + if(gtp_species_version.ne.1) then + if(ocv()) write(*,17)'Species',1,gtp_species_version +17 format(a,' record version error: ',2i4) + gx%bmperr=7777; goto 1000 + endif + ceq=>firsteq + do isp=1,noofsp + nel=splista(isp)%noofel + deallocate(splista(isp)%ellinks) + deallocate(splista(isp)%stoichiometry) + enddo +!---------- phases, many records, here we travese all endmembers etc +!>>>>> 4 + if(gtp_phase_version.ne.1) then + if(ocv()) write(*,17)'Phase',1,gtp_phase_version + gx%bmperr=7777; goto 1000 + endif + if(gtp_endmember_version.ne.1) then + if(ocv()) write(*,17)'Endmember',1,gtp_endmember_version + gx%bmperr=7777; goto 1000 + endif + if(gtp_interaction_version.ne.1) then + if(ocv()) write(*,17)'Interaction',1,gtp_interaction_version + gx%bmperr=7777; goto 1000 + endif + if(gtp_property_version.ne.1) then + if(ocv()) write(*,17)'Property',1,gtp_property_version + gx%bmperr=7777; goto 1000 + endif + do j=0,noofph + call delphase(j) + if(gx%bmperr.ne.0) goto 1000 + enddo +!----------- jump here if no thermodynamic data +600 continue +!---------- equilibrium records +!>>>>> 50: equilibrium records +! call delete_equil(ceq) +! do j=1,noofeq +! this loop was added in an attempt to get rid of an error occuring with +! 64 bit version, the TP functions was not cleared correctly + do j=1,eqfree-1 + ceq=>eqlista(j) + deallocate(ceq%svfunres) + deallocate(ceq%eq_tpres) + enddo +! I am not sure if this really releases all memory, how to check .... ??? + deallocate(eqlista) +!------- deallocate elements, species and phases, will be allocated in init_gtp + deallocate(ellista) + deallocate(elements) + deallocate(splista) + deallocate(species) + deallocate(phlista) + deallocate(phases) + deallocate(phasetuple) +!------ tpfunction expressions and other lists +!>>>>> 20: delete tpfuns +! write(*,*)'Delete TP funs, just deallocate??' + call delete_all_tpfuns +! write(*,*)'Back from deleting all TP funs, this is fun!!' +!------ tpfunction expressions and other lists +!>>>>> 30: delete state variable functions + deallocate(svflista) +! call delete_svfuns +!---------- delete bibliographic references +!>>>>> 40: references + deallocate(bibrefs) +! call delete_biblio +!------ parameter property records + deallocate(propid) +! deallocate( .... any more ??? +!--------------------------- +! now initiate all lists and a little more + if(ocv()) write(*,*)'All data structures will be reinitiated' +! intv(1) negative means reinititate with same values as before + intv(1)=-1 + call init_gtp(intv,dblv) +! after return firsteq must ve initiated ... maybe it should be done here ?? +! +1000 continue + return + end subroutine new_gtp + +!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\!!/!\! + +!\begin{verbatim} + subroutine delphase(lokph) +! save data for phase at location lokph (except data in the equilibrium record) +! For phases with disordered set of parameters we must access the number of +! sublattices via firsteq + implicit none + integer lokph +!\end{verbatim} + integer level,nsl,noendm + type(gtp_endmember), pointer :: emrec,nextem + type(gtp_interaction), pointer :: intrec,nextint + type(gtp_property), pointer :: proprec,nextprop +! to keep track of interaction records + type saveint + type(gtp_interaction), pointer :: p1 + end type saveint + type(saveint), dimension(:), pointer :: stack + type(gtp_phase_add), pointer :: addlink,nextadd +! write(*,*)'In delphase',lokph + allocate(stack(5)) + nsl=phlista(lokph)%noofsubl +!>>>>> 6: + deallocate(phlista(lokph)%nooffr) + deallocate(phlista(lokph)%constitlist) + emrec=>phlista(lokph)%ordered + noendm=0 +!>>>>> 6: sublattice info +! we come back here if there are disordered parameters +200 continue +! there can be phases without any parameters ... + emlista: do while(associated(emrec)) + proprec=>emrec%propointer + intrec=>emrec%intpointer + nextem=>emrec%nextem +!>>>>> 7: after saving links deallocate endmember record with all its content +! write(*,*)'deallocate endmember record' + deallocate(emrec) +! nextem do not need to be declared as target?? + emrec=>nextem + emproplista: do while(associated(proprec)) + nextprop=>proprec%nextpr +!>>>>> 8: endmember property records +! functions and references deallocated separately +! write(*,*)'deallocate endmember property record' + deallocate(proprec) + proprec=>nextprop + enddo emproplista +! interaction tree + level=0 +300 continue + intlista: do while(associated(intrec)) +!>>>>> 9: interaction record + level=level+1 + if(level.gt.5) then + gx%bmperr=4164; goto 1000 + endif +! write(*,*)'Pushing ',level + stack(level)%p1=>intrec%nextlink + nextint=>intrec%highlink + proprec=>intrec%propointer +! write(*,*)'deallocate interaction record' + deallocate(intrec) + intproplista: do while(associated(proprec)) + nextprop=>proprec%nextpr +!>>>>> 10: interaction properties +! write(*,*)'deallocate interaction property record' + deallocate(proprec) + proprec=>nextprop + enddo intproplista + intrec=>nextint + enddo intlista +! pop the link to next interaction if any + pop: if(level.gt.0) then +! write(*,*)'popping interaction record',level + intrec=>stack(level)%p1 + nullify(stack(level)%p1) + level=level-1 + goto 300 + endif pop +!---- next endmember + emrec=>nextem + enddo emlista +! no more endmembers, check if the disordered (if any) has been written + if(noendm.eq.0) then +! we do not have to care about that nsl is different .... +!>>>>> 11: disordered endmembers +! write(*,*)'disordered endmembers' + emrec=>phlista(lokph)%disordered + noendm=1 + goto 200 + endif +! write(*,*)'finished parameter records' +!------ additions list +500 continue + addlink=>phlista(lokph)%additions + addition: do while(associated(addlink)) +!>>>>> 12: additions + nextadd=>addlink%nextadd + if(addlink%type.eq.1) then +!>>>>> 12A: delete magnetic addition ... + deallocate(addlink) + else + write(*,*)'Cannot delete unknown addition type ',addlink%type + endif + addlink=>nextadd + enddo addition +! write(*,*)'phase location: ',lokph,size(phlista(lokph)%nooffr),& +! size(phlista(lokph)%constitlist) +! if(lokph.ne.0) then +! problem with phases, cannot deallocate these arrays, why?? +! deallocate(phlista(lokph)%nooffr) +! deallocate(phlista(lokph)%constitlist) +! endif + phlista(lokph)%noofcs=0 + phlista(lokph)%nooffs=0 +! write(*,*)'all done' +1000 continue + return + end subroutine delphase + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + logical function iskeyword(text,keyword,nextc) +! compare a text with a given keyword. Abbreviations allowed +! but the keyword and abbreviation must be surrounded by spaces +! nextc set to space character in text after the (abbreviated) keyword + implicit none + character text*(*),keyword*(*),key*64 + integer nextc +!\end{verbatim} + character word*64 + logical ok + integer kl,ks,kt +! extract the first word of text + ks=1 + if(eolch(text,ks)) then +! if empty line, just exit + ok=.false.; goto 1000 + else +! find the space after the first word + kt=ks+index(text(ks:),' ')-1 +! the abbreviation of the keyword must be at least 3 character !!! + if(kt-ks.lt.3 .or. kt-ks.ge.64) then + ok=.false.; goto 1000 + endif + endif + word=text(ks:kt) + kt=kt-ks + key=keyword + kl=len_trim(key) +! check if word is an abbreviation of key + if(word(1:kt).eq.key(1:kt)) then +! found keyword at start of line, set nextc to be positioned at the final space + nextc=ks+kt + ok=.true. + else + ok=.false. + endif +! write(*,100)ok,text(1:15),word(1:15),key(1:15),nextc,ks,kt,kl +!100 format('iskeyword: ',l1,' >',a,'<>',a,'<>',a,'<',5i3) +1000 continue + iskeyword=ok + return + end function iskeyword + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + integer function istdbkeyword(text,nextc) +! compare a text with a given keyword. Abbreviations allowed (not within _) +! but the keyword and abbreviation must be surrounded by spaces +! nextc set to space character in text after the (abbreviated) keyword + implicit none + character text*(*) + integer nextc +!\end{verbatim} +! only those currently implemented ... rest ignored + integer, parameter :: kwl=20 + integer, parameter :: nkw=12 + character (len=kwl), dimension(nkw), parameter :: keyword=& + ['ELEMENT ','SPECIES ',& + 'PHASE ','CONSTITUENT ',& + 'FUNCTION ','PARAMETER ',& + 'TYPE_DEFINITION ','LIST_OF_REFERENCES ',& + 'ADD_REFERENCES ','ASSESSED_SYSTEMS ',& + 'DATABASE_INFORMATION','VERSION '] +! + character word*64 + integer j,ks,kt +! extract the first word of text + ks=1 + if(eolch(text,ks)) then +! if empty line, just exit + j=0; goto 1000 + else +! find the space after the first word + kt=ks+index(text(ks:),' ')-1 +! the abbreviation of the keyword must be at least 3 character, max kwl + if(kt-ks.lt.3 .or. kt-ks.ge.kwl) then + j=0; goto 1000 + endif + endif + word=text(ks:kt) + kt=kt-ks + call capson(word) +! check if word is an abbreviation of a keyword +! write(*,*)'abbreviation: ',kt,'>',word(1:kt),'<' +! do j=1,10 + do j=1,nkw + if(word(1:kt).eq.keyword(j)(1:kt)) goto 100 + enddo + j=0 + goto 1000 +! found keyword at start of line, set nextc to be positioned at the final space +100 continue + nextc=ks+kt +! write(*,101)j,nextc,text(1:nextc) +!101 format('Found keyword: ',2i3,'>',a,'<') +1000 continue + istdbkeyword=j + return + end function istdbkeyword + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine replacetab(line,nl) +! replaces TAB by space in line + implicit none + character line*(*) + integer nl +!\end{verbatim} + integer ip +100 continue + ip=index(line,char(9)) + if(ip.gt.0) then + line(ip:ip)=' ' +! write(*,*)'Replaced TAB by space on line ',nl + goto 100 + endif +1000 continue + return + end subroutine replacetab + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine readtdb(filename,nel,selel) +! reading data from a TDB file with selection of elements +!------------------------------------------------------- +! Not all TYPE_DEFS implemented +!------------------------------------------------------- + implicit none + integer nel + character filename*(*),selel(*)*2 +!\end{verbatim} + character line*100,elsym*2,name1*24,name2*24,elsyms(10)*2 + character longline*10000,reftext*512 + character phtype*1,ch1*1,const(maxsp)*24,name3*24,funname*60,name4*60 + character refx*16 + character (len=1), dimension(20) :: typedefchar + integer, dimension(20) :: typedefaction + integer, dimension(5) :: addphasetypedef + double precision mass,h298,s298 + integer, dimension(10) :: knr,endm +! lint(1,*) is sublattice, lint(2,*) is species + double precision stoik(10),xsl,xxx + integer lint(2,3),noofphasetype,nytypedef,nextc,keyw,tdbv + integer typty,fractyp,lp1,lp2,ix,jph,kkk,lcs,nint,noelx + logical onlyfun,nophase,ionliq,notent + integer norew,newfun,nfail,nooftypedefs,nl,ipp,jp,jss,lrot,ip,jt + integer nsl,ll,kp,nr,nrr,mode,lokph,lokcs,km,nrefs,ideg,iph,ics +! disparttc and dispartph to handle phases with disordered parts + integer nofunent,disparttc,dodis,jl,nd1,thisdis + character*24 dispartph(5),ordpartph(5) + logical warning +! set to TRUE if element present in database + logical, allocatable :: present(:) +! +! if warning is true at the end pause before listing bibliography + warning=.FALSE. + if(ocv()) write(*,*)'reading a TDB file' + if(.not.(index(filename,'.tdb').gt.0 & + .or. index(filename,'.TDB').gt.0)) then +! no extention provided + filename(len_trim(filename)+1:)='.TDB' + endif + if(nel.gt.0) then + allocate(present(nel)) + present=.FALSE. + endif +! disparttc counts the number of disordered phases to read, the +! phase names are in dispartph(1..disparttc) +! dodis is nonzero only when reading the disordered part of phases. + disparttc=0 + dodis=0 + open(21,file=filename,access='sequential',form='formatted',& + err=1010,iostat=gx%bmperr,status='old') + onlyfun=.FALSE. + tdbv=1 + norew=0 + newfun=0 + nfail=0 + nrefs=0 + nooftypedefs=0 +! nophase set false after reading a PHASE keyword, +! expecting next keyword to be CONSTITUENT + nophase=.TRUE. +! return here after rewind +90 continue + nl=0 +! return here to look for a new keyword, end-of-file OK here +100 continue + read(21,110,end=2000)line +110 format(a) + nl=nl+1 +! One should remove TAB characters !! ?? YES !! +! if(line(1:1).eq.'$') goto 100 + ipp=1 + if(eolch(line,ipp)) goto 100 + if(line(ipp:ipp).eq.'$') goto 100 +! replace TAB by space + call replacetab(line,nl) + goto 120 +!----- this part moved to the end .... + funfirst: if(onlyfun) then +! first read only functions until all has been read +! if(line(2:10).eq.'FUNCTION ') then +! write(*,*)'Input line >',line(1:20),'<' + ipp=istdbkeyword(line,nextc) + if(ipp.eq.5) then +!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 +! FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) +! name1=line(11:18) +! special case, error in TDB file, UN_ASS is only 6 characters +! if(name1(1:6).eq.'UN_ASS') then +! name1=line(11:16); ipp=18 +! else +! ipp=20 +! endif + if(eolch(line,nextc)) then + write(*,*)'Function name must be on same line as FUNCTION' + gx%bmperr=4000; goto 1000 + endif + ipp=nextc+index(line(nextc:),' ') + name1=line(nextc:ipp-1) +! write(*,18)'function >',name1,'< ',nextc,ipp +!18 format(a,a,a,2i4) +! old code + longline=' ' + longline=line(ipp:) +111 continue + jp=len_trim(longline) + if(longline(jp:jp).eq.'!') then +! replace # by ' ' +112 continue + jss=index(longline(1:jp),'#') + if(jss.gt.0) then + longline(jss:jss)=' ' + goto 112 + endif +! write(*,*)'3E Entering function 1: ',name1,len_trim(longline) +! lrot=0 + call enter_tpfun(name1,longline,lrot,.TRUE.) + if(gx%bmperr.ne.0) then +! one may have error here if function calls other functions not entered, 4002 +! or if the function is already entered, 4026 + if(gx%bmperr.eq.4002.or. gx%bmperr.eq.4026) then + if(gx%bmperr.eq.4002) nfail=nfail+1 + gx%bmperr=0; goto 100 + endif + write(*,*)'Failed entering function: ',name1 + goto 1000 + endif + if(ocv()) write(*,*)'Entered function: ',name1 + newfun=newfun+1 + else + nl=nl+1 + read(21,110)line +! write(kou,101)'readtdb 2: ',nl,line(1:40) + call replacetab(line,nl) + longline=longline(1:jp)//line + goto 111 + endif + elseif(ipp.gt.0) then +! skip lines until !. There can be a ! on the line with the keyword! +77 continue + if(index(line,'!').le.0) then + read(21,110,end=2000)line + nl=nl+1 + call replacetab(line,nl) + goto 77 + endif + endif + goto 100 + endif funfirst +!--------------------------------------------------------- +! handle all TDB keywords except function +120 continue + keyw=istdbkeyword(line,nextc) + if(keyw.eq.0) then + ip=1 + if(.not.eolch(line,ip)) then + if(ocv()) write(*,*)'Ignoring line: ',nl,ip,line(ip:ip+20) + endif + goto 100 + elseif(onlyfun) then + if(keyw.eq.5) goto 800 + goto 100 + endif + if(.not.nophase .and. keyw.ne.4) then +! after a PHASE keyword one should have a CONSTITUENT + write(*,*)'expeciting CONSTITUENT: ',line(1:30) + warning=.TRUE. + endif +! check there is a ! in line, otherwise read until we find an exclamation mark + ip=1 + longline(ip:)=line + ip=len_trim(longline)+1 +! write(*,*)'new keyword ',ip,'>',longline(1:40) + do while(index(longline,'!').le.0) + read(21,110,err=2200)line + nl=nl+1 + if(line(1:1).ne.'$') then + call replacetab(line,nl) + longline(ip:)=line + ip=len_trim(longline)+1 + if(ip.gt.len(longline)-80) then + write(*,69)nl,ip,longline(1:72) +69 format('Overflow in longline ',2i5,' for line starting:'/a) + gx%bmperr=7777; goto 1000 + endif + endif + enddo + if(dodis.eq.1) then +! if dodis=1 only read data for disordred phases +! PHASE=3, CONSTITUENT=4, PARAMETER=6 ... any more? + if(keyw.lt.3 .or. keyw.eq.5 .or. keyw.gt.6) goto 100 + endif +! + select case(keyw) + case default + if(ocv()) write(*,*)'default case: ',keyw,line(1:30) +!--------------------------------------------------------------------- +!101 format('readtdb 1: ',i3,'>',a,'<') +! if(line(2:9).eq.'ELEMENT ') then + case(1) !element ------------------------------------------------ +!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 +! ELEMENT CR BCC_A2 5.1996E+01 4.0500E+03 2.3560E+01! + ip=nextc + if(eolch(longline,ip)) then + write(*,*)'No element name after ELEMENT keyword on line ',nl + gx%bmperr=7777; goto 1000 + endif + elsym=longline(ip:ip+1) + if(elsym.eq.'/-' .or. elsym.eq.'VA') goto 100 +! allow lower case in TDB file ... + call capson(elsym) + if(nel.gt.0) then +! check if element among selected, if nel=0 accept all + do jt=1,nel + if(elsym.eq.selel(jt)) goto 76 + enddo +! ignore this element as not selected + if(ocv()) write(*,*)'Skipping database element: ',elsym +! write(*,*)'Skipping database element: ',elsym +! write(*,*)'Select: ',nel,(selel(jt),jt=1,nel) + goto 100 + endif +! mark we found a selected element +76 continue + if(allocated(present)) then + present(jt)=.TRUE. + endif + ip=ip+len_trim(elsym) + if(eolch(longline,ip)) then + name1='DUMMY' + mass=one + h298=zero + s298=zero + else +! extract the reference phase, third argument is 1 meaning until next space +! ix is the length of the reference phase (irrelevant here) +! ip is updated to character after the name extracted + call getext(longline,ip,1,name1,' ',ix) +! name1=longline(ip:) +! ip=ip+len_trim(name1) +! after the name should be mass, H298-H0 and S298, ignore errors + call getrel(longline,ip,mass) + if(buperr.ne.0) then + mass=one; buperr=0 + endif + call getrel(longline,ip,h298) + if(buperr.ne.0) then + h298=zero; buperr=0 + endif + call getrel(longline,ip,s298) + if(buperr.ne.0) then + s298=zero; buperr=0 + endif + name2=elsym + endif + call enter_element(elsym,name2,name1,mass,h298,s298) + if(gx%bmperr.ne.0) goto 1000 + case(2) !SPECIES ------------------------------------------------- +! elseif(line(2:9).eq.'SPECIES ') then +!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 +! SPECIES O3PU2 O3PU2! + ip=nextc + if(eolch(longline,ip)) then + write(*,*)'Line after SPECIES keyword empty' + gx%bmperr=7777; goto 1000 + endif + name1=longline(ip:) +! find first space after non-space + jp=index(name1,' ') + name1(jp:)=' ' + ip=ip+jp + if(eolch(longline,ip)) then + write(*,*)'No stoichiometry for species: ',name1 + warning=.TRUE. + goto 100 + endif + name2=longline(ip:) + jp=index(name2,' ') + name2(jp:)=' ' + call decode_stoik(name2,noelx,elsyms,stoik) + if(gx%bmperr.ne.0) goto 1000 +! check elements exist + call enter_species(name1,noelx,elsyms,stoik) +! write(*,*)'3E: entering species error: ',gx%bmperr + if(gx%bmperr.ne.0) then +! if element not selected just skip the species + if(gx%bmperr.eq.4046) then + gx%bmperr=0; goto 100 + else + write(*,*)'Error entering species: ',name1,name2 + goto 1000 + endif + endif +!----------------------------------------------------------------------- + case(5) ! function +! elseif(line(2:10).eq.'FUNCTION ') then +!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 +! FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) +! name1=line(11:18) +! longline=' ' +! longline=line(20:) +!300 continue +! jp=len_trim(longline) +! if(longline(jp:jp).eq.'!') then +! write(*,*)'Skipping function: ',name1 +! all functions entered at the end, skip until ! +! do while(index(longline,'!').le.0) + if(index(longline,'!').le.0) then + write(*,*)' Error, terminating ! not found for funtion!!',nl + gx%bmperr=7777; goto 1000 + endif +!------------------------------------------------------------------------- +! elseif(line(2:7).eq.'PHASE ') then + case(3) ! PHASE +!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 +! PHASE LIQUID:L % 1 1.0 ! + if(nophase) then + nophase=.false. +! give a warning if any selected element is not present + if(allocated(present)) then + funname=' ' + kkk=1 + do jt=1,nel + if(.not.present(jt)) then + funname(kkk:)=selel(jt) + kkk=len_trim(funname)+2 + endif + enddo + if(kkk.gt.1) then + write(kou,68)funname(1:kkk) +68 format(/' *** Warning, elements not present in database: ',a/) + endif + deallocate(present) + endif + else + write(*,*)'Error, a PHASE keyword must be followed by its CONSTIT' + gx%bmperr=7777; goto 1000 + endif + ip=nextc + if(eolch(longline,ip)) then + write(*,*)'line after PHASE empty' + goto 100 + endif + name1=longline(ip:) +! convert phase name to upp case + call capson(name1) + jp=index(name1,' ') + ip=nextc+jp + if(jp.gt.0) then + name1(jp:)=' ' + endif + jp=index(name1,':') +! write(*,*)'3E readtdb 11: ',name1,ip,jp +! phytype + if(jp.gt.0) then + phtype=name1(jp+1:jp+1) + name1(jp:)=' ' + else + phtype=' ' + endif +! write(*,*)'nophase set to false, phase: ',name1 +! phase type code + noofphasetype=0 + ip=ip+1 + jp=ip + name2=longline(ip:jp) + thisdis=0 + phdis: if(dodis.eq.1) then +! special when reading disordered parts, check phase name equail +! write(*,*)'Check if disordered part: ',dodis,name1 + do jt=1,disparttc + if(name1.eq.dispartph(jt)) goto 307 + enddo +! not a disordered part + goto 100 +307 continue + thisdis=jt +! write(*,*)'Found disordered part: ',name1,thisdis +! we skip the rest of the phase line ... + goto 100 + elseif(dodis.eq.0 .and. disparttc.gt.0) then +! we must not enter phases that are disordered parts + do jt=1,disparttc + if(name1.eq.dispartph(jt)) then +! write(*,*)'Skip phase that is a disordered part: ',name1 + thisdis=-1 + goto 100 + endif + enddo + endif phdis +! write(*,*)'Entering phase: ',name1 +! write(*,*)'Checking phase types for phase: ',name1,jp +! skip blanks, then read type code, finished by a blank + if(eolch(longline,jp)) then + write(*,*)'3E no phase typecode: ',name1(1:len_trim(name1)) + warning=.TRUE. + endif + jp=jp-1 +310 jp=jp+1 +! NOTE and FIX: type code expected to be after a single space: be flexible ?? + typedefcheck: if(longline(jp:jp).ne.' ') then + ch1=longline(jp:jp) +! write(*,*)'3E typedef: ',ch1,jp + do jt=1,nooftypedefs + if(ch1.eq.typedefchar(jt)) goto 320 + enddo + goto 310 +320 continue + if(typedefaction(jt).eq.99) then +! ignore TYPE_DEF SEQ + continue + elseif(typedefaction(jt).eq.-1 .or. & + typedefaction(jt).eq.-3) then +! magnetic addition, save for after phase created + noofphasetype=noofphasetype+1 + addphasetypedef(noofphasetype)=typedefaction(jt) + else + continue + endif + goto 310 + endif typedefcheck + name2='TDB file model: '//name2 +! sublattices +! write(*,*)'3E buperr: ',buperr ,jp + call getrel(longline,jp,xsl) + if(buperr.ne.0) then + write(*,*)'3E tdb: "',longline(1:jp),'"',buperr + gx%bmperr=buperr; goto 1000 + endif + nsl=int(xsl) + do ll=1,nsl + call getrel(longline,jp,stoik(ll)) + if(buperr.ne.0) then + gx%bmperr=buperr; goto 1000 + endif + enddo +! write(*,*)'readtdb 3A: ',nsl,(stoik(ll),ll=1,nsl) +!--------------------------------------------------------------------- +! The constituent line must follow PHASE before any new phase + case(4) ! CONSTITUENT LIQUID:L :CR,FE,MO : ! +! the phase must have been defined + if(nophase) then + write(*,*)'A CONSTITUENT keyword not directly preceeded by PHASE!' + gx%bmperr=7777; goto 1000 + endif + nophase=.true. + condis1: if(dodis.eq.1) then + if(thisdis.eq.0) goto 100 +! we skip the constituent line and go directly to create disordered fractions + goto 395 + elseif(disparttc.gt.0 .and. thisdis.lt.0) then +! this is a disordered part, skip + goto 100 + endif condis1 +!360 continue + jp=len_trim(longline) +! write(*,*)'readtdb gas1: ',nl,jp,longline(1:jp) +! eliminate all after the exclamation mark +! longline(jp+1:)=' ' +! + ip=index(longline,' :')+2 +! write(*,*)'readtdb gas2: ',jp,longline(1:jp) + ll=0 + nr=0 + nrr=0 +! write(*,*)'readtdb 3C: ',ll,nr,nsl,longline(ip:jp) +! mode=1 indicates to getname that / + - are allowed in species names + mode=1 +370 continue + if(ll.ge.1) then + knr(ll)=nr + if(nr.le.0) then + if(ocv()) then + write(*,*)'Skipping phase due to missing constituents: ',name1 +! write(*,378)name1,ll +378 format('Phase ',a,' has no constituents in sublattice ',i2) +! Not a fatal error when elements have been selected but skip this phase +! gx%bmperr=7777; goto 1000 + endif + goto 100 + endif + endif + ll=ll+1 +! write(*,*)'start sublat ',ll,nsl,nr,ip + if(ll.gt.nsl) goto 390 + nr=0 +380 continue + if(eolch(longline,ip)) then + write(*,*)'Error extracting constituents 1' + gx%bmperr=7777; goto 1000 + endif + nr=nr+1 + nrr=nrr+1 +! write(*,379)'readtdb 3CXX: ',ip,nr,longline(ip:ip+10) +379 format(a,2i4,' >',a,'< >',a,'< >',a,'<') + call getname(longline,ip,name3,mode,ch1) +! write(*,379)'readtdb 3CY: ',ip,nr,longline(ip:ip+10),name3,ch1 + if(buperr.ne.0) then +! write(*,381)'readtdb 3E: ',ll,nr,longline(1:ip+5),ip,name3 +381 format(a,2i4,' "',a,'" ',i5,1x,a,'"',a) + gx%bmperr=buperr; goto 1000 + endif +! write(*,381)'readtdb 3E: ',ll,nr,longline(1:ip+5),ip,name3,ch1 + const(nrr)=name3 +! bypass any "major" indicator % + if(ch1.eq.'%') ip=ip+1 + if(eolch(longline,ip)) then + write(*,*)'Error extracting constituents 2' + gx%bmperr=7777; goto 1000 + endif +! check that const(nrr) among the selected elements ... +! write(*,*)'Testing constituent: ',name3,nr + call find_species_record_noabbr(name3,lp1) + if(gx%bmperr.ne.0) then +! this species is not present, not a fatal error, skip it and continue +! write(*,*)'Skipping constituent: ',name3 + gx%bmperr=0; nrr=nrr-1; nr=nr-1 + endif + ch1=longline(ip:ip) + if(ch1.eq.',') then + ip=ip+1; goto 380 + elseif(ch1.eq.':') then + ip=ip+1; goto 370 + endif + if(ch1.ne.'!') goto 380 +! when an ! found the list of constutents is finished. But we +! should have found a : before the ! + write(*,*)'Found "!" before terminating ":"' + gx%bmperr=7777; goto 1000 +! write(*,*)'Species terminator error: ',ch1,nl +! gx%bmperr=4157; goto 1000 +390 continue +! name2 is model, ignored on reading TDB + ionliq=.FALSE. + if(phtype(1:1).eq.'Y') then + name2='IONIC_LIQUID ' + ionliq=.TRUE. + else + name2='CEF-TDB-RKM? ' + endif + if(ocv()) write(*,*)'readtdb 9: ',name1,nsl,knr(1),knr(2),phtype +395 continue + condis2: if(dodis.eq.1) then +! if we have a disordered part do not enter the phase, add disordered fracs! +! the ordered phase name is ordpart(thisdis) + call find_phase_by_name(ordpartph(thisdis),iph,ics) + if(gx%bmperr.ne.0) then +! NOTE THE ORDERED PHASE MAY NOT BE ENTERED DUE TO COMPONENTS!! + write(*,396)thisdis,ordpartph(thisdis) +396 format('Disordered phase skipped as no ordered: ',i3,' "',a,'"') + warning=.TRUE. + gx%bmperr=0 + goto 100 + else + write(*,*)'Adding disordered fraction set: ',ordpartph(thisdis) + endif +! we are creating the phase, there is only one composition set + call get_phase_compset(iph,1,lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 +! ch1 is suffix for parameters, always D + ch1='D' +! jl=0 if NDM (sigma) +! jl=1 if phase can be totally disordered (but can have interstitials) +! nd1 is the number of sublattices to sum into disordered set + if(dispartph(thisdis)(1:7).eq.'FCC_A1 ' .or. & + dispartph(thisdis)(1:7).eq.'BCC_A2 ' .or. & + dispartph(thisdis)(1:7).eq.'HCP_A3 ') then +! if disordred phase is FCC, BCC or HCP then set jl=1 and nd1 to 2 or 4 + if(phlista(lokph)%noofsubl.le.5) nd1=4 + if(phlista(lokph)%noofsubl.le.3) nd1=2 + write(kou,397)ordpartph(thisdis)(1:len_trim(ordpartph(thisdis))),& + nd1 +! write(*,399) +!399 format('Phase names for disordered parts of FCC, BCC and HCP must',& +! ' start with:'/' A1_ , A2_ and A3_ respectivly!'/& +! ' and have an interstitial sublattice') + elseif(dispartph(thisdis)(1:3).eq.'A1_' .or. & + dispartph(thisdis)(1:3).eq.'A2_' .or. & + dispartph(thisdis)(1:3).eq.'A3_') then +! if disordred phase is FCC, BCC or HCP then set jl=1 and nd1 to 2 or 4 + if(phlista(lokph)%noofsubl.le.5) nd1=4 + if(phlista(lokph)%noofsubl.le.3) nd1=2 + write(kou,397)ordpartph(thisdis)(1:len_trim(ordpartph(thisdis))),& + nd1 +397 format('Phase ',a,& + ' has an order/disorder partition model summing first ',i2) + jl=1 + else +! disordered part of sigma, mu etc. + jl=0; nd1=phlista(lokph)%noofsubl + write(kou,398)ordpartph(thisdis)(1:len_trim(ordpartph(thisdis))),nd1 +398 format('Phase ',a,' has NODT partition model summing first ',i2) + endif +! add DIS_PART from TDB + call add_fraction_set(iph,ch1,nd1,jl) + if(gx%bmperr.ne.0) then + write(*,*)'3E Error entering disordered fraction set: ',gx%bmperr + goto 1000 + endif + if(jl.eq.0) then +! we must set the correct formula unit of the disordered phase, on the +! TDB file it is unity. Sum up the sites for the ordered phase in lokcs + xxx=zero + do ll=1,nd1 + xxx=xxx+firsteq%phase_varres(lokcs)%sites(ll) + enddo + firsteq%phase_varres(lokcs)%disfra%fsites=xxx + else + xxx=one + endif + write(kou,601)dispartph(thisdis)(1:len_trim(dispartph(thisdis))),& + ch1,nd1,jl,xxx +601 format('Parameters from disordered part added: ',a,5x,a,2x,2i3,F12.4) + else + call enter_phase(name1,nsl,knr,const,stoik,name2,phtype) +! write(*,*)'readtdb 9A: ',gx%bmperr + if(gx%bmperr.ne.0) then + if(gx%bmperr.eq.4121) then + write(*,*)'Phase ',name1(1:len_trim(name1)),& + ' is ambiguous or short for another phase' + endif + goto 1000 + endif +! any typedefs? only magnetic handelled at present + call find_phase_by_name(name1,iph,lcs) +! write(*,*)'readtdb 9X: ',gx%bmperr + if(gx%bmperr.ne.0) then + write(*,*)'Phase ',name1,' is ambiguous' + goto 1000 + endif + lokph=phases(iph) +! write(*,*)'typedefs for ',name1(1:20),lokph,noofphasetype + phasetypes: do jt=1,noofphasetype +! write(*,*)'typedef ',jt,addphasetypedef(jt) + if(addphasetypedef(jt).eq.-1) then + call add_magrec_inden(lokph,1,-1) + elseif(addphasetypedef(jt).eq.-3) then + call add_magrec_inden(lokph,1,-3) + endif + if(gx%bmperr.ne.0) goto 1000 + enddo phasetypes +! write(*,607)name1,iph +607 format('3E Entered phase ',a,i5) + endif condis2 +! write(*,*)'readtdb 9B:',name1,nsl,phtype +!------------------------------------------------------------------- + case(6) ! PARAMETER -------------------------------------------- +! elseif(line(4:13).eq.'PARAMETER ') then +!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 +! PARAMETER G(LIQUID,CR;0) 2.98150E+02 +24339.955-11.420225*T + if(eolch(longline,nextc)) then + write(*,*)'Empty line after PARAMETER' + gx%bmperr=7777; goto 1000 + endif +! if(dodis.eq.1) write(*,*)'Reading disordered parameters' + ip=nextc + funname=longline(ip:) + kp=index(funname,' ') +! save position after parameter name in nextc + nextc=ip+kp + funname(kp:)=' ' +! extract symbol, normally G or L but TC, BMAGN and others can occur + lp1=index(funname,'(') + name1=funname(1:lp1-1) + typty=0 +! this is kept for compatibility with TDB files generated by TC + if(name1(1:2).eq.'G ' .or. name1(1:2).eq.'L ') then + typty=1 + elseif(name1(1:3).eq.'TC ') then + typty=2 + elseif(name1(1:6).eq.'BMAGN ') then + typty=3 + endif +! we should handle also other parameter types + if(typty.eq.0) then +! find the property associated with this symbol +! write(*,*)'psym1: ',name1(1:len_trim(name1)) + call get_parameter_typty(name1,lokph,typty,fractyp) + if(gx%bmperr.ne.0) then + write(*,*)' *** Illegal parameter identifier on line: ',nl + gx%bmperr=0; typty=0 + warning=.TRUE. + endif +! write(*,*)'psym2: ',typty,fractyp + endif +! only fractyp 1 on TDB files until I implemented disordered part + fractyp=1 +! write(*,*)'readtdb: PAR',name1,typty +! extract phase name and constituent array + lp1=index(funname,'(') + lp2=index(funname,',') + name2=funname(lp1+1:lp2-1) + dispar: if(dodis.eq.1) then +! first check if phase name is a disordered part, if not skip +! then change phase name to ordered phase and set fractyp=2 +! and add a suffix D to parameter symbol + do jl=1,disparttc + if(name2.eq.dispartph(jl)) goto 710 + enddo +! not disordered phase, skip this parameter + goto 100 +!----------------------- +710 continue +! write(*,*)'Entering disordered parameter to: ',thisdis,jl + thisdis=jl +! write(*,*)'Entering disordered parameter to: ',ordpartph(thisdis) +! write(*,*)'3E ',longline(1:len_trim(longline)) + name2=ordpartph(jl) + fractyp=2 + endif dispar + call find_phase_by_name_exact(name2,jph,kkk) +! write(*,*)'readtdb 19: ',jph,gx%bmperr,name2 + if(gx%bmperr.ne.0) then +! write(*,*)'Skipping parameter due to phase: ',name2 + gx%bmperr=0; goto 100 +! goto 1000 + endif +! extract constituent array, remove final ) and decode +! constituent names can be very long .... + lokph=phases(jph) + name4=funname(lp2+1:) +! find terminating ) + lp1=index(name4,')') + if(lp1.le.0) then + write(*,*)'Possible error in constituent array? ',name4,', line:',nl + warning=.TRUE. + goto 100 + else + name4(lp1:)=' ' + endif +297 continue +! + call decode_constarr(lokph,name4,nsl,endm,nint,lint,ideg) + if(ocv()) write(*,303)'readtdb 303: ',name4(1:len_trim(name4)),& + nsl,endm(1),endm(2),nint,((lint(ip,jp),ip=1,2),jp=1,nint) +303 format(a,a,2i4,2x,2i3,' : ',3(2i3,2x)) + if(gx%bmperr.ne.0) then +! error here can mean parameter with un-selected constituent, i.e. no error +! write(*,*)'3E: decode',ionliq,tdbv,nsl,gx%bmperr + if(ionliq .and. tdbv.eq.1 .and. nsl.eq.1) then +! handle parameters in ionic liquids with only neutrals in second sublattice +! in TC one can have no constituent there or an arbitrary constituent, +! in OC the constituent in sublattice 1 must be a * + nsl=2 + endm(2)=endm(1) + endm(1)=-99 +! shift any interaction from sublattice 1 to 2 + do ip=1,nint +! write(*,*)'3E lint: ',lint(1,ip),lint(2,ip) + lint(2,ip)=2 + enddo + if(ocv()) write(*,303)'modif endmem: ',name4(1:len_trim(name4)),& + nsl,endm(1),endm(2),nint,((lint(ip,jp),ip=1,2),jp=1,nint) + gx%bmperr=0 + else + if(ocv()) write(*,*)'Skipping parameter: ',name4(1:len_trim(name4)) + gx%bmperr=0; goto 100 +! write(*,*)'readtdb error: ',gx%bmperr,name4 +! goto 1000 + endif + endif + if(nint.gt.1) then +! lint(1,1) is species of first, lint(1,2) in second interaction +! write(*,305)'readtdb 305: ',endm(1),nint,lint(2,1),lint(2,2) + endif +305 format(a,5i4) +!---------------- encode function +! if(dodis.eq.1) write(*,*)'We are here 1' + ip=0 + jp=0 +400 continue + ip=ip+1 +405 continue + ch1=funname(ip:ip) +! accept the first 8 letters and numbers of phase name + if((ch1.ge.'A' .and. ch1.le.'Z') .or. & + (ch1.ge.'0' .and. ch1.le.'9')) goto 400 + if(ch1.ne.' ') then + funname(ip:)=funname(ip+1:) + jp=jp+1 + if(jp.lt.8) goto 405 + funname(ip+1:)=' ' + endif + funname='_'//funname +!------------------------------------------------- +! now read the function, start from position nextc + longline=longline(nextc:) +!410 continue + jp=len_trim(longline) + if(longline(jp:jp).ne.'!') then + write(*,410)nl,ip,longline(1:ip) +410 format('Error, parameter line not ending with !',2i5/a) + gx%bmperr=7777; goto 1000 + endif +! extract reference if any +! NOTE: a legal ending is ;,,,! + refx='none' + kp=jp-1 + do while(longline(kp:kp).ne.';') + kp=kp-1 + if(kp.lt.1) then +! illegal termination of function in TDB file + write(*,417)nl +417 format('No final ; of function in TDB file, around line: ',i5) + gx%bmperr=4013; goto 1000 + endif + enddo + kp=kp+2 +! longline(kp:kp) is character after "; " or ";," +! next is upper temperature limit or , meaning default. We have a "!" at end +430 continue + if(eolch(longline,kp)) continue + if(longline(kp:kp).eq.',') then + kp=kp+1 + elseif(longline(kp:kp).eq.'!') then + goto 433 + else +! ; 6000 N 91DIN ! +! kp=^ => index(...,' ')=5; kp=kp+4 + kp=kp+index(longline(kp:),' ')-1 + endif +! next is N or , + if(eolch(longline,kp)) continue + if(longline(kp:kp).ne.'!') then + kp=kp+1 + endif + if(eolch(longline,kp)) continue + if(kp.lt.jp) then + refx=longline(kp:jp-1) + call capson(refx) + else + refx=' ' + endif +! ------------------- we found the reference, continue with the expression +433 continue +! replace any # by ' ' +412 continue + jss=index(longline(1:jp),'#') + if(jss.gt.0) then + longline(jss:jss)=' ' + goto 412 + endif +! write(*,*)'3E Entering function 2: ',funname,len_trim(longline) +! lrot=0 + call enter_tpfun(funname,longline,lrot,.TRUE.) +! write(*,17)lokph,typty,nsl,lrot,(endm(i),i=1,nsl) +17 format('readtdb 17: '4i3,5x,10i3) +! write(*,404)'readtdb entpar: ',refx,fractyp,nint,ideg +404 format(a,a,i3,2x,10i3) + if(gx%bmperr.ne.0) then + write(*,*)'Error set: ',gx%bmperr,lrot,' ',& + funname(1:len_trim(funname)),' around line: ',nl + goto 1000 + else +! if(dodis.eq.1) write(*,*)'We are here 2' + call enter_parameter(lokph,typty,fractyp,nsl,endm,nint,lint,ideg,& + lrot,refx) + if(ocv()) write(*,407)'Entered parameter: ',lokph,typty,gx%bmperr +407 format(a,3i5) + if(gx%bmperr.ne.0) then +! error entering parameter, not fatal + if(dodis.eq.1) write(*,408)'3E parameter warning:',gx%bmperr,nl,& + funname(1:40) +408 format(a,i6,' line ',i5,': ',a) + if(.not.(gx%bmperr.ne.4096 .or. gx%bmperr.ne.4066)) goto 1000 +! ignore error 4096 meaning "no such constituent" or "... in a sublattice" +! write(*,*)'readtdb entparerr: ',gx%bmperr,' >',& +! funname(1:len_trim(funname)) + if(gx%bmperr.eq.7778) write(*,*)'3E Error 7778 at line: ',nl + gx%bmperr=0 +! elseif(dodis.eq.1) then +! write(*,*)'Disordered parameter should be entered ok' + endif + endif + if(gx%bmperr.ne.0) write(*,*)'3E errorcode 1: ',gx%bmperr +!------------------------------------------------------------------ +! elseif(line(2:17).eq.'TYPE_DEFINITION ') then + case(7) !TYPE_DEFINITION +!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 +! TYPE_DEFINITION & GES A_P_D BCC_A2 MAGNETIC -1.0 4.00000E-01 ! + nytypedef=nooftypedefs+1 + nooftypedefs=nytypedef + typedefchar(nytypedef)=longline(nextc+1:nextc+1) + ip=nextc+3 + newtypedef: if(longline(ip:ip+2).eq.'SEQ') then + typedefaction(nytypedef)=100 + else + km=index(longline,' MAGNETIC ') + magnetic: if(km.gt.0) then + ip=km+9 +!73 format(a,i3,' "',a,'"') + call getrel(longline,ip,xxx) + if(buperr.ne.0) then + gx%bmperr=buperr; goto 1000 + endif +! this can be -1 for BCC or -3 for FCC, HCP and other phases + typedefaction(nytypedef)=int(xxx) + else + km=index(longline,' DIS_PART ') + if(km.gt.0) then +! disordered part, several checks + disparttc=disparttc+1 +! find the ordered phase name, we have to go backwrds from km + ip=km-1 +81 continue + if(longline(ip:ip).eq.' ') then +! ordpartph(disparttc)=' ' + ordpartph(disparttc)=longline(ip+1:km) + else + ip=ip-1 + goto 81 + endif +! extract the disordered part phase name + ip=index(longline(km+2:),' ') + dispartph(disparttc)=longline(km+2+ip:) +! find the end of phase name, a space or a , there is always a space ... + ip=index(dispartph(disparttc),' ') + km=index(dispartph(disparttc),',') + if(km.gt.0 .and. km.lt.ip) ip=km +! if(ip.le.0) ip=1 + dispartph(disparttc)(ip:)=' ' + write(*,82)disparttc,ordpartph(disparttc),dispartph(disparttc) +! longline(1:len_trim(longline)) +!82 format('Found a type_def DIS_PART:',a,' : ',a) +82 format('Found a type_def DIS_PART:',i2,1x,a,1x,a) +! if the disordered part phase already entered give advice + call find_phase_by_name(dispartph(disparttc),iph,ics) + if(gx%bmperr.ne.0) then + gx%bmperr=0 + else + write(*,83)dispartph(disparttc) +83 format(' *** Warning, the disordered phase is already',& + ' entered ***'/' Please rearrange the TDB file so',& + ' this TYPE_DEF comes before'/& + ' the PHASE keyword for the disordered phase: ',a/& + ' *** The disordordered part ignored ***') + disparttc=disparttc-1 + warning=.TRUE. + endif + else + typedefaction(nytypedef)=99 + write(kou,87)nl,longline(1:min(78,len_trim(longline))) +87 format('Skipping this TYPE_DEFINITION on line ',i5,':'/a) + warning=.TRUE. + endif + endif magnetic + endif newtypedef +!--------------------------------------------------------------------- +! elseif(line(2:20).eq.'LIST_OF_REFERENCES ' .or. & +! line(2:16).eq.'ADD_REFERENCES ') then + case(8,9) ! LIST_OF_REFERENCES and ADD_REFERENCES +!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 +! LIST_OF_REFERENCES +! NUMBER SOURCE +! REF283 'Alan Dinsdale, SGTE Data for Pure Elements, +! Calphad Vol 15(1991) p 317-425, +! also in NPL Report DMA(A)195 Rev. August 1990' +! write(kou,*)'Does not handle REFERENCES' +! skip the line with "NUMBER SOURCE" +! position ip after "NUMBER SOURCE" + ip=index(longline,'NUMBER SOURCE')+14 + if(eolch(longline,ip)) then + write(*,*)'Empty reference line',nl + gx%bmperr=7777; goto 1000 + endif + if(longline(ip:ip).eq.'!') then +! write(*,*)'No references at all' + goto 100 + endif +! write(*,*)'list_of_references text length: ',len_trim(longline),ip +! some reference lists like those from SSUB has no single quotes + kp=index(longline(ip:),"'") + citationmarks: if(kp.gt.0) then +775 continue +! reference symbol is refx; reference text in reftext + refx=longline(ip:ip+kp-2) + if(longline(ip+kp:ip+kp).eq."'") then +! two ' after each other, a dummy reference + reftext=' ' + ip=ip+kp+1 + kkk=1 +! write(*,*)'dummy: ',refx,' next >',longline(ip:ip+20),'<' + else + jp=ip+kp+1+index(longline(ip+kp+1:),"'") + reftext=longline(ip+kp:jp-2) + ip=jp +! when all works replace multiple spaces by a single one in reftext + kkk=len_trim(reftext) + kp=index(reftext(1:kkk),' ') + do while(kp.gt.0) + reftext(kp:)=reftext(kp+1:) + kkk=kkk-1 + kp=index(reftext(1:kkk),' ') + enddo + endif +! write(*,776)refx,nrefs,ip,jp,reftext(1:kkk) +776 format('Reference: ',a,3i5/a) +! this will not create bibliographic references that has not been referenced + call tdbrefs(refx,reftext(1:kkk),1,ix) + nrefs=nrefs+1 +! write(*,*)'added biblio ',refx,'>',longline(ip-5:ip+5),'<' + if(eolch(longline,ip)) then + gx%bmperr=7777; goto 1000 + endif + if(longline(ip:ip).ne.'!') then + kp=index(longline(ip:),"'") + goto 775 + endif + else +! references without citation marks +! ip is at the start of the reference id, look for space + write(*,*)'Cannot handle references without citation marks',nl + gx%bmperr=7777; goto 1000 + endif citationmarks +777 continue +! write(*,*)'Read ',nrefs,' references, ending at',nl +!---------------------------------------------------------------- + case(10) ! ASSESSED_SYSTEMS + write(*,*)'Cannot handle ASSESSED_SYSTEMS ending at ',nl + warning=.TRUE. +! skip lines until ! + do while(index(line,'!').le.0) + read(21,110)line + nl=nl+1 + call replacetab(line,nl) + enddo +!------------------------------------------------------------------ + case(11) ! DATABASE_INFORMATION + write(*,*)'Cannot handle DATABASE_INFORMATION at ',nl + warning=.TRUE. +! skip lines until ! + do while(index(line,'!').le.0) + read(21,110)line + nl=nl+1 + call replacetab(line,nl) + enddo +!------------------------------------------------------------------ + case(12) ! VERSION, recognize OC1 +780 continue + if(eolch(line,ip)) then + read(21,110)line + nl=nl+1 + call replacetab(line,nl) + goto 780 + else + if(line(ip:ip).eq.'!') then + write(*,*)'Found VERSION keyword but no specification' + else + if(line(ip:ip+3).eq.'OC1 ') tdbv=2 + endif + endif +! skip lines until ! + do while(index(line,'!').le.0) + read(21,110)line + nl=nl+1 + call replacetab(line,nl) + enddo + end select + if(gx%bmperr.ne.0) write(*,*)'3E errorcode 2: ',gx%bmperr +! look for next KEYWORD + goto 100 +!-------------------------------------------------------- +!----- reading functions at the end +800 continue +! barafun: if(onlyfun) then +! enter only functions that are undefined +! if(line(2:10).eq.'FUNCTION ') then +! write(*,*)'Input line >',line(1:20),'<' +! ipp=istdbkeyword(line,nextc) +! if(ipp.eq.5) then +!123456789.123456789.123456789.123456789.123456789.123456789.123456789.12345678 +! FUNCTION GHSERCR 2.98150E+02 -8856.94+157.48*T-26.908*T*LN(T) +! name1=line(11:18) +! special case, error in TDB file, UN_ASS is only 6 characters +! if(name1(1:6).eq.'UN_ASS') then +! name1=line(11:16); ipp=18 +! else +! ipp=20 +! endif + if(eolch(line,nextc)) then + write(*,*)'Function name must be on same line as FUNCTION' + gx%bmperr=4000; goto 1000 + endif + ipp=nextc+index(line(nextc:),' ') + name1=line(nextc:ipp-1) +! write(*,18)'function >',name1,'< ',nextc,ipp +!18 format(a,a,a,2i4) +! old code + longline=' ' + longline=line(ipp:) +810 continue + jp=len_trim(longline) + if(longline(jp:jp).eq.'!') then +! replace # by ' ' +820 continue + jss=index(longline(1:jp),'#') + if(jss.gt.0) then + longline(jss:jss)=' ' + goto 820 + endif +! check if function is entered as undefined, exact match of name required + call find_tpfun_by_name_exact(name1,nr,notent) + if(gx%bmperr.eq.0) then + if(notent) then +! write(*,*)'Entering function: ',name1 +! entering a function may add new unentered functions ... last argument TRUE +! write(*,*)'3E Entering function 3: ',name1,len_trim(longline) +! lrot=0 + call enter_tpfun(name1,longline,lrot,.TRUE.) + if(gx%bmperr.ne.0) then +! one may have error here + write(*,*)'Failed entering function: ',name1 + goto 1000 + endif + if(ocv()) write(*,*)'Entered function: ',name1 + nofunent=nofunent+1 + endif + else +! reset error code + gx%bmperr=0 + endif + else + nl=nl+1 + read(21,110)line +! write(kou,101)'readtdb 2: ',nl,line(1:40) + call replacetab(line,nl) + longline=longline(1:jp)//line + goto 810 + endif + goto 100 +! endif barafun +!--------------------------------------------------------- +! We have now read all +!-------------------------------------------------------- +1000 continue + if(warning) then + write(kou,1003) +1003 format(/'There were warnings, continue?/Y/') + read(kiu,1004)ch1 +1004 format(a) + if(ch1.eq.'N') stop 'warnings reading database' + endif +! write(*,*)'3E At label 1000' + if(buperr.ne.0 .or. gx%bmperr.ne.0) then + if(gx%bmperr.eq.0) gx%bmperr=buperr + write(*,1002)gx%bmperr,nl +1002 format('Error ',i5', occured at TDB file line ',i7) +! write(*,*)'Do you want to continue at your own risk anyway?' +! read(*,1008)ch1 +!1008 format(a) +! if(ch1.eq.'Y') then +! write(*,*)'Now any kind of error may occur .... ' +! buperr=0 +! gx%bmperr=0 +! goto 100 +! endif + endif + close(21) +! read numbers, value after / is maximum +! endmember, interactions, property, +! tpfuns, composition sets, equilibria +! state variable functions, references, additions + if(ocv()) write(*,1007)noofel,maxel,noofsp,maxsp,noofph,maxph,& + noofem,100000,noofint,100000,noofprop,100000,& + notpf(),maxtpf,csfree-1,2*maxph,eqfree-1,maxeq,& + nsvfun,maxsvfun,reffree-1,maxrefs,addrecs,100000 +1007 format('Created records for elements, species, phases: ',2x,& + 3(i4,'/',i4,1x)/& + 'end members, interactions, properties: ',10x,& + 3(i4,'/',i4,1x)/& + 'TP-funs, composition sets, equilibria: ',10x,& + 3(i4,'/',i4,1x)/& + 'state variable functions, references, additions: ',& + 3(i4,'/',i4,1x)/) + return +1010 continue + write(*,*)'I/O error opening file: ',gx%bmperr + return +!----------------------------------------------------- +! end of file found, act differently if reading functions +2000 continue + rewind: if(dodis.eq.0 .and. disparttc.gt.0) then +! rewind to read disordred parts + write(*,*)'Rewind to read disordered parts of phases: ',disparttc + rewind(21) + dodis=1 + nl=0 + goto 100 + elseif(.not.onlyfun) then +! rewind to read referenced functions + dodis=2 + rewind(21) + onlyfun=.TRUE. + nofunent=0 +! write(*,2002)gx%bmperr +2002 format('Found end-of-file, rewind to find functions',i5) + nl=0 + goto 100 + elseif(nofunent.gt.0) then +! rewind if there were functions entered last time + rewind(21) + norew=norew+1 +! write(*,*)'Found functions: ',nofunent,' rewinding again',norew,gx%bmperr +! if(newfun.gt.0) then +! write(*,*)'Read ',newfun+nfail,' functions, entered ',newfun,& +! ' rewinding ',norew +! newfun=0 + nofunent=0 + nl=0 + goto 100 + else +! check if there are any unentered functions + call list_unentered_funs(kou,nr) + if(nr.gt.0) then + write(kou,*)'Number of missing function: ',nr + gx%bmperr=4186 + endif +! check if any function not entered + onlyfun=.FALSE. + endif rewind + goto 1000 +! end of file while looking for ! terminating a keyword +2200 continue + write(*,2210)nl,longline(1:72) +2210 format('End of file at ',i5,' looking for end of keyword:'/a) + gx%bmperr=7777 + goto 1000 + end subroutine readtdb + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine checktdb(filename,nel,selel) +! checking a TDB file exists and return the elements + implicit none + integer nel + character filename*(*),selel(*)*2 +!\end{verbatim} + character line*256 + integer ipp,nl,kk +! + if(.not.(index(filename,'.tdb').gt.0 & + .or. index(filename,'.TDB').gt.0)) then +! no extention provided + filename(len_trim(filename)+1:)='.TDB' + endif + open(21,file=filename,access='sequential',form='formatted',& + err=1010,iostat=gx%bmperr,status='old') +! just check for ELEMENT keywords +! return here to look for a new keyword, end-of-file OK here + nl=0 + nel=0 +100 continue + read(21,110,end=2000)line +110 format(a) + nl=nl+1 +! One should remove TAB characters !! ?? + ipp=1 + if(eolch(line,ipp)) goto 100 + if(line(ipp:ipp).eq.'$') goto 100 +! look for ELEMENT keyword, ipp=1 + ipp=istdbkeyword(line,kk) + if(ipp.ne.1) goto 100 +! +! ignore /- and VA + if(line(kk+1:kk+2).eq.'/-' .or. line(kk+1:kk+2).eq.'VA') goto 100 + nel=nel+1 + selel(nel)=line(kk+1:kk+2) +! write(*,111)nl,line(1:20) +!111 format('Read line ',i5,': ',a) + goto 100 +!--------- +1000 continue + return +! error +1010 continue + goto 1000 +! end of file +2000 continue + close(21) + goto 1000 + return + end subroutine checktdb + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!-\begin{verbatim} + subroutine gtpsavetm(filename,str) +! save all data on file in a modified TDB format. Also as macro and LaTeX +! header +! element list +! species list +! phase list with sublattices, endmembers, interactions and parameters etc +! tpfuns +! state variable functions +! references +! + implicit none + character*(*) filename,str +!-\end{verbatim} + logical tdbmode + if(str(1:1).eq.'T') then +! TDB file + tdbmode=.true. + else +! MACRO mode + tdbmode=.false. + endif + write(*,*)'TDB and MACRO save not implemented yet' + goto 1000 +! unfinished .... +! open file and write (either as TDB, MACRO or LaTeX): +! header +! element list +! species list +! phase list with sublattices, endmembers, interactions and parameters etc +! tpfuns +! state variable functions +! references +! +! For inspiration look at the LIST subroutines in pmod25E.F90 +! +1000 continue + return + end subroutine gtpsavetm +! +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ +! + diff --git a/models/pmod25C.F90 b/models/gtp3F.F90 similarity index 69% rename from models/pmod25C.F90 rename to models/gtp3F.F90 index 5956428..9c5e3fe 100644 --- a/models/pmod25C.F90 +++ b/models/gtp3F.F90 @@ -1,2435 +1,3042 @@ -! -! included in pmod25.F90 -! -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ -!> 7. State variable manipulations -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine get_state_var_value(statevar,value,encoded,ceq) -! called with a state variable character - implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq - character statevar*(*),encoded*(*) - double precision value -!\end{verbatim} -! integer indices(4) - integer iunit,ip,lrot,mode - type(gtp_state_variable), pointer :: svr - character actual_arg(2)*16,name*16 -! - iunit=0 - call decode_state_variable(statevar,svr,ceq) -! write(*,20)statevar(1:len_trim(statevar)),svr%oldstv,svr%norm,& -! svr%argtyp,svr%component -20 format('25C gsvv 1: ',a,' : ',4i3) - if(gx%bmperr.ne.0) then -! goto 1000 -! it can be a state variable symbol ... -! -! Possible problem ... this can cause nesting as a state variable will -! normally evaluate some state variables or other state variable functions -! - gx%bmperr=0 - name=statevar - call capson(name) - call find_svfun(name,lrot,ceq) - if(gx%bmperr.ne.0) then - write(*,*)'Neither state variable or symbol' - gx%bmperr=8888; goto 1000 - else -! get the value of the symbol, may involve other symbols and state variablse -! The actual_arg is a facility not yet implemented and not allowed here -! if mode=0 the stored value may be used, mode=1 always evaluate - actual_arg=' ' - mode=1 -! this is OK as no derivative - value=evaluate_svfun_old(lrot,actual_arg,mode,ceq) - encoded=name - endif - else -! it is a real state variable - call state_variable_val(svr,value,ceq) - if(gx%bmperr.ne.0) goto 1000 - ip=1 - call encode_state_variable(encoded,ip,svr,ceq) - if(gx%bmperr.ne.0) then - write(*,*)'encode error: ',gx%bmperr - gx%bmperr=0; encoded='dummy' - endif - endif -1000 continue - return - end subroutine get_state_var_value - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine get_many_svar(statevar,values,mjj,kjj,encoded,ceq) -! called with a state variable name with woldcards allowed like NP(*), X(*,CR) -! mjj is dimension of values, kjj is number of values returned -! encoded used to specify if phase data in phasetuple order ('Z') -! >>>> BIG problem: How to do with phases that are note stable? -! If I ask for w(*,Cr) I only want the fraction in stable phases -! but whenthis is used for GNUPLOT the values are written in a matix -! and the same column in that phase must be the same phase ... -! so I have to have the same number of phases from each equilibria. -! - implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq - character statevar*(*),encoded*(*) - double precision values(*) - integer mjj,kjj -!\end{verbatim} - integer indices(4),modind(4) - double precision xnan,xxx - integer jj,lokph,lokcs,k1,k2,k3,iref,jl,iunit,istv - type(gtp_state_variable), pointer :: svr -! logical phtupord -! calculate the NaN bit pattern - xnan=0.0d0 -! xnan=0.0d0/xnan - if(gx%bmperr.ne.0) then - write(*,*)'Error entering get_many_svar ',gx%bmperr,xnan - endif -!------------------------ - iunit=0 - modind=0 -! phtupord=.FALSE. -! if(encoded(1:1).eq.'Z') then -! when called from TQ interface the phase order should be as for phase tuples -! phtupord=.TRUE. -! endif -! called from minimizer for testing -! write(*,*)'gmv 1: ',statevar(1:20) -! call decode_state_variable(statevar,istv,indices,iref,iunit,svr,ceq) - call decode_state_variable(statevar,svr,ceq) - if(gx%bmperr.ne.0) then - write(*,*)'Failed decode statevar in get_many_svar',gx%bmperr - goto 1000 - endif -! translate svr data to old indices etc - istv=svr%oldstv - iref=svr%phref - iunit=svr%unit -! svr%argtyp specifies values in indices: -! svr%argtyp: 0=no arguments; 1=comp; 2=ph+cs; 3=ph+cs+comp; 4=ph+cs+const - indices=0 - if(svr%argtyp.eq.1) then - indices(1)=svr%component - elseif(svr%argtyp.eq.2) then - indices(1)=svr%phase - indices(2)=svr%compset - elseif(svr%argtyp.eq.3) then - indices(1)=svr%phase - indices(2)=svr%compset - indices(3)=svr%component - elseif(svr%argtyp.eq.4) then - indices(1)=svr%phase - indices(2)=svr%compset - indices(3)=svr%constituent -! else -! write(*,*)'state variable has illegal argtyp: ',svr%argtyp -! gx%bmperr=7775; goto 1000 - endif -! -! write(*,20)istv,indices,iref,gx%bmperr -20 format('gmsvar 1: ',i5,4i4,3i7) -! ----------------------------------------- -! Indices 1: one or all components (-1) -! Indices 2+3: 0 or phase+set -! Indices 1+2: phase+set -! Indices 3: 0 or component (-1) or constituent (-2) -! indices 4 never used -! ----------------------------------------- -! -1 means element or component -! -2 species or constituent -! -3 phase -! -4 composition set - jj=0 - if(indices(1).ge.0) then - if(indices(2).ge.0) then - if(indices(3).ge.0) then -! all indices given, a single value - jj=jj+1 - if(jj.gt.mjj) goto 1100 - call state_variable_val3(istv,indices,iref,& - iunit,values(jj),ceq) - if(gx%bmperr.ne.0) goto 1000 - elseif(indices(3).eq.-1) then -! loop for components, indices 1+2 must be phase+compset - do k3=1,noofel - indices(3)=k3 - jj=jj+1 - if(jj.gt.mjj) goto 1100 - call state_variable_val3(istv,indices,iref,& - iunit,values(jj),ceq) - if(gx%bmperr.ne.0) goto 1000 - enddo - elseif(indices(3).eq.-2) then -! loop for constituents, indices 1+2 must be phase+compset - call get_phase_record(indices(1),lokph) - do k3=1,phlista(lokph)%tnooffr - indices(3)=k3 - jj=jj+1 - if(jj.gt.mjj) goto 1100 - call state_variable_val3(istv,indices,iref,& - iunit,values(jj),ceq) - if(gx%bmperr.ne.0) goto 1000 - enddo - else -! indices(3) must be -2, -1 or >=0 so if we are here there is an error - write(*,17)'Illegal set of indices 1',(indices(jl),jl=1,4) -17 format(a,4i4) - gx%bmperr=7777; goto 1000 - endif - elseif(indices(2).eq.-3) then -! if indices(1)>=0 then indices(2)<0 must means a loop for all phase+compset - do k2=1,noofph - indices(2)=k2 - call get_phase_record(indices(2),lokph) - do k3=1,phlista(lokph)%noofcs - indices(3)=k3 - jj=jj+1 - if(jj.gt.mjj) goto 1100 - call get_phase_compset(indices(2),indices(3),lokph,lokcs) -! if composition set not stable so return NaN -! if(test_phase_status(indices(2),indices(3),xxx,ceq).ge.2) then - if(test_phase_status(indices(2),indices(3),xxx,ceq).le. & - PHENTUNST) then - values(jj)=xnan -! elseif(.not.btest(ceq%phase_varres(lokcs)%status2,& -! CSSTABLE)) then -! values(jj)=xnan - elseif(ceq%phase_varres(lokcs)%dgm.lt.zero) then -! the phase must not have negative driving force - values(jj)=xnan - else -! problem that get_many returns values for unstable phases - call state_variable_val3(istv,indices,iref,& - iunit,values(jj),ceq) - if(gx%bmperr.ne.0) goto 1000 -! write(*,23)'25C many 1: ',indices,values(jj),& -! ceq%phase_varres(lokcs)%dgm -23 format(a,2i3,2(1pe14.6)) - endif - enddo - enddo - else -! if indices(1)>=0 then indices(2) must be -3 or >=0, so if here it is error - write(*,17)'Illegal set of indices 2',(indices(jl),jl=1,4) - gx%bmperr=7777; goto 1000 - endif - elseif(indices(1).eq.-1) then -! loop for component as first indices, 2+3 can be fix phase+compset - if(indices(2).ge.0) then - do k1=1,noofel - indices(1)=k1 - jj=jj+1 - if(jj.gt.mjj) goto 1100 - call state_variable_val3(istv,indices,iref,& - iunit,values(jj),ceq) - if(gx%bmperr.ne.0) goto 1000 - enddo - elseif(indices(2).eq.-3) then -! loop for components and phase+compset - do k1=1,noofel - indices(1)=k1 - do k2=1,noofph - indices(2)=k2 - call get_phase_record(indices(2),lokph) - do k3=1,phlista(lokph)%noofcs - indices(3)=k3 - jj=jj+1 - if(jj.gt.mjj) goto 1100 - call get_phase_compset(indices(2),indices(3),lokph,lokcs) -! if composition not stable so return NaN - if(test_phase_status(indices(2),indices(3),xxx,ceq).le. & - PHENTSTAB) then - values(jj)=xnan -! elseif(.not.btest(ceq%phase_varres(lokcs)%status2,& -! CSSTABLE)) then -! values(jj)=xnan - elseif(ceq%phase_varres(lokcs)%dgm.lt.zero) then -! the phase must not have negative driving force - values(jj)=xnan - else - call state_variable_val3(istv,indices,iref,& - iunit,values(jj),ceq) - if(gx%bmperr.ne.0) goto 1000 -! write(*,23)'25C many 2: ',indices(1),indices(2),& -! values(jj),ceq%phase_varres(lokcs)%dgm - endif - enddo - enddo - enddo - else -! if we come here it must be an error - write(*,17)'Illegal set of indices 3',(indices(jl),jl=1,4) - gx%bmperr=7777; goto 1000 - endif - elseif(indices(1).eq.-3) then -! loop for phase+compset as indices(1+2) -! here we must be careful not to destroy original indices, use modind -! write(*,*)'get_many NP(*) 1: ',gx%bmperr,indices(3) -! write(*,*)'Loop for many phases',indices(1) - do k1=1,noofph - modind(1)=k1 - modind(2)=0 - call get_phase_record(modind(1),lokph) -! write(*,19)'test 17',modind,gx%bmperr,xnan - if(gx%bmperr.ne.0) goto 1000 - do k2=1,phlista(lokph)%noofcs - modind(2)=k2 - jj=jj+1 - if(jj.gt.mjj) goto 1100 - call get_phase_compset(modind(1),modind(2),lokph,lokcs) -! write(*,19)'test 2: ',modind,gx%bmperr,xnan -19 format(a,4i3,i7,1pe12.4) - if(gx%bmperr.ne.0) goto 1000 - call get_phase_compset(modind(1),modind(2),lokph,lokcs) - if(gx%bmperr.ne.0) then -! write(*,19)'error 2',modind,gx%bmperr - goto 1000 - endif - if(test_phase_status(modind(1),modind(2),xxx,ceq).le. & - PHENTUNST) then -! if phase not entered or fix return NaN - values(jj)=xnan - else - if(indices(3).eq.0) then -! This is typically listing of NP(*) for all phases - modind(3)=indices(3) -! write(*,16)16,(modind(i),i=1,4),gx%bmperr -!16 format('bug: ',i3,4i5,i7) - call state_variable_val3(istv,modind,iref,& - iunit,values(jj),ceq) -! write(*,*)'get_many NP(*): 2',gx%bmperr - if(gx%bmperr.ne.0) goto 1000 - elseif(ceq%phase_varres(lokcs)%phstate.lt.PHENTSTAB) then -! elseif(.not.btest(ceq%phase_varres(lokcs)%status2,& -! CSSTABLE)) then -! if wildcard for index 3 the phase must be stable -! write(*,*)'Not stable: ',modind(1),modind(2),& -! ceq%phase_varres(lokcs)%phstate - values(jj)=xnan - elseif(indices(3).gt.0) then -! This is typically listing of w(*,cr), only in stable range of phases - modind(3)=indices(3) -! write(*,16)16,(modind(i),i=1,4),gx%bmperr -!16 format('bug: ',i3,4i5,i7) - call get_phase_compset(modind(1),modind(2),lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 -! write(*,23)'25C many 3: ',modind(1),modind(2),values(jj),& -! ceq%phase_varres(lokcs)%dgm - if(ceq%phase_varres(lokcs)%dgm.lt.zero) then -! the phase must not have negative driving force - values(jj)=xnan - else - call state_variable_val3(istv,modind,iref,& - iunit,values(jj),ceq) - endif - if(gx%bmperr.ne.0) goto 1000 - elseif(indices(3).eq.-1) then -! loop for components of all phases - do k3=1,noofel - modind(3)=k3 - call state_variable_val3(istv,modind,iref,& - iunit,values(jj),ceq) - if(gx%bmperr.ne.0) goto 1000 - enddo - elseif(indices(3).eq.-2) then -! loop for constituents of all phases - do k3=1,phlista(lokph)%tnooffr - modind(3)=k3 - call state_variable_val3(istv,modind,iref,& - iunit,values(jj),ceq) - if(gx%bmperr.ne.0) goto 1000 - enddo - else -! error if here - write(*,17)'Illegal set of indices 4',(indices(jl),jl=1,4) - gx%bmperr=7777; goto 1000 - endif - if(gx%bmperr.ne.0) then - write(*,19)'error 3',modind,gx%bmperr - goto 1000 - endif - endif - enddo - enddo - else -! error if here - write(*,17)'Illegal set of indices 5',(indices(jl),jl=1,4) - gx%bmperr=7777; goto 1000 - endif -! ip=1 -! call encode_state_variable(encoded,ip,istv,indices,iunit,iref,ceq) -! if(gx%bmperr.ne.0) then -! write(*,*)'encode error: ',gx%bmperr -! gx%bmperr=0; encoded='dummy' -! endif -1000 continue - kjj=jj - return -1100 continue - write(*,*)'Overflow in array to get_state_variables' - gx%bmperr=7777; goto 1000 - end subroutine get_many_svar - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine decode_state_variable(statevar,svr,ceq) -! converts a state variable character to state variable record - character statevar*(*) - type(gtp_state_variable), pointer :: svr - type(gtp_equilibrium_data), pointer :: ceq -! this subroutine using state variable records is a front end of the next: -!\end{verbatim} %+ -! type(gtp_state_variable) :: svrec - integer istv,indices(4),iref,iunit - call decode_state_variable3(statevar,istv,indices,iref,iunit,svr,ceq) -1000 continue - return - end subroutine decode_state_variable - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine decode_state_variable3(statevar,istv,indices,iref,iunit,svr,ceq) -! converts an old state variable character to indices -! Typically: T, x(fe), x(fcc,fe), np(fcc), y(fcc,c#2), ac(h2,bcc), ac(fe) -! NOTE! model properties like TC(FCC),MQ&FE(FCC,CR) must be detected -! NOTE: added storing information in a gtp_state_variable record svrec !! -! -! this routine became as messy as I tried to avoid -! but I leave it to someone else to clean it up ... -! -! state variable and indices -! Symbol no index1 index2 index3 index4 -! T 1 - -! P 2 - -! MU 3 component or phase,constituent -! AC 4 component or phase,constituent -! LNAC 5 component or phase,constituent -! index (in svid array) -! U 10 (phase#set) 6 Internal energy (J) -! UM 11 " 6 per mole components -! UW 12 " 6 per kg -! UV 13 " 6 per m3 -! UF 14 " 6 per formula unit -! S 2x " 7 entropy -! V 3x " 8 volume -! H 4x " 9 enthalpy -! A 5x " 10 Helmholtz energy -! G 6x " 11 Gibbs energy -! NP 7x " 12 moles of phase -! BP 8x " 13 mass of moles -! DG 9x " 15 Driving force -! Q 10x " 14 Internal stability -! N 11x (component/phase#set,component) 16 moles of components -! X 111 " 17 mole fraction of components -! B 12x " 18 mass of components -! W 122 " 19 mass fraction of components -! Y 13 phase#set,constituent#subl 20 constituent fraction -!----- model variables <<<< these now treated differently -! TC - phase#set - Magnetic ordering T -! BMAG - phase#set - Aver. Bohr magneton number -! MQ& - element, phase#set - Mobility -! THET - phase#set - Debye temperature -! - implicit none - integer, parameter :: noos=20 - character*4, dimension(noos), parameter :: svid = & - ['T ','P ','MU ','AC ','LNAC','U ','S ','V ',& - 'H ','A ','G ','NP ','BP ','DG ','Q ','N ',& - 'X ','B ','W ','Y '] -! 1 2 3 4 4 6 7 8 - character statevar*(*) - integer istv,iref,iunit - integer, dimension(4) :: indices - type(gtp_equilibrium_data), pointer :: ceq -! I shall try to use this record type instead of separate arguments: !! -! type(gtp_state_variable), pointer :: svrec - type(gtp_state_variable), pointer :: svr -!\end{verbatim} -! type(gtp_state_variable), allocatable, target :: svr - integer is,jp,kp,iph,ics,icon,icomp,norm,narg,icc - double precision cmass,asum -! - character argument*60,arg1*24,arg2*24,ch1*1,lstate*60,propsym*60 - integer typty - logical deblist -! initiate svr internal variables - deblist=.FALSE. -! deblist=.TRUE. - if(ocv()) deblist=.TRUE. - if(deblist) write(*,*)'25C entering decode_statevariable: ',& - statevar(1:len_trim(statevar)) -! write(*,*)'25C svr allocated' - allocate(svr) -! write(*,*)'25C svr assignment start' - svr%oldstv=0 - svr%norm=0 - svr%unit=0 -! svr%argtyp: 0=no arguments; 1=comp; 2=ph+cs; 3=ph+cs+comp; 4=ph+cs+const - svr%argtyp=0 - svr%phref=0 - svr%phase=0 - svr%compset=0 - svr%component=0 - svr%constituent=0 -! write(*,*)'25C svr assignment end' -! -! For wildcard argument "*" return: -! -1 for element or component -! -2 for species or constituent -! -3 for phase -! -4 for composition set - istv=-1 - indices=0 - iref=0 - iunit=0 - iph=0 - ics=0 - norm=0 -! local character for state variable - lstate=statevar - call capson(lstate) - if(deblist) write(*,*)'25C decode_state_var 1: ',lstate(1:20) -! compare first character - ch1=lstate(1:1) - do is=1,noos - if(ch1.eq.svid(is)(1:1)) goto 50 - enddo -! it may be a property, parameter identifier - goto 600 -!------------------------------------------------------------ -50 continue - if(deblist) write(*,*)'25C dsv 1: ',is,lstate(1:30) - if(is.eq.1) then - if(lstate(2:2).ne.' ') then -! it must be a property like TC or THET - goto 600 - endif -! T - istv=1; svr%oldstv=1; svr%statevarid=1; goto 1000 - elseif(is.eq.2) then -! P - if(lstate(2:2).ne.' ') goto 600 - istv=2; svr%oldstv=2; svr%statevarid=2; goto 1000 - elseif(is.gt.5) then - goto 100 - endif -!------------------------------------------------------------ -! MU 3 component, possible suffix S for SER reference - chemp: if(is.eq.3) then - if(lstate(1:2).ne.'MU') then - goto 600 - endif - istv=3 - jp=3 - elseif(is.eq.4) then -! AC is 4 but just A or AM, AV etc can mean Helmholtz Energy or a property - if(lstate(1:2).ne.'AC') then - is=8; goto 100 - endif - istv=4 - jp=3 - elseif(is.eq.5) then -! LNAC 5 component - if(lstate(1:4).ne.'LNAC') goto 600 - istv=5 - jp=5 - endif chemp -! MU, AC and LNAC can have a suffix 'S', reference state, iref=0 is default - if(lstate(jp:jp).eq.'S') then -! This iref has not been treated correctly so far. The idea is now that -! iref=0 means user defined reference state, if the user has not defined any -! reference state it means SER. If the user specifies a suffix S it means -! always SER even if the user has defined another reference state. -! Maybe iref>0 will have some other meaing in the future ... - iref=-1 - jp=jp+1 - endif -! extract the argument, can be one or two indices - svr%oldstv=istv; svr%statevarid=istv - if(lstate(jp:jp).ne.'(') goto 1130 - kp=index(lstate,')') - if(kp.lt.jp) goto 1140 - argument=lstate(jp+1:kp-1) - kp=index(argument,',') - if(kp.gt.0) then -! >>> if two arguments first is phase ??? different from TC - arg1=argument(1:kp-1) - arg2=argument(kp+1:) - if(arg1(1:2).eq.'* ') then - iph=-3 - else - call find_phase_by_name(arg1,iph,ics) - if(gx%bmperr.ne.0) goto 1150 - endif - if(arg2(1:2).eq.'* ') then - icon=-2 - else - call find_constituent(iph,arg2,cmass,icon) - if(gx%bmperr.ne.0) goto 1160 - call set_constituent_reference_state(iph,icon,asum) - if(gx%bmperr.ne.0) then - gx%bmperr=4112; goto 1000 - endif - endif -! composition set irrelevant as chempot depend only on species stoichiometry - indices(1)=iph - indices(2)=icon - svr%phase=iph - svr%compset=1 - svr%constituent=icon - svr%argtyp=4 - else - if(argument(1:2).eq.'* ') then - icomp=-1 - else - call find_component_by_name(argument,icomp,ceq) - if(gx%bmperr.ne.0) goto 1170 - endif - indices(1)=icomp - svr%component=icomp - svr%argtyp=1 - endif - goto 1000 -!================================================================= -! extensive variable, is=6..20 or a model property -100 continue - jp=2 -! check second letter for some state variables - if(deblist) write(*,105)is,norm,jp -105 format('25C dsv 4: ',3i4) - letter2: if(is.eq.12 .and. lstate(jp:jp).ne.'P') then -! This is for Nx or a property - is=16 - elseif(is.eq.13) then -! this can be Bx for component, BP for phase or BMAG for Bohr magnetons - if(lstate(jp-1:jp).eq.'BP') then - jp=jp+1 - else -! this is Bx or a property - is=18 - endif - elseif(is.eq.14 .and. lstate(jp-1:jp).ne.'DG') then -! this is for Dx, can be a property -! gx%bmperr=4107; goto 1000 - goto 600 - elseif(is.eq.12 .or. is.eq.14) then -! This is NP or DG, increment jp to check the second character - jp=jp+1 - elseif(is.eq.17 .or. is.eq.19) then -! X and W can have a suffix % to indicate percentage - if(lstate(jp:jp).eq.'%') then - iunit=100 - jp=jp+1 - svr%unit=iunit - endif - endif letter2 -!--------------------------------------------------------------------- -! If we come here the first (and sometimes second) letter must have been: -! A, B, BP, D, G, H, N, NP, Q, S, U, W, X, Y -! and "is" is 10, 18, 13, 14, 11, 9, 16, 12, 15, 7, 6, 19, 17, 20 -! NOTE: for N and B the second character has been checked and jp incremented -! if equal to P. The third (for NP and BP forth) character must -! be normallizing (MWVF), a space or a (, otherwise it is a property - if(deblist) write(*,*)'25C lstate: ',lstate(1:20) -! these have no normalizing: Q, X, W, Y - nomalize: if(is.le.14 .or. is.eq.16 .or. is.eq.18) then -! ZM x1 (phase) per mole components -! ZW x2 (phase) per kg -! ZV x3 (phase) per m3 -! ZF x4 phase must be specified per formula unit - ch1=lstate(jp:jp) - jp=jp+1 - if(ch1.eq.'M') then - norm=1 - elseif(ch1.eq.'W') then - norm=2 - elseif(ch1.eq.'V') then - norm=3 - elseif(ch1.eq.'F') then - norm=4 - else -! no or default normalization, backspace - jp=jp-1 - endif - svr%norm=norm - if(deblist) write(*,*)'25C Normalize 1: ',is,jp,ch1,norm - endif nomalize -!--------------------------------------------------------------------- -! extract arguments if any. If arguments then lstate(jp:jp) should be ( -! Typically G(fcc#2), N(Cr), BP(fcc), Y(sigma#2,cr#3), TC(BCC#2) -!300 continue - if(deblist) write(*,*)'25C args: ',jp,lstate(1:jp+10) - narg=0 - args: if(lstate(jp:jp).eq.'(') then - kp=index(lstate,')') - if(kp.le.0) then - if(deblist) write(*,110)'25C dsv 5: ',is,jp,kp,lstate(1:20) -110 format(a,3i3,a) - gx%bmperr=4103; goto 1000 - endif - argument=lstate(jp+1:kp-1) - kp=index(argument,',') - arg: if(kp.gt.0) then - arg1=argument(1:kp-1) - arg2=argument(kp+1:) - narg=2 - kp=index(arg2,',') - if(kp.gt.0) then -! too many arguments to a state variable - gx%bmperr=4097; goto 1000 - endif - else !no arg - narg=1 - arg1=argument - endif arg - elseif(lstate(jp:jp).ne.' ') then -! if additional character then it must be a property - goto 600 - endif args -!------------------ -! transform arguments to indices, different arguments for 6- -! Handle arguments: U, S, V, H, A, G, NP, BP,DG, Q, N, X, B, W, Y -! 6, 7, 8, 9,10, 11,12, 13,14,15,16,17,18,19,20 - if(narg.eq.1) then - if(is.le.15 .or. is.ge.21) then -! single argument is phase+composition set - if(arg1(1:2).eq.'* ') then - iph=-3 - ics=-4 - else - call find_phase_by_name(arg1,iph,ics) - if(gx%bmperr.ne.0) goto 1000 - endif - indices(1)=iph - indices(2)=ics - svr%phase=iph - svr%compset=ics - svr%argtyp=2 - elseif(is.eq.20) then -! state variable Y must have 2 arguments - gx%bmperr=4098; goto 1000 - else -! single argument is component for is=16-19 - if(arg1(1:2).eq.'* ') then - icomp=-1 - else - call find_component_by_name(arg1,icomp,ceq) - if(gx%bmperr.ne.0) goto 1000 - endif - indices(1)=icomp - svr%component=icomp - svr%argtyp=1 - endif - elseif(narg.eq.2) then -! two arguments only for is=16-20, first phase, second component or constit - if(is.le.15 .or. is.ge.21) then - gx%bmperr=4110; goto 1000 - endif - if(arg1(1:2).eq.'* ') then - iph=-3 - ics=-4 - else - call find_phase_by_name(arg1,iph,ics) - if(gx%bmperr.ne.0) goto 1000 - endif - indices(1)=iph - indices(2)=ics - svr%phase=iph - svr%compset=ics - if(is.eq.20) then - if(arg2(1:2).eq.'* ') then - icc=-2 - else - call find_constituent(iph,arg2,cmass,icc) - if(gx%bmperr.ne.0) goto 1000 - endif - svr%constituent=icc - svr%argtyp=4 - else - if(arg2(1:2).eq.'* ') then - icc=-1 - else - call find_component_by_name(arg2,icc,ceq) - if(gx%bmperr.ne.0) goto 1000 - endif - svr%component=icc - svr%argtyp=3 - endif -! note indices(4) never used as icc is constituent index, arg2 must have -! a #sublattice to find the correct, otherwise always the first occurence -! In a sigma (Fe)(Cr)(Cr,Fe) y(sigma,cr)=1 but y(sigma,cr#3) gives Cr in third - indices(3)=icc - elseif((is.ge.12 .and. is.le.15) .or. is.eq.17 .or. is.ge.19) then -! There must be an argument for NP, BP, DG, Q, X, W, Y, TC and BMAG - gx%bmperr=4111; goto 1000 - elseif(norm.eq.4) then -! there must be a phase specification for a quantity per formula unit - gx%bmperr=4115; goto 1000 - endif -! if(is.eq.17 .or. is.eq.19) then -! is=is-1 -! svr%norm=1 - if(is.eq.16) svr%norm=1 - if(is.eq.18) svr%norm=2 -! endif -!----------------------- -500 continue -!----------------------------------------------------------------------- -! U 1x (phase,composition set) Internal energy (J) -! S 2x entropy -! V 3x volume -! H 4x enthalpy -! A 5x Helmholtz energy -! G 6x Gibbs energy -! NP 7x phase moles of phase -! BP 8x phase mass of phase -! N 9x (component/phase,component) moles >>14 -! X 9x component/phase,component mole fraction >>15 -! B 10x (component/phase,component) mass >>16 -! W 10x mass fraction >>17 -! Y 11 phase,constituent#sublattice constituent fraction >>18 -! Q 12 Internal stability >>19 -! DG 13x Driving force -! TC, BM, MQ& etc (model variables) - svr%statevarid=is - extensive: if(is.eq.6) then -! U 1x (phase) Internal energy (J) - istv=10+norm - elseif(is.eq.7) then -! S 2x entropy - istv=20+norm - elseif(is.eq.8) then -! V 3x volume - istv=30+norm - elseif(is.eq.9) then -! H 4x enthalpy - istv=40+norm - elseif(is.eq.10) then -! A 5x Helmholtz energy - istv=50+norm - elseif(is.eq.11) then -! G 6x Gibbs energy - istv=60+norm - elseif(is.eq.12) then -! NP 7x phase moles of phase - istv=70+norm - elseif(is.eq.13) then -! BP 8x phase mass of phase - istv=80+norm - elseif(is.eq.14) then -! DG 9x Driving force - istv=90+norm - elseif(is.eq.15) then -! Q 10x Internal stability - istv=100+norm - elseif(is.eq.16 .or. is.eq.17) then -! N 11x (component/phase,component) moles -! X=NM 111 mole fraction -! X% 111, iunit=100 mole percent - if(is.eq.16) then - istv=110+norm - else - istv=111 - endif - elseif(is.eq.18 .or. is.eq.19) then -! B 12x (component/phase,component) mass -! W=BW 122 mass fraction -! W% 122, iunit=100 mass percent - if(is.eq.18) then - istv=120+norm - else - istv=122 - endif - elseif(is.eq.20) then -! Y 130 phase#comp.set,constituent#sublat constituent fraction - istv=130 - else -! the symbol may be a property - if(deblist) write(*,*)'maybe a property ',is - goto 600 - endif extensive - goto 1000 -!------------------------------------------------ -! handling of properties like TC, BMAGN, MQ etc -600 continue -! the symbol may be a property symbol - propsym=statevar -! second argument 0 means a symbol - call find_defined_property(propsym,0,typty,iph,ics) - if(deblist) write(*,*)'25C at 600: ',propsym(1:len_trim(propsym)),typty - if(gx%bmperr.ne.0) then - svr%oldstv=-1; goto 1000 - endif - indices(1)=iph - indices(2)=ics - svr%phase=iph - svr%compset=ics -!----------------------------- unfinished ????? - if(typty.gt.100) then -! typty: third argument is constituent (or component??) - istv=-typty/100 - indices(3)=typty+100*istv - svr%argtyp=4 - elseif(typty.gt.1) then - istv=-typty - svr%argtyp=3 - svr%argtyp=2 - else -! unknown propery - write(*,*)'Unknown state variable or property',typty - gx%bmperr=7777; goto 1000 - endif - svr%oldstv=istv - svr%statevarid=istv - svr%constituent=indices(3) - if(deblist) write(*,611)'Property: ',is,istv,typty,indices -611 format(a,10i4) -!------------------------------------------------ -1000 continue -! accept the current istv as svr%oldstv, store a suffix S on MU as phref<0 - svr%oldstv=istv - svr%phref=iref - if(deblist) write(*,1001)'25C exit decode: ',istv,(indices(is),is=1,4),& - norm,iref,iunit,svr%oldstv,svr%phase,svr%compset,svr%component,& - svr%constituent,svr%norm,svr%phref,svr%unit,svr%argtyp,& - svr%statevarid,gx%bmperr -1001 format(a,i5,4i3,2x,3i5/17x,i5,4i3,2x,6i5) - return -!---------------- errors ------------------------------- -! Wrong first character of state variable -1100 continue - gx%bmperr=4099; goto 1000 -! M not followed by U -!1110 continue -! gx%bmperr=4100; goto 1000 -! L not followed by NAC -!1120 continue -! gx%bmperr=4101; goto 1000 -! No opening ( for arguments -1130 continue - gx%bmperr=4102; goto 1000 -! No closing ) for arguments -1140 continue - gx%bmperr=4103; goto 1000 -! Unknown phase used as argument in state variable -1150 continue - gx%bmperr=4104; goto 1000 -! No such constituent -1160 continue - gx%bmperr=4105; goto 1000 -! No such component -1170 continue - gx%bmperr=4106; goto 1000 - end subroutine decode_state_variable3 - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine calc_phase_molmass(iph,ics,xmol,wmass,totmol,totmass,amount,ceq) -! calculates mole fractions and mass fractions for a phase#set -! xmol and wmass are fractions of components in mol or mass -! totmol is total number of moles and totmass total mass of components. -! amount is number of moles of components per formula unit. - implicit none - TYPE(gtp_equilibrium_data) :: ceq - integer iph,ics - double precision, dimension(*) :: xmol,wmass - double precision amount,totmol,totmass -!\end{verbatim} - integer ic,jc,lokph,lokcs,ll,iel,lokel,ie,kk,loksp - double precision as,yz,xsum,wsum - double precision, dimension(maxel) :: x2mol,w2mass -! - do ic=1,noofel - xmol(ic)=zero - wmass(ic)=zero - enddo - call get_phase_compset(iph,ics,lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 - ic=0 -! -! bug here when calculating Cr-Fe because we create new composition set ... - if(ocv()) write(*,14)'25c cpm: ',iph,ics,lokph,lokcs -14 format(a,10i5) - allsubl: do ll=1,phlista(lokph)%noofsubl - as=ceq%phase_varres(lokcs)%sites(ll) - allcons: do kk=1,phlista(lokph)%nooffr(ll) - ic=ic+1 - if(.not.btest(ceq%phase_varres(lokcs)%constat(ic),CONSUS)) then - yz=ceq%phase_varres(lokcs)%yfr(ic) - loksp=phlista(lokph)%constitlist(ic) -! isq just for debug output -! isq=splista(loksp)%alphaindex -! write(*,11)'cpm 3: ',lokph,lokcs,loksp,splista(loksp)%noofel -!11 format(a,5i3) - do iel=1,splista(loksp)%noofel - lokel=splista(loksp)%ellinks(iel) - ie=ellista(lokel)%alphaindex - if(ie.ne.0) then - xmol(ie)=xmol(ie)+& - as*yz*splista(loksp)%stoichiometry(iel) - endif - enddo -! if(ie.gt.0) then -! write(*,711)ic,loksp,isq,lokel,ie,yz,xmol(ie) -! else -! write(*,711)ic,loksp,isq,lokel,ie,yz -! endif -!711 format('cpmm: ',5i9,2F7.4) - endif - enddo allcons - enddo allsubl -! normallize, All ok here -! write(*,713)'A',noofel,(xmol(iq),iq=1,noofel) -713 format('25c x:',a,i2,10f7.4) -!800 continue - xsum=zero - wsum=zero -! here xmol(i) is equal to the number of moles of element i per formula unit -! set wmass(i) to the mass of of element i per mole formula unit and sum - do ic=1,noofel - wmass(ic)=xmol(ic)*ellista(elements(ic))%mass - xsum=xsum+xmol(ic) - wsum=wsum+wmass(ic) - enddo -! write(*,713)'F',noofel,xsum,(xmol(iq),iq=1,noofel) - do ic=1,noofel - xmol(ic)=xmol(ic)/xsum - wmass(ic)=wmass(ic)/wsum - enddo -! This is the current number of formula unit of the phase, zero if not stable - amount=ceq%phase_varres(lokcs)%amfu -! ceq%phase_varres(lokcs)%abnorm(1) is moles atoms for one formula unit -! ceq%phase_varres(lokcs)%abnorm(2) is mass for one formula unit - totmol=amount*xsum - totmass=amount*wsum -! write(*,713)'G',noofel,totmol,totmass,amount -! all seems OK here -! write(*,811)xsum,ceq%phase_varres(lokcs)%abnorm(1),& -! wsum,ceq%phase_varres(lokcs)%abnorm(2),amount,totmass -! write(*,811)xsum,ceq%phase_varres(lokcs)%abnorm(1),& -! wsum,ceq%phase_varres(lokcs)%abnorm(2),amount,totmass -811 format('cphmm: ',6(1pe12.4)) -! write(*,*)'cpmm: ',totmol,totmass -! all calculation so far in elements, convert to current components -! NOTE: sum of mole fractions can be zero or negative with other -! components than elements -76 format(a,10F7.4) -78 format(a,2i3,3(1PE12.4)) -! do ic=1,noofel -! write(*,298)(ceq%invcompstoi(jc,ic),jc=1,noofel) -! enddo -!298 format('25C: ',6(1pe12.4)) - goto 1000 -! what is this ... converting to user defined components ... (not implemented) - x2mol=zero - w2mass=zero - do ic=1,noofel - do jc=1,noofel - x2mol(ic)=x2mol(ic)+ceq%invcompstoi(jc,ic)*xmol(jc) -! write(*,78)'addon: ',ic,jc,x2mol(ic),ceq%invcompstoi(jc,ic),xmol(jc) - w2mass(ic)=w2mass(ic)+ceq%invcompstoi(ic,jc)*wmass(jc) - enddo - enddo -! do ic=1,noofel -! write(*,99)'ci: ',(ceq%invcompstoi(jc,ic),jc=1,noofel) -! enddo -99 format(a,7e11.3) -! write(*,76)'cmm2: ',(x2mol(ic),ic=1,noofel) - do ic=1,noofel - xmol(ic)=x2mol(ic) - wmass(ic)=w2mass(ic) - enddo -! something wrong between writing label 713 above and here !!!!!!!!!!!!! -! write(*,713)'B',noofel,(xmol(iq),iq=1,noofel) -1000 continue - return - end subroutine calc_phase_molmass - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine calc_phase_mol(iph,xmol,ceq) -! calculates mole fractions for phase iph, compset 1 in equilibrium ceq -! used for grid generation and some other things -! returns current constitution in xmol equal to mole fractions of components - implicit none - integer iph - double precision xmol(*) - TYPE(gtp_equilibrium_data) :: ceq -!\end{verbatim} - integer ic,lokph,lokcs,ll,kk,loksp,lokel,iel,ie - double precision as,yz,xsum - do ic=1,noofel - xmol(ic)=zero - enddo - lokph=phases(iph) - lokcs=phlista(lokph)%linktocs(1) - ic=0 - allsubl: do ll=1,phlista(lokph)%noofsubl - as=ceq%phase_varres(lokcs)%sites(ll) - allcons: do kk=1,phlista(lokph)%nooffr(ll) - ic=ic+1 - if(.not.btest(ceq%phase_varres(lokcs)%constat(ic),CONSUS)) then - yz=ceq%phase_varres(lokcs)%yfr(ic) - loksp=phlista(lokph)%constitlist(ic) - do iel=1,splista(loksp)%noofel - lokel=splista(loksp)%ellinks(iel) - ie=ellista(lokel)%alphaindex - if(ie.ne.0) then - xmol(ie)=xmol(ie)+& - as*yz*splista(loksp)%stoichiometry(iel) - endif - enddo - endif - enddo allcons - enddo allsubl -! normallize - xsum=zero - do ic=1,noofel - xsum=xsum+xmol(ic) - enddo - do ic=1,noofel - xmol(ic)=xmol(ic)/xsum - enddo -1000 continue - return - end subroutine calc_phase_mol - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine calc_molmass(xmol,wmass,totmol,totmass,ceq) -! summing up N and B for each component over all phases with positive amount -! Check that totmol and totmass are correct .... - implicit none - double precision, dimension(*) :: xmol,wmass - double precision totmol,totmass - TYPE(gtp_equilibrium_data) :: ceq -!\end{verbatim} - double precision am,amult,tmol,tmass - double precision, dimension(maxel) :: xph,wph - integer ic,iph,lokph,ics,lokcs - do ic=1,noofel - xmol(ic)=zero - wmass(ic)=zero - enddo - totmol=zero - totmass=zero - allph: do iph=1,noofph - lokph=phases(iph) - if(.not.btest(phlista(lokph)%status1,phhid)) then - allcs: do ics=1,phlista(lokph)%noofcs - lokcs=phlista(lokph)%linktocs(ics) -! ceq%phase_varres(lokcs)%amfu is current number of formula units -! ceq%phase_varres(lokcs)%abnorm(1) is number of real atoms in a formula unit - am=ceq%phase_varres(lokcs)%amfu*& - ceq%phase_varres(lokcs)%abnorm(1) - if(am.gt.zero) then - call calc_phase_molmass(iph,ics,xph,wph,tmol,tmass,amult,ceq) - if(gx%bmperr.ne.0) goto 1000 -! write(*,17)'25c amult:',iph,ics,am,amult,tmol,tmass -! write(*,18)'25c x0: ',(xph(ic),ic=1,noofel) -! write(*,18)'25c w0: ',(wph(ic),ic=1,noofel) -17 format(a,2i4,6(1pe14.6)) -18 format(a,8(F9.5)) - do ic=1,noofel - xmol(ic)=xmol(ic)+am*xph(ic) - wmass(ic)=wmass(ic)+tmass*wph(ic) - enddo - totmass=totmass+tmass - totmol=totmol+tmol - endif - enddo allcs - endif - enddo allph -! we have summed the number of moles and mass of all elements in all phases -! xsum=zero -! wsum=zero -! do ic=1,noofel -! xsum=xsum+xmol(ic) -! wsum=wsum+wmass(ic) -! enddo -! write(*,21)'25C x1: ',xsum,totmol,(xmol(ic),ic=1,noofel) -! write(*,21)'25C w2: ',wsum,totmass,(wmass(ic),ic=1,noofel) -!21 format(a,2(1pe12.4),10(0pF9.4)) - if(totmass.gt.zero) then - do ic=1,noofel - xmol(ic)=xmol(ic)/totmol - wmass(ic)=wmass(ic)/totmass - enddo -! else -! write(*,*)'There is no mass at all in the system!' -! gx%bmperr=4185; goto 1000 - endif -! write(*,21)'25C x1: ',totmol,(xmol(ic),ic=1,noofel) -! write(*,21)'25C w1: ',totmass,(wmass(ic),ic=1,noofel) -21 format(a,1pe12.4,8(0pF9.5)) -! else -! this is not an error if no calculation has been made -! write(*,28)'25C: calc_molmass: No mole fractions',totmol,totmass,xsum,& -! (xmol(ic),ic=1,noofel) -28 format(a,3(1pe12.4)/'25C. ',10f7.4) -! gx%bmperr=4185; goto 1000 -! endif -! wsum=zero -! do ic=1,noofel -! wmass(ic)=xmol(ic)*ellista(elements(ic))%mass -! wsum=wsum+wmass(ic) -! write(*,44)'cmm4: ',ic,xmol(ic),wmass(ic),& -! ellista(elements(ic))%mass,wsum,totmass -44 format(a,i3,6(1pe12.4)) -! enddo -! if(wsum.gt.zero) then -! do ic=1,noofel -! wmass(ic)=wmass(ic)/wsum -! enddo -! endif -1000 continue - return - end subroutine calc_molmass - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine sumprops(props,ceq) -! summing up G, S, V, N and B for all phases with positive amount -! Check if this is correct - implicit none - TYPE(gtp_equilibrium_data) :: ceq - double precision props(5) -!\end{verbatim} - integer lokph,lokcs,ics - double precision am - if(gx%bmperr.ne.0) write(*,*)'error entering sumprops ',gx%bmperr - props=zero - allph: do lokph=1,noofph -! write(*,*)'25c sumprops: ',lokph - if(.not.btest(phlista(lokph)%status1,phhid)) then -! lokcs=phlista(lokph)%cslink - allcs: do ics=1,phlista(lokph)%noofcs -! phase_varres(lokcs)%amfu is the amount formula units of the phase -! phase_varres(lokcs)%abnorm(1) is the moles of real atoms/formula unit -! am is the number of moles of real atoms of the phase - lokcs=phlista(lokph)%linktocs(ics) - am=ceq%phase_varres(lokcs)%amfu*& - ceq%phase_varres(lokcs)%abnorm(1) -! write(*,*)'25c sumprops: ',lokph,am - if(am.gt.zero) then -! properties are G, G.T=-S, G.P=V and moles and mass of real atoms -! Note gval(*,1) is per mole formula unit and ceq%phase_varres(lokcs)%abnorm(1) -! is the number of real atoms per formula unit - props(1)=props(1)+am*ceq%phase_varres(lokcs)%gval(1,1)/& - ceq%phase_varres(lokcs)%abnorm(1) - props(2)=props(2)+am*ceq%phase_varres(lokcs)%gval(2,1)/& - ceq%phase_varres(lokcs)%abnorm(1) - props(3)=props(3)+am*ceq%phase_varres(lokcs)%gval(3,1)/& - ceq%phase_varres(lokcs)%abnorm(1) - props(4)=props(4)+am -! ceq%phase_varres(lokcs)%abnorm(2) should be the current mass -! but I am not sure it is updated for the current composition -! props(5)=props(5)+am*ceq%phase_varres(lokcs)%abnorm(2)/& -! ceq%phase_varres(lokcs)%abnorm(1) -! I think abnorm(2) is actual mass -! props(5)=props(5)+ceq%phase_varres(lokcs)%abnorm(2) - props(5)=props(5)+am*ceq%phase_varres(lokcs)%abnorm(2) -! write(*,11)'25C sumprops: ',lokcs,props(1),props(4),props(5),& -! ceq%phase_varres(lokcs)%abnorm(2) -! write(*,11)'sumprops ',lokcs,am,props(4),& -! ceq%phase_varres(lokcs)%abnorm(1) -11 format(a,i4,6(1pe12.4)) - endif - enddo allcs - endif - enddo allph -1000 continue - if(gx%bmperr.ne.0) write(*,*)'error exiting sumprops ',gx%bmperr - return - end subroutine sumprops - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine encode_state_variable(text,ip,svr,ceq) -! writes a state variable in text form position ip. ip is updated - character text*(*) - integer ip - type(gtp_state_variable), pointer :: svr - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} %+ - integer istv,indices(4),iunit,iref - iref=svr%phref - iunit=svr%unit -! if svr%oldstv>=10 then istv should be 10*(svr%oldstv-5)+svr%norm -! if(svr%oldstv.ge.10) then -! istv=10*(svr%oldstv-5)+svr%norm -! write(*,*)'25C encode: ',svr%oldstv,svr%norm,istv -! else - istv=svr%oldstv -! endif -! svr%argtyp specifies values in indices: -! svr%argtyp: 0=no arguments; 1=comp; 2=ph+cs; 3=ph+cs+comp; 4=ph+cs+const - indices=0 - if(svr%argtyp.eq.1) then - indices(1)=svr%component - elseif(svr%argtyp.eq.2) then - indices(1)=svr%phase - indices(2)=svr%compset - elseif(svr%argtyp.eq.3) then - indices(1)=svr%phase - indices(2)=svr%compset - indices(3)=svr%component - elseif(svr%argtyp.eq.4) then - indices(1)=svr%phase - indices(2)=svr%compset - indices(3)=svr%constituent -! else -! write(*,*)'state variable has illegal argtyp: ',svr%argtyp -! gx%bmperr=7775; goto 1000 - endif - call encode_state_variable3(text,ip,istv,indices,iunit,iref,ceq) -1000 continue - return - end subroutine encode_state_variable - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine encode_state_variable3(text,ip,istv,indices,iunit,iref,ceq) -! writes a state variable in text form position ip. ip is updated -! the internal coding provides in istv, indices, iunit and iref -! ceq is needed as compopnents can be different in different equilibria ?? -! >>>> unfinished as iunit and iref not really cared for - implicit none - integer, parameter :: noos=20 - character*4, dimension(noos), parameter :: svid = & - ['T ','P ','MU ','AC ','LNAC','U ','S ','V ',& - 'H ','A ','G ','NP ','BP ','DG ','Q ','N ',& - 'X ','B ','W ','Y '] - character*(*) text - integer, dimension(4) :: indices - integer istv,ip,iunit,iref - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer jp,ics,kstv,iph,norm -! - character stsymb*60 - character*1, dimension(4), parameter :: cnorm=['M','W','V','F'] -! - if(istv.le.0) then -! this is a parameter property symbol: TC (-2), BM (-3), MQ&FE(FCC) (-4) etc -! translate to 21, 22, 23 ... - kstv=19-istv - goto 200 -! gx%bmperr=4116; goto 1000 - endif -! T or P - if(istv.le.2) then - text(ip:ip)=svid(istv) - ip=ip+1 - goto 1000 - endif - stsymb=' ' -! potential: if(istv.le.6) then - potential: if(istv.le.5) then -! Potential, MU, AC or LNAC, possible suffix 'S' for SER - stsymb=svid(istv) - jp=len_trim(stsymb)+1 -! if(iref.ne.0) then - if(iref.lt.0) then -! New use of svr%phref and iref, <0 means use SER as reference state - stsymb(jp:jp)='S' - jp=jp+1 - endif - stsymb(jp:jp)='(' - jp=jp+1 - if(indices(2).eq.0) then -! problem ... component names different in different equilibria .... - call get_component_name(indices(1),stsymb(jp:),ceq) - if(gx%bmperr.ne.0) goto 1000 - jp=len_trim(stsymb)+1 - else -! always use composition set 1 - ics=1 - call get_phase_name(indices(1),ics,stsymb(jp:)) - if(gx%bmperr.ne.0) goto 1000 - jp=len_trim(stsymb)+1 - stsymb(jp:jp)=','; jp=jp+1 - call get_phase_constituent_name(indices(1),indices(2),stsymb(jp:)) - if(gx%bmperr.ne.0) goto 1000 - jp=len_trim(stsymb)+1 - endif - stsymb(jp:jp)=')' - goto 800 - endif potential - if(istv.lt.10) then -! write(*,*)'unknown potential' - gx%bmperr=4158; goto 1000 - endif -! Extensive property has istv>=10 - norm=mod(istv,10) - kstv=(istv+1)/10+5 -! write(*,3)'encode 3: ',kstv,indices -!3 format(a,5i5) - if(kstv.eq.16 .and. norm.eq.1) then -! NM should be X - if(indices(1).ne.0) kstv=17 - elseif(kstv.eq.17) then -! BW should be W - if(norm.eq.2 .and. indices(1).ne.0) then - kstv=19 - else - kstv=18 - endif - elseif(kstv.ge.18) then -! Y -! kstv=kstv+2 - kstv=20 - endif -! write(*,11)'esv 7: ',istv,kstv,indices -11 format(a,10i4) - stsymb=svid(kstv) - jp=len_trim(stsymb)+1 -! write(*,*)'25C norm 1A: ',kstv,norm - if(kstv.le.16 .or. kstv.eq.18) then - if(norm.gt.0 .and. norm.le.4) then -! write(*,*)'25C norm 1B: ',kstv,norm - stsymb(jp:jp)=cnorm(norm) - jp=jp+1 - elseif(norm.ne.0) then -! write(*,*)'25C norm 1C: ',kstv,norm - gx%bmperr=4118; goto 1000 - endif - endif - goto 500 -!----------------- -! parameter property symbols -200 continue - iph=indices(1) - ics=indices(2) - if(indices(3).ne.0) then - kstv=-100*istv+indices(3) - else - kstv=-istv - endif -! this call creates the symbol or gives an error - call find_defined_property(stsymb,1,kstv,iph,ics) - if(gx%bmperr.ne.0) goto 1000 - jp=len_trim(stsymb)+1 - goto 800 -!------------------ -! handle indices -500 continue - noind: if(indices(3).gt.0) then -! 3 indices, phase, comp.set and constituent allowed for Y -! or phase, comp.set and component, allowed for N, X, B and W -! or phase, comp.set and constituent allowed for MQ& - if(kstv.eq.20) then -! this is Y - stsymb(jp:jp)='(' - jp=jp+1 - call get_phase_name(indices(1),indices(2),stsymb(jp:)) - if(gx%bmperr.ne.0) goto 1000 - jp=len_trim(stsymb)+1 - stsymb(jp:jp)=',' - jp=jp+1 - call get_phase_constituent_name(indices(1),indices(3),stsymb(jp:)) - if(gx%bmperr.ne.0) goto 1000 - jp=len_trim(stsymb)+1 - stsymb(jp:jp)=')' - jp=jp+1 - elseif(kstv.ge.16 .and. kstv.le.19) then -! allow for percent or % - if(iunit.eq.100) then - stsymb(jp:jp+1)='%(' - jp=jp+2 - else - stsymb(jp:jp)='(' - jp=jp+1 - endif - call get_phase_name(indices(1),indices(2),stsymb(jp:)) - if(gx%bmperr.ne.0) goto 1000 - jp=len_trim(stsymb)+1 - stsymb(jp:jp)=',' - jp=jp+1 - call get_component_name(indices(3),stsymb(jp:),ceq) - if(gx%bmperr.ne.0) goto 1000 - jp=len_trim(stsymb)+1 - stsymb(jp:jp)=')' - jp=jp+1 - else - gx%bmperr=4117; goto 1000 - endif - elseif(indices(2).gt.0) then -! 2 indices, can only be phase and comp.set - stsymb(jp:jp)='(' - jp=jp+1 - call get_phase_name(indices(1),indices(2),stsymb(jp:)) - if(gx%bmperr.ne.0) goto 1000 - jp=len_trim(stsymb)+1 - stsymb(jp:jp)=')' - jp=jp+1 - elseif(indices(1).gt.0) then -! 1 index, can only be component -! allow for percent or % - if(iunit.eq.100) then - stsymb(jp:jp+1)='%(' - jp=jp+2 - else - stsymb(jp:jp)='(' - jp=jp+1 - endif - call get_component_name(indices(1),stsymb(jp:),ceq) - if(gx%bmperr.ne.0) goto 1000 - jp=len_trim(stsymb)+1 - stsymb(jp:jp)=')' - jp=jp+1 -! >>>> unfinished - endif noind -! -800 continue - text(ip:ip+jp-1)=stsymb - ip=ip+jp - if(text(ip:ip).eq.' ') then -! remove a trailing space occuring in some cases - ip=ip-1 - endif -1000 continue - return - end subroutine encode_state_variable3 - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine encode_state_variable_record(text,ip,svr,ceq) -! writes a state variable in text form position ip. ip is updated -! the svr record provide istv, indices, iunit and iref -! ceq is needed as compopnents can be different in different equilibria ?? -! >>>> unfinished as iunit and iref not really cared for - implicit none - integer, parameter :: noos=20 - character*4, dimension(noos), parameter :: svid = & - ['T ','P ','MU ','AC ','LNAC','U ','S ','V ',& - 'H ','A ','G ','NP ','BP ','DG ','Q ','N ',& - 'X ','B ','W ','Y '] - character*(*) text - type(gtp_state_variable) :: svr - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer jp,ics,kstv,iph,norm - integer, dimension(4) :: indices - integer istv,ip,iunit,iref -! - character stsymb*60 - character*1, dimension(4), parameter :: cnorm=['M','W','V','F'] -! - istv=svr%oldstv - norm=svr%norm - iunit=svr%unit - indices=0 - if(svr%argtyp.eq.1) then - indices(1)=svr%component - elseif(svr%argtyp.eq.2) then - indices(1)=svr%phase - indices(2)=svr%compset - elseif(svr%argtyp.eq.3) then - indices(1)=svr%phase - indices(2)=svr%compset - indices(3)=svr%component - elseif(svr%argtyp.eq.4) then - indices(1)=svr%phase - indices(2)=svr%compset - indices(3)=svr%constituent - endif -! there is some cloudy thinking here. If the user has defined his own -! reference state that should be used. The information is stored in the -! component record (ceq%complist(i)%phlink -! But if the user specifies MUS(i) one should use SER ... how to transfer that -! information to the calculating routines? -! By default svr%phref=0, then use user defined. If phref<0 use SER ?? - iref=svr%phref -! - if(istv.le.0) then -! this is a parameter property symbol: TC (-2), BM (-3), MQ&FE(FCC) (-4) etc -! translate to 21, 22, 23 ... - kstv=19-istv - goto 200 -! gx%bmperr=4116; goto 1000 - endif -! T or P - if(istv.le.2) then - text(ip:ip)=svid(istv) - ip=ip+1 - goto 1000 - endif - stsymb=' ' -! potential: if(istv.le.6) then - potential: if(istv.le.5) then -! Potential, MU, AC or LNAC, possible suffix 'S' for SER - stsymb=svid(istv) - jp=len_trim(stsymb)+1 -! if(iref.ne.0) then - if(iref.lt.0) then -! new use of phref and iref, <0 means use SER and suffix S - stsymb(jp:jp)='S' - jp=jp+1 - endif - stsymb(jp:jp)='(' - jp=jp+1 - if(indices(2).eq.0) then -! problem ... component names can be different in different equilibria .... - call get_component_name(indices(1),stsymb(jp:),ceq) - if(gx%bmperr.ne.0) goto 1000 - jp=len_trim(stsymb)+1 - else -! always use composition set 1 - ics=1 - call get_phase_name(indices(1),ics,stsymb(jp:)) - if(gx%bmperr.ne.0) goto 1000 - jp=len_trim(stsymb)+1 - stsymb(jp:jp)=','; jp=jp+1 - call get_phase_constituent_name(indices(1),indices(2),stsymb(jp:)) - if(gx%bmperr.ne.0) goto 1000 - jp=len_trim(stsymb)+1 - endif - stsymb(jp:jp)=')' - goto 800 - endif potential - if(istv.lt.10) then -! write(*,*)'unknown potential' - gx%bmperr=4158; goto 1000 - endif -! Extensive property has istv>=10 - norm=mod(istv,10) - kstv=(istv+1)/10+5 -! write(*,3)'encode 3: ',kstv,indices -!3 format(a,5i5) - if(kstv.eq.16 .and. norm.eq.1) then -! NM should be X - if(indices(1).ne.0) kstv=17 - elseif(kstv.eq.17) then -! BW should be W - if(norm.eq.2 .and. indices(1).ne.0) then - kstv=19 - else - kstv=18 - endif - elseif(kstv.ge.18) then -! Y -! kstv=kstv+2 - kstv=20 - endif -! write(*,11)'esv 7: ',istv,kstv,indices -11 format(a,10i4) - stsymb=svid(kstv) - jp=len_trim(stsymb)+1 - write(*,*)'25C norm 2: ',kstv,norm - if(kstv.le.16 .or. kstv.eq.18) then - if(norm.gt.0 .and. norm.le.4) then - stsymb(jp:jp)=cnorm(norm) - jp=jp+1 - elseif(norm.ne.0) then - gx%bmperr=4118; goto 1000 - endif - endif - goto 500 -!----------------- -! parameter property symbols -200 continue - iph=indices(1) - ics=indices(2) - if(indices(3).ne.0) then - kstv=-100*istv+indices(3) - else - kstv=-istv - endif -! this call creates the symbol or gives an error - call find_defined_property(stsymb,1,kstv,iph,ics) - if(gx%bmperr.ne.0) goto 1000 - jp=len_trim(stsymb)+1 - goto 800 -!------------------ -! handle indices -500 continue - noind: if(indices(3).gt.0) then -! 3 indices, phase, comp.set and constituent allowed for Y -! or phase, comp.set and component, allowed for N, X, B and W -! or phase, comp.set and constituent allowed for MQ& - if(kstv.eq.20) then -! this is Y - stsymb(jp:jp)='(' - jp=jp+1 - call get_phase_name(indices(1),indices(2),stsymb(jp:)) - if(gx%bmperr.ne.0) goto 1000 - jp=len_trim(stsymb)+1 - stsymb(jp:jp)=',' - jp=jp+1 - call get_phase_constituent_name(indices(1),indices(3),stsymb(jp:)) - if(gx%bmperr.ne.0) goto 1000 - jp=len_trim(stsymb)+1 - stsymb(jp:jp)=')' - jp=jp+1 - elseif(kstv.ge.16 .and. kstv.le.19) then -! allow for percent or % - if(iunit.eq.100) then - stsymb(jp:jp+1)='%(' - jp=jp+2 - else - stsymb(jp:jp)='(' - jp=jp+1 - endif - call get_phase_name(indices(1),indices(2),stsymb(jp:)) - if(gx%bmperr.ne.0) goto 1000 - jp=len_trim(stsymb)+1 - stsymb(jp:jp)=',' - jp=jp+1 - call get_component_name(indices(3),stsymb(jp:),ceq) - if(gx%bmperr.ne.0) goto 1000 - jp=len_trim(stsymb)+1 - stsymb(jp:jp)=')' - jp=jp+1 - else - gx%bmperr=4117; goto 1000 - endif - elseif(indices(2).gt.0) then -! 2 indices, can only be phase and comp.set - stsymb(jp:jp)='(' - jp=jp+1 - call get_phase_name(indices(1),indices(2),stsymb(jp:)) - if(gx%bmperr.ne.0) goto 1000 - jp=len_trim(stsymb)+1 - stsymb(jp:jp)=')' - jp=jp+1 - elseif(indices(1).gt.0) then -! 1 index, can only be component -! allow for percent or % - if(iunit.eq.100) then - stsymb(jp:jp+1)='%(' - jp=jp+2 - else - stsymb(jp:jp)='(' - jp=jp+1 - endif - call get_component_name(indices(1),stsymb(jp:),ceq) - if(gx%bmperr.ne.0) goto 1000 - jp=len_trim(stsymb)+1 - stsymb(jp:jp)=')' - jp=jp+1 -! >>>> unfinished - endif noind -! -800 continue - text(ip:ip+jp-1)=stsymb - ip=ip+jp - if(text(ip:ip).eq.' ') then -! remove a trailing space occuring in some cases - ip=ip-1 - endif -1000 continue - return - end subroutine encode_state_variable_record - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine state_variable_val(svr,value,ceq) -! calculate the value of a state variable in equilibrium record ceq -! It transforms svr data to old format and calls state_variable_val3 - type(gtp_state_variable), pointer :: svr - double precision value - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} %+ - integer istv, indices(4),iref,iunit -! - iref=svr%phref - iunit=svr%unit -! if(svr%oldstv.gt.10) then -! istv=10*(svr%oldstv-5)+svr%norm -! else - istv=svr%oldstv -! endif -! svr%argtyp specifies values in indices: -! svr%argtyp: 0=no arguments; 1=comp; 2=ph+cs; 3=ph+cs+comp; 4=ph+cs+const - indices=0 - if(svr%argtyp.eq.1) then - indices(1)=svr%component - elseif(svr%argtyp.eq.2) then - indices(1)=svr%phase - indices(2)=svr%compset - elseif(svr%argtyp.eq.3) then - indices(1)=svr%phase - indices(2)=svr%compset - indices(3)=svr%component - elseif(svr%argtyp.eq.4) then - indices(1)=svr%phase - indices(2)=svr%compset - indices(3)=svr%constituent - elseif(svr%argtyp.ne.0) then - write(*,*)'25C state variable has illegal argtyp: ',svr%argtyp - gx%bmperr=7775; goto 1000 - endif -! write(*,910)'25C svv: ',istv,indices,iref,iunit,value -910 format(a,i3,2x,4i3,2i3,1pe14.6) - call state_variable_val3(istv,indices,iref,iunit,value,ceq) - if(gx%bmperr.ne.0) then - write(*,920)'25C error: ',gx%bmperr,istv,svr%oldstv,svr%argtyp -920 format(a,i5,2x,2i4,i2) -! else -! write(*,*)'25C value: ',value - endif -1000 continue - return - end subroutine state_variable_val - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine state_variable_val3(istv,indices,iref,iunit,value,ceq) -! calculate the value of a state variable in equilibrium record ceq -! istv is state variable type (integer) -! indices are possible specifiers -! iref indicates use of possible reference state, 0 current, -1 SER -! iunit is unit, (K, oC, J, cal etc). For % it is 100 -! value is the calculated values. for state variables with wildcards use -! get_many_svar - implicit none - integer, dimension(4) :: indices - TYPE(gtp_equilibrium_data), pointer :: ceq - integer istv,iref,iunit - double precision value -!\end{verbatim} - double precision props(5),xmol(maxel),wmass(maxel),stoi(10),cmpstoi(10) - double precision vt,vp,amult,vg,vs,vv,div,aref,vn,bmult,tmass,tmol - double precision qsp,gref,spmass,rmult - integer kstv,norm,lokph,lokcs,icx,jp,ncmp,ic,iprop,loksp,nspel - integer endmember(maxsubl),ielno(maxspel) - value=zero - ceq%rtn=globaldata%rgas*ceq%tpval(1) -! write(*,10)'25C svval: ',istv,indices,iref,iunit,gx%bmperr,value -10 format(a,i4,4i4,3i5,1PE17.6) - potentials: if(istv.lt.0) then -! negative istv indicate parameter property symbols - kstv=-istv - goto 200 -! gx%bmperr=4097; goto 1000 - elseif(istv.ge.10) then - goto 50 - elseif(istv.eq.1) then - value=ceq%tpval(1) - elseif(istv.eq.2) then - value=ceq%tpval(2) - else - if(istv.eq.3) then -! MUx(component) or MU(phase,constituent), x can be S for SER - goto 500 - elseif(istv.eq.4) then -! ACx(component) or AC(phase,constituent) - goto 500 - elseif(istv.eq.5) then -! LNACx(component) or LNAC(phase,constituent) - goto 500 - endif -! wrong or state variable not implemented - write(*,10)'25C not impl: ',istv,indices,iref,iunit,gx%bmperr,value - goto 1100 - endif potentials -! normal return - goto 1000 -!---------------------------------------------------------- -! extensive variable (N, X, G ...) or model variable (TC, BMAG) -50 continue - norm=mod(istv,10) - kstv=istv/10 -! this may not be necessary in all cases but do it anyway: -! sum over all stable phases, props(1..3) are G, G.T and G.P, -! props(4) is amount of moles of components, props(5) is mass of components - call sumprops(props,ceq) - if(gx%bmperr.ne.0) goto 1000 -! if verbose on - if(ocv()) write(*,51)'25C stv A: ',props -51 format(a,5(1PE12.3)) -! kstv can be 1 to 15 for different properties -! norm can be 1, 2, 3 or 4 for normalizing. 0 for not normallizing -! M W V F -! OLD: iref can be 0 or 1 for reference state -! iref can be 0 for using current referennce state -! iref <0 for default reference state (SER) - le10: if(kstv.le.10) then -! kstv= 1 2 3 4 5 6 7 8 9 10 -! state var; U, S, V, H, A, G, NP, BP, DG and Q - vt=ceq%tpval(1) - vp=ceq%tpval(2) -! ceq%rtn=globaldata%rgas*ceq%tpval(1) - amult=ceq%rtn -! write(*,*)'stv B: ',vt,vp,amult - if(indices(1).eq.0) then - vg=props(1) - vs=-props(2) - vv=props(3) -! normalizing - if(norm.eq.1) then - div=props(4) - elseif(norm.eq.2) then - div=props(5) - elseif(norm.eq.3) then - div=props(3) - if(div.eq.zero) then - gx%bmperr=4114; goto 1000 - endif - elseif(norm.eq.4) then - gx%bmperr=4115; goto 1000 - else - div=one - endif -! for phase specific the aref should be independent of amult and div ?? -! for system wide these are unity - rmult=one - else -! phase specific, indices are phase and composition set - call get_phase_compset(indices(1),indices(2),lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 - vg=ceq%phase_varres(lokcs)%gval(1,1) - vs=-ceq%phase_varres(lokcs)%gval(2,1) - vv=ceq%phase_varres(lokcs)%gval(3,1) - if(norm.eq.1) then - div=ceq%phase_varres(lokcs)%abnorm(1) - rmult=div - elseif(norm.eq.2) then -! abnorm(2) should be the mass per formulat unit - div=ceq%phase_varres(lokcs)%abnorm(2) - rmult=div - elseif(norm.eq.3) then - div=ceq%phase_varres(lokcs)%gval(3,1) - if(div.eq.zero) then - gx%bmperr=4114; goto 1000 - endif - rmult=div - elseif(norm.eq.4) then -! per formula unit - div=one - rmult=div - else -! no normalizing for a specific phase, value for current amount -! NOTE amult is alreadt RT - amult=amult*ceq%phase_varres(lokcs)%amfu - rmult=ceq%phase_varres(lokcs)%amfu - div=one -! div=ceq%phase_varres(lokcs)%abnorm(1) - endif -! for phase specific the aref is for one mole of atoms and should -! be independent of amult and div ?? -! if(amult.eq.zero) then -! rmult=zero -! else -! rmult=div/amult -! endif - endif -! here the reference state should be considered -! aref=zero - if(iref.eq.0) then -! >>>> unfinished - call calculate_reference_state(kstv,indices(1),indices(2),aref,ceq) - if(gx%bmperr.ne.0) goto 1000 -! write(*,53)'25 C Reference state:',iref,aref,rmult - elseif(iref.lt.0) then - aref=zero - else - write(*,*)'25C Reference state undefined',iref - aref=zero - endif -! if phase specific the scaling for phase specific must be compensated - aref=rmult*aref -! write(*,53)'at kstv1: ',kstv,props,aref,div -53 format(a,i3,5(1PE12.3)) - kstv1: if(kstv.eq.1) then -! 1: U = G + TS - PV = G - T*G.T - P*G.P - value=amult*(vg+vt*vs-vp*vv-aref)/div - elseif(kstv.eq.2) then -! 2: S = -G.T - value=amult*(vs-aref)/div -! write(*,54)value,amult,vs,aref,div -54 format('25C svv: ',5(1pe12.4)) - elseif(kstv.eq.3) then -! 3: V = G.P - value=amult*(vv-aref)/div - elseif(kstv.eq.4) then -! 4: H = G + TS = G - T*G.T - if(ocv()) write(*,177)'25C H:',vg+vt*vs,aref,amult,div,rmult -177 format(a,6(1pe12.4)) - value=amult*(vg+vt*vs-aref)/div - elseif(kstv.eq.5) then -! 5: A = G - PV = G - P*G.P - value=amult*(vg-vp*vv-aref)/div - elseif(kstv.eq.6) then -! 6: G -! write(*,177)'25C G:',vg,aref,amult,div - value=amult*(vg-aref)/div - elseif(kstv.eq.7) then -! 7: NP - value=ceq%phase_varres(lokcs)%abnorm(1)* & - ceq%phase_varres(lokcs)%amfu/div - elseif(kstv.eq.8) then -! 8: BP -! abnorm(2) should be the mass per formula unit - value=ceq%phase_varres(lokcs)%abnorm(2)* & - ceq%phase_varres(lokcs)%amfu/div - elseif(kstv.eq.9) then -! 9: DG (driving force) -! write(*,202)'svval DG:',lokcs,ceq%phase_varres(lokcs)%dgm,div -202 format(a,i5,2(1pe12.4)) - value=ceq%phase_varres(lokcs)%dgm/div - elseif(kstv.eq.10) then -! 10: Q (stability, thermodynamic factor), not implemented - gx%bmperr=4081; goto 1000 -! else -! write(*,*)'svval after 10:',kstv - endif kstv1 - goto 1000 - endif le10 -!---------------------------------------------------------------------- -! here with kstv>10 -! kstv= 11 12 13 -! state var: N B Y - le12: if(kstv.le.12) then -! normallizing for N (kstv=11) and B (kstv=12) -! write(*,88)'25c svv 12: ',indices(1),norm,props(5) -88 format(a,2i3,6(1pe12.4)) - if(indices(1).eq.0) then -! no first index means the sum over all phases -! props(4) is amount of moles of components, props(5) is mass of components - if(kstv.eq.11) then - vn=props(4) - else - vn=props(5) - endif -! normalizing - if(norm.eq.1) then - div=props(4) - elseif(norm.eq.2) then - div=props(5) - elseif(norm.eq.3) then -! we may not have any volume data ... - div=props(3) - if(div.eq.zero) then - gx%bmperr=4114; goto 1000 - endif - elseif(norm.eq.4) then - gx%bmperr=4115; goto 1000 - else - div=one - endif -! This is N or B without index but possibly normallized -! write(*,89)'25C svv, N or B: ',vn,div -89 format(a,5(1pe12.4)) - value=vn/div - else -! one or two indices, overall of phase specific component amount - if(indices(2).eq.0) then -! one index is component specific, N(comp.), B(CR) etc. Sum over all phases -! props(4) is amount of moles of components, props(5) is mass of components - call calc_molmass(xmol,wmass,tmol,tmass,ceq) - if(gx%bmperr.ne.0) goto 1000 -! write(*,89)'25c mm: ',tmol,tmass -! write(*,93)'25c x: ',(xmol(icx),icx=1,noofel) -! write(*,93)'25c w: ',(wmass(icx),icx=1,noofel) -93 format(a,9F7.4) - icx=1 - if(kstv.eq.11) then - bmult=props(4) - else - bmult=props(5) - endif - else -! two indices is phase and component specific. bmult is amount of phase - call calc_phase_molmass(indices(1),indices(2),& - xmol,wmass,tmol,tmass,bmult,ceq) - icx=3 - endif - if(gx%bmperr.ne.0) goto 1000 -! write(*,13)'gsvv 19: ',norm,(xmol(iq),iq=1,noofel) -777 format('gsvv 77: ',10(f7.4)) - if(kstv.eq.11) then -! total moles of component - vn=xmol(indices(icx)) - amult=tmol -! write(*,777)kstv,icx,indices(icx),norm,vn,amult,bmult -!777 format('N(i): ',4i4,3(1pe12.4)) - else -! total mass of component - vn=wmass(indices(icx)) - amult=tmass - endif -! write(*,13)'gsvv 8: ',norm,vn,amult,bmult,tmol,tmass -13 format(a,i3,7(1PE10.2)) - norm3: if(norm.eq.1) then -! NM or X - if(tmol.ne.zero) then - value=amult*vn/tmol - else -! problem at x(phase,component) was zero when phase fix with zero amount -! value=zero - value=vn - endif -! percent % -! write(*,*)'x%: ',iunit,value - if(iunit.eq.100) value=1.0D2*value - elseif(norm.eq.2) then -! NW or W - if(tmass.gt.zero) then - value=amult*vn/tmass - else - value=zero - endif -! percent % - if(iunit.eq.100) value=1.0D2*value - elseif(norm.eq.3) then -! NV - if(props(3).gt.zero) then - value=amult*vn/props(3) - else - gx%bmperr=4114 - endif - elseif(norm.eq.4) then -! NF or BF with one or two indices - if(indices(2).eq.0) then - gx%bmperr=4115; goto 1000 - else - value=vn - endif - else -! N(comp), N(phase,comp), B(comp) or B(phase,comp) - value=bmult*vn - endif norm3 - endif - goto 1000 - endif le12 -!----------------------------------------------------------------- -! special for Y - if(kstv.eq.13) then -! 13: Y - call get_phase_compset(indices(1),indices(2),lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 - value=ceq%phase_varres(lokcs)%yfr(indices(3)) - else -! wrong state variable specification - value=zero - gx%bmperr=4113 - endif - goto 1000 -!----------------------------------------------------------------- -! values of parameter property symbols -! >>> this can easily be generallized ... next time around ... -! here with state variable <0, syetm and user defined properties -200 continue - select case(kstv) - case default - write(kou,*)'Unknown parameter identifier: ',kstv -!....................................... - case(2:5,7,9:19) -! 2: TC (Curie/Neel Temperature) -! 3: BM (Average Bohr magneton number) -! 4: CTA just Curie Temperature -! 5: NTA just Neel temperature -! 7: THET Debye or Einstein temperature -! 9: RHO electrical resistivity -! 10: MAGS Magnetic suseptibility -! 11: GTT Glas transition temperature -! 12: VISC viscosity -! 13: LPX Lattice parameter in X direction -! 14: LPY Lattice parameter in Y direction -! 15: LPZ Lattice parameter in Z direction -! 16: LPTH Lattice angle -! 17: EC11 Elastic constant C11 -! 18: EC12 Elastic constant C12 -! 19: EC44 Elastic constant C44 - call get_phase_compset(indices(1),indices(2),lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 -! nprop is number of properties calculated. Property 1 is always G - find1: do jp=2,ceq%phase_varres(lokcs)%nprop -! the listprop array contain identification of the property stored there - if(ceq%phase_varres(lokcs)%listprop(jp).eq.kstv) then - value=ceq%phase_varres(lokcs)%gval(1,jp) - goto 1000 - endif - enddo find1 -!....................................... - case(6,8) -! 6: IBM& Individual Bohr magneton number -! 8: MQ& mobility value - call get_phase_compset(indices(1),indices(2),lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 -! property is kstv*100+indices(3) (constituent identifier) - iprop=100*kstv+indices(3) - find2: do jp=2,ceq%phase_varres(lokcs)%nprop - if(ceq%phase_varres(lokcs)%listprop(jp).eq.iprop) then - value=ceq%phase_varres(lokcs)%gval(1,jp) - goto 1000 - endif - enddo find2 - end select -!....................................... - gx%bmperr=4113; goto 1000 -!----------------------------------------------------------------- -! chemical potentials, activites etc, istv is 3, 4 or 5 for MU, AC and LNAC -! there can be a reference state -500 continue -! ceq%rtn=globaldata%rgas*ceq%tpval(1) -! if one argument that is a component, if two these are phase and constituent - if(indices(2).ne.0) then - lokph=phases(indices(1)) - loksp=phlista(lokph)%constitlist(indices(2)) -! split the species in elements, convert to components, add chemical potentials - call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp) - if(gx%bmperr.ne.0) goto 1000 - if(qsp.ne.zero) then -! write(*,*)'Cannot calculate potential of charged species' - gx%bmperr=4159; goto 1000 - endif -! write(*,*)'converting to component',nspel,ielno(1),stoi(1) - call elements2components(nspel,stoi,ncmp,cmpstoi,ceq) - if(gx%bmperr.ne.0) goto 1000 -! write(*,*)'converting to component',ncmp,cmpstoi(1) - value=zero - do ic=1,ncmp - value=value+cmpstoi(ic)*ceq%complist(ic)%chempot(1) - enddo -! >>>> subtract reference state: i.e. calculate G for the phase with -! just this constituent - endmember(1)=indices(2) - call calcg_endmember(indices(1),endmember,gref,ceq) - if(gx%bmperr.ne.0) goto 1000 - value=value-gref*ceq%rtn -! write(*,511)'25C refstate: ',endmember(1),indices(1),gref,value -511 format(a,2i3,6(1pe14.6)) -! possibly convert to AC or LNAC - goto 700 - else -! MU(i) should be in position i, not indexed by splink ?? -! loop through components, different components in each equilibrium -! do ic=1,noofel -! write(*,*)'state var value: ',indices(1),ceq%complist(ic)%splink,& -! ceq%complist(ic)%chempot(1) -! if(indices(1).eq.ceq%complist(ic)%splink) then - if(indices(1).le.0 .or. indices(1).gt.noofel) then -! write(*,*)'Asking for nonexisting chemical potential' - gx%bmperr=4171; goto 1000 - endif -! iref=0 is default i.e. mean MU and iref<0 should mean MUS -! If a component has a defined reference state that is in complist(indices(1)) -! write(*,*)'25C Reference state: ',iref,ceq%complist(indices(1))%phlink - if(iref.eq.0 .and. ceq%complist(indices(1))%phlink.ne.0) then -! if(iref.eq.1) then -! phlink is phase, endmember is enmember, tpref<0 means current T -! we should also have a stoichiometry factor ?? - endmember(1)=indices(2) - aref=ceq%tpval(1) - if(ceq%complist(indices(1))%tpref(1).gt.zero) then -! reference state is at a fixed T, negative tpref(1) means current T - ceq%tpval(1)=ceq%complist(indices(1))%tpref(1) - endif -! write(*,*)'25C calling calcg_endmember: ',& -! ceq%complist(indices(1))%phlink,& -! ceq%complist(indices(1))%endmember - call calcg_endmember(ceq%complist(indices(1))%phlink,& - ceq%complist(indices(1))%endmember,gref,ceq) - if(gx%bmperr.ne.0) goto 1000 - ceq%tpval(1)=aref - aref=ceq%complist(indices(1))%chempot(1) - value=ceq%complist(indices(1))%chempot(1)-gref*ceq%rtn -! write(*,513)'25C gref: ',indices(1),value,aref,gref*ceq%rtn -513 format(a,i3,5(1pe14.6)) - else -! this value should always be referenced to SER -! the value in chempot(2) is probably redundant after this change - value=ceq%complist(indices(1))%chempot(1) - endif -! write(*,*)'25C chempot: ',indices(1),& -! ceq%complist(indices(1))%chempot(1),& -! ceq%complist(indices(1))%chempot(2) - goto 700 - endif -! convert from MU to AC or LNAC if necessary -700 continue -! ceq%rtn=globaldata%rgas*ceq%tpval(1) - if(istv.eq.4) then -! AC = exp(mu/RT) - value=exp(value/ceq%rtn) - elseif(istv.eq.5) then -! LNAC = mu/RT - value=value/ceq%rtn - endif -!----------------------------------------------------------------- -1000 continue - return -1100 continue - gx%bmperr=4078 -! write(*,*)'State variable value not implemented yet' - goto 1000 - end subroutine state_variable_val3 - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!-\begin{verbatim} - subroutine state_var_value_derivative_old(svr1,svr2,value,ceq) -! THIS SUBROUTINE MOVED TO MINIMIZER -! subroutine state_var_value_derivative(istv,indices,iref,iunit,& -! istv2,indices2,iref2,iunit2,value,ceq) -! calculates a state variable value derivative NOT IMPLEMENTED YET -! istv and istv2 are state variable type (integer) -! indices and indices2 are possible specifiers -! iref and iref2 are possible reference state -! iunit and iunit2 are units, (K, oC, J, cal etc) -! value is calculated value -! ceq is current equilibrium - implicit none - TYPE(gtp_state_variable), pointer :: svr1,svr2 - TYPE(gtp_equilibrium_data) :: ceq -! integer :: istv,iref,iunit,istv2,iref2,iunit2 -! integer, dimension(4) :: indices,indices2 - double precision value -!-\end{verbatim} -! - value=zero - write(*,17)svr1%statevarid,svr1%argtyp,svr2%statevarid,svr2%argtyp -17 format('25C: state_var_value_derivative: ',10i4) -! this must be calculated in the minimizer -! call meq_state_var_value_derivative(svr1,svr2,value,ceq) - gx%bmperr=4078 -1000 continue - return - end subroutine state_var_value_derivative_old - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine calculate_reference_state(kstv,iph,ics,aref,ceq) -! Calculate the user defined reference state for extensive properties -! kstv is the typde of property: 1 U, 2 S, 3 V, 4 H, 5 A, 6 G -! It can be phase specific (iph.ne.0) or global (iph=0) - implicit none - integer kstv,iph,ics - double precision aref - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} -! kstv=1 2 3 4 5 6 other values cared for elsewhere -! U S V H A G - integer iel,phref - double precision gref(6),bref(6),xmol(maxel),wmass(maxel),xxx(6) - double precision tmol,tmass,bmult -! -! write(*,*)'Reference states not implemented yet'; goto 1000 -! write(*,*)'25C reference state:',kstv,iph,ics - if(kstv.lt.1 .or. kstv.gt.6) then -! write(*,*)'No reference state for kstv: ',kstv - goto 1000 - endif - aref=zero - bref=zero - gref=zero - xxx=zero -! loop for all components to extract the value of their reference states -! Multiply that with the overall composition (iph=0) or the phase composition - xmol=zero - do iel=1,noofel -! this is the reference phase for component iel - phref=ceq%complist(iel)%phlink - if(phref.gt.0) then -! special endmember call that returns G, G.T, G.P, G.T.T, G.T.P and G.P.P -! write(*,73)'25C R state: ',iel,phref,ceq%complist(iel)%endmember -73 format(a,2i3,2x,10i4) - call calcg_endmember6(phref,ceq%complist(iel)%endmember,gref,ceq) - if(gx%bmperr.ne.0) goto 1000 - if(iph.gt.0) then -! multiply with mole fractions of phase iph,ics - call calc_phase_molmass(iph,ics,xmol,wmass,tmol,tmass,bmult,ceq) - else -! multiply with overall mole fractions - call calc_molmass(xmol,wmass,tmol,tmass,ceq) - endif -! note xxx, bref and gref are arrays - xxx=bref+xmol(iel)*gref -! write(*,70)'25Crs: ',bref,gref,xxx,(xmol(ij),ij=1,noofel) -70 format(a,6(1pe12.4)/,2(7x,6e12.4/),8(0pF8.4)) - bref=xxx - else -! this is not really needed, it is bref that is used below - gref=zero - endif - enddo -! calculate the correct correction depending on kstv - if(kstv.eq.1) then -! U = G - T*G.T - P*G.P - aref=bref(1)-ceq%tpval(1)*bref(2)-ceq%tpval(2)*bref(3) - elseif(kstv.eq.2) then -! S = - G.T - aref=-bref(2) - - elseif(kstv.eq.3) then -! V - aref=bref(3) - - elseif(kstv.eq.4) then -! H = G - T*G.T - aref=bref(1)-ceq%tpval(1)*bref(2) - - elseif(kstv.eq.5) then -! A = G - P*G.P - aref=bref(1)-ceq%tpval(2)*bref(3) - - elseif(kstv.eq.6) then -! G - aref=bref(1) - endif -! write(*,75)kstv,aref -75 format('25C ref:',i3,6(1pe12.4)) -1000 continue - return - end subroutine calculate_reference_state - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - - subroutine sortinphtup(n,m,xx) -! subroutine to sort the values in xx which are in phase and compset order -! in phase tuple order. This is needed by the TQ interface -! The number of values belonging to the phase is m (for example composition) - integer n,m - double precision xx(n*m) -! - integer iz,jz,kz,lz,lokph,aha - double precision, dimension(:), allocatable :: dum -! I assume the values are NP(*), maybe there are other cases ... - allocate(dum(n*m)) - kz=0 - do iz=1,noofph - lokph=phases(iz) - do jz=1,noofcs(lokph) -! in xx the values are sequentially for all composition sets for this phase -! But they should be stored in tuple order and compset 2 etc comes at the end -! the index to the tuple is in %phtups -! phlista(lokph)%linktocs(jz) is index of phase_varres record for compset -! firsteq%phase_varres(..)%phtupx is index of phase tuple for compset -! There can be m values (for example compositions) for each phase - aha=(firsteq%phase_varres(phlista(lokph)%linktocs(jz))%phtupx-1)*m - do lz=1,m - dum(aha+lz)=xx(kz+lz) - enddo - kz=kz+m - enddo - enddo - xx=dum - deallocate(dum) -1000 continue - return - end subroutine sortinphtup - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - +! +! gtp3E included in gtp3.F90 +! +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ +!> 10. State variable manipulations +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine get_state_var_value(statevar,value,encoded,ceq) +! called with a state variable character + implicit none + TYPE(gtp_equilibrium_data), pointer :: ceq + character statevar*(*),encoded*(*) + double precision value +!\end{verbatim} +! integer indices(4) + integer iunit,ip,lrot,mode + type(gtp_state_variable), pointer :: svr + character actual_arg(2)*16,name*16 +! +! write(*,*)'3F In state_variable_value: ',statevar + iunit=0 + call decode_state_variable(statevar,svr,ceq) +! write(*,20)statevar(1:len_trim(statevar)),svr%oldstv,svr%norm,& +! svr%argtyp,svr%component +20 format('3F gsvv 1: ',a,' : ',4i3) + if(gx%bmperr.ne.0) then +! goto 1000 +! it can be a state variable symbol ... +! +! Possible problem ... this can cause nesting as a state variable will +! normally evaluate some state variables or other state variable functions +! + gx%bmperr=0 + name=statevar + call capson(name) + call find_svfun(name,lrot,ceq) + if(gx%bmperr.ne.0) then + write(*,*)'3F Neither state variable or symbol' + gx%bmperr=8888; goto 1000 + else +! get the value of the symbol, may involve other symbols and state variablse +! The actual_arg is a facility not yet implemented and not allowed here +! if mode=0 the stored value may be used, mode=1 always evaluate +! write(*,*)'3F Found function: ',lrot + actual_arg=' ' + mode=1 +! this is OK if it is not a derivative + value=evaluate_svfun_old(lrot,actual_arg,mode,ceq) + if(gx%bmperr.eq.4217) goto 1000 + encoded=name + endif + else +! it is a real state variable +! write(*,*)'3F calling state_variable_val' + call state_variable_val(svr,value,ceq) + if(gx%bmperr.ne.0) goto 1000 + ip=1 + call encode_state_variable(encoded,ip,svr,ceq) + if(gx%bmperr.ne.0) then + write(*,*)'3F encode error: ',gx%bmperr + gx%bmperr=0; encoded='dummy' + endif + endif +1000 continue + return + end subroutine get_state_var_value + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine get_many_svar(statevar,values,mjj,kjj,encoded,ceq) +! called with a state variable name with woldcards allowed like NP(*), X(*,CR) +! mjj is dimension of values, kjj is number of values returned +! encoded used to specify if phase data in phasetuple order ('Z') +! >>>> BIG problem: How to do with phases that are note stable? +! If I ask for w(*,Cr) I only want the fraction in stable phases +! but whenthis is used for GNUPLOT the values are written in a matix +! and the same column in that phase must be the same phase ... +! so I have to have the same number of phases from each equilibria. +! + implicit none + TYPE(gtp_equilibrium_data), pointer :: ceq + character statevar*(*),encoded*(*) + double precision values(*) + integer mjj,kjj +!\end{verbatim} + integer indices(4),modind(4) + double precision xnan,xxx + integer jj,lokph,lokcs,k1,k2,k3,iref,jl,iunit,istv,enpos + type(gtp_state_variable), pointer :: svr +! logical phtupord +! calculate the NaN bit pattern + xnan=0.0d0 +! xnan=0.0d0/xnan + encoded=' ' + enpos=1 + if(gx%bmperr.ne.0) then + write(*,*)'3F Error entering get_many_svar ',gx%bmperr,xnan + endif +!------------------------ + iunit=0 + modind=0 +! phtupord=.FALSE. +! if(encoded(1:1).eq.'Z') then +! when called from TQ interface the phase order should be as for phase tuples +! phtupord=.TRUE. +! endif +! called from minimizer for testing +! write(*,*)'gmv 1: ',statevar(1:20) +! call decode_state_variable(statevar,istv,indices,iref,iunit,svr,ceq) + call decode_state_variable(statevar,svr,ceq) + if(gx%bmperr.ne.0) then + write(*,*)'3F Failed decode statevar in get_many_svar',gx%bmperr + goto 1000 + endif +! translate svr data to old indices etc + istv=svr%oldstv + iref=svr%phref + iunit=svr%unit +! svr%argtyp specifies values in indices: +! svr%argtyp: 0=no arguments; 1=comp; 2=ph+cs; 3=ph+cs+comp; 4=ph+cs+const + indices=0 + if(svr%argtyp.eq.1) then + indices(1)=svr%component + elseif(svr%argtyp.eq.2) then + indices(1)=svr%phase + indices(2)=svr%compset + elseif(svr%argtyp.eq.3) then + indices(1)=svr%phase + indices(2)=svr%compset + indices(3)=svr%component + elseif(svr%argtyp.eq.4) then + indices(1)=svr%phase + indices(2)=svr%compset + indices(3)=svr%constituent +! else +! write(*,*)'state variable has illegal argtyp: ',svr%argtyp +! gx%bmperr=7775; goto 1000 + endif +! +! write(*,20)istv,indices,iref,gx%bmperr +20 format('gmsvar 1: ',i5,4i4,3i7) +! ----------------------------------------- +! Indices 1: one or all components (-1) +! Indices 2+3: 0 or phase+set +! Indices 1+2: phase+set +! Indices 3: 0 or component (-1) or constituent (-2) +! indices 4 never used +! ----------------------------------------- +! -1 means element or component +! -2 species or constituent +! -3 phase +! -4 composition set + jj=0 + if(indices(1).ge.0) then + if(indices(2).ge.0) then + if(indices(3).ge.0) then +! all indices given, a single value + jj=jj+1 + if(jj.gt.mjj) goto 1100 + call encode_state_variable3(encoded,enpos,istv,indices,& + iunit,iref,ceq) + if(gx%bmperr.ne.0) goto 1000 + enpos=enpos+1 + call state_variable_val3(istv,indices,iref,& + iunit,values(jj),ceq) + if(gx%bmperr.ne.0) goto 1000 + elseif(indices(3).eq.-1) then +! loop for components, indices 1+2 must be phase+compset + do k3=1,noofel + indices(3)=k3 + jj=jj+1 + if(jj.gt.mjj) goto 1100 + call encode_state_variable3(encoded,enpos,istv,indices,& + iunit,iref,ceq) + if(gx%bmperr.ne.0) goto 1000 + enpos=enpos+1 + call state_variable_val3(istv,indices,iref,& + iunit,values(jj),ceq) + if(gx%bmperr.ne.0) goto 1000 + enddo + elseif(indices(3).eq.-2) then +! loop for constituents, indices 1+2 must be phase+compset + call get_phase_record(indices(1),lokph) + do k3=1,phlista(lokph)%tnooffr + indices(3)=k3 + jj=jj+1 + if(jj.gt.mjj) goto 1100 + call encode_state_variable3(encoded,enpos,istv,indices,& + iunit,iref,ceq) + if(gx%bmperr.ne.0) goto 1000 + enpos=enpos+1 + call state_variable_val3(istv,indices,iref,& + iunit,values(jj),ceq) + if(gx%bmperr.ne.0) goto 1000 + enddo + else +! indices(3) must be -2, -1 or >=0 so if we are here there is an error + write(*,17)'3F Illegal set of indices 1',(indices(jl),jl=1,4) +17 format(a,4i4) + gx%bmperr=7777; goto 1000 + endif + elseif(indices(2).eq.-3) then +! if indices(1)>=0 then indices(2)<0 must means a loop for all phase+compset + do k2=1,noofph + indices(2)=k2 + call get_phase_record(indices(2),lokph) + do k3=1,phlista(lokph)%noofcs + indices(3)=k3 + jj=jj+1 + if(jj.gt.mjj) goto 1100 + call get_phase_compset(indices(2),indices(3),lokph,lokcs) + call encode_state_variable3(encoded,enpos,istv,indices,& + iunit,iref,ceq) + if(gx%bmperr.ne.0) goto 1000 + enpos=enpos+1 +! if composition set not stable so return NaN (in xnan) + if(test_phase_status(indices(2),indices(3),xxx,ceq).le. & + PHENTUNST) then + values(jj)=xnan + elseif(ceq%phase_varres(lokcs)%dgm.lt.zero) then +! the phase must not have negative driving force + values(jj)=xnan + else +! problem that get_many returns values for unstable phases + call state_variable_val3(istv,indices,iref,& + iunit,values(jj),ceq) + if(gx%bmperr.ne.0) goto 1000 +23 format(a,2i3,2(1pe14.6)) + endif + enddo + enddo + else +! if indices(1)>=0 then indices(2) must be -3 or >=0, so if here it is error + write(*,17)'3F Illegal set of indices 2',(indices(jl),jl=1,4) + gx%bmperr=7777; goto 1000 + endif + elseif(indices(1).eq.-1) then +! loop for component as first indices, 2+3 can be fix phase+compset + if(indices(2).ge.0) then + do k1=1,noofel + indices(1)=k1 + jj=jj+1 + if(jj.gt.mjj) goto 1100 + call encode_state_variable3(encoded,enpos,istv,indices,& + iunit,iref,ceq) + if(gx%bmperr.ne.0) goto 1000 + enpos=enpos+1 + call state_variable_val3(istv,indices,iref,& + iunit,values(jj),ceq) + if(gx%bmperr.ne.0) goto 1000 + enddo + elseif(indices(2).eq.-3) then +! loop for components and phase+compset + do k1=1,noofel + indices(1)=k1 + do k2=1,noofph + indices(2)=k2 + call get_phase_record(indices(2),lokph) + do k3=1,phlista(lokph)%noofcs + indices(3)=k3 + jj=jj+1 + if(jj.gt.mjj) goto 1100 + call get_phase_compset(indices(2),indices(3),lokph,lokcs) +! if composition not stable so return NaN + call encode_state_variable3(encoded,enpos,istv,indices,& + iunit,iref,ceq) + if(gx%bmperr.ne.0) goto 1000 + enpos=enpos+1 + if(test_phase_status(indices(2),indices(3),xxx,ceq).le. & + PHENTSTAB) then + values(jj)=xnan + elseif(ceq%phase_varres(lokcs)%dgm.lt.zero) then +! the phase must not have negative driving force + values(jj)=xnan + else + call state_variable_val3(istv,indices,iref,& + iunit,values(jj),ceq) + if(gx%bmperr.ne.0) goto 1000 + endif + enddo + enddo + enddo + else +! if we come here it must be an error + write(*,17)'3F Illegal set of indices 3',(indices(jl),jl=1,4) + gx%bmperr=7777; goto 1000 + endif + elseif(indices(1).eq.-3) then +! loop for phase+compset as indices(1+2) +! here we must be careful not to destroy original indices, use modind +! write(*,*)'get_many NP(*) 1: ',gx%bmperr,indices(3) +! write(*,*)'Loop for many phases',indices(1) + phloop: do k1=1,noofph + modind(1)=k1 + modind(2)=0 + call get_phase_record(modind(1),lokph) +! write(*,19)'3F test 17',modind,gx%bmperr,xnan + if(gx%bmperr.ne.0) goto 1000 + csloop: do k2=1,phlista(lokph)%noofcs + modind(2)=k2 + jj=jj+1 + if(jj.gt.mjj) goto 1100 + call get_phase_compset(modind(1),modind(2),lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 + if(indices(3).eq.0) then +! This is typically listing of NP(*) for all phases + modind(3)=0 + call encode_state_variable3(encoded,enpos,istv,modind,& + iunit,iref,ceq) + if(gx%bmperr.ne.0) goto 1000 + enpos=enpos+1 + if(ceq%phase_varres(lokcs)%phstate.lt.PHENTSTAB) then + values(jj)=xnan + else + call state_variable_val3(istv,modind,iref,& + iunit,values(jj),ceq) + if(gx%bmperr.ne.0) goto 1000 + endif +! elseif(ceq%phase_varres(lokcs)%phstate.lt.PHENTSTAB) then +! call encode_state_variable3(encoded,enpos,istv,modind,& +! iunit,iref,ceq) +! if(gx%bmperr.ne.0) goto 1000 +! enpos=enpos+1 +! values(jj)=xnan + elseif(indices(3).gt.0) then +! This is typically listing of w(*,cr), only in stable range of phases + modind(3)=indices(3) + call get_phase_compset(modind(1),modind(2),lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 + call encode_state_variable3(encoded,enpos,istv,modind,& + iunit,iref,ceq) + if(gx%bmperr.ne.0) goto 1000 + enpos=enpos+1 + if(ceq%phase_varres(lokcs)%phstate.lt.PHENTSTAB) then +! if phase is unstable set dummy value + values(jj)=xnan + else + call state_variable_val3(istv,modind,iref,& + iunit,values(jj),ceq) + endif + if(gx%bmperr.ne.0) goto 1000 + elseif(ceq%phase_varres(lokcs)%phstate.lt.PHENTSTAB) then +! loop for all components or constitunets of stable phases +! Maybe it should be included to have same number of values in all ranges? + cycle csloop + elseif(indices(3).eq.-1) then +! loop for all components of all phases, skip unstable phases + elloop: do k3=1,noofel + modind(3)=k3 + call encode_state_variable3(encoded,enpos,istv,modind,& + iunit,iref,ceq) + if(gx%bmperr.ne.0) goto 1000 + enpos=enpos+1 + call state_variable_val3(istv,modind,iref,& + iunit,values(jj),ceq) + if(gx%bmperr.ne.0) goto 1000 + enddo elloop + elseif(indices(3).eq.-2) then +! loop for constituents of all phases + conloop: do k3=1,phlista(lokph)%tnooffr + modind(3)=k3 + call encode_state_variable3(encoded,enpos,istv,modind,& + iunit,iref,ceq) + if(gx%bmperr.ne.0) goto 1000 + enpos=enpos+1 + call state_variable_val3(istv,modind,iref,& + iunit,values(jj),ceq) + if(gx%bmperr.ne.0) goto 1000 + enddo conloop + else +! error if here + write(*,17)'3F Illegal set of indices 4',(indices(jl),jl=1,4) + gx%bmperr=7777; goto 1000 + endif + if(gx%bmperr.ne.0) then + write(*,19)'3F error 3',modind,gx%bmperr +19 format(a,4i4,i7) + goto 1000 + endif + enddo csloop + enddo phloop + else +! error if here + write(*,17)'3F Illegal set of indices 5',(indices(jl),jl=1,4) + gx%bmperr=7777; goto 1000 + endif +1000 continue + kjj=jj + return +1100 continue + write(*,*)'3F Overflow in array to get_state_variables' + gx%bmperr=7777; goto 1000 + end subroutine get_many_svar + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine decode_state_variable(statevar,svr,ceq) +! converts a state variable character to state variable record + character statevar*(*) + type(gtp_state_variable), pointer :: svr + type(gtp_equilibrium_data), pointer :: ceq +! this subroutine using state variable records is a front end of the next: +!\end{verbatim} %+ +! type(gtp_state_variable) :: svrec + integer istv,indices(4),iref,iunit + call decode_state_variable3(statevar,istv,indices,iref,iunit,svr,ceq) +1000 continue + return + end subroutine decode_state_variable + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine decode_state_variable3(statevar,istv,indices,iref,iunit,svr,ceq) +! converts an old state variable character to indices +! Typically: T, x(fe), x(fcc,fe), np(fcc), y(fcc,c#2), ac(h2,bcc), ac(fe) +! NOTE! model properties like TC(FCC),MQ&FE(FCC,CR) must be detected +! NOTE: added storing information in a gtp_state_variable record svrec !! +! +! this routine became as messy as I tried to avoid +! but I leave it to someone else to clean it up ... +! +! state variable and indices +! Symbol no index1 index2 index3 index4 +! T 1 - +! P 2 - +! MU 3 component or phase,constituent +! AC 4 component or phase,constituent +! LNAC 5 component or phase,constituent +! index (in svid array) +! U 10 (phase#set) 6 Internal energy (J) +! UM 11 " 6 per mole components +! UW 12 " 6 per kg +! UV 13 " 6 per m3 +! UF 14 " 6 per formula unit +! S 2x " 7 entropy +! V 3x " 8 volume +! H 4x " 9 enthalpy +! A 5x " 10 Helmholtz energy +! G 6x " 11 Gibbs energy +! NP 7x " 12 moles of phase +! BP 8x " 13 mass of moles +! DG 9x " 15 Driving force +! Q 10x " 14 Internal stability +! N 11x (component/phase#set,component) 16 moles of components +! X 111 " 17 mole fraction of components +! B 12x " 18 mass of components +! W 122 " 19 mass fraction of components +! Y 13 phase#set,constituent#subl 20 constituent fraction +!----- model variables <<<< these now treated differently +! TC - phase#set - Magnetic ordering T +! BMAG - phase#set - Aver. Bohr magneton number +! MQ& - element, phase#set - Mobility +! THET - phase#set - Debye temperature +! + implicit none + integer, parameter :: noos=20 + character*4, dimension(noos), parameter :: svid = & + ['T ','P ','MU ','AC ','LNAC','U ','S ','V ',& + 'H ','A ','G ','NP ','BP ','DG ','Q ','N ',& + 'X ','B ','W ','Y '] +! 1 2 3 4 4 6 7 8 + character statevar*(*) + integer istv,iref,iunit + integer, dimension(4) :: indices + type(gtp_equilibrium_data), pointer :: ceq +! I shall try to use this record type instead of separate arguments: !! +! type(gtp_state_variable), pointer :: svrec + type(gtp_state_variable), pointer :: svr +!\end{verbatim} +! type(gtp_state_variable), allocatable, target :: svr + integer is,jp,kp,iph,ics,icon,icomp,norm,narg,icc + double precision cmass,asum +! + character argument*60,arg1*24,arg2*24,ch1*1,lstate*60,propsym*60 + integer typty + logical deblist +! initiate svr internal variables + deblist=.FALSE. +! deblist=.TRUE. + if(ocv()) deblist=.TRUE. + if(deblist) write(*,*)'3F entering decode_statevariable: ',& + statevar(1:len_trim(statevar)) +! write(*,*)'3F svr allocated' + allocate(svr) +! write(*,*)'3F svr assignment start' + svr%oldstv=0 + svr%norm=0 + svr%unit=0 +! svr%argtyp: 0=no arguments; 1=comp; 2=ph+cs; 3=ph+cs+comp; 4=ph+cs+const + svr%argtyp=0 + svr%phref=0 + svr%phase=0 + svr%compset=0 + svr%component=0 + svr%constituent=0 +! write(*,*)'3F svr assignment end' +! +! For wildcard argument "*" return: +! -1 for element or component +! -2 for species or constituent +! -3 for phase +! -4 for composition set + istv=-1 + indices=0 +! iref=0 means user defined reference state + iref=0 +! unit is not implemented (can apply to T, P, V, mass, etc) + iunit=0 + iph=0 + ics=0 + norm=0 +! local character for state variable + lstate=statevar + call capson(lstate) + if(deblist) write(*,*)'3F decode_state_var 1: ',lstate(1:20) +! compare first character + ch1=lstate(1:1) + do is=1,noos + if(ch1.eq.svid(is)(1:1)) goto 50 + enddo +! it may be a property, parameter identifier + goto 600 +!------------------------------------------------------------ +50 continue + if(deblist) write(*,*)'3F dsv 1: ',is,lstate(1:30) + if(is.eq.1) then + if(lstate(2:2).ne.' ') then +! it must be a property like TC or THET + goto 600 + endif +! T + istv=1; svr%oldstv=1; svr%statevarid=1; goto 1000 + elseif(is.eq.2) then +! P + if(lstate(2:2).ne.' ') goto 600 + istv=2; svr%oldstv=2; svr%statevarid=2; goto 1000 + elseif(is.gt.5) then + goto 100 + endif +!------------------------------------------------------------ +! MU 3 component, possible suffix S for SER reference + chemp: if(is.eq.3) then + if(lstate(1:2).ne.'MU') then + goto 600 + endif + istv=3 + jp=3 + elseif(is.eq.4) then +! AC is 4 but just A or AM, AV etc can mean Helmholtz Energy or a property + if(lstate(1:2).ne.'AC') then + is=8; goto 100 + endif + istv=4 + jp=3 + elseif(is.eq.5) then +! LNAC 5 component + if(lstate(1:4).ne.'LNAC') goto 600 + istv=5 + jp=5 + endif chemp +! MU, AC and LNAC can have a suffix 'S', reference state, iref=0 is default + if(lstate(jp:jp).eq.'S') then +! This iref has not been treated correctly so far. The idea is now that +! iref=0 means user defined reference state, if the user has not defined any +! reference state it means SER. If the user specifies a suffix S it means +! always SER even if the user has defined another reference state. +! Maybe iref>0 will have some other meaing in the future ... + iref=-1 + jp=jp+1 + endif +! extract the argument, can be one or two indices + svr%oldstv=istv; svr%statevarid=istv + if(lstate(jp:jp).ne.'(') goto 1130 + kp=index(lstate,')') + if(kp.lt.jp) goto 1140 + argument=lstate(jp+1:kp-1) + kp=index(argument,',') + if(kp.gt.0) then +! >>> if two arguments first is phase ??? different from TC + arg1=argument(1:kp-1) + arg2=argument(kp+1:) + if(arg1(1:2).eq.'* ') then + iph=-3 + else + call find_phase_by_name(arg1,iph,ics) + if(gx%bmperr.ne.0) goto 1150 + endif + if(arg2(1:2).eq.'* ') then + icon=-2 + else + call find_constituent(iph,arg2,cmass,icon) + if(gx%bmperr.ne.0) goto 1160 + call set_constituent_reference_state(iph,icon,asum) + if(gx%bmperr.ne.0) then + gx%bmperr=4112; goto 1000 + endif + endif +! composition set irrelevant as chempot depend only on species stoichiometry + indices(1)=iph + indices(2)=icon + svr%phase=iph + svr%compset=1 + svr%constituent=icon + svr%argtyp=4 + else + if(argument(1:2).eq.'* ') then + icomp=-1 + else + call find_component_by_name(argument,icomp,ceq) + if(gx%bmperr.ne.0) goto 1170 + endif + indices(1)=icomp + svr%component=icomp + svr%argtyp=1 + endif + goto 1000 +!================================================================= +! extensive variable, is=6..20 or a model property +100 continue + jp=2 +! check second letter for some state variables + if(deblist) write(*,105)is,norm,jp +105 format('3F dsv 4: ',3i4) + letter2: if(is.eq.12 .and. lstate(jp:jp).ne.'P') then +! This is for Nx or a property + is=16 + elseif(is.eq.13) then +! this can be Bx for component, BP for phase or BMAG for Bohr magnetons + if(lstate(jp-1:jp).eq.'BP') then + jp=jp+1 + else +! this is Bx or a property + is=18 + endif + elseif(is.eq.14 .and. lstate(jp-1:jp).ne.'DG') then +! this is for Dx, can be a property +! gx%bmperr=4107; goto 1000 + goto 600 + elseif(is.eq.12 .or. is.eq.14) then +! This is NP or DG, increment jp to check the second character + jp=jp+1 + elseif(is.eq.17 .or. is.eq.19) then +! X and W can have a suffix % to indicate percentage + if(lstate(jp:jp).eq.'%') then + iunit=100 + jp=jp+1 + svr%unit=iunit + endif + endif letter2 +!--------------------------------------------------------------------- +! If we come here the first (and sometimes second) letter must have been: +! A, B, BP, D, G, H, N, NP, Q, S, U, W, X, Y +! and "is" is 10, 18, 13, 14, 11, 9, 16, 12, 15, 7, 6, 19, 17, 20 +! NOTE: for N and B the second character has been checked and jp incremented +! if equal to P. The third (for NP and BP forth) character must +! be normallizing (MWVF), a space or a (, otherwise it is a property + if(deblist) write(*,*)'3F lstate: ',lstate(1:20) +! these have no normalizing: Q, X, W, Y + nomalize: if(is.le.14 .or. is.eq.16 .or. is.eq.18) then +! ZM x1 (phase) per mole components +! ZW x2 (phase) per kg +! ZV x3 (phase) per m3 +! ZF x4 phase must be specified per formula unit + ch1=lstate(jp:jp) + jp=jp+1 + if(ch1.eq.'M') then + norm=1 + elseif(ch1.eq.'W') then + norm=2 + elseif(ch1.eq.'V') then + norm=3 + elseif(ch1.eq.'F') then + norm=4 + else +! no or default normalization, backspace + jp=jp-1 + endif + svr%norm=norm + if(deblist) write(*,*)'3F Normalize 1: ',is,jp,ch1,norm + endif nomalize +!--------------------------------------------------------------------- +! reference state can be specified by an S for SER +! If no S the user specified reference states applies + if(lstate(jp:jp).eq.'S') then + jp=jp+1 + iref=-1 + endif +!--------------------------------------------------------------------- +! extract arguments if any. If arguments then lstate(jp:jp) should be ( +! Typically G(fcc#2), N(Cr), BP(fcc), Y(sigma#2,cr#3), TC(BCC#2) +!300 continue + if(deblist) write(*,*)'3F args: ',jp,lstate(1:jp+10) + narg=0 + args: if(lstate(jp:jp).eq.'(') then + kp=index(lstate,')') + if(kp.le.0) then + if(deblist) write(*,110)'3F dsv 5: ',is,jp,kp,lstate(1:20) +110 format(a,3i3,a) + gx%bmperr=4103; goto 1000 + endif + argument=lstate(jp+1:kp-1) + kp=index(argument,',') + arg: if(kp.gt.0) then + arg1=argument(1:kp-1) + arg2=argument(kp+1:) + narg=2 + kp=index(arg2,',') + if(kp.gt.0) then +! too many arguments to a state variable + gx%bmperr=4097; goto 1000 + endif + else !no arg + narg=1 + arg1=argument + endif arg + elseif(lstate(jp:jp).ne.' ') then +! if additional character then it must be a property + goto 600 + endif args +!------------------ +! transform arguments to indices, different arguments for 6- +! Handle arguments: U, S, V, H, A, G, NP, BP,DG, Q, N, X, B, W, Y +! 6, 7, 8, 9,10, 11,12, 13,14,15,16,17,18,19,20 + if(narg.eq.1) then + if(is.le.15 .or. is.ge.21) then +! single argument is phase+composition set + if(arg1(1:2).eq.'* ') then + iph=-3 + ics=-4 + else + call find_phase_by_name(arg1,iph,ics) + if(gx%bmperr.ne.0) goto 1000 + endif + indices(1)=iph + indices(2)=ics + svr%phase=iph + svr%compset=ics + svr%argtyp=2 + elseif(is.eq.20) then +! state variable Y must have 2 arguments + gx%bmperr=4098; goto 1000 + else +! single argument is component for is=16-19 + if(arg1(1:2).eq.'* ') then + icomp=-1 + else + call find_component_by_name(arg1,icomp,ceq) + if(gx%bmperr.ne.0) goto 1000 + endif + indices(1)=icomp + svr%component=icomp + svr%argtyp=1 + endif + elseif(narg.eq.2) then +! two arguments only for is=16-20, first phase, second component or constit + if(is.le.15 .or. is.ge.21) then + gx%bmperr=4110; goto 1000 + endif + if(arg1(1:2).eq.'* ') then + iph=-3 + ics=-4 + else + call find_phase_by_name(arg1,iph,ics) + if(gx%bmperr.ne.0) goto 1000 + endif + indices(1)=iph + indices(2)=ics + svr%phase=iph + svr%compset=ics + if(is.eq.20) then + if(arg2(1:2).eq.'* ') then + icc=-2 + else + call find_constituent(iph,arg2,cmass,icc) + if(gx%bmperr.ne.0) goto 1000 + endif + svr%constituent=icc + svr%argtyp=4 + else + if(arg2(1:2).eq.'* ') then + icc=-1 + else + call find_component_by_name(arg2,icc,ceq) + if(gx%bmperr.ne.0) goto 1000 + endif + svr%component=icc + svr%argtyp=3 + endif +! note indices(4) never used as icc is constituent index, arg2 must have +! a #sublattice to find the correct, otherwise always the first occurence +! In a sigma (Fe)(Cr)(Cr,Fe) y(sigma,cr)=1 but y(sigma,cr#3) gives Cr in third + indices(3)=icc + elseif((is.ge.12 .and. is.le.15) .or. is.eq.17 .or. is.ge.19) then +! There must be an argument for NP, BP, DG, Q, X, W, Y, TC and BMAG + gx%bmperr=4111; goto 1000 + elseif(norm.eq.4) then +! there must be a phase specification for a quantity per formula unit + gx%bmperr=4115; goto 1000 + endif +! if(is.eq.17 .or. is.eq.19) then +! is=is-1 +! svr%norm=1 + if(is.eq.16) svr%norm=1 + if(is.eq.18) svr%norm=2 +! endif +!----------------------- +500 continue +!----------------------------------------------------------------------- +! U 1x (phase,composition set) Internal energy (J) +! S 2x entropy +! V 3x volume +! H 4x enthalpy +! A 5x Helmholtz energy +! G 6x Gibbs energy +! NP 7x phase moles of phase +! BP 8x phase mass of phase +! N 9x (component/phase,component) moles >>14 +! X 9x component/phase,component mole fraction >>15 +! B 10x (component/phase,component) mass >>16 +! W 10x mass fraction >>17 +! Y 11 phase,constituent#sublattice constituent fraction >>18 +! Q 12 Internal stability >>19 +! DG 13x Driving force +! TC, BM, MQ& etc (model variables) + svr%statevarid=is + extensive: if(is.eq.6) then +! U 1x (phase) Internal energy (J) + istv=10+norm + elseif(is.eq.7) then +! S 2x entropy + istv=20+norm + elseif(is.eq.8) then +! V 3x volume + istv=30+norm + elseif(is.eq.9) then +! H 4x enthalpy + istv=40+norm + elseif(is.eq.10) then +! A 5x Helmholtz energy + istv=50+norm + elseif(is.eq.11) then +! G 6x Gibbs energy + istv=60+norm + elseif(is.eq.12) then +! NP 7x phase moles of phase + istv=70+norm + elseif(is.eq.13) then +! BP 8x phase mass of phase + istv=80+norm + elseif(is.eq.14) then +! DG 9x Driving force + istv=90+norm + elseif(is.eq.15) then +! Q 10x Internal stability + istv=100+norm + elseif(is.eq.16 .or. is.eq.17) then +! N 11x (component/phase,component) moles +! X=NM 111 mole fraction +! X% 111, iunit=100 mole percent + if(is.eq.16) then + istv=110+norm + else + istv=111 + endif + elseif(is.eq.18 .or. is.eq.19) then +! B 12x (component/phase,component) mass +! W=BW 122 mass fraction +! W% 122, iunit=100 mass percent + if(is.eq.18) then + istv=120+norm + else + istv=122 + endif + elseif(is.eq.20) then +! Y 130 phase#comp.set,constituent#sublat constituent fraction + istv=130 + else +! the symbol may be a property + if(deblist) write(*,*)'3F maybe a property ',is + goto 600 + endif extensive + goto 1000 +!------------------------------------------------ +! handling of properties like TC, BMAGN, MQ etc +600 continue +! the symbol may be a property symbol + propsym=statevar +! second argument 0 means a symbol + call find_defined_property(propsym,0,typty,iph,ics) + if(deblist) write(*,*)'3F at 600: ',propsym(1:len_trim(propsym)),typty + if(gx%bmperr.ne.0) then + svr%oldstv=-1; goto 1000 + endif + indices(1)=iph + indices(2)=ics + svr%phase=iph + svr%compset=ics +!----------------------------- unfinished ????? + if(typty.gt.100) then +! typty: third argument is constituent (or component??) + istv=-typty/100 + indices(3)=typty+100*istv + svr%argtyp=4 + elseif(typty.gt.1) then + istv=-typty + svr%argtyp=3 + svr%argtyp=2 + else +! unknown propery + write(*,*)'3F Unknown state variable or property',typty + gx%bmperr=7777; goto 1000 + endif + svr%oldstv=istv + svr%statevarid=istv + svr%constituent=indices(3) + if(deblist) write(*,611)'3F Property: ',is,istv,typty,indices +611 format(a,10i4) +!------------------------------------------------ +1000 continue +! accept the current istv as svr%oldstv, store a suffix S on MU as phref<0 + svr%oldstv=istv + svr%phref=iref + if(deblist) write(*,1001)'3F exit decode: ',istv,(indices(is),is=1,4),& + norm,iref,iunit,svr%oldstv,svr%phase,svr%compset,svr%component,& + svr%constituent,svr%norm,svr%phref,svr%unit,svr%argtyp,& + svr%statevarid,gx%bmperr +1001 format(a,i5,4i3,2x,3i5/17x,i5,4i3,2x,6i5) + return +!---------------- errors ------------------------------- +! Wrong first character of state variable +1100 continue + gx%bmperr=4099; goto 1000 +! M not followed by U +!1110 continue +! gx%bmperr=4100; goto 1000 +! L not followed by NAC +!1120 continue +! gx%bmperr=4101; goto 1000 +! No opening ( for arguments +1130 continue + gx%bmperr=4102; goto 1000 +! No closing ) for arguments +1140 continue + gx%bmperr=4103; goto 1000 +! Unknown phase used as argument in state variable +1150 continue + gx%bmperr=4104; goto 1000 +! No such constituent +1160 continue + gx%bmperr=4105; goto 1000 +! No such component +1170 continue + gx%bmperr=4106; goto 1000 + end subroutine decode_state_variable3 + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine calc_phase_molmass(iph,ics,xmol,wmass,totmol,totmass,amount,ceq) +! calculates mole fractions and mass fractions for a phase#set +! xmol and wmass are fractions of components in mol or mass +! totmol is total number of moles and totmass total mass of components. +! amount is number of moles of components per formula unit. + implicit none + TYPE(gtp_equilibrium_data) :: ceq + integer iph,ics + double precision, dimension(*) :: xmol,wmass + double precision amount,totmol,totmass +!\end{verbatim} + integer ic,jc,lokph,lokcs,ll,iel,lokel,ie,kk,loksp + double precision as,yz,xsum,wsum + double precision, dimension(maxel) :: x2mol,w2mass +! + do ic=1,noofel + xmol(ic)=zero + wmass(ic)=zero + enddo + call get_phase_compset(iph,ics,lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 + ic=0 +! +! bug here when calculating Cr-Fe because we create new composition set ... + if(ocv()) write(*,14)'3F cpm: ',iph,ics,lokph,lokcs +14 format(a,10i5) + allsubl: do ll=1,phlista(lokph)%noofsubl + as=ceq%phase_varres(lokcs)%sites(ll) + allcons: do kk=1,phlista(lokph)%nooffr(ll) + ic=ic+1 + if(.not.btest(ceq%phase_varres(lokcs)%constat(ic),CONSUS)) then + yz=ceq%phase_varres(lokcs)%yfr(ic) + loksp=phlista(lokph)%constitlist(ic) +! isq just for debug output +! isq=splista(loksp)%alphaindex +! write(*,11)'3F cpm 3: ',lokph,lokcs,loksp,splista(loksp)%noofel +!11 format(a,5i3) + do iel=1,splista(loksp)%noofel + lokel=splista(loksp)%ellinks(iel) + ie=ellista(lokel)%alphaindex + if(ie.ne.0) then + xmol(ie)=xmol(ie)+& + as*yz*splista(loksp)%stoichiometry(iel) + endif + enddo +! if(ie.gt.0) then +! write(*,711)ic,loksp,isq,lokel,ie,yz,xmol(ie) +! else +! write(*,711)ic,loksp,isq,lokel,ie,yz +! endif +!711 format('3F cpmm: ',5i9,2F7.4) + endif + enddo allcons + enddo allsubl +! normallize, All ok here +! write(*,713)'A',noofel,(xmol(iq),iq=1,noofel) +713 format('3F x:',a,i2,10f7.4) +!800 continue + xsum=zero + wsum=zero +! here xmol(i) is equal to the number of moles of element i per formula unit +! set wmass(i) to the mass of of element i per mole formula unit and sum + do ic=1,noofel + wmass(ic)=xmol(ic)*ellista(elements(ic))%mass + xsum=xsum+xmol(ic) + wsum=wsum+wmass(ic) + enddo +! write(*,713)'F',noofel,xsum,(xmol(iq),iq=1,noofel) + do ic=1,noofel + xmol(ic)=xmol(ic)/xsum + wmass(ic)=wmass(ic)/wsum + enddo +! This is the current number of formula unit of the phase, zero if not stable + amount=ceq%phase_varres(lokcs)%amfu +! ceq%phase_varres(lokcs)%abnorm(1) is moles atoms for one formula unit +! ceq%phase_varres(lokcs)%abnorm(2) is mass for one formula unit + totmol=amount*xsum + totmass=amount*wsum +! write(*,717)'3F z:',noofel,lokcs,totmol,totmass,amount,& +! wsum,ceq%phase_varres(lokcs)%abnorm(2) +717 format(a,i3,i6,6(1pe12.4)) +! all seems OK here +! write(*,811)xsum,ceq%phase_varres(lokcs)%abnorm(1),& +! wsum,ceq%phase_varres(lokcs)%abnorm(2),amount,totmass +! write(*,811)xsum,ceq%phase_varres(lokcs)%abnorm(1),& +! wsum,ceq%phase_varres(lokcs)%abnorm(2),amount,totmass +811 format('cphmm: ',6(1pe12.4)) +! write(*,*)'cpmm: ',totmol,totmass +! all calculation so far in elements, convert to current components +! NOTE: sum of mole fractions can be zero or negative with other +! components than elements +76 format(a,10F7.4) +78 format(a,2i3,3(1PE12.4)) +! do ic=1,noofel +! write(*,298)(ceq%invcompstoi(jc,ic),jc=1,noofel) +! enddo +!298 format('3F: ',6(1pe12.4)) + goto 1000 +! what is this ... converting to user defined components ... (not implemented) + x2mol=zero + w2mass=zero + do ic=1,noofel + do jc=1,noofel + x2mol(ic)=x2mol(ic)+ceq%invcompstoi(jc,ic)*xmol(jc) +! write(*,78)'addon: ',ic,jc,x2mol(ic),ceq%invcompstoi(jc,ic),xmol(jc) + w2mass(ic)=w2mass(ic)+ceq%invcompstoi(ic,jc)*wmass(jc) + enddo + enddo +! do ic=1,noofel +! write(*,99)'ci: ',(ceq%invcompstoi(jc,ic),jc=1,noofel) +! enddo +99 format(a,7e11.3) +! write(*,76)'cmm2: ',(x2mol(ic),ic=1,noofel) + do ic=1,noofel + xmol(ic)=x2mol(ic) + wmass(ic)=w2mass(ic) + enddo +! something wrong between writing label 713 above and here !!!!!!!!!!!!! +! write(*,713)'B',noofel,(xmol(iq),iq=1,noofel) +1000 continue + return + end subroutine calc_phase_molmass + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine calc_phase_mol(iph,xmol,ceq) +! calculates mole fractions for phase iph, compset 1 in equilibrium ceq +! used for grid generation and some other things +! returns current constitution in xmol equal to mole fractions of components + implicit none + integer iph + double precision xmol(*) + TYPE(gtp_equilibrium_data) :: ceq +!\end{verbatim} + integer ic,lokph,lokcs,ll,kk,loksp,lokel,iel,ie + double precision as,yz,xsum + do ic=1,noofel + xmol(ic)=zero + enddo + lokph=phases(iph) + lokcs=phlista(lokph)%linktocs(1) + ic=0 + allsubl: do ll=1,phlista(lokph)%noofsubl + as=ceq%phase_varres(lokcs)%sites(ll) + allcons: do kk=1,phlista(lokph)%nooffr(ll) + ic=ic+1 + if(.not.btest(ceq%phase_varres(lokcs)%constat(ic),CONSUS)) then + yz=ceq%phase_varres(lokcs)%yfr(ic) + loksp=phlista(lokph)%constitlist(ic) + do iel=1,splista(loksp)%noofel + lokel=splista(loksp)%ellinks(iel) + ie=ellista(lokel)%alphaindex + if(ie.ne.0) then + xmol(ie)=xmol(ie)+& + as*yz*splista(loksp)%stoichiometry(iel) + endif + enddo + endif + enddo allcons + enddo allsubl +! normallize + xsum=zero + do ic=1,noofel + xsum=xsum+xmol(ic) + enddo + do ic=1,noofel + xmol(ic)=xmol(ic)/xsum + enddo +1000 continue + return + end subroutine calc_phase_mol + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine calc_molmass(xmol,wmass,totmol,totmass,ceq) +! summing up N and B for each component over all phases with positive amount +! Check that totmol and totmass are correct .... + implicit none + double precision, dimension(*) :: xmol,wmass + double precision totmol,totmass + TYPE(gtp_equilibrium_data) :: ceq +!\end{verbatim} + double precision am,amult,tmol,tmass + double precision, dimension(maxel) :: xph,wph + integer ic,iph,lokph,ics,lokcs + do ic=1,noofel + xmol(ic)=zero + wmass(ic)=zero + enddo + totmol=zero + totmass=zero + allph: do iph=1,noofph + lokph=phases(iph) + if(.not.btest(phlista(lokph)%status1,phhid)) then + allcs: do ics=1,phlista(lokph)%noofcs + lokcs=phlista(lokph)%linktocs(ics) +! ceq%phase_varres(lokcs)%amfu is current number of formula units +! ceq%phase_varres(lokcs)%abnorm(1) is number of real atoms in a formula unit + am=ceq%phase_varres(lokcs)%amfu*& + ceq%phase_varres(lokcs)%abnorm(1) + if(am.gt.zero) then + call calc_phase_molmass(iph,ics,xph,wph,tmol,tmass,amult,ceq) + if(gx%bmperr.ne.0) goto 1000 +! write(*,17)'3F amult:',iph,ics,am,amult,tmol,tmass +! write(*,18)'3F x0: ',(xph(ic),ic=1,noofel) +! write(*,18)'3F w0: ',(wph(ic),ic=1,noofel) +17 format(a,2i4,6(1pe14.6)) +18 format(a,8(F9.5)) + do ic=1,noofel + xmol(ic)=xmol(ic)+am*xph(ic) + wmass(ic)=wmass(ic)+tmass*wph(ic) + enddo + totmass=totmass+tmass + totmol=totmol+tmol + endif + enddo allcs + endif + enddo allph +! we have summed the number of moles and mass of all elements in all phases +! xsum=zero +! wsum=zero +! do ic=1,noofel +! xsum=xsum+xmol(ic) +! wsum=wsum+wmass(ic) +! enddo + if(totmass.gt.zero) then + do ic=1,noofel + xmol(ic)=xmol(ic)/totmol + wmass(ic)=wmass(ic)/totmass + enddo +! write(*,21)'3F x1: ',totmol,(xmol(ic),ic=1,noofel) +! write(*,21)'3F w2: ',totmass,(wmass(ic),ic=1,noofel) +21 format(a,1pe12.4,8(0pF9.5)) +! else +! write(*,*)'There is no mass at all in the system!' +! gx%bmperr=4185; goto 1000 + endif +! write(*,21)'3F x1: ',totmol,(xmol(ic),ic=1,noofel) +! write(*,21)'3F w1: ',totmass,(wmass(ic),ic=1,noofel) +! else +! this is not an error if no calculation has been made +! write(*,28)'3F: calc_molmass: No mole fractions',totmol,totmass,xsum,& +! (xmol(ic),ic=1,noofel) +28 format(a,3(1pe12.4)/'3F. ',10f7.4) +! gx%bmperr=4185; goto 1000 +! endif +! wsum=zero +! do ic=1,noofel +! wmass(ic)=xmol(ic)*ellista(elements(ic))%mass +! wsum=wsum+wmass(ic) +! write(*,44)'3F cmm4: ',ic,xmol(ic),wmass(ic),& +! ellista(elements(ic))%mass,wsum,totmass +44 format(a,i3,6(1pe12.4)) +! enddo +! if(wsum.gt.zero) then +! do ic=1,noofel +! wmass(ic)=wmass(ic)/wsum +! enddo +! endif +1000 continue + return + end subroutine calc_molmass + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine sumprops(props,ceq) +! summing up G, S, V, N and B for all phases with positive amount +! Check if this is correct + implicit none + TYPE(gtp_equilibrium_data) :: ceq + double precision props(5) +!\end{verbatim} + integer lokph,lokcs,ics + double precision am + if(gx%bmperr.ne.0) write(*,*)'3F error entering sumprops ',gx%bmperr + props=zero + allph: do lokph=1,noofph +! write(*,*)'3F sumprops: ',lokph + if(.not.btest(phlista(lokph)%status1,phhid)) then +! lokcs=phlista(lokph)%cslink + allcs: do ics=1,phlista(lokph)%noofcs +! phase_varres(lokcs)%amfu is the amount formula units of the phase +! phase_varres(lokcs)%abnorm(1) is the moles of real atoms/formula unit +! am is the number of moles of real atoms of the phase + lokcs=phlista(lokph)%linktocs(ics) +! skip phases that are not entered + if(ceq%phase_varres(lokcs)%phstate.eq.phdorm) cycle + am=ceq%phase_varres(lokcs)%amfu*& + ceq%phase_varres(lokcs)%abnorm(1) +! write(*,7)'3F sumprops 2: ',lokph,lokcs,am,& +! ceq%phase_varres(lokcs)%abnorm(1),& +! ceq%phase_varres(lokcs)%abnorm(2),props(5) +7 format(a,2i5,6(1pe12.4)) + if(am.gt.zero) then +! properties are G, G.T=-S, G.P=V and moles and mass of real atoms +! Note gval(*,1) is per mole formula unit and ceq%phase_varres(lokcs)%abnorm(1) +! is the number of real atoms per formula unit + props(1)=props(1)+am*ceq%phase_varres(lokcs)%gval(1,1)/& + ceq%phase_varres(lokcs)%abnorm(1) + props(2)=props(2)+am*ceq%phase_varres(lokcs)%gval(2,1)/& + ceq%phase_varres(lokcs)%abnorm(1) + props(3)=props(3)+am*ceq%phase_varres(lokcs)%gval(3,1)/& + ceq%phase_varres(lokcs)%abnorm(1) + props(4)=props(4)+am +! ceq%phase_varres(lokcs)%abnorm(2) should be the current mass +! %abnorm(2) is actual mass, its should be multiplied with %amfu, not am!! +! This value is calculated in set_constitution ... check there if problems + props(5)=props(5)+ceq%phase_varres(lokcs)%amfu*& + ceq%phase_varres(lokcs)%abnorm(2) +! write(*,75)'3F sumprops: ',lokcs,am,& +! ceq%phase_varres(lokcs)%abnorm(2),props(5) +75 format(a,i4,6(1pe12.4)) +! write(*,11)'3F sumprops: ',lokcs,props(1),props(4),props(5),& +! ceq%phase_varres(lokcs)%abnorm(2) +! write(*,11)'3F sumprops ',lokcs,am,props(4),& +! ceq%phase_varres(lokcs)%abnorm(1) +11 format(a,i4,6(1pe12.4)) + endif + enddo allcs + endif + enddo allph +1000 continue + if(gx%bmperr.ne.0) write(*,*)'3F error exiting sumprops ',gx%bmperr + return + end subroutine sumprops + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine encode_state_variable(text,ip,svr,ceq) +! writes a state variable in text form position ip. ip is updated + character text*(*) + integer ip + type(gtp_state_variable), pointer :: svr + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} %+ + integer istv,indices(4),iunit,iref + iref=svr%phref + iunit=svr%unit +! if svr%oldstv>=10 then istv should be 10*(svr%oldstv-5)+svr%norm +! if(svr%oldstv.ge.10) then +! istv=10*(svr%oldstv-5)+svr%norm +! write(*,*)'3F encode: ',svr%oldstv,svr%norm,istv +! else + istv=svr%oldstv +! endif +! svr%argtyp specifies values in indices: +! svr%argtyp: 0=no arguments; 1=comp; 2=ph+cs; 3=ph+cs+comp; 4=ph+cs+const + indices=0 + if(svr%argtyp.eq.1) then + indices(1)=svr%component + elseif(svr%argtyp.eq.2) then + indices(1)=svr%phase + indices(2)=svr%compset + elseif(svr%argtyp.eq.3) then + indices(1)=svr%phase + indices(2)=svr%compset + indices(3)=svr%component + elseif(svr%argtyp.eq.4) then + indices(1)=svr%phase + indices(2)=svr%compset + indices(3)=svr%constituent +! else +! write(*,*)'3F state variable has illegal argtyp: ',svr%argtyp +! gx%bmperr=7775; goto 1000 + endif + call encode_state_variable3(text,ip,istv,indices,iunit,iref,ceq) +1000 continue + return + end subroutine encode_state_variable + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine encode_state_variable3(text,ip,istv,indices,iunit,iref,ceq) +! writes a state variable in text form position ip. ip is updated +! the internal coding provides in istv, indices, iunit and iref +! ceq is needed as compopnents can be different in different equilibria ?? +! >>>> unfinished as iunit and iref not really cared for + implicit none + integer, parameter :: noos=20 + character*4, dimension(noos), parameter :: svid = & + ['T ','P ','MU ','AC ','LNAC','U ','S ','V ',& + 'H ','A ','G ','NP ','BP ','DG ','Q ','N ',& + 'X ','B ','W ','Y '] + character*(*) text + integer, dimension(4) :: indices + integer istv,ip,iunit,iref + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer jp,ics,kstv,iph,norm,sublat +! + character stsymb*60 + character*1, dimension(4), parameter :: cnorm=['M','W','V','F'] +! + if(istv.le.0) then +! this is a parameter property symbol: TC (-2), BM (-3), MQ&FE(FCC) (-4) etc +! translate to 21, 22, 23 ... + kstv=19-istv + goto 200 +! gx%bmperr=4116; goto 1000 + endif +! T or P + if(istv.le.2) then + text(ip:ip)=svid(istv) + ip=ip+1 + goto 1000 + endif + stsymb=' ' +! potential: if(istv.le.6) then + potential: if(istv.le.5) then +! Potential, MU, AC or LNAC, possible suffix 'S' for SER + stsymb=svid(istv) + jp=len_trim(stsymb)+1 + if(iref.lt.0) then +! New use of svr%phref and iref, <0 means use SER as reference state + stsymb(jp:jp)='S' + jp=jp+1 + endif + stsymb(jp:jp)='(' + jp=jp+1 + if(indices(2).eq.0) then +! problem ... component names different in different equilibria .... + call get_component_name(indices(1),stsymb(jp:),ceq) + if(gx%bmperr.ne.0) goto 1000 + jp=len_trim(stsymb)+1 + stsymb(jp:jp)=')' + jp=jp+1 + else +! always use composition set 1 + ics=1 + call get_phase_name(indices(1),ics,stsymb(jp:)) + if(gx%bmperr.ne.0) goto 1000 + jp=len_trim(stsymb)+1 + stsymb(jp:jp)=','; jp=jp+1 + call get_phase_constituent_name(indices(1),indices(2),& + stsymb(jp:),sublat) + if(gx%bmperr.ne.0) goto 1000 + jp=len_trim(stsymb)+1 + if(sublat.gt.1) then + stsymb(jp:)='#'//char(ichar('0')+sublat)//')' + jp=jp+3 + else + stsymb(jp:jp)=')' + jp=jp+1 + endif + endif + goto 800 + endif potential + if(istv.lt.10) then +! write(*,*)'3F unknown potential' + gx%bmperr=4158; goto 1000 + endif +! Extensive property has istv>=10 + norm=mod(istv,10) + kstv=(istv+1)/10+5 +! write(*,3)'3F encode 3: ',kstv,indices +!3 format(a,5i5) + if(kstv.eq.16 .and. norm.eq.1) then +! NM should be X + if(indices(1).ne.0) kstv=17 + elseif(kstv.eq.17) then +! BW should be W + if(norm.eq.2 .and. indices(1).ne.0) then + kstv=19 + else + kstv=18 + endif + elseif(kstv.ge.18) then +! Y +! kstv=kstv+2 + kstv=20 + endif +! write(*,11)'3F esv 7: ',istv,kstv,indices +11 format(a,10i4) + stsymb=svid(kstv) + jp=len_trim(stsymb)+1 +! write(*,*)'3F norm 1A: ',kstv,norm + if(kstv.le.16 .or. kstv.eq.18) then + if(norm.gt.0 .and. norm.le.4) then +! write(*,*)'3F norm 1B: ',kstv,norm + stsymb(jp:jp)=cnorm(norm) + jp=jp+1 + elseif(norm.ne.0) then +! write(*,*)'3F norm 1C: ',kstv,norm + gx%bmperr=4118; goto 1000 + endif + endif + goto 500 +!----------------- +! parameter property symbols +200 continue + iph=indices(1) + ics=indices(2) + if(indices(3).ne.0) then + kstv=-100*istv+indices(3) + else + kstv=-istv + endif +! this call creates the symbol or gives an error + call find_defined_property(stsymb,1,kstv,iph,ics) + if(gx%bmperr.ne.0) goto 1000 + jp=len_trim(stsymb)+1 + goto 800 +!------------------ +! handle indices +500 continue + noind: if(indices(3).gt.0) then +! 3 indices, phase, comp.set and constituent allowed for Y +! or phase, comp.set and component, allowed for N, X, B and W +! or phase, comp.set and constituent allowed for MQ& + if(kstv.eq.20) then +! this is Y + stsymb(jp:jp)='(' + jp=jp+1 + call get_phase_name(indices(1),indices(2),stsymb(jp:)) + if(gx%bmperr.ne.0) goto 1000 + jp=len_trim(stsymb)+1 + stsymb(jp:jp)=',' + jp=jp+1 + call get_phase_constituent_name(indices(1),indices(3),& + stsymb(jp:),sublat) + if(gx%bmperr.ne.0) goto 1000 +! sublattice is the last argument + jp=len_trim(stsymb)+1 + if(sublat.gt.1) then + stsymb(jp:)='#'//char(ichar('0')+sublat)//')' + jp=jp+3 + else + stsymb(jp:jp)=')' + jp=jp+1 + endif + elseif(kstv.ge.16 .and. kstv.le.19) then +! allow for percent or % + if(iunit.eq.100) then + stsymb(jp:jp+1)='%(' + jp=jp+2 + else + stsymb(jp:jp)='(' + jp=jp+1 + endif + call get_phase_name(indices(1),indices(2),stsymb(jp:)) + if(gx%bmperr.ne.0) goto 1000 + jp=len_trim(stsymb)+1 + stsymb(jp:jp)=',' + jp=jp+1 + call get_component_name(indices(3),stsymb(jp:),ceq) + if(gx%bmperr.ne.0) goto 1000 + jp=len_trim(stsymb)+1 + stsymb(jp:jp)=')' + jp=jp+1 + else + gx%bmperr=4117; goto 1000 + endif + elseif(indices(2).gt.0) then +! 2 indices, can only be phase and comp.set + stsymb(jp:jp)='(' + jp=jp+1 + call get_phase_name(indices(1),indices(2),stsymb(jp:)) + if(gx%bmperr.ne.0) goto 1000 + jp=len_trim(stsymb)+1 + stsymb(jp:jp)=')' + jp=jp+1 + elseif(indices(1).gt.0) then +! 1 index, can only be component +! allow for percent or % + if(iunit.eq.100) then + stsymb(jp:jp+1)='%(' + jp=jp+2 + else + stsymb(jp:jp)='(' + jp=jp+1 + endif + call get_component_name(indices(1),stsymb(jp:),ceq) + if(gx%bmperr.ne.0) goto 1000 + jp=len_trim(stsymb)+1 + stsymb(jp:jp)=')' + jp=jp+1 +! >>>> unfinished + endif noind +! +800 continue + text(ip:ip+jp-1)=stsymb + ip=ip+jp + if(text(ip:ip).eq.' ') then +! remove a trailing space occuring in some cases + ip=ip-1 + endif +1000 continue + return + end subroutine encode_state_variable3 + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine encode_state_variable_record(text,ip,svr,ceq) +! writes a state variable in text form position ip. ip is updated +! the svr record provide istv, indices, iunit and iref +! ceq is needed as compopnents can be different in different equilibria ?? +! >>>> unfinished as iunit and iref not really cared for + implicit none + integer, parameter :: noos=20 + character*4, dimension(noos), parameter :: svid = & + ['T ','P ','MU ','AC ','LNAC','U ','S ','V ',& + 'H ','A ','G ','NP ','BP ','DG ','Q ','N ',& + 'X ','B ','W ','Y '] + character*(*) text + type(gtp_state_variable) :: svr + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer jp,ics,kstv,iph,norm,sublat + integer, dimension(4) :: indices + integer istv,ip,iunit,iref +! + character stsymb*60 + character*1, dimension(4), parameter :: cnorm=['M','W','V','F'] +! + istv=svr%oldstv + norm=svr%norm + iunit=svr%unit + indices=0 + if(svr%argtyp.eq.1) then + indices(1)=svr%component + elseif(svr%argtyp.eq.2) then + indices(1)=svr%phase + indices(2)=svr%compset + elseif(svr%argtyp.eq.3) then + indices(1)=svr%phase + indices(2)=svr%compset + indices(3)=svr%component + elseif(svr%argtyp.eq.4) then + indices(1)=svr%phase + indices(2)=svr%compset + indices(3)=svr%constituent + endif +! there is some cloudy thinking here. If the user has defined his own +! reference state that should be used. The information is stored in the +! component record (ceq%complist(i)%phlink +! But if the user specifies MUS(i) one should use SER ... how to transfer that +! information to the calculating routines? +! By default svr%phref=0, then use user defined. If phref<0 use SER ?? + iref=svr%phref +! + if(istv.le.0) then +! this is a parameter property symbol: TC (-2), BM (-3), MQ&FE(FCC) (-4) etc +! translate to 21, 22, 23 ... + kstv=19-istv + goto 200 +! gx%bmperr=4116; goto 1000 + endif +! T or P + if(istv.le.2) then + text(ip:ip)=svid(istv) + ip=ip+1 + goto 1000 + endif + stsymb=' ' +! potential: if(istv.le.6) then + potential: if(istv.le.5) then +! Potential, MU, AC or LNAC, possible suffix 'S' for SER + stsymb=svid(istv) + jp=len_trim(stsymb)+1 +! if(iref.ne.0) then + if(iref.lt.0) then +! new use of phref and iref, <0 means use SER and suffix S + stsymb(jp:jp)='S' + jp=jp+1 + endif + stsymb(jp:jp)='(' + jp=jp+1 + if(indices(2).eq.0) then +! problem ... component names can be different in different equilibria .... + call get_component_name(indices(1),stsymb(jp:),ceq) + if(gx%bmperr.ne.0) goto 1000 + jp=len_trim(stsymb)+1 + else +! always use composition set 1 + ics=1 + call get_phase_name(indices(1),ics,stsymb(jp:)) + if(gx%bmperr.ne.0) goto 1000 + jp=len_trim(stsymb)+1 + stsymb(jp:jp)=','; jp=jp+1 + call get_phase_constituent_name(indices(1),indices(2),& + stsymb(jp:),sublat) + if(gx%bmperr.ne.0) goto 1000 + jp=len_trim(stsymb)+1 + if(sublat.gt.1) then + stsymb(jp:)='#'//char(ichar('0')+sublat)//')' + jp=jp+3 + else + stsymb(jp:jp)=')' + jp=jp+1 + endif + endif + stsymb(jp:jp)=')' + goto 800 + endif potential + if(istv.lt.10) then +! write(*,*)'3F unknown potential' + gx%bmperr=4158; goto 1000 + endif +! Extensive property has istv>=10 + norm=mod(istv,10) + kstv=(istv+1)/10+5 +! write(*,3)'3F encode 3: ',kstv,indices +!3 format(a,5i5) + if(kstv.eq.16 .and. norm.eq.1) then +! NM should be X + if(indices(1).ne.0) kstv=17 + elseif(kstv.eq.17) then +! BW should be W + if(norm.eq.2 .and. indices(1).ne.0) then + kstv=19 + else + kstv=18 + endif + elseif(kstv.ge.18) then +! Y +! kstv=kstv+2 + kstv=20 + endif +! write(*,11)'3F esv 7: ',istv,kstv,indices +11 format(a,10i4) + stsymb=svid(kstv) + jp=len_trim(stsymb)+1 +! write(*,*)'3F norm 2: ',kstv,norm + if(kstv.le.16 .or. kstv.eq.18) then + if(norm.gt.0 .and. norm.le.4) then + stsymb(jp:jp)=cnorm(norm) + jp=jp+1 + elseif(norm.ne.0) then + gx%bmperr=4118; goto 1000 + endif + endif + goto 500 +!----------------- +! parameter property symbols +200 continue + iph=indices(1) + ics=indices(2) + if(indices(3).ne.0) then + kstv=-100*istv+indices(3) + else + kstv=-istv + endif +! this call creates the symbol or gives an error + call find_defined_property(stsymb,1,kstv,iph,ics) + if(gx%bmperr.ne.0) goto 1000 + jp=len_trim(stsymb)+1 + goto 800 +!------------------ +! handle indices +500 continue + noind: if(indices(3).gt.0) then +! 3 indices, phase, comp.set and constituent allowed for Y +! or phase, comp.set and component, allowed for N, X, B and W +! or phase, comp.set and constituent allowed for MQ& + if(kstv.eq.20) then +! this is Y + stsymb(jp:jp)='(' + jp=jp+1 + call get_phase_name(indices(1),indices(2),stsymb(jp:)) + if(gx%bmperr.ne.0) goto 1000 + jp=len_trim(stsymb)+1 + stsymb(jp:jp)=',' + jp=jp+1 + call get_phase_constituent_name(indices(1),indices(3),& + stsymb(jp:),sublat) + if(gx%bmperr.ne.0) goto 1000 + jp=len_trim(stsymb)+1 + if(sublat.gt.1) then + stsymb(jp:)='#'//char(ichar('0')+sublat)//')' + jp=jp+3 + else + stsymb(jp:jp)=')' + jp=jp+1 + endif + elseif(kstv.ge.16 .and. kstv.le.19) then +! allow for percent or % + if(iunit.eq.100) then + stsymb(jp:jp+1)='%(' + jp=jp+2 + else + stsymb(jp:jp)='(' + jp=jp+1 + endif + call get_phase_name(indices(1),indices(2),stsymb(jp:)) + if(gx%bmperr.ne.0) goto 1000 + jp=len_trim(stsymb)+1 + stsymb(jp:jp)=',' + jp=jp+1 + call get_component_name(indices(3),stsymb(jp:),ceq) + if(gx%bmperr.ne.0) goto 1000 + jp=len_trim(stsymb)+1 + stsymb(jp:jp)=')' + jp=jp+1 + else + gx%bmperr=4117; goto 1000 + endif + elseif(indices(2).gt.0) then +! 2 indices, can only be phase and comp.set + stsymb(jp:jp)='(' + jp=jp+1 + call get_phase_name(indices(1),indices(2),stsymb(jp:)) + if(gx%bmperr.ne.0) goto 1000 + jp=len_trim(stsymb)+1 + stsymb(jp:jp)=')' + jp=jp+1 + elseif(indices(1).gt.0) then +! 1 index, can only be component +! allow for percent or % + if(iunit.eq.100) then + stsymb(jp:jp+1)='%(' + jp=jp+2 + else + stsymb(jp:jp)='(' + jp=jp+1 + endif + call get_component_name(indices(1),stsymb(jp:),ceq) + if(gx%bmperr.ne.0) goto 1000 + jp=len_trim(stsymb)+1 + stsymb(jp:jp)=')' + jp=jp+1 +! >>>> unfinished + endif noind +! +800 continue + text(ip:ip+jp-1)=stsymb + ip=ip+jp + if(text(ip:ip).eq.' ') then +! remove a trailing space occuring in some cases + ip=ip-1 + endif +1000 continue + return + end subroutine encode_state_variable_record + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine state_variable_val(svr,value,ceq) +! calculate the value of a state variable in equilibrium record ceq +! It transforms svr data to old format and calls state_variable_val3 + type(gtp_state_variable), pointer :: svr + double precision value + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} %+ + integer istv, indices(4),iref,iunit +! + iref=svr%phref + iunit=svr%unit +! if(svr%oldstv.gt.10) then +! istv=10*(svr%oldstv-5)+svr%norm +! else + istv=svr%oldstv +! endif +! svr%argtyp specifies values in indices: +! svr%argtyp: 0=no arguments; 1=comp; 2=ph+cs; 3=ph+cs+comp; 4=ph+cs+const + indices=0 + if(svr%argtyp.eq.1) then + indices(1)=svr%component + elseif(svr%argtyp.eq.2) then + indices(1)=svr%phase + indices(2)=svr%compset + elseif(svr%argtyp.eq.3) then + indices(1)=svr%phase + indices(2)=svr%compset + indices(3)=svr%component + elseif(svr%argtyp.eq.4) then + indices(1)=svr%phase + indices(2)=svr%compset + indices(3)=svr%constituent + elseif(svr%argtyp.ne.0) then + write(*,*)'3F state variable has illegal argtyp: ',svr%argtyp + gx%bmperr=7775; goto 1000 + endif +! write(*,910)'3F svv: ',istv,indices,iref,iunit,value +910 format(a,i3,2x,4i3,2i3,1pe14.6) + call state_variable_val3(istv,indices,iref,iunit,value,ceq) + if(gx%bmperr.ne.0) then + write(*,920)'3F error: ',gx%bmperr,istv,svr%oldstv,svr%argtyp +920 format(a,i5,2x,2i4,i2) +! else +! write(*,*)'3F value: ',value + endif +1000 continue + return + end subroutine state_variable_val + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine state_variable_val3(istv,indices,iref,iunit,value,ceq) +! calculate the value of a state variable in equilibrium record ceq +! istv is state variable type (integer) +! indices are possible specifiers +! iref indicates use of possible reference state, 0 current, -1 SER +! iunit is unit, (K, oC, J, cal etc). For % it is 100 +! value is the calculated values. for state variables with wildcards use +! get_many_svar + implicit none + integer, dimension(4) :: indices + TYPE(gtp_equilibrium_data), pointer :: ceq + integer istv,iref,iunit + double precision value +!\end{verbatim} + double precision props(5),xmol(maxel),wmass(maxel),stoi(10),cmpstoi(10) + double precision vt,vp,amult,vg,vs,vv,div,aref,vn,bmult,tmass,tmol + double precision qsp,gref,spmass,rmult,tsave,rtn + integer kstv,norm,lokph,lokcs,icx,jp,ncmp,ic,iprop,loksp,nspel + integer endmember(maxsubl),ielno(maxspel) + value=zero + ceq%rtn=globaldata%rgas*ceq%tpval(1) +! write(*,10)'3F svval: ',istv,indices,iref,iunit,gx%bmperr,value +10 format(a,i4,4i4,3i5,1PE17.6) + potentials: if(istv.lt.0) then +! negative istv indicate parameter property symbols + kstv=-istv + goto 200 +! gx%bmperr=4097; goto 1000 + elseif(istv.ge.10) then + goto 50 + elseif(istv.eq.1) then +! this is T + value=ceq%tpval(1) + elseif(istv.eq.2) then +! this is P + value=ceq%tpval(2) + else + if(istv.eq.3) then +! MUx(component) or MU(phase,constituent), x can be S for SER + goto 500 + elseif(istv.eq.4) then +! ACx(component) or AC(phase,constituent) + goto 500 + elseif(istv.eq.5) then +! LNACx(component) or LNAC(phase,constituent) + goto 500 + endif +! wrong or state variable not implemented + write(*,10)'3F not impl: ',istv,indices,iref,iunit,gx%bmperr,value + goto 1100 + endif potentials +! normal return + goto 1000 +!---------------------------------------------------------- +! extensive variable (N, X, G ...) or model variable (TC, BMAG) +50 continue + norm=mod(istv,10) + kstv=istv/10 +! this may not be necessary in all cases but do it anyway: +! sum over all stable phases, props(1..3) are G, G.T and G.P, +! props(4) is amount of moles of components, props(5) is mass of components + call sumprops(props,ceq) + if(gx%bmperr.ne.0) goto 1000 +! if verbose on + if(ocv()) write(*,51)'3F stv A: ',props +51 format(a,5(1PE12.3)) +! kstv can be 1 to 15 for different properties +! norm can be 1, 2, 3 or 4 for normalizing. 0 for not normallizing +! M W V F +! OLD: iref can be 0 or 1 for reference state +! iref can be 0 for using current referennce state +! iref <0 for default reference state (SER) + le10: if(kstv.le.10) then +! kstv= 1 2 3 4 5 6 7 8 9 10 +! state var; U, S, V, H, A, G, NP, BP, DG and Q + vt=ceq%tpval(1) + vp=ceq%tpval(2) +! ceq%rtn=globaldata%rgas*ceq%tpval(1) + amult=ceq%rtn +! write(*,*)'3F stv B: ',vt,vp,amult + if(indices(1).eq.0) then + vg=props(1) + vs=-props(2) + vv=props(3) +! normalizing + if(norm.eq.1) then + div=props(4) + elseif(norm.eq.2) then + div=props(5) + elseif(norm.eq.3) then + div=props(3) + if(div.eq.zero) then + gx%bmperr=4114; goto 1000 + endif + elseif(norm.eq.4) then + gx%bmperr=4115; goto 1000 + else + div=one + endif +! for phase specific the aref should be independent of amult and div ?? +! for system wide these are unity + rmult=one + else +! phase specific, indices are phase and composition set + call get_phase_compset(indices(1),indices(2),lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 + vg=ceq%phase_varres(lokcs)%gval(1,1) + vs=-ceq%phase_varres(lokcs)%gval(2,1) + vv=ceq%phase_varres(lokcs)%gval(3,1) + if(norm.eq.1) then + div=ceq%phase_varres(lokcs)%abnorm(1) + rmult=div + elseif(norm.eq.2) then +! abnorm(2) should be the mass per formulat unit + div=ceq%phase_varres(lokcs)%abnorm(2) + rmult=div + elseif(norm.eq.3) then + div=ceq%phase_varres(lokcs)%gval(3,1) + if(div.eq.zero) then + gx%bmperr=4114; goto 1000 + endif + rmult=div + elseif(norm.eq.4) then +! per formula unit + div=one + rmult=div + else +! no normalizing for a specific phase, value for current amount +! NOTE amult is alreadt RT + amult=amult*ceq%phase_varres(lokcs)%amfu + rmult=ceq%phase_varres(lokcs)%amfu + div=one +! div=ceq%phase_varres(lokcs)%abnorm(1) + endif +! for phase specific the aref is for one mole of atoms and should +! be independent of amult and div ?? +! if(amult.eq.zero) then +! rmult=zero +! else +! rmult=div/amult +! endif + endif +! here the reference state should be considered +! aref=zero + if(iref.eq.0) then +! iref=0 means user defined reference state >>>> unfinished +! write(*,52)'3F Ref state:',iref,kstv,indices(1),indices(2),rmult +52 format(a,4i4,1pe12.4) + call calculate_reference_state(kstv,indices(1),indices(2),aref,ceq) + if(gx%bmperr.ne.0) goto 1000 +! write(*,53)'3F Reference state:',iref,aref,rmult + elseif(iref.lt.0) then + aref=zero + else +! positive value of iref is undefined + write(*,*)'3F Reference state undefined',iref + aref=zero + endif +! if phase specific the scaling for phase specific must be compensated + aref=rmult*aref +! write(*,53)'3F at kstv1: ',kstv,props,aref,div +53 format(a,i3,5(1PE12.3)) + kstv1: if(kstv.eq.1) then +! 1: U = G + TS - PV = G - T*G.T - P*G.P + value=amult*(vg+vt*vs-vp*vv-aref)/div + elseif(kstv.eq.2) then +! 2: S = -G.T + value=amult*(vs-aref)/div +! write(*,54)value,amult,vs,aref,div +54 format('3F svv: ',5(1pe12.4)) + elseif(kstv.eq.3) then +! 3: V = G.P + value=amult*(vv-aref)/div + elseif(kstv.eq.4) then +! 4: H = G + TS = G - T*G.T + if(ocv()) write(*,177)'3F H:',vg+vt*vs,aref,amult,div,rmult +177 format(a,6(1pe12.4)) + value=amult*(vg+vt*vs-aref)/div + elseif(kstv.eq.5) then +! 5: A = G - PV = G - P*G.P + value=amult*(vg-vp*vv-aref)/div + elseif(kstv.eq.6) then +! 6: G +! write(*,177)'3F G:',vg,aref,amult,div + value=amult*(vg-aref)/div + elseif(kstv.eq.7) then +! 7: NP + value=ceq%phase_varres(lokcs)%abnorm(1)* & + ceq%phase_varres(lokcs)%amfu/div + elseif(kstv.eq.8) then +! 8: BP +! abnorm(2) should be the mass per formula unit + value=ceq%phase_varres(lokcs)%abnorm(2)* & + ceq%phase_varres(lokcs)%amfu/div + elseif(kstv.eq.9) then +! 9: DG (driving force) +! write(*,202)'3F svval DG:',lokcs,ceq%phase_varres(lokcs)%dgm,div +202 format(a,i5,2(1pe12.4)) + value=ceq%phase_varres(lokcs)%dgm/div + elseif(kstv.eq.10) then +! 10: Q (stability, thermodynamic factor), not implemented + gx%bmperr=4081; goto 1000 +! else +! write(*,*)'3F svval after 10:',kstv + endif kstv1 + goto 1000 + endif le10 +!---------------------------------------------------------------------- +! here with kstv>10 +! kstv= 11 12 13 +! state var: N B Y + le12: if(kstv.le.12) then +! normallizing for N (kstv=11) and B (kstv=12) +! write(*,88)'3F svv 12: ',indices(1),norm,props(4),props(5) +88 format(a,2i3,6(1pe12.4)) + if(indices(1).eq.0) then +! no first index means the sum over all phases +! props(4) is amount of moles of components, props(5) is mass of components + if(kstv.eq.11) then + vn=props(4) + else + vn=props(5) + endif +! normalizing + if(norm.eq.1) then + div=props(4) + elseif(norm.eq.2) then + div=props(5) + elseif(norm.eq.3) then +! we may not have any volume data ... + div=props(3) + if(div.eq.zero) then + gx%bmperr=4114; goto 1000 + endif + elseif(norm.eq.4) then + gx%bmperr=4115; goto 1000 + else + div=one + endif +! This is N or B without index but possibly normallized +! write(*,89)'3F svv, N or B: ',vn,div +89 format(a,5(1pe12.4)) + value=vn/div + else +! one or two indices, overall of phase specific component amount + if(indices(2).eq.0) then +! one index is component specific, N(comp.), B(CR) etc. Sum over all phases +! props(4) is amount of moles of components, props(5) is mass of components + call calc_molmass(xmol,wmass,tmol,tmass,ceq) + if(gx%bmperr.ne.0) goto 1000 +! write(*,89)'3F mm: ',tmol,tmass +! write(*,93)'3F x: ',(xmol(icx),icx=1,noofel) +! write(*,93)'3F w: ',(wmass(icx),icx=1,noofel) +93 format(a,9F7.4) + icx=1 + if(kstv.eq.11) then + bmult=props(4) + else + bmult=props(5) + endif + else +! two indices is phase and component specific. bmult is amount of phase + call calc_phase_molmass(indices(1),indices(2),& + xmol,wmass,tmol,tmass,bmult,ceq) + icx=3 + endif + if(gx%bmperr.ne.0) goto 1000 +! write(*,13)'3F gsvv 19: ',norm,(xmol(iq),iq=1,noofel) +777 format('gsvv 77: ',10(f7.4)) + if(kstv.eq.11) then +! total moles of component + vn=xmol(indices(icx)) + amult=tmol +! write(*,777)kstv,icx,indices(icx),norm,vn,amult,bmult +!777 format('3F N(i): ',4i4,3(1pe12.4)) + else +! total mass of component + vn=wmass(indices(icx)) + amult=tmass + endif +! write(*,13)'3F gsvv 8: ',norm,vn,amult,bmult,tmol,tmass +13 format(a,i3,7(1PE10.2)) + norm3: if(norm.eq.1) then +! NM or X + if(tmol.ne.zero) then + value=amult*vn/tmol + else +! problem at x(phase,component) was zero when phase fix with zero amount +! value=zero + value=vn + endif +! percent % +! write(*,*)'3F x%: ',iunit,value + if(iunit.eq.100) value=1.0D2*value + elseif(norm.eq.2) then +! NW or W + if(tmass.gt.zero) then + value=amult*vn/tmass + else + value=zero + endif +! percent % + if(iunit.eq.100) value=1.0D2*value + elseif(norm.eq.3) then +! NV + if(props(3).gt.zero) then + value=amult*vn/props(3) + else + gx%bmperr=4114 + endif + elseif(norm.eq.4) then +! NF or BF with one or two indices + if(indices(2).eq.0) then + gx%bmperr=4115; goto 1000 + else + value=vn + endif + else +! N(comp), N(phase,comp), B(comp) or B(phase,comp) + value=bmult*vn + endif norm3 + endif + goto 1000 + endif le12 +!----------------------------------------------------------------- +! special for Y + if(kstv.eq.13) then +! 13: Y + call get_phase_compset(indices(1),indices(2),lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 + value=ceq%phase_varres(lokcs)%yfr(indices(3)) + else +! wrong state variable specification + value=zero + gx%bmperr=4113 + endif + goto 1000 +!----------------------------------------------------------------- +! values of parameter property symbols +! >>> this can easily be generallized ... next time around ... +! here with state variable <0, syetm and user defined properties +200 continue + select case(kstv) + case default + write(kou,*)'Unknown parameter identifier: ',kstv +!....................................... + case(2:5,7,9:19) +! 2: TC (Curie/Neel Temperature) +! 3: BM (Average Bohr magneton number) +! 4: CTA just Curie Temperature +! 5: NTA just Neel temperature +! 7: THET Debye or Einstein temperature +! 9: RHO electrical resistivity +! 10: MAGS Magnetic suseptibility +! 11: GTT Glas transition temperature +! 12: VISC viscosity +! 13: LPX Lattice parameter in X direction +! 14: LPY Lattice parameter in Y direction +! 15: LPZ Lattice parameter in Z direction +! 16: LPTH Lattice angle +! 17: EC11 Elastic constant C11 +! 18: EC12 Elastic constant C12 +! 19: EC44 Elastic constant C44 + call get_phase_compset(indices(1),indices(2),lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 +! nprop is number of properties calculated. Property 1 is always G + find1: do jp=2,ceq%phase_varres(lokcs)%nprop +! the listprop array contain identification of the property stored there + if(ceq%phase_varres(lokcs)%listprop(jp).eq.kstv) then + value=ceq%phase_varres(lokcs)%gval(1,jp) + goto 1000 + endif + enddo find1 +!....................................... + case(6,8) +! 6: IBM& Individual Bohr magneton number +! 8: MQ& mobility value + call get_phase_compset(indices(1),indices(2),lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 +! property is kstv*100+indices(3) (constituent identifier) + iprop=100*kstv+indices(3) + find2: do jp=2,ceq%phase_varres(lokcs)%nprop + if(ceq%phase_varres(lokcs)%listprop(jp).eq.iprop) then + value=ceq%phase_varres(lokcs)%gval(1,jp) + goto 1000 + endif + enddo find2 + end select +!....................................... + gx%bmperr=4113; goto 1000 +!----------------------------------------------------------------- +! chemical potentials, activites etc, istv is 3, 4 or 5 for MU, AC and LNAC +! there can be a reference state +500 continue +! ceq%rtn=globaldata%rgas*ceq%tpval(1) +! if one argument that is a component, if two these are phase and constituent +! write(*,502)'3F refstate 500: ',iref,indices(1),indices(2) +502 format(a,10i4) + if(indices(2).ne.0) then + lokph=phases(indices(1)) + loksp=phlista(lokph)%constitlist(indices(2)) +! split the species in elements, convert to components, add chemical potentials + call get_species_data(loksp,nspel,ielno,stoi,spmass,qsp) + if(gx%bmperr.ne.0) goto 1000 + if(qsp.ne.zero) then +! write(*,*)'3F Cannot calculate potential of charged species' + gx%bmperr=4159; goto 1000 + endif +! other components than elements not implemented +! write(*,*)'3F converting to component',nspel,ielno(1),stoi(1) + call elements2components(nspel,stoi,ncmp,cmpstoi,ceq) + if(gx%bmperr.ne.0) goto 1000 +! write(*,*)'3F converting to component',ncmp,cmpstoi(1) + value=zero + do ic=1,ncmp + value=value+cmpstoi(ic)*ceq%complist(ic)%chempot(1) + enddo +! >>>> subtract reference state: i.e. calculate G for the phase with +! just this constituent. Note indices(1) is phase record, change to index +! write(*,*)'3F refphase: ',indices(1),phlista(indices(1))%alphaindex + ic=phlista(indices(1))%alphaindex + endmember(1)=indices(2) + call calcg_endmember(indices(1),endmember,gref,ceq) + if(gx%bmperr.ne.0) goto 1000 + value=value-gref*ceq%rtn + write(*,511)'3F refstate: ',endmember(1),indices(1),gref,value +511 format(a,2i3,6(1pe14.6)) +! possibly convert to AC or LNAC + goto 700 + else +! MU(i) should be in position i, not indexed by splink ?? +! loop through components, different components in each equilibrium +! do ic=1,noofel +! write(*,*)'3F state var value: ',indices(1),ceq%complist(ic)%splink,& +! ceq%complist(ic)%chempot(1) +! if(indices(1).eq.ceq%complist(ic)%splink) then + if(indices(1).le.0 .or. indices(1).gt.noofel) then +! write(*,*)'3F Asking for nonexisting chemical potential' + gx%bmperr=4171; goto 1000 + endif +! iref=0 is default meaning SER, if iref<0 user user defined reference state +! If a component has a defined reference state that is in complist(indices(1)) +! write(*,*)'3F Reference state: ',iref,ceq%complist(indices(1))%phlink +! write(*,*)'3F Reference state: ',iref + if(iref.eq.0 .and. ceq%complist(indices(1))%phlink.ne.0) then +! write(*,*)'3F Reference state: ',indices(1),indices(2),& +! ceq%complist(indices(1))%phlink +! phlink is phase, endmember is enmember, tpref<0 means current T +! we should also have a stoichiometry factor ?? + endmember(1)=indices(2) + tsave=ceq%tpval(1) + if(ceq%complist(indices(1))%tpref(1).gt.zero) then +! reference state is at a fixed T, negative tpref(1) means current T + ceq%tpval(1)=ceq%complist(indices(1))%tpref(1) + endif +! write(*,*)'3F calling calcg_endmember: ',& +! ceq%complist(indices(1))%phlink,& +! ceq%complist(indices(1))%endmember + ic=ceq%complist(indices(1))%phlink +! write(*,*)'3F refphase: ',indices(1),ic,phlista(indices(1))%alphaindex +! ic=phlista(indices(1))%alphaindex + ic=phlista(ic)%alphaindex +! the first index should be phase index, not location + call calcg_endmember(ic,ceq%complist(indices(1))%endmember,gref,ceq) + if(gx%bmperr.ne.0) then + write(*,*)'3F Error calculating refstate for chemical pot' + goto 1000 + endif +! RT for current T + rtn=globaldata%rgas*ceq%tpval(1) + ceq%tpval(1)=tsave + aref=ceq%complist(indices(1))%chempot(1) + value=ceq%complist(indices(1))%chempot(1)-gref*rtn +! write(*,513)'3F gref: ',indices(1),value,aref,gref*rtn,rtn +513 format(a,i3,5(1pe14.6)) + else +! this value should always be referenced to SER +! the value in chempot(2) is probably redundant now + value=ceq%complist(indices(1))%chempot(1) + endif +! write(*,*)'3F chempot: ',indices(1),& +! ceq%complist(indices(1))%chempot(1),& +! ceq%complist(indices(1))%chempot(2) + goto 700 + endif +! convert from MU to AC or LNAC if necessary +700 continue +! ceq%rtn=globaldata%rgas*ceq%tpval(1) + if(istv.eq.4) then +! AC = exp(mu/RT) + value=exp(value/ceq%rtn) + elseif(istv.eq.5) then +! LNAC = mu/RT + value=value/ceq%rtn + endif +!----------------------------------------------------------------- +1000 continue + return +1100 continue + gx%bmperr=4078 +! write(*,*)'3F State variable value not implemented yet' + goto 1000 + end subroutine state_variable_val3 + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!-\begin{verbatim} + subroutine state_var_value_derivative_old(svr1,svr2,value,ceq) +! THIS SUBROUTINE MOVED TO MINIMIZER +! subroutine state_var_value_derivative(istv,indices,iref,iunit,& +! istv2,indices2,iref2,iunit2,value,ceq) +! calculates a state variable value derivative NOT IMPLEMENTED YET +! istv and istv2 are state variable type (integer) +! indices and indices2 are possible specifiers +! iref and iref2 are possible reference state +! iunit and iunit2 are units, (K, oC, J, cal etc) +! value is calculated value +! ceq is current equilibrium + implicit none + TYPE(gtp_state_variable), pointer :: svr1,svr2 + TYPE(gtp_equilibrium_data) :: ceq +! integer :: istv,iref,iunit,istv2,iref2,iunit2 +! integer, dimension(4) :: indices,indices2 + double precision value +!-\end{verbatim} +! + value=zero + write(*,17)svr1%statevarid,svr1%argtyp,svr2%statevarid,svr2%argtyp +17 format('3F: state_var_value_derivative: ',10i4) +! this must be calculated in the minimizer +! call meq_state_var_value_derivative(svr1,svr2,value,ceq) + gx%bmperr=4078 +1000 continue + return + end subroutine state_var_value_derivative_old + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine calculate_reference_state(kstv,iph,ics,aref,ceq) +! Calculate the user defined reference state for extensive properties +! kstv is the typde of property: 1 U, 2 S, 3 V, 4 H, 5 A, 6 G +! It can be phase specific (iph.ne.0) or global (iph=0) + implicit none + integer kstv,iph,ics + double precision aref + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} +! kstv=1 2 3 4 5 6 other values cared for elsewhere +! U S V H A G + integer iel,phref + double precision gref(6),bref(6),xmol(maxel),wmass(maxel),xxx(6) + double precision tmol,tmass,bmult +! +! write(*,*)'Reference states not implemented yet'; goto 1000 +! write(*,*)'3F reference state:',kstv,iph,ics + if(kstv.lt.1 .or. kstv.gt.6) then +! write(*,*)'3F No reference state for kstv: ',kstv + goto 1000 + endif + aref=zero + bref=zero + gref=zero + xxx=zero +! loop for all components to extract the value of their reference states +! Multiply that with the overall composition (iph=0) or the phase composition + xmol=zero + do iel=1,noofel +! this is the reference phase for component iel + phref=ceq%complist(iel)%phlink + if(phref.gt.0) then +! we should use the phase index, not location in call below +! write(*,*)'3F ref.ph: ',phref,phlista(phref)%alphaindex + phref=phlista(phref)%alphaindex +! special endmember call that returns G, G.T, G.P, G.T.T, G.T.P and G.P.P +! write(*,73)'3F R state: ',iel,phref,ceq%complist(iel)%endmember +73 format(a,2i3,2x,10i4) + call calcg_endmember6(phref,ceq%complist(iel)%endmember,gref,ceq) + if(gx%bmperr.ne.0) then + write(*,*)'3F Error return: ',gx%bmperr + goto 1000 + endif + if(iph.gt.0) then +! multiply with mole fractions of phase iph,ics + call calc_phase_molmass(iph,ics,xmol,wmass,tmol,tmass,bmult,ceq) + else +! multiply with overall mole fractions + call calc_molmass(xmol,wmass,tmol,tmass,ceq) + endif +! note xxx, bref and gref are arrays + xxx=bref+xmol(iel)*gref +! write(*,70)'3F rs: ',bref,gref,xxx,(xmol(ij),ij=1,noofel) +70 format(a,6(1pe12.4)/,2(7x,6e12.4/),8(0pF8.4)) + bref=xxx + else +! this is not really needed, it is bref that is used below + gref=zero + endif + enddo +! calculate the correct correction depending on kstv + if(kstv.eq.1) then +! U = G - T*G.T - P*G.P + aref=bref(1)-ceq%tpval(1)*bref(2)-ceq%tpval(2)*bref(3) + elseif(kstv.eq.2) then +! S = - G.T + aref=-bref(2) + + elseif(kstv.eq.3) then +! V + aref=bref(3) + + elseif(kstv.eq.4) then +! H = G - T*G.T + aref=bref(1)-ceq%tpval(1)*bref(2) + + elseif(kstv.eq.5) then +! A = G - P*G.P + aref=bref(1)-ceq%tpval(2)*bref(3) + + elseif(kstv.eq.6) then +! G + aref=bref(1) + endif +! write(*,75)kstv,aref +75 format('3F ref:',i3,6(1pe12.4)) +1000 continue + return + end subroutine calculate_reference_state + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + + subroutine sortinphtup(n,m,xx) +! subroutine to sort the values in xx which are in phase and compset order +! in phase tuple order. This is needed by the TQ interface +! The number of values belonging to the phase is m (for example composition) + integer n,m + double precision xx(n*m) +! + integer iz,jz,kz,lz,lokph,aha + double precision, dimension(:), allocatable :: dum +! I assume the values are NP(*), maybe there are other cases ... + allocate(dum(n*m)) + kz=0 + do iz=1,noofph + lokph=phases(iz) + do jz=1,noofcs(lokph) +! in xx the values are sequentially for all composition sets for this phase +! But they should be stored in tuple order and compset 2 etc comes at the end +! the index to the tuple is in %phtups +! phlista(lokph)%linktocs(jz) is index of phase_varres record for compset +! firsteq%phase_varres(..)%phtupx is index of phase tuple for compset +! There can be m values (for example compositions) for each phase + aha=(firsteq%phase_varres(phlista(lokph)%linktocs(jz))%phtupx-1)*m + do lz=1,m + dum(aha+lz)=xx(kz+lz) + enddo + kz=kz+m + enddo + enddo + xx=dum + deallocate(dum) +1000 continue + return + end subroutine sortinphtup + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine enter_svfun(cline,last,ceq) +! enter a state variable function + implicit none + integer last + character cline*(*) + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} %+ + integer, parameter :: npfs=20 + integer ks,maxsym,ipos,jt,js,kdot,nsymb + character name2*16,pfsym(npfs)*60,string*128,pfsymdenom*60 +! integer istv(npfs),indstv(4,npfs),iref(npfs),iunit(npfs),lokv(npfs) + integer iarr(10,npfs),lokv(npfs) + type(gtp_state_variable), pointer :: svr + type(putfun_node), pointer :: lrot +! +! maxsym is negative to allow the user to enter abs(maxs) symbols +! pfsym are the entered symbols +! lokv is only internal strage in putfun +! lrot is the root node of expression +! nsymb is the number of user entered symbols +! write(kou,17)'enter svgun ',last,cline(1:20),nsvfun +17 format(a,i3,2x,a,i3) + call gparc('Symbol name: ',cline,last,ichar('='),name2,' ',q1help) + call capson(name2) +! write(*,*)'3F enter_svfun: ',last,name2,':',cline(1:10) + if(.not.proper_symbol_name(name2,0)) goto 1000 + do ks=1,nsvfun + if(name2.eq.svflista(ks)%name) then + gx%bmperr=4136; goto 1000 + endif + enddo +! TO BE IMPLEMENTED: enter symbols with dummy arguments like CP(@P1)=HM(@P1).T +! where @Pi is a phase, @Ci is a component and @Si is a species +! these dummy variables must be defined in symbol name ?? why ?? maybe not + call gparc('Expression, end with ";" :',cline,last,6,string,';',q1help) + maxsym=-npfs + ipos=1 + call putfun(string,ipos,maxsym,pfsym,lokv,lrot,nsymb) + if(pfnerr.ne.0) then + pfnerr=0; gx%bmperr=4134; goto 1000 + endif +! on return nsymb is the number of external symbols used in the function +! these can be other functions or state variables or used defined identifiers +! like Curie temperature etc. The symbols are in pfsym(1..nsymb) +! +! write(*,11)nsymb,(pfsym(js)(1:len_trim(pfsym(js))),js=1,nsymb) +11 format('3F: args ',i2,': ',10(1x,a,',')) +! identify symbols as state variables, if derivative there is a dot + iarr=0 + jt=0 + do js=1,nsymb + kdot=index(pfsym(js),'.') + if(kdot.gt.0) then +! derivatives must be stored as two state variables +! write(*,*)'3F Found dot derivative: ',kdot,pfsym(js) +! Only allow a single symbol in this case!!! + if(nsymb.gt.1) then + write(*,*)'3F Only a single symbol allowed!' + gx%bmperr=7777; goto 1000 + endif + jt=1 +! denominator, variable after . for with the derivative is taken + pfsymdenom=pfsym(js)(kdot+1:) + pfsym(js)(kdot:)=' ' + call decode_state_variable(pfsym(js),svr,ceq) + if(gx%bmperr.ne.0) goto 1000 +! store in the old way in iarr for two state variables + iarr(1,js)=svr%oldstv + iarr(2,js)=svr%norm + iarr(3,js)=svr%unit + iarr(4,js)=svr%phref + iarr(5,js)=svr%argtyp + iarr(6,js)=svr%phase + iarr(7,js)=svr%compset + iarr(8,js)=svr%component + iarr(9,js)=svr%constituent + iarr(10,js)=jt + call decode_state_variable(pfsymdenom,svr,ceq) + if(gx%bmperr.ne.0) goto 1000 +! store in the old way in iarr for two state variables + iarr(1,js+1)=svr%oldstv + iarr(2,js+1)=svr%norm + iarr(3,js+1)=svr%unit + iarr(4,js+1)=svr%phref + iarr(5,js+1)=svr%argtyp + iarr(6,js+1)=svr%phase + iarr(7,js+1)=svr%compset + iarr(8,js+1)=svr%component + iarr(9,js+1)=svr%constituent + else + call decode_state_variable(pfsym(js),svr,ceq) + if(gx%bmperr.ne.0) then +! symbol not a state variable, may be another function +! write(*,*)'3F not state variable: ',gx%bmperr,' "',& +! pfsym(js)(1:len_trim(pfsym(js))),'"' + gx%bmperr=0 + do ks=1,nsvfun + if(pfsym(js).eq.svflista(ks)%name) then +! write(*,*)'3F found other function: ',& +! pfsym(js)(1:len_trim(pfsym(js))) + iarr(1,js)=-ks + goto 390 + endif + enddo + write(*,*)'3F not a function: "',& + pfsym(js)(1:len_trim(pfsym(js))),'"' + gx%bmperr=4135; goto 1000 + else +! write(*,*)'3F decoded 1: ',pfsym(js) +! write(*,*)'3F decoded 2: ',svr%statev +! Store in the old way in iarr + iarr(1,js)=svr%oldstv + iarr(2,js)=svr%norm + iarr(3,js)=svr%unit + iarr(4,js)=svr%phref + iarr(5,js)=svr%argtyp + iarr(6,js)=svr%phase + iarr(7,js)=svr%compset + iarr(8,js)=svr%component + iarr(9,js)=svr%constituent + endif + endif +390 continue + enddo +! for derivatives two iarr arrays +! Found bug in store_putfun if just a variable entered, coefficient set to 0.0 + call store_putfun(name2,lrot,nsymb+jt,iarr) +1000 continue + return + end subroutine enter_svfun + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ +!\begin{verbatim} %- + subroutine store_putfun(name,lrot,nsymb,iarr) +! enter an expression of state variables with name name with address lrot +! nsymb is number of formal arguments +! iarr identifies these +! idot if derivative + implicit none + character name*(*) + type(putfun_node), pointer :: lrot + integer nsymb,idot + integer iarr(10,*) +!\end{verbatim} %+ + integer jf,jg +! write(*,*)'3F: store_putfun ',nsvfun + nsvfun=nsvfun+1 + if(nsymb.gt.0) then + allocate(svflista(nsvfun)%formal_arguments(10,nsymb)) + idot=10 +! dot derivatives have two consequtive symbols for the variable before/after + do jf=1,nsymb +! the order is: 1: state variable (negative means index to another symbol) +! 2-5: norm, unit, phref, argtyp, +! 6-10: phase, compset, component, constituent, derivative + do jg=1,idot + svflista(nsvfun)%formal_arguments(jg,jf)=iarr(jg,jf) + enddo +! write(*,77)(iarr(jg,jf),jg=1,idot) +77 format('3F: store_putfun: ',20i3) + enddo + endif + svflista(nsvfun)%name=name + svflista(nsvfun)%linkpnode=>lrot + svflista(nsvfun)%status=0 + svflista(nsvfun)%narg=nsymb +! this is the number of actual argument needed (like @P, @C and @S) + svflista(nsvfun)%nactarg=0 +! eqnoval indicate which equilibrium to use to get its value. +! default is 0 meaning current equilibria, can be changed by AMEND SYMBOL + svflista(nsvfun)%eqnoval=0 +1000 continue + return + end subroutine store_putfun + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine store_putfun_old(name,lrot,nsymb,& + istv,indstv,iref,iunit,idot) +! enter an expression of state variables +! name: character, name of state variable function +! lrot: pointer, to a putfun_node that is the root of the stored expression +! nsymb: integer, number of formal arguments +! istv: integer array, formal argument state variables typ +! indstv: 2D integer array, indices for the formal state variables +! iref: integer array, reference for the formal state variables +! iunit: integer array, unit of the formal state variables + implicit none + type(putfun_node), pointer :: lrot + integer nsymb + integer, dimension(*) :: istv,iref,iunit,idot + integer, dimension(4,*) :: indstv + character name*(*) +!\end{verbatim} + integer jf +! write(*,*)'3F store_putfun ',nsvfun + nsvfun=nsvfun+1 + if(nsymb.gt.0) then + allocate(svflista(nsvfun)%formal_arguments(10,nsymb)) + do jf=1,nsymb + svflista(nsvfun)%formal_arguments(1,jf)=istv(jf) + svflista(nsvfun)%formal_arguments(2,jf)=indstv(1,jf) + svflista(nsvfun)%formal_arguments(3,jf)=indstv(2,jf) + svflista(nsvfun)%formal_arguments(4,jf)=indstv(3,jf) + svflista(nsvfun)%formal_arguments(5,jf)=indstv(4,jf) + svflista(nsvfun)%formal_arguments(6,jf)=iref(jf) + svflista(nsvfun)%formal_arguments(7,jf)=iunit(jf) + svflista(nsvfun)%formal_arguments(8,jf)=idot(jf) + enddo + endif + svflista(nsvfun)%name=name + svflista(nsvfun)%linkpnode=>lrot + svflista(nsvfun)%status=0 + svflista(nsvfun)%narg=nsymb +! this is the number of actual argument needed (like @P, @C and @S) + svflista(nsvfun)%nactarg=0 +! eqnoval indicate which equilibrium to use to get its value. +! default is 0 meaning current equilibria, can be changed by AMEND SYMBOL + svflista(nsvfun)%eqnoval=0 +1000 continue + return + end subroutine store_putfun_old + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine find_svfun(name,lrot,ceq) +! finds a state variable function called name (no abbreviations) + implicit none + character name*(*) + integer lrot + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} %+ +! name must be in UPPER CASE and exact match required + do lrot=1,nsvfun + if(name.eq.svflista(lrot)%name) goto 500 + enddo + write(*,*)'3F No such symbol: ',name + gx%bmperr=8888; goto 1000 +! +500 continue +! nothing more to do! +1000 continue + return + end subroutine find_svfun + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} %- + subroutine list_svfun(text,ipos,lrot,ceq) +! list a state variable function + implicit none + character text*(*) + integer ipos,lrot + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} +! copied svflista(lrot)%formal_arguments(2..5,jt) to indices as gfortran error +! integer indstv(4) + type(gtp_state_variable), pointer :: svr + character symbols(20)*32,afterdot*32 + integer js,jt,ip,istv,kl +! write(*,*)'3F list_svfun 1:',svflista(lrot)%narg + if(lrot.le.0 .or. lrot.gt.nsvfun) then + gx%bmperr=4140; goto 1000 + endif + if(svflista(lrot)%narg.eq.0) goto 500 + js=0 + jt=0 +100 continue + jt=jt+1 + js=js+1 + ip=1 + symbols(js)=' ' + istv=svflista(lrot)%formal_arguments(1,jt) + if(istv.lt.0) then +! function refer to another function + symbols(js)=svflista(-istv)%name + else +! the 1:10 was a new bug discovered in GNU fortran 4.7 and later + call make_stvrec(svr,svflista(lrot)%formal_arguments(1:10,jt)) + call encode_state_variable(symbols(js),ip,svr,ceq) + if(svflista(lrot)%formal_arguments(10,jt).ne.0) then +! a derivative!!! +! write(*,111)'3F A dot derivative of ',js,jt,symbols(js) +111 format(a,2i3,': ',a) + jt=jt+1 + afterdot=' ' + ip=1 + call make_stvrec(svr,svflista(lrot)%formal_arguments(1:10,jt)) + call encode_state_variable(afterdot,ip,svr,ceq) +! write(*,111)'3F wrt state variable ',js,jt,afterdot + symbols(js)=symbols(js)(1:len_trim(symbols(js)))//'.'//afterdot +! write(*,111)'3F alltogether ',js,jt,symbols(js) + endif + endif + if(jt.lt.svflista(lrot)%narg) goto 100 +500 continue + kl=len_trim(svflista(lrot)%name) + text(ipos:ipos+kl+1)=svflista(lrot)%name(1:kl)//'= ' + ipos=ipos+kl+2 + call wrtfun(text,ipos,svflista(lrot)%linkpnode,symbols) +! where is pfnerr defined?? + if(pfnerr.ne.0) then + write(kou,*)'Putfun error listing funtion ',pfnerr + gx%bmperr=4142; goto 1000 + endif +! text(ipos:ipos)=';' +! ipos=ipos+1 +1000 continue + return + end subroutine list_svfun + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine make_stvrec(svr,iarr) +! stores appropriate values from a formal argument list to a state variable +! function in a state variable record + implicit none + type(gtp_state_variable), pointer :: svr + integer iarr(10) +!\end{verbatim} + integer jt,norm +! + allocate(svr) + if(iarr(1).lt.10) then +! This is T, P, MU, AC, LNAC +! 1 2 3 4 5 + svr%statevarid=iarr(1) + else +! This is U, S, V, H, A, G, NP, BP, DG, Q, N, X, B, W, Y symbol +! 6 7 8 9 10, 11, 12, 13, 14, 15, 16, 17, 18, 19. 20 new code +! 10 20 30 40 50 60 70 80 90 100 110 111 120 122 130 old code +! dvs iarr()=10 means U etc. + jt=iarr(1)/10+5 + norm=mod(iarr(1),10) +! special for x and w, note norm is set to normallizing + if(jt.eq.16 .and. norm.eq.1) jt=17 + if(jt.eq.18 .and. norm.eq.2) jt=19 + svr%statevarid=jt +! write(*,*)'3F make: ',iarr(1),jt + endif +! write(*,11)iarr +11 format('3F Arguments: ',10i5) +! Not implemented handling of property symbols like TC, BMAGN etc + svr%oldstv=iarr(1) + svr%norm=iarr(2) + svr%unit=iarr(3) + svr%phref=iarr(4) + svr%argtyp=iarr(5) + svr%phase=iarr(6) + svr%compset=iarr(7) + svr%component=iarr(8) + svr%constituent=iarr(9) +1000 continue + return + end subroutine make_stvrec + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine list_all_svfun(kou,ceq) +! list all state variable funtions + implicit none + integer kou + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + character text*256 + integer ks,ipos + write(kou,17) +17 format('List of all state variable symbols'/' No Name = expression ;') + do ks=1,nsvfun + ipos=1 + call list_svfun(text,ipos,ks,ceq) + if(pfnerr.ne.0) then + gx%bmperr=4142; pfnerr=0; goto 1000 + endif + write(kou,76)ks,text(1:ipos-1) +76 format(i3,2x,a) + enddo +1000 continue + return + end subroutine list_all_svfun + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine evaluate_all_svfun_old(kou,ceq) +! THIS SUBROUTINE MOVED TO MINIMIZER but kept for initiallizing +! cannot be used for state variable functions that are derivatives ... +! evaluate and list values of all functions + implicit none + integer kou + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} %+ + character actual_arg(10)*24 + integer kf + double precision val + if(kou.gt.0) write(kou,75) +75 format('No Name ',12x,'Value') + do kf=1,nsvfun +! actual arguments needed if svflista(kf)%nactarg>0 + val=evaluate_svfun_old(kf,actual_arg,0,ceq) + if(gx%bmperr.ne.0) goto 1000 + if(kou.gt.0) write(kou,77)kf,svflista(kf)%name,val +77 format(i3,1x,a,1x,1PE15.8) + enddo +1000 continue + return + end subroutine evaluate_all_svfun_old + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} %- + double precision function evaluate_svfun_old(lrot,actual_arg,mode,ceq) +! THIS SUBROUTINE MOVED TO MINIMIZER +! but needed in some cases in this module ... ??? +! envaluate all funtions as they may depend on each other +! actual_arg are names of phases, components or species as @Pi, @Ci and @Si +! needed in some deferred formal parameters (NOT IMPLEMENTED YET) + implicit none + integer lrot,mode + character actual_arg(*)*(*) + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + double precision argval(20) + type(gtp_state_variable), pointer :: svr,svr2 + integer jv,jt,istv,ieq + double precision value + argval=zero +! write(*,*)'3F evaluate_svfun ',lrot,svflista(lrot)%narg,svflista(lrot)%name +! locate function + if(lrot.le.0 .or. lrot.gt.nsvfun) then + gx%bmperr=4140; goto 1000 + endif + if(svflista(lrot)%narg.eq.0) goto 300 +! get values of arguments + jv=0 + jt=0 +100 continue + jt=jt+1 + istv=svflista(lrot)%formal_arguments(1,jt) + if(istv.lt.0) then +! if eqnoval nonzero it indicates from which equilibrium to get its value + ieq=svflista(lrot)%eqnoval + if(ieq.eq.0) then + value=ceq%svfunres(-istv) + else + value=eqlista(ieq)%svfunres(-istv) + endif +! write(*,*)'3F evaluate_svfun symbol',ieq,value + else +! the 1:10 was a new bug discovered in GNU fortran 4.7 and later + call make_stvrec(svr,svflista(lrot)%formal_arguments(1:10,jt)) + if(gx%bmperr.ne.0) goto 1000 + if(svflista(lrot)%formal_arguments(10,jt).eq.0) then +! get state variable value + call state_variable_val(svr,value,ceq) + else +! state variable derivative, error code here should be handelled by calling +! routine and use meq_evaluate_evaluate +! write(*,*)'3F In evaluate_svfun_old!!!' +! write(*,*)'Use "calculate symbol" for state variable derivatives!' + gx%bmperr=4217 +! call make_stvrec(svr2,svflista(lrot)%formal_arguments(1:10,jt)) +! call state_var_value_derivative(svr,svr2,value,ceq) +! call meq_state_var_value_derivative(svr,svr2,value,ceq) + endif + if(gx%bmperr.ne.0) goto 1000 + endif + jv=jv+1 + argval(jv)=value + if(jt.lt.svflista(lrot)%narg) goto 100 +! all arguments evaluated (or no arguments needed) +300 continue +! write(*,333)'evaluate_svfun ',svflista(lrot)%name,argval(1),argval(2) +!333 format(a,a,2(1PE15.6)) +! write(*,340)'evaluate svfun 1: ',mode,lrot +340 format(a,5i4) + modeval: if(mode.eq.0 .and. btest(svflista(lrot)%status,SVFVAL)) then +! If mode=0 and SVFVAL set return the stored value + value=ceq%svfunres(lrot) +! write(*,350)'evaluate svfun 2: ',0,lrot,value + elseif(mode.eq.0 .and. btest(svflista(lrot)%status,SVFEXT)) then +! if mode=0 and SVFEXT set use value from equilibrium eqno + ieq=svflista(lrot)%eqnoval + if(ceq%eqno.eq.ieq) then + value=evalf(svflista(lrot)%linkpnode,argval) + if(pfnerr.ne.0) then + write(*,*)'evaluate_svfun putfunerror ',pfnerr + gx%bmperr=4141; goto 1000 + endif + ceq%svfunres(lrot)=value +! write(*,350)'evaluate svfun 3: ',ieq,lrot,value + else + value=eqlista(ieq)%svfunres(lrot) + endif +! write(*,350)'evaluate svfun 4: ',ieq,lrot,value +350 format(a,2i3,1pe12.4) + else +! if mode=1 always evaluate + value=evalf(svflista(lrot)%linkpnode,argval) + if(pfnerr.ne.0) then + write(*,*)'evaluate_svfun putfunerror ',pfnerr + gx%bmperr=4141; goto 1000 + endif + endif modeval +! save value in current equilibrium +! write(*,*)'3F eval_svfun: ',lrot,value,size(ceq%svfunres) + ceq%svfunres(lrot)=value + evaluate_svfun_old=value +1000 continue + return + end function evaluate_svfun_old + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ diff --git a/models/pmod25H.F90 b/models/gtp3G.F90 similarity index 89% rename from models/pmod25H.F90 rename to models/gtp3G.F90 index 91ef45d..53949de 100644 --- a/models/pmod25H.F90 +++ b/models/gtp3G.F90 @@ -1,2297 +1,2217 @@ -! -! included in pmod25.F90 -! -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ -!> 13. Status for things -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine change_element_status(elname,nystat,ceq) -! change the status of an element, can affect species and phase status -! nystat:0=entered, 1=suspended, -1 special (exclude from sum of mole fraction) -! -! suspending elements for each equilibrium separately not yet implemented -! - implicit none - character elname*(*) - integer nystat - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer iel,lokel - call find_element_by_name(elname,iel) - if(gx%bmperr.ne.0) goto 1000 - lokel=elements(iel) - if(btest(ellista(iel)%status,elsus)) then -! element already suspended, quit it should be suspended again .... - if(nystat.eq.1) goto 1000 -! element status should be changed from suspended to entered - ellista(iel)%status=ibclr(ellista(iel)%status,elsus) - call restore_species_implicitly_suspended - call restore_phases_implicitly_suspended - elseif(nystat.eq.1) then -! element should be changed from entered to suspended - ellista(iel)%status=ibset(ellista(iel)%status,elsus) - call suspend_species_implicitly(ceq) - call suspend_phases_implicitly(ceq) - endif -1000 continue - return - end subroutine change_element_status - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - logical function testelstat(iel,status) -! return value of element status bit - implicit none - integer iel,status -!\end{verbatim} - integer lokel - if(iel.gt.0 .and. iel.lt.noofel) then - lokel=elements(iel) - if(btest(ellista(lokel)%status,status)) then -! btest(iword,bit) .true. if bit set in iword -! iword=ibclr(iword,bit) to clear bit bit in iword -! iword=ibset(iword,bit) to set bit bit in iword - testelstat=.true. - else - testelstat=.false. - endif - else - gx%bmperr=4042 - endif - end function testelstat - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine change_species_status(spname,nystat,ceq) -! change the status of a species, can affect phase status -! nystat:0=entered, 1=suspended - implicit none - integer nystat - character spname*(*) - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer loksp - call find_species_record(spname,loksp) - if(gx%bmperr.ne.0) goto 1000 - if(btest(splista(loksp)%status,spsus)) then -! species already suspended, quit if it should be suspended again .... - if(nystat.eq.1) goto 1000 -! restore the species (and phases) unless implicitly suspended - if(btest(splista(loksp)%status,spimsus)) then -! species cannot be entered as it is implicitly suspended (some element susp) - gx%bmperr=4085; goto 1000 - endif - splista(loksp)%status=ibclr(splista(loksp)%status,spsus) - call restore_phases_implicitly_suspended - elseif(nystat.eq.1) then -! suspend the species and possibly some phases - splista(loksp)%status=ibset(splista(loksp)%status,spsus) - call suspend_phases_implicitly(ceq) - endif -1000 continue - return - end subroutine change_species_status - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - logical function testspstat(isp,status) -! return value of species status bit - implicit none - integer isp,status -!\end{verbatim} - integer loksp - if(isp.gt.0 .and. isp.lt.noofsp) then - loksp=species(isp) - if(btest(splista(loksp)%status,status)) then -! btest(iword,bit) .true. if bit set in iword -! iword=ibclr(iword,bit) to clear bit bit in iword -! iword=ibset(iword,bit) to set bit bit in iword - testspstat=.true. - else - testspstat=.false. - endif - else - gx%bmperr=4051 - endif - end function testspstat - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - integer function get_phase_status(iph,ics,text,ip,val,ceq) -! return phase status as text and amount formula units in val -! for entered and fix phases also phase amounts. -! OLD Function value: 1=entered, 2=fix, 3=dormant, 4=suspended, 5=hidden - implicit none - character text*(*) - integer iph,ics,ip - TYPE(gtp_equilibrium_data), pointer :: ceq - double precision val -!\end{verbatim} %+ - integer ists,lokph,lokcs,j -! write current status - ists=0 - val=-one - if(iph.gt.0 .and. iph.le.noph()) then - call get_phase_compset(iph,ics,lokph,lokcs) -!old if(btest(phlista(lokph)%status1,phhid)) then -!old text='HIDDEN'; ip=6 -!old ists=5 -!old elseif(btest(ceq%phase_varres(lokcs)%status2,CSSUS)) then -! entered, fix, suspended, dormant -! bit setting: 00 01 , 10 11 -!old if(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then -!old text='DORMANT'; ip=7 -!old ists=3 -!old else -!old text='SUSPENDED'; ip=9 -!old ists=4 -!old endif -!old elseif(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then -!old text='FIXED'; ip=5 -! val=ceq%phase_varres(lokcs)%amount(1) -!old val=ceq%phase_varres(lokcs)%amfu -!old ists=2 -!old else -!old text='ENTERED'; ip=7 -!old val=ceq%phase_varres(lokcs)%amfu -!old ists=1 -!old endif -! new way, test PHSTATE - j=ceq%phase_varres(lokcs)%phstate -!z if(j.lt.-4 .or. j.gt.2) then -! I had an erroor here when plotting map2 macro because after the second -! map command I had 2 liquid compsets and during the first mapping I had -! only one liquid so I think -!z ip=j -!z j=0 -!z if(btest(ceq%phase_varres(lokcs)%status2,CSSUS)) then -!z if(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then -!z j=-2 -!z else ! suspended -!z j=3 -!z endif -!z elseif(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then -! fix -!z j=2 -!z else ! entered -!z j=0 -!z endif -! save this status .... ??? -!z write(*,16)'25H PHSTATE wrong, fixing ...',iph,ics,j,ip,& -!z ceq%phase_varres(lokcs)%status2 -!z ceq%phase_varres(lokcs)%phstate=j -!z endif - select case(j) - case default - write(*,16)'25H: PHSTATE not correct: ',iph,ics,j,ip,& - ceq%phase_varres(lokcs)%status2 -16 format(a,4i3,2x,z16) - gx%bmperr=7777 - case(phfixed) ! fix 2 - text='FIXED' - ip=5 - val=ceq%phase_varres(lokcs)%amfu - ists=phfixed - case(-1,0,1) ! entered (unstable, unknown, stable) - text='ENTERED' - ip=7 - val=ceq%phase_varres(lokcs)%amfu - ists=phentered - case(phdorm) ! dormant -2 - text='DORMANT' - ip=7 - ists=phdorm - case(phsus) ! suspended -3 - text='SUSPENDED' - ip=9 - ists=phsus - case(phhidden) ! hidden -4 - text='HIDDEN' - ip=6 - ists=phhidden - end select - else -! write(*,*)'No such phase' - gx%bmperr=4050; goto 1000 - endif - get_phase_status=ists -! write(*,*)'25H: PHSTAT value: ',ists -! write(*,*)'25H: gps: ',ip -1000 continue - return - end function get_phase_status - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - integer function test_phase_status(iph,ics,val,ceq) -! Almost same as get_..., returns phase status as function value but no text -! old: 1=entered, 2=fix, 3=dormant, 4=suspended, 5=hidden -! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix -! this is different from in change_phase .... one has to make up one's mind - implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq - integer iph,ics - double precision val -!\end{verbatim} - integer ists,lokph,lokcs,j,ip - character text*24 -! new code - call get_phase_compset(iph,ics,lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 - ists=ceq%phase_varres(lokcs)%phstate - val=ceq%phase_varres(lokcs)%amfu - goto 900 -!============================================= - ists=0 - ip=1 - val=-one - ists=get_phase_status(iph,ics,text,ip,val,ceq) - goto 900 -!------------------ - if(iph.gt.0 .and. iph.le.noph()) then - call get_phase_compset(iph,ics,lokph,lokcs) -! biet set means false .... -!z if(btest(phlista(lokph)%status1,phhid)) then -! hidden -!z ists=5 -!z elseif(btest(ceq%phase_varres(lokcs)%status2,CSSUS)) then -! entered, fix, suspended, dormant -! bit setting: 00 01 , 10 11 -!z if(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then -!z ists=3 -!z else -!z ists=4 -!z endif -!z elseif(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then -!z val=ceq%phase_varres(lokcs)%amfu -!z ists=2 -!z else -!z ists=1 -!z val=ceq%phase_varres(lokcs)%amfu -!z endif -! new way, test PHSTATE - j=ceq%phase_varres(lokcs)%phstate - select case(ceq%phase_varres(lokcs)%phstate) - case default - write(*,*)'PHSTAT outside range -4:2: ',j - case(phfixed) ! fix +2 - if(ists.ne.2) write(*,*)'wrong PHSTAT',ists,j - case(-1,0,1) ! entered (unstable, unknown, stable) - if(ists.ne.1) write(*,*)'wrong PHSTAT',ists,j - case(phdorm) ! dormant -2 - if(ists.ne.3) write(*,*)'wrong PHSTAT',ists,j - case(phsus) ! suspended -3 - if(ists.ne.4) write(*,*)'wrong PHSTAT',ists,j - case(phhidden) ! hidden -4 - if(ists.ne.5) write(*,*)'wrong PHSTAT',ists,j - end select - else -! write(*,*)'No such phase' - gx%bmperr=4050; goto 1000 - endif -900 continue - test_phase_status=ists -1000 continue - return - end function test_phase_status - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine set_phase_status_bit(lokph,bit) -! set the status bit "bit" in status1, cannot be done outside this module -! as the phlista is private -! These bits do not depend on the composition set - implicit none - integer lokph,bit -!\end{verbatim} %+ - integer lokcs,j - if(bit.lt.0 .or. bit.gt.31) then - write(*,*)'Illegal phase bit number' - gx%bmperr=7777; goto 1000 - elseif(lokph.le.0 .or. lokph.gt.noofph) then - write(*,*)'Illegal phase in call to set_phase_status_bit' - gx%bmperr=7777; goto 1000 - endif -! write(*,99)'sphs1bit: ',lokph,bit,phlista(lokph)%status1 -99 format(a,2i3,z8) - phlista(lokph)%status1=ibset(phlista(lokph)%status1,bit) - if(bit.eq.PHHID) then -! if bit is PHHID, i.e. hidden, set PHSTATE in all phase_varres record to -4 - do j=1,phlista(lokph)%noofcs - lokcs=phlista(lokph)%linktocs(j) -! eventually, this must be set in all equilibrium records now just firsteq ?? - firsteq%phase_varres(lokcs)%phstate=-4 - enddo - endif -1000 continue - return - end subroutine set_phase_status_bit - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - subroutine clear_phase_status_bit(lokph,bit) -! clear the status bit "bit" in status1, cannot be done outside this module -! as the phlista is private - implicit none - integer lokph,bit -!\end{verbatim} %+ - integer lokcs,j - if(bit.lt.0 .or. bit.gt.31) then - write(*,*)'Illegal phase bit number' - gx%bmperr=7777; goto 1000 - endif - phlista(lokph)%status1=ibclr(phlista(lokph)%status1,bit) - if(bit.eq.PHHID) then - write(*,*)'clear_bit: Not implemented to change PHSTATE' -! if bit is PHHID, i.e. hidden, set PHSTATE in all phase_varres record to 0 - do j=1,phlista(lokph)%noofcs - lokcs=phlista(lokph)%linktocs(j) -! eventually, this must be set in all equilibrium records now just firsteq ?? - firsteq%phase_varres(lokcs)%phstate=phentered - enddo - endif -1000 continue - return - end subroutine clear_phase_status_bit - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} %- - logical function test_phase_status_bit(iph,ibit) -! return TRUE is status bit ibit for phase iph, is set -! because phlista is private. Needed to test for gas, ideal etc, -! DOES NOT TEST STATUS like entered/fixed/dormant/suspended - implicit none - integer iph,ibit -!\end{verbatim} - integer lokph - if(iph.gt.0 .and. iph.le.noofph) then - lokph=phases(iph) - else - gx%bmperr=4050; goto 1000 - endif - if(btest(phlista(lokph)%status1,ibit)) then - test_phase_status_bit=.true. - else - test_phase_status_bit=.false. - endif -1000 continue - return - end function test_phase_status_bit - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine change_phase_status(qph,ics,nystat,val,ceq) -! change the status of a phase. Also used when setting phase fix etc. -! old: 0=entered, 1=suspended, 2=dormant, 3=fix, 4=hidden,5=not hidden -! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix -! qph can be -1 meaning all or a specifix phase index. ics compset -! - implicit none - integer qph,ics,nystat - double precision val - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} %+ - integer lokph,lokcs,iph,ip,mcs - character line*80,phname*32 -! write(*,11)'25H in change_phase_status: ',qph,ics,nystat,val -11 format(a,3i5,1pe14.6) - if(qph.eq.-1) then -! this means all phases. All phases cannot be set fix - if(nystat.eq.3) then - gx%bmperr=4152; goto 1000 - endif - iph=1 - ics=1 - else -! a specific phase - iph=qph - endif -! return here for next phase -100 continue - call get_phase_compset(iph,ics,lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 -! write(*,*)'25H: Phase and status: ',iph,ceq%phase_varres(lokcs)%phstate - if(ceq%phase_varres(lokcs)%phstate.eq.phfixed) then -! this phase and composition set is fix, remove condition -! unless the new status is also FIX - if(nystat.ne.phfixed) then - call get_phase_name(iph,ics,phname) - line=' NOFIX='//phname(1:len_trim(phname)) - ip=1 -! write(*,*)'Remove fix phase: ',line(1:len_trim(line)) - call set_condition(line,ip,ceq) - if(gx%bmperr.ne.0) then -! write(*,*)'Failed to remove fix phase as condition' - goto 1000 - endif - endif - endif - bigif: if(ceq%phase_varres(lokcs)%phstate.eq.phhidden) then -! phase is hidden, quit if it should be hidden again -! bigif: if(btest(phlista(lokph)%status1,phhid)) then - if(nystat.eq.phhidden) goto 900 -! phlista(lokph)%status1=ibclr(phlista(lokph)%status1,phhid) -!??? this phase must be added in phlista ??? no it is already there ??? - write(*,*)'Unifished handling of hide/not hide ...' - gx%bmperr=4095; goto 900 - elseif(nystat.eq.phhidden) then -! phase is not hidden but should be set as hidden, -! Always applies to all composition sets -! clear all entered/suspended/dormant/fix for all composition sets - phlista(lokph)%status1=ibset(phlista(lokph)%status1,phhid) - do mcs=1,phlista(lokph)%noofcs - lokcs=phlista(lokph)%linktocs(mcs) - ceq%phase_varres(lokcs)%phstate=phhidden -! also set amounts and dgm to zero - ceq%phase_varres(lokcs)%amfu=zero - ceq%phase_varres(lokcs)%netcharge=zero - ceq%phase_varres(lokcs)%dgm=zero - enddo - else !bigif - lokcs=phlista(lokph)%linktocs(ics) -! changing FIX/ENTERED/SUSPENDED/DORMANT for a composition set -! input nystat:0=entered, 3=fix, 1=suspended, 2=dormant -! bit setting: 00 01 , 10 11 -! write(*,71)'25H new status: ',iph,ics,lokph,lokcs,nystat,phentered,val -71 format(a,6i5,1pe14.6) - if(nystat.eq.phentered .or. nystat.eq.phentunst .or. & - nystat.eq.phentstab) then -! set enterered with amount val and dgm zero -! write(*,*)'Setting phase as entered',nystat -! ceq%phase_varres(lokcs)%phstate=phentered - ceq%phase_varres(lokcs)%phstate=nystat -! remove use of status bits -!z ceq%phase_varres(lokcs)%status2=& -!z ibclr(ceq%phase_varres(lokcs)%status2,CSSUS) -!z ceq%phase_varres(lokcs)%status2=& -!z ibclr(ceq%phase_varres(lokcs)%status2,CSFIXDORM) -! ceq%phase_varres(lokcs)%amount=val - ceq%phase_varres(lokcs)%amfu=val - ceq%phase_varres(lokcs)%netcharge=zero - ceq%phase_varres(lokcs)%dgm=zero - elseif(nystat.eq.phsus) then -! set suspended with amount and dgm zero - ceq%phase_varres(lokcs)%phstate=phsus -!z ceq%phase_varres(lokcs)%status2=& -!z ibset(ceq%phase_varres(lokcs)%status2,CSSUS) -!z ceq%phase_varres(lokcs)%status2=& -!z ibclr(ceq%phase_varres(lokcs)%status2,CSFIXDORM) -!z ceq%phase_varres(lokcs)%status2=& -!z ibclr(ceq%phase_varres(lokcs)%status2,CSSTABLE) -! ceq%phase_varres(lokcs)%amount=zero - ceq%phase_varres(lokcs)%amfu=zero - ceq%phase_varres(lokcs)%netcharge=zero - ceq%phase_varres(lokcs)%dgm=zero - elseif(nystat.eq.phdorm) then -! set dormant with amount and dgm zero - ceq%phase_varres(lokcs)%phstate=phdorm -!z ceq%phase_varres(lokcs)%status2=& -!z ibset(ceq%phase_varres(lokcs)%status2,CSSUS) -!z ceq%phase_varres(lokcs)%status2=& -!z ibset(ceq%phase_varres(lokcs)%status2,CSFIXDORM) -!z ceq%phase_varres(lokcs)%status2=& -!z ibclr(ceq%phase_varres(lokcs)%status2,CSSTABLE) - ceq%phase_varres(lokcs)%amfu=zero - ceq%phase_varres(lokcs)%netcharge=zero - ceq%phase_varres(lokcs)%dgm=zero - elseif(nystat.eq.phfixed) then -! set fix with amount val -! write(*,*)'Setting phase as fix' - ceq%phase_varres(lokcs)%phstate=phfixed -!z ceq%phase_varres(lokcs)%status2=& -!z ibclr(ceq%phase_varres(lokcs)%status2,CSSUS) -!z ceq%phase_varres(lokcs)%status2=& -!z ibset(ceq%phase_varres(lokcs)%status2,CSFIXDORM) - ceq%phase_varres(lokcs)%amfu=val - ceq%phase_varres(lokcs)%netcharge=zero - ceq%phase_varres(lokcs)%dgm=zero -! also set as condition - call get_phase_name(iph,ics,phname) - line=' FIX='//phname(1:len_trim(phname))//' ==' - ip=len_trim(line)+2 - call wrinum(line,ip,6,0,val) - if(buperr.ne.0) goto 1000 - ip=1 -! write(*,*)'phase fix condition: ',line(1:40) - call set_condition(line,ip,ceq) - endif - endif bigif -900 continue -! check if loop - if(qph.eq.-1) then - lokph=phases(iph) - if(ics.lt.phlista(lokph)%noofcs) then - ics=ics+1 - elseif(iph.lt.noofph) then - iph=iph+1 - ics=1 - else - goto 1000 - endif - goto 100 - endif -1000 continue -! write(*,*)'error code: ',gx%bmperr - return - end subroutine change_phase_status - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} &- - subroutine mark_stable_phase(iph,ics,ceq) -! change the status of a phase. Does not change fix status -! called from meq_sameset to indicate stable phases (nystat=1) -! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix -! - implicit none - integer iph,ics - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer lokph,lokcs -! write(*,11)'25H mark as stable: ',iph,ics,phentstab -11 format(a,3i5,1pe14.6) - call get_phase_compset(iph,ics,lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 -! write(*,*)'25H: Phase and status: ',iph,ceq%phase_varres(lokcs)%phstate - if(ceq%phase_varres(lokcs)%phstate.eq.phhidden) then - write(*,*)'Error calling mark_stable for hidden phase' - gx%bmperr=4095; goto 1000 - elseif(ceq%phase_varres(lokcs)%phstate.le.phdorm) then - write(*,*)'Cannot make suspended or doremant phases as stable' - gx%bmperr=4095; goto 1000 - elseif(ceq%phase_varres(lokcs)%phstate.eq.phfixed) then -! do nothing - goto 1000 - else - ceq%phase_varres(lokcs)%phstate=phentstab - endif -1000 continue -! write(*,*)'error code: ',gx%bmperr - return - end subroutine mark_stable_phase - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ -!> 14. Unfinished things -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine set_reference_state(icomp,iph,tpval,ceq) -! set the reference state of a component to be "iph" at tpval - implicit none - integer icomp,iph - double precision, dimension(2) :: tpval - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer nsl,nkl(maxsubl),knr(maxconst),splink,j1,ie,elink - integer ll,jj,nrel,lokph,noendm,jerr,lokres,ny,endmemx,endmemxy,ics - double precision sites(maxsubl),qq(5),yarrsave(maxconst),xsum,gmin,gval - double precision, dimension(:), allocatable :: yarr,xcomp,xmol - integer, dimension(:), allocatable :: maxjj,jend,jendsave - double precision tpsave(2),molat,saveg(6) -! iph negative means remove current reference state - if(iph.lt.0) then - ceq%complist(icomp)%phlink=0 - deallocate(ceq%complist(icomp)%endmember) - ceq%complist(icomp)%tpref=zero - ceq%complist(icomp)%refstate='SER (default)' - goto 1000 - endif -! calculate the composition of the component in mole fractions - nrel=noel() - allocate(xcomp(nrel)) - splink=ceq%complist(icomp)%splink - xcomp=zero - xsum=zero - do j1=1,splista(splink)%noofel - elink=splista(splink)%ellinks(j1) - ie=ellista(elink)%alphaindex - xcomp(ie)=splista(splink)%stoichiometry(j1) - xsum=xsum+xcomp(ie) - enddo - do ie=1,splista(splink)%noofel - xcomp(ie)=xcomp(ie)/xsum - enddo -! write(*,17)'srs x: ',(xcomp(ie),ie=1,nrel) -17 format(a,15(f5.2)) -! find suitable endmember with correct composition and minimal G - call get_phase_data(iph,1,nsl,nkl,knr,yarrsave,sites,qq,ceq) - if(gx%bmperr.ne.0) goto 1000 - allocate(maxjj(0:nsl)) - allocate(jend(1:nsl)) - allocate(jendsave(1:nsl)) -! generate all endmembers, maybe there is a better way ... -! and set unity fraction in yarr and check composition - ny=0 - maxjj(0)=1 - do ll=1,nsl - ny=ny+nkl(ll) - maxjj(ll)=ny - enddo - allocate(yarr(ny)) - yarr=zero - jj=1 - do ll=1,nsl - yarr(jj)=one - jend(ll)=jj - jj=jj+nkl(ll) - enddo - allocate(xmol(nrel)) -! lokph=phases(iph) -! we must save the gval for lokres (composition set 1) - ics=1 - call get_phase_compset(iph,ics,lokph,lokres) - if(gx%bmperr.ne.0) goto 1000 - gmin=1.0D5 - noendm=0 - tpsave=ceq%tpval - if(tpval(1).gt.zero) then -! negative tpval means current temperature, else use tpval(1) - ceq%tpval(1)=tpval(1) - endif - ceq%tpval(2)=tpval(2) - do ie=1,6 - saveg(ie)=ceq%phase_varres(lokres)%gval(ie,1) - enddo -! write(*,912)'25H Saved G: ',lokres,ceq%phase_varres(lokres)%gval(1,1),& -! saveg(1) -!---------------------------------------------- -! return here for each endmember - endmemx=0 -200 continue -! write(*,*)'25H endm: ',(jend(jj),jj=1,nsl) -! write(*,17)'25H srs y: ',(yarr(jj),jj=1,ny) - call set_constitution(iph,1,yarr,qq,ceq) - if(gx%bmperr.ne.0) goto 900 -! this subroutine converts site fractions in phase iph, compset 1 -! to mole fractions of components (or elements ??? ) - endmemx=endmemx+1 - call calc_phase_mol(iph,xmol,ceq) - if(gx%bmperr.ne.0) goto 900 -! write(*,17)'25H srs xem: ',(xmol(ie),ie=1,nrel) - do jj=1,nrel - if(abs(xmol(jj)-xcomp(jj)).gt.1.0D-12) goto 250 - enddo -!-------------------------------------------------- -! we have an endmember with the correct composition - call calcg(iph,1,0,lokres,ceq) - if(gx%bmperr.ne.0) goto 900 - gval=ceq%phase_varres(lokres)%gval(1,1)/qq(1) -! write(*,222)'25H, srs gval: ',qq(1),gval,gmin -222 format(a,F10.3,2(1pe12.4)) - if(gval.lt.gmin) then -! we should check i electrically neutral ?? - noendm=noendm+1 - gmin=gval - jendsave=jend - molat=qq(1) - endmemxy=endmemx -! write(*,229)'25H min: ',gmin,jendsave -229 format(a,1pe12.4,10i4) - endif -250 continue -! change constitution .... quit when all endmembers done - ll=nsl -! should this always be 0? - maxjj(0)=0 -260 continue -! jend is the current endmember - jj=jend(ll) - yarr(jj)=zero - jj=jj+1 - if(jj.gt.maxjj(ll)) then - jend(ll)=maxjj(ll-1)+1 - yarr(jend(ll))=one - ll=ll-1 -! if ll becomes zero here all endmemebrs have been generated (?) - if(ll.ge.1) goto 260 - else - jend(ll)=jj - yarr(jj)=one - goto 200 - endif -!---------------------------------------------- - if(noendm.eq.0) then -! if no endmember found this phase cannt be reference phase - write(*,*)'This phase cannot be reference state for for this component' - gx%bmperr=7777; goto 900 - endif -! endmemx and endmemxy redundant -! write(*,808)'25H reference state endmember',lokph,endmemxy,jendsave -808 format(a,i3,2x,10i3) -! If all OK then save phase name, endmember array, T and P - ceq%complist(icomp)%phlink=lokph - if(.not.allocated(ceq%complist(icomp)%endmember)) then -! if the user changes reference state do not allocate again - allocate(ceq%complist(icomp)%endmember(nsl)) - endif - ceq%complist(icomp)%endmember=jendsave -! allocate(ceq%complist(icomp)%endmember(1)) -! ceq%complist(icomp)%endmember=endmemxy -! molat is probably redundant as calcg_endmember returns for one mole component - ceq%complist(icomp)%molat=molat -! Note tpval(1) can be negative indicating current T - ceq%complist(icomp)%tpref=tpval - ceq%complist(icomp)%refstate=phlista(lokph)%name -! restore original constitution of compset 1 -900 continue - ceq%tpval=tpsave - jerr=gx%bmperr; gx%bmperr=0 - call set_constitution(iph,1,yarrsave,qq,ceq) - if(jerr.ne.0) then - gx%bmperr=jerr - endif -! restore original vales of G and derivatives - do ie=1,6 - ceq%phase_varres(lokres)%gval(ie,1)=saveg(ie) - enddo -! write(*,912)'25H Restored G: ',lokres,ceq%phase_varres(lokres)%gval(1,1),& -! saveg(1) -912 format(a,i5,6(1pe12.4)) -1000 continue - return - end subroutine set_reference_state - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine set_unit(property,unit) -! set the unit for a property, like K, F or C for temperature -! >>>> unfinished - implicit none - character*(*) property,unit -!\end{verbatim} - write(*,*)'Not implemented yet' - gx%bmperr=7777 -1000 continue - return - end subroutine set_unit - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine save_results(lut,iph,ics,long) -! write calculated results for a phase for later use in POST - implicit none - integer lut,iph,ics,long -!\end{verbatim} - write(*,*)'Not implemented yet' - gx%bmperr=7777 -! header with abbreviations -! call list_abbrev(lut) -! first conditions ... -! call list_conditions(lut) -! Global values of G, N, V etc -! call list_global_results(lut) -! Element data -! call list_components_results(lut) -! Phases and composition sets -! call dump_phase_results(lut) -1000 return - end subroutine save_results - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine set_constituent_reference_state(iph,icon,asum) -! determine the end member to calculate as reference state for this constituent -! Used when giving a chemical potential for a constituent like MU(GAS,H2O) - implicit none - integer iph,icon - double precision asum -!\end{verbatim} - type(gtp_endmember), pointer :: endmemrec - integer lokph,nsl,ll,jcon,loksp,loksp2,lokcs -! - lokph=phases(iph) - loksp=phlista(lokph)%constitlist(icon) - nsl=phlista(lokph)%noofsubl - endmemrec=>phlista(lokph)%ordered - asum=one - lokcs=phlista(lokph)%linktocs(1) - if(nsl.eq.1) then - asum=firsteq%phase_varres(lokcs)%sites(1) - emlist1: do while(associated(endmemrec)) - if(endmemrec%fraclinks(nsl,1).eq.icon) goto 300 - endmemrec=>endmemrec%nextem - enddo emlist1 - else -! several sublattices OK if same species or vacancies in other sublattices - asum=zero - emlist2: do while(associated(endmemrec)) - do ll=1,nsl - jcon=endmemrec%fraclinks(ll,1) - if(jcon.ne.icon) then - loksp2=phlista(lokph)%constitlist(jcon) - if(loksp2.eq.loksp) then -! same species in this sublattice, add sites to asum - asum=asum+firsteq%phase_varres(lokcs)%sites(ll) - elseif(.not.btest(splista(loksp2)%status,spva)) then -! other species (not vacancies) in this sublattice, skip this end member - goto 200 - endif - else - asum=asum+firsteq%phase_varres(lokcs)%sites(ll) - endif - enddo -! this endmember OK - goto 300 -! not this end member -200 continue - endmemrec=>endmemrec%nextem - enddo emlist2 - endif -! this phase cannot exist for species icon as pure - gx%bmperr=4112; goto 1000 -300 continue -1000 continue - return - end subroutine set_constituent_reference_state - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine elements2components(nspel,stoi,ncmp,cmpstoi,ceq) -! converts a stoichiometry array for a species from elements to components - implicit none - integer nspel,ncmp - double precision stoi(*),cmpstoi(*) - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - double precision, parameter :: small=1.0d-30 - integer ic,jc,ns -! use the ceq%complist(ic)%invcompstoi - do ic=1,noofel - cmpstoi(ic)=zero - enddo -! not sure about the indices here .... ???? -! write(*,*)'e2c: ',noofel,nspel,stoi(1),ceq%invcompstoi(1,1) - do ic=1,noofel - do jc=1,nspel - cmpstoi(ic)=cmpstoi(ic)+ceq%invcompstoi(ic,jc)*stoi(jc) - enddo - enddo - ncmp=0 - ic=0 - ns=0 -200 continue - ic=ic+1 - if(ic.lt.noofel) then - if(abs(cmpstoi(ic)).lt.small) then - do jc=ic,noofel - cmpstoi(jc)=cmpstoi(jc+1) - enddo - else - ncmp=ncmp+1 -! write(*,*)'c2c1: ',ic,ncmp - endif - goto 200 - elseif(abs(cmpstoi(ic)).gt.small) then -! write(*,*)'c2c2: ',ic,ncmp,cmpstoi(ic) - ncmp=ncmp+1 - endif -! write(*,190)ic,(cmpstoi(i),i=1,ncmp) -!190 format('e2c3: ',i3,10F7.3) -1000 continue - return - end subroutine elements2components - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\! -!> 15. Internal stuff -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine alphaelorder -! arrange new element in alphabetical order -! also make alphaindex give alphabetical order - implicit none -!\end{verbatim} %+ - character symb1*2 - integer i,j - symb1=ellista(noofel)%symbol -! write(6,*)'alphaelorder 1: ',symb1,noofel - loop1: do i=1,noofel-1 - if(symb1.lt.ellista(elements(i))%symbol) then - loop2: do j=noofel,i+1,-1 - elements(j)=elements(j-1) - ellista(elements(j))%alphaindex=j - enddo loop2 -! write(6,*)'alphaelorder 3: ',i - elements(i)=noofel - ellista(elements(i))%alphaindex=i - exit - endif - enddo loop1 -! write(6,*)'alphaelorder 4: ',(elements(k),k=1,noofel) - END subroutine alphaelorder - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine alphasporder -! arrange new species in alphabetical order -! also make alphaindex give alphabetical order - implicit none -!\end{verbatim} %+ - character symb1*24 - integer i,j - symb1=splista(noofsp)%symbol -! write(6,*)'alphasporder 1: ',symb1(1:6),noofsp - loop1: do i=1,noofsp-1 - if(symb1.lt.splista(species(i))%symbol) then -! write(6,*)'alphasporder 2; ',symb1,splista(species(i))%symbol - loop2: do j=noofsp,i+1,-1 - species(j)=species(j-1) - splista(species(j))%alphaindex=j - enddo loop2 - species(i)=noofsp -! write(6,*)'alphasporder 3:',i - splista(species(i))%alphaindex=i - exit - endif - enddo loop1 -! write(6,*)'alphasporder 4: ',(species(k),k=1,noofsp) - END subroutine alphasporder - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine alphaphorder(tuple) -! arrange last added phase in alphabetical order -! also make alphaindex give alphabetical order -! phletter G and L and I have priority -! tuple is returned as position in phase tuple - implicit none - integer tuple -!\end{verbatim} - character symb1*24,ch1*1,ch2*1 - integer iph,lokph,j,lokcs -! - symb1=phlista(noofph)%name - ch1=phlista(noofph)%phletter -! one more phase in "phases" array - phases(noofph)=noofph -! write(6,75)'alphaphorder 1: ',noofph,ch1,symb1(1:6) -!75 format(A,I3,1x,A,1x,A) - loop1: do iph=1,noofph-1 - lokph=phases(iph) - ch2=phlista(lokph)%phletter -! write(6,76)'alphaphorder 2A: ',iph,lokph,ch1,ch2 -76 format(A,2I3,1x,A,1x,A) -! phaseletter different, if ch1=G insert it here - if(ch1.eq.'G') goto 300 - if(ch2.eq.'G') goto 200 - liquid: if(ch1.eq.'L') then - if(ch2.eq.'G') goto 200 - if(ch2.eq.'L') goto 100 - goto 300 - endif liquid - if(ch2.eq.'L') goto 200 - solution: if(ch1.eq.'S') then - if(ch2.eq.'G' .or. ch2.eq.'L') goto 200 - if(ch2.eq.'S') goto 100 - goto 300 - endif solution - if(ch2.eq.'S') goto 200 - compound: if(ch1.eq.'C') then - if(ch2.eq.'C') goto 100 - goto 200 - endif compound -! here phletter of lokph and the new phase are the same -100 continue -! write(6,*)'alphaphorder 2B: ',symb1,phlista(lokph)%name - if(symb1.lt.phlista(lokph)%name) goto 300 -200 continue - enddo loop1 -! exit loop, add new phase last -! lokph=phases(noofph) - iph=phases(noofph) -300 continue -! write(*,*)'25H new phase position: ',iph -! write(6,77)'alphaphorder 2C: ',iph,lokph,phlista(lokph)%name -!77 format(A,2I3,1X,A) -! insert phase here at iph, shift down trailing phase indices -! also OK if new phase should be last - loop2: do j=noofph,iph+1,-1 -! update index of trailing phases, loop from the end not to overwrite - phases(j)=phases(j-1) - phlista(phases(j))%alphaindex=j - enddo loop2 -! index of new phase -! write(6,*)'alphaphorder 4: ',lokph,iph,noofph - phases(iph)=noofph - phlista(noofph)%alphaindex=iph -! write(6,*)'alphaphorder 3: ',iph,(phases(k),k=1,noofph) -! update phasetuple array -! write(*,*)'25H New phase alphabetic order: ',iph - do j=nooftuples,iph,-1 - phasetuple(j+1)%phase=phasetuple(j)%phase - phasetuple(j+1)%compset=phasetuple(j)%compset -! we must also change the tuple index in phase_varres!! - lokcs=phlista(phasetuple(j)%phase)%linktocs(1) - firsteq%phase_varres(lokcs)%phtupx=j+1 -! write(*,777)'25H shifted phase in phasetuple',& -! phasetuple(j)%phase,lokcs,j+1 - enddo -! insert the first compset of new phase in phasetuple position iph - phasetuple(iph)%phase=noofph - phasetuple(iph)%compset=1 - nooftuples=nooftuples+1 - tuple=iph -! write(*,771)(phasetuple(j)%phase,phasetuple(j)%compset,j=1,nooftuples) -771 format('25H: ',10(2i3,1x)) -! link to first compset set when phase_varres record connected -! write(*,777)'25H phase tuple position: ',iph,noofph,lokph,lokcs,tuple -777 format(a,10i5) - return - END subroutine alphaphorder - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine check_alphaindex -! just for debugging, check that ellist(i)%alphaindex etc is correct - implicit none -!\end{verbatim} - integer i,j,k,l - write(kou,*) - write(6,77)(ellista(elements(i))%symbol,i=1,noofel) -77 format(20(1x,A2)) - write(6,78)(splista(species(i))%symbol,i=1,noofsp) -78 format(20(1x,a6)) - write(6,*)'element alphaindex' - check1: do i=1,noofel - j=ellista(elements(i))%alphaindex - write(6,*)i,j,elements(i),ellista(i)%symbol - enddo check1 - write(6,*)'species alphaindex' - check2: do i=1,noofsp - j=species(i) - k=splista(j)%alphaindex - l=splista(species(j))%alphaindex - write(6,79)i,k,j,l,splista(j)%symbol - enddo check2 -79 format(4i4,1x,A) - check3: do i=1,noofsp - write(6,*)i,splista(i)%alphaindex,splista(i)%symbol - enddo check3 - END subroutine check_alphaindex - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine create_constitlist(constitlist,nc,klist) -! creates a constituent list ... - implicit none - integer, dimension(*) :: klist - integer, dimension(:), allocatable :: constitlist - integer nc -!\end{verbatim} - integer ic - ALLOCATE(constitlist(nc)) - DO ic=1,nc - constitlist(ic)=klist(ic) - enddo - return - END subroutine create_constitlist - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine create_parrecords(lokph,lokcs,nsl,nc,nprop,iva,ceq) -! fractions and results arrays for a phase for parallell calculations -! location is returned in lokcs -! nsl is sublattices, nc number of constituents, nprop max number if propert, -! iva is an array which is set as constituent status word (to indicate VA) -! ceq is always firsteq ??? -! -! BEWARE not adopted for threads -! -! >>> changed all firsteq below to ceq???? -! - implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq - integer, dimension(*) :: iva - integer lokph,lokcs, nsl, nc, nprop -!\end{verbatim} - integer ic,nnc -! find free record, free list maintained in FIRSTEQ -! write(*,*)'25H maxcalcprop: ',nprop - lokcs=csfree - if(csfree.le.0) then -! This means no free phase_varres records. -! csfree is set to -1 by the statement csfree=phase_varres(lokcs)%next below -! when reserving the last free record. The same for the other free lists - gx%bmperr=4094; goto 1000 - endif -! the free list of phase_varres record only maintained in firsteq -! all equilibria have identical allocation of phase_varres records - csfree=firsteq%phase_varres(lokcs)%nextfree - if(csfree.gt.highcs) highcs=csfree - firsteq%phase_varres(lokcs)%nextfree=0 - firsteq%phase_varres(lokcs)%status2=0 -! added integer status array constat. Set CONVA bit from iva array -! write(*,*)'Allocate constat 2: ',nc,lokcs - allocate(ceq%phase_varres(lokcs)%constat(nc)) -! write(*,33)nc,(iva(i),i=1,nc) - do ic=1,nc - ceq%phase_varres(lokcs)%constat(ic)=iva(ic) - enddo -! allocate fraction and default fraction arrays - allocate(ceq%phase_varres(lokcs)%yfr(nc)) - allocate(ceq%phase_varres(lokcs)%mmyfr(nc)) - do ic=1,nc - ceq%phase_varres(lokcs)%yfr(ic)=one - ceq%phase_varres(lokcs)%mmyfr(ic)=zero - enddo -! write(*,*)'Allocated mmyfr: ',lokcs,nc,nprop -! abnorm initiated to unity to avoid trouble at first calculation - ceq%phase_varres(lokcs)%abnorm=one - allocate(ceq%phase_varres(lokcs)%sites(nsl)) -! - if(btest(phlista(lokph)%status1,PHIONLIQ)) then -! for ionic liquid the sites may depend on composition - allocate(ceq%phase_varres(lokcs)%dpqdy(nc)) - allocate(ceq%phase_varres(lokcs)%d2pqdvay(nc)) - endif -! -! result arrays for a phase for use in parallell processing - ceq%phase_varres(lokcs)%nprop=nprop - allocate(ceq%phase_varres(lokcs)%listprop(nprop)) - allocate(ceq%phase_varres(lokcs)%gval(6,nprop)) -! write(*,*)'Allocated gval: ',nprop,nc - allocate(ceq%phase_varres(lokcs)%dgval(3,nc,nprop)) - nnc=nc*(nc+1)/2 -! write(*,*)'Allocated dgval: ',nprop,nc,nnc - allocate(ceq%phase_varres(lokcs)%d2gval(nnc,nprop)) -! write(*,*)'Allocated d2gval: ',nprop,nc,nnc -! zero everything - ceq%phase_varres(lokcs)%listprop=0 -! ceq%phase_varres(lokcs)%amount=zero - ceq%phase_varres(lokcs)%amfu=zero - ceq%phase_varres(lokcs)%netcharge=zero - ceq%phase_varres(lokcs)%dgm=zero - ceq%phase_varres(lokcs)%gval=zero - ceq%phase_varres(lokcs)%dgval=zero - ceq%phase_varres(lokcs)%d2gval=zero -! Mark there is no disordered phase_varres record - ceq%phase_varres(lokcs)%disfra%varreslink=0 -! write(*,*)'parrecords: ',lokcs,nsl,nc -1000 continue - return - end subroutine create_parrecords - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine create_interaction(intrec,mint,lint,intperm,intlinks) -! creates a parameter interaction record -! with permutations if intperm(1)>0 - implicit none - type(gtp_interaction), pointer :: intrec - integer, dimension(2,*) :: lint,intlinks - integer, dimension(*) :: intperm - integer mint -!\end{verbatim} - integer permut,emperm,nz,nq,lqq,ii,ll -! -! write(*,5)'create interaction:',mint,lint(1,mint),lint(2,mint),& -! (intperm(i),i=1,6) -5 format(a,i5,2x,2i3,2x6i3) - allocate(intrec) -! note that the order of values in intperm here is not the same as in -! fccpermuts or bccpermuts. Intlinks is the same - permut=intperm(1) - if(permut.le.0) then -! This is a default for no permutations, store 1's - permut=0 - allocate(intrec%noofip(2)) - intrec%noofip(1)=1 - intrec%noofip(2)=1 - allocate(intrec%sublattice(1)) - allocate(intrec%fraclink(1)) - elseif(mint.eq.1) then -! Intperm contains information as created by fccpermut or bccpermut -! intperm(1) and 2 are related to mint=1 (level 1 interaction), -! intperm(3) to mint=2 -! The values are stored in noofip(1) and intperm(2..) in noofip(2..) -! For mint=1 intperm(1..2) are stored in noofipermt(1..2) -! intperm(1) is the number of interaction permutations for each -! endmember permutation. -! intperm(2) are the number total number of permutations on level 1 -! The number of endmember permutations is thus intperm(2)/intperm(1) -! write(*,17)'intrec: ',mint,intperm(1),intperm(2) - permut=intperm(2) - nz=intperm(2) - allocate(intrec%noofip(2)) - intrec%noofip(1)=intperm(1) - intrec%noofip(2)=intperm(2) - allocate(intrec%sublattice(nz)) - allocate(intrec%fraclink(nz)) - nq=0 - elseif(mint.eq.2) then -! For mint=2 intperm(3) is stored in noofip(1) and intperm(4..) after that -! if intperm(3)>1 then there are intperm(3) number of limits in -! intperm(2..) for each lower order interaction. -! Example endmember A:A:A:A; no permutations -! 1st level intperm(1)=1, intperm(2)=4; permutations AX:A:A:A, A:AX:A:A etc -! 2nd level intperm(1)=4, inteprm(2..4)=(3, 2, 1, 0) -! 3 permutations for AX:A:A:A: AX:AX:A:A; AX:A:AX:A; AX:A:A:AX -! 2 permutations for A:AX:A:A: A:AX:AX:A A:AX:A:AX; -! 1 permutation for A:A:AX:A: A:A:AX:AX; -! 0 permutations for A:A:A:AX: none -! If noofpermut>1 the index selected of noofip is by the permutation of -! the lower order interaction -! the value in intpermut(4+intperm(3)) is total number of permutations - lqq=intperm(4+intperm(3)) -! write(*,17)'intrec: ',mint,intperm(3),(intperm(3+ii),ii=1,intperm(3)) -17 format(a,2i4,2x,10i4) - permut=intperm(3) - emperm=intperm(2)/intperm(1) - allocate(intrec%noofip(permut+2)) - nz=0 - intrec%noofip(1)=intperm(3) - do ii=1,permut - intrec%noofip(1+ii)=intperm(3+ii) - nz=nz+intperm(3+ii) - enddo -! write(*,19)'ci: ',nz,emperm,permut,(intrec%noofip(j),j=1,permut+2) -19 format(a,10i4) -! AX:AX:A:A; 1 endmember permutation, 4 1st level permutations; 6 2nd level -! emperm=1; intperm(3)=4, intparm(4..6)=(3,2,1,0), nz=1*6=6 -! AX:AX:B:B; 6 endmember permutation, 6 1st level permutations; 6 2nd level -! emperm=6; nz=1; nz=1*6=6 -! number of permutations is related to the previous level -! nz=nz*emperm - nz=lqq -! write(*,*)'Level 2 permutations: ',nz - allocate(intrec%sublattice(nz)) - allocate(intrec%fraclink(nz)) -! Save at the end the total number of permutations stored - intrec%noofip(permut+2)=nz - nq=intperm(2) -! write(*,19)'c2: ',nz,emperm,permut,(intrec%noofip(j),j=1,permut+2) -! write(*,17)'level 2 permutations: ',nz,emperm,nq,lqq - else - write(*,*)'Create_interaction called with too many permutations' - gx%bmperr=7777; goto 1000 - endif - if(permut.eq.0) then -! this is again a default when there are no permutations - intrec%sublattice(1)=lint(1,mint) - intrec%fraclink(1)=lint(2,mint) - else -! We can have cases like noofiperumt(1)=1; noofip(2)=4 or -! noofip(1)=4; noofip(2..5)=(4, 3, 2, 1) -! nq is 0 for first level, intperm(2) for second level - do ll=1,nz - intrec%sublattice(ll)=intlinks(1,nq+ll) - intrec%fraclink(ll)=intlinks(2,nq+ll) - enddo -! write(*,99)'isp: ',mint,& -! (intrec%sublattice(ll),intrec%fraclink(ll),ll=1,nz) -99 format(a,i2,8(2x,2i3)) - endif - nullify(intrec%propointer) - nullify(intrec%nextlink) - nullify(intrec%highlink) - intrec%status=0 - noofint=noofint+1 - intrec%antalint=noofint -1000 continue - return - end subroutine create_interaction - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine create_endmember(lokph,newem,noperm,nsl,endm,elinks) -! create endmember record with nsl sublattices with endm as constituents -! noperm is number of permutations -! endm is the basic endmember -! elinks are the links to constituents for all permutations - implicit none - integer endm(*) - type(gtp_endmember), pointer :: newem - integer, dimension(nsl,noperm) ::elinks - integer lokph,noperm,nsl -!\end{verbatim} - integer is,ndemr,noemr - allocate(newem) - nullify(newem%nextem) - allocate(newem%fraclinks(nsl,noperm)) -! write(*,7)noperm,nsl,(elinks(i,1),i=1,4),(endm(i),i=1,nsl) -7 format('ce1: ',2i4,2x,4i5,2x10i4) - if(noperm.eq.1) then - do is=1,nsl - newem%fraclinks(is,1)=endm(is) - enddo - else - newem%fraclinks=elinks - endif -! zero or set values - newem%noofpermut=noperm - newem%phaselink=lokph - noofem=noofem+1 - newem%antalem=noofem - nullify(newem%propointer) - nullify(newem%intpointer) -! indicate that oendmemarr and denmemarr must be renewed ??? - noemr=0 - ndemr=0 -1000 continue - return - end subroutine create_endmember - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine create_proprec(proprec,proptype,degree,lfun,refx) -! reservs a property record from free list and insert data - implicit none - TYPE(gtp_property), pointer :: proprec - integer proptype,degree,lfun - character refx*(*) -!\end{verbatim} - integer j,iref - character notext*32 - if(degree.lt.0 .or. degree.gt.9) then - gx%bmperr=4063; goto 1000 - endif - allocate(proprec) -! enter data in reserved record - allocate(proprec%degreelink(0:degree)) - nullify(proprec%nextpr) -! if(proptype.ge.100) write(*,*)'property type: ',proptype - proprec%proptype=proptype - proprec%degree=degree - do j=0,degree - proprec%degreelink(j)=0 - enddo - proprec%degreelink(degree)=lfun - proprec%reference=adjustl(refx) -! create reference record if new, can be amended later - call capson(refx) - notext='*** Not set by database or user ' -!------counter - noofprop=noofprop+1 - proprec%antalprop=noofprop -! write(*,11)refx,notext -!11 format('create proprec: ',a,a) - call tdbrefs(refx,notext,0,iref) - proprec%extra=0 -1000 continue - return - end subroutine create_proprec - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine extend_proprec(current,degree,lfun) -! extends a property record and insert new data - implicit none - integer degree,lfun - type(gtp_property), pointer :: current -!\end{verbatim} - integer oldeg,j - integer :: savedegs(0:9) -! save degreelinks ... maybe not necessary .... - oldeg=current%degree -! write(*,*)'extend_proprec 1: ',current,degree,lfun,oldeg - do j=0,9 - savedegs(j)=0 - enddo - do j=0,oldeg - savedegs(j)=current%degreelink(j) - enddo -! important to get it correct here - deallocate(current%degreelink) - allocate(current%degreelink(0:degree)) - current%degree=degree - do j=0,current%degree - current%degreelink(j)=0 - enddo - do j=0,oldeg - current%degreelink(j)=savedegs(j) - enddo - current%degreelink(degree)=lfun -1000 continue - return - end subroutine extend_proprec - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine new_phase_varres_record(iph,phvar,ceq) -! this subroutine returnes a copy of the phase variable structure for iph -! >>>>>>>>>>>>> -! this subroutine is probably redundant since the structure -! gtp_equilibrium_data was introduced. Each parallell tread should have -! its own gtp_equilibrium_data record. -! >>>>>>>>>>>>>>>>>>>>>>>>>> -! The programmer can enter fraction in this structure and use it in calls -! to parcalcg should be suitable for parallel processing (NOT TESTED) -! when the same phase is calculated in several threads (like when separate -! threads calculate different lines suring mapping) - implicit none -! >>>> unfinished -! >>>> for calculation of the same phase in separate threads - integer iph - TYPE(gtp_equilibrium_data) :: ceq - TYPE(gtp_phase_varres) :: phvar -!\end{verbatim} - integer tnooffr,lokph,lokcs,nsl,lokdis - TYPE(gtp_phase_varres) :: phdis - TYPE(gtp_fraction_set) :: olddis,newdis -! - if(iph.le.0 .or. iph.gt.noofph) then - gx%bmperr=4050; goto 1000 - endif - lokph=phases(iph) -! lokcs=phlista(lokph)%cslink - lokcs=phlista(lokph)%linktocs(1) -! allocate arrays and copy values from phase_varres(lokcs) to phvar - phvar%nextfree=0 - phvar%phlink=ceq%phase_varres(lokcs)%phlink - phvar%status2=ceq%phase_varres(lokcs)%status2 - nsl=size(ceq%phase_varres(lokcs)%sites) - tnooffr=size(ceq%phase_varres(lokcs)%yfr) -! write(*,*)'Allocate constat 3: ',nc - allocate(phvar%constat(tnooffr)) - allocate(phvar%yfr(tnooffr)) - allocate(phvar%mmyfr(tnooffr)) - allocate(phvar%sites(nsl)) - phvar%constat=ceq%phase_varres(lokcs)%constat - phvar%yfr=ceq%phase_varres(lokcs)%yfr -! phvar%mmyfr=ceq%phase_varres(lokcs)%mmyfr - phvar%mmyfr=zero - phvar%sites=ceq%phase_varres(lokcs)%sites - write(*,*)'new_phase_varres: ',lokcs,tnooffr - if(btest(phlista(lokph)%status1,PHMFS))then -! there is a disordered fraction set ... suck - olddis=ceq%phase_varres(lokcs)%disfra - phvar%disfra%latd=olddis%latd - phvar%disfra%ndd=olddis%ndd - phvar%disfra%tnoofxfr=olddis%tnoofxfr - phvar%disfra%tnoofyfr=olddis%tnoofyfr - phvar%disfra%varreslink=olddis%varreslink - phvar%disfra%totdis=olddis%totdis - allocate(phvar%disfra%dsites(olddis%ndd)) - allocate(phvar%disfra%nooffr(olddis%ndd)) - allocate(phvar%disfra%splink(olddis%tnoofxfr)) - allocate(phvar%disfra%y2x(olddis%tnoofyfr)) - allocate(phvar%disfra%dxidyj(olddis%tnoofyfr)) - phvar%disfra%dsites=olddis%dsites - phvar%disfra%nooffr=olddis%nooffr - phvar%disfra%splink=olddis%splink - phvar%disfra%y2x=olddis%y2x - phvar%disfra%dxidyj=olddis%dxidyj -! -! we must create a new phase_varres record for the disordered fractions - lokdis=olddis%varreslink -! allocate(phdis) - call new_disordered_phase_variable_record(lokdis,phvar,phdis,ceq) -! the link between phvar and phdis is set inside new_disordered -! write(*,*)'disord 5 ',phdis%phlink,phase_varres(lokdis)%phlink, & -! phvar%disfra%phdapointer%phlink - endif -1000 continue - return - end subroutine new_phase_varres_record - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine new_disordered_phase_variable_record(lokdis,phvar,phdis,ceq) -! Does this really work???? -! creates a copy of the disordered phase variable record lokdis -! and set links from ordered phvar -! ?????????????? does this work ?????????? is it necessary ???? -! can one just make an assignment ???? - implicit none - TYPE(gtp_equilibrium_data) :: ceq - TYPE(gtp_phase_varres) :: phvar - TYPE(gtp_phase_varres), target :: phdis - integer lokdis -!\end{verbatim} - integer tnooffr,nsl -! - phdis%nextfree=0 - phdis%phlink=ceq%phase_varres(lokdis)%phlink -! write(*,*)'disord 1 ',phdis%phlink,phase_varres(lokdis)%phlink - phdis%status2=ceq%phase_varres(lokdis)%status2 - nsl=size(ceq%phase_varres(lokdis)%sites) - tnooffr=size(ceq%phase_varres(lokdis)%yfr) -! write(*,*)'Allocate constat 4: ',tnooffr - allocate(phdis%constat(tnooffr)) - allocate(phdis%yfr(tnooffr)) - allocate(phdis%sites(nsl)) - phdis%constat=ceq%phase_varres(lokdis)%constat - phdis%yfr=ceq%phase_varres(lokdis)%yfr - allocate(phdis%mmyfr(tnooffr)) - phdis%mmyfr=zero -! phdis%mmyfr=ceq%phase_varres(lokdis)%mmyfr - phdis%sites=ceq%phase_varres(lokdis)%sites -! save link to the phdis record, two links ... why? just because it is messy -! write(*,*)'disord 2 ',phdis%phlink,phase_varres(lokdis)%phlink - phvar%disfra%phdapointer=>phdis -! why setting it to zero here??? it should be an index to phase_varres record - phvar%disfra%varreslink=0 -! phvar%disordered=>phdis -! write(*,*)'disord 3 ',phdis%phlink,phase_varres(lokdis)%phlink -1000 continue - return - end subroutine new_disordered_phase_variable_record - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine add_fraction_set(iph,id,ndl,totdis) -! add a new set of fractions to a phase, usually to describe a disordered state -! like the "partitioning" in old TC -! -! BEWARE this is only done for firsteq, illegal when having more equilibria -! -! id is a letter used as suffix to identify the parameters of this set -! ndl is the last original sublattice included in the (first) disordered set -! ndl can be 1 meaning sublattice 2..nsl are disordered, or nsl meaning all are -! disordered -! totdis=0 if phase never disorder totally (like sigma) -! -! For a phase like (Al,Fe,Ni)3(Al,Fe,Ni)1(C,Va)4 to add (Al,Fe,Ni)4(C,Va)4 -! icon=1 2 3 1 2 3 4 5 with ndl=2 -! For a phase like (Fe,Ni)10(Cr,Mo)4(Cr,Fe,Mo,Ni)16 then -! icon=2 4 1 3 1 2 3 4 with ndl=3 -! This subroutine will create the necessary data to calculate the -! disordered fraction set from the site fractions. -! -! IMPORTANT (done): for each composition set this must be repeated -! if new composition sets are created it must be repeated for these -! -! IMPORTANT (not done): order the constituents alphabetically in each disorderd -! sublattice otherwise it will not be possible to enter parameters correctly -! - implicit none - integer iph,ndl,totdis - character id*1 -!\end{verbatim} -! ceq probably not needed as firsteq is declared as pointer - TYPE(gtp_equilibrium_data), target :: ceq - TYPE(gtp_fraction_set), target :: fsdata -! jsp(i) contains species locations of disordered constituent i -! jy2x(i) is the disordered fraction to which site fraction i should be added -! y2x(i) is the site ration factor for multiplying sitefraction i when added -! ispord and ispold are needed to sort disordered constituents - integer jsp(maxconst,2),jy2x(maxconst),iva(maxconst) - integer ispord(maxconst),ispold(maxconst),nrj3(2),nrj4(2) - integer lokph,lokcs,nsl,ii,nrj1,nrj2,nlat,lokx,l2 - integer ll,kk,jall,nnn,mmm,ioff,koff,jl,j1,j2,ix,is,jj,k,ijcs,nydis,nyttcs - double precision sum,div -! - if(.not.allowenter(2)) then - gx%bmperr=4125 - goto 1000 - endif -! this subroutine can only be called when there is only one equilibrium -! Hm, does this create a copy of firsteq?? YES ... clumsy - ceq=firsteq - lokph=phases(iph) -! phase must not have any suspended constituents nor any composition sets - if(phlista(lokph)%noofcs.gt.1) then - gx%bmperr=4029; goto 1000 - else - lokcs=phlista(lokph)%linktocs(1) - if(btest(firsteq%phase_varres(lokcs)%status2,CSCONSUS)) then - gx%bmperr=4030; goto 1000 - endif - endif - nsl=phlista(lokph)%noofsubl - if(ndl.le.0 .or. ndl.gt.nsl) then -! ndl must be larger than 0 and lesser or equal to nsl - gx%bmperr=4076; goto 1000 - endif -! location of first composition set, there may be more - if(btest(phlista(lokph)%status1,phmfs)) then -! disordered fractions already set - gx%bmperr=4077; goto 1000 - endif -! we must organise a constituent list for the disordered fractions by -! scanning the constituents in the current phlista(lokph)%constitlist -! we must also contruct the way site fractions should be added - ii=0 - nrj1=1 - nrj2=0 - nlat=0 - lokx=0 - l2=1 - iva=0 - subloop: do ll=1,nsl - constloop: do kk=1,phlista(lokph)%nooffr(ll) - ii=ii+1 - if(nrj2.lt.nrj1) then - nrj2=nrj2+1 - lokx=lokx+1 - jy2x(ii)=lokx - jsp(nrj2,l2)=phlista(lokph)%constitlist(ii) -! write(*,46)'new 1: ',nrj2,l2,ii,nlat,jsp(nrj2,l2),jy2x(ii) - else - do jall=nrj1,nrj2 - if(phlista(lokph)%constitlist(ii).eq.jsp(jall,l2)) then -! this constituent already found in another sublattice to be merged -! write(*,*)'same: ',jall,nlat,jall+nlat,ii,jy2x(jall+nlat) - jy2x(ii)=jy2x(jall+nlat); goto 50 - endif - enddo -! new constituent - nrj2=nrj2+1 - lokx=lokx+1 - jy2x(ii)=lokx - jsp(nrj2,l2)=phlista(lokph)%constitlist(ii) -! write(*,46)'new 2: ',nrj2,l2,ii,nlat,jsp(nrj2,l2),jy2x(ii) -46 format(a,10i3) -! if vacancy set that bit in iva - if(btest(firsteq%phase_varres(lokcs)%constat(ii),conva)) then - iva(nrj2)=ibset(iva(nrj2),conva) - endif -! write(*,*)'addfs 7B: ',ll,ii,nrj2 -50 continue - endif - enddo constloop - if(ll.eq.ndl) then -! next sublattices (if any) will be summed to second disordered sublattice - nrj3(1)=nrj2 - nrj3(2)=0 -! bug?? - nlat=ii - nrj1=1 - nrj2=0 -! nrj4 is the number of constituents in ordered phase thst is summed -! to first disordered sublattice. Needed below to rearrange jy2x - nrj4(1)=ii - nrj4(2)=0 - if(ndl.lt.nsl) l2=2 -! write(*,*)'addfs 7C: ',ll,ndl,nrj1,nrj2,nrj3 - elseif(ll.eq.nsl) then -! this may never be executed if ndl=nsl but we set nrj3(2)=0 above - nrj3(2)=nrj2 - nrj4(2)=ii-nrj4(1) - endif - enddo subloop -! write(*,53)'add_fraction_set 2: ',(jy2x(i),i=1,ii) -53 format(a,20i3) -! added fsites to handle the case when reading sigma etc from a TDB file -! as the TDB file format assumes 1 site. Default is 1.0, changed externally - fsdata%fsites=one -! write(*,*)'Set fsites: ',fsdata%fsites -! -! write(*,53)'add_fraction_set 3: ',nrj1,nrj2,nrj3,nrj4 - fsdata%latd=ndl - fsdata%tnoofyfr=phlista(lokph)%tnooffr - fsdata%varreslink=lokcs -! totdis=1 means disordered fcc, bcc, ncp. totdis=0 means sigma - fsdata%totdis=totdis - fsdata%id=id -! one or 2 disordered sublattices - nnn=1 - if(ndl.lt.nsl) nnn=2 - allocate(fsdata%dsites(nnn)) - fsdata%ndd=nnn - allocate(fsdata%nooffr(nnn)) - fsdata%nooffr(1)=nrj3(1) - if(nnn.eq.2) fsdata%nooffr(2)=nrj3(2) -! nrj3(1) are the number of constituents on first sublattice, nrj3(2) on 2nd - mmm=nrj3(1)+nrj3(2) - fsdata%tnoofxfr=mmm - allocate(fsdata%splink(mmm)) - allocate(fsdata%y2x(phlista(lokph)%tnooffr)) - allocate(fsdata%dxidyj(phlista(lokph)%tnooffr)) -! write(*,*)'add_fs dxidyj: ',phlista(lokph)%tnooffr -! the constituents in jsp(i..n,subl) must be ordered alphabetically!!! -! get the species number in alphadetical order - ioff=0 - koff=0 - do l2=1,nnn - do jl=1,nrj3(l2) -! write(*,*)'l2 loop: ',jsp(i,l2) - ispord(jl)=splista(jsp(jl,l2))%alphaindex - enddo -! write(*,47)1,(ispord(i),i=1,nrj3(l2)) -47 format('add_fs ',i1,': ',20i3) -! species, noofsp, origonal order - call sortin(ispord,nrj3(l2),ispold) - if(buperr.ne.0) then - gx%bmperr=buperr; goto 1000 - endif -! when rearranging jsp(1..n,l2) we must also rearrange y2x -! for 2nd sublattice add nrj3(1) to ispold - if(l2.eq.2) then - ioff=nrj4(1) - koff=nrj3(1) - endif -! write(*,47)2,(jy2x(ioff+i),i=1,nrj4(l2)) -! this must be possible to do smarter ..... - do j2=1,nrj4(l2) - do j1=1,nrj3(l2) - if(jy2x(ioff+j2).eq.ispold(j1)+koff) then - jy2x(ioff+j2)=j1+koff; goto 77 - endif - enddo -77 continue - enddo - do j1=1,nrj3(l2) - ispord(j1)=jsp(ispold(j1),l2) - enddo - do j1=1,nrj3(l2) - jsp(j1,l2)=ispord(j1) - enddo -! write(*,47)5,(jsp(i,l2),i=1,nrj3(l2)) - enddo - fsdata%splink=0 -! - do jl=1,phlista(lokph)%tnooffr - fsdata%y2x(jl)=jy2x(jl) - enddo - ix=0 - do l2=1,nnn - do jl=1,nrj3(l2) - ix=ix+1 - fsdata%splink(ix)=jsp(jl,l2) - enddo - enddo -! write(*,*)'addfs splink: ',fsdata%splink -! - is=0 - sum=zero - do ll=1,ndl -! sum=sum+phlista(lokph)%sites(ll) - sum=sum+firsteq%phase_varres(lokcs)%sites(ll) - enddo - fsdata%dsites(1)=sum - if(ndl.lt.nsl) then - sum=zero - do ll=ndl+1,nsl -! sum=sum+phlista(lokph)%sites(ll) - sum=sum+firsteq%phase_varres(lokcs)%sites(ll) - enddo - fsdata%dsites(2)=sum - endif -! - jj=0 - sum=fsdata%dsites(1) - do ll=1,nsl - if(ll.gt.ndl) sum=fsdata%dsites(2) -! div=phlista(lokph)%sites(ll)/sum - div=firsteq%phase_varres(lokcs)%sites(ll)/sum -! write(*,78)'add_fs 5A ',div,phlista(lokph)%sites(ll),sum -!78 format(a,6F10.7) - do k=1,phlista(lokph)%nooffr(ll) - jj=jj+1 - fsdata%dxidyj(jj)=div - enddo - enddo -! write(*,99)'add_fs 5B ',fsdata%dxidyj -99 format(a,6(F10.7)) - firsteq%phase_varres(lokcs)%disfra=fsdata - firsteq%phase_varres(lokcs)%status2=& - ibset(firsteq%phase_varres(lokcs)%status2,CSDLNK) -! we have to reserve a phase_varres record for calculations -! ... det gäller att hålla tungan rätt i mun ... -! nprop=10 -! call create_parrecords(nyttcs,nnn,mmm,nprop,iva,firsteq) - call create_parrecords(lokph,nyttcs,nnn,mmm,maxcalcprop,iva,firsteq) - if(gx%bmperr.ne.0) goto 1000 - fsdata%varreslink=nyttcs -! note ceq is firsteq but declared target - fsdata%phdapointer=>ceq%phase_varres(nyttcs) - firsteq%phase_varres(nyttcs)%phlink=lokph - firsteq%phase_varres(nyttcs)%prefix=' ' - firsteq%phase_varres(nyttcs)%suffix=' ' - do ll=1,nnn - firsteq%phase_varres(nyttcs)%sites(ll)=fsdata%dsites(ll) - enddo - firsteq%phase_varres(nyttcs)%status2=0 - firsteq%phase_varres(nyttcs)%status2=& - ibset(firsteq%phase_varres(nyttcs)%status2,CSDFS) -! finally copy fsdata to the link in lokcs - call copy_fracset_record(lokcs,fsdata,firsteq) - if(gx%bmperr.ne.0) goto 1000 -! if there are several composition sets create fracset records for each -200 continue -! if(firsteq%phase_varres(lokcs)%next.gt.0) then -! lokcs=firsteq%phase_varres(lokcs)%next - do ijcs=2,phlista(lokph)%noofcs - lokcs=phlista(lokph)%linktocs(ijcs) -! one must also create parrecords for these !!! -! call create_parrecords(nydis,nnn,mmm,nprop,iva,firsteq) - call create_parrecords(lokph,nydis,nnn,mmm,maxcalcprop,iva,firsteq) - if(gx%bmperr.ne.0) goto 1000 - fsdata%varreslink=nydis -! set pointer also - fsdata%phdapointer=firsteq%phase_varres(nydis) - firsteq%phase_varres(nydis)%phlink=lokph - firsteq%phase_varres(nydis)%prefix=' ' - firsteq%phase_varres(nydis)%suffix=' ' - do ll=1,nnn - firsteq%phase_varres(nydis)%sites(ll)=fsdata%dsites(ll) - enddo - firsteq%phase_varres(nydis)%status2=0 - firsteq%phase_varres(nydis)%status2=& - ibset(firsteq%phase_varres(nyttcs)%status2,CSDFS) -! This does not create a new record -! firsteq%phase_varres(lokcs)%disfra=fsdata -! but this seems to work - call copy_fracset_record(lokcs,fsdata,firsteq) - if(gx%bmperr.ne.0) goto 1000 - firsteq%phase_varres(lokcs)%status2=& - ibset(firsteq%phase_varres(lokcs)%status2,CSDLNK) - goto 200 - enddo -! set status bit for multiple/disordered fraction sets and no of fraction sets - phlista(lokph)%status1=ibset(phlista(lokph)%status1,PHMFS) - phlista(lokph)%nooffs=2 -1000 continue - return -! nydis - end subroutine add_fraction_set - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine copy_fracset_record(lokcs,disrec,ceq) -! attempt to create a new disordered record ??? this can probably be done -! with just one statement .. but as it works I am not changing right now - implicit none - TYPE(gtp_equilibrium_data) :: ceq - TYPE(gtp_fraction_set) :: disrec - integer lokcs -!\end{verbatim} - TYPE(gtp_fraction_set) :: discopy -! the hard way ?? - discopy%fsites=disrec%fsites - discopy%latd=disrec%latd - discopy%ndd=disrec%ndd - discopy%tnoofxfr=disrec%tnoofxfr - discopy%tnoofyfr=disrec%tnoofyfr - discopy%varreslink=disrec%varreslink - discopy%phdapointer=>disrec%phdapointer - discopy%totdis=disrec%totdis - discopy%id=disrec%id - allocate(discopy%dsites(disrec%ndd)) - allocate(discopy%nooffr(disrec%ndd)) - allocate(discopy%splink(disrec%tnoofxfr)) - allocate(discopy%y2x(disrec%tnoofyfr)) - allocate(discopy%dxidyj(disrec%tnoofyfr)) -! - discopy%dsites=disrec%dsites - discopy%nooffr=disrec%nooffr - discopy%splink=disrec%splink - discopy%y2x=disrec%y2x - discopy%dxidyj=disrec%dxidyj -! -! write(*,*)'copyfs 1: ',lokcs,discopy%varreslink,disrec%varreslink - ceq%phase_varres(lokcs)%disfra=discopy -! write(*,*)'copyfs 2: ',phase_varres(lokcs)%disfra%varreslink -1000 continue - return - end subroutine copy_fracset_record - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine suspend_species_implicitly(ceq) -! loop through all entered species and suspend those with an element suspended - implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} %+ - integer loksp,iel,lokel - sploop: do loksp=1,noofsp - if(.not.btest(splista(loksp)%status,spsus)) then - elloop: do iel=1,splista(loksp)%noofel - lokel=splista(loksp)%ellinks(iel) - if(btest(ellista(lokel)%status,elsus)) then -! an element is suspended, suspend this species implicitly - splista(loksp)%status=ibset(splista(loksp)%status,spsus) - splista(loksp)%status=ibset(splista(loksp)%status,spimsus) - goto 200 - endif - enddo elloop - endif -200 continue - enddo sploop -1000 continue - return - end subroutine suspend_species_implicitly - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine suspend_phases_implicitly(ceq) -! loop through all entered phases and suspend constituents and -! SUSPEND phases with all constituents in a sublattice suspended -! dimension lokcs(9) - implicit none - TYPE(gtp_equilibrium_data) :: ceq -!\end{verbatim} %+ - integer lokph,lokcs,ncc,kk,kkl,nek,icon,ll,loksp,jl -! -! BEWARE not adopted fro parallel processing -! - phloop: do lokph=1,noofph - if(.not.btest(phlista(lokph)%status1,phhid)) then -! locate all composition sets and store indices in lokcs - ncc=phlista(lokph)%noofcs - kk=0 - sublloop: do ll=1,phlista(lokph)%noofsubl - kkl=kk - nek=0 - constloop: do icon=1,phlista(lokph)%nooffr(ll) - kk=kk+1 - loksp=phlista(lokph)%constitlist(kk) - if(btest(splista(loksp)%status,spsus)) then -! a constituent is suspended, mark this also in constat for all comp.sets - compsets: do jl=1,ncc - lokcs=phlista(lokph)%linktocs(jl) - ceq%phase_varres(lokcs)%constat(kk)=& - ibset(ceq%phase_varres(lokcs)%constat(kk),consus) - ceq%phase_varres(lokcs)%constat(kk)=& - ibset(ceq%phase_varres(lokcs)%constat(kk),conimsus) -! mark that some constituents are suspended in this composition set - ceq%phase_varres(lokcs)%status2=& - ibset(ceq%phase_varres(lokcs)%status2,CSCONSUS) - enddo compsets - goto 200 - else - nek=nek+1 - endif - enddo constloop - if(nek.eq.0) then -! this sublattice has all constituents suspended, hide/suspend the phase - phlista(lokph)%status1=ibset(phlista(lokph)%status1,phhid) - phlista(lokph)%status1=ibset(phlista(lokph)%status1,phimhid) -! also set amount to zero ?? - compsets2: do jl=1,ncc - lokcs=phlista(lokph)%linktocs(jl) -! ceq%phase_varres(lokcs)%amount=zero - ceq%phase_varres(lokcs)%amfu=zero - ceq%phase_varres(lokcs)%netcharge=zero - enddo compsets2 - endif - goto 300 -200 continue - kk=kkl+phlista(lokph)%nooffr(ll) - kkl=kk-1 - enddo sublloop -300 continue - endif - enddo phloop -1000 continue - return - end subroutine suspend_phases_implicitly - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine restore_species_implicitly_suspended -! loop through all implicitly suspended species and restore those with -! all elements enteded - implicit none -!\end{verbatim} %+ - integer loksp,lokel - sploop: do loksp=1,noofsp - if(btest(splista(loksp)%status,spimsus)) then - elloop: do lokel=1,splista(loksp)%noofel -! an element is suspended, keep species suspended - if(btest(ellista(lokel)%status,elsus)) goto 200 - enddo elloop -! all elements entered, restore species as entered - splista(loksp)%status=ibclr(splista(loksp)%status,spsus) - splista(loksp)%status=ibclr(splista(loksp)%status,spimsus) - endif -200 continue - enddo sploop -1000 continue - return - end subroutine restore_species_implicitly_suspended - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine restore_phases_implicitly_suspended -! loop through all implicitly suspended phases and restore those with -! at least one constituent entered in each sublattice - implicit none -!\end{verbatim} - integer lokph,ll,kk,kkl,icon,loksp - phloop: do lokph=1,noofph - if(btest(phlista(lokph)%status1,phimhid)) then - kk=0 - sublloop: do ll=1,phlista(lokph)%noofsubl - kkl=kk - constloop: do icon=1,phlista(lokph)%nooffr(ll) - kk=kk+1 - loksp=phlista(lokph)%constitlist(kk) - if(.not.btest(splista(loksp)%status,spsus)) goto 200 - enddo constloop -! all constituents in this sublattice are suspended, keep the phase hidden - goto 300 -200 continue - kk=kkl+phlista(lokph)%nooffr(ll) - kkl=kk-1 - enddo sublloop -! all sublattices have at least one constituent entered, restore it - phlista(lokph)%status1=ibclr(phlista(lokph)%status1,phhid) - phlista(lokph)%status1=ibclr(phlista(lokph)%status1,phimhid) -300 continue - endif - enddo phloop -1000 continue - return - end subroutine restore_phases_implicitly_suspended - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine add_to_reference_phase(loksp) -! add this element to the reference phase -! loksp: species index of new element - implicit none - integer loksp -!\end{verbatim} -! one must extend all arrays in phlista, phase_varres and phase_varres - integer lokph,noc,i,nprop,mc2,lokcs - integer, dimension(maxel) :: isave - lokph=0 - lokcs=phlista(lokph)%linktocs(1) -! constitlist - noc=phlista(lokph)%tnooffr - do i=1,noc - isave(i)=phlista(lokph)%constitlist(i) - enddo - deallocate(phlista(lokph)%constitlist) - noc=noc+1 - allocate(phlista(lokph)%constitlist(noc)) - isave(noc)=loksp - do i=1,noc - phlista(lokph)%constitlist(i)=isave(i) - enddo - phlista(lokph)%tnooffr=noc - phlista(lokph)%nooffr(1)=noc -! phase_varres, no data need saving -! write(*,*)'Deallocate constat 5: ',size(firsteq%phase_varres(lokcs)%constat) - deallocate(firsteq%phase_varres(lokcs)%constat) - deallocate(firsteq%phase_varres(lokcs)%yfr) - deallocate(firsteq%phase_varres(lokcs)%mmyfr) -! write(*,*)'Allocate constat 5: ',noc - allocate(firsteq%phase_varres(lokcs)%constat(noc)) - firsteq%phase_varres(lokcs)%constat(noc)=0 - allocate(firsteq%phase_varres(lokcs)%yfr(noc)) - allocate(firsteq%phase_varres(lokcs)%mmyfr(noc)) - firsteq%phase_varres(lokcs)%yfr=one - firsteq%phase_varres(lokcs)%mmyfr=zero - nprop=firsteq%phase_varres(lokcs)%nprop - deallocate(firsteq%phase_varres(lokcs)%dgval) - deallocate(firsteq%phase_varres(lokcs)%d2gval) - allocate(firsteq%phase_varres(lokcs)%dgval(3,noc,nprop)) - mc2=noc*(noc+1)/2 - allocate(firsteq%phase_varres(lokcs)%d2gval(mc2,nprop)) -! ready!! -1000 continue - return - end subroutine add_to_reference_phase - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatiom} - logical function ocv() -! returns TRUE if GSVERBOSE bit is set -!\end{verbatim} -! typical use: if(ocv()) write(*,*).... - ocv=btest(globaldata%status,GSVERBOSE) - return - end function ocv - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!-\begin{verbatim} - integer function vssize(varres) -! calculates the size in words (4 bytes) of a phase_varres record - implicit none - type(gtp_phase_varres) :: varres -!-\end{verbatim} - integer sum -! write(*,*)'In vssize 1' -! integer nextfree,phlink,status2,phstate -! double precision, dimension(2) :: abnorm -! character*4 prefix,suffix - sum=10 -! changed to allocatable -! integer, dimension(:), allocatable :: constat -! double precision, dimension(:), allocatable :: yfr -! real, dimension(:), allocatable :: mmyfr -! double precision, dimension(:), allocatable :: sites - if(allocated(varres%constat)) sum=sum+size(varres%constat) - if(allocated(varres%yfr)) sum=sum+3*size(varres%yfr) -! write(*,*)'In vssize 2',sum -! for ionic liquid derivatives of sites wrt fractions (it is the charge), -! 2nd derivates only when one constituent is vacancy -! 1st sublattice P=\sum_j (-v_j)*y_j + Qy_Va -! 2nd sublattice Q=\sum_i v_i*y_i -! double precision, dimension(:), allocatable :: dpqdy -! double precision, dimension(:), allocatable :: d2pqdvay - if(allocated(varres%dpqdy)) sum=sum+size(varres%dpqdy) - if(allocated(varres%d2pqdvay)) sum=sum+size(varres%d2pqdvay) -! write(*,*)'In vssize 3',sum -! for extra fraction sets, better to go via phase record index above -! this TYPE(gtp_fraction_set) variable is a bit messy. Declaring it in this -! way means the record is stored inside this record. -! type(gtp_fraction_set) :: disfra -! size of disfra record?? - sum=sum+10 - if(allocated(varres%disfra%dsites)) sum=sum+size(varres%disfra%dsites) - if(allocated(varres%disfra%nooffr)) sum=sum+size(varres%disfra%nooffr) - if(allocated(varres%disfra%splink)) sum=sum+size(varres%disfra%splink) - if(allocated(varres%disfra%y2x)) sum=sum+size(varres%disfra%y2x) - if(allocated(varres%disfra%dxidyj)) sum=sum+size(varres%disfra%dxidyj) -! write(*,*)'In vssize 4',sum -! It seems difficult to get the phdapointer in disfra record to work -! --- -! arrays for storing calculated results for each phase (composition set) -! amfu: is amount formula units of the composition set (calculated result) -! netcharge: is net charge of phase -! dgm: driving force (calculated result) -! amcom: not used -! damount: set to last change of phase amount in equilibrium calculations -! qqsave: values of qq calculated in set_constitution -! double precision amount(2),dgm,amcom,damount,qqsave(3) -! double precision amfu,netcharge,dgm,amcom,damount,qqsave(3) -! double precision amfu,netcharge,dgm,amcom,damount - sum=sum+10 -! Other properties may be that: gval(*,2) is TC, (*,3) is BMAG, see listprop -! nprop: the number of different properties (set in allocate) -! ncc: total number of site fractions (redundant but used in some subroutines) -! BEWHARE: ncc seems to be wrong using TQ test program fenitq.F90 ??? -! listprop(1): is number of calculated properties -! listprop(2:listprop(1)): identifies the property stored in gval(1,ipy) etc -! 2=TC, 3=BMAG. Properties defined in the gtp_propid record -! integer nprop,ncc -! integer, dimension(:), allocatable :: listprop - if(allocated(varres%listprop)) sum=sum+2+size(varres%listprop) -! write(*,*)'In vssize 5',sum -! gval etc are for all composition dependent properties, gval(*,1) for G -! gval(*,1): is G, G.T, G.P, G.T.T, G.T.P and G.P.P -! dgval(1,j,1): is first derivatives of G wrt fractions j -! dgval(2,j,1): is second derivatives of G wrt fractions j and T -! dgval(3,j,1): is second derivatives of G wrt fractions j and P -! d2gval(ixsym(i,j),1): is second derivatives of G wrt fractions i and j -! double precision, dimension(:,:), allocatable :: gval -! double precision, dimension(:,:,:), allocatable :: dgval -! double precision, dimension(:,:), allocatable :: d2gval - if(allocated(varres%gval)) sum=sum+2*size(varres%gval) - if(allocated(varres%dgval)) sum=sum+2*size(varres%dgval) - if(allocated(varres%d2gval)) sum=sum+2*size(varres%d2gval) -! write(*,*)'In vssize 6',sum -! added for strain/stress, current values of lattice parameters -! double precision, dimension(3,3) :: curlat -! saved values from last equilibrium calculation -! double precision, dimension(:,:), allocatable :: cinvy -! double precision, dimension(:), allocatable :: cxmol -! double precision, dimension(:,:), allocatable :: cdxmol - if(allocated(varres%cinvy)) sum=sum+18+2*size(varres%cinvy) - if(allocated(varres%cxmol)) sum=sum+18+2*size(varres%cxmol) - if(allocated(varres%cdxmol)) sum=sum+18+2*size(varres%cdxmol) -! -1000 continue - vssize=sum - return - end function vssize - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!-\begin{verbatim} - integer function ceqsize(ceq) -! calculates the size in words (4 bytes) of an equilibrium record - implicit none - type(gtp_equilibrium_data), pointer :: ceq -!-\end{verbatim} - integer sum,vsum,ivs,vss -! write(*,*)'In ceqsize 1' -! -! integer status,multiuse,eqno,next -! character eqname*24 -! double precision tpval(2),rtn -! svfunres: the values of state variable functions valid for this equilibrium -! double precision, dimension(:), allocatable :: svfunres - sum=18+2*size(ceq%svfunres) -! write(*,*)'In ceqsize 2',sum -! the experiments are used in assessments and stored like conditions -! lastcondition: link to condition list -! lastexperiment: link to experiment list -! TYPE(gtp_condition), pointer :: lastcondition,lastexperiment -! assuming a pointer is 4 bytes (2 words) - sum=sum+4 -! components and conversion matrix from components to elements -! complist: array with components -! compstoi: stoichiometric matrix of compoents relative to elements -! invcompstoi: inverted stoichiometric matrix -! TYPE(gtp_components), dimension(:), allocatable :: complist -! double precision, dimension(:,:), allocatable :: compstoi -! double precision, dimension(:,:), allocatable :: invcompstoi -! a gtp_component record is about 20 words, invcompstoi same as compsoti - if(allocated(ceq%complist)) sum=sum+20*size(ceq%complist)+& - 4*size(ceq%compstoi) -! write(*,*)'In ceqsize 3',sum -! one record for each phase+composition set that can be calculated -! phase_varres: here all calculated data for the phase is stored -! TYPE(gtp_phase_varres), dimension(:), allocatable :: phase_varres -! each phase_varres record is different for each phase - vsum=0 -! csfree is first free phase_varres record - do ivs=1,csfree - vss=vssize(ceq%phase_varres(ivs)) -! write(*,*)'Phase varres: ',ivs,vss - vsum=vsum+vss - enddo - sum=sum+vsum -! write(*,*)'In ceqsize 4',sum -! index to the tpfun_parres array is the same as in the global array tpres -! eq_tpres: here local calculated values of TP functions are stored -! TYPE(tpfun_parres), dimension(:), pointer :: eq_tpres -! each tpfun_parres record is 8 double - sum=sum+16*size(ceq%eq_tpres) -! current values of chemical potentials stored in component record but -! duplicated here for easy acces by application software -! double precision, dimension(:), allocatable :: cmuval - if(allocated(ceq%cmuval)) sum=sum+2*size(ceq%cmuval) -! xconc: convergence criteria for constituent fractions and other things -! double precision xconv -! delta-G value for merging gridpoints in grid minimizer -! smaller value creates problem for test step3.BMM, MC and austenite merged -! double precision :: gmindif=-5.0D-2 -! maxiter: maximum number of iterations allowed -! integer maxiter - sum=sum+5 -! this is to save a copy of the last calculated system matrix, needed -! to calculate dot derivatives, initiate to zero -! integer :: sysmatdim=0,nfixmu=0,nfixph=0 -! integer, allocatable :: fixmu(:) -! integer, allocatable :: fixph(:,:) -! double precision, allocatable :: savesysmat(:,:) - sum=sum+3+size(ceq%fixmu)+size(ceq%fixph)+size(ceq%savesysmat) -! these are normally not used any more -! sum=sum+size(ceq%fixmu)+size(ceq%fixph)+size(ceq%savesysmat) - ceqsize=sum -1000 continue - return - end function ceqsize - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - +! +! gtp3G included in gtp3.F90 +! +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ +!> 11. Status for things +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine change_element_status(elname,nystat,ceq) +! change the status of an element, can affect species and phase status +! nystat:0=entered, 1=suspended, -1 special (exclude from sum of mole fraction) +! +! suspending elements for each equilibrium separately not yet implemented +! + implicit none + character elname*(*) + integer nystat + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer iel,lokel + call find_element_by_name(elname,iel) + if(gx%bmperr.ne.0) goto 1000 + lokel=elements(iel) + if(btest(ellista(iel)%status,elsus)) then +! element already suspended, quit it should be suspended again .... + if(nystat.eq.1) goto 1000 +! element status should be changed from suspended to entered + ellista(iel)%status=ibclr(ellista(iel)%status,elsus) + call restore_species_implicitly_suspended + call restore_phases_implicitly_suspended + elseif(nystat.eq.1) then +! element should be changed from entered to suspended + ellista(iel)%status=ibset(ellista(iel)%status,elsus) + call suspend_species_implicitly(ceq) + call suspend_phases_implicitly(ceq) + endif +1000 continue + return + end subroutine change_element_status + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + logical function testelstat(iel,status) +! return value of element status bit + implicit none + integer iel,status +!\end{verbatim} + integer lokel + if(iel.gt.0 .and. iel.lt.noofel) then + lokel=elements(iel) + if(btest(ellista(lokel)%status,status)) then +! btest(iword,bit) .true. if bit set in iword +! iword=ibclr(iword,bit) to clear bit bit in iword +! iword=ibset(iword,bit) to set bit bit in iword + testelstat=.true. + else + testelstat=.false. + endif + else + gx%bmperr=4042 + endif + end function testelstat + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine change_species_status(spname,nystat,ceq) +! change the status of a species, can affect phase status +! nystat:0=entered, 1=suspended + implicit none + integer nystat + character spname*(*) + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer loksp + call find_species_record(spname,loksp) + if(gx%bmperr.ne.0) goto 1000 + if(btest(splista(loksp)%status,spsus)) then +! species already suspended, quit if it should be suspended again .... + if(nystat.eq.1) goto 1000 +! restore the species (and phases) unless implicitly suspended + if(btest(splista(loksp)%status,spimsus)) then +! species cannot be entered as it is implicitly suspended (some element susp) + gx%bmperr=4085; goto 1000 + endif + splista(loksp)%status=ibclr(splista(loksp)%status,spsus) + call restore_phases_implicitly_suspended + elseif(nystat.eq.1) then +! suspend the species and possibly some phases + splista(loksp)%status=ibset(splista(loksp)%status,spsus) + call suspend_phases_implicitly(ceq) + endif +1000 continue + return + end subroutine change_species_status + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + logical function testspstat(isp,status) +! return value of species status bit + implicit none + integer isp,status +!\end{verbatim} + integer loksp + if(isp.gt.0 .and. isp.le.noofsp) then + loksp=species(isp) + if(btest(splista(loksp)%status,status)) then +! btest(iword,bit) .true. if bit set in iword +! iword=ibclr(iword,bit) to clear bit bit in iword +! iword=ibset(iword,bit) to set bit bit in iword + testspstat=.true. + else + testspstat=.false. + endif + else + gx%bmperr=4051 + endif + end function testspstat + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + integer function get_phase_status(iph,ics,text,ip,val,ceq) +! return phase status as text and amount formula units in val +! for entered and fix phases also phase amounts. +! OLD Function value: 1=entered, 2=fix, 3=dormant, 4=suspended, 5=hidden + implicit none + character text*(*) + integer iph,ics,ip + TYPE(gtp_equilibrium_data), pointer :: ceq + double precision val +!\end{verbatim} %+ + integer ists,lokph,lokcs,j +! write current status + ists=0 + val=-one + if(iph.gt.0 .and. iph.le.noph()) then + call get_phase_compset(iph,ics,lokph,lokcs) +!old if(btest(phlista(lokph)%status1,phhid)) then +!old text='HIDDEN'; ip=6 +!old ists=5 +!old elseif(btest(ceq%phase_varres(lokcs)%status2,CSSUS)) then +! entered, fix, suspended, dormant +! bit setting: 00 01 , 10 11 +!old if(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then +!old text='DORMANT'; ip=7 +!old ists=3 +!old else +!old text='SUSPENDED'; ip=9 +!old ists=4 +!old endif +!old elseif(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then +!old text='FIXED'; ip=5 +! val=ceq%phase_varres(lokcs)%amount(1) +!old val=ceq%phase_varres(lokcs)%amfu +!old ists=2 +!old else +!old text='ENTERED'; ip=7 +!old val=ceq%phase_varres(lokcs)%amfu +!old ists=1 +!old endif +! new way, test PHSTATE + j=ceq%phase_varres(lokcs)%phstate +!z if(j.lt.-4 .or. j.gt.2) then +! I had an erroor here when plotting map2 macro because after the second +! map command I had 2 liquid compsets and during the first mapping I had +! only one liquid so I think +!z ip=j +!z j=0 +!z if(btest(ceq%phase_varres(lokcs)%status2,CSSUS)) then +!z if(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then +!z j=-2 +!z else ! suspended +!z j=3 +!z endif +!z elseif(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then +! fix +!z j=2 +!z else ! entered +!z j=0 +!z endif +! save this status .... ??? +!z write(*,16)'3G PHSTATE wrong, fixing ...',iph,ics,j,ip,& +!z ceq%phase_varres(lokcs)%status2 +!z ceq%phase_varres(lokcs)%phstate=j +!z endif + select case(j) + case default + write(*,16)'3G: PHSTATE not correct: ',iph,ics,j,ip,& + ceq%phase_varres(lokcs)%status2 +16 format(a,4i3,2x,z16) + gx%bmperr=7777 + case(phfixed) ! fix 2 + text='FIXED' + ip=5 + val=ceq%phase_varres(lokcs)%amfu + ists=phfixed + case(-1,0,1) ! entered (unstable, unknown, stable) + text='ENTERED' + ip=7 + val=ceq%phase_varres(lokcs)%amfu + ists=phentered + case(phdorm) ! dormant -2 + text='DORMANT' + ip=7 + ists=phdorm + case(phsus) ! suspended -3 + text='SUSPENDED' + ip=9 + ists=phsus + case(phhidden) ! hidden -4 + text='HIDDEN' + ip=6 + ists=phhidden + end select + else +! write(*,*)'No such phase' + gx%bmperr=4050; goto 1000 + endif + get_phase_status=ists +! write(*,*)'3G: PHSTAT value: ',ists +! write(*,*)'3G: gps: ',ip +1000 continue + return + end function get_phase_status + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + integer function test_phase_status(iph,ics,val,ceq) +! Almost same as get_..., returns phase status as function value but no text +! old: 1=entered, 2=fix, 3=dormant, 4=suspended, 5=hidden +! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix +! this is different from in change_phase .... one has to make up one's mind + implicit none + TYPE(gtp_equilibrium_data), pointer :: ceq + integer iph,ics + double precision val +!\end{verbatim} + integer ists,lokph,lokcs,j,ip + character text*24 +! new code + call get_phase_compset(iph,ics,lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 + ists=ceq%phase_varres(lokcs)%phstate + val=ceq%phase_varres(lokcs)%amfu + goto 900 +!============================================= + ists=0 + ip=1 + val=-one + ists=get_phase_status(iph,ics,text,ip,val,ceq) + goto 900 +!------------------ + if(iph.gt.0 .and. iph.le.noph()) then + call get_phase_compset(iph,ics,lokph,lokcs) +! biet set means false .... +!z if(btest(phlista(lokph)%status1,phhid)) then +! hidden +!z ists=5 +!z elseif(btest(ceq%phase_varres(lokcs)%status2,CSSUS)) then +! entered, fix, suspended, dormant +! bit setting: 00 01 , 10 11 +!z if(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then +!z ists=3 +!z else +!z ists=4 +!z endif +!z elseif(btest(ceq%phase_varres(lokcs)%status2,CSFIXDORM)) then +!z val=ceq%phase_varres(lokcs)%amfu +!z ists=2 +!z else +!z ists=1 +!z val=ceq%phase_varres(lokcs)%amfu +!z endif +! new way, test PHSTATE + j=ceq%phase_varres(lokcs)%phstate + select case(ceq%phase_varres(lokcs)%phstate) + case default + write(*,*)'PHSTAT outside range -4:2: ',j + case(phfixed) ! fix +2 + if(ists.ne.2) write(*,*)'wrong PHSTAT',ists,j + case(-1,0,1) ! entered (unstable, unknown, stable) + if(ists.ne.1) write(*,*)'wrong PHSTAT',ists,j + case(phdorm) ! dormant -2 + if(ists.ne.3) write(*,*)'wrong PHSTAT',ists,j + case(phsus) ! suspended -3 + if(ists.ne.4) write(*,*)'wrong PHSTAT',ists,j + case(phhidden) ! hidden -4 + if(ists.ne.5) write(*,*)'wrong PHSTAT',ists,j + end select + else +! write(*,*)'No such phase' + gx%bmperr=4050; goto 1000 + endif +900 continue + test_phase_status=ists +1000 continue + return + end function test_phase_status + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine set_phase_status_bit(lokph,bit) +! set the status bit "bit" in status1, cannot be done outside this module +! as the phlista is private +! These bits do not depend on the composition set + implicit none + integer lokph,bit +!\end{verbatim} %+ + integer lokcs,j + if(bit.lt.0 .or. bit.gt.31) then + write(*,*)'Illegal phase bit number' + gx%bmperr=7777; goto 1000 + elseif(lokph.le.0 .or. lokph.gt.noofph) then + write(*,*)'Illegal phase in call to set_phase_status_bit' + gx%bmperr=7777; goto 1000 + endif +! write(*,99)'sphs1bit: ',lokph,bit,phlista(lokph)%status1 +99 format(a,2i3,z8) + phlista(lokph)%status1=ibset(phlista(lokph)%status1,bit) + if(bit.eq.PHHID) then +! if bit is PHHID, i.e. hidden, set PHSTATE in all phase_varres record to -4 + do j=1,phlista(lokph)%noofcs + lokcs=phlista(lokph)%linktocs(j) +! eventually, this must be set in all equilibrium records now just firsteq ?? + firsteq%phase_varres(lokcs)%phstate=-4 + enddo + endif +1000 continue + return + end subroutine set_phase_status_bit + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + subroutine clear_phase_status_bit(lokph,bit) +! clear the status bit "bit" in status1, cannot be done outside this module +! as the phlista is private + implicit none + integer lokph,bit +!\end{verbatim} %+ + integer lokcs,j + if(bit.lt.0 .or. bit.gt.31) then + write(*,*)'Illegal phase bit number' + gx%bmperr=7777; goto 1000 + endif + phlista(lokph)%status1=ibclr(phlista(lokph)%status1,bit) + if(bit.eq.PHHID) then + write(*,*)'clear_bit: Not implemented to change PHSTATE' +! if bit is PHHID, i.e. hidden, set PHSTATE in all phase_varres record to 0 + do j=1,phlista(lokph)%noofcs + lokcs=phlista(lokph)%linktocs(j) +! eventually, this must be set in all equilibrium records now just firsteq ?? + firsteq%phase_varres(lokcs)%phstate=phentered + enddo + endif +1000 continue + return + end subroutine clear_phase_status_bit + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} %- + logical function test_phase_status_bit(iph,ibit) +! return TRUE is status bit ibit for phase iph, is set +! because phlista is private. Needed to test for gas, ideal etc, +! DOES NOT TEST STATUS like entered/fixed/dormant/suspended + implicit none + integer iph,ibit +!\end{verbatim} + integer lokph + if(iph.gt.0 .and. iph.le.noofph) then + lokph=phases(iph) + else + gx%bmperr=4050; goto 1000 + endif + if(btest(phlista(lokph)%status1,ibit)) then + test_phase_status_bit=.true. + else + test_phase_status_bit=.false. + endif +1000 continue + return + end function test_phase_status_bit + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine change_many_phase_status(phnames,nystat,val,ceq) +! change the status of many phases. +! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix +! phnames is a list of phase names or *S (all suspeded) *D (all dormant) or +! *E (all entered (stable, unknown, unstable), *U all unstable +! If just * then change_phase_status is called directly +! It calls change_phase_status for each phase + implicit none + character phnames*(*) + integer nystat + double precision val + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} %+ + integer qph,ics,oldstat,ipos,slen,lokph,lokcs + character name*24 + if(phnames(1:1).eq.'*') then + if(phnames(2:2).eq.'S') then + oldstat=-3 + elseif(phnames(2:2).eq.'D') then + oldstat=-2 + elseif(phnames(2:2).eq.'E') then +! all entered (stable, unstable, unknown) + oldstat=0 + elseif(phnames(2:2).eq.'U') then +! all unstable phases + oldstat=1 + elseif(phnames(2:2).eq.' ') then + qph=-1 + call change_phase_status(qph,ics,nystat,val,ceq) + goto 1000 + else + write(*,*)'No such selection of phase status after *' + gx%bmperr=7222; goto 1000 + endif +! loop for all phases to find those with correct old status + do qph=1,noofph +! we cannot loop for ics as we do not know lokph + ics=1 + call get_phase_compset(qph,ics,lokph,lokcs) +200 continue +! stable phases has ceq%phase_varres(lokcs)%phstate = 1 + ipos=oldstat-ceq%phase_varres(lokcs)%phstate +! write(*,*)'3G entered: ',qph,ics,oldstat,ipos + if((oldstat.ne.1 .and. ipos.eq.0) .or. & + (oldstat.eq.0 .and. abs(ipos).eq.1) .or.& + (oldstat.eq.1 .and. abs(ipos).gt.0)) then +! this comp.set has correct old phase status + call change_phase_status(qph,ics,nystat,val,ceq) + if(gx%bmperr.ne.0) goto 1000 + endif +! take next composition set if any, else next phase + if(ics.lt.phlista(lokph)%noofcs) then + ics=ics+1 + lokcs=phlista(lokph)%linktocs(ics) + goto 200 + endif + enddo + else +! we have one or more specific phase names separated by space or comma +! ipos is updated inside getext, The 3rd argument of getext is JTYP +! JTYP DEFINES THE TERMINATION OF A STRING +! 1 TEXT TERMINATED BY SPACE OR "," +! 2 TEXT TERMINATED BY SPACE +! 3 TEXT TERMINATED BY ";" OR "." +! 4 TEXT TERMINATED BY ";" +! 5 TEXT UP TO END-OF-LINE +! 6 TEXT UP TO AND INCLUDING ";" +! >31, THE CHAR(JTYP) IS USED AS TERMINATING CHARACTER + ipos=0 +500 continue + call getext(phnames,ipos,1,name,' ',slen) +! write(*,*)'3G phase1: ',slen,' ',name + if(name(1:1).eq.' ') goto 1000 +! write(*,*)'3G phase2: ',name + call find_phase_by_name(name,qph,ics) + if(gx%bmperr.ne.0) then + write(*,*)'No phase called "',name(1:len_trim(name)),'"' + gx%bmperr=0 + else + call change_phase_status(qph,ics,nystat,val,ceq) + if(gx%bmperr.ne.0) goto 1000 + endif + goto 500 + endif +1000 continue + return + end subroutine change_many_phase_status + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} %- + subroutine change_phase_status(qph,ics,nystat,val,ceq) +! change the status of a phase. Also used when setting phase fix etc. +! old: 0=entered, 1=suspended, 2=dormant, 3=fix, 4=hidden,5=not hidden +! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix +! qph can be -1 meaning all or a specifix phase index. ics compset +! + implicit none + integer qph,ics,nystat + double precision val + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} %+ + integer lokph,lokcs,iph,ip,mcs + character line*80,phname*32 +! write(*,11)'3G in change_phase_status: ',qph,ics,nystat,val +11 format(a,3i5,1pe14.6) + if(qph.eq.-1) then +! this means all phases. All phases cannot be set fix + if(nystat.eq.3) then + gx%bmperr=4152; goto 1000 + endif + iph=1 + ics=1 + else +! a specific phase + iph=qph + endif +! return here for next phase +100 continue + call get_phase_compset(iph,ics,lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 +! write(*,*)'3G: Phase and status: ',iph,ceq%phase_varres(lokcs)%phstate + if(ceq%phase_varres(lokcs)%phstate.eq.phfixed) then +! this phase and composition set is fix, remove condition +! unless the new status is also FIX + if(nystat.ne.phfixed) then + call get_phase_name(iph,ics,phname) + line=' NOFIX='//phname(1:len_trim(phname)) + ip=1 +! write(*,*)'Remove fix phase: ',line(1:len_trim(line)) + call set_condition(line,ip,ceq) + if(gx%bmperr.ne.0) then +! write(*,*)'Failed to remove fix phase as condition' + goto 1000 + endif + endif + endif + bigif: if(ceq%phase_varres(lokcs)%phstate.eq.phhidden) then +! phase is hidden, quit if it should be hidden again +! bigif: if(btest(phlista(lokph)%status1,phhid)) then + if(nystat.eq.phhidden) goto 900 +! phlista(lokph)%status1=ibclr(phlista(lokph)%status1,phhid) +!??? this phase must be added in phlista ??? no it is already there ??? + write(*,*)'Unifished handling of hide/not hide ...' + gx%bmperr=4095; goto 900 + elseif(nystat.eq.phhidden) then +! phase is not hidden but should be set as hidden, +! Always applies to all composition sets +! clear all entered/suspended/dormant/fix for all composition sets + phlista(lokph)%status1=ibset(phlista(lokph)%status1,phhid) + do mcs=1,phlista(lokph)%noofcs + lokcs=phlista(lokph)%linktocs(mcs) + ceq%phase_varres(lokcs)%phstate=phhidden +! also set amounts and dgm to zero + ceq%phase_varres(lokcs)%amfu=zero + ceq%phase_varres(lokcs)%netcharge=zero + ceq%phase_varres(lokcs)%dgm=zero + enddo + else !bigif + lokcs=phlista(lokph)%linktocs(ics) +! changing FIX/ENTERED/SUSPENDED/DORMANT for a composition set +! input nystat:0=entered, 3=fix, 1=suspended, 2=dormant +! bit setting: 00 01 , 10 11 +! write(*,71)'3G new status: ',iph,ics,lokph,lokcs,nystat,phentered,val +71 format(a,6i5,1pe14.6) + if(nystat.eq.phentered .or. nystat.eq.phentunst .or. & + nystat.eq.phentstab) then +! set enterered with amount val and dgm zero +! write(*,*)'Setting phase as entered',nystat +! ceq%phase_varres(lokcs)%phstate=phentered + ceq%phase_varres(lokcs)%phstate=nystat +! remove use of status bits +!z ceq%phase_varres(lokcs)%status2=& +!z ibclr(ceq%phase_varres(lokcs)%status2,CSSUS) +!z ceq%phase_varres(lokcs)%status2=& +!z ibclr(ceq%phase_varres(lokcs)%status2,CSFIXDORM) +! ceq%phase_varres(lokcs)%amount=val + ceq%phase_varres(lokcs)%amfu=val + ceq%phase_varres(lokcs)%netcharge=zero + ceq%phase_varres(lokcs)%dgm=zero + elseif(nystat.eq.phsus) then +! set suspended with amount and dgm zero + ceq%phase_varres(lokcs)%phstate=phsus +!z ceq%phase_varres(lokcs)%status2=& +!z ibset(ceq%phase_varres(lokcs)%status2,CSSUS) +!z ceq%phase_varres(lokcs)%status2=& +!z ibclr(ceq%phase_varres(lokcs)%status2,CSFIXDORM) +!z ceq%phase_varres(lokcs)%status2=& +!z ibclr(ceq%phase_varres(lokcs)%status2,CSSTABLE) +! ceq%phase_varres(lokcs)%amount=zero + ceq%phase_varres(lokcs)%amfu=zero + ceq%phase_varres(lokcs)%netcharge=zero + ceq%phase_varres(lokcs)%dgm=zero + elseif(nystat.eq.phdorm) then +! set dormant with amount and dgm zero + ceq%phase_varres(lokcs)%phstate=phdorm +!z ceq%phase_varres(lokcs)%status2=& +!z ibset(ceq%phase_varres(lokcs)%status2,CSSUS) +!z ceq%phase_varres(lokcs)%status2=& +!z ibset(ceq%phase_varres(lokcs)%status2,CSFIXDORM) +!z ceq%phase_varres(lokcs)%status2=& +!z ibclr(ceq%phase_varres(lokcs)%status2,CSSTABLE) + ceq%phase_varres(lokcs)%amfu=zero + ceq%phase_varres(lokcs)%netcharge=zero + ceq%phase_varres(lokcs)%dgm=zero + elseif(nystat.eq.phfixed) then +! set fix with amount val +! write(*,*)'Setting phase as fix' + ceq%phase_varres(lokcs)%phstate=phfixed +!z ceq%phase_varres(lokcs)%status2=& +!z ibclr(ceq%phase_varres(lokcs)%status2,CSSUS) +!z ceq%phase_varres(lokcs)%status2=& +!z ibset(ceq%phase_varres(lokcs)%status2,CSFIXDORM) + ceq%phase_varres(lokcs)%amfu=val + ceq%phase_varres(lokcs)%netcharge=zero + ceq%phase_varres(lokcs)%dgm=zero +! also set as condition + call get_phase_name(iph,ics,phname) + line=' FIX='//phname(1:len_trim(phname))//' ==' + ip=len_trim(line)+2 + call wrinum(line,ip,6,0,val) + if(buperr.ne.0) goto 1000 + ip=1 +! write(*,*)'phase fix condition: ',line(1:40) + call set_condition(line,ip,ceq) + endif + endif bigif +900 continue +! check if loop + if(qph.eq.-1) then + lokph=phases(iph) + if(ics.lt.phlista(lokph)%noofcs) then + ics=ics+1 + elseif(iph.lt.noofph) then + iph=iph+1 + ics=1 + else + goto 1000 + endif + goto 100 + endif +1000 continue +! write(*,*)'error code: ',gx%bmperr + return + end subroutine change_phase_status + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} &- + subroutine mark_stable_phase(iph,ics,ceq) +! change the status of a phase. Does not change fix status +! called from meq_sameset to indicate stable phases (nystat=1) +! nystat:-4 hidden, -3 suspended, -2 dormant, -1,0,1 entered, 2 fix +! + implicit none + integer iph,ics + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer lokph,lokcs +! write(*,11)'3G mark as stable: ',iph,ics,phentstab +11 format(a,3i5,1pe14.6) + call get_phase_compset(iph,ics,lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 +! write(*,*)'3G: Phase and status: ',iph,ceq%phase_varres(lokcs)%phstate + if(ceq%phase_varres(lokcs)%phstate.eq.phhidden) then + write(*,*)'Error calling mark_stable for hidden phase' + gx%bmperr=4095; goto 1000 + elseif(ceq%phase_varres(lokcs)%phstate.le.phdorm) then + write(*,*)'Cannot make suspended or doremant phases as stable' + gx%bmperr=4095; goto 1000 + elseif(ceq%phase_varres(lokcs)%phstate.eq.phfixed) then +! do nothing + goto 1000 + else + ceq%phase_varres(lokcs)%phstate=phentstab + endif +1000 continue +! write(*,*)'error code: ',gx%bmperr + return + end subroutine mark_stable_phase + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ +!> 12. Unfinished things +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine set_unit(property,unit) +! set the unit for a property, like K, F or C for temperature +! >>>> unfinished + implicit none + character*(*) property,unit +!\end{verbatim} + write(*,*)'Not implemented yet' + gx%bmperr=7777 +1000 continue + return + end subroutine set_unit + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine save_results(lut,iph,ics,long) +! write calculated results for a phase for later use in POST + implicit none + integer lut,iph,ics,long +!\end{verbatim} + write(*,*)'Not implemented yet' + gx%bmperr=7777 +! header with abbreviations +! call list_abbrev(lut) +! first conditions ... +! call list_conditions(lut) +! Global values of G, N, V etc +! call list_global_results(lut) +! Element data +! call list_components_results(lut) +! Phases and composition sets +! call dump_phase_results(lut) +1000 return + end subroutine save_results + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine set_constituent_reference_state(iph,icon,asum) +! determine the end member to calculate as reference state for this constituent +! Used when giving a chemical potential for a constituent like MU(GAS,H2O) + implicit none + integer iph,icon + double precision asum +!\end{verbatim} + type(gtp_endmember), pointer :: endmemrec + integer lokph,nsl,ll,jcon,loksp,loksp2,lokcs +! + lokph=phases(iph) + loksp=phlista(lokph)%constitlist(icon) + nsl=phlista(lokph)%noofsubl + endmemrec=>phlista(lokph)%ordered + asum=one + lokcs=phlista(lokph)%linktocs(1) + if(nsl.eq.1) then + asum=firsteq%phase_varres(lokcs)%sites(1) + emlist1: do while(associated(endmemrec)) + if(endmemrec%fraclinks(nsl,1).eq.icon) goto 300 + endmemrec=>endmemrec%nextem + enddo emlist1 + else +! several sublattices OK if same species or vacancies in other sublattices + asum=zero + emlist2: do while(associated(endmemrec)) + do ll=1,nsl + jcon=endmemrec%fraclinks(ll,1) + if(jcon.ne.icon) then + loksp2=phlista(lokph)%constitlist(jcon) + if(loksp2.eq.loksp) then +! same species in this sublattice, add sites to asum + asum=asum+firsteq%phase_varres(lokcs)%sites(ll) + elseif(.not.btest(splista(loksp2)%status,spva)) then +! other species (not vacancies) in this sublattice, skip this end member + goto 200 + endif + else + asum=asum+firsteq%phase_varres(lokcs)%sites(ll) + endif + enddo +! this endmember OK + goto 300 +! not this end member +200 continue + endmemrec=>endmemrec%nextem + enddo emlist2 + endif +! this phase cannot exist for species icon as pure + gx%bmperr=4112; goto 1000 +300 continue +1000 continue + return + end subroutine set_constituent_reference_state + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine elements2components(nspel,stoi,ncmp,cmpstoi,ceq) +! converts a stoichiometry array for a species from elements to components + implicit none + integer nspel,ncmp + double precision stoi(*),cmpstoi(*) + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + double precision, parameter :: small=1.0d-30 + integer ic,jc,ns +! use the ceq%complist(ic)%invcompstoi + do ic=1,noofel + cmpstoi(ic)=zero + enddo +! not sure about the indices here .... ???? +! write(*,*)'e2c: ',noofel,nspel,stoi(1),ceq%invcompstoi(1,1) + do ic=1,noofel + do jc=1,nspel + cmpstoi(ic)=cmpstoi(ic)+ceq%invcompstoi(ic,jc)*stoi(jc) + enddo + enddo + ncmp=0 + ic=0 + ns=0 +200 continue + ic=ic+1 + if(ic.lt.noofel) then + if(abs(cmpstoi(ic)).lt.small) then + do jc=ic,noofel + cmpstoi(jc)=cmpstoi(jc+1) + enddo + else + ncmp=ncmp+1 +! write(*,*)'c2c1: ',ic,ncmp + endif + goto 200 + elseif(abs(cmpstoi(ic)).gt.small) then +! write(*,*)'c2c2: ',ic,ncmp,cmpstoi(ic) + ncmp=ncmp+1 + endif +! write(*,190)ic,(cmpstoi(i),i=1,ncmp) +!190 format('e2c3: ',i3,10F7.3) +1000 continue + return + end subroutine elements2components + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\! +!> 13. Internal stuff +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine alphaelorder +! arrange new element in alphabetical order +! also make alphaindex give alphabetical order + implicit none +!\end{verbatim} %+ + character symb1*2 + integer i,j + symb1=ellista(noofel)%symbol +! write(6,*)'alphaelorder 1: ',symb1,noofel + loop1: do i=1,noofel-1 + if(symb1.lt.ellista(elements(i))%symbol) then + loop2: do j=noofel,i+1,-1 + elements(j)=elements(j-1) + ellista(elements(j))%alphaindex=j + enddo loop2 +! write(6,*)'alphaelorder 3: ',i + elements(i)=noofel + ellista(elements(i))%alphaindex=i + exit + endif + enddo loop1 +! write(6,*)'alphaelorder 4: ',(elements(k),k=1,noofel) + END subroutine alphaelorder + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine alphasporder +! arrange new species in alphabetical order +! also make alphaindex give alphabetical order + implicit none +!\end{verbatim} %+ + character symb1*24 + integer i,j + symb1=splista(noofsp)%symbol +! write(6,*)'alphasporder 1: ',symb1(1:6),noofsp + loop1: do i=1,noofsp-1 + if(symb1.lt.splista(species(i))%symbol) then +! write(6,*)'alphasporder 2; ',symb1,splista(species(i))%symbol + loop2: do j=noofsp,i+1,-1 + species(j)=species(j-1) + splista(species(j))%alphaindex=j + enddo loop2 + species(i)=noofsp +! write(6,*)'alphasporder 3:',i + splista(species(i))%alphaindex=i + exit + endif + enddo loop1 +! write(6,*)'alphasporder 4: ',(species(k),k=1,noofsp) + END subroutine alphasporder + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine alphaphorder(tuple) +! arrange last added phase in alphabetical order +! also make alphaindex give alphabetical order +! phletter G and L and I have priority +! tuple is returned as position in phase tuple + implicit none + integer tuple +!\end{verbatim} + character symb1*24,ch1*1,ch2*1 + integer iph,lokph,j,lokcs +! + symb1=phlista(noofph)%name + ch1=phlista(noofph)%phletter +! one more phase in "phases" array + phases(noofph)=noofph +! write(6,75)'alphaphorder 1: ',noofph,ch1,symb1(1:6) +!75 format(A,I3,1x,A,1x,A) + loop1: do iph=1,noofph-1 + lokph=phases(iph) + ch2=phlista(lokph)%phletter +! write(6,76)'alphaphorder 2A: ',iph,lokph,ch1,ch2 +76 format(A,2I3,1x,A,1x,A) +! phaseletter different, if ch1=G insert it here + if(ch1.eq.'G') goto 300 + if(ch2.eq.'G') goto 200 + liquid: if(ch1.eq.'L') then + if(ch2.eq.'G') goto 200 + if(ch2.eq.'L') goto 100 + goto 300 + endif liquid + if(ch2.eq.'L') goto 200 + solution: if(ch1.eq.'S') then + if(ch2.eq.'G' .or. ch2.eq.'L') goto 200 + if(ch2.eq.'S') goto 100 + goto 300 + endif solution + if(ch2.eq.'S') goto 200 + compound: if(ch1.eq.'C') then + if(ch2.eq.'C') goto 100 + goto 200 + endif compound +! here phletter of lokph and the new phase are the same +100 continue +! write(6,*)'alphaphorder 2B: ',symb1,phlista(lokph)%name + if(symb1.lt.phlista(lokph)%name) goto 300 +200 continue + enddo loop1 +! exit loop, add new phase last +! lokph=phases(noofph) + iph=phases(noofph) +300 continue +! write(*,*)'3G new phase position: ',iph +! write(6,77)'alphaphorder 2C: ',iph,lokph,phlista(lokph)%name +!77 format(A,2I3,1X,A) +! insert phase here at iph, shift down trailing phase indices +! also OK if new phase should be last + loop2: do j=noofph,iph+1,-1 +! update index of trailing phases, loop from the end not to overwrite + phases(j)=phases(j-1) + phlista(phases(j))%alphaindex=j + enddo loop2 +! index of new phase +! write(6,*)'alphaphorder 4: ',lokph,iph,noofph + phases(iph)=noofph + phlista(noofph)%alphaindex=iph +! write(6,*)'alphaphorder 3: ',iph,(phases(k),k=1,noofph) +! update phasetuple array +! write(*,*)'3G New phase alphabetic order: ',iph + do j=nooftuples,iph,-1 + phasetuple(j+1)%phase=phasetuple(j)%phase + phasetuple(j+1)%compset=phasetuple(j)%compset +! we must also change the tuple index in phase_varres!! + lokcs=phlista(phasetuple(j)%phase)%linktocs(1) + firsteq%phase_varres(lokcs)%phtupx=j+1 +! write(*,777)'3G shifted phase in phasetuple',& +! phasetuple(j)%phase,lokcs,j+1 + enddo +! insert the first compset of new phase in phasetuple position iph + phasetuple(iph)%phase=noofph + phasetuple(iph)%compset=1 + nooftuples=nooftuples+1 + tuple=iph +! write(*,771)(phasetuple(j)%phase,phasetuple(j)%compset,j=1,nooftuples) +771 format('3G: ',10(2i3,1x)) +! link to first compset set when phase_varres record connected +! write(*,777)'3G phase tuple position: ',iph,noofph,lokph,lokcs,tuple +777 format(a,10i5) + return + END subroutine alphaphorder + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine check_alphaindex +! just for debugging, check that ellist(i)%alphaindex etc is correct + implicit none +!\end{verbatim} + integer i,j,k,l + write(kou,*) + write(6,77)(ellista(elements(i))%symbol,i=1,noofel) +77 format(20(1x,A2)) + write(6,78)(splista(species(i))%symbol,i=1,noofsp) +78 format(20(1x,a6)) + write(6,*)'element alphaindex' + check1: do i=1,noofel + j=ellista(elements(i))%alphaindex + write(6,*)i,j,elements(i),ellista(i)%symbol + enddo check1 + write(6,*)'species alphaindex' + check2: do i=1,noofsp + j=species(i) + k=splista(j)%alphaindex + l=splista(species(j))%alphaindex + write(6,79)i,k,j,l,splista(j)%symbol + enddo check2 +79 format(4i4,1x,A) + check3: do i=1,noofsp + write(6,*)i,splista(i)%alphaindex,splista(i)%symbol + enddo check3 + END subroutine check_alphaindex + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine create_constitlist(constitlist,nc,klist) +! creates a constituent list ... + implicit none + integer, dimension(*) :: klist + integer, dimension(:), allocatable :: constitlist + integer nc +!\end{verbatim} + integer ic + ALLOCATE(constitlist(nc)) + DO ic=1,nc + constitlist(ic)=klist(ic) + enddo + return + END subroutine create_constitlist + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine create_parrecords(lokph,lokcs,nsl,nc,nprop,iva,ceq) +! fractions and results arrays for a phase for parallell calculations +! location is returned in lokcs +! nsl is sublattices, nc number of constituents, nprop max number if propert, +! iva is an array which is set as constituent status word (to indicate VA) +! ceq is always firsteq ??? +! +! BEWARE not adopted for threads +! +! >>> changed all firsteq below to ceq???? +! + implicit none + TYPE(gtp_equilibrium_data), pointer :: ceq + integer, dimension(*) :: iva + integer lokph,lokcs, nsl, nc, nprop +!\end{verbatim} + integer ic,nnc +! find free record, free list maintained in FIRSTEQ +! write(*,*)'3G maxcalcprop: ',nprop + lokcs=csfree + if(csfree.le.0) then +! This means no free phase_varres records. +! csfree is set to -1 by the statement csfree=phase_varres(lokcs)%next below +! when reserving the last free record. The same for the other free lists + gx%bmperr=4094; goto 1000 + endif +! the free list of phase_varres record only maintained in firsteq +! all equilibria have identical allocation of phase_varres records +! write(*,*)'3G allocating varres record ',lokcs + csfree=firsteq%phase_varres(lokcs)%nextfree + if(csfree.gt.highcs) highcs=csfree + firsteq%phase_varres(lokcs)%nextfree=0 + firsteq%phase_varres(lokcs)%status2=0 +! added integer status array constat. Set CONVA bit from iva array +! write(*,*)'Allocate constat 2: ',nc,lokcs + if(.not.allocated(ceq%phase_varres(lokcs)%constat)) then +! already allocated error for the Al-Ni case, why? +! Maybe if composition set has been deleted without releasing allocated arrays? + allocate(ceq%phase_varres(lokcs)%constat(nc)) + endif +! write(*,33)nc,(iva(i),i=1,nc) + do ic=1,nc + ceq%phase_varres(lokcs)%constat(ic)=iva(ic) + enddo +! allocate fraction and default fraction arrays + allocate(ceq%phase_varres(lokcs)%yfr(nc)) + allocate(ceq%phase_varres(lokcs)%mmyfr(nc)) + do ic=1,nc + ceq%phase_varres(lokcs)%yfr(ic)=one + ceq%phase_varres(lokcs)%mmyfr(ic)=zero + enddo +! write(*,*)'Allocated mmyfr: ',lokcs,nc,nprop +! abnorm initiated to unity to avoid trouble at first calculation + ceq%phase_varres(lokcs)%abnorm=one + allocate(ceq%phase_varres(lokcs)%sites(nsl)) +! + if(btest(phlista(lokph)%status1,PHIONLIQ)) then +! for ionic liquid the sites may depend on composition +! I get error these already allocated. Why ?? + if(.not.allocated(ceq%phase_varres(lokcs)%dpqdy)) then + allocate(ceq%phase_varres(lokcs)%dpqdy(nc)) + allocate(ceq%phase_varres(lokcs)%d2pqdvay(nc)) + endif + endif +! +! result arrays for a phase for use in parallell processing + ceq%phase_varres(lokcs)%nprop=nprop + allocate(ceq%phase_varres(lokcs)%listprop(nprop)) + allocate(ceq%phase_varres(lokcs)%gval(6,nprop)) +! write(*,*)'Allocated gval: ',nprop,nc + allocate(ceq%phase_varres(lokcs)%dgval(3,nc,nprop)) + nnc=nc*(nc+1)/2 +! write(*,*)'Allocated dgval: ',nprop,nc,nnc + allocate(ceq%phase_varres(lokcs)%d2gval(nnc,nprop)) +! write(*,*)'Allocated d2gval: ',nprop,nc,nnc +! zero everything + ceq%phase_varres(lokcs)%listprop=0 +! ceq%phase_varres(lokcs)%amount=zero + ceq%phase_varres(lokcs)%amfu=zero + ceq%phase_varres(lokcs)%netcharge=zero + ceq%phase_varres(lokcs)%dgm=zero + ceq%phase_varres(lokcs)%gval=zero + ceq%phase_varres(lokcs)%dgval=zero + ceq%phase_varres(lokcs)%d2gval=zero +! Mark there is no disordered phase_varres record + ceq%phase_varres(lokcs)%disfra%varreslink=0 +! write(*,*)'parrecords: ',lokcs,nsl,nc +1000 continue + return + end subroutine create_parrecords + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine create_interaction(intrec,mint,lint,intperm,intlinks) +! creates a parameter interaction record +! with permutations if intperm(1)>0 + implicit none + type(gtp_interaction), pointer :: intrec + integer, dimension(2,*) :: lint,intlinks + integer, dimension(*) :: intperm + integer mint +!\end{verbatim} + integer permut,emperm,nz,nq,lqq,ii,ll +! +! write(*,5)'create interaction:',mint,lint(1,mint),lint(2,mint),& +! (intperm(i),i=1,6) +5 format(a,i5,2x,2i3,2x6i3) + allocate(intrec) +! note that the order of values in intperm here is not the same as in +! fccpermuts or bccpermuts. Intlinks is the same + permut=intperm(1) + if(permut.le.0) then +! This is a default for no permutations, store 1's + permut=0 + allocate(intrec%noofip(2)) + intrec%noofip(1)=1 + intrec%noofip(2)=1 + allocate(intrec%sublattice(1)) + allocate(intrec%fraclink(1)) + elseif(mint.eq.1) then +! Intperm contains information as created by fccpermut or bccpermut +! intperm(1) and 2 are related to mint=1 (level 1 interaction), +! intperm(3) to mint=2 +! The values are stored in noofip(1) and intperm(2..) in noofip(2..) +! For mint=1 intperm(1..2) are stored in noofipermt(1..2) +! intperm(1) is the number of interaction permutations for each +! endmember permutation. +! intperm(2) are the number total number of permutations on level 1 +! The number of endmember permutations is thus intperm(2)/intperm(1) +! write(*,17)'intrec: ',mint,intperm(1),intperm(2) + permut=intperm(2) + nz=intperm(2) + allocate(intrec%noofip(2)) + intrec%noofip(1)=intperm(1) + intrec%noofip(2)=intperm(2) + allocate(intrec%sublattice(nz)) + allocate(intrec%fraclink(nz)) + nq=0 + elseif(mint.eq.2) then +! For mint=2 intperm(3) is stored in noofip(1) and intperm(4..) after that +! if intperm(3)>1 then there are intperm(3) number of limits in +! intperm(2..) for each lower order interaction. +! Example endmember A:A:A:A; no permutations +! 1st level intperm(1)=1, intperm(2)=4; permutations AX:A:A:A, A:AX:A:A etc +! 2nd level intperm(1)=4, inteprm(2..4)=(3, 2, 1, 0) +! 3 permutations for AX:A:A:A: AX:AX:A:A; AX:A:AX:A; AX:A:A:AX +! 2 permutations for A:AX:A:A: A:AX:AX:A A:AX:A:AX; +! 1 permutation for A:A:AX:A: A:A:AX:AX; +! 0 permutations for A:A:A:AX: none +! If noofpermut>1 the index selected of noofip is by the permutation of +! the lower order interaction +! the value in intpermut(4+intperm(3)) is total number of permutations + lqq=intperm(4+intperm(3)) +! write(*,17)'intrec: ',mint,intperm(3),(intperm(3+ii),ii=1,intperm(3)) +17 format(a,2i4,2x,10i4) + permut=intperm(3) + emperm=intperm(2)/intperm(1) + allocate(intrec%noofip(permut+2)) + nz=0 + intrec%noofip(1)=intperm(3) + do ii=1,permut + intrec%noofip(1+ii)=intperm(3+ii) + nz=nz+intperm(3+ii) + enddo +! write(*,19)'ci: ',nz,emperm,permut,(intrec%noofip(j),j=1,permut+2) +19 format(a,10i4) +! AX:AX:A:A; 1 endmember permutation, 4 1st level permutations; 6 2nd level +! emperm=1; intperm(3)=4, intparm(4..6)=(3,2,1,0), nz=1*6=6 +! AX:AX:B:B; 6 endmember permutation, 6 1st level permutations; 6 2nd level +! emperm=6; nz=1; nz=1*6=6 +! number of permutations is related to the previous level +! nz=nz*emperm + nz=lqq +! write(*,*)'Level 2 permutations: ',nz + allocate(intrec%sublattice(nz)) + allocate(intrec%fraclink(nz)) +! Save at the end the total number of permutations stored + intrec%noofip(permut+2)=nz + nq=intperm(2) +! write(*,19)'c2: ',nz,emperm,permut,(intrec%noofip(j),j=1,permut+2) +! write(*,17)'level 2 permutations: ',nz,emperm,nq,lqq + else + write(*,*)'Create_interaction called with too many permutations' + gx%bmperr=7777; goto 1000 + endif + if(permut.eq.0) then +! this is again a default when there are no permutations + intrec%sublattice(1)=lint(1,mint) + intrec%fraclink(1)=lint(2,mint) + else +! We can have cases like noofiperumt(1)=1; noofip(2)=4 or +! noofip(1)=4; noofip(2..5)=(4, 3, 2, 1) +! nq is 0 for first level, intperm(2) for second level + do ll=1,nz + intrec%sublattice(ll)=intlinks(1,nq+ll) + intrec%fraclink(ll)=intlinks(2,nq+ll) + enddo +! write(*,99)'isp: ',mint,& +! (intrec%sublattice(ll),intrec%fraclink(ll),ll=1,nz) +99 format(a,i2,8(2x,2i3)) + endif + nullify(intrec%propointer) + nullify(intrec%nextlink) + nullify(intrec%highlink) + intrec%status=0 + noofint=noofint+1 + intrec%antalint=noofint +1000 continue + return + end subroutine create_interaction + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine create_endmember(lokph,newem,noperm,nsl,endm,elinks) +! create endmember record with nsl sublattices with endm as constituents +! noperm is number of permutations +! endm is the basic endmember +! elinks are the links to constituents for all permutations + implicit none + integer endm(*) + type(gtp_endmember), pointer :: newem + integer, dimension(nsl,noperm) ::elinks + integer lokph,noperm,nsl +!\end{verbatim} + integer is,ndemr,noemr + allocate(newem) + nullify(newem%nextem) + allocate(newem%fraclinks(nsl,noperm)) +! write(*,7)noperm,nsl,(elinks(i,1),i=1,4),(endm(i),i=1,nsl) +7 format('ce1: ',2i4,2x,4i5,2x10i4) + if(noperm.eq.1) then + do is=1,nsl + newem%fraclinks(is,1)=endm(is) + enddo + else + newem%fraclinks=elinks + endif +! zero or set values + newem%noofpermut=noperm + newem%phaselink=lokph + noofem=noofem+1 + newem%antalem=noofem + nullify(newem%propointer) + nullify(newem%intpointer) +! indicate that oendmemarr and denmemarr must be renewed ??? + noemr=0 + ndemr=0 +1000 continue + return + end subroutine create_endmember + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine create_proprec(proprec,proptype,degree,lfun,refx) +! reservs a property record from free list and insert data + implicit none + TYPE(gtp_property), pointer :: proprec + integer proptype,degree,lfun + character refx*(*) +!\end{verbatim} + integer j,iref + character notext*32 + if(degree.lt.0 .or. degree.gt.9) then + gx%bmperr=4063; goto 1000 + endif + allocate(proprec) +! enter data in reserved record + allocate(proprec%degreelink(0:degree)) + nullify(proprec%nextpr) +! if(proptype.ge.100) write(*,*)'property type: ',proptype + proprec%proptype=proptype + proprec%degree=degree + do j=0,degree + proprec%degreelink(j)=0 + enddo + proprec%degreelink(degree)=lfun + proprec%reference=adjustl(refx) +! create reference record if new, can be amended later + call capson(refx) + notext='*** Not set by database or user ' +!------counter + noofprop=noofprop+1 + proprec%antalprop=noofprop +! write(*,11)refx,notext +!11 format('create proprec: ',a,a) + call tdbrefs(refx,notext,0,iref) + proprec%extra=0 +1000 continue + return + end subroutine create_proprec + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine extend_proprec(current,degree,lfun) +! extends a property record and insert new data + implicit none + integer degree,lfun + type(gtp_property), pointer :: current +!\end{verbatim} + integer oldeg,j + integer :: savedegs(0:9) +! save degreelinks ... maybe not necessary .... + oldeg=current%degree +! write(*,*)'extend_proprec 1: ',current,degree,lfun,oldeg + do j=0,9 + savedegs(j)=0 + enddo + do j=0,oldeg + savedegs(j)=current%degreelink(j) + enddo +! important to get it correct here + deallocate(current%degreelink) + allocate(current%degreelink(0:degree)) + current%degree=degree + do j=0,current%degree + current%degreelink(j)=0 + enddo + do j=0,oldeg + current%degreelink(j)=savedegs(j) + enddo + current%degreelink(degree)=lfun +1000 continue + return + end subroutine extend_proprec + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine new_phase_varres_record(iph,phvar,ceq) +! this subroutine returnes a copy of the phase variable structure for iph +! >>>>>>>>>>>>> +! this subroutine is probably redundant since the structure +! gtp_equilibrium_data was introduced. Each parallell tread should have +! its own gtp_equilibrium_data record. +! >>>>>>>>>>>>>>>>>>>>>>>>>> +! The programmer can enter fraction in this structure and use it in calls +! to parcalcg should be suitable for parallel processing (NOT TESTED) +! when the same phase is calculated in several threads (like when separate +! threads calculate different lines suring mapping) + implicit none +! >>>> unfinished +! >>>> for calculation of the same phase in separate threads + integer iph + TYPE(gtp_equilibrium_data) :: ceq + TYPE(gtp_phase_varres) :: phvar +!\end{verbatim} + integer tnooffr,lokph,lokcs,nsl,lokdis + TYPE(gtp_phase_varres) :: phdis + TYPE(gtp_fraction_set) :: olddis,newdis +! + if(iph.le.0 .or. iph.gt.noofph) then + gx%bmperr=4050; goto 1000 + endif + lokph=phases(iph) +! lokcs=phlista(lokph)%cslink + lokcs=phlista(lokph)%linktocs(1) +! allocate arrays and copy values from phase_varres(lokcs) to phvar + phvar%nextfree=0 + phvar%phlink=ceq%phase_varres(lokcs)%phlink + phvar%status2=ceq%phase_varres(lokcs)%status2 + nsl=size(ceq%phase_varres(lokcs)%sites) + tnooffr=size(ceq%phase_varres(lokcs)%yfr) +! write(*,*)'Allocate constat 3: ',nc + allocate(phvar%constat(tnooffr)) + allocate(phvar%yfr(tnooffr)) + allocate(phvar%mmyfr(tnooffr)) + allocate(phvar%sites(nsl)) + phvar%constat=ceq%phase_varres(lokcs)%constat + phvar%yfr=ceq%phase_varres(lokcs)%yfr +! phvar%mmyfr=ceq%phase_varres(lokcs)%mmyfr + phvar%mmyfr=zero + phvar%sites=ceq%phase_varres(lokcs)%sites + write(*,*)'new_phase_varres: ',lokcs,tnooffr + if(btest(phlista(lokph)%status1,PHMFS))then +! there is a disordered fraction set ... suck + olddis=ceq%phase_varres(lokcs)%disfra + phvar%disfra%latd=olddis%latd + phvar%disfra%ndd=olddis%ndd + phvar%disfra%tnoofxfr=olddis%tnoofxfr + phvar%disfra%tnoofyfr=olddis%tnoofyfr + phvar%disfra%varreslink=olddis%varreslink + phvar%disfra%totdis=olddis%totdis + allocate(phvar%disfra%dsites(olddis%ndd)) + allocate(phvar%disfra%nooffr(olddis%ndd)) + allocate(phvar%disfra%splink(olddis%tnoofxfr)) + allocate(phvar%disfra%y2x(olddis%tnoofyfr)) + allocate(phvar%disfra%dxidyj(olddis%tnoofyfr)) + phvar%disfra%dsites=olddis%dsites + phvar%disfra%nooffr=olddis%nooffr + phvar%disfra%splink=olddis%splink + phvar%disfra%y2x=olddis%y2x + phvar%disfra%dxidyj=olddis%dxidyj +! +! we must create a new phase_varres record for the disordered fractions + lokdis=olddis%varreslink +! allocate(phdis) + call new_disordered_phase_variable_record(lokdis,phvar,phdis,ceq) +! the link between phvar and phdis is set inside new_disordered +! write(*,*)'disord 5 ',phdis%phlink,phase_varres(lokdis)%phlink, & +! phvar%disfra%phdapointer%phlink + endif +1000 continue + return + end subroutine new_phase_varres_record + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine new_disordered_phase_variable_record(lokdis,phvar,phdis,ceq) +! Does this really work???? +! creates a copy of the disordered phase variable record lokdis +! and set links from ordered phvar +! ?????????????? does this work ?????????? is it necessary ???? +! can one just make an assignment ???? + implicit none + TYPE(gtp_equilibrium_data) :: ceq + TYPE(gtp_phase_varres) :: phvar + TYPE(gtp_phase_varres), target :: phdis + integer lokdis +!\end{verbatim} + integer tnooffr,nsl +! + phdis%nextfree=0 + phdis%phlink=ceq%phase_varres(lokdis)%phlink +! write(*,*)'disord 1 ',phdis%phlink,phase_varres(lokdis)%phlink + phdis%status2=ceq%phase_varres(lokdis)%status2 + nsl=size(ceq%phase_varres(lokdis)%sites) + tnooffr=size(ceq%phase_varres(lokdis)%yfr) +! write(*,*)'Allocate constat 4: ',tnooffr + allocate(phdis%constat(tnooffr)) + allocate(phdis%yfr(tnooffr)) + allocate(phdis%sites(nsl)) + phdis%constat=ceq%phase_varres(lokdis)%constat + phdis%yfr=ceq%phase_varres(lokdis)%yfr + allocate(phdis%mmyfr(tnooffr)) + phdis%mmyfr=zero +! phdis%mmyfr=ceq%phase_varres(lokdis)%mmyfr + phdis%sites=ceq%phase_varres(lokdis)%sites +! save link to the phdis record, two links ... why? just because it is messy +! write(*,*)'disord 2 ',phdis%phlink,phase_varres(lokdis)%phlink + phvar%disfra%phdapointer=>phdis +! why setting it to zero here??? it should be an index to phase_varres record + phvar%disfra%varreslink=0 +! phvar%disordered=>phdis +! write(*,*)'disord 3 ',phdis%phlink,phase_varres(lokdis)%phlink +1000 continue + return + end subroutine new_disordered_phase_variable_record + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine add_fraction_set(iph,id,ndl,totdis) +! add a new set of fractions to a phase, usually to describe a disordered state +! like the "partitioning" in old TC +! +! BEWARE this is only done for firsteq, illegal when having more equilibria +! +! id is a letter used as suffix to identify the parameters of this set +! ndl is the last original sublattice included in the (first) disordered set +! ndl can be 1 meaning sublattice 2..nsl are disordered, or nsl meaning all are +! disordered +! totdis=0 if phase never disorder totally (like sigma) +! +! For a phase like (Al,Fe,Ni)3(Al,Fe,Ni)1(C,Va)4 to add (Al,Fe,Ni)4(C,Va)4 +! icon=1 2 3 1 2 3 4 5 with ndl=2 +! For a phase like (Fe,Ni)10(Cr,Mo)4(Cr,Fe,Mo,Ni)16 then +! icon=2 4 1 3 1 2 3 4 with ndl=3 +! This subroutine will create the necessary data to calculate the +! disordered fraction set from the site fractions. +! +! IMPORTANT (done): for each composition set this must be repeated +! if new composition sets are created it must be repeated for these +! +! IMPORTANT (not done): order the constituents alphabetically in each disorderd +! sublattice otherwise it will not be possible to enter parameters correctly +! + implicit none + integer iph,ndl,totdis + character id*1 +!\end{verbatim} +! ceq probably not needed as firsteq is declared as pointer + TYPE(gtp_equilibrium_data), target :: ceq + TYPE(gtp_fraction_set), target :: fsdata +! jsp(i) contains species locations of disordered constituent i +! jy2x(i) is the disordered fraction to which site fraction i should be added +! y2x(i) is the site ration factor for multiplying sitefraction i when added +! ispord and ispold are needed to sort disordered constituents + integer jsp(maxconst,2),jy2x(maxconst),iva(maxconst) + integer ispord(maxconst),ispold(maxconst),nrj3(2),nrj4(2) + integer lokph,lokcs,nsl,ii,nrj1,nrj2,nlat,lokx,l2 + integer ll,kk,jall,nnn,mmm,ioff,koff,jl,j1,j2,ix,is,jj,k,ijcs,nydis,nyttcs + double precision sum,div +! + if(.not.allowenter(2)) then + gx%bmperr=4125 + goto 1000 + endif +! this subroutine can only be called when there is only one equilibrium +! Hm, does this create a copy of firsteq?? YES ... clumsy + ceq=firsteq + lokph=phases(iph) +! phase must not have any suspended constituents nor any composition sets + if(phlista(lokph)%noofcs.gt.1) then + gx%bmperr=4029; goto 1000 + else + lokcs=phlista(lokph)%linktocs(1) + if(btest(firsteq%phase_varres(lokcs)%status2,CSCONSUS)) then + gx%bmperr=4030; goto 1000 + endif + endif + nsl=phlista(lokph)%noofsubl + if(ndl.le.0 .or. ndl.gt.nsl) then +! ndl must be larger than 0 and lesser or equal to nsl + gx%bmperr=4076; goto 1000 + endif +! location of first composition set, there may be more + if(btest(phlista(lokph)%status1,phmfs)) then +! disordered fractions already set + gx%bmperr=4077; goto 1000 + endif +! we must organise a constituent list for the disordered fractions by +! scanning the constituents in the current phlista(lokph)%constitlist +! we must also contruct the way site fractions should be added + ii=0 + nrj1=1 + nrj2=0 + nlat=0 + lokx=0 + l2=1 + iva=0 + subloop: do ll=1,nsl + constloop: do kk=1,phlista(lokph)%nooffr(ll) + ii=ii+1 + if(nrj2.lt.nrj1) then + nrj2=nrj2+1 + lokx=lokx+1 + jy2x(ii)=lokx + jsp(nrj2,l2)=phlista(lokph)%constitlist(ii) +! write(*,46)'new 1: ',nrj2,l2,ii,nlat,jsp(nrj2,l2),jy2x(ii) + else + do jall=nrj1,nrj2 + if(phlista(lokph)%constitlist(ii).eq.jsp(jall,l2)) then +! this constituent already found in another sublattice to be merged +! write(*,*)'same: ',jall,nlat,jall+nlat,ii,jy2x(jall+nlat) + jy2x(ii)=jy2x(jall+nlat); goto 50 + endif + enddo +! new constituent + nrj2=nrj2+1 + lokx=lokx+1 + jy2x(ii)=lokx + jsp(nrj2,l2)=phlista(lokph)%constitlist(ii) +! write(*,46)'new 2: ',nrj2,l2,ii,nlat,jsp(nrj2,l2),jy2x(ii) +46 format(a,10i3) +! if vacancy set that bit in iva + if(btest(firsteq%phase_varres(lokcs)%constat(ii),conva)) then + iva(nrj2)=ibset(iva(nrj2),conva) + endif +! write(*,*)'addfs 7B: ',ll,ii,nrj2 +50 continue + endif + enddo constloop + if(ll.eq.ndl) then +! next sublattices (if any) will be summed to second disordered sublattice + nrj3(1)=nrj2 + nrj3(2)=0 +! bug?? + nlat=ii + nrj1=1 + nrj2=0 +! nrj4 is the number of constituents in ordered phase thst is summed +! to first disordered sublattice. Needed below to rearrange jy2x + nrj4(1)=ii + nrj4(2)=0 + if(ndl.lt.nsl) l2=2 +! write(*,*)'addfs 7C: ',ll,ndl,nrj1,nrj2,nrj3 + elseif(ll.eq.nsl) then +! this may never be executed if ndl=nsl but we set nrj3(2)=0 above + nrj3(2)=nrj2 + nrj4(2)=ii-nrj4(1) + endif + enddo subloop +! write(*,53)'add_fraction_set 2: ',(jy2x(i),i=1,ii) +53 format(a,20i3) +! added fsites to handle the case when reading sigma etc from a TDB file +! as the TDB file format assumes 1 site. Default is 1.0, changed externally + fsdata%fsites=one +! write(*,*)'Set fsites: ',fsdata%fsites +! +! write(*,53)'add_fraction_set 3: ',nrj1,nrj2,nrj3,nrj4 + fsdata%latd=ndl + fsdata%tnoofyfr=phlista(lokph)%tnooffr + fsdata%varreslink=lokcs +! totdis=1 means disordered fcc, bcc, ncp. totdis=0 means sigma + fsdata%totdis=totdis + fsdata%id=id +! one or 2 disordered sublattices + nnn=1 + if(ndl.lt.nsl) nnn=2 + allocate(fsdata%dsites(nnn)) + fsdata%ndd=nnn + allocate(fsdata%nooffr(nnn)) + fsdata%nooffr(1)=nrj3(1) + if(nnn.eq.2) fsdata%nooffr(2)=nrj3(2) +! nrj3(1) are the number of constituents on first sublattice, nrj3(2) on 2nd + mmm=nrj3(1)+nrj3(2) + fsdata%tnoofxfr=mmm + allocate(fsdata%splink(mmm)) + allocate(fsdata%y2x(phlista(lokph)%tnooffr)) + allocate(fsdata%dxidyj(phlista(lokph)%tnooffr)) +! write(*,*)'add_fs dxidyj: ',phlista(lokph)%tnooffr +! the constituents in jsp(i..n,subl) must be ordered alphabetically!!! +! get the species number in alphadetical order + ioff=0 + koff=0 + do l2=1,nnn + do jl=1,nrj3(l2) +! write(*,*)'l2 loop: ',jsp(i,l2) + ispord(jl)=splista(jsp(jl,l2))%alphaindex + enddo +! write(*,47)1,(ispord(i),i=1,nrj3(l2)) +47 format('add_fs ',i1,': ',20i3) +! species, noofsp, origonal order + call sortin(ispord,nrj3(l2),ispold) + if(buperr.ne.0) then + gx%bmperr=buperr; goto 1000 + endif +! when rearranging jsp(1..n,l2) we must also rearrange y2x +! for 2nd sublattice add nrj3(1) to ispold + if(l2.eq.2) then + ioff=nrj4(1) + koff=nrj3(1) + endif +! write(*,47)2,(jy2x(ioff+i),i=1,nrj4(l2)) +! this must be possible to do smarter ..... + do j2=1,nrj4(l2) + do j1=1,nrj3(l2) + if(jy2x(ioff+j2).eq.ispold(j1)+koff) then + jy2x(ioff+j2)=j1+koff; goto 77 + endif + enddo +77 continue + enddo + do j1=1,nrj3(l2) + ispord(j1)=jsp(ispold(j1),l2) + enddo + do j1=1,nrj3(l2) + jsp(j1,l2)=ispord(j1) + enddo +! write(*,47)5,(jsp(i,l2),i=1,nrj3(l2)) + enddo + fsdata%splink=0 +! + do jl=1,phlista(lokph)%tnooffr + fsdata%y2x(jl)=jy2x(jl) + enddo + ix=0 + do l2=1,nnn + do jl=1,nrj3(l2) + ix=ix+1 + fsdata%splink(ix)=jsp(jl,l2) + enddo + enddo +! write(*,*)'addfs splink: ',fsdata%splink +! + is=0 + sum=zero + do ll=1,ndl +! sum=sum+phlista(lokph)%sites(ll) + sum=sum+firsteq%phase_varres(lokcs)%sites(ll) + enddo + fsdata%dsites(1)=sum + if(ndl.lt.nsl) then + sum=zero + do ll=ndl+1,nsl +! sum=sum+phlista(lokph)%sites(ll) + sum=sum+firsteq%phase_varres(lokcs)%sites(ll) + enddo + fsdata%dsites(2)=sum + endif +! + jj=0 + sum=fsdata%dsites(1) + do ll=1,nsl + if(ll.gt.ndl) sum=fsdata%dsites(2) +! div=phlista(lokph)%sites(ll)/sum + div=firsteq%phase_varres(lokcs)%sites(ll)/sum +! write(*,78)'add_fs 5A ',div,phlista(lokph)%sites(ll),sum +!78 format(a,6F10.7) + do k=1,phlista(lokph)%nooffr(ll) + jj=jj+1 + fsdata%dxidyj(jj)=div + enddo + enddo +! write(*,99)'add_fs 5B ',fsdata%dxidyj +99 format(a,6(F10.7)) + firsteq%phase_varres(lokcs)%disfra=fsdata + firsteq%phase_varres(lokcs)%status2=& + ibset(firsteq%phase_varres(lokcs)%status2,CSDLNK) +! we have to reserve a phase_varres record for calculations +! ... det gäller att hålla tungan rätt i mun ... +! nprop=10 +! call create_parrecords(nyttcs,nnn,mmm,nprop,iva,firsteq) + call create_parrecords(lokph,nyttcs,nnn,mmm,maxcalcprop,iva,firsteq) + if(gx%bmperr.ne.0) goto 1000 + fsdata%varreslink=nyttcs +! note ceq is firsteq but declared target + fsdata%phdapointer=>ceq%phase_varres(nyttcs) + firsteq%phase_varres(nyttcs)%phlink=lokph + firsteq%phase_varres(nyttcs)%prefix=' ' + firsteq%phase_varres(nyttcs)%suffix=' ' + do ll=1,nnn + firsteq%phase_varres(nyttcs)%sites(ll)=fsdata%dsites(ll) + enddo + firsteq%phase_varres(nyttcs)%status2=0 + firsteq%phase_varres(nyttcs)%status2=& + ibset(firsteq%phase_varres(nyttcs)%status2,CSDFS) +! finally copy fsdata to the link in lokcs + call copy_fracset_record(lokcs,fsdata,firsteq) + if(gx%bmperr.ne.0) goto 1000 +! if there are several composition sets create fracset records for each +200 continue +! if(firsteq%phase_varres(lokcs)%next.gt.0) then +! lokcs=firsteq%phase_varres(lokcs)%next + do ijcs=2,phlista(lokph)%noofcs + lokcs=phlista(lokph)%linktocs(ijcs) +! one must also create parrecords for these !!! +! call create_parrecords(nydis,nnn,mmm,nprop,iva,firsteq) + call create_parrecords(lokph,nydis,nnn,mmm,maxcalcprop,iva,firsteq) + if(gx%bmperr.ne.0) goto 1000 + fsdata%varreslink=nydis +! set pointer also + fsdata%phdapointer=firsteq%phase_varres(nydis) + firsteq%phase_varres(nydis)%phlink=lokph + firsteq%phase_varres(nydis)%prefix=' ' + firsteq%phase_varres(nydis)%suffix=' ' + do ll=1,nnn + firsteq%phase_varres(nydis)%sites(ll)=fsdata%dsites(ll) + enddo + firsteq%phase_varres(nydis)%status2=0 + firsteq%phase_varres(nydis)%status2=& + ibset(firsteq%phase_varres(nyttcs)%status2,CSDFS) +! This does not create a new record +! firsteq%phase_varres(lokcs)%disfra=fsdata +! but this seems to work + call copy_fracset_record(lokcs,fsdata,firsteq) + if(gx%bmperr.ne.0) goto 1000 + firsteq%phase_varres(lokcs)%status2=& + ibset(firsteq%phase_varres(lokcs)%status2,CSDLNK) + goto 200 + enddo +! set status bit for multiple/disordered fraction sets and no of fraction sets + phlista(lokph)%status1=ibset(phlista(lokph)%status1,PHMFS) + phlista(lokph)%nooffs=2 +1000 continue + return +! nydis + end subroutine add_fraction_set + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine copy_fracset_record(lokcs,disrec,ceq) +! attempt to create a new disordered record ??? this can probably be done +! with just one statement .. but as it works I am not changing right now + implicit none + TYPE(gtp_equilibrium_data) :: ceq + TYPE(gtp_fraction_set) :: disrec + integer lokcs +!\end{verbatim} + TYPE(gtp_fraction_set) :: discopy +! the hard way ?? + discopy%fsites=disrec%fsites + discopy%latd=disrec%latd + discopy%ndd=disrec%ndd + discopy%tnoofxfr=disrec%tnoofxfr + discopy%tnoofyfr=disrec%tnoofyfr + discopy%varreslink=disrec%varreslink + discopy%phdapointer=>disrec%phdapointer + discopy%totdis=disrec%totdis + discopy%id=disrec%id + allocate(discopy%dsites(disrec%ndd)) + allocate(discopy%nooffr(disrec%ndd)) + allocate(discopy%splink(disrec%tnoofxfr)) + allocate(discopy%y2x(disrec%tnoofyfr)) + allocate(discopy%dxidyj(disrec%tnoofyfr)) +! + discopy%dsites=disrec%dsites + discopy%nooffr=disrec%nooffr + discopy%splink=disrec%splink + discopy%y2x=disrec%y2x + discopy%dxidyj=disrec%dxidyj +! +! write(*,*)'copyfs 1: ',lokcs,discopy%varreslink,disrec%varreslink + ceq%phase_varres(lokcs)%disfra=discopy +! write(*,*)'copyfs 2: ',phase_varres(lokcs)%disfra%varreslink +1000 continue + return + end subroutine copy_fracset_record + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine suspend_species_implicitly(ceq) +! loop through all entered species and suspend those with an element suspended + implicit none + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} %+ + integer loksp,iel,lokel + sploop: do loksp=1,noofsp + if(.not.btest(splista(loksp)%status,spsus)) then + elloop: do iel=1,splista(loksp)%noofel + lokel=splista(loksp)%ellinks(iel) + if(btest(ellista(lokel)%status,elsus)) then +! an element is suspended, suspend this species implicitly + splista(loksp)%status=ibset(splista(loksp)%status,spsus) + splista(loksp)%status=ibset(splista(loksp)%status,spimsus) + goto 200 + endif + enddo elloop + endif +200 continue + enddo sploop +1000 continue + return + end subroutine suspend_species_implicitly + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine suspend_phases_implicitly(ceq) +! loop through all entered phases and suspend constituents and +! SUSPEND phases with all constituents in a sublattice suspended +! dimension lokcs(9) + implicit none + TYPE(gtp_equilibrium_data) :: ceq +!\end{verbatim} %+ + integer lokph,lokcs,ncc,kk,kkl,nek,icon,ll,loksp,jl +! +! BEWARE not adopted fro parallel processing +! + phloop: do lokph=1,noofph + if(.not.btest(phlista(lokph)%status1,phhid)) then +! locate all composition sets and store indices in lokcs + ncc=phlista(lokph)%noofcs + kk=0 + sublloop: do ll=1,phlista(lokph)%noofsubl + kkl=kk + nek=0 + constloop: do icon=1,phlista(lokph)%nooffr(ll) + kk=kk+1 + loksp=phlista(lokph)%constitlist(kk) + if(btest(splista(loksp)%status,spsus)) then +! a constituent is suspended, mark this also in constat for all comp.sets + compsets: do jl=1,ncc + lokcs=phlista(lokph)%linktocs(jl) + ceq%phase_varres(lokcs)%constat(kk)=& + ibset(ceq%phase_varres(lokcs)%constat(kk),consus) + ceq%phase_varres(lokcs)%constat(kk)=& + ibset(ceq%phase_varres(lokcs)%constat(kk),conimsus) +! mark that some constituents are suspended in this composition set + ceq%phase_varres(lokcs)%status2=& + ibset(ceq%phase_varres(lokcs)%status2,CSCONSUS) + enddo compsets + goto 200 + else + nek=nek+1 + endif + enddo constloop + if(nek.eq.0) then +! this sublattice has all constituents suspended, hide/suspend the phase + phlista(lokph)%status1=ibset(phlista(lokph)%status1,phhid) + phlista(lokph)%status1=ibset(phlista(lokph)%status1,phimhid) +! also set amount to zero ?? + compsets2: do jl=1,ncc + lokcs=phlista(lokph)%linktocs(jl) +! ceq%phase_varres(lokcs)%amount=zero + ceq%phase_varres(lokcs)%amfu=zero + ceq%phase_varres(lokcs)%netcharge=zero + enddo compsets2 + endif + goto 300 +200 continue + kk=kkl+phlista(lokph)%nooffr(ll) + kkl=kk-1 + enddo sublloop +300 continue + endif + enddo phloop +1000 continue + return + end subroutine suspend_phases_implicitly + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine restore_species_implicitly_suspended +! loop through all implicitly suspended species and restore those with +! all elements enteded + implicit none +!\end{verbatim} %+ + integer loksp,lokel + sploop: do loksp=1,noofsp + if(btest(splista(loksp)%status,spimsus)) then + elloop: do lokel=1,splista(loksp)%noofel +! an element is suspended, keep species suspended + if(btest(ellista(lokel)%status,elsus)) goto 200 + enddo elloop +! all elements entered, restore species as entered + splista(loksp)%status=ibclr(splista(loksp)%status,spsus) + splista(loksp)%status=ibclr(splista(loksp)%status,spimsus) + endif +200 continue + enddo sploop +1000 continue + return + end subroutine restore_species_implicitly_suspended + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine restore_phases_implicitly_suspended +! loop through all implicitly suspended phases and restore those with +! at least one constituent entered in each sublattice + implicit none +!\end{verbatim} + integer lokph,ll,kk,kkl,icon,loksp + phloop: do lokph=1,noofph + if(btest(phlista(lokph)%status1,phimhid)) then + kk=0 + sublloop: do ll=1,phlista(lokph)%noofsubl + kkl=kk + constloop: do icon=1,phlista(lokph)%nooffr(ll) + kk=kk+1 + loksp=phlista(lokph)%constitlist(kk) + if(.not.btest(splista(loksp)%status,spsus)) goto 200 + enddo constloop +! all constituents in this sublattice are suspended, keep the phase hidden + goto 300 +200 continue + kk=kkl+phlista(lokph)%nooffr(ll) + kkl=kk-1 + enddo sublloop +! all sublattices have at least one constituent entered, restore it + phlista(lokph)%status1=ibclr(phlista(lokph)%status1,phhid) + phlista(lokph)%status1=ibclr(phlista(lokph)%status1,phimhid) +300 continue + endif + enddo phloop +1000 continue + return + end subroutine restore_phases_implicitly_suspended + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine add_to_reference_phase(loksp) +! add this element to the reference phase +! loksp: species index of new element + implicit none + integer loksp +!\end{verbatim} +! one must extend all arrays in phlista, phase_varres and phase_varres + integer lokph,noc,i,nprop,mc2,lokcs + integer, dimension(maxel) :: isave + lokph=0 + lokcs=phlista(lokph)%linktocs(1) +! constitlist + noc=phlista(lokph)%tnooffr + do i=1,noc + isave(i)=phlista(lokph)%constitlist(i) + enddo + deallocate(phlista(lokph)%constitlist) + noc=noc+1 + allocate(phlista(lokph)%constitlist(noc)) + isave(noc)=loksp + do i=1,noc + phlista(lokph)%constitlist(i)=isave(i) + enddo + phlista(lokph)%tnooffr=noc + phlista(lokph)%nooffr(1)=noc +! phase_varres, no data need saving +! write(*,*)'Deallocate constat 5: ',size(firsteq%phase_varres(lokcs)%constat) + deallocate(firsteq%phase_varres(lokcs)%constat) + deallocate(firsteq%phase_varres(lokcs)%yfr) + deallocate(firsteq%phase_varres(lokcs)%mmyfr) +! write(*,*)'Allocate constat 5: ',noc + allocate(firsteq%phase_varres(lokcs)%constat(noc)) + firsteq%phase_varres(lokcs)%constat(noc)=0 + allocate(firsteq%phase_varres(lokcs)%yfr(noc)) + allocate(firsteq%phase_varres(lokcs)%mmyfr(noc)) + firsteq%phase_varres(lokcs)%yfr=one + firsteq%phase_varres(lokcs)%mmyfr=zero + nprop=firsteq%phase_varres(lokcs)%nprop + deallocate(firsteq%phase_varres(lokcs)%dgval) + deallocate(firsteq%phase_varres(lokcs)%d2gval) + allocate(firsteq%phase_varres(lokcs)%dgval(3,noc,nprop)) + mc2=noc*(noc+1)/2 + allocate(firsteq%phase_varres(lokcs)%d2gval(mc2,nprop)) +! ready!! +1000 continue + return + end subroutine add_to_reference_phase + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatiom} + logical function ocv() +! returns TRUE if GSVERBOSE bit is set +!\end{verbatim} +! typical use: if(ocv()) write(*,*).... + ocv=btest(globaldata%status,GSVERBOSE) + return + end function ocv + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!-\begin{verbatim} + integer function vssize(varres) +! calculates the size in words (4 bytes) of a phase_varres record + implicit none + type(gtp_phase_varres) :: varres +!-\end{verbatim} + integer sum +! write(*,*)'In vssize 1' +! integer nextfree,phlink,status2,phstate +! double precision, dimension(2) :: abnorm +! character*4 prefix,suffix + sum=10 +! changed to allocatable +! integer, dimension(:), allocatable :: constat +! double precision, dimension(:), allocatable :: yfr +! real, dimension(:), allocatable :: mmyfr +! double precision, dimension(:), allocatable :: sites + if(allocated(varres%constat)) sum=sum+size(varres%constat) + if(allocated(varres%yfr)) sum=sum+3*size(varres%yfr) +! write(*,*)'In vssize 2',sum +! for ionic liquid derivatives of sites wrt fractions (it is the charge), +! 2nd derivates only when one constituent is vacancy +! 1st sublattice P=\sum_j (-v_j)*y_j + Qy_Va +! 2nd sublattice Q=\sum_i v_i*y_i +! double precision, dimension(:), allocatable :: dpqdy +! double precision, dimension(:), allocatable :: d2pqdvay + if(allocated(varres%dpqdy)) sum=sum+size(varres%dpqdy) + if(allocated(varres%d2pqdvay)) sum=sum+size(varres%d2pqdvay) +! write(*,*)'In vssize 3',sum +! for extra fraction sets, better to go via phase record index above +! this TYPE(gtp_fraction_set) variable is a bit messy. Declaring it in this +! way means the record is stored inside this record. +! type(gtp_fraction_set) :: disfra +! size of disfra record?? + sum=sum+10 + if(allocated(varres%disfra%dsites)) sum=sum+size(varres%disfra%dsites) + if(allocated(varres%disfra%nooffr)) sum=sum+size(varres%disfra%nooffr) + if(allocated(varres%disfra%splink)) sum=sum+size(varres%disfra%splink) + if(allocated(varres%disfra%y2x)) sum=sum+size(varres%disfra%y2x) + if(allocated(varres%disfra%dxidyj)) sum=sum+size(varres%disfra%dxidyj) +! write(*,*)'In vssize 4',sum +! It seems difficult to get the phdapointer in disfra record to work +! --- +! arrays for storing calculated results for each phase (composition set) +! amfu: is amount formula units of the composition set (calculated result) +! netcharge: is net charge of phase +! dgm: driving force (calculated result) +! amcom: not used +! damount: set to last change of phase amount in equilibrium calculations +! qqsave: values of qq calculated in set_constitution +! double precision amount(2),dgm,amcom,damount,qqsave(3) +! double precision amfu,netcharge,dgm,amcom,damount,qqsave(3) +! double precision amfu,netcharge,dgm,amcom,damount + sum=sum+10 +! Other properties may be that: gval(*,2) is TC, (*,3) is BMAG, see listprop +! nprop: the number of different properties (set in allocate) +! ncc: total number of site fractions (redundant but used in some subroutines) +! BEWHARE: ncc seems to be wrong using TQ test program fenitq.F90 ??? +! listprop(1): is number of calculated properties +! listprop(2:listprop(1)): identifies the property stored in gval(1,ipy) etc +! 2=TC, 3=BMAG. Properties defined in the gtp_propid record +! integer nprop,ncc +! integer, dimension(:), allocatable :: listprop + if(allocated(varres%listprop)) sum=sum+2+size(varres%listprop) +! write(*,*)'In vssize 5',sum +! gval etc are for all composition dependent properties, gval(*,1) for G +! gval(*,1): is G, G.T, G.P, G.T.T, G.T.P and G.P.P +! dgval(1,j,1): is first derivatives of G wrt fractions j +! dgval(2,j,1): is second derivatives of G wrt fractions j and T +! dgval(3,j,1): is second derivatives of G wrt fractions j and P +! d2gval(ixsym(i,j),1): is second derivatives of G wrt fractions i and j +! double precision, dimension(:,:), allocatable :: gval +! double precision, dimension(:,:,:), allocatable :: dgval +! double precision, dimension(:,:), allocatable :: d2gval + if(allocated(varres%gval)) sum=sum+2*size(varres%gval) + if(allocated(varres%dgval)) sum=sum+2*size(varres%dgval) + if(allocated(varres%d2gval)) sum=sum+2*size(varres%d2gval) +! write(*,*)'In vssize 6',sum +! added for strain/stress, current values of lattice parameters +! double precision, dimension(3,3) :: curlat +! saved values from last equilibrium calculation +! double precision, dimension(:,:), allocatable :: cinvy +! double precision, dimension(:), allocatable :: cxmol +! double precision, dimension(:,:), allocatable :: cdxmol + if(allocated(varres%cinvy)) sum=sum+18+2*size(varres%cinvy) + if(allocated(varres%cxmol)) sum=sum+18+2*size(varres%cxmol) + if(allocated(varres%cdxmol)) sum=sum+18+2*size(varres%cdxmol) +! +1000 continue + vssize=sum + return + end function vssize + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!-\begin{verbatim} + integer function ceqsize(ceq) +! calculates the size in words (4 bytes) of an equilibrium record + implicit none + type(gtp_equilibrium_data), pointer :: ceq +!-\end{verbatim} + integer sum,vsum,ivs,vss +! write(*,*)'In ceqsize 1' +! +! integer status,multiuse,eqno,next +! character eqname*24 +! double precision tpval(2),rtn +! svfunres: the values of state variable functions valid for this equilibrium +! double precision, dimension(:), allocatable :: svfunres + sum=18+2*size(ceq%svfunres) +! write(*,*)'In ceqsize 2',sum +! the experiments are used in assessments and stored like conditions +! lastcondition: link to condition list +! lastexperiment: link to experiment list +! TYPE(gtp_condition), pointer :: lastcondition,lastexperiment +! assuming a pointer is 4 bytes (2 words) + sum=sum+4 +! components and conversion matrix from components to elements +! complist: array with components +! compstoi: stoichiometric matrix of compoents relative to elements +! invcompstoi: inverted stoichiometric matrix +! TYPE(gtp_components), dimension(:), allocatable :: complist +! double precision, dimension(:,:), allocatable :: compstoi +! double precision, dimension(:,:), allocatable :: invcompstoi +! a gtp_component record is about 20 words, invcompstoi same as compsoti + if(allocated(ceq%complist)) sum=sum+20*size(ceq%complist)+& + 4*size(ceq%compstoi) +! write(*,*)'In ceqsize 3',sum +! one record for each phase+composition set that can be calculated +! phase_varres: here all calculated data for the phase is stored +! TYPE(gtp_phase_varres), dimension(:), allocatable :: phase_varres +! each phase_varres record is different for each phase + vsum=0 +! csfree is first free phase_varres record + do ivs=1,csfree + vss=vssize(ceq%phase_varres(ivs)) +! write(*,*)'Phase varres: ',ivs,vss + vsum=vsum+vss + enddo + sum=sum+vsum +! write(*,*)'In ceqsize 4',sum +! index to the tpfun_parres array is the same as in the global array tpres +! eq_tpres: here local calculated values of TP functions are stored +! TYPE(tpfun_parres), dimension(:), pointer :: eq_tpres +! each tpfun_parres record is 8 double + sum=sum+16*size(ceq%eq_tpres) +! current values of chemical potentials stored in component record but +! duplicated here for easy acces by application software +! double precision, dimension(:), allocatable :: cmuval + if(allocated(ceq%cmuval)) sum=sum+2*size(ceq%cmuval) +! xconc: convergence criteria for constituent fractions and other things +! double precision xconv +! delta-G value for merging gridpoints in grid minimizer +! smaller value creates problem for test step3.BMM, MC and austenite merged +! double precision :: gmindif=-5.0D-2 +! maxiter: maximum number of iterations allowed +! integer maxiter + sum=sum+5 +! this is to save a copy of the last calculated system matrix, needed +! to calculate dot derivatives, initiate to zero +! integer :: sysmatdim=0,nfixmu=0,nfixph=0 +! integer, allocatable :: fixmu(:) +! integer, allocatable :: fixph(:,:) +! double precision, allocatable :: savesysmat(:,:) + sum=sum+3+size(ceq%fixmu)+size(ceq%fixph)+size(ceq%savesysmat) +! these are normally not used any more +! sum=sum+size(ceq%fixmu)+size(ceq%fixph)+size(ceq%savesysmat) + ceqsize=sum +1000 continue + return + end function ceqsize + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + diff --git a/models/pmod25I.F90 b/models/gtp3H.F90 similarity index 94% rename from models/pmod25I.F90 rename to models/gtp3H.F90 index 2eb3d15..3260b60 100644 --- a/models/pmod25I.F90 +++ b/models/gtp3H.F90 @@ -1,1274 +1,1284 @@ -! -! included in pmod25.F90 -! -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! -!> 16. Additions -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! -! Additions have a unique number, given sequentially as implemented -! These are all defined in pmod25.F90 -! integer, public, parameter :: indenmagnetic=1 -! integer, public, parameter :: debyecp=2 -! integer, public, parameter :: weimagnetic=3 -! integer, public, parameter :: einstaincp=4 -! integer, public, parameter :: elasticmodela=5 -! integer, public, parameter :: glastransmodela=6 -! 1 is Inden magnetic model with mixed Cuire and Neel temperatures and aff -! 2 is Debye Cp model for low T -! 3 is Inden magnetic model with separate Curie and Neel temp -! 4 is Einstein Cp model for low T -! 5 is Elastic model A -! 6 is glas transition model -!------------------------------------ -! For each addition XX there is a subroutine create_XX -! called from the add_addrecord -! and a subroutine calc_XX -! called from the addition_selector, called from calcg_internal -! There is a common list routine -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! - -!\begin{verbatim} - subroutine addition_selector(addrec,moded,phres,lokph,mc,ceq) -! called when finding an addtion record while calculating G for a phase -! addrec is addition record -! moded is 0, 1 or 2 if no, first or 2nd order derivatives should be calculated -! phres is ? -! lokph is phase location -! mc is number of constitution fractions -! ceq is current equilibrium record - implicit none - type(gtp_phase_add), pointer :: addrec - integer moded,lokph,mc - TYPE(gtp_phase_varres), pointer :: phres - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - addition: select case(addrec%type) - case default - write(kou,*)'No such addition type ',addrec%type,lokph - gx%bmperr=7777 - case(indenmagnetic) ! Inden magnetic - call calc_magnetic_inden(moded,phres,addrec,lokph,mc,ceq) - case(debyecp) ! Debye Cp - call calc_debyecp(moded,phres,addrec,lokph,mc,ceq) - write(kou,*)' Debye Cp model not implemented yet' - gx%bmperr=7777 - case(weimagnetic) ! Wei-Inden - call calc_weimagnetic(moded,phres,addrec,lokph,mc,ceq) - write(kou,*)'Inden magnetic model with sep TC and TN not implemented yet' - gx%bmperr=7777 - case(einsteincp) ! Einstein Cp - call calc_einsteincp(moded,phres,addrec,lokph,mc,ceq) - write(kou,*)' Einstein Cp model not implemented yet' - gx%bmperr=7777 - case(elasticmodela) ! Elastic model - call calc_elastica(moded,phres,addrec,lokph,mc,ceq) -! write(kou,*)' Elastic model not implemented yet' -! gx%bmperr=7777 - case(glastransmodela) ! Glas transition model - write(kou,*)' Glas transition not implemented yet' - gx%bmperr=7777 - end select addition -1000 continue - return - end subroutine addition_selector - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! - -!\begin{verbatim} - subroutine add_addrecord(iph,addtyp) -! generic subroutine to add an addition typ addtyp (Except Inden) - implicit none - integer iph,addtyp -!\end{verbatim} - integer lokph,mc - type(gtp_phase_add), pointer :: newadd,addrec,lastrec - logical bcc -! - call get_phase_record(iph,lokph) - if(gx%bmperr.ne.0) goto 1000 - mc=phlista(lokph)%tnooffr -! create addition record - addition: select case(addtyp) - case default - write(kou,*)'No addtion type ',addtyp,lokph - case(indenmagnetic) ! Inden magnetic -! added by separate subroutine - write(kou,*)'Inden magnetic model is not added this way' - gx%bmperr=7777 - case(debyecp) ! Debye Cp - call create_debyecp(newadd) - case(weimagnetic) ! Inden-Wei. Assume bcc if BCC part of phase name - bcc=.false. - if(index('BCC',phlista(lokph)%name).gt.0) bcc=.true. - call create_weimagnetic(newadd,bcc) - case(einsteincp) ! Einstein Cp - call create_einsteincp(newadd) - case(elasticmodela) ! Elastic model A - call create_elastic_model_a(newadd) - case(glastransmodela) ! Glas transition model A - call create_glas_transition_modela(newadd) - end select addition - if(gx%bmperr.ne.0) goto 1000 -! check if there are other additions -! write(*,*)'25I: adding addition: ',newadd%type,addtyp - if(.not.associated(phlista(lokph)%additions)) then - phlista(lokph)%additions=>newadd -! write(*,*)'25I: added as first addition: ',newadd%type - else -! remove any previous addition of the same type - nullify(lastrec) - addrec=>phlista(lokph)%additions -200 if(addrec%type.eq.addtyp) then - write(*,*)'25I: replace old addition: ',newadd%type - if(associated(lastrec)) then - lastrec%nextadd=>addrec%nextadd - deallocate(addrec) - else - phlista(lokph)%additions=>newadd - newadd%nextadd=>addrec%nextadd - goto 1000 - endif - elseif(associated(addrec%nextadd)) then - addrec=>addrec%nextadd - goto 200 - endif -! write(*,*)'25I: Insering as first addition: ',newadd%type - newadd%nextadd=>phlista(lokph)%additions - phlista(lokph)%additions=>newadd - endif -1000 return - end subroutine add_addrecord - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine need_propertyid(id,typty) -! get the index of the property needed - implicit none - integer typty - character*4 id -!\end{verbatim} -! here the property list is searched for "id" and its index stored in addrec - do typty=1,ndefprop - if(propid(typty)%symbol.eq.id) then - goto 1000 - endif - enddo - write(*,*)'Parameter id ',id,' not found' - gx%bmperr=7777 - typty=-1 -1000 continue - return - end subroutine need_propertyid - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine add_magrec_inden(lokph,addtyp,aff) -! adds a magnetic record to lokph -! lokph is phase location -! addtyp should be 1 of Inden model -! aff is antiferromagnic factor, -1 for bcc and -3 for fcc and hcp - implicit none - integer lokph,addtyp,aff -!\end{verbatim} %+ - integer mc - type(gtp_phase_add), pointer :: newadd,addrec - mc=phlista(lokph)%tnooffr -! create addition record - call create_magrec_inden(newadd,aff) - if(gx%bmperr.ne.0) goto 1000 -! check if there are other additions - if(.not.associated(phlista(lokph)%additions)) then - phlista(lokph)%additions=>newadd - else -! remove any previous addition of the same type 1 - addrec=>phlista(lokph)%additions -200 if(addrec%type.eq.indenmagnetic) then - addrec%nextadd=>addrec%nextadd - deallocate(addrec) - elseif(associated(addrec%nextadd)) then - addrec=>addrec%nextadd - goto 200 - endif - phlista(lokph)%additions=>newadd - endif -1000 continue - return - end subroutine add_magrec_inden - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine create_magrec_inden(addrec,aff) -! enters the magnetic model - implicit none - type(gtp_phase_add), pointer :: addrec - integer aff -!\end{verbatim} %+ - integer typty,ip,nc - character text*128 - integer, parameter :: ncc=6 - double precision coeff(ncc) - integer koder(5,ncc) - TYPE(tpfun_expression), pointer :: llow,lhigh -! - if(aff.eq.-1) then -! bcc, aff=-1 -! Magnetic function below Curie Temperature -! problem in ct1xfn to start a function with +1 or 1 - text=' 1.0-.905299383*T**(-1)-.153008346*T**3-'//& - '.00680037095*T**9-.00153008346*T**15 ;' -! write(*,*)'emm 1: ',text(1:len_trim(text)) - ip=1 - nc=ncc - call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) -! write(*,17)'emm 1B:',nc,(coeff(i),i=1,nc) -17 format(a,i3,5(1PE11.3)) - if(gx%bmperr.ne.0) goto 1000 - call ct1mexpr(nc,coeff,koder,llow) - if(gx%bmperr.ne.0) goto 1000 -! Magnetic function above Curie Temperature - text=' -.0641731208*T**(-5)-.00203724193*T**(-15)'//& - '-4.27820805E-04*T**(-25) ; ' -! write(*,*)'emm 2: ',text(1:len_trim(text)) - ip=1 - nc=ncc - call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) - if(gx%bmperr.ne.0) goto 1000 - call ct1mexpr(nc,coeff,koder,lhigh) - if(gx%bmperr.ne.0) goto 1000 - else -!------------ -! fcc, aff=-3 -! Magnetic function below Curie Temperature - text='+1.0-.860338755*T**(-1)-.17449124*T**3-.00775516624*T**9'//& - '-.0017449124*T**15 ; ' - ip=1 - nc=ncc - call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) - if(gx%bmperr.ne.0) goto 1000 - call ct1mexpr(nc,coeff,koder,llow) - if(gx%bmperr.ne.0) goto 1000 -! Magnetic function above Curie Temperature - text='-.0426902268*T**(-5)-.0013552453*T**(-15)'//& - '-2.84601512E-04*T**(-25) ; ' - ip=1 - nc=ncc - call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) - if(gx%bmperr.ne.0) goto 1000 - call ct1mexpr(nc,coeff,koder,lhigh) - if(gx%bmperr.ne.0) goto 1000 - endif -! reserve an addition record - allocate(addrec) -! store data in record - allocate(addrec%explink(2)) - nullify(addrec%nextadd) - addrec%aff=aff - addrec%type=indenmagnetic - addrec%explink(1)=llow - addrec%explink(2)=lhigh - addrecs=addrecs+1 - allocate(addrec%need_property(2)) - addrec%addrecno=addrecs - addrec%need_property=0 -! here the property list is searched for TC and BM - call need_propertyid('TC ',typty) - if(gx%bmperr.ne.0) goto 1000 - addrec%need_property(1)=typty - call need_propertyid('BMAG',typty) - if(gx%bmperr.ne.0) goto 1000 - addrec%need_property(2)=typty -1000 continue - return - end subroutine create_magrec_inden - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine calc_magnetic_inden(moded,phres,lokadd,lokph,mc,ceq) -! calculates Indens magnetic contribution -! NOTE: values for function not saved, should be done to save time. -! Gmagn = RT*f(T/Tc)*ln(beta+1) -! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2 -! phres: pointer, to phase\_varres record -! lokadd: pointer, to addition record -! lokph: integer, phase record -! mc: integer, number of constituents -! ceq: pointer, to gtp_equilibrium_data - implicit none - integer moded,lokph,mc - TYPE(gtp_phase_varres) :: phres - TYPE(gtp_phase_add), pointer :: lokadd - TYPE(gtp_equilibrium_data) :: ceq -!\end{verbatim} - integer itc,ibm,jl,noprop,ik,k,jk,j - double precision logb1,invb1,iafftc,iaffbm,rgasm,rt,tao,gmagn - double precision dtaodt,dtaodp,beta,d2taodp2,d2taodtdp,tc,tv - double precision tao2(2),ftao(6),dtao(3,mc),d2tao(mc*(mc+1)/2) - double precision addgval(6),daddgval(3,mc),d2addgval(mc*(mc+1)/2) -! phres points to result record with gval etc for this phase - TYPE(tpfun_expression), pointer :: exprot -! dgdt = Gmagn/T + RT*df/dtao*dtao/dT*ln(beta+1) -! dgdp = RT df/dtao*dtao/dP*ln(beta+1) -! dgdy = RT*df/dtao*dtao/dy*ln(beta+1) + RT*f/(beta+1)*dbeta/dy -! d2gdt2=2*R*df/dtao*dtao/dT*ln(beta+1) + RT*d2f/dtao2*(dtao/dT)**2*ln(beta+1) -! +RT*df/dtao*d2tao/dT2*ln(beta+1) -! d2gdtdp= ... -! d2gdp2= -! d2gdtdy= -! d2gdpdy= -! d2gdydy= -! listprop(1) is the number of properties calculated -! listprop(2:listprop(1)) give the typty of different properties -! calculated in gval(*,i) etc -! one has to find those with typty equal for need_property in the magnetic -! record, i.e. typty=2 for TC and typty=3 for BM -! the properties needed. -! - noprop=phres%listprop(1)-1 - itc=0; ibm=0 -! write(*,*)'25I cmi 2: ',mc,noprop,(phres%listprop(j),j=1,noprop) -! Inden magnetic need properties in need_property(1..2) - findix: do jl=2,noprop - if(phres%listprop(jl).eq.lokadd%need_property(1)) then - itc=jl - elseif(phres%listprop(jl).eq.lokadd%need_property(2)) then - ibm=jl - endif - enddo findix - if(itc.eq.0 .or. ibm.eq.0) then -! it is no error if no TC or BM but then magnetic contribution is zero -! write(*,12)phlista(lokph)%name -12 format('Warning: Magnetic addition for phase ',a& - /9x,'but no values for TC or BM, magnetic contribution zero') - goto 1000 - endif - tc=phres%gval(1,itc) - beta=phres%gval(1,ibm) -! write(*,95)'Magnetic values in: ',itc,ibm,tc,beta -!95 format(a,2i3,3(1PE15.6)) - if(tc.lt.zero) then -! we should take care of the case when tc and beta have different signs -! note: all derivatives of tc must be multiplied with iaff - iafftc=one/lokadd%aff - do ik=1,mc - do k=1,3 - phres%dgval(k,ik,itc)=iafftc*phres%dgval(k,ik,itc) - enddo - do jk=ik,mc - phres%d2gval(ixsym(ik,jk),itc)=& - iafftc*phres%d2gval(ixsym(ik,jk),itc) - enddo - enddo - do k=1,6 - phres%gval(k,itc)=iafftc*phres%gval(k,itc) - enddo - tc=phres%gval(1,itc) -! write(*,*)'Inden 1: ',tc,iafftc - else - iafftc=zero - endif -! avoid diving with zero, tc is a temperature so 0.01 degree is small - if(tc.lt.one) tc=1.0D-2 - if(beta.lt.zero) then -! note all derivatives of bm must be multipled by iaffbm -! iaffbm=one/addlista(lokadd)%aff - iaffbm=one/lokadd%aff - do ik=1,mc - do k=1,3 - phres%dgval(k,ik,ibm)=iaffbm*phres%dgval(k,ik,ibm) - enddo - do jk=ik,mc - phres%d2gval(ixsym(ik,jk),ibm)=& - iaffbm*phres%d2gval(ixsym(ik,jk),ibm) - enddo - enddo - do k=1,6 - phres%gval(k,ibm)=iaffbm*phres%gval(k,ibm) - enddo - beta=phres%gval(1,ibm) -! write(*,*)'Inden 2: ',beta,iaffbm - endif -! - tv=ceq%tpval(1) - rgasm=globaldata%rgas - rt=rgasm*tv - tao=tv/tc - tao2(1)=tao -! one should save values of ftao if tao2 is the same next time .... -! but as tc depend on the constitution that is maybe not so often. - if(tao.lt.one) then - exprot=>lokadd%explink(1) - else - exprot=>lokadd%explink(2) - endif - call ct1efn(exprot,tao2,ftao,ceq%eq_tpres) - logb1=log(beta+one) - invb1=one/(beta+one) - gmagn=rt*ftao(1)*logb1 -! if(ocv()) then -! write(*,98)'25I m1: ',tc,beta,ftao(1),logb1,rt -! write(*,98)'25I m2: ',rt*gmagn,rt*(gmagn+phres%gval(1,1)),iafftc -!98 format(a,5(1PE14.6)) -! endif -! - dtaodt=one/tc - dtaodp=-tao/tc*phres%gval(3,itc) - addgval(1)=gmagn - addgval(2)=gmagn/tv+rt*ftao(2)*dtaodt*logb1 - addgval(3)=rt*ftao(2)*dtaodp*logb1+rt*ftao(1)*invb1*phres%gval(3,ibm) - phres%gval(1,1)=phres%gval(1,1)+addgval(1)/rt - phres%gval(2,1)=phres%gval(2,1)+addgval(2)/rt - phres%gval(3,1)=phres%gval(3,1)+addgval(3)/rt -! ignore second derivatives if no derivatives wanted - if(moded.eq.0) then - goto 1000 - endif -! Now all derivatives -! phres%gval(*,itc) are TC and derivatives wrt T and P -! phres%dgval(*,*,itc) are derivatives of TC wrt T, P and Y -! phres%d2gval(*,itc) are derivatives of TC wrt Y1 and Y2 -! phres%gval(*,ibm) are beta and dervatives etc -! TC and beta must not depend on T, only on P and Y -! dtaodt=one/tc -! dtaodp=-tao/tc*phres%gval(3,itc) -! d2taodt2 is zero - d2taodtdp=-one/tc*phres%gval(3,itc) - d2taodp2=2.0d0*tao/tc**2*phres%gval(3,itc)-tao/tc*phres%gval(6,itc) -! 1-6 means F, F.T, T.P, F.T.T, F.T.P and F.P.P - addgval(4)=2.0d0*rgasm*ftao(2)*dtaodt*logb1+& - rt*ftao(4)*(dtaodt)**2*logb1 - addgval(5)=rgasm*ftao(2)*dtaodp*logb1+& - rgasm*ftao(1)*invb1*phres%gval(3,ibm)+& - rt*ftao(4)*dtaodt*dtaodp*logb1+& - rt*ftao(2)*d2taodtdp*logb1+& - rt*ftao(2)*dtaodt*invb1*phres%gval(3,ibm) - addgval(6)=rt*ftao(4)*(dtaodp)**2*logb1+& - rt*ftao(2)*d2taodp2*logb1+rt*ftao(1)*dtaodp*invb1*phres%gval(3,ibm)+& - rt*ftao(2)*dtaodp*invb1*phres%gval(3,ibm)-& - rt*ftao(1)*(invb1*phres%gval(3,ibm))**2+& - rt*ftao(1)*invb1*phres%gval(6,ibm) -! G, G.T and G.Y, G.T.Y and G.Y1.Y2 correct (no P dependence checked) - do j=1,mc - dtao(1,j)=-tao*phres%dgval(1,j,itc)/tc - dtao(2,j)=-phres%dgval(1,j,itc)/tc**2 - dtao(3,j)=2.0d0*tao*phres%gval(3,itc)*phres%dgval(1,j,itc)/tc**2-& - tao*phres%dgval(3,j,itc)/tc - do k=j,mc - d2tao(ixsym(j,k))=& - 2.0*tao*phres%dgval(1,j,itc)*phres%dgval(1,k,itc)/tc**2& - -tao*phres%d2gval(ixsym(j,k),itc)/tc - enddo - enddo - do j=1,mc -! first derivative wrt Y, checked for bcc in Cr-Fe-Mo, error in fcc in c-cr-fe? - daddgval(1,j)=rt*ftao(2)*dtao(1,j)*logb1+& - rt*ftao(1)*invb1*phres%dgval(1,j,ibm) -! write(*,43)j,daddgval(1,j),dtao(1,j),phres%dgval(1,j,ibm) -!43 format('Inden 4: ',i2,6(1pe12.5)) -! second derivative wrt to T and Y, checked - daddgval(2,j)=rgasm*ftao(2)*dtao(1,j)*logb1+& - rgasm*ftao(1)*invb1*phres%dgval(1,j,ibm)+& - rt*ftao(4)*dtaodt*dtao(1,j)*logb1+& - rt*ftao(2)*dtao(2,j)*logb1+& - rt*ftao(2)*dtaodt*invb1*phres%dgval(1,j,ibm) -! write(*,56)rgasm*ftao(2)*dtao(1,j)*logb1,& -! rgasm*ftao(1)*invb1*phres%dgval(1,j,ibm),& -! rt*ftao(4)*dtaodt*dtao(1,j)*logb1,& -! rgasm*ftao(2)*dtao(2,j)*logb1,& -! rt*ftao(2)*dtaodt*invb1*phres%dgval(1,j,ibm) -!56 format('calcmag : ',5(1PE13.5)) -! second derivative wrt P and Y, no P dependence - daddgval(3,j)=rt*ftao(4)*dtaodp*dtao(1,j)*logb1+& - rt*ftao(2)*dtao(3,j)*logb1+& - rt*ftao(2)*dtao(1,j)*invb1*phres%gval(3,ibm)-& - rt*ftao(1)*invb1**2*phres%gval(3,ibm)*phres%dgval(1,j,ibm)+& - rt*ftao(1)*invb1*phres%dgval(3,j,ibm) - do k=j,mc -! second derivatives wrt Y1 and Y2, wrong - d2addgval(ixsym(j,k))=rt*ftao(4)*dtao(1,j)*dtao(1,k)*logb1+& - rt*ftao(2)*d2tao(ixsym(j,k))*logb1+& - rt*ftao(2)*dtao(1,j)*invb1*phres%dgval(1,k,ibm)+& - rt*ftao(2)*dtao(1,k)*invb1*phres%dgval(1,j,ibm)-& - rt*ftao(1)*invb1**2*phres%dgval(1,j,ibm)*phres%dgval(1,k,ibm)+& - rt*ftao(1)*invb1*phres%d2gval(ixsym(j,k),ibm) -! write(*,57)rt*ftao(4)*dtao(1,j)*dtao(1,k)*logb1,& -! rt*ftao(2)*d2tao(ixsym(j,k))*logb1,& -! rt*ftao(2)*dtao(1,j)*invb1*phres%dgval(1,k,ibm),& -! rt*ftao(2)*dtao(1,k)*invb1*phres%dgval(1,j,ibm),& -! -rt*ftao(1)*invb1**2*phres%dgval(1,j,ibm)*phres%dgval(1,k,ibm),& -! rt*ftao(1)*invb1*phres%d2gval(ixsym(j,k),ibm) -!57 format('mag2y: ',6(1PE12.4)) - enddo - enddo -! now add all to the total G and its derivatives -! something wrong here, j should go from 1 to 9 in my fenix case ... - do j=1,mc -! write(*,99)'magadd 1: ',1,j,phres%dgval(1,j,1),daddgval(1,j)/rt - do k=1,3 -! first derivatives - phres%dgval(k,j,1)=phres%dgval(k,j,1)+daddgval(k,j)/rt - enddo -99 format(a,2i3,2(1pe16.8)) - do k=j,mc -! second derivatives -! write(*,99)'magadd 2: ',k,j,rt*phres%d2gval(ixsym(j,k),1),& -! d2addgval(ixsym(j,k)) - phres%d2gval(ixsym(j,k),1)=phres%d2gval(ixsym(j,k),1)+& - d2addgval(ixsym(j,k))/rt - enddo - enddo -! write(*,*)'cm 7: ',phres%gval(1,1),addgval(1)/rt -! note phres%gval(1..3,1) already calculated above - do j=4,6 - phres%gval(j,1)=phres%gval(j,1)+addgval(j)/rt - enddo -1000 continue - return - end subroutine calc_magnetic_inden - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine create_weimagnetic(addrec,bcc) -! adds a wei type magnetic record, we must separate fcc and bcc but no aff!! -! copied from Inden magnetic model -! The difference is that it uses TCA for Curie temperature and TNA for Neel -! and individual Bohr magneton numbers - implicit none - logical bcc - type(gtp_phase_add), pointer :: addrec -!\end{verbatim} %+ - integer typty,ip,nc - character text*128 - integer, parameter :: ncc=6 - double precision coeff(ncc) - integer koder(5,ncc) - TYPE(tpfun_expression), pointer :: llow,lhigh -! - if(bcc) then -! Magnetic function below Curie Temperature -! problem in ct1xfn to start a function with +1 or 1 - text=' 1.0-.905299383*T**(-1)-.153008346*T**3-'//& - '.00680037095*T**9-.00153008346*T**15 ;' -! write(*,*)'emm 1: ',text(1:len_trim(text)) - ip=1 - nc=ncc - call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) -! write(*,17)'emm 1B:',nc,(coeff(i),i=1,nc) -17 format(a,i3,5(1PE11.3)) - if(gx%bmperr.ne.0) goto 1000 - call ct1mexpr(nc,coeff,koder,llow) - if(gx%bmperr.ne.0) goto 1000 -! Magnetic function above Curie Temperature - text=' -.0641731208*T**(-5)-.00203724193*T**(-15)'//& - '-4.27820805E-04*T**(-25) ; ' -! write(*,*)'emm 2: ',text(1:len_trim(text)) - ip=1 - nc=ncc - call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) - if(gx%bmperr.ne.0) goto 1000 - call ct1mexpr(nc,coeff,koder,lhigh) - if(gx%bmperr.ne.0) goto 1000 - else -!------------ -! fcc -! Magnetic function below Curie Temperature - text='+1.0-.860338755*T**(-1)-.17449124*T**3-.00775516624*T**9'//& - '-.0017449124*T**15 ; ' - ip=1 - nc=ncc - call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) - if(gx%bmperr.ne.0) goto 1000 - call ct1mexpr(nc,coeff,koder,llow) - if(gx%bmperr.ne.0) goto 1000 -! Magnetic function above Curie Temperature - text='-.0426902268*T**(-5)-.0013552453*T**(-15)'//& - '-2.84601512E-04*T**(-25) ; ' - ip=1 - nc=ncc - call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) - if(gx%bmperr.ne.0) goto 1000 - call ct1mexpr(nc,coeff,koder,lhigh) - if(gx%bmperr.ne.0) goto 1000 - endif -! reserve an addition record - allocate(addrec) -! store data in record - allocate(addrec%explink(2)) - nullify(addrec%nextadd) - addrec%type=weimagnetic - addrec%explink(1)=llow - addrec%explink(2)=lhigh - addrecs=addrecs+1 - allocate(addrec%need_property(3)) - addrec%addrecno=addrecs -! here the property list is searched for CTA, NTA and IBM - call need_propertyid('CTA ',typty) - if(gx%bmperr.ne.0) goto 1000 - addrec%need_property(1)=typty - call need_propertyid('IBM ',typty) - if(gx%bmperr.ne.0) goto 1000 - addrec%need_property(2)=typty -! NTA is not so important, anti-magnetic contributions usually small - call need_propertyid('NTA ',typty) - if(gx%bmperr.ne.0) then - gx%bmperr=0 - addrec%need_property(3)=0 - else - addrec%need_property(3)=typty - endif -1000 continue - return - end subroutine create_weimagnetic - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine calc_weimagnetic(moded,phres,lokadd,lokph,mc,ceq) -! calculates Wei-Indens magnetic contribution -! -! NOTE this is just copied from Inden subroutine, must be changed -! -! Gmagn = RT*f(T/Tc)*ln(beta+1) -! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2 -! phres: pointer, to phase\_varres record -! lokadd: pointer, to addition record -! lokph: integer, phase record -! mc: integer, number of constituents -! ceq: pointer, to gtp_equilibrium_data - implicit none - integer moded,lokph,mc -! phres points to result record with gval etc for this phase - TYPE(gtp_phase_varres) :: phres - TYPE(gtp_phase_add), pointer :: lokadd - TYPE(gtp_equilibrium_data) :: ceq -!\end{verbatim} - integer itc,ibm,jl,noprop,ik,k,jk,j - double precision logb1,invb1,iafftc,iaffbm,rgasm,rt,tao,gmagn - double precision dtaodt,dtaodp,beta,d2taodp2,d2taodtdp,tc,tv - double precision tao2(2),ftao(6),dtao(3,mc),d2tao(mc*(mc+1)/2) - double precision addgval(6),daddgval(3,mc),d2addgval(mc*(mc+1)/2) - TYPE(tpfun_expression), pointer :: exprot -! dgdt = Gmagn/T + RT*df/dtao*dtao/dT*ln(beta+1) -! dgdp = RT df/dtao*dtao/dP*ln(beta+1) -! dgdy = RT*df/dtao*dtao/dy*ln(beta+1) + RT*f/(beta+1)*dbeta/dy -! d2gdt2=2*R*df/dtao*dtao/dT*ln(beta+1) + RT*d2f/dtao2*(dtao/dT)**2*ln(beta+1) -! +RT*df/dtao*d2tao/dT2*ln(beta+1) -! d2gdtdp= ... -! d2gdp2= -! d2gdtdy= -! d2gdpdy= -! d2gdydy= -! listprop(1) is the number of properties calculated -! listprop(2:listprop(1)) give the typty of different properties -! calculated in gval(*,i) etc -! one has to find those with typty equal for need_property in the magnetic -! record, i.e. typty=2 for TC and typty=3 for BM -! the properties needed. -! - noprop=phres%listprop(1)-1 - itc=0; ibm=0 -! write(*,*)'cmi 2: ',noprop,(phres%listprop(i),i=1,noprop) -! Inden magnetic need properties in need_property(1..2) - findix: do jl=2,noprop - if(phres%listprop(jl).eq.lokadd%need_property(1)) then - itc=jl - elseif(phres%listprop(jl).eq.lokadd%need_property(2)) then - ibm=jl - endif - enddo findix - if(itc.eq.0 .or. ibm.eq.0) then -! it is no error if no TC or BM but then magnetic contribution is zero -! write(*,12)phlista(lokph)%name -12 format('Warning: Magnetic addition for phase ',a& - /9x,'but no values for TC or BM, magnetic contribution zero') - goto 1000 - endif - tc=phres%gval(1,itc) - beta=phres%gval(1,ibm) -! write(*,95)'Magnetic values in: ',itc,ibm,tc,beta -!95 format(a,2i3,3(1PE15.6)) - if(tc.lt.zero) then -! we should take care of the case when tc and beta have different signs -! note: all derivatives of tc must be multiplied with iaff - iafftc=one/lokadd%aff - do ik=1,mc - do k=1,3 - phres%dgval(k,ik,itc)=iafftc*phres%dgval(k,ik,itc) - enddo - do jk=ik,mc - phres%d2gval(ixsym(ik,jk),itc)=& - iafftc*phres%d2gval(ixsym(ik,jk),itc) - enddo - enddo - do k=1,6 - phres%gval(k,itc)=iafftc*phres%gval(k,itc) - enddo - tc=phres%gval(1,itc) -! write(*,*)'Inden 1: ',tc,iafftc - endif -! avoid diving with zero, tc is a temperature so 0.01 degree is small - if(tc.lt.one) tc=1.0D-2 - if(beta.lt.zero) then -! note all derivatives of bm must be multipled by iaffbm -! iaffbm=one/addlista(lokadd)%aff - iaffbm=one/lokadd%aff - do ik=1,mc - do k=1,3 - phres%dgval(k,ik,ibm)=iaffbm*phres%dgval(k,ik,ibm) - enddo - do jk=ik,mc - phres%d2gval(ixsym(ik,jk),ibm)=& - iaffbm*phres%d2gval(ixsym(ik,jk),ibm) - enddo - enddo - do k=1,6 - phres%gval(k,ibm)=iaffbm*phres%gval(k,ibm) - enddo - beta=phres%gval(1,ibm) -! write(*,*)'Inden 2: ',beta,iaffbm - endif -! - tv=ceq%tpval(1) - rgasm=globaldata%rgas - rt=rgasm*tv - tao=tv/tc - tao2(1)=tao -! one should save values of ftao if tao2 is the same next time .... -! but as tc depend on the constitution that is maybe not so often. - if(tao.lt.one) then - exprot=>lokadd%explink(1) - else - exprot=>lokadd%explink(2) - endif - call ct1efn(exprot,tao2,ftao,ceq%eq_tpres) - logb1=log(beta+one) - invb1=one/(beta+one) - gmagn=rt*ftao(1)*logb1 -! write(*,98)'cm 97: ',tc,beta,ftao(1),logb1,rt -! write(*,98)'cm 98: ',rt*gmagn,rt*(gmagn+phres%gval(1,1)),tcx,iafftc -!98 format(a,5(1PE14.6)) -! - dtaodt=one/tc - dtaodp=-tao/tc*phres%gval(3,itc) - addgval(1)=gmagn - addgval(2)=gmagn/tv+rt*ftao(2)*dtaodt*logb1 - addgval(3)=rt*ftao(2)*dtaodp*logb1+rt*ftao(1)*invb1*phres%gval(3,ibm) - phres%gval(1,1)=phres%gval(1,1)+addgval(1)/rt - phres%gval(2,1)=phres%gval(2,1)+addgval(2)/rt - phres%gval(3,1)=phres%gval(3,1)+addgval(3)/rt -! ignore second derivatives if no derivatives wanted - if(moded.eq.0) then - goto 1000 - endif -! Now all derivatives -! phres%gval(*,itc) are TC and derivatives wrt T and P -! phres%dgval(*,*,itc) are derivatives of TC wrt T, P and Y -! phres%d2gval(*,itc) are derivatives of TC wrt Y1 and Y2 -! phres%gval(*,ibm) are beta and dervatives etc -! TC and beta must not depend on T, only on P and Y -! dtaodt=one/tc -! dtaodp=-tao/tc*phres%gval(3,itc) -! d2taodt2 is zero - d2taodtdp=-one/tc*phres%gval(3,itc) - d2taodp2=2.0d0*tao/tc**2*phres%gval(3,itc)-tao/tc*phres%gval(6,itc) -! 1-6 means F, F.T, T.P, F.T.T, F.T.P and F.P.P - addgval(4)=2.0d0*rgasm*ftao(2)*dtaodt*logb1+& - rt*ftao(4)*(dtaodt)**2*logb1 - addgval(5)=rgasm*ftao(2)*dtaodp*logb1+& - rgasm*ftao(1)*invb1*phres%gval(3,ibm)+& - rt*ftao(4)*dtaodt*dtaodp*logb1+& - rt*ftao(2)*d2taodtdp*logb1+& - rt*ftao(2)*dtaodt*invb1*phres%gval(3,ibm) - addgval(6)=rt*ftao(4)*(dtaodp)**2*logb1+& - rt*ftao(2)*d2taodp2*logb1+rt*ftao(1)*dtaodp*invb1*phres%gval(3,ibm)+& - rt*ftao(2)*dtaodp*invb1*phres%gval(3,ibm)-& - rt*ftao(1)*(invb1*phres%gval(3,ibm))**2+& - rt*ftao(1)*invb1*phres%gval(6,ibm) -! G, G.T and G.Y, G.T.Y and G.Y1.Y2 correct (no P dependence checked) - do j=1,mc - dtao(1,j)=-tao*phres%dgval(1,j,itc)/tc - dtao(2,j)=-phres%dgval(1,j,itc)/tc**2 - dtao(3,j)=2.0d0*tao*phres%gval(3,itc)*phres%dgval(1,j,itc)/tc**2-& - tao*phres%dgval(3,j,itc)/tc - do k=j,mc - d2tao(ixsym(j,k))=& - 2.0*tao*phres%dgval(1,j,itc)*phres%dgval(1,k,itc)/tc**2& - -tao*phres%d2gval(ixsym(j,k),itc)/tc - enddo - enddo - do j=1,mc -! first derivative wrt Y, checked for bcc in Cr-Fe-Mo, error in fcc in c-cr-fe? - daddgval(1,j)=rt*ftao(2)*dtao(1,j)*logb1+& - rt*ftao(1)*invb1*phres%dgval(1,j,ibm) -! write(*,43)j,daddgval(1,j),dtao(1,j),phres%dgval(1,j,ibm) -!43 format('Inden 4: ',i2,6(1pe12.5)) -! second derivative wrt to T and Y, checked - daddgval(2,j)=rgasm*ftao(2)*dtao(1,j)*logb1+& - rgasm*ftao(1)*invb1*phres%dgval(1,j,ibm)+& - rt*ftao(4)*dtaodt*dtao(1,j)*logb1+& - rt*ftao(2)*dtao(2,j)*logb1+& - rt*ftao(2)*dtaodt*invb1*phres%dgval(1,j,ibm) -! write(*,56)rgasm*ftao(2)*dtao(1,j)*logb1,& -! rgasm*ftao(1)*invb1*phres%dgval(1,j,ibm),& -! rt*ftao(4)*dtaodt*dtao(1,j)*logb1,& -! rgasm*ftao(2)*dtao(2,j)*logb1,& -! rt*ftao(2)*dtaodt*invb1*phres%dgval(1,j,ibm) -!56 format('calcmag : ',5(1PE13.5)) -! second derivative wrt P and Y, no P dependence - daddgval(3,j)=rt*ftao(4)*dtaodp*dtao(1,j)*logb1+& - rt*ftao(2)*dtao(3,j)*logb1+& - rt*ftao(2)*dtao(1,j)*invb1*phres%gval(3,ibm)-& - rt*ftao(1)*invb1**2*phres%gval(3,ibm)*phres%dgval(1,j,ibm)+& - rt*ftao(1)*invb1*phres%dgval(3,j,ibm) - do k=j,mc -! second derivatives wrt Y1 and Y2, wrong - d2addgval(ixsym(j,k))=rt*ftao(4)*dtao(1,j)*dtao(1,k)*logb1+& - rt*ftao(2)*d2tao(ixsym(j,k))*logb1+& - rt*ftao(2)*dtao(1,j)*invb1*phres%dgval(1,k,ibm)+& - rt*ftao(2)*dtao(1,k)*invb1*phres%dgval(1,j,ibm)-& - rt*ftao(1)*invb1**2*phres%dgval(1,j,ibm)*phres%dgval(1,k,ibm)+& - rt*ftao(1)*invb1*phres%d2gval(ixsym(j,k),ibm) -! write(*,57)rt*ftao(4)*dtao(1,j)*dtao(1,k)*logb1,& -! rt*ftao(2)*d2tao(ixsym(j,k))*logb1,& -! rt*ftao(2)*dtao(1,j)*invb1*phres%dgval(1,k,ibm),& -! rt*ftao(2)*dtao(1,k)*invb1*phres%dgval(1,j,ibm),& -! -rt*ftao(1)*invb1**2*phres%dgval(1,j,ibm)*phres%dgval(1,k,ibm),& -! rt*ftao(1)*invb1*phres%d2gval(ixsym(j,k),ibm) -!57 format('mag2y: ',6(1PE12.4)) - enddo - enddo -! now add all to the total G - do j=1,mc - do k=1,3 -! write(*,99)'magadd 1: ',k,j,rt*phres%dgval(k,j,1),daddgval(k,j) - phres%dgval(k,j,1)=phres%dgval(k,j,1)+daddgval(k,j)/rt - enddo -!99 format(a,2i3,2(1pe16.8)) - do k=j,mc -! write(*,99)'magadd 2: ',k,j,rt*phres%d2gval(ixsym(j,k),1),& -! d2addgval(ixsym(j,k)) - phres%d2gval(ixsym(j,k),1)=phres%d2gval(ixsym(j,k),1)+& - d2addgval(ixsym(j,k))/rt - enddo - enddo -! write(*,*)'cm 7: ',rt*phres%gval(1,1),addgval(1) -! note phres%gval(1..3,1) already calculated above - do j=4,6 - phres%gval(j,1)=phres%gval(j,1)+addgval(j)/rt - enddo -1000 continue - return - end subroutine calc_weimagnetic - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine create_elastic_model_a(newadd) -! addition record to calculate the elastic energy contribution - implicit none - type(gtp_phase_add), pointer :: newadd -!\end{verbatim} %+ - integer typty - allocate(newadd) - newadd%type=elasticmodela - allocate(newadd%need_property(5)) -! needed properties - newadd%need_property=0 - call need_propertyid('LPX ',typty) - if(gx%bmperr.ne.0) goto 1000 - newadd%need_property(1)=typty - call need_propertyid('EC11',typty) - if(gx%bmperr.ne.0) goto 1000 - newadd%need_property(2)=typty - call need_propertyid('EC12',typty) - if(gx%bmperr.ne.0) goto 1000 - newadd%need_property(3)=typty - call need_propertyid('EC44',typty) - if(gx%bmperr.ne.0) goto 1000 - newadd%need_property(4)=typty - call need_propertyid('LPTH',typty) - if(gx%bmperr.ne.0) goto 1000 - newadd%need_property(5)=typty -! now elastica is declared as pointer, is that OK? - allocate(newadd%elastica) -1000 continue - return - end subroutine create_elastic_model_a - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine calc_elastica(moded,phres,addrec,lokph,mc,ceq) -! calculates elastic contribution and adds to G and derivatives - implicit none - integer moded,lokph,mc - type(gtp_phase_varres), pointer :: phres - type(gtp_phase_add), pointer :: addrec - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} %+ - integer jl,ilpx,ilpth,iec11,iec12,iec44,noprop,i1,i2 - double precision sum1,sum2 -! get the current lattice parameters and elastic constants - ilpx=0; ilpth=0; iec11=0; iec12=0; iec44=0 - noprop=phres%listprop(1)-1 - findix: do jl=2,noprop - if(phres%listprop(jl).eq.addrec%need_property(1)) then - ilpx=jl - elseif(phres%listprop(jl).eq.addrec%need_property(2)) then - iec11=jl - elseif(phres%listprop(jl).eq.addrec%need_property(3)) then - iec12=jl - elseif(phres%listprop(jl).eq.addrec%need_property(4)) then - iec44=jl - elseif(phres%listprop(jl).eq.addrec%need_property(5)) then -! this one may not be needed initially at least - ilpth=jl - endif - enddo findix - if(ilpx.eq.0 .or. iec11.eq.0 .or. iec12.eq.0 .or. iec44.eq.0) then - write(*,11)'Missing elastic parameter index: ',ilpx,iec11,iec12,iec44 -11 format(a,5i4) - endif -! write(*,11)'25I indices: ',ilpx,iec11,iec12,iec44 -! take care of the special elastic record -! ignore compsition derivatives at present ... -! elastic constant matrix, Voigt notation, symetric - addrec%elastica%cmat=zero - addrec%elastica%cmat(1,1)=phres%gval(1,iec11) - addrec%elastica%cmat(2,2)=phres%gval(1,iec11) - addrec%elastica%cmat(3,3)=phres%gval(1,iec11) - addrec%elastica%cmat(4,4)=phres%gval(1,iec44) - addrec%elastica%cmat(5,5)=phres%gval(1,iec44) - addrec%elastica%cmat(6,6)=phres%gval(1,iec44) - addrec%elastica%cmat(1,2)=phres%gval(1,iec12) - addrec%elastica%cmat(1,3)=phres%gval(1,iec12) - addrec%elastica%cmat(2,3)=phres%gval(1,iec12) - addrec%elastica%cmat(2,1)=phres%gval(1,iec12) - addrec%elastica%cmat(3,1)=phres%gval(1,iec12) - addrec%elastica%cmat(3,2)=phres%gval(1,iec12) -! write(*,22)phres%gval(1,iec11),phres%gval(1,iec12),phres%gval(1,iec44) -22 format('Elastic constants: ',3(1pe12.4)) -! write(*,19)(addrec%elastica%cmat(1,i1),i1=1,6) -! write(*,19)(addrec%elastica%cmat(2,i1),i1=1,6) -! write(*,19)(addrec%elastica%cmat(3,i1),i1=1,6) -! write(*,19)(addrec%elastica%cmat(4,i1),i1=1,6) -! write(*,19)(addrec%elastica%cmat(5,i1),i1=1,6) -! write(*,19)(addrec%elastica%cmat(6,i1),i1=1,6) -19 format('CIJ: ',6(1pe12.4)) -!.................... -! equilibrium lattice constant (cubic, just diagonal) - addrec%elastica%latticepar=zero - addrec%elastica%latticepar(1,1)=phres%gval(1,ilpx) - addrec%elastica%latticepar(2,2)=phres%gval(1,ilpx) - addrec%elastica%latticepar(3,3)=phres%gval(1,ilpx) -! write(*,23)'Lattice parameter: ',phres%gval(1,ilpx) -!.................... -! The equilibrium lattice distances are in LPX (cubic lattice) -! The current lattice parameters are in ceq%phres%curlat(3,3) -! generate epsa, Voigt notation -! write(*,23)'curlat 1: ',(phres%curlat(i1,1),i1=1,3) -! write(*,23)'curlat 2: ',(phres%curlat(i1,2),i1=1,3) -! write(*,23)'curlat 3: ',(phres%curlat(i1,3),i1=1,3) -23 format(a,3(1pe12.4)) - addrec%elastica%epsa(1)=(phres%curlat(1,1)-addrec%elastica%latticepar(1,1))& - /addrec%elastica%latticepar(1,1) - addrec%elastica%epsa(2)=(phres%curlat(2,2)-addrec%elastica%latticepar(2,2))& - /addrec%elastica%latticepar(2,2) - addrec%elastica%epsa(3)=(phres%curlat(3,3)-addrec%elastica%latticepar(3,3))& - /addrec%elastica%latticepar(3,3) -! as addrec%elastica%latticepar(2,3) is zero for cubic use (1,1) - addrec%elastica%epsa(4)=& - (2*(phres%curlat(2,3)-addrec%elastica%latticepar(2,3)))& - /addrec%elastica%latticepar(1,1) - addrec%elastica%epsa(5)=& - (2*(phres%curlat(1,3)-addrec%elastica%latticepar(1,3)))& - /addrec%elastica%latticepar(1,1) - addrec%elastica%epsa(6)=& - (2*(phres%curlat(1,2)-addrec%elastica%latticepar(1,2)))& - /addrec%elastica%latticepar(1,1) -! write(*,25)'ev1: ',(addrec%elastica%epsa(i1),i1=1,6) -25 format(a,6(1pe12.4)) -!.................... -! calculate the elastic energy ... I do not know how to use F08 matrix mult - sum1=zero - do i1=1,6 - sum2=zero - do i2=1,6 - sum2=sum2+addrec%elastica%cmat(i1,i2)*addrec%elastica%epsa(i2) - enddo -! write(*,23)'sum2: ',sum2 - sum1=sum1+addrec%elastica%epsa(i1)*sum2 - enddo - addrec%elastica%eeadd(1)=5.0D-1*sum1 - write(*,30)'25I: Elastic energy: ',addrec%elastica%eeadd(1) -30 format(a,1pe15.7) -! TYPE gtp_elastic_modela -! double precision, dimension(3,3) :: latticepar -! epsilon in Voigt notation -! double precision, dimension(6) :: epsa -! elastic constant matrix in Voigt notation -! double precision, dimension(6,6) :: cmat -! calculated elastic energy addition (with derivative to T and P?) -! double precision, dimension(6) :: eeadd -! maybe more -! end TYPE gtp_elastic_modela - -1000 continue - return - end subroutine calc_elastica - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine set_lattice_parameters(iph,ics,xxx,ceq) -! temporary way to set current lattice parameters for use with elastic model a - implicit none - integer iph,ics - double precision, dimension(3,3) :: xxx - type(gtp_equilibrium_data) :: ceq -!\end{verbatim} - integer lokph,lokcs - call get_phase_compset(iph,ics,lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 - ceq%phase_varres(lokcs)%curlat=xxx -! write(*,*)'25I Phase+set: ',lokph,lokcs -! write(*,23)'slp 1: ',(ceq%phase_varres(lokcs)%curlat(i1,1),i1=1,3) -! write(*,23)'slp 2: ',(ceq%phase_varres(lokcs)%curlat(i1,2),i1=1,3) -! write(*,23)'slp 3: ',(ceq%phase_varres(lokcs)%curlat(i1,3),i1=1,3) -23 format(a,3(1pe12.4)) -1000 continue - return - end subroutine set_lattice_parameters - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine create_einsteincp(newadd) - implicit none - type(gtp_phase_add), pointer :: newadd -!\end{verbatim} %+ - integer, parameter :: ncc=6 - integer typty -! -! G/RT = 3*ln( 1 - exp( THET/T ) ) -! No need to use TPFUN -! -! gtp_phase_add has variables: -! integer :: type,addrecno,aff -! integer, allocatable :: need_property -! type(tpfun_expression), dimension, pointer :: explink -! type(gtp_phase_add), pointer :: nextadd -! for spme additions one may create other records but they must have -! the variables type and nextadd -!------------------------------------------ - allocate(newadd) -! Both Einstein and Debye models use THET - newadd%type=einsteincp - call need_propertyid('THET',typty) - if(gx%bmperr.ne.0) goto 1000 - allocate(newadd%need_property(1)) - newadd%need_property(1)=typty -1000 continue - return - end subroutine create_einsteincp - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine calc_einsteincp(moded,phres,addrec,lokph,mc,ceq) -! Calculate the contibution due to Einste Cp model for low T -! moded 0, 1 or 2 -! phres all results -! addrec pointer to addition record -! lokph phase record -! mc number of variable fractions -! ceq equilibrum record -! -! G = 3*R*T*ln( 1 - exp( THET/T ) ) -! This is easier to handle inside the calc routine without TPFUN -! - implicit none - integer moded,lokph,mc - type(gtp_phase_varres), pointer :: phres - type(gtp_phase_add), pointer :: addrec - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer ith,noprop - double precision del1,del2,del3,gein,dgeindt,d2geindt2 -! - noprop=phres%listprop(1)-1 - findix: do ith=2,noprop - if(phres%listprop(ith).eq.addrec%need_property(1)) goto 100 - enddo findix - write(*,*)'No theta value. ',lokph - gx%bmperr=7777; goto 1000 -100 continue -! thet is in gval(ith,1), derivatives in dgval(*,ith,*) and d2gval(ith,*) -! G/RT = 3*ln( 1 - exp( THET/T ) ) -! NOTE DIRIVATES CALCULATED FOR G/RT - del1=phres%gval(ith,1)/ceq%tpval(1) - del2=exp(del1) - del3=1.0d0-del2 - gein=3.0D0*log(del3) - dgeindt=3.0D0*(del1/ceq%tpval(1))*(del2/del3) -! d2geindt2=3.0D0*(del1**2/ceq%tpval(1))*(del2/del3**2) - d2geindt2=dgeindt*del1/del3 -! Missing implem of derivatives wrt fractions of thet. thet cannot depend on T -1000 continue - return - end subroutine calc_einsteincp - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine create_glas_transition_modela(newadd) -! not implemented - implicit none - type(gtp_phase_add), pointer :: newadd -!\end{verbatim} - write(kou,*)'Not implemented yet'; gx%bmperr=7777 -1000 continue - return - end subroutine create_glas_transition_modela - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine create_debyecp(addrec) -! enters a record for the debye model - implicit none - type(gtp_phase_add), pointer :: addrec -!\end{verbatim} %+ - integer typty -! reserve an addition record - allocate(addrec) -! Set the type of addition and look for needed parameter properties - addrec%type=debyecp - allocate(addrec%need_property(1)) - call need_propertyid('THET',typty) - if(gx%bmperr.ne.0) goto 1000 - addrec%need_property(1)=typty -! missing things for the actual Cp function ... -! - write(kou,*)'Not implemented yet'; gx%bmperr=7777 -! -1000 continue - return - end subroutine create_debyecp - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine calc_debyecp(moded,phres,lokadd,lokph,mc,ceq) -! calculates Mauro Debye contribution -! NOTE: values for function not saved, should be done to save calculation time. -! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2 -! phres: pointer, to phase\_varres record -! lokadd: pointer, to addition record -! lokph: integer, phase record -! mc: integer, number of constituents -! ceq: pointer, to gtp_equilibrium_data - implicit none - integer moded,lokph,mc - TYPE(gtp_equilibrium_data) :: ceq - TYPE(gtp_phase_add), pointer :: lokadd - TYPE(gtp_phase_varres) :: phres -!\end{verbatim} - integer ith,noprop -! value of THET and derivatives have type ?? - noprop=phres%listprop(1)-1 -! write(*,*)'cmi 2: ',noprop,(phres%listprop(i),i=1,noprop) -! Find thet, index stored in need_property(1) - do ith=2,noprop - if(phres%listprop(ith).eq.lokadd%need_property(1)) goto 100 - enddo - write(*,*)'No Debye temperature THET',lokph - gx%bmperr=7777; goto 1000 -100 continue - write(*,*)'Not implemented yet' - gx%bmperr=7777 -1000 continue - return - end subroutine calc_debyecp - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine list_addition(unit,lokph,lokadd) -! list description of an addition for a phase on unit - implicit none - integer unit,lokph - TYPE(gtp_phase_add), pointer :: lokadd -!\end{verbatim} - integer ip - TYPE(tpfun_expression), pointer :: exprot - character line*256,tps(2)*3 - addition: select case(lokadd%type) - case default - write(unit,*)'Unknown addtion type: ',lokadd%type,lokph - case(indenmagnetic) ! Inden magnetic model - write(unit,100)lokadd%aff -100 format(2x,'+ Magnetic model by Inden, anti-ferromagntic factor:',i3,/& - 4x,'Magnetic function below the ordering temperature TC',& - ' with TAO=T/TC:') - tps(1)='TAO' - tps(2)='err' - ip=1 - line=' ' - exprot=>lokadd%explink(1) - call ct1wfn(exprot,tps,line,ip) - call wrice(unit,4,8,78,line(1:ip)) - write(unit,110) -110 format(4x,'Magnetic function above the ordering temperature TC ',& - 'with TAO=T/TC:') - ip=1 - line=' ' - exprot=>lokadd%explink(2) - call ct1wfn(exprot,tps,line,ip) - call wrice(unit,4,8,78,line(1:ip)) -!--------------------------------------------- - case(debyecp) ! Debye Cp model - write(unit,200) -200 format(2x,'+ Debye Cp model, not implemented yet') -!--------------------------------------------- - case(weimagnetic) ! Inden-Wei - write(unit,300) -300 format(2x,'+ Inden magnetic model'/& - 2x,'with separate Curie and Neel temperatures.'/& - 4x,'Magnetic function above the ordering temperature TC'& - ' with TAO=T/TC':) - tps(1)='TAO' - tps(2)='err' - ip=1 - line=' ' - exprot=>lokadd%explink(1) - call ct1wfn(exprot,tps,line,ip) - call wrice(unit,4,8,78,line(1:ip)) - write(unit,110) - ip=1 - line=' ' - exprot=>lokadd%explink(2) - call ct1wfn(exprot,tps,line,ip) - call wrice(unit,4,8,78,line(1:ip)) -!--------------------------------------------- - case(einsteincp) ! Einstein Cp model - write(unit,400) -400 format(2x,'+ Einstein Cp model:'/4x,'G = 3*R*T*LN(1-THET/T)') -!--------------------------------------------- - case(elasticmodela) ! Elastic model A - write(unit,500) -500 format(2x,'+ Elastic model A, with P interpreted as a force in',& - ' the X direction.') -!--------------------------------------------- - case(glastransmodela) ! Glas transtion model A - write(unit,*)'Glas transition model A, not implemented yet' - end select addition -1000 continue - return - end subroutine list_addition - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - +! +! gtp3H included in gtp3.F90 +! +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! +!> 14. Additions +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! +! Additions have a unique number, given sequentially as implemented +! These are all defined in gtp3.F90 +! integer, public, parameter :: indenmagnetic=1 +! integer, public, parameter :: debyecp=2 +! integer, public, parameter :: weimagnetic=3 +! integer, public, parameter :: einstaincp=4 +! integer, public, parameter :: elasticmodela=5 +! integer, public, parameter :: glastransmodela=6 +! 1 is Inden magnetic model with mixed Cuire and Neel temperatures and aff +! 2 is Debye Cp model for low T +! 3 is Inden magnetic model with separate Curie and Neel temp +! 4 is Einstein Cp model for low T +! 5 is Elastic model A +! 6 is glas transition model +!------------------------------------ +! For each addition XX there is a subroutine create_XX +! called from the add_addrecord +! and a subroutine calc_XX +! called from the addition_selector, called from calcg_internal +! There is a common list routine +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! + +!\begin{verbatim} + subroutine addition_selector(addrec,moded,phres,lokph,mc,ceq) +! called when finding an addtion record while calculating G for a phase +! addrec is addition record +! moded is 0, 1 or 2 if no, first or 2nd order derivatives should be calculated +! phres is ? +! lokph is phase location +! mc is number of constitution fractions +! ceq is current equilibrium record + implicit none + type(gtp_phase_add), pointer :: addrec + integer moded,lokph,mc + TYPE(gtp_phase_varres), pointer :: phres + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + addition: select case(addrec%type) + case default + write(kou,*)'No such addition type ',addrec%type,lokph + gx%bmperr=7777 + case(indenmagnetic) ! Inden magnetic + call calc_magnetic_inden(moded,phres,addrec,lokph,mc,ceq) + case(debyecp) ! Debye Cp + call calc_debyecp(moded,phres,addrec,lokph,mc,ceq) + write(kou,*)' Debye Cp model not implemented yet' + gx%bmperr=7777 + case(weimagnetic) ! Wei-Inden + call calc_weimagnetic(moded,phres,addrec,lokph,mc,ceq) + write(kou,*)'Inden magnetic model with sep TC and TN not implemented yet' + gx%bmperr=7777 + case(einsteincp) ! Einstein Cp + call calc_einsteincp(moded,phres,addrec,lokph,mc,ceq) + write(kou,*)' Einstein Cp model not implemented yet' + gx%bmperr=7777 + case(elasticmodela) ! Elastic model + call calc_elastica(moded,phres,addrec,lokph,mc,ceq) +! write(kou,*)' Elastic model not implemented yet' +! gx%bmperr=7777 + case(glastransmodela) ! Glas transition model + write(kou,*)' Glas transition not implemented yet' + gx%bmperr=7777 + end select addition +1000 continue + return + end subroutine addition_selector + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/! + +!\begin{verbatim} + subroutine add_addrecord(iph,addtyp) +! generic subroutine to add an addition typ addtyp (Except Inden) + implicit none + integer iph,addtyp +!\end{verbatim} + integer lokph,mc + type(gtp_phase_add), pointer :: newadd,addrec,lastrec + logical bcc +! + call get_phase_record(iph,lokph) + if(gx%bmperr.ne.0) goto 1000 + mc=phlista(lokph)%tnooffr +! create addition record + addition: select case(addtyp) + case default + write(kou,*)'No addtion type ',addtyp,lokph + case(indenmagnetic) ! Inden magnetic +! added by separate subroutine + write(kou,*)'Inden magnetic model is not added this way' + gx%bmperr=7777 + case(debyecp) ! Debye Cp + call create_debyecp(newadd) + case(weimagnetic) ! Inden-Wei. Assume bcc if BCC part of phase name + bcc=.false. + if(index('BCC',phlista(lokph)%name).gt.0) bcc=.true. + call create_weimagnetic(newadd,bcc) + case(einsteincp) ! Einstein Cp + call create_einsteincp(newadd) + case(elasticmodela) ! Elastic model A + call create_elastic_model_a(newadd) + case(glastransmodela) ! Glas transition model A + call create_glas_transition_modela(newadd) + end select addition + if(gx%bmperr.ne.0) goto 1000 +! check if there are other additions +! write(*,*)'3H: adding addition: ',newadd%type,addtyp + if(.not.associated(phlista(lokph)%additions)) then + phlista(lokph)%additions=>newadd +! write(*,*)'3H: added as first addition: ',newadd%type + else +! remove any previous addition of the same type + nullify(lastrec) + addrec=>phlista(lokph)%additions +200 if(addrec%type.eq.addtyp) then + write(*,*)'3H: replace old addition: ',newadd%type + if(associated(lastrec)) then + lastrec%nextadd=>addrec%nextadd + deallocate(addrec) + else + phlista(lokph)%additions=>newadd + newadd%nextadd=>addrec%nextadd + goto 1000 + endif + elseif(associated(addrec%nextadd)) then + addrec=>addrec%nextadd + goto 200 + endif +! write(*,*)'3H: Insering as first addition: ',newadd%type + newadd%nextadd=>phlista(lokph)%additions + phlista(lokph)%additions=>newadd + endif +1000 return + end subroutine add_addrecord + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine need_propertyid(id,typty) +! get the index of the property needed + implicit none + integer typty + character*4 id +!\end{verbatim} +! here the property list is searched for "id" and its index stored in addrec + do typty=1,ndefprop + if(propid(typty)%symbol.eq.id) then + goto 1000 + endif + enddo + write(*,*)'Parameter id ',id,' not found' + gx%bmperr=7777 + typty=-1 +1000 continue + return + end subroutine need_propertyid + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine add_magrec_inden(lokph,addtyp,aff) +! adds a magnetic record to lokph +! lokph is phase location +! addtyp should be 1 of Inden model +! aff is antiferromagnic factor, -1 for bcc and -3 for fcc and hcp + implicit none + integer lokph,addtyp,aff +!\end{verbatim} %+ + integer mc + type(gtp_phase_add), pointer :: newadd,addrec + mc=phlista(lokph)%tnooffr +! create addition record + call create_magrec_inden(newadd,aff) + if(gx%bmperr.ne.0) goto 1000 +! check if there are other additions + if(.not.associated(phlista(lokph)%additions)) then + phlista(lokph)%additions=>newadd + else +! remove any previous addition of the same type 1 + addrec=>phlista(lokph)%additions +200 if(addrec%type.eq.indenmagnetic) then + addrec%nextadd=>addrec%nextadd + deallocate(addrec) + elseif(associated(addrec%nextadd)) then + addrec=>addrec%nextadd + goto 200 + endif + phlista(lokph)%additions=>newadd + endif +1000 continue + return + end subroutine add_magrec_inden + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine create_magrec_inden(addrec,aff) +! enters the magnetic model + implicit none + type(gtp_phase_add), pointer :: addrec + integer aff +!\end{verbatim} %+ + integer typty,ip,nc + character text*128 + integer, parameter :: ncc=6 + double precision coeff(ncc) + integer koder(5,ncc) + TYPE(tpfun_expression), pointer :: llow,lhigh +! + if(aff.eq.-1) then +! bcc, aff=-1 +! Magnetic function below Curie Temperature +! problem in ct1xfn to start a function with +1 or 1 + text=' 1.0-.905299383*T**(-1)-.153008346*T**3-'//& + '.00680037095*T**9-.00153008346*T**15 ;' +! write(*,*)'emm 1: ',text(1:len_trim(text)) + ip=1 + nc=ncc + call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) +! write(*,17)'emm 1B:',nc,(coeff(i),i=1,nc) +17 format(a,i3,5(1PE11.3)) + if(gx%bmperr.ne.0) goto 1000 + call ct1mexpr(nc,coeff,koder,llow) + if(gx%bmperr.ne.0) goto 1000 +! Magnetic function above Curie Temperature + text=' -.0641731208*T**(-5)-.00203724193*T**(-15)'//& + '-4.27820805E-04*T**(-25) ; ' +! write(*,*)'emm 2: ',text(1:len_trim(text)) + ip=1 + nc=ncc + call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) + if(gx%bmperr.ne.0) goto 1000 + call ct1mexpr(nc,coeff,koder,lhigh) + if(gx%bmperr.ne.0) goto 1000 + else +!------------ +! fcc, aff=-3 +! Magnetic function below Curie Temperature + text='+1.0-.860338755*T**(-1)-.17449124*T**3-.00775516624*T**9'//& + '-.0017449124*T**15 ; ' + ip=1 + nc=ncc + call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) + if(gx%bmperr.ne.0) goto 1000 + call ct1mexpr(nc,coeff,koder,llow) + if(gx%bmperr.ne.0) goto 1000 +! Magnetic function above Curie Temperature + text='-.0426902268*T**(-5)-.0013552453*T**(-15)'//& + '-2.84601512E-04*T**(-25) ; ' + ip=1 + nc=ncc + call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) + if(gx%bmperr.ne.0) goto 1000 + call ct1mexpr(nc,coeff,koder,lhigh) + if(gx%bmperr.ne.0) goto 1000 + endif +! reserve an addition record + allocate(addrec) +! store data in record + allocate(addrec%explink(2)) + nullify(addrec%nextadd) + addrec%aff=aff + addrec%type=indenmagnetic + addrec%explink(1)=llow + addrec%explink(2)=lhigh + addrecs=addrecs+1 + allocate(addrec%need_property(2)) + addrec%addrecno=addrecs + addrec%need_property=0 +! here the property list is searched for TC and BM + call need_propertyid('TC ',typty) + if(gx%bmperr.ne.0) goto 1000 + addrec%need_property(1)=typty + call need_propertyid('BMAG',typty) + if(gx%bmperr.ne.0) goto 1000 + addrec%need_property(2)=typty +1000 continue + return + end subroutine create_magrec_inden + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine calc_magnetic_inden(moded,phres,lokadd,lokph,mc,ceq) +! calculates Indens magnetic contribution +! NOTE: values for function not saved, should be done to save time. +! Gmagn = RT*f(T/Tc)*ln(beta+1) +! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2 +! phres: pointer, to phase\_varres record +! lokadd: pointer, to addition record +! lokph: integer, phase record +! mc: integer, number of constituents +! ceq: pointer, to gtp_equilibrium_data + implicit none + integer moded,lokph,mc + TYPE(gtp_phase_varres) :: phres + TYPE(gtp_phase_add), pointer :: lokadd + TYPE(gtp_equilibrium_data) :: ceq +!\end{verbatim} + integer itc,ibm,jl,noprop,ik,k,jk,j + double precision logb1,invb1,iafftc,iaffbm,rgasm,rt,tao,gmagn + double precision dtaodt,dtaodp,beta,d2taodp2,d2taodtdp,tc,tv + double precision tao2(2),ftao(6),dtao(3,mc),d2tao(mc*(mc+1)/2) + double precision addgval(6),daddgval(3,mc),d2addgval(mc*(mc+1)/2) +! phres points to result record with gval etc for this phase + TYPE(tpfun_expression), pointer :: exprot +! dgdt = Gmagn/T + RT*df/dtao*dtao/dT*ln(beta+1) +! dgdp = RT df/dtao*dtao/dP*ln(beta+1) +! dgdy = RT*df/dtao*dtao/dy*ln(beta+1) + RT*f/(beta+1)*dbeta/dy +! d2gdt2=2*R*df/dtao*dtao/dT*ln(beta+1) + RT*d2f/dtao2*(dtao/dT)**2*ln(beta+1) +! +RT*df/dtao*d2tao/dT2*ln(beta+1) +! d2gdtdp= ... +! d2gdp2= +! d2gdtdy= +! d2gdpdy= +! d2gdydy= +! listprop(1) is the number of properties calculated +! listprop(2:listprop(1)) give the typty of different properties +! calculated in gval(*,i) etc +! one has to find those with typty equal for need_property in the magnetic +! record, i.e. typty=2 for TC and typty=3 for BM +! the properties needed. +! + noprop=phres%listprop(1)-1 + itc=0; ibm=0 +! write(*,*)'3H cmi 2: ',mc,noprop,(phres%listprop(j),j=1,noprop) +! Inden magnetic need properties in need_property(1..2) + findix: do jl=2,noprop + if(phres%listprop(jl).eq.lokadd%need_property(1)) then + itc=jl + elseif(phres%listprop(jl).eq.lokadd%need_property(2)) then + ibm=jl + endif + enddo findix + if(itc.eq.0 .or. ibm.eq.0) then +! it is no error if no TC or BM but then magnetic contribution is zero +! write(*,12)phlista(lokph)%name +12 format('Warning: Magnetic addition for phase ',a& + /9x,'but no values for TC or BM, magnetic contribution zero') + goto 1000 + endif + tc=phres%gval(1,itc) + beta=phres%gval(1,ibm) +! write(*,95)'Magnetic values in: ',itc,ibm,tc,beta +!95 format(a,2i3,3(1PE15.6)) + if(tc.lt.zero) then +! we should take care of the case when tc and beta have different signs +! note: all derivatives of tc must be multiplied with iaff + iafftc=one/lokadd%aff + do ik=1,mc + do k=1,3 + phres%dgval(k,ik,itc)=iafftc*phres%dgval(k,ik,itc) + enddo + do jk=ik,mc + phres%d2gval(ixsym(ik,jk),itc)=& + iafftc*phres%d2gval(ixsym(ik,jk),itc) + enddo + enddo + do k=1,6 + phres%gval(k,itc)=iafftc*phres%gval(k,itc) + enddo + tc=phres%gval(1,itc) +! write(*,*)'Inden 1: ',tc,iafftc + else + iafftc=zero + endif +! avoid diving with zero, tc is a temperature so 0.01 degree is small + if(tc.lt.one) tc=1.0D-2 + if(beta.lt.zero) then +! note all derivatives of bm must be multipled by iaffbm +! iaffbm=one/addlista(lokadd)%aff + iaffbm=one/lokadd%aff + do ik=1,mc + do k=1,3 + phres%dgval(k,ik,ibm)=iaffbm*phres%dgval(k,ik,ibm) + enddo + do jk=ik,mc + phres%d2gval(ixsym(ik,jk),ibm)=& + iaffbm*phres%d2gval(ixsym(ik,jk),ibm) + enddo + enddo + do k=1,6 + phres%gval(k,ibm)=iaffbm*phres%gval(k,ibm) + enddo + beta=phres%gval(1,ibm) +! write(*,*)'Inden 2: ',beta,iaffbm + endif +! + tv=ceq%tpval(1) + rgasm=globaldata%rgas + rt=rgasm*tv + tao=tv/tc + tao2(1)=tao +! one should save values of ftao if tao2 is the same next time .... +! but as tc depend on the constitution that is maybe not so often. + if(tao.lt.one) then + exprot=>lokadd%explink(1) + else + exprot=>lokadd%explink(2) + endif + call ct1efn(exprot,tao2,ftao,ceq%eq_tpres) + logb1=log(beta+one) + invb1=one/(beta+one) + gmagn=rt*ftao(1)*logb1 +! if(ocv()) then +! write(*,98)'3H m1: ',tc,beta,ftao(1),logb1,rt +! write(*,98)'3H m2: ',rt*gmagn,rt*(gmagn+phres%gval(1,1)),iafftc +!98 format(a,5(1PE14.6)) +! endif +! + dtaodt=one/tc + dtaodp=-tao/tc*phres%gval(3,itc) + addgval(1)=gmagn + addgval(2)=gmagn/tv+rt*ftao(2)*dtaodt*logb1 + addgval(3)=rt*ftao(2)*dtaodp*logb1+rt*ftao(1)*invb1*phres%gval(3,ibm) + phres%gval(1,1)=phres%gval(1,1)+addgval(1)/rt + phres%gval(2,1)=phres%gval(2,1)+addgval(2)/rt + phres%gval(3,1)=phres%gval(3,1)+addgval(3)/rt +! ignore second derivatives if no derivatives wanted + if(moded.eq.0) then + goto 1000 + endif +! Now all derivatives +! phres%gval(*,itc) are TC and derivatives wrt T and P +! phres%dgval(*,*,itc) are derivatives of TC wrt T, P and Y +! phres%d2gval(*,itc) are derivatives of TC wrt Y1 and Y2 +! phres%gval(*,ibm) are beta and dervatives etc +! TC and beta must not depend on T, only on P and Y +! dtaodt=one/tc +! dtaodp=-tao/tc*phres%gval(3,itc) +! d2taodt2 is zero + d2taodtdp=-one/tc*phres%gval(3,itc) + d2taodp2=2.0d0*tao/tc**2*phres%gval(3,itc)-tao/tc*phres%gval(6,itc) +! 1-6 means F, F.T, T.P, F.T.T, F.T.P and F.P.P + addgval(4)=2.0d0*rgasm*ftao(2)*dtaodt*logb1+& + rt*ftao(4)*(dtaodt)**2*logb1 + addgval(5)=rgasm*ftao(2)*dtaodp*logb1+& + rgasm*ftao(1)*invb1*phres%gval(3,ibm)+& + rt*ftao(4)*dtaodt*dtaodp*logb1+& + rt*ftao(2)*d2taodtdp*logb1+& + rt*ftao(2)*dtaodt*invb1*phres%gval(3,ibm) + addgval(6)=rt*ftao(4)*(dtaodp)**2*logb1+& + rt*ftao(2)*d2taodp2*logb1+rt*ftao(1)*dtaodp*invb1*phres%gval(3,ibm)+& + rt*ftao(2)*dtaodp*invb1*phres%gval(3,ibm)-& + rt*ftao(1)*(invb1*phres%gval(3,ibm))**2+& + rt*ftao(1)*invb1*phres%gval(6,ibm) +! G, G.T and G.Y, G.T.Y and G.Y1.Y2 correct (no P dependence checked) + do j=1,mc + dtao(1,j)=-tao*phres%dgval(1,j,itc)/tc + dtao(2,j)=-phres%dgval(1,j,itc)/tc**2 + dtao(3,j)=2.0d0*tao*phres%gval(3,itc)*phres%dgval(1,j,itc)/tc**2-& + tao*phres%dgval(3,j,itc)/tc + do k=j,mc + d2tao(ixsym(j,k))=& + 2.0*tao*phres%dgval(1,j,itc)*phres%dgval(1,k,itc)/tc**2& + -tao*phres%d2gval(ixsym(j,k),itc)/tc + enddo + enddo + do j=1,mc +! first derivative wrt Y, checked for bcc in Cr-Fe-Mo, error in fcc in c-cr-fe? + daddgval(1,j)=rt*ftao(2)*dtao(1,j)*logb1+& + rt*ftao(1)*invb1*phres%dgval(1,j,ibm) +! write(*,43)j,daddgval(1,j),dtao(1,j),phres%dgval(1,j,ibm) +!43 format('Inden 4: ',i2,6(1pe12.5)) +! second derivative wrt to T and Y, checked + daddgval(2,j)=rgasm*ftao(2)*dtao(1,j)*logb1+& + rgasm*ftao(1)*invb1*phres%dgval(1,j,ibm)+& + rt*ftao(4)*dtaodt*dtao(1,j)*logb1+& + rt*ftao(2)*dtao(2,j)*logb1+& + rt*ftao(2)*dtaodt*invb1*phres%dgval(1,j,ibm) +! write(*,56)rgasm*ftao(2)*dtao(1,j)*logb1,& +! rgasm*ftao(1)*invb1*phres%dgval(1,j,ibm),& +! rt*ftao(4)*dtaodt*dtao(1,j)*logb1,& +! rgasm*ftao(2)*dtao(2,j)*logb1,& +! rt*ftao(2)*dtaodt*invb1*phres%dgval(1,j,ibm) +!56 format('calcmag : ',5(1PE13.5)) +! second derivative wrt P and Y, no P dependence + daddgval(3,j)=rt*ftao(4)*dtaodp*dtao(1,j)*logb1+& + rt*ftao(2)*dtao(3,j)*logb1+& + rt*ftao(2)*dtao(1,j)*invb1*phres%gval(3,ibm)-& + rt*ftao(1)*invb1**2*phres%gval(3,ibm)*phres%dgval(1,j,ibm)+& + rt*ftao(1)*invb1*phres%dgval(3,j,ibm) + do k=j,mc +! second derivatives wrt Y1 and Y2, wrong + d2addgval(ixsym(j,k))=rt*ftao(4)*dtao(1,j)*dtao(1,k)*logb1+& + rt*ftao(2)*d2tao(ixsym(j,k))*logb1+& + rt*ftao(2)*dtao(1,j)*invb1*phres%dgval(1,k,ibm)+& + rt*ftao(2)*dtao(1,k)*invb1*phres%dgval(1,j,ibm)-& + rt*ftao(1)*invb1**2*phres%dgval(1,j,ibm)*phres%dgval(1,k,ibm)+& + rt*ftao(1)*invb1*phres%d2gval(ixsym(j,k),ibm) +! write(*,57)rt*ftao(4)*dtao(1,j)*dtao(1,k)*logb1,& +! rt*ftao(2)*d2tao(ixsym(j,k))*logb1,& +! rt*ftao(2)*dtao(1,j)*invb1*phres%dgval(1,k,ibm),& +! rt*ftao(2)*dtao(1,k)*invb1*phres%dgval(1,j,ibm),& +! -rt*ftao(1)*invb1**2*phres%dgval(1,j,ibm)*phres%dgval(1,k,ibm),& +! rt*ftao(1)*invb1*phres%d2gval(ixsym(j,k),ibm) +!57 format('mag2y: ',6(1PE12.4)) + enddo + enddo +! now add all to the total G and its derivatives +! something wrong here, j should go from 1 to 9 in my fenix case ... + do j=1,mc +! write(*,99)'magadd 1: ',1,j,phres%dgval(1,j,1),daddgval(1,j)/rt + do k=1,3 +! first derivatives + phres%dgval(k,j,1)=phres%dgval(k,j,1)+daddgval(k,j)/rt + enddo +99 format(a,2i3,2(1pe16.8)) + do k=j,mc +! second derivatives +! write(*,99)'magadd 2: ',k,j,rt*phres%d2gval(ixsym(j,k),1),& +! d2addgval(ixsym(j,k)) + phres%d2gval(ixsym(j,k),1)=phres%d2gval(ixsym(j,k),1)+& + d2addgval(ixsym(j,k))/rt + enddo + enddo +! write(*,*)'cm 7: ',phres%gval(1,1),addgval(1)/rt +! note phres%gval(1..3,1) already calculated above + do j=4,6 + phres%gval(j,1)=phres%gval(j,1)+addgval(j)/rt + enddo +1000 continue + return + end subroutine calc_magnetic_inden + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine create_weimagnetic(addrec,bcc) +! adds a wei type magnetic record, we must separate fcc and bcc but no aff!! +! copied from Inden magnetic model +! The difference is that it uses TCA for Curie temperature and TNA for Neel +! and individual Bohr magneton numbers + implicit none + logical bcc + type(gtp_phase_add), pointer :: addrec +!\end{verbatim} %+ + integer typty,ip,nc + character text*128 + integer, parameter :: ncc=6 + double precision coeff(ncc) + integer koder(5,ncc) + TYPE(tpfun_expression), pointer :: llow,lhigh +! + if(bcc) then +! Magnetic function below Curie Temperature +! problem in ct1xfn to start a function with +1 or 1 + text=' 1.0-.905299383*T**(-1)-.153008346*T**3-'//& + '.00680037095*T**9-.00153008346*T**15 ;' +! write(*,*)'emm 1: ',text(1:len_trim(text)) + ip=1 + nc=ncc + call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) +! write(*,17)'emm 1B:',nc,(coeff(i),i=1,nc) +17 format(a,i3,5(1PE11.3)) + if(gx%bmperr.ne.0) goto 1000 + call ct1mexpr(nc,coeff,koder,llow) + if(gx%bmperr.ne.0) goto 1000 +! Magnetic function above Curie Temperature + text=' -.0641731208*T**(-5)-.00203724193*T**(-15)'//& + '-4.27820805E-04*T**(-25) ; ' +! write(*,*)'emm 2: ',text(1:len_trim(text)) + ip=1 + nc=ncc + call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) + if(gx%bmperr.ne.0) goto 1000 + call ct1mexpr(nc,coeff,koder,lhigh) + if(gx%bmperr.ne.0) goto 1000 + else +!------------ +! fcc +! Magnetic function below Curie Temperature + text='+1.0-.860338755*T**(-1)-.17449124*T**3-.00775516624*T**9'//& + '-.0017449124*T**15 ; ' + ip=1 + nc=ncc + call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) + if(gx%bmperr.ne.0) goto 1000 + call ct1mexpr(nc,coeff,koder,llow) + if(gx%bmperr.ne.0) goto 1000 +! Magnetic function above Curie Temperature + text='-.0426902268*T**(-5)-.0013552453*T**(-15)'//& + '-2.84601512E-04*T**(-25) ; ' + ip=1 + nc=ncc + call ct1xfn(text,ip,nc,coeff,koder,.FALSE.) + if(gx%bmperr.ne.0) goto 1000 + call ct1mexpr(nc,coeff,koder,lhigh) + if(gx%bmperr.ne.0) goto 1000 + endif +! reserve an addition record + allocate(addrec) +! store data in record + allocate(addrec%explink(2)) + nullify(addrec%nextadd) + addrec%type=weimagnetic + addrec%explink(1)=llow + addrec%explink(2)=lhigh + addrecs=addrecs+1 + allocate(addrec%need_property(3)) + addrec%addrecno=addrecs +! here the property list is searched for CTA, NTA and IBM + call need_propertyid('CTA ',typty) + if(gx%bmperr.ne.0) goto 1000 + addrec%need_property(1)=typty + call need_propertyid('IBM ',typty) + if(gx%bmperr.ne.0) goto 1000 + addrec%need_property(2)=typty +! NTA is not so important, anti-magnetic contributions usually small + call need_propertyid('NTA ',typty) + if(gx%bmperr.ne.0) then + gx%bmperr=0 + addrec%need_property(3)=0 + else + addrec%need_property(3)=typty + endif +1000 continue + return + end subroutine create_weimagnetic + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine calc_weimagnetic(moded,phres,lokadd,lokph,mc,ceq) +! calculates Wei-Indens magnetic contribution +! +! NOTE this is just copied from Inden subroutine, must be changed +! +! Gmagn = RT*f(T/Tc)*ln(beta+1) +! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2 +! phres: pointer, to phase\_varres record +! lokadd: pointer, to addition record +! lokph: integer, phase record +! mc: integer, number of constituents +! ceq: pointer, to gtp_equilibrium_data + implicit none + integer moded,lokph,mc +! phres points to result record with gval etc for this phase + TYPE(gtp_phase_varres) :: phres + TYPE(gtp_phase_add), pointer :: lokadd + TYPE(gtp_equilibrium_data) :: ceq +!\end{verbatim} + integer itc,ibm,jl,noprop,ik,k,jk,j + double precision logb1,invb1,iafftc,iaffbm,rgasm,rt,tao,gmagn + double precision dtaodt,dtaodp,beta,d2taodp2,d2taodtdp,tc,tv + double precision tao2(2),ftao(6),dtao(3,mc),d2tao(mc*(mc+1)/2) + double precision addgval(6),daddgval(3,mc),d2addgval(mc*(mc+1)/2) + TYPE(tpfun_expression), pointer :: exprot +! dgdt = Gmagn/T + RT*df/dtao*dtao/dT*ln(beta+1) +! dgdp = RT df/dtao*dtao/dP*ln(beta+1) +! dgdy = RT*df/dtao*dtao/dy*ln(beta+1) + RT*f/(beta+1)*dbeta/dy +! d2gdt2=2*R*df/dtao*dtao/dT*ln(beta+1) + RT*d2f/dtao2*(dtao/dT)**2*ln(beta+1) +! +RT*df/dtao*d2tao/dT2*ln(beta+1) +! d2gdtdp= ... +! d2gdp2= +! d2gdtdy= +! d2gdpdy= +! d2gdydy= +! listprop(1) is the number of properties calculated +! listprop(2:listprop(1)) give the typty of different properties +! calculated in gval(*,i) etc +! one has to find those with typty equal for need_property in the magnetic +! record, i.e. typty=2 for TC and typty=3 for BM +! the properties needed. +! + noprop=phres%listprop(1)-1 + itc=0; ibm=0 +! write(*,*)'cmi 2: ',noprop,(phres%listprop(i),i=1,noprop) +! Inden magnetic need properties in need_property(1..2) + findix: do jl=2,noprop + if(phres%listprop(jl).eq.lokadd%need_property(1)) then + itc=jl + elseif(phres%listprop(jl).eq.lokadd%need_property(2)) then + ibm=jl + endif + enddo findix + if(itc.eq.0 .or. ibm.eq.0) then +! it is no error if no TC or BM but then magnetic contribution is zero +! write(*,12)phlista(lokph)%name +12 format('Warning: Magnetic addition for phase ',a& + /9x,'but no values for TC or BM, magnetic contribution zero') + goto 1000 + endif + tc=phres%gval(1,itc) + beta=phres%gval(1,ibm) +! write(*,95)'Magnetic values in: ',itc,ibm,tc,beta +!95 format(a,2i3,3(1PE15.6)) + if(tc.lt.zero) then +! we should take care of the case when tc and beta have different signs +! note: all derivatives of tc must be multiplied with iaff + iafftc=one/lokadd%aff + do ik=1,mc + do k=1,3 + phres%dgval(k,ik,itc)=iafftc*phres%dgval(k,ik,itc) + enddo + do jk=ik,mc + phres%d2gval(ixsym(ik,jk),itc)=& + iafftc*phres%d2gval(ixsym(ik,jk),itc) + enddo + enddo + do k=1,6 + phres%gval(k,itc)=iafftc*phres%gval(k,itc) + enddo + tc=phres%gval(1,itc) +! write(*,*)'Inden 1: ',tc,iafftc + endif +! avoid diving with zero, tc is a temperature so 0.01 degree is small + if(tc.lt.one) tc=1.0D-2 + if(beta.lt.zero) then +! note all derivatives of bm must be multipled by iaffbm +! iaffbm=one/addlista(lokadd)%aff + iaffbm=one/lokadd%aff + do ik=1,mc + do k=1,3 + phres%dgval(k,ik,ibm)=iaffbm*phres%dgval(k,ik,ibm) + enddo + do jk=ik,mc + phres%d2gval(ixsym(ik,jk),ibm)=& + iaffbm*phres%d2gval(ixsym(ik,jk),ibm) + enddo + enddo + do k=1,6 + phres%gval(k,ibm)=iaffbm*phres%gval(k,ibm) + enddo + beta=phres%gval(1,ibm) +! write(*,*)'Inden 2: ',beta,iaffbm + endif +! + tv=ceq%tpval(1) + rgasm=globaldata%rgas + rt=rgasm*tv + tao=tv/tc + tao2(1)=tao +! one should save values of ftao if tao2 is the same next time .... +! but as tc depend on the constitution that is maybe not so often. + if(tao.lt.one) then + exprot=>lokadd%explink(1) + else + exprot=>lokadd%explink(2) + endif + call ct1efn(exprot,tao2,ftao,ceq%eq_tpres) + logb1=log(beta+one) + invb1=one/(beta+one) + gmagn=rt*ftao(1)*logb1 +! write(*,98)'cm 97: ',tc,beta,ftao(1),logb1,rt +! write(*,98)'cm 98: ',rt*gmagn,rt*(gmagn+phres%gval(1,1)),tcx,iafftc +!98 format(a,5(1PE14.6)) +! + dtaodt=one/tc + dtaodp=-tao/tc*phres%gval(3,itc) + addgval(1)=gmagn + addgval(2)=gmagn/tv+rt*ftao(2)*dtaodt*logb1 + addgval(3)=rt*ftao(2)*dtaodp*logb1+rt*ftao(1)*invb1*phres%gval(3,ibm) + phres%gval(1,1)=phres%gval(1,1)+addgval(1)/rt + phres%gval(2,1)=phres%gval(2,1)+addgval(2)/rt + phres%gval(3,1)=phres%gval(3,1)+addgval(3)/rt +! ignore second derivatives if no derivatives wanted + if(moded.eq.0) then + goto 1000 + endif +! Now all derivatives +! phres%gval(*,itc) are TC and derivatives wrt T and P +! phres%dgval(*,*,itc) are derivatives of TC wrt T, P and Y +! phres%d2gval(*,itc) are derivatives of TC wrt Y1 and Y2 +! phres%gval(*,ibm) are beta and dervatives etc +! TC and beta must not depend on T, only on P and Y +! dtaodt=one/tc +! dtaodp=-tao/tc*phres%gval(3,itc) +! d2taodt2 is zero + d2taodtdp=-one/tc*phres%gval(3,itc) + d2taodp2=2.0d0*tao/tc**2*phres%gval(3,itc)-tao/tc*phres%gval(6,itc) +! 1-6 means F, F.T, T.P, F.T.T, F.T.P and F.P.P + addgval(4)=2.0d0*rgasm*ftao(2)*dtaodt*logb1+& + rt*ftao(4)*(dtaodt)**2*logb1 + addgval(5)=rgasm*ftao(2)*dtaodp*logb1+& + rgasm*ftao(1)*invb1*phres%gval(3,ibm)+& + rt*ftao(4)*dtaodt*dtaodp*logb1+& + rt*ftao(2)*d2taodtdp*logb1+& + rt*ftao(2)*dtaodt*invb1*phres%gval(3,ibm) + addgval(6)=rt*ftao(4)*(dtaodp)**2*logb1+& + rt*ftao(2)*d2taodp2*logb1+rt*ftao(1)*dtaodp*invb1*phres%gval(3,ibm)+& + rt*ftao(2)*dtaodp*invb1*phres%gval(3,ibm)-& + rt*ftao(1)*(invb1*phres%gval(3,ibm))**2+& + rt*ftao(1)*invb1*phres%gval(6,ibm) +! G, G.T and G.Y, G.T.Y and G.Y1.Y2 correct (no P dependence checked) + do j=1,mc + dtao(1,j)=-tao*phres%dgval(1,j,itc)/tc + dtao(2,j)=-phres%dgval(1,j,itc)/tc**2 + dtao(3,j)=2.0d0*tao*phres%gval(3,itc)*phres%dgval(1,j,itc)/tc**2-& + tao*phres%dgval(3,j,itc)/tc + do k=j,mc + d2tao(ixsym(j,k))=& + 2.0*tao*phres%dgval(1,j,itc)*phres%dgval(1,k,itc)/tc**2& + -tao*phres%d2gval(ixsym(j,k),itc)/tc + enddo + enddo + do j=1,mc +! first derivative wrt Y, checked for bcc in Cr-Fe-Mo, error in fcc in c-cr-fe? + daddgval(1,j)=rt*ftao(2)*dtao(1,j)*logb1+& + rt*ftao(1)*invb1*phres%dgval(1,j,ibm) +! write(*,43)j,daddgval(1,j),dtao(1,j),phres%dgval(1,j,ibm) +!43 format('Inden 4: ',i2,6(1pe12.5)) +! second derivative wrt to T and Y, checked + daddgval(2,j)=rgasm*ftao(2)*dtao(1,j)*logb1+& + rgasm*ftao(1)*invb1*phres%dgval(1,j,ibm)+& + rt*ftao(4)*dtaodt*dtao(1,j)*logb1+& + rt*ftao(2)*dtao(2,j)*logb1+& + rt*ftao(2)*dtaodt*invb1*phres%dgval(1,j,ibm) +! write(*,56)rgasm*ftao(2)*dtao(1,j)*logb1,& +! rgasm*ftao(1)*invb1*phres%dgval(1,j,ibm),& +! rt*ftao(4)*dtaodt*dtao(1,j)*logb1,& +! rgasm*ftao(2)*dtao(2,j)*logb1,& +! rt*ftao(2)*dtaodt*invb1*phres%dgval(1,j,ibm) +!56 format('calcmag : ',5(1PE13.5)) +! second derivative wrt P and Y, no P dependence + daddgval(3,j)=rt*ftao(4)*dtaodp*dtao(1,j)*logb1+& + rt*ftao(2)*dtao(3,j)*logb1+& + rt*ftao(2)*dtao(1,j)*invb1*phres%gval(3,ibm)-& + rt*ftao(1)*invb1**2*phres%gval(3,ibm)*phres%dgval(1,j,ibm)+& + rt*ftao(1)*invb1*phres%dgval(3,j,ibm) + do k=j,mc +! second derivatives wrt Y1 and Y2, wrong + d2addgval(ixsym(j,k))=rt*ftao(4)*dtao(1,j)*dtao(1,k)*logb1+& + rt*ftao(2)*d2tao(ixsym(j,k))*logb1+& + rt*ftao(2)*dtao(1,j)*invb1*phres%dgval(1,k,ibm)+& + rt*ftao(2)*dtao(1,k)*invb1*phres%dgval(1,j,ibm)-& + rt*ftao(1)*invb1**2*phres%dgval(1,j,ibm)*phres%dgval(1,k,ibm)+& + rt*ftao(1)*invb1*phres%d2gval(ixsym(j,k),ibm) +! write(*,57)rt*ftao(4)*dtao(1,j)*dtao(1,k)*logb1,& +! rt*ftao(2)*d2tao(ixsym(j,k))*logb1,& +! rt*ftao(2)*dtao(1,j)*invb1*phres%dgval(1,k,ibm),& +! rt*ftao(2)*dtao(1,k)*invb1*phres%dgval(1,j,ibm),& +! -rt*ftao(1)*invb1**2*phres%dgval(1,j,ibm)*phres%dgval(1,k,ibm),& +! rt*ftao(1)*invb1*phres%d2gval(ixsym(j,k),ibm) +!57 format('mag2y: ',6(1PE12.4)) + enddo + enddo +! now add all to the total G + do j=1,mc + do k=1,3 +! write(*,99)'magadd 1: ',k,j,rt*phres%dgval(k,j,1),daddgval(k,j) + phres%dgval(k,j,1)=phres%dgval(k,j,1)+daddgval(k,j)/rt + enddo +!99 format(a,2i3,2(1pe16.8)) + do k=j,mc +! write(*,99)'magadd 2: ',k,j,rt*phres%d2gval(ixsym(j,k),1),& +! d2addgval(ixsym(j,k)) + phres%d2gval(ixsym(j,k),1)=phres%d2gval(ixsym(j,k),1)+& + d2addgval(ixsym(j,k))/rt + enddo + enddo +! write(*,*)'cm 7: ',rt*phres%gval(1,1),addgval(1) +! note phres%gval(1..3,1) already calculated above + do j=4,6 + phres%gval(j,1)=phres%gval(j,1)+addgval(j)/rt + enddo +1000 continue + return + end subroutine calc_weimagnetic + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine create_elastic_model_a(newadd) +! addition record to calculate the elastic energy contribution + implicit none + type(gtp_phase_add), pointer :: newadd +!\end{verbatim} %+ + integer typty + allocate(newadd) + newadd%type=elasticmodela + allocate(newadd%need_property(5)) +! needed properties + newadd%need_property=0 + call need_propertyid('LPX ',typty) + if(gx%bmperr.ne.0) goto 1000 + newadd%need_property(1)=typty + call need_propertyid('EC11',typty) + if(gx%bmperr.ne.0) goto 1000 + newadd%need_property(2)=typty + call need_propertyid('EC12',typty) + if(gx%bmperr.ne.0) goto 1000 + newadd%need_property(3)=typty + call need_propertyid('EC44',typty) + if(gx%bmperr.ne.0) goto 1000 + newadd%need_property(4)=typty + call need_propertyid('LPTH',typty) + if(gx%bmperr.ne.0) goto 1000 + newadd%need_property(5)=typty +! now elastica is declared as pointer, is that OK? + allocate(newadd%elastica) +1000 continue + return + end subroutine create_elastic_model_a + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine calc_elastica(moded,phres,addrec,lokph,mc,ceq) +! calculates elastic contribution and adds to G and derivatives + implicit none + integer moded,lokph,mc + type(gtp_phase_varres), pointer :: phres + type(gtp_phase_add), pointer :: addrec + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} %+ + integer jl,ilpx,ilpth,iec11,iec12,iec44,noprop,i1,i2 + double precision sum1,sum2 +! get the current lattice parameters and elastic constants + ilpx=0; ilpth=0; iec11=0; iec12=0; iec44=0 + noprop=phres%listprop(1)-1 + findix: do jl=2,noprop + if(phres%listprop(jl).eq.addrec%need_property(1)) then + ilpx=jl + elseif(phres%listprop(jl).eq.addrec%need_property(2)) then + iec11=jl + elseif(phres%listprop(jl).eq.addrec%need_property(3)) then + iec12=jl + elseif(phres%listprop(jl).eq.addrec%need_property(4)) then + iec44=jl + elseif(phres%listprop(jl).eq.addrec%need_property(5)) then +! this one may not be needed initially at least + ilpth=jl + endif + enddo findix + if(ilpx.eq.0 .or. iec11.eq.0 .or. iec12.eq.0 .or. iec44.eq.0) then + write(*,11)'Missing elastic parameter index: ',ilpx,iec11,iec12,iec44 +11 format(a,5i4) + endif +! write(*,11)'3H indices: ',ilpx,iec11,iec12,iec44 +! take care of the special elastic record +! ignore compsition derivatives at present ... +! elastic constant matrix, Voigt notation, symetric + addrec%elastica%cmat=zero + addrec%elastica%cmat(1,1)=phres%gval(1,iec11) + addrec%elastica%cmat(2,2)=phres%gval(1,iec11) + addrec%elastica%cmat(3,3)=phres%gval(1,iec11) + addrec%elastica%cmat(4,4)=phres%gval(1,iec44) + addrec%elastica%cmat(5,5)=phres%gval(1,iec44) + addrec%elastica%cmat(6,6)=phres%gval(1,iec44) + addrec%elastica%cmat(1,2)=phres%gval(1,iec12) + addrec%elastica%cmat(1,3)=phres%gval(1,iec12) + addrec%elastica%cmat(2,3)=phres%gval(1,iec12) + addrec%elastica%cmat(2,1)=phres%gval(1,iec12) + addrec%elastica%cmat(3,1)=phres%gval(1,iec12) + addrec%elastica%cmat(3,2)=phres%gval(1,iec12) +! write(*,22)phres%gval(1,iec11),phres%gval(1,iec12),phres%gval(1,iec44) +22 format('Elastic constants: ',3(1pe12.4)) +! write(*,19)(addrec%elastica%cmat(1,i1),i1=1,6) +! write(*,19)(addrec%elastica%cmat(2,i1),i1=1,6) +! write(*,19)(addrec%elastica%cmat(3,i1),i1=1,6) +! write(*,19)(addrec%elastica%cmat(4,i1),i1=1,6) +! write(*,19)(addrec%elastica%cmat(5,i1),i1=1,6) +! write(*,19)(addrec%elastica%cmat(6,i1),i1=1,6) +19 format('CIJ: ',6(1pe12.4)) +!.................... +! equilibrium lattice constant (cubic, just diagonal) + addrec%elastica%latticepar=zero + addrec%elastica%latticepar(1,1)=phres%gval(1,ilpx) + addrec%elastica%latticepar(2,2)=phres%gval(1,ilpx) + addrec%elastica%latticepar(3,3)=phres%gval(1,ilpx) +! write(*,23)'Lattice parameter: ',phres%gval(1,ilpx) +!.................... +! The equilibrium lattice distances are in LPX (cubic lattice) +! The current lattice parameters are in ceq%phres%curlat(3,3) +! generate epsa, Voigt notation +! write(*,23)'curlat 1: ',(phres%curlat(i1,1),i1=1,3) +! write(*,23)'curlat 2: ',(phres%curlat(i1,2),i1=1,3) +! write(*,23)'curlat 3: ',(phres%curlat(i1,3),i1=1,3) +23 format(a,3(1pe12.4)) + addrec%elastica%epsa(1)=(phres%curlat(1,1)-addrec%elastica%latticepar(1,1))& + /addrec%elastica%latticepar(1,1) + addrec%elastica%epsa(2)=(phres%curlat(2,2)-addrec%elastica%latticepar(2,2))& + /addrec%elastica%latticepar(2,2) + addrec%elastica%epsa(3)=(phres%curlat(3,3)-addrec%elastica%latticepar(3,3))& + /addrec%elastica%latticepar(3,3) +! as addrec%elastica%latticepar(2,3) is zero for cubic use (1,1) + addrec%elastica%epsa(4)=& + (2*(phres%curlat(2,3)-addrec%elastica%latticepar(2,3)))& + /addrec%elastica%latticepar(1,1) + addrec%elastica%epsa(5)=& + (2*(phres%curlat(1,3)-addrec%elastica%latticepar(1,3)))& + /addrec%elastica%latticepar(1,1) + addrec%elastica%epsa(6)=& + (2*(phres%curlat(1,2)-addrec%elastica%latticepar(1,2)))& + /addrec%elastica%latticepar(1,1) +! write(*,25)'ev1: ',(addrec%elastica%epsa(i1),i1=1,6) +25 format(a,6(1pe12.4)) +!.................... +! calculate the elastic energy ... I do not know how to use F08 matrix mult + sum1=zero + do i1=1,6 + sum2=zero + do i2=1,6 + sum2=sum2+addrec%elastica%cmat(i1,i2)*addrec%elastica%epsa(i2) + enddo +! write(*,23)'sum2: ',sum2 + sum1=sum1+addrec%elastica%epsa(i1)*sum2 + enddo + addrec%elastica%eeadd(1)=5.0D-1*sum1 + write(*,30)'3H: Elastic energy: ',addrec%elastica%eeadd(1) +30 format(a,1pe15.7) +! TYPE gtp_elastic_modela +! double precision, dimension(3,3) :: latticepar +! epsilon in Voigt notation +! double precision, dimension(6) :: epsa +! elastic constant matrix in Voigt notation +! double precision, dimension(6,6) :: cmat +! calculated elastic energy addition (with derivative to T and P?) +! double precision, dimension(6) :: eeadd +! maybe more +! end TYPE gtp_elastic_modela + +1000 continue + return + end subroutine calc_elastica + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine set_lattice_parameters(iph,ics,xxx,ceq) +! temporary way to set current lattice parameters for use with elastic model a + implicit none + integer iph,ics + double precision, dimension(3,3) :: xxx + type(gtp_equilibrium_data) :: ceq +!\end{verbatim} + integer lokph,lokcs + call get_phase_compset(iph,ics,lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 + ceq%phase_varres(lokcs)%curlat=xxx +! write(*,*)'3H Phase+set: ',lokph,lokcs +! write(*,23)'slp 1: ',(ceq%phase_varres(lokcs)%curlat(i1,1),i1=1,3) +! write(*,23)'slp 2: ',(ceq%phase_varres(lokcs)%curlat(i1,2),i1=1,3) +! write(*,23)'slp 3: ',(ceq%phase_varres(lokcs)%curlat(i1,3),i1=1,3) +23 format(a,3(1pe12.4)) +1000 continue + return + end subroutine set_lattice_parameters + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine create_einsteincp(newadd) + implicit none + type(gtp_phase_add), pointer :: newadd +!\end{verbatim} %+ + integer, parameter :: ncc=6 + integer typty +! +! G/RT = 3*ln( 1 - exp( THET/T ) ) +! No need to use TPFUN +! +! gtp_phase_add has variables: +! integer :: type,addrecno,aff +! integer, allocatable :: need_property +! type(tpfun_expression), dimension, pointer :: explink +! type(gtp_phase_add), pointer :: nextadd +! for spme additions one may create other records but they must have +! the variables type and nextadd +!------------------------------------------ + allocate(newadd) +! Both Einstein and Debye models use THET + newadd%type=einsteincp + call need_propertyid('THET',typty) + if(gx%bmperr.ne.0) goto 1000 + allocate(newadd%need_property(1)) + newadd%need_property(1)=typty +1000 continue + return + end subroutine create_einsteincp + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine calc_einsteincp(moded,phres,addrec,lokph,mc,ceq) +! Calculate the contibution due to Einste Cp model for low T +! moded 0, 1 or 2 +! phres all results +! addrec pointer to addition record +! lokph phase record +! mc number of variable fractions +! ceq equilibrum record +! +! G = 3*R*T*ln( 1 - exp( THET/T ) ) +! This is easier to handle inside the calc routine without TPFUN +! + implicit none + integer moded,lokph,mc + type(gtp_phase_varres), pointer :: phres + type(gtp_phase_add), pointer :: addrec + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer ith,noprop + double precision del1,del2,del3,gein,dgeindt,d2geindt2 +! + noprop=phres%listprop(1)-1 + findix: do ith=2,noprop + if(phres%listprop(ith).eq.addrec%need_property(1)) goto 100 + enddo findix + write(*,*)'No theta value. ',lokph + gx%bmperr=7777; goto 1000 +100 continue +! thet is in gval(ith,1), derivatives in dgval(*,ith,*) and d2gval(ith,*) +! G/RT = 3*ln( 1 - exp( THET/T ) ) +! NOTE DIRIVATES CALCULATED FOR G/RT + del1=phres%gval(ith,1)/ceq%tpval(1) + del2=exp(del1) + del3=1.0d0-del2 + gein=3.0D0*log(del3) + dgeindt=3.0D0*(del1/ceq%tpval(1))*(del2/del3) +! d2geindt2=3.0D0*(del1**2/ceq%tpval(1))*(del2/del3**2) + d2geindt2=dgeindt*del1/del3 +! Missing implem of derivatives wrt fractions of thet. thet cannot depend on T +1000 continue + return + end subroutine calc_einsteincp + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine create_glas_transition_modela(newadd) +! not implemented + implicit none + type(gtp_phase_add), pointer :: newadd +!\end{verbatim} + write(kou,*)'Not implemented yet'; gx%bmperr=7777 +1000 continue + return + end subroutine create_glas_transition_modela + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine create_debyecp(addrec) +! enters a record for the debye model + implicit none + type(gtp_phase_add), pointer :: addrec +!\end{verbatim} %+ + integer typty +! reserve an addition record + allocate(addrec) +! Set the type of addition and look for needed parameter properties + addrec%type=debyecp + allocate(addrec%need_property(1)) + call need_propertyid('THET',typty) + if(gx%bmperr.ne.0) goto 1000 + addrec%need_property(1)=typty +! missing things for the actual Cp function ... +! + write(kou,*)'Not implemented yet'; gx%bmperr=7777 +! +1000 continue + return + end subroutine create_debyecp + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine calc_debyecp(moded,phres,lokadd,lokph,mc,ceq) +! calculates Mauro Debye contribution +! NOTE: values for function not saved, should be done to save calculation time. +! moded: integer, 0=only G, S, Cp; 1=G and dG/dy; 2=Gm dG/dy and d2G/dy2 +! phres: pointer, to phase\_varres record +! lokadd: pointer, to addition record +! lokph: integer, phase record +! mc: integer, number of constituents +! ceq: pointer, to gtp_equilibrium_data + implicit none + integer moded,lokph,mc + TYPE(gtp_equilibrium_data) :: ceq + TYPE(gtp_phase_add), pointer :: lokadd + TYPE(gtp_phase_varres) :: phres +!\end{verbatim} + integer ith,noprop +! value of THET and derivatives have type ?? + noprop=phres%listprop(1)-1 +! write(*,*)'cmi 2: ',noprop,(phres%listprop(i),i=1,noprop) +! Find thet, index stored in need_property(1) + do ith=2,noprop + if(phres%listprop(ith).eq.lokadd%need_property(1)) goto 100 + enddo + write(*,*)'No Debye temperature THET',lokph + gx%bmperr=7777; goto 1000 +100 continue + write(*,*)'Not implemented yet' + gx%bmperr=7777 +1000 continue + return + end subroutine calc_debyecp + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine list_addition(unit,ch1,phname,ftyp,lokadd) +! list description of an addition for a phase on unit + implicit none + integer unit,ftyp + character ch1*1,phname*(*) + TYPE(gtp_phase_add), pointer :: lokadd +!\end{verbatim} + integer ip + TYPE(tpfun_expression), pointer :: exprot + character line*256,tps(2)*3 + double precision ff + addition: select case(lokadd%type) + case default + write(unit,*)'Unknown addtion type: ',phname,lokadd%type + case(indenmagnetic) ! Inden magnetic model + if(ftyp.eq.2) then +! TDB file: a do not think I have saved the enthalpy factor, bcc (-1) it is 0.4 + ff=0.28D0 + if(lokadd%aff.eq.-1) ff=0.4D0 + write(unit,88)ch1,phname(1:len_trim(phname)),lokadd%aff,ff +88 format(' TYPE_DEFINITION ',a,' GES A_P_D ',a,' MAGNETIC ',i3,F8.4,'!') + else + write(unit,100)lokadd%aff +100 format(2x,'+ Magnetic model by Inden, anti-ferromagntic factor:',i3,/& + 4x,'Magnetic function below the ordering temperature TC',& + ' with TAO=T/TC:') + tps(1)='TAO' + tps(2)='err' + ip=1 + line=' ' + exprot=>lokadd%explink(1) + call ct1wfn(exprot,tps,line,ip) + call wrice(unit,4,8,78,line(1:ip)) + write(unit,110) +110 format(4x,'Magnetic function above the ordering temperature TC ',& + 'with TAO=T/TC:') + ip=1 + line=' ' + exprot=>lokadd%explink(2) + call ct1wfn(exprot,tps,line,ip) + call wrice(unit,4,8,78,line(1:ip)) + endif +!--------------------------------------------- + case(debyecp) ! Debye Cp model + write(unit,200) +200 format(2x,'+ Debye Cp model, not implemented yet') +!--------------------------------------------- + case(weimagnetic) ! Inden-Wei + write(unit,300) +300 format(2x,'+ Inden magnetic model'/& + 2x,'with separate Curie and Neel temperatures.'/& + 4x,'Magnetic function above the ordering temperature TC'& + ' with TAO=T/TC':) + tps(1)='TAO' + tps(2)='err' + ip=1 + line=' ' + exprot=>lokadd%explink(1) + call ct1wfn(exprot,tps,line,ip) + call wrice(unit,4,8,78,line(1:ip)) + write(unit,110) + ip=1 + line=' ' + exprot=>lokadd%explink(2) + call ct1wfn(exprot,tps,line,ip) + call wrice(unit,4,8,78,line(1:ip)) +!--------------------------------------------- + case(einsteincp) ! Einstein Cp model + write(unit,400) +400 format(2x,'+ Einstein Cp model:'/4x,'G = 3*R*T*LN(1-THET/T)') +!--------------------------------------------- + case(elasticmodela) ! Elastic model A + write(unit,500) +500 format(2x,'+ Elastic model A, with P interpreted as a force in',& + ' the X direction.') +!--------------------------------------------- + case(glastransmodela) ! Glas transtion model A + write(unit,*)'Glas transition model A, not implemented yet' + end select addition +1000 continue + return + end subroutine list_addition + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + diff --git a/models/pmod25B.F90 b/models/gtp3X.F90 similarity index 95% rename from models/pmod25B.F90 rename to models/gtp3X.F90 index 83d9413..ad202b8 100644 --- a/models/pmod25B.F90 +++ b/models/gtp3X.F90 @@ -1,2735 +1,2740 @@ -! -! included in pmod25.F90 -! -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ -!> 6. Calculate things -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine calcg(iph,ics,moded,lokres,ceq) -! calculates G for phase iph and composition set ics in equilibrium ceq -! checks first that phase and composition set exists -! Data taken and stored in equilibrium record ceq -! lokres is set to the phase_varres record with all fractions and results -! moded is 0, 1 or 2 depending on calculating no, first or 2nd derivarives - implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq - integer iph,ics,moded,lokres -!\end{verbatim} - integer jcs,lokcs,lokph - if(gx%bmperr.ne.0) then - write(*,*)'Error code set when calling calcg: ',gx%bmperr - goto 1000 - endif - if(iph.le.0 .or. iph.gt.noofph) then -! the selected_element_reference phase with iph=0 is calculated separtely - gx%bmperr=4050; goto 1000 - endif - lokph=phases(iph) - if(lokph.le.0 .or.lokph.gt.noofph) then - gx%bmperr=4050; goto 1000 - endif -! write(*,*)'calcg 1: ',phlista(lokph)%name -! find fractions for this composition set - if(ics.le.1) then - jcs=1 - elseif(ics.le.phlista(lokph)%noofcs) then - jcs=ics - else -! no such composition set -! write(*,*)'calcg 1 error 4072' - gx%bmperr=4072; goto 1000 - endif -! if(phlista(1)%noofcs.gt.1) then -! strange error that liquid (phase 1) has 3 composition set -! write(*,*)'csbug: ',lokph,jcs,phlista(1)%noofcs -! stop 'csbug' -! endif -! Find fraction record this composition set - lokcs=phlista(lokph)%linktocs(ics) -!----- -! mcs=1 -! lokcs=phlista(lokph)%cslink -! do while(mcs.lt.jcs) -! mcs=mcs+1 -! firsteq is the first equilibrium and a global variable in this module -! lokcs=firsteq%phase_varres(lokcs)%next -! if(lokcs.le.0) then -! write(*,*)'calcg 2 error 4072' -! gx%bmperr=4072; goto 1000 -! endif -! enddo - lokres=lokcs -! write(*,*)'calcg 7: ',lokres,ceq%eqname(1:10) -! call using the local structure phase_varres -! results can be obtained through lokres -! write(*,17)'calcg: ',lokph,lokres,ceq%phase_varres(lokres)%yfr(1) -17 format(a,2i4,1pe15.6) - call calcg_internal(lokph,moded,ceq%phase_varres(lokres),ceq) -1000 continue - return - end subroutine calcg - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine calcg_internal(lokph,moded,cps,ceq) -! Central calculating routine calculating G and everyting else for a phase -! ceq is the equilibrium record, cps is the phase_varres record for lokph -! moded is type of calculation, 0=only G, 1 G and first derivatives -! 2=G and all second derivatives -! Can also handle the ionic liquid model now .... - implicit none - integer lokph,moded - TYPE(gtp_equilibrium_data), pointer :: ceq - TYPE(gtp_phase_varres), target :: cps -!\end{verbatim} -! fractype defines fraction type (1=constituent fractions) -! empermut and ipermut permutation of fractions for phases with option F and B -! permrecord, maxprec and sameint to handle permutation in the interaction tree - integer, parameter :: permstacklimit=150 - integer fractype,epermut,ipermut,typty,pmq,maxprec - integer sameint(5) - integer, dimension(permstacklimit) :: lastpmq,maxpmq -! character bug*60 -! dimension sites(maxsubl),pushpop(maxpp) - double precision, dimension(:), allocatable :: dpyq(:),d2pyq(:),d2vals(:) - double precision, dimension(:,:), allocatable :: dvals(:,:) - double precision vals(6) - integer incffr(0:maxsubl) -! in local gz: gz%intlevel level of interaction, gz%intcon and gz%intlat are -! used also in cgint when calculating interactions. - TYPE(gtp_parcalc) :: gz -! disordered fraction set - TYPE(gtp_fraction_set) :: fracset,dislink - TYPE(gtp_phase_varres), pointer :: phres,phpart,phmain - TYPE(gtp_property), pointer :: proprec - TYPE(gtp_endmember), pointer :: endmemrec - TYPE(gtp_interaction), pointer :: intrec - TYPE(gtp_pystack), pointer :: pystack - TYPE(gtp_phase_add), pointer :: addrec -! for an ordered phase like FCC with a disordered contribution one must -! calculate the ordered part twice, one with original fractions and once -! with these replaced by the disordered fractions. and subdrahera. This means -! one must have space to save fractions and results - double precision, dimension(:), allocatable :: savey - double precision, dimension(:,:), allocatable :: saveg - double precision, dimension(:,:,:), allocatable :: savedg - double precision, dimension(:,:), allocatable :: saved2g - double precision, dimension(:,:), allocatable :: tmpd2g -! added when implicit none - double precision rtg,pyq,ymult,add1,sum,yionva,fsites,xxx - integer nofc2,nprop,nsl,msl,lokdiseq,ll,id,id1,id2,lm,jl - integer lokfun,itp,nz,intlat,ic,jd,jk,ic1,jpr,ipy,i1,j1 - integer i2,j2,ider,is,kk,ioff,norfc,iw,iw1,iw2,lprop,jonva -! to handle parameters with wildcard constituent and other things - logical wildc,nevertwice,first,chkperm,ionicliq,iliqsave,iliqva -! debugging for partitioning and ordering -! integer clist(4) -! calculate RT to normalize all Gibbs energies, ceq is current equilibrium - rtg=globaldata%rgas*ceq%tpval(1) - ceq%rtn=rtg -!----------------------- - chkperm=.false. - if(btest(phlista(lokph)%status1,PHFORD) .or. & - btest(phlista(lokph)%status1,PHBORD)) then - chkperm=.true. -! This is needed only once unless parameters are changed. It numbers the -! interaction records sequentially for the permutations - call palmtree(lokph) - if(gx%bmperr.ne.0) goto 1000 - endif -! if(ocv()) write(*,*)'in gcalc_internal: ',lokph -!----------------------------------------------------------------- -50 continue -! local work arrays for products of Y and calculated parameters are allocated - gz%nofc=phlista(lokph)%tnooffr - nofc2=gz%nofc*(gz%nofc+1)/2 -! write(*,17)'calcg, ',lokph,gz%nofc,nofc2,size(cps%d2gval),cps%nprop,& -! cps%yfr(1) -!17 format(a,5i4,1pe15.6) -! for disordered fraction sets gz%nofc must be from disordered fraction record -! maybe these should not be allocated for moded=0 and 1 -! if(ocv()) write(*,*)'First allocate: ',gz%nofc,nofc2 - allocate(dpyq(gz%nofc)) - allocate(d2pyq(nofc2)) -! these return values from excess parameters that may depend on constitution - allocate(dvals(3,gz%nofc)) - allocate(d2vals(nofc2)) - nullify(pystack) -! do they have to be zeroed? YES! - dpyq=zero - d2pyq=zero -! dimension for number of parameter properties - nprop=cps%nprop -! phres will point either to ordered or disordered results -! phmain will always point to record for ordered phase_varres - phmain=>cps - phres=>cps -! zero result arrays for all properties, maybe one should do it separately for -! each property as it is found but it may be faster to do it like this anyway - phres%gval=zero - if(moded.gt.0) then - phres%dgval=zero - if(moded.gt.1) then - phres%d2gval=zero - endif - endif -! copy current values of T, P and RT from gtp_phase_varres - gz%tpv(1)=ceq%tpval(1) - gz%tpv(2)=ceq%tpval(2) -! write(*,*)'calcg_i: ',gz%tpv - gz%rgast=ceq%tpval(1)*globaldata%rgas -! gz%rgast=ceq%tpval(1)*ceq%rgas -! this is used to check the number of times an ordered phase is calculated - first=.true. -!------------------------------------------------------------------- -! calculate configurational entropy. - nsl=phlista(lokph)%noofsubl - ionicliq=.FALSE. - if(btest(phlista(lokph)%status1,PHIONLIQ)) then - call config_entropy_i2sl(moded,nsl,phlista(lokph)%nooffr,phres,& - phlista(lokph)%i2slx,gz%tpv(1)) - ionicliq=.TRUE. - iliqsave=.FALSE. - iliqva=.FALSE. - jonva=0 -! write(*,*)'Config G 1: ',phres%gval(1,1)*rtg -! if(phlista(lokph)%i2slx(1).gt.phlista(lokph)%tnooffr .and. & -! phlista(lokph)%i2slx(2).gt.phlista(lokph)%tnooffr) then -! onlyanions=.TRUE. -! else -! onlyanions=.FALSE. -! endif - else -! NOTE: for phases with disordered fraction set this is calculated -! for the ordered original constituent fraction set only - call config_entropy(moded,nsl,phlista(lokph)%nooffr,phres,gz%tpv(1)) - endif - if(gx%bmperr.ne.0) goto 1000 -!------------------------------------------------------------------- -! start BIG LOOP for all fraction variables and parameters -! there may be several different properties in addition to G like TC, MQ& etc -! each of these are stored in separate gval(*,ipy) where ipy is an integer -! set for each property. lprop is incremented by one for each new property -! found (each phase may have different) and in listprop the original type -! of property is stored. listprop will always be associated with phmain -100 continue -! yionva is used as indicator below if there are Va or just neutrals ... - yionva=zero -! this nevertwice is probably redundant - nevertwice=.true. - lprop=2 - phmain%listprop(1)=1 - fractype=0 -! write(*,101)'calcg 100 ',nsl,phres%gval(1,1),cps%gval(1,1) -101 format(a,i4,4(1pe14.4)) -!-------------------------------------------------------------------- -! loop for different types of fractions: site fractions, mole fractions ... - fractyp: do while(fractype.lt.phlista(lokph)%nooffs) -105 continue - fractype=fractype+1 -! return here for calculating with disordered fractions for same fraction type -110 continue -! gz%nofc is number of fraction variables, msl is number of sublattices -! for this set of fractions!!! Ordering in FCC may have 5 sublattices with -! 4 participating in ordering and one interstitial. The second fraction -! set may have 2 sublattices, 1 for the 4 ordering and one interstitial - fracset=phmain%disfra - ftype: if(fractype.eq.1) then -!---------------------------------------------- ordered (or only) fraction set -! if(btest(phlista(lokph)%status1,PHMFS)) then -! there is a disordered fractions set, we need fracset later -! if(fracset%totdis.ne.0) then -! the phase can totally disorder, if disordered skip ordered part -! if(btest(phmain%status2,CSORDER)) then -! the phase is ordered, we have to calculate this part twice -! nevertwice=.false. -! independent if ordered or disordered always calculate first fraction set -! nevertwice probably redundant -! else -! the phase is disordered, skip ordered part and just calculate disordered -! goto 105 -! endif -! endif -! endif - gz%nofc=phlista(lokph)%tnooffr - msl=nsl - incffr(0)=0 - do jl=1,nsl - incffr(jl)=incffr(jl-1)+phlista(lokph)%nooffr(jl) - enddo -! the results will be stored in the results arrays indicated by phres -! it was set above for the ordered fraction set. - else -!------------------------------------------------- -! disorderd/other fraction sets, take data from gtp_fraction_set - msl=fracset%ndd - gz%nofc=fracset%tnoofxfr - incffr(0)=0 - do jl=1,msl - incffr(jl)=incffr(jl-1)+fracset%nooffr(jl) - enddo -! we have to deallocate and allocate local arrays, not if moded=0 or 1?? - deallocate(dpyq) - deallocate(d2pyq) - allocate(dpyq(gz%nofc)) - allocate(d2pyq(nofc2)) -! if(ocv()) write(*,*)'Allocated dpyq 2' - dpyq=zero - deallocate(dvals) - deallocate(d2vals) - allocate(dvals(3,gz%nofc)) - allocate(d2vals(nofc2)) - if(ocv()) write(*,*)'Allocated vals 2' -! the results will be stored in result arrays indicated by phres -! for the disordered fraction set phres must be set here and the arrays zeroed - dislink=cps%disfra -! write(*,*)'Calc internal disordred part 1A',dislink%fsites - lokdiseq=dislink%varreslink -! write(*,*)'Calc internal disordred part 1B' - phres=>ceq%phase_varres(lokdiseq) - phres%gval=zero -! write(*,*)'Calc internal disordred part 1c' - if(moded.gt.0) then - phres%dgval=zero - if(moded.gt.1) then - phres%d2gval=zero - endif - endif -! write(*,*)'Calc internal disordred part 2' - endif ftype -!========================================================== -!vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv -! code below is an attempt to parallelize the calculation of each -! endmember tree for a single phase ... -! It is commented away as there has been som many changes -! -! there can be ordered and disordered fraction sets selected by fractype -! One endmember at a time but to speed up when having several -! CPU we give one endmamber plus its interaction tree to each tread. -! To handle this all endmember records should be in an array -! if(fractype.eq.1) then -! TYPE gtp_phase must be extended with these lists -! endmemrec=>phlista(lokph)%ordered -! oendmems: do i=1,phlista(lokph)%noemr -! call calc_endmemtree(lokph,moded,msl,& -! phlista(lokph)%oendmemarr(i)%p1,phres,phmain,ceq) -! enddo oendmems -! else -! endmemrec=>phlista(lokph)%disordered -! dendmems: do i=1,phlista(lokph)%ndemr -! call calc_endmemtree(lokph,moded,msl,& -! phlista(lokph)%dendmemarr(i)%p1,phres,phmain,ceq) -! enddo dendmems -! endif -! -! calculated for this fraction type, initiation for next in the beginning of -! loop but we may have to calculate once again with same fraction type but -! with the fractions as disordered fractions -! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -!========================================================== -! there can be ordered and disordered fraction sets selected by fractype - if(fractype.eq.1) then - endmemrec=>phlista(lokph)%ordered - else - endmemrec=>phlista(lokph)%disordered - endif -! -! here we take one endmember at a time but to speed up when having several -! CPU we give one endmamber plus its interaction tree to each tread. -! To handle this all endmember records should be in an array. An attempt to -! implement this was made in calcg_internal2 but not updated for permutations -! -! empermut, lastpmq and maxpmq controls permutations (option F and B) -! maxpmq is set to zero for each new endmember but keep its content -! during calculation of all permutations of the same endmember and interactions -! big loop for all permutation of fractions (ordering option F and B) -! including all interaction parameters linked from this endmember -! -! write(*,*)'Config G 2: ',phres%gval(1,1)*rtg - endmemloop: do while(associated(endmemrec)) -! -! The array maxpmq is used for interaction permutations. It must be -! initialized to zero at the first endmember permutation. It is set to -! limits for the interacton permutations for all interaction records. - maxpmq=0 - maxprec=0 - epermut=0 - sameint=0 -! write(*,*)'25B: start endmember list' - empermut: do while(epermut.lt.endmemrec%noofpermut) - epermut=epermut+1 -! calculate py, calculate parameter, calculate contribution to G etc -! py is product of all fractions, dpy are first derivatives and d2py second - pyq=one - if(moded.gt.0) then -! moded=0, only G, =1 only G and dG/dy, moded=2 all Gm dG/dy and d2G/dy2 - dpyq=zero - if(moded.gt.1) then - d2pyq=zero - endif - endif -!----------------------------------------------------- - pyqloop: do ll=1,msl - id=endmemrec%fraclinks(ll,epermut) -! remove next line when all fixed -! if(ll.lt.5) clist(ll)=id -! id negative means wildcard, independent of the fraction in this sublattice - if(id.lt.0) then - gz%yfrem(ll)=one - else - gz%yfrem(ll)=phres%yfr(id) - if(gz%yfrem(ll).lt.bmpymin) gz%yfrem(ll)=bmpymin - if(gz%yfrem(ll).gt.one) gz%yfrem(ll)=one - endif -! gz%endcon is used for interaction parameters below - gz%endcon(ll)=id - pyq=pyq*gz%yfrem(ll) - if(ionicliq .and. ll.eq.2) then -! For ionic liquid we must check when Va or neutral in second sublattice -! i2slx(1) is index of vacancy, i2slx(2) is first neutral - if(id.eq.phlista(lokph)%i2slx(1) .and. yionva.eq.zero) then - iliqva=.TRUE. - yionva=gz%yfrem(ll) - jonva=phlista(lokph)%i2slx(1) -! We found Va. Save all calculated values as the follwing terms should all -! be multiplied with Q (done after finishing calculation) - nprop=phmain%nprop - allocate(saveg(6,nprop)) - saveg=phres%gval -! if(ocv()) write(*,*)'saveg allocated 1A: ',size(saveg),& -! gz%nofc,nofc2,nprop,moded - if(moded.gt.0) then -! only allocate if needed, some "out of memory" problems here calculating grid -! with just ionic liquid phase - allocate(savedg(3,gz%nofc,nprop)) - allocate(saved2g(nofc2,nprop)) - savedg=phres%dgval - saved2g=phres%d2gval - endif -! if(ocv()) write(*,*)'saveg allocated 1B: ' -! write(*,*)'Config G 3A: ',phres%gval(1,1)*rtg - phres%gval=zero - phres%dgval=zero - phres%d2gval=zero -! write(*,*)'Config G 3B: ',phres%gval(1,1)*rtg - iliqsave=.TRUE. -! write(*,117)'Saved ionliq G at Va id: ',& -! id,yionva,saveg(1,1) -117 format(a,i3,6(1pe12.4)) - elseif(id.eq.phlista(lokph)%i2slx(2)) then -! we have a neutral in second sublattice - iliqva=.FALSE. - yionva=-one - jonva=0 - if(.not.iliqsave) then -! We may have model without Va, for exampel (Ca+2)p(O-2,SiO4-4,SiO2)q, if so -! we must save all calculated values as the rest should be multiplied with Q - nprop=phmain%nprop - allocate(saveg(6,nprop)) - allocate(savedg(3,gz%nofc,nprop)) - allocate(saved2g(nofc2,nprop)) -! if(ocv()) write(*,*)'saveg allocated 2: ',size(saveg) - saveg=phres%gval - savedg=phres%dgval - saved2g=phres%d2gval - phres%gval=zero - phres%dgval=zero - phres%d2gval=zero - iliqsave=.TRUE. -! write(*,117)'Saved ionliq G at neutral id: ',& -! id,yionva,saveg(1,1) - endif - endif - endif - enddo pyqloop - if(moded.eq.0) goto 150 -!---------------------------------------------------- first derivatives - dpyqloop: do ll=1,msl -! here pyq is known, same loop as above to calculate dpyq(i)=pyq/y_i - id=endmemrec%fraclinks(ll,epermut) - if(id.gt.0) then -! pyq was multiplied with gz%yfrem(11) above, now divide with it - dpyq(id)=pyq/gz%yfrem(ll) -! write(*,*)'25B dpq/dy: ',ll,id,dpyq(id) - elseif(.not.ionicliq) then -! wildcard in the sublattice and NOT ionic liquid - do iw=incffr(ll-1)+1,incffr(ll) - dpyq(iw)=pyq - enddo - elseif(ll.ne.1) then -! wildcard in second subl of ionic liquid, same as for CEF - do iw=incffr(ll-1)+1,incffr(ll) - dpyq(iw)=pyq - enddo -! else -! wildcard in first subl of ionic liquid then just ignore first derivatives -! with respect to constituents in first sublattice -! continue - endif - enddo dpyqloop - if(moded.le.1) goto 150 -!---------------------------------------------------- second derivatives - d2pyqloop1: do ll=1,msl - id1=endmemrec%fraclinks(ll,epermut) - d2pyloop2: do lm=ll+1,msl - id2=endmemrec%fraclinks(lm,epermut) - if(id1.gt.0) then - if(id2.gt.0) then - d2pyq(ixsym(id1,id2))=dpyq(id1)/gz%yfrem(lm) - else -! wildcard in sublattice lm - do iw=incffr(lm-1)+1,incffr(lm) - d2pyq(ixsym(id1,iw))=dpyq(id1) - enddo - endif - else -! wildcard in sublattice ll - if(id2.gt.0) then - do iw=incffr(ll-1)+1,incffr(ll) - d2pyq(ixsym(id2,iw))=one - enddo - else -! wildcards in both sublattice ll and lm - do iw1=incffr(ll-1)+1,incffr(ll) - do iw2=incffr(lm-1)+1,incffr(lm) - d2pyq(ixsym(iw1,iw2))=pyq - enddo - enddo - endif - endif - enddo d2pyloop2 - enddo d2pyqloop1 -!---- jump here if moded is 0 or 1 -150 continue -! write(*,*)'Config G 4A: ',phres%gval(1,1)*rtg -! write(*,154)'endmember permutation: ',epermut,(clist(i),i=1,4) -154 format(a,i5,4i4,'--------------------------------') -155 format(a,i5,10i4) - proprec=>endmemrec%propointer - emprop: do while(associated(proprec)) - typty=proprec%proptype - if(typty.ne.1) then -! if property different from 1 (=G) find where to store it, use phmain link - do jl=2,lprop-1 - if(phmain%listprop(jl).eq.typty) goto 170 - enddo -! a new property, save its typty in listprop and increment lprop -! note that the property index typty is not used as index in gval etc -! as that can be very large. lprop is incremented by 1 for each property -! actually used in the model of the phase. - jl=lprop - phmain%listprop(jl)=typty - if(lprop.ge.nprop) then - write(*,*)'Too many parameter properties ',& - lprop,nprop,typty - gx%bmperr=7777; goto 1000 - endif - lprop=lprop+1 - phmain%listprop(1)=lprop -170 continue - ipy=jl - else - ipy=1 - endif -! calculate function and derivatives wrt T and P -! the results from eval_tpfun must also be different in different treads ... - lokfun=proprec%degreelink(0) - call eval_tpfun(lokfun,ceq%tpval,vals,ceq%eq_tpres) -! write(*,*)'calcg calling eval_tpfun 2: ',gx%bmperr,vals(1) - if(gx%bmperr.ne.0) goto 1000 - prop1: if(ipy.eq.1) then -! property 1 i.e. Gibbs energy, should be divided by RT - vals=vals/rtg - endif prop1 -! debug -! write(*,173)'endmember: ',endmemrec%antalem,pyq,vals(1) -!173 format(a,i3,4(1pe12.4)) -! multiply with py and derivatives. vals is composition independent -! write(*,*)'Config G 4B: ',vals(1)*rtg - noderz2: if(moded.gt.0) then - derloopz2: do id=1,gz%nofc - do itp=1,3 - phres%dgval(itp,id,ipy)=phres%dgval(itp,id,ipy)+ & - dpyq(id)*vals(itp) - enddo - if(moded.gt.1 .and. dpyq(id).gt.zero) then - do jd=id+1,gz%nofc - phres%d2gval(ixsym(id,jd),ipy)= & - phres%d2gval(ixsym(id,jd),ipy)+ & - d2pyq(ixsym(id,jd))*vals(1) - enddo - endif - enddo derloopz2 - endif noderz2 - do itp=1,6 - phres%gval(itp,ipy)=phres%gval(itp,ipy)+pyq*vals(itp) - enddo - proprec=>proprec%nextpr -! write(*,*)'Config G 4C: ',phres%gval(1,1)*rtg - enddo emprop -!------------------------------------------------------------------ -! take link to interaction records, use push and pop to save pyq etc -! pmq keeps track of the location in LASTPMQ and MAXPMQ -! for each interaction record in this binary interaction tree - intrec=>endmemrec%intpointer - gz%intlevel=0 - pmq=1 -! pmq is initiated by palmtree above in the interaction records -! write(*,*)'Config G 4D: ',phres%gval(1,1)*rtg - interloop: do while(associated(intrec)) -!---------------------------------------------------------------- -! come back here an interaction at a higher level or a poped next that must -! be pushed -200 continue -! write(*,*)'Config G 4E: ',phres%gval(1,1)*rtg,gz%intlevel - gz%intlevel=gz%intlevel+1 - call push_pyval(pystack,intrec,pmq,& - pyq,dpyq,d2pyq,moded,gz%nofc) -! intrec%order is initiated by palmtree to set a sequential number - pmq=intrec%order -! write(*,155)'Pushed: ',pmq,gz%intlevel -!------------------------------------------------------------------- -! come back here for another permutation of same paremeter (no push needed) -220 continue - bford: if(chkperm) then - setipermut: if(maxpmq(pmq).eq.0) then -! ipermut must be initiated and saved in lastpmq - ipermut=1; lastpmq(pmq)=ipermut -! On level 1 the number of permutation is in first location -! On level 2 it is more complicated but the first number of perm is in 2nd loc - maxpmq(pmq)=intrec%noofip(gz%intlevel) - else -! lastpmq and maxpmq already initiated (NOTE: they are used for all -! permutations of the same endmember, that is why they are stored here -! They cannot be pushed on the stack as the stack is also popped - ipermut=lastpmq(pmq)+1 - plimit: if(ipermut.gt.maxpmq(pmq)) then -! maximum interaction level allowed when permutations is 2 - level: if(gz%intlevel.eq.1) then -! This is always simple for level 1, - maxpmq(pmq)=maxpmq(pmq)+& - intrec%noofip(1) -! write(*,155)'new limit: ',ipermut,& -! maxpmq(pmq) - if(ipermut.le.maxpmq(pmq)) goto 230 - elseif(gz%intlevel.gt.2) then - write(*,*)'Max level 2 interactions allowed' - gx%bmperr=7777; goto 1000 - else - varying: if(intrec%noofip(1).eq.1) then -! If this is 1 then noofip(2) is number of permutations each time - maxpmq(pmq)=maxpmq(pmq)+intrec%noofip(2) - if(ipermut.le.maxpmq(pmq)) goto 230 - else -! This is more complicated, different number of permutations each time -! Example: noofip=(3,2,1,0,12) means there are 3 different permutations -! first time; 2 the second time; 1 the last time none; -! 12 is the total number of permutationss (including first order) -! Example 1: end member (A:A:A:A), no permutation -! first int B in 1 with perms: 2nd int C in 2 with perms: (3,3,3,3,12) -! (AB:A:A:A) (AB:AC:A:A) (AB:A:AC:A) (AB:A:A:AC) -! (A:AB:A:A) (AC:AB:A:A) (A:AB:AC:A) (A:AB:A:AC) -! (A:A:AB:A) (AC:A:AB:A) (A:AC:AB:A) (A:A:AB:AC) -! (A:A:A:AB) (AC:A:A:AB) (A:AC:A:AB) (A:A:AC:AB) -! Example 2: end member (A:A:A:A), no permutation -! first int B in 1 with perms: 2nd int B in 2 with perms: (3,2,1,0,6) -! (AB:A:A:A) (AB:AB:A:A) (AB:A:AB:A) (AB:A:A:AB) -! (A:AB:A:A) (A:AB:AB:A) (A:AB:A:AB) -! (A:A:AB:A) (A:A:AB:AB) -! (A:A:A:AB) none -! If mod(ipermut,noofip(1)) is 0 one should start from index 2 - nz=intrec%noofip(1) -! write(*,155)'noofip: ',ipermut,pmq,maxpmq(pmq),& -! (intrec%noofip(j),j=1,nz) - if(maxpmq(pmq).gt.0) then -! Previous increase of limit was greater than zero, special case for noofip=2 - if(intrec%noofip(1).eq.2) then - maxpmq(pmq)=-maxpmq(pmq) - else - nz=mod(ipermut-1,intrec%noofip(1)) - if(nz.eq.0) then - maxpmq(pmq)=-maxpmq(pmq) - else - maxpmq(pmq)=maxpmq(pmq)+& - intrec%noofip(1+nz) - endif - endif - if(ipermut.le.maxpmq(pmq)) goto 230 - else -! Previous increase of limit was 0, start repeating values from noofip(2.. - maxpmq(pmq)=intrec%noofip(2)-& - maxpmq(pmq) - if(ipermut.le.maxpmq(pmq)) goto 230 - endif -! write(*,155)'noperm: ',ipermut,pmq,& -! lastpmq(pmq),maxpmq(pmq) - endif varying -! as we have passed the limit of permutations, take higher or next interaction -!??? if(ipermut.le.maxpmq(pmq)) goto 230 - endif level -! We have exeeded the permutation limit, we should not go to any -! higher interaction but to a next interaction on same level (if any) -! or go down one level - if(associated(intrec%highlink)) then - if(gz%intlevel.eq.2) then - write(*,229)gz%intlevel -229 format('Error, max 2 levels of interactions',/& - ' with permutations!! ',i3) - gx%bmperr=7777; goto 1000 - endif -! Take the link to higher as no more permutations here - goto 290 - endif -!.............................. -! No higher level, if we cannot pop we must return to endmember - if(gz%intlevel.eq.0) exit interloop -! we must pop lower order interaction records here to get correct permutation - call pop_pyval(pystack,intrec,pmq,& - pyq,dpyq,d2pyq,moded,gz%nofc) - gz%intlevel=gz%intlevel-1 - pmq=intrec%order -!................................. -! intrec must not be associated in the popint: do-loop - nullify(intrec) - goto 295 - endif plimit -! We have now the permutation for this interaction in ipermut -230 continue - endif setipermut -! Found the permutations for option F and B, save it in lastpmq(pmq) - lastpmq(pmq)=ipermut -! Without permutations just set ipermut=1 - else - ipermut=1 - endif bford -!------------------------------------------------------------------- -! Code below until label 290 the same with and without permutations -! extract sublattice, constituent and fraction of interacting constituent -! NOTE "ic" used several times below, do not manipulate it!!! - intlat=intrec%sublattice(ipermut) - ic=intrec%fraclink(ipermut) - gz%intlat(gz%intlevel)=intlat - gz%intcon(gz%intlevel)=ic - gz%yfrint(gz%intlevel)=phres%yfr(ic) - if(ionicliq .and. iliqsave) then - if(intlat.eq.1 .and. yionva.gt.zero) then -! iliqsave is TRUE for ionic_liquid and for excess parameters without anions -! For cation interactions multiply with yionva. If no vacancies yionva=-1.0 - gz%yfrint(gz%intlevel)=phres%yfr(ic)*yionva -! write(*,*)'25B *yionva: ',yionva,gz%yfrint(gz%intlevel) - endif - endif -! calculate new PY incl derivatives. Moded to avoid unrequested derivatives -! IF interaction endmember is WILDCARD then the interaction is special, -! L(*,A) is y_A *(1-y_A) where 1-y_A is the sum of all fractions except A -! pyq = pyq * y_ic * (y_ix + y_iy + ... ) (all_other_in_same_sublattice)) -! derivatives are calculated for all constituents in intlat -! note one can also have wildcards in other sublattices - if(gz%endcon(intlat).gt.0) then - wildc=.FALSE. - ymult=gz%yfrint(gz%intlevel) - else - if(iliqsave) then -! I sincerely hope wildcards are never used in 2nd subl of ionic liquids ... - write(*,*)'Wildcard in second sublattice is not allowed for ionic liquids' - gx%bmperr=7777; goto 1000 - endif - wildc=.TRUE. - write(*,*)'wildcard found!' - ymult=gz%yfrint(gz%intlevel)*(one-gz%yfrint(gz%intlevel)) - endif - noder3A: if(moded.gt.0) then -! ...................................... loop for first derivatives - iloop1: do id=1,gz%nofc - if(moded.gt.1) then -! ...................................... second derivatives - iloop2: do jd=id+1,gz%nofc - if(iliqsave .and. intlat.eq.1) then -! For ionic liquids interaction parameters that are multiplied with yionva -! should also be multiplied with the power of yionva which is gz%intlevel+1 - d2pyq(ixsym(id,jd))=& - (gz%intlevel+1)*d2pyq(ixsym(id,jd))*ymult - else -! For all other models it is simply ... - d2pyq(ixsym(id,jd))=d2pyq(ixsym(id,jd))*ymult - endif - enddo iloop2 -! NOTE "ic" has been set above as the interacting constituent - if(iliqsave) then - if(intlat.eq.1 .and. yionva.gt.zero) then -! For ionic liquid model the 2nd derivatives must be multipled with yionva - if(id.eq.phlista(lokph)%i2slx(1)) then -! This is the vacancy, all 2nd derivatives multiplied with a factor - d2pyq(ixsym(id,ic))=& - (gz%intlevel+1)*d2pyq(ixsym(id,ic)) - endif - else - d2pyq(ixsym(id,ic))=dpyq(id)*yionva - endif - else - d2pyq(ixsym(id,ic))=dpyq(id) - endif - endif -! ................................. this is the first derivative, must be exact -! very messy for the ionic liquid here ... - dpyq(id)=dpyq(id)*ymult - if(ionicliq .and. iliqsave) then -! write(*,*)'Extra va power: ',id,gz%intlevel,& -! gz%intlat(gz%intlevel) - if(id.eq.phlista(lokph)%i2slx(1) .and. & - gz%intlat(gz%intlevel).eq.1) then -! for vacancies there is an additional factor if interaction in first subl - dpyq(id)=(gz%intlevel+1)*dpyq(id) -! write(*,197)gz%intlevel,gz%intcon(gz%intlevel) -197 format('25B: inter: ',5i3) - endif - endif - enddo iloop1 -! we must check if any endmember is wildcard like L(*:A,B) -! Hopefully this works also for ionic liquid interaction between neutrals - do ll=1,msl - if(ll.ne.intlat) then - if(gz%endcon(ll).lt.0) then - do iw=incffr(ll-1)+1,incffr(ll) - d2pyq(ixsym(iw,ic))=pyq - enddo - endif - endif - enddo - wildcard: if(wildc) then -! The interacting constituent is a wildcard ... calculate the contribution -! to second derivate from all fractions in intlat, remember incffr(0)=0. -! Ionic liquids should never have wildcards as intercations ... ? - do iw=incffr(intlat-1)+1,incffr(intlat) - if(iw.ne.ic) then - d2pyq(ixsym(iw,ic))=dpyq(iw) - endif -! write(*,213)'529: ',iw,ic,ixsym(iw,ic),& -! gz%intlevel,intlat,incffr(intlat) - dpyq(iw)=pyq*gz%yfrint(gz%intlevel) -! dpyq(jd)=pyq*gz%yfrint(gz%intlevel) - enddo -213 format(a,10i5) - dpyq(ic)=pyq*(one-gz%yfrint(gz%intlevel)) - else -! this is the normal first derivative of pyq*y(ic) with respect to y(ic)=ymult - dpyq(ic)=pyq - if(ionicliq) then -! write(*,214)'Multiply with y_va: ',& -! iliqsave,ic,intlat,yionva,pyq -214 format(a,l,2i3,4(1pe12.4)) - if(iliqsave .and. intlat.eq.1.and.yionva.gt.zero) then -! for compatibility with substitutional liquids, multiply interactions -! of cations (in 1st subl) when vacancies in 2nd with the vacancy fraction - dpyq(ic)=pyq*yionva - endif - endif - endif wildcard -! write(*,228)'25B: dpyq: ',(dpyq(ll),ll=1,4) -!228 format(a,6(1pe12.4)) - endif noder3A -! pyq calculated identically for wildcards as ymult set differently above -! It should work for ionic liquids as ymult has been multiplied with yionva - pyq=pyq*ymult -! write(*,*)'25B pyq: ',ymult,pyq - proprec=>intrec%propointer -!.............................. - intprop: do while(associated(proprec)) -! calculate interaction parameter, can depend on composition - call cgint(lokph,proprec,moded,vals,dvals,d2vals,gz,ceq) - if(gx%bmperr.ne.0) goto 1000 -! G parameters (ipy=1) are divided by RT inside cgint - typty=proprec%proptype - if(typty.ne.1) then -! other properties than 1 (G) must be stored in different gval(*,ipy) etc - do jl=2,lprop-1 - if(phmain%listprop(jl).eq.typty) goto 250 - enddo -! a new property, save its typty in listprop and increment lprop - jl=lprop - phmain%listprop(jl)=typty - lprop=lprop+1 - phmain%listprop(1)=lprop -250 continue -! here the value of ipy is set, 1 means G - ipy=jl - else - ipy=1 - endif -! note: adding to phres%gval at the end of noder4: if(....) - noder4: if(moded.gt.0) then - iloop3: do id=1,gz%nofc - if(moded.gt.1) then - iloop4: do jd=id+1,gz%nofc - phres%d2gval(ixsym(id,jd),ipy)= & - phres%d2gval(ixsym(id,jd),ipy)+ & - d2pyq(ixsym(id,jd))*vals(1) - enddo iloop4 - endif - do itp=1,3 - phres%dgval(itp,id,ipy)=& - phres%dgval(itp,id,ipy)+ & - dpyq(id)*vals(itp) - enddo - enddo iloop3 -! write(*,211)'Interactions: ',gz%iq,jonva -211 format(a,5i3,5x,i3) -! if(jonva.gt.0) then -! write(*,212)jonva,phres%dgval(1,jonva,1)*rtg -!212 format('with va: ',i3,6(1pe12.4)) -! endif -!............................... -! below contribution to derivatives from composition dependent parameters -! the values of gz%iq represent interacting constituents and are set in cgint - cdex1: if(gz%iq(5).gt.0) then -! gz%iq(5) is nonzero only for TOOP and similar models not implemented yet ... - gx%bmperr=4086; goto 1000 - elseif(gz%iq(4).gt.0) then -!............................... -! composition dependent reciprocal parameter -! for ionic liquid one must consider extra vacancy fraction ... -! contribution to second derivatives ignored ... -! remember ipy is property type for this parameter, set above - if(moded.gt.0) then - do jk=1,4 - do itp=1,3 - phres%dgval(itp,gz%iq(jk),ipy)=& - phres%dgval(itp,gz%iq(jk),ipy)+& - pyq*dvals(1,gz%iq(jk)) - enddo - enddo - endif - elseif(gz%iq(3).gt.0) then !cedex1 -! composition dependent ternary interaction in same sublattice, Mats model -! PROBABLY ERRORS HERE as no consideration of derivatives wrt other endmember -! constituents, only to the 3 interacting -! ALSO used to indicate derivatives wrt vacancies in ionic liquid model ??? -!...<<<<<<<...... indentation back 2 levels - if(moded.gt.1) then - noindent1: do jk=1,3 - do jl=jk+1,3 -! the second derivative for jk=jl calculated below as it is simpler - phres%d2gval(ixsym(gz%iq(jk),gz%iq(jl)),ipy)=& - phres%d2gval(ixsym(gz%iq(jk),gz%iq(jl)),ipy)+& - dpyq(gz%iq(jk))*dvals(1,gz%iq(jl))+& - dpyq(gz%iq(jl))*dvals(1,gz%iq(jk)) - enddo - enddo noindent1 - endif - do jk=1,3 - do itp=1,3 - phres%dgval(itp,gz%iq(jk),ipy)=& - phres%dgval(itp,gz%iq(jk),ipy)& - +pyq*dvals(itp,gz%iq(jk)) - enddo - phres%d2gval(ixsym(gz%iq(jk),gz%iq(jk)),ipy)=& - phres%d2gval(ixsym(gz%iq(jk),gz%iq(jk)),ipy)+& - 2.0D0*dpyq(gz%iq(jk))*dvals(1,gz%iq(jk)) - enddo -!...>>>>>>...........indentation back - elseif(gz%iq(2).gt.0) then !cedex1 -! gz%iq(2) nonzero means composition dependent binary interaction parameter, -! only RK yet. - noder3B: if(moded.gt.1) then -! one can maybe make this loop faster by just looping throungh endmembrs -! but then one must handle wildcard endmembers .... -! and there may be other bugs here anyway .... - do ic1=1,gz%nofc - add1=dpyq(ic1)*dvals(1,gz%iq(1))+& - dpyq(gz%iq(1))*dvals(1,ic1)+& - pyq*d2vals(ixsym(ic1,gz%iq(1))) - phres%d2gval(ixsym(ic1,gz%iq(1)),ipy)=& - phres%d2gval(ixsym(ic1,gz%iq(1)),ipy)+add1 - if(ic1.ne.gz%iq(1)) then -! this IF to avoid that the second derivative gz%iq(1) and gz%iq(2) is -! calculated twice. ic1 will at some time be equal to gz%iq(1) and to gz%iq(2) - add1=dpyq(ic1)*dvals(1,gz%iq(2))+& - dpyq(gz%iq(2))*dvals(1,ic1)+& - pyq*d2vals(ixsym(ic1,gz%iq(2))) - phres%d2gval(ixsym(ic1,gz%iq(2)),ipy)=add1+& - phres%d2gval(ixsym(ic1,gz%iq(2)),ipy) - endif - enddo - endif noder3B - do itp=1,3 - phres%dgval(itp,gz%iq(1),ipy)=& - phres%dgval(itp,gz%iq(1),ipy)& - +pyq*dvals(itp,gz%iq(1)) - phres%dgval(itp,gz%iq(2),ipy)=& - phres%dgval(itp,gz%iq(2),ipy)& - +pyq*dvals(itp,gz%iq(2)) - if(ionicliq) then -! for ionic liquid when interactions involve cations there is a contribution -! due to the vacancy fraction multiplied with the cations yc1*yc2*yva**2 -! we are dealing with binary RK interactions, gz%intlevel=1, check if -! interaction is in first sublattice (between cations) and vacancy in second - if(iliqva .and. gz%intlat(1).eq.1 & - .and. jonva.gt.0) then -! add pyq multipled with the derivative with respect to vacancy fraction -! This should be done for d2gval also but I skip that at present ... - phres%dgval(itp,jonva,ipy)=& - phres%dgval(itp,jonva,ipy)+& - pyq*dvals(itp,jonva) -! write(*,*)'jonva: ',jonva,pyq,dvals(1,jonva) - endif - endif - enddo - endif cdex1 -! end contribution to derivates from composition dependent parameters -!...................... - endif noder4 -! finally add the contribution to G, G.T etc - iloop6: do itp=1,6 - phres%gval(itp,ipy)=phres%gval(itp,ipy)+pyq*vals(itp) - enddo iloop6 - proprec=>proprec%nextpr - enddo intprop -! write(*,*)'Config G 4F: ',phres%gval(1,1)*rtg -! finished one interaction (or permutation on this level), go to higher level -! note that ipermut is saved in lastpmq(pmq). If there are more -! permutations on this level they will be calculated later also including -! higher order parameters. -!------------------------------------------------------------------ -! Take link to higher level records for current permutation -290 continue - intrec=>intrec%highlink - wrong: if(chkperm .and. associated(intrec)) then -! We must go to higher as we can have interactions with different permutations? - jpr=intrec%order - if(lastpmq(jpr).gt.0 .and.lastpmq(jpr).ge.maxpmq(jpr)) then -! if we nullify here we will take next rather than higher -! nullify(intrec) -! write(*,155)'Maybe skipping higer?: ',jpr,& -! lastpmq(jpr),maxpmq(jpr),gz%intlevel -! if(maxpmq(jpr).lt.0) maxpmq(jpr)=intrec%noofip(2)-& -! maxpmq(jpr) - endif - endif wrong -! if intrec is associated then go to big "interloop: do while()" loop -295 continue - popint: do while(.not.associated(intrec)) -! No higher level, pop lower order interaction records, if no pop: endmember - if(gz%intlevel.eq.0) exit interloop - call pop_pyval(pystack,intrec,pmq,& - pyq,dpyq,d2pyq,moded,gz%nofc) - gz%intlevel=gz%intlevel-1 - pmq=intrec%order -! check if we have more permutations for this record - if(chkperm) then - if(lastpmq(pmq).lt.maxpmq(pmq)) then - goto 200 - endif - endif - intrec=>intrec%nextlink - enddo popint -! we should loop here if we found a higher order record or -! a lower order record with a next link - enddo interloop -298 continue -! write(*,*)'Config G 4X: ',phres%gval(1,1)*rtg -! take next permutation of the end member fractions - enddo empermut -300 continue -! take next end member -! write(*,155)'endmem: ',epermut,endmemrec%noofpermut,endmemrec%antalem - endmemrec=>endmemrec%nextem - enddo endmemloop -! write(*,*)'Config G 5: ',phres%gval(1,1)*rtg -!------------------------------------------------------------------------ -! end loop for this fraction type, initiation for next in the beginning of loop -! but we may have to calculate once again with same fraction type but -! with the fractions as disordered fractions -! write(*,*)' **** 25B Warning: This code should never be executed ',& -! nevertwice -! if(nevertwice) then -! goto 400 -! endif - goto 400 -!------------------------------------------------ -! the code from disord: if ... endif is redundant - disord: if(fractype.eq.1 .and. btest(phlista(lokph)%status1,phmfs) & - .and. btest(phmain%status2,csorder)) then -! Handle additions of several fraction set ?? Additions calculated -! after both ordered and disordered fraction set calculated -! write(*,611)'25B ftyp:',fractype,btest(phlista(lokph)%status1,phmfs),& -! btest(phmain%status2,csorder),first,lokph -!611 format(a,i3,3(1x,L),2i3) - if(first) then -! calculate with next fraction type -! NEW METHOD: no need to calculate with all fractions as disordered - first=.false. - write(*,*)'25B: next fraction type' - goto 400 -!------------ code below redundant until ^^^^^^^^^^^^^^^^^^^^^^^^^ -! this is no longer needed as we just add the disordered part -! but do not delete yet ... wait until I know it works ... - allocate(savey(gz%nofc)) - savey=phres%yfr -! write(*,*)'cg: ',phmain%phlink,phmain%disfra%varreslink -! ??? very uncertain how to call disordery ..... -! call disordery(phmain,phmain%disfra%varreslink,ceq) - call disordery(phmain,ceq) - nprop=phmain%nprop - allocate(saveg(6,nprop)) - allocate(savedg(3,gz%nofc,nprop)) - allocate(saved2g(nofc2,nprop)) -! write(*,*)'saveg allocated 3: ',size(saveg) - saveg=phres%gval - savedg=phres%dgval - saved2g=phres%d2gval - phres%gval=zero - phres%dgval=zero - phres%d2gval=zero - goto 110 - else -! We have now calculated the 4SL model with both as original and disordered -! We should now subreact the disordered from the ordered -! this is debug output -! do i1=1,gz%nofc -! write(*,602)'25B Gx: ',i1,phres%dgval(1,i1,1),savedg(1,i1,1) -! enddo -!602 format(a,i3,6(1pe14.6)) -! Ordered part calculated with disordered fractions, subtract this -! from the first, restore fractions and deallocate -! THIS IS TRICKY -! NOTE all sublattices are identical in this case with the same number -! of constituents -! First sum all second derivatives into tmpd2g, moded=1 means only 1st deriv - noder6A: if(moded.gt.1) then - nz=fracset%tnoofxfr - allocate(tmpd2g(nz*(nz+1)/2,nprop)) - tmpd2g=zero -! DEBUG, problem with partitioning 4 sublattice FeNi: -! write(*,613)'25B sub: ',nz,gz%nofc,fracset%latd,fracset%y2x -!613 format(a,3i3,2x,20i3) -! write(*,614)'25B dxi/dyj: ',fracset%dxidyj -!614 format(a,(10f7.4)) - do ipy=1,lprop-1 - do i1=1,gz%nofc - j1=fracset%y2x(i1) - do i2=i1,gz%nofc - j2=fracset%y2x(i2) - tmpd2g(ixsym(j1,j2),ipy)=tmpd2g(ixsym(j1,j2),ipy)+& - phres%d2gval(ixsym(i1,i2),ipy) - enddo - enddo - enddo -! tmpd2g is now d2G/dxidxj calculated with disordered fractions -! subract that from saved d2G/dyidyj saved in saved2g taking into account -! the derivatives dxi/dyj (in fracset%dxidyj) - do ipy=1,lprop-1 - do i1=1,gz%nofc - j1=fracset%y2x(i1) - do i2=i1,gz%nofc -! subtract from saved value - j2=fracset%y2x(i2) - phres%d2gval(ixsym(i1,i2),ipy)=& - saved2g(ixsym(i1,i2),ipy)-& - tmpd2g(ixsym(j1,j2),ipy)*& - fracset%dxidyj(i1)*fracset%dxidyj(i2) - enddo - enddo - enddo - deallocate(tmpd2g) - endif noder6A -!--------------------- -! sum all first partial derivates to first sublattice - noder6B: if(moded.gt.0) then -! write(*,613)'25B dG/dx: ',fracset%ndd,fracset%nooffr - do ipy=1,lprop-1 - do ider=1,3 - do is=1,fracset%nooffr(1) - sum=zero - kk=is - do ll=1,fracset%latd - sum=sum+phres%dgval(ider,kk,ipy) -! it is not really necessary to put phres%dgval it to zero, just for prudence -! phres%dgval(ider,kk,ipy)=zero - kk=kk+fracset%nooffr(1) - enddo - phres%dgval(ider,is,ipy)=sum - enddo - if(fracset%ndd.eq.2) then -! one can have 2 sets of ordered subl like (Al,Fe)(Al,Fe)...(C,Va)(C,Va)... - ioff=fracset%nooffr(1)*fracset%latd - do is=1,fracset%nooffr(2) - sum=zero - kk=ioff+is - do ll=fracset%latd+1,phlista(lokph)%noofsubl - sum=sum+phres%dgval(ider,kk,ipy) - phres%dgval(ider,kk,ipy)=zero - kk=kk+fracset%nooffr(2) - enddo - phres%dgval(ider,ioff+is,ipy)=sum - enddo - endif - enddo - enddo -!------------------------- - if(moded.gt.0) then - do ipy=1,lprop-1 -! loop in negative direction avoid destroy the values in phres%dgval first subl - do i1=gz%nofc,1,-1 -! all derivatives wrt same element from all sublattices is in first sublattice - j1=fracset%y2x(i1) - do ider=1,3 -! Finally subtract this contribution from saved values -! phres%dgval(ider,i1,ipy)=savedg(ider,i1,ipy)-& - xxx=savedg(ider,i1,ipy)-& - phres%dgval(ider,j1,ipy)*fracset%dxidyj(i1) -! write(*,615)'25B Gy-Gx: ',ider,i1,ipy,j1,& -! savedg(ider,i1,ipy),phres%dgval(ider,j1,ipy),& -! fracset%dxidyj(i1),xxx -!615 format(a,4i3,4(1pe14.6)) - phres%dgval(ider,i1,ipy)=xxx - enddo - enddo - enddo - endif - endif noder6B - do ipy=1,lprop-1 - do ider=1,6 - phres%gval(ider,ipy)=saveg(ider,ipy)-& - phres%gval(ider,ipy) - enddo - enddo -! restore ordered fractions and deallocate save arrays -! write(*,612)'25B yd: ',phres%yfr - phres%yfr=savey -! write(*,612)'25B yo: ',phres%yfr -612 format(a,6(1pe11.3),(7x,6e11.3)) -! why set to zero if I deallocate ?? -! savey=zero -! saveg=zero -! savedg=zero -! saved2g=zero -! if(ocv()) write(*,*)'saveg DE-allocated 1: ',size(saveg) - deallocate(savey) - deallocate(saveg) - deallocate(savedg) - deallocate(saved2g) - endif -! ----------------- code above redundant ^^^^^^^^^^^^^^^^^^^^^^^^ - endif disord -400 continue - enddo fractyp -!-------------------------------------------------------------- -! finished loops for all fractypes, now add together G and all -! partial derivatives for all fractypes -410 continue -! cheking for properties -! if(ocv()) then -! write(*,411)lprop-1,(phmain%listprop(j1),j1=2,lprop) -! write(*,412)'Val: ',(phmain%gval(1,j1),j1=1,lprop-1) -!411 format('Properties: ',i3,': ',10i4) -412 format(a,(6E12.4)) -! endif - norfc=phlista(lokph)%tnooffr - fractionsets: if(btest(phlista(lokph)%status1,phmfs)) then -!---------------------------------------------------------------- -! for disordered part of sigma we may have to multiply the disordered -! part with fsites to have correct formula unit -! write(*,*)'25B fsites 1: ',phmain%disfra%fsites - fsites=phmain%disfra%fsites -! add together contributions from different fractypes -! phres is last calculated part, set phpart to ordered part (phmain) - phpart=>phmain -! loop for all second and first derivatives using chain rule -! and coefficients from fracset%dxidyj -! d2f1/dyidyj = d2f2/dxkdxl*dxk/dyi*dxl/dyj -! gz%nofc are number of disordered constituents -! norfc are number of ordered constituents -! lprop-1 is number of properties to be summed -! G(tot) = GD(x)+(GO(y)-GO(y=x)) -! G(tot).yj = dGD(x).dxi*dxdyj + (GO(y).yj - GO(y=x).yj) -! configurational entropy calculated only for GO(y) - noder7A: if(moded.gt.0) then - do i1=1,norfc - j1=fracset%y2x(i1) -! second derivatives - noder7B: if(moded.gt.1) then - do i2=i1,norfc -! add the contributions from the disordered part - j2=fracset%y2x(i2) - do ipy=1,lprop-1 - phpart%d2gval(ixsym(i1,i2),ipy)=& - phpart%d2gval(ixsym(i1,i2),ipy)+& - fsites*phres%d2gval(ixsym(j1,j2),ipy)*& - fracset%dxidyj(i1)*fracset%dxidyj(i2) - enddo - enddo - endif noder7B -! first derivatives - do ipy=1,lprop-1 -! add1=phpart%dgval(1,i1,ipy) - do ider=1,3 -! phpart%dgval(ider,i1,ipy)=phpart%dgval(ider,i1,ipy)+& - xxx=phpart%dgval(ider,i1,ipy)+& - fsites*phres%dgval(ider,j1,ipy)*fracset%dxidyj(i1) -! phres have the disordred contribution -! write(*,413)'25B Gd+Go:',ider,i1,j1,& -! phpart%dgval(ider,i1,ipy),fsites,& -! phres%dgval(ider,j1,ipy),fracset%dxidyj(i1),xxx -! write(*,413)'25X Gd+Go:',ider,i1,j1,& -! phmain%dgval(ider,i1,ipy),fsites,& -! phres%dgval(ider,j1,ipy),fracset%dxidyj(i1),xxx - phpart%dgval(ider,i1,ipy)=xxx - enddo - enddo - enddo - endif noder7A -413 format(a,3i3,6(1pe12.4)) -! Integral values - do ipy=1,lprop-1 -! add1=phpart%gval(1,ipy) - do ider=1,6 - phpart%gval(ider,ipy)=phpart%gval(ider,ipy)+& - fsites*phres%gval(ider,ipy) - - enddo -! if(ocv()) write(*,413)'25B G:',ipy,0,0,& -! write(*,413)'25B G:',ipy,0,0,& -! phpart%gval(1,ipy),add1,phres%gval(1,ipy) - enddo - endif fractionsets -! now set phres to ordered+disorded results and forget phpart - phres=>phmain -!................................ -! write(*,*)'25B: ioliq+saved: ',ionicliq,iliqsave,phres%gval(1,1) - ionliqsum: if(ionicliq .and. iliqsave) then -! For ionic liquid we may have to add gsave+Q*gval (with chain rule ...) -! G = saveg + Q*phres%gval with 1st and 2nd derivatives -! NOT FINISHED !!! interaction parameters above with VA must be treated -! -!vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv -! BEWHARE: FOR IONIC_LIQUID Thermo-Calc calculates G = Q G_M -! if there are no end-member parameters (G_M is the Gibbs energy per -! formula unit and Q is the number of sites in second sublattice), -! This is wrong but all endmember parameters are never zero for a real liquid. -!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -! -! write(*,*)'Config G 6: ',phres%gval(1,1)*rtg - if(moded.eq.0) goto 490 -! write(*,491)'25B ionliq: ',phlista(lokph)%i2slx,phlista(lokph)%nooffr -491 format(a,2i3,5x,2i3) - firstd: do i1=1,norfc - secondd: do i2=i1,norfc - do ipy=1,lprop-1 -! write(*,497)'adding: ',i1,i2,ixsym(i1,i2),ipy -497 format(a,10i3) - phres%d2gval(ixsym(i1,i2),ipy)=saved2g(ixsym(i1,i2),ipy)+& - phres%sites(2)*phres%d2gval(ixsym(i1,i2),ipy) - add1=zero -! IMPORTANT note dpqdy(i1) the the charge of iq, do not confuse with dpyq ... - if(i1.le.phlista(lokph)%nooffr(1)) then - add1=phres%dpqdy(i1)*phres%dgval(1,i2,ipy) - endif - if(i2.le.phlista(lokph)%nooffr(1)) then - add1=add1+phres%dpqdy(i2)*phres%dgval(1,i1,ipy) - endif - phres%d2gval(ixsym(i1,i2),ipy)=phres%d2gval(ixsym(i1,i2),ipy)+& - add1 - enddo - enddo secondd -! hm, when debugging here phres%dgval(1,*,1)=0 so ... - add1=savedg(1,i1,1) - sum=phres%dgval(1,i1,1) - if(phres%dpqdy(i1).lt.1.0D-60) phres%dpqdy(i1)=zero - do ipy=1,lprop-1 - do ider=1,3 -! this calculates the proper ionic liquid model, not Q times - phres%dgval(ider,i1,ipy)=& - savedg(ider,i1,ipy)+& - phres%sites(2)*phres%dgval(ider,i1,ipy) -! The contribution from the derivative of Q = \sum_i nu_i y_i, dQ/dy_i = nu_i -! G = G1 + Q G2 where -! G1 = \sum_i \sum_j y_i y_j G_ij + config.entropy -! G2 = y_va\sum_i y_i G_i + Q\sum_k y_k G_k -! Above were added: dG/dy_i = dG1/dy_i + + Q dG2/dy_i -! For cations we must add also dG/dy_i = dG/dy_i + nu_i G2 - if(i1.le.phlista(lokph)%nooffr(1)) then -! nooffr(1) is the number of constituents in first sublattice - phres%dgval(ider,i1,ipy)=phres%dgval(ider,i1,ipy)+& - phres%dpqdy(i1)*phres%gval(ider,ipy) - endif - enddo - enddo -! write(*,747)'suming: ',i1,savedg(1,i1,1)*rtg,phres%dgval(1,i1,1)*rtg,& -! phres%dpqdy(i1),phres%gval(1,1) -! write(*,747)'25Bx:',i1,add1,sum,phres%dgval(1,i1,1),phres%dpqdy(i1),& -! phres%sites(2),savedg(1,i1,1) -747 format(a,i2,6(1pe12.4)) - enddo firstd -! write(*,*)'summed: ',savedg(1,1,1)*rtg,phres%dgval(1,1,1)*rtg -! Integral values: G = saveg + Q*phres%gval with T and P derivatives -490 continue -! write(*,492)'ionsum: ',saveg(1,1),phres%gval(1,1),& -! (saveg(1,1)+phres%gval(1,1))*rtg*phres%sites(2) -492 format(a,6(1pe12.4)) -! write(*,*)'Config G 7A: ',phres%gval(1,1)*rtg - do ipy=1,lprop-1 - do ider=1,6 - phres%gval(ider,ipy)=saveg(ider,ipy)+& - phres%sites(2)*phres%gval(ider,ipy) - enddo - enddo -! write(*,*)'Config G 7B: ',phres%gval(1,1)*rtg,saveg(1,1)*rtg -! strange bug which changes the results for a calculation with only C1 -! if the ionic liquid has been non-suspended at some previous calculation ... - saveg=zero -! if(ocv()) write(*,*)'De-allocated saveg 2: ',size(saveg) -! no need to set them zero if they will be deallocated?? -! savedg=zero -! saved2g=zero - deallocate(saveg) - if(moded.gt.0) then - deallocate(savedg) - deallocate(saved2g) - endif -!499 continue - endif ionliqsum -!................................ -! calculate additions like magnetic contributions etc and add to G - addrec=>phlista(lokph)%additions - additions: do while(associated(addrec)) -! if(addlista(lokadd)%type.eq.1) then -! Note for phases with a disordered fraction set, gz%nofc is equal to -! the disordered number of fractions here -! i1=gz%nofc - gz%nofc=phlista(lokph)%tnooffr -! write(*,*)'25B gz%nofc: ',i1,gz%nofc -! moded is 0, 1 or 2 if derivatives should be calculated, phres is pointer -! to result arrays, lokadd is the addition record, listprop is needed to -! find where TC and BM are stored, gz%nofc are number of constituents - call addition_selector(addrec,moded,phres,lokph,gz%nofc,ceq) - if(gx%bmperr.ne.0) goto 1000 -! there are actually no other additions defined ... - addrec=>addrec%nextadd - enddo additions -! there are some special properties like mobilities and similar which -! have a conmponent or constituent index like MQ& -! ipy=typty/100+mod(typty,100) -! if(ipy.gt.10) then -! write(*,*)'Property ',typty,ipy -1000 continue - if(chkperm) then -! wait for checking for errors .... -! write(*,*)'Press return' -! read(*,297)ch1 -!297 format(a) - endif -! running out of memory?? - deallocate(dpyq) - deallocate(d2pyq) - deallocate(dvals) - deallocate(d2vals) -! write(*,1001)gx%bmperr,(phres%gval(i,1),i=1,4) -! write(*,1002)(phres%dgval(1,i,1),i=1,3) -! write(*,1003)(phres%d2gval(i,1),i=1,6) -1001 format('calcg g: ',i5,4(1PE15.7)) -1002 format('calcg dg: ',3(1PE15.7)) -1003 format('calcg d2g: ',6(1PE11.3)) - return - end subroutine calcg_internal - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine setendmemarr(lokph,ceq) -! stores the pointers to all ordered and disordered endmemners in arrays - implicit none - integer lokph - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer ll,nz,noemr - TYPE(gtp_endmember), pointer :: emrec - TYPE(gtp_fraction_set), pointer :: disfraset - if(allocated(phlista(lokph)%oendmemarr)) then - deallocate(phlista(lokph)%oendmemarr) -! allways allocate place for maximum endmembers (product of constituents) - nz=1 - do ll=1,phlista(lokph)%noofsubl - nz=nz*phlista(lokph)%nooffr(ll) - enddo - allocate(phlista(lokph)%oendmemarr(nz)) - noemr=0 - emrec=>phlista(lokph)%ordered - do while(associated(emrec)) - noemr=noemr+1 - phlista(lokph)%oendmemarr(noemr)%p1=>emrec - emrec=>emrec%nextem - enddo - phlista(lokph)%noemr=noemr - endif -! same for disordered endmembers (if any) -! Data for this is stored in phase_varres record, same index as phlista !!! - if(allocated(phlista(lokph)%dendmemarr)) then - deallocate(phlista(lokph)%dendmemarr) -! allways allocate place for maximum endmembers (product of constituents) - disfraset=>ceq%phase_varres(lokph)%disfra - nz=1 - do ll=1,disfraset%ndd - nz=nz*disfraset%nooffr(ll) - enddo - allocate(phlista(lokph)%dendmemarr(nz)) - noemr=0 - emrec=>phlista(lokph)%disordered - do while(associated(emrec)) - noemr=noemr+1 - phlista(lokph)%dendmemarr(noemr)%P1=>emrec - emrec=>emrec%nextem - enddo - phlista(lokph)%ndemr=noemr - endif -1000 continue - return - end subroutine setendmemarr - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine tabder(iph,ics,ceq) -! tabulate derivatives of phase iph with current constitution and T and P - implicit none - integer iph,ics - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - character name*24 - double precision kappa,napfu,t,p,rtg,g,v,s,h,u,f,cp,alpha - integer tnk,lokph,nsl,lokres,lokcs,ll,ll2,kk1,kk2,kk3,kk4,loksp -! - lokph=phases(iph) - nsl=phlista(lokph)%noofsubl -! calculate G and derivatives, lokres returns index of phase_varres - call calcg(iph,ics,2,lokres,ceq) - if(gx%bmperr.ne.0) then - goto 1000 - endif -! number of moles of atoms per formula unit - napfu=ceq%phase_varres(lokres)%abnorm(1) - T=ceq%tpval(1) - P=ceq%tpval(2) - rtg=globaldata%rgas*T - lokcs=lokres -! returned values: G, G.T=-S, G.P=V, G.T.T=-Cp/T G.T.P=V*alpha, G.P.P=-V*kappa -! all divided by RT and per mole formula unit of phase -! G=H-TS, F=U-TS, H=U+PV, S=-G.T, V=G.P -! H=G+TS=G-T*G.T, U=H-PV=(G-T*G.T)-P*G.P, CP=-T*G.T.T -! alpha= 1/V*V.T = G.T.P/V, kappa = -1/V*V.P = -G.P.P/V - G=rtg*ceq%phase_varres(lokcs)%gval(1,1) -! write(*,5)'tabder 2: ',rtg,G - S=-rtg*ceq%phase_varres(lokcs)%gval(2,1) - V=rtg*ceq%phase_varres(lokcs)%gval(3,1) - H=G+T*S - U=H-P*V - F=U-T*S - CP=-T*rtg*ceq%phase_varres(lokcs)%gval(4,1) - if(V.ne.zero) then - alpha=rtg*ceq%phase_varres(lokcs)%gval(5,1)/V - kappa=rtg*ceq%phase_varres(lokcs)%gval(6,1)/V - else - alpha=zero - kappa=zero - endif - write(kou,100)napfu,T,P,G -100 format(/'Per mole FORMULA UNIT of the phase, ',1pe12.4,' atoms'/& - 'at T= ',0pF8.2,' K and P= ',1PE13.6,' Pa',/ & - 'Gibbs energy J/mol ',28('.'),1Pe16.8) - write(kou,102)F,H,U,S,V,CP,alpha,kappa -102 format('Helmholtz energy J/mol ',24('.'),1PE16.8 & - /'Enthalpy J/mol ',32('.'),1PE16.8 & - /'Internal energy J/mol ',25('.'),1PE16.8 & - /'Entropy J/mol/K ',31('.'),1PE16.8 & - /'Volume m3 ',37('.'),1PE16.8 & - /'Heat capacity J/mol/K ',25('.'),1PE16.8 & - /'Thermal expansion 1/K ',25('.'),1PE16.8 & - /'Bulk modulus 1/Pa ',29('.'),1PE16.8) - tnk=phlista(lokph)%tnooffr - ll=1 - kk1=0 - kk2=phlista(lokph)%nooffr(ll) - dy1loop: do while(kk1.le.tnk) - kk1=kk1+1 - if(kk1.gt.kk2) then -! write(*,11)'tabder 2: ',kk1,kk2,ll,tnk,nsl -!11 format(a,10i3) - ll=ll+1 - if(ll.gt.nsl) exit - kk2=kk2+phlista(lokph)%nooffr(ll) - endif - if(phlista(lokph)%nooffr(ll).eq.1) then -! write(*,*)'tabder 1: ',kk1,kk2,ll,tnk - ll=ll+1 - if(ll.gt.nsl) exit - kk2=kk2+phlista(lokph)%nooffr(ll) - cycle - endif - loksp=phlista(lokph)%constitlist(kk1) - name=splista(loksp)%symbol - write(kou,110)name(1:len_trim(name)),ll -110 format('First partial derivative with respect to ',a,& - ' in sublattice ',i2,' of') - write(kou,120)rtg*ceq%phase_varres(lokcs)%dgval(1,kk1,1),& - rtg*(ceq%phase_varres(lokcs)%dgval(1,kk1,1)-& - T*ceq%phase_varres(lokcs)%dgval(2,kk1,1)),& - rtg*ceq%phase_varres(lokcs)%dgval(2,kk1,1),& - rtg*ceq%phase_varres(lokcs)%dgval(3,kk1,1) -120 format(5x,'G ',40('.'),1PE16.8, & - /5x,'H ',40('.'),1PE16.8, & - /5x,'G.T ',38('.'),1PE16.8, & - /5x,'G.P ',38('.'),1PE16.8) - kk3=kk1 - kk4=kk2 - ll2=ll - write(kou,150) -150 format(5x,'Second partial derivative of Gibbs energy with respect to also') - dy2loop: do while(kk3.le.tnk) - if(phlista(lokph)%nooffr(ll2).gt.1) then -! write(kou,160)name(1:len_trim(name)),ll2, & - write(kou,160)name,ll2, & - rtg*ceq%phase_varres(lokcs)%d2gval(ixsym(kk1,kk3),1) -160 format(10x,a,' in ',i2,5('.'),1PE16.8) - endif - kk3=kk3+1 - if(kk3.le.tnk) then - loksp=phlista(lokph)%constitlist(kk3) - name=splista(loksp)%symbol - endif - if(kk3.gt.kk4) then - ll2=ll2+1 - if(ll2.gt.nsl) exit - kk4=kk4+phlista(lokph)%nooffr(ll2) - endif - enddo dy2loop -! write(*,*)'tabder 7A: ',kk1,kk2 - enddo dy1loop -900 continue -! write(*,*)'tabder 7B: ',kk2 -! write(*,*)'tabder: ',rtg,rtg*phase_varres(lokcs)%gval(1,1) -1000 continue - return - end subroutine tabder - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine cgint(lokph,lokpty,moded,vals,dvals,d2vals,gz,ceq) -! calculates an excess parameter that can be composition dependent -! gz%yfrem are the site fractions in the end member record -! gz%yfrint are the site fractions in the interaction record(s) -! lokpty is the property index, lokph is the phase record -! moded=0 means only G, =1 G and dG/dy, =2 all - implicit none - integer moded,lokph - TYPE(gtp_property), pointer :: lokpty - TYPE(gtp_parcalc) :: gz - double precision vals(6),dvals(3,gz%nofc) - TYPE(gtp_equilibrium_data) :: ceq -!\end{verbatim} -! temporary data like gz%intlevel, gz%nofc etc - double precision d2vals(gz%nofc*(gz%nofc+1)/2),valtp(6) - double precision vv(0:2),fvv(0:2) - integer lfun,jdeg,jint,jl,ivax - double precision rtg,dx0,dx,dx1,dx2,ct,fvs,dvax0,dvax1,dvax2,yionva - double precision, parameter :: onethird=one/3.0D0,two=2.0D0 - logical ionicliq,iliqva,iliqneut -! zeroing 5 iq, and vals, dvals and d2vals - gz%iq=0 - vals=0 - dvals=0 - d2vals=0 - rtg=gz%rgast - if(lokpty%degree.eq.0) then -!---------------------------------------------------------------------- -! no composition dependence - lfun=lokpty%degreelink(0) - call eval_tpfun(lfun,gz%tpv,vals,ceq%eq_tpres) - if(gx%bmperr.ne.0) goto 1000 - if(lokpty%proptype.eq.1) then - vals=vals/rtg - endif - goto 1000 - endif -! set default variables for ionic liquid - ionicliq=.FALSE. - iliqva=.FALSE. - iliqneut=.FALSE. - yionva=zero - if(btest(phlista(lokph)%status1,PHIONLIQ)) then -! write(*,17)'25B RK: ',phlista(lokph)%i2slx(1),gz%endcon(gz%intlat(1)) -17 format(a,5i3) -! write(*,*)'ionicliq set true' -! write(*,*)'Const in subl: ',gz%intlat(1),gz%endcon(gz%intlat(1)) - ionicliq=.TRUE. - if(gz%endcon(2).eq.phlista(lokph)%i2slx(1)) then -! VA endmember in the 2nd sublattice, this is the complicated case - yionva=gz%yfrem(2) - ivax=phlista(lokph)%i2slx(1) - if(gz%intlat(1).eq.1) then -! interaction in sublattice 1 between two cations same as substituional L_A,B -! with each cation fraction multiplied with vacancy -! Also set TRUE for reciprocal interactions (gz%intlevel=2) - iliqva=.TRUE. - else -! interaction in sublattice 2 between Va and neutral (i.e. cation and neutral) -! same as substitutional L_A,B with cation fraction multiplied with vacancy - iliqneut=.TRUE. - endif - endif - endif - intlev: if(gz%intlevel.eq.1) then -!---------------------------------------------------------------------- -! plain binary Redlich Kister. gz%endcon can be wildcard, i.e. negative -! but for the moment give error message in that case -! A binary wildcard excess parameter means y_A ( 1 - y_A) * L_A* -! most naturally gz%intcon(1) would be negative - gz%iq(1)=gz%endcon(gz%intlat(1)) - gz%iq(2)=gz%intcon(1) - if(gz%iq(1).lt.0 .or. gz%iq(2).lt.0) then -! composition dependent wildcard interaction not implemented -! y(1-y) ( L0 + (2y-1) L1 + (2y-1)**2 L2 + ....) - gx%bmperr=4031; goto 1000 - endif -! endmember fraction minus interaction fraction - dx0=gz%yfrem(gz%intlat(1))-gz%yfrint(1) - if(ionicliq) then - if(iliqva) then -! interaction between cations with vacancy on second sublattice -! NOTE intraction fraction alreay multiplied with yionva!!! - dx0=gz%yfrem(gz%intlat(1))-gz%yfrint(1)/yionva - dvax0=dx0 - dx0=yionva*dx0 -! write(*,*)'Cation interaction with vacancies on 2nd: ',dvax0,dx0,& -! gz%yfrem(gz%intlat(1)),gz%yfrint(1),gz%iq(2),gz%intlat(1) - elseif(iliqneut) then -! interaction between vacancy and neutral in second sublattice - dvax0=gz%yfrem(gz%intlat(1)) - dx0=gz%yfrem(gz%intlat(1))*yionva-gz%yfrint(1) - endif - endif - vals=zero - dx=one - dx1=zero - dx2=zero - dvax2=zero - dvax1=zero -! write(*,*)'25B c1bug: ',ionicliq,iliqva,iliqneut -! special for ionic liquid: when two cation interacts with Va in second -! sublattice the vacancy fraction is raised by power 2 - RK: do jdeg=0,lokpty%degree - lfun=lokpty%degreelink(jdeg) - call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres) - if(gx%bmperr.ne.0) goto 1000 - if(lokpty%proptype.eq.1) then -! property type 1 is G and should be normalized by RT - valtp=valtp/rtg - endif - vals=vals+dx*valtp -! write(*,11)'25B dx: ',gz%iq(1),gz%iq(2),jdeg,dx0,dx,dx1 -11 format(a,3i2,6(1pe12.4)) -! no composition derivative. if moded=0 only G, =1 G+G.Y, =2 all - noder5: if(moded.gt.0) then -! first derivatives, jl=1: dG/dyA dG/dyB; jl=2: d2G/dTdy; jl=3: d3G/dPdy -! for iliqneut there should not be same -dx1 ... gz%iq(2) is neutral - do jl=1,3 - dvals(jl,gz%iq(1))=dvals(jl,gz%iq(1))+dx1*valtp(jl) - dvals(jl,gz%iq(2))=dvals(jl,gz%iq(2))-dx1*valtp(jl) - if(iliqva) then -! derivative with respect to vacancy fraction for (yc1-yc2)*yva: yc1-yc2 - dvals(jl,ivax)=dvals(jl,ivax)+dvax1*valtp(jl) -! if(jl.eq.1) write(*,11)'25B iliqva: ',0,0,ivax,dvax1 - elseif(iliqneut) then -! derivative with respect to vacancy fraction for (yc1*yva-yn): yc1 - dvals(jl,ivax)=dvals(jl,ivax)+dvax1*valtp(jl) - endif - enddo -! second derivatives, d2G/dyAdyA d2G/dyAdyB d2G/dyBdyB - if(moded.gt.1) then - d2vals(ixsym(gz%iq(1),gz%iq(1)))=& - d2vals(ixsym(gz%iq(1),gz%iq(1)))+dx2*valtp(1) - d2vals(ixsym(gz%iq(1),gz%iq(2)))=& - d2vals(ixsym(gz%iq(1),gz%iq(2)))-dx2*valtp(1) - d2vals(ixsym(gz%iq(2),gz%iq(2)))=& - d2vals(ixsym(gz%iq(2),gz%iq(2)))+dx2*valtp(1) -! if(iliqva) then -! unfinished d2G/dyvdyv d2G/dyvdyA d2G/dyvdyB -! d2vals(ixsym(ivax,ivax))=& -! d2vals(ixsym(ivax,ivax))+dvax2*valtp(1) -! elseif(iliqneut) then -! continue -! endif - endif - endif noder5 -! next power of dx - if(iliqva) then -! interaction between two cations, dx0=y_va*(y_c1 - y_c2) - dx2=(jdeg+1)*dx1 - dvax2=(jdeg+1)*dvax1 - if(jdeg.eq.0) then - dx1=yionva - dvax1=dvax0 - else - dx1=(jdeg+1)*dx1*dx0 - dvax1=(jdeg+1)*dvax1*dx0 - endif - dx=dx*dx0 -! write(*,23)'25B iliqvb: ',jdeg,dx,dx1,dx2,dvax0,dvax1,dvax2 -23 format(a,i2,6(1pe12.4)) - elseif(iliqneut) then -! interaction between Va and neutral a bit more complicated ... NOT TESTED - dx2=(jdeg+1)*dx1 - dvax2=(jdeg+1)*dvax1 - if(jdeg.eq.0) then - dx1=yionva - dvax1=dvax0 - else - dx1=(jdeg+1)*dx1*dx0 - dvax1=(jdeg+1)*dvax1*dx0 - endif - dx=dx*dx0 - else -! normal CEF model - dx2=(jdeg+1)*dx1 - dx1=(jdeg+1)*dx - dx=dx*dx0 - endif - enddo RK - elseif(gz%intlevel.eq.2) then !intlev -!---------------------------------------------------------------------- -! important to set ivax=0 here as tested below if not zero - ivax=0 - if(ionicliq) then -! write(*,*)'Comp.dep ternary ionic liquid parameter',iliqva - if(iliqva) then - if(gz%intlat(1).eq.1 .and. gz%intlat(2).eq.1) then -! we have 3 cations interacting in first sublattice and Va in second -! require treatment of extra vacancy fraction - write(*,*)'3 interacting cations not implemented' - gx%bmperr=7777; goto 1000 - elseif(gz%intlat(1).eq.1 .and. gz%intlat(2).eq.2) then -! we have 2 cations interacting in 1st sublattice and Va and neutral in 2nd -! require treatment of extra vacancy fraction -! write(*,*)'Reciprocal with neutrals not implemented' -! gx%bmperr=7777; goto 1000 -! yionva set above! - ivax=gz%endcon(2) - endif - elseif(gz%intcon(2).eq.phlista(lokph)%i2slx(1)) then -! vacancy is the intarction constituent - ivax=gz%intcon(2) - yionva=gz%yfrint(2) - endif -! other ternary parameters in ionic liquid OK, no extra vacancy fraction - endif -!................................................................ -! ternary composition dependent interaction - ternary: if(gz%intlat(1).eq.gz%intlat(2)) then -! Ternary composition dependent interaction in same sublattice, Hillert form. -! The idea is that the sum of vv is always unity even in higher order systems -! whereas the sum of the constituent frations are not -! If wildcard then any of the gz%iq would be negative, not allowed - gz%iq(1)=gz%endcon(gz%intlat(1)) - gz%iq(2)=gz%intcon(1) - gz%iq(3)=gz%intcon(2) - if(gz%iq(1).lt.0 .or. gz%iq(2).lt.0 .or. gz%iq(3).lt.0) then - gx%bmperr=4031; goto 1000 - endif - vv(0)=gz%yfrem(gz%intlat(1)) - vv(1)=gz%yfrint(1) - vv(2)=gz%yfrint(2) - ct=(one-vv(0)-vv(1)-vv(2))*onethird - vv=vv+ct - fvv(0)=two*onethird - fvv(1)=-onethird - fvv(2)=-onethird - terloop: do jint=0,2 -! calculate parameter - lfun=lokpty%degreelink(jint) - call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres) - if(lokpty%proptype.eq.1) then - valtp=valtp/rtg - endif -! function value - vals=vals+vv(jint)*valtp - noder6: if(moded.gt.0) then -! first derivatives - do jl=1,3 - dvals(jl,gz%iq(1))=dvals(jl,gz%iq(1))+fvv(0)*valtp(jl) - dvals(jl,gz%iq(2))=dvals(jl,gz%iq(2))+fvv(1)*valtp(jl) - dvals(jl,gz%iq(3))=dvals(jl,gz%iq(3))+fvv(2)*valtp(jl) - enddo -! there is no contribution to the second derivatives from this interaction - endif noder6 - fvs=fvv(2) - fvv(2)=fvv(1) - fvv(1)=fvv(0) - fvv(0)=fvs - enddo terloop - else -!......................................................... -! composition dependent reciprocal interactions here only degree 1 and 2 - if(lokpty%degree.gt.2) then - write(*,*)'Composition dependent reciprocal degree max 2' - gx%bmperr=4078; goto 1000 - else -! write(*,32)lokph,lokpty%degree,gz%intlat(1),gz%intlat(2),& -! gz%iq(1),gz%iq(2),gz%iq(3),gz%iq(4) -32 format('Comp.dep. rec. param: ',i3,2x,i1,2x,2i2,4i5) - endif -! Note the composition dependence is defined that -! L = y'_Ay'_By"_y"_D (0L + (y"_C-y"_D)*1L + (y'_A-y'_D)*2L) -! it is a bit strange that 2nd sublattice is 1L ... but that is the definition - gz%iq(1)=gz%endcon(1) - gz%iq(2)=gz%intcon(1) - gz%iq(3)=gz%endcon(2) - gz%iq(4)=gz%intcon(2) -! degree 0 not composition dependent, vals multiplied with pyq after return - lfun=lokpty%degreelink(0) - if(lfun.gt.0) then - call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres) - if(gx%bmperr.ne.0) goto 1000 - if(lokpty%proptype.eq.1) then - valtp=valtp/rtg - endif - vals=vals+valtp - endif -! lokpty%degree must be 1 or 2 otherwise we would not be here - lfun=lokpty%degreelink(1) - recip1: if(lfun.gt.0) then -! degree 2 can be empty, otherwise multiplied with gz%iq(3)-gz%iq(4) -! no problem with ionic liquid except there may be values in dvals - call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres) - if(gx%bmperr.ne.0) goto 1000 - if(lokpty%proptype.eq.1) then - valtp=valtp/rtg - endif - vals=vals+(gz%yfrem(gz%intlat(2))-gz%yfrint(2))*valtp -! one dvals(*,ivax) could have been assigned a value above (for ionic liquid) - do jl=1,3 - dvals(jl,gz%iq(3))=dvals(jl,gz%iq(3))+valtp(jl) - dvals(jl,gz%iq(4))=dvals(jl,gz%iq(4))-valtp(jl) - enddo - endif recip1 -! degree 2 can be empty, otherwise multiplied with y(gz%iq(1))-y(gz%iq(2)) - recip2: if(lokpty%degree.gt.1) then - lfun=lokpty%degreelink(2) - if(lfun.gt.0) then - call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres) - if(gx%bmperr.ne.0) goto 1000 - if(lokpty%proptype.eq.1) then - valtp=valtp/rtg - endif - if(ivax.gt.0) then - write(*,67)ivax,gz%iq(1),gz%iq(2),gz%iq(3),gz%iq(4),yionva -67 format('ion liq recip: ',i3,2x,4i3,1pe12.4) -! interaction in ionic liquid with vacancy as one constituent in 2nd subl. - vals=vals+yionva*(gz%yfrem(gz%intlat(1))-gz%yfrint(1))*valtp - do jl=1,3 - dvals(jl,gz%iq(1))=+yionva*valtp(jl) - dvals(jl,gz%iq(2))=-yionva*valtp(jl) - enddo -! we have to take into account extra derivatives wrt vacancies if vacancy -! is a constituent in second sublattice - do jl=1,3 - dvals(jl,ivax)=& - (gz%yfrem(gz%intlat(1))-gz%yfrint(1))*valtp(jl) - enddo - else -! not ionic liquid .... puuuh - vals=vals+(gz%yfrem(gz%intlat(1))-gz%yfrint(1))*valtp - do jl=1,3 - dvals(jl,gz%iq(1))=+valtp(jl) - dvals(jl,gz%iq(2))=-valtp(jl) - enddo - endif - endif - endif recip2 - endif ternary -!---------------------------------------------------------------------- - elseif(gz%intlevel.ge.3) then !intlev -! higher interaction levels have no composition dependence - write(*,999) -999 format('Composition dependence for parameters with >2 interacting ',& - 'constituents'/'not implemented!') - gx%bmperr=4078; goto 1000 - endif intlev -!---------------------------------------------------------------------- -! finished finally .... -1000 continue - return - end subroutine cgint - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine config_entropy(moded,nsl,nkl,phvar,tval) -! calculates configurational entropy/R for phase lokph - implicit none - integer moded,nsl - integer, dimension(nsl) :: nkl - TYPE(gtp_phase_varres), pointer :: phvar -!\end{verbatim} - integer ll,kk,kall,nk,jl - double precision tval,ss,yfra,ylog - ll=0 - kall=0 - sublatticeloop: do while (ll.lt.nsl) - ll=ll+1 - nk=nkl(ll) - kk=0 - ss=zero - fractionloop: do while (kk.lt.nk) - kk=kk+1 - kall=kall+1 - if(nk.eq.1) cycle sublatticeloop - yfra=phvar%yfr(kall) - if(yfra.lt.bmpymin) yfra=bmpymin - if(yfra.gt.one) yfra=one - ylog=log(yfra) -! gval(1:6,1) are G and derivator wrt T and P -! dgval(1,1:N,1) are derivatives of G wrt fraction 1:N -! dgval(2,1:N,1) are derivatives of G wrt fraction 1:N and T -! dgval(3,1:N,1) are derivatives of G wrt fraction 1:N and P -! d2dval(ixsym(N*(N+1)/2),1) are derivatives of G wrt fractions N and M -! this is a symmetric matrix and index givem by ixsym(M,N) - ss=ss+yfra*ylog - if(moded.gt.0) then - phvar%dgval(1,kall,1)=phvar%sites(ll)*(one+ylog) - phvar%d2gval(ixsym(kall,kall),1)=phvar%sites(ll)/yfra - endif - enddo fractionloop - phvar%gval(1,1)=phvar%gval(1,1)+phvar%sites(ll)*ss - enddo sublatticeloop -! set temperature derivative of G and dG/dy - phvar%gval(2,1)=phvar%gval(1,1)/tval - if(moded.gt.0) then - do jl=1,kall - phvar%dgval(2,jl,1)=phvar%dgval(1,jl,1)/tval - enddo - endif -1000 continue - return - end subroutine config_entropy - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine config_entropy_i2sl(moded,nsl,nkl,phvar,i2slx,tval) -! calculates configurational entropy/R for ionic liquid model -! Always 2 sublattices, the sites depend on composition -! P = \sum_j (-v_j) y_j + Q y_Va -! Q = \sum_i v_i y_i -! where v is the charge on the ions. P and Q calculated by set_constitution - implicit none - integer moded,nsl,i2slx(2) - integer, dimension(nsl) :: nkl - TYPE(gtp_phase_varres), pointer :: phvar -!\end{verbatim} - integer ll,kk,kall,nk,j1,j2 - double precision tval,ss,yfra,ylog,yva,spart(2) - ll=0 - kall=0 - spart=zero - yva=zero - sublatticeloop: do while (ll.lt.nsl) - ll=ll+1 - nk=nkl(ll) - kk=0 - ss=zero - fractionloop: do while (kk.lt.nk) - kk=kk+1 - kall=kall+1 -! no cycle as we may need values of spart and yva ... -! if(nk.eq.1) cycle sublatticeloop - yfra=phvar%yfr(kall) - if(yfra.lt.bmpymin) yfra=bmpymin - if(yfra.gt.one) yfra=one -! save current value of vacancy fraction - if(kall.eq.i2slx(1)) yva=yfra -! write(*,2)'yva: ',kall,i2slx(1),yva,yfra -!2 format(a,2i3,6(1pe12.4)) - ylog=log(yfra) -! gval(1:6,1) are G and derivator wrt T and P -! dgval(1,1:N,1) are derivatives of G wrt fraction 1:N -! dgval(2,1:N,1) are derivatives of G wrt fraction 1:N and T -! dgval(3,1:N,1) are derivatives of G wrt fraction 1:N and P -! d2dval(ixsym(N*(N+1)/2),1) are derivatives of G wrt fractions N and M -! this is a symmetric matrix and index givem by ixsym(M,N) - ss=ss+yfra*ylog - if(moded.gt.0) then - phvar%dgval(1,kall,1)=phvar%sites(ll)*(one+ylog) - phvar%d2gval(ixsym(kall,kall),1)=phvar%sites(ll)/yfra - endif - enddo fractionloop - phvar%gval(1,1)=phvar%gval(1,1)+phvar%sites(ll)*ss - if(ll.eq.1) then - spart(1)=ss - else - spart(2)=ss - endif - enddo sublatticeloop - if(moded.eq.0) goto 900 -! convergence problem with ionic liquid, skip contribution to 2nd derivatuves -! localmoded=moded -! if(moded.eq.2) localmoded=1 -! write(*,*)'ionic config_entropy: ',i2slx,kall -! additional derivatives as sublattice sites depend on composition -! -------------------------- derivatives of config entropy -! S = P*S1 + Q*S2 -! S1 = \sum_i y_i*ln(y_i) -! S2 = \sum_j y_j*ln(y_j)+y_Va*ln(y_Va)+\sum_k y_k*ln(Y_k)) -! P = \sum_j (-v_j)*y_j + Q*y_Va -! Q = \sum_i v_i*y_i -! term within [...] already calculated as part of normal config.entropy -! dS/dy_i = +v_i*S2 + v_i*y_Va*S1 + [P*(1+ln(y_i)] ..cation OK -! dS/dy_j = -v_j*S1 + [Q*(1+ln(y_j))] ..anion OK -! dS/dy_Va = Q*S1 + [Q*(1+ln(y_Va))] ..Va OK -! dS/dy_k = [Q*(1+ln(y_k)] ..neutral OK -! d2S/dy_i1dy_i2 = v_i1*y_Va*(1+ln(y_i2) + v_i2*y_Va*(1+ln(y_i1) + -! [P*(1/y_i1**2)] ..last term zero unless i1=i2 OK -! d2S/dy_idy_j = v_i*(1+ln(y_j)) + (-v_j)*(1+ln(y_i)) OK -! d2S/dy_idy_Va = v_i*(1+ln(y_Va)) + v_i*S1 + Q*(1+ln(y_i)) OK -! d2S/dy_idy_k = v_i*(1+ln(y_k)) OK -! d2S/dy_j1d_j2 = [only Q/y**2 if j1=j2] OK -! d2S/dy_jdy_Va = zero OK -! d2S/dy_jdy_k = zero OK -! d2S/dy_Va2 = [only Q/y_Va**2] OK -! d2S/dy_Vady_k = zero OK -! d2S/dy_k1dy_k2 = [only Q/y_k1**2 if k1=k2] OK -! ---------------------- -! the coding is not optimal for speed, all the 1/y**2 term calculated above -! i2slx(1) is index of vacancy, i2slx(2) is index of first neutral -! if either (or both) are missing their index is higher than last constituent -! write(*,102)'va+neutral: ',i2slx -!102 format(a,10i3) -! dpqdy is calculated in pmod25A: set_constitution ?? -! write(*,108)'25B dpqdy: ',(phvar%dpqdy(j1),j1=1,nkl(1)+nkl(2)) -108 format(a,10F7.3) - cation: do j1=1,nkl(1) -! this was an attempt to improve convergence ... it did but not enough -! if(localmoded.eq.1) goto 109 - cation2: do j2=j1,nkl(1) -! d2S/dy_i1dy_i2 = v_i1*y_Va*(1+ln(y_i2) + v_i2*y_Va*(1+ln(y_i1) + -! [P*(1/y_i1**2)] ..last term already calculated OK -! write(*,103)'ij: ',j1,j2,ixsym(j1,j2),yva,& -! phvar%d2gval(ixsym(j1,j2),1),& -! phvar%dpqdy(j1),phvar%dpqdy(j2),& -! phvar%dgval(1,j1,1),phvar%dgval(1,j2,1) -!103 format(a,3i3,6(1pe11.3)) - phvar%d2gval(ixsym(j1,j2),1)=phvar%d2gval(ixsym(j1,j2),1)+& - (phvar%dpqdy(j1)*phvar%dgval(1,j2,1)+& - phvar%dpqdy(j2)*phvar%dgval(1,j1,1))*yva/phvar%sites(1) - enddo cation2 - anion2: do kk=1,nkl(2) - j2=nkl(1)+kk - if(j2.lt.min(i2slx(1),i2slx(2))) then -! d2S/dy_idy_j = v_i*(1+ln(y_j)) + (-v_j)*(1+ln(y_i)) ...cation+anion OK - phvar%d2gval(ixsym(j1,j2),1)=& - phvar%dpqdy(j1)*phvar%dgval(1,j2,1)/phvar%sites(2)+& - phvar%dpqdy(j2)*phvar%dgval(1,j1,1)/phvar%sites(1) - elseif(j2.eq.i2slx(1)) then -! d2S/dy_idy_Va = v_i*(1+ln(y_Va)) + v_i*S1 + Q*(1+ln(y_i)) ...cation+Va OK - phvar%d2gval(ixsym(j1,j2),1)=& - phvar%dpqdy(j1)*phvar%dgval(1,j2,1)/phvar%sites(2)+& - phvar%dpqdy(j1)*spart(1)+& - phvar%sites(2)*phvar%dgval(1,j1,1)/phvar%sites(1) - else -! d2S/dy_idy_k = v_i*(1+ln(y_k)) ...cation+neutral OK -! write(*,107)'i,va: ',j1,j2,phvar%dpqdy(j1),phvar%dgval(1,j2,1),& -! phvar%sites(2) -!107 format(a,2i2,6(1pe12.4)) - phvar%d2gval(ixsym(j1,j2),1)=& - phvar%dpqdy(j1)*phvar%dgval(1,j2,1)/phvar%sites(2) - endif - enddo anion2 -109 continue -! this done at the end as original dgval(1,j1,1)=P*(1+ln(y_j1))/P used above -! dS/dy_i = +v_i*S2 + v_i*y_Va*S1 + [P*(1+ln(y_i)] ..cation OK -! write(*,19)'c: ',j1,phvar%dgval(1,j1,1),& -! phvar%dpqdy(j1),spart(2),phvar%dpqdy(j1),yva,spart(1) -!19 format(a,i3,6(1pe12.4)) - phvar%dgval(1,j1,1)=phvar%dgval(1,j1,1)+& - phvar%dpqdy(j1)*spart(2)+phvar%dpqdy(j1)*yva*spart(1) - enddo cation -! this done separately as original dgval(1,j2,1)=Q*(1+ln(y_j2))/Q used above -! kall here should be total number of constituents - anion1: do j2=nkl(1)+1,min(i2slx(1),kall) - if(j2.lt.min(i2slx(1),i2slx(2))) then -! dS/dy_j = -v_j*S1 + [Q*(1+ln(y_j))] ..anion OK -! write(*,*)'anion1 A: ',j2 - phvar%dgval(1,j2,1)=phvar%dgval(1,j2,1)+phvar%dpqdy(j2)*spart(1) - elseif(j2.eq.i2slx(1)) then -! dS/dy_Va = Q*S1 + [Q*(1+ln(y_Va))] ..Va OK -! write(*,*)'anion1 B: ',j2 - phvar%dgval(1,j2,1)=phvar%dgval(1,j2,1)+phvar%sites(2)*spart(1) -! else -! dS/dy_k = nothing + [Q*(1+ln(y_k)] ..neutral OK - endif -! write(*,*)'anion1 C: ',j2 - enddo anion1 -! set temperature derivative of dG/dy - do j1=1,kall - phvar%dgval(2,j1,1)=phvar%dgval(1,j1,1)/tval - enddo -900 continue -! phvar%gval(1,1)=phvar%gval(1,1)+phvar%sites(ll)*ss -! write(*,905)'parts: ',phvar%gval(1,1),phvar%sites,spart -!905 format(a,6(1pe12.4)) -! set temperature derivative of G - phvar%gval(2,1)=phvar%gval(1,1)/tval -1000 continue - return - end subroutine config_entropy_i2sl - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine push_pyval(pystack,intrec,pmq,pyq,dpyq,d2pyq,moded,iz) -! push data when entering an interaction record - implicit none - integer pmq,moded,iz - double precision pyq,dpyq(iz),d2pyq(iz*(iz+1)/2) - type(gtp_pystack), pointer :: pystack - type(gtp_interaction), pointer :: intrec -!\end{verbatim} %+ - type(gtp_pystack), pointer :: new -! - if(associated(pystack)) then - allocate(new) - new%previous=>pystack - pystack=>new - else - allocate(pystack) - nullify(pystack%previous) - endif -! save data - pystack%intrecsave=>intrec - pystack%pmqsave=pmq - pystack%pysave=pyq - if(moded.ge.1) then -! if moded 0 there are no derivatives - allocate(pystack%dpysave(iz)) - pystack%dpysave=dpyq - if(moded.eq.2) then -! if moded 1 there are no second derivatives - allocate(pystack%d2pysave(iz*(iz+1)/2)) - pystack%d2pysave=d2pyq - endif - endif -1000 continue - return - end subroutine push_pyval - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine pop_pyval(pystack,intrec,pmq,pyq,dpyq,d2pyq,moded,iz) -! pop data when entering an interaction record - implicit none - integer iz,pmq,moded - double precision pyq,dpyq(iz),d2pyq(iz*(iz+1)/2) - type(gtp_pystack), pointer :: pystack - type(gtp_interaction), pointer :: intrec -!\end{verbatim} - type(gtp_pystack), pointer :: old - if(.not.associated(pystack)) then -! write(*,*)'Tying to pop from an empty PY stack' - gx%bmperr=4075; goto 1000 - endif -! restore data - intrec=>pystack%intrecsave - pmq=pystack%pmqsave - pyq=pystack%pysave - if(moded.ge.1) then -! if moded >0 there are derivatives - dpyq=pystack%dpysave - if(moded.eq.2) then -! if moded 2 there are second derivatives - d2pyq=pystack%d2pysave - endif - endif -! release memory - old=>pystack - pystack=>pystack%previous - deallocate(old) -1000 continue - return - end subroutine pop_pyval - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine calc_disfrac(lokph,lokcs,ceq) -! calculate and set disordered set of fractions from sitefractions -! The first derivatives are dxidyj. There are no second derivatives -! TYPE(gtp_fraction_set), pointer :: disrec - implicit none - integer lokph,lokcs - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - TYPE(gtp_fraction_set), pointer :: disrec - TYPE(gtp_phase_varres), pointer :: phord - TYPE(gtp_phase_varres), pointer :: phdis - logical ordered -! minimum difference in site fraction to be set as ordered - double precision, parameter :: yminord=1.0D-10 - integer lokdis,is -! -! write(*,*)'entering calc_disfrac' -! disrec=phord%disfra -! lokdis=disrec%varreslink -! phdis=>disrec%phdapointer -! this is the record with the ordered constitution - phord=>ceq%phase_varres(lokcs) -! this is a record within the ordered constitution record for disordered fracs - disrec=>phord%disfra -! to find the varres record with disordered fractions use varreslink -! this is the index to the phase_varres record with the ordered fractions ??? - lokdis=disrec%varreslink - phdis=>ceq%phase_varres(lokdis) -! write(*,*)'calc_disfrac 1A' -! check that some values are accessable -! write(*,*)'calc_disfra phase index: ',phord%phlink -! write(*,*)'calc_disfra disordered sublattices: ',disrec%ndd -! write(*,*)'calc_disfra ordered and disordered records: ',lokcs,lokdis -! write(*,*)'calc_disfra phase index via disordred record: ',phdis%phlink -! write(*,*)'calc_disfrac 1B' - phdis%yfr=zero -! write(*,*)'disfrac 1: ',disrec%tnoofyfr - do is=1,disrec%tnoofyfr - phdis%yfr(disrec%y2x(is))=& - phdis%yfr(disrec%y2x(is))+disrec%dxidyj(is)*phord%yfr(is) -! write(*,77)'disfrac 2: ',is,disrec%y2x(is),phdis%yfr(disrec%y2x(is)),& -! disrec%dxidyj(is),phord%yfr(is) -77 format(a,2i3,3(1pe12.4)) - enddo -! write(*,*)'calc_disfrac 2' -! check if phase is really ordered, meaning that the disordered fractions -! are equal to the ordered ones - ordered=.false. - do is=1,disrec%tnoofyfr - if(abs(phdis%yfr(disrec%y2x(is))-& - phord%yfr(is)).gt.yminord) ordered=.true. - enddo -! write(*,*)'calc_disfrac 3' - if(.not.ordered) then -! if this bit set one will not calculate the ordered part of the phase - phord%status2=ibclr(phord%status2,csorder) -! write(*,*)'calc_disfrac: disordered, clear ordered bit',lokph - else -! bit must be cleared as it might have been set at previous call - phord%status2=ibset(phord%status2,csorder) -! write(*,*)'calc_disfrac: ordered, set ordered bit',lokph - endif -! write(*,*)'calc_disfrac 4' -! copy these to the phase_varres record that belongs to this fraction set -! a derivative dGD/dyj = sum_i dGD/dxi * dxidyj -! where dGD/dxi is dgval(1,y2x(j),1) and dxidyj is disrec%dxidyj(j) -! because each y constituent contributes to only one disordered x fraction -1000 continue - return -! G(tot) = GD(xdis)+(GO(yord)-GO(yord=xdis)) -! G(tot).yj = dGD(xdis).dxi*dxdyj + GO.yj - GO.yj ... - end subroutine calc_disfrac - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine disordery(phvar,ceq) -! sets the ordered site fractions in FCC and other order/disordered phases -! equal to their disordered value in order to calculate and subtract this part -! phvar is index to phase_varres for ordered fractions - implicit none - TYPE(gtp_phase_varres), pointer :: phvar - TYPE(gtp_equilibrium_data) :: ceq -!\end{verbatim} - TYPE(gtp_fraction_set), pointer :: disrec - TYPE(gtp_phase_varres) :: phdis - integer lokdcs,kk,ll,is,nis,nsl -! find disordered fractions - lokdcs=phvar%disfra%varreslink - disrec=>phvar%disfra -! write(*,*)'disordery: ',disrec%latd,disrec%nooffr(1),lokdcs - phdis=ceq%phase_varres(lokdcs) -! write(*,*)'disordery: ',ceq%xconv -! write(*,*)'disordery: ',phdis%yfr(1) -! phdis=>ceq%disrec%phdapointer -! copy fractions, loop through all ordered sublattices in phvar -! and store fraction from lokdis - kk=0 -! here copy: -! y(ord,1,1)=y(dis,1); y(ord,1,2)=y(dis,2); y(ord,1,3)=y(dis,3); -! y(ord,2,1)=y(dis,1); y(ord,2,2)=y(dis,2); y(ord,2,3)=y(dis,3); - do ll=1,disrec%latd - do is=1,disrec%nooffr(1) - kk=kk+1 - phvar%yfr(kk)=phdis%yfr(is) - enddo - enddo - if(disrec%ndd.eq.2) then -! one can have 2 sets of ordered subl. like (Al,Fe)(Al,Fe)...(C,Va)(C,Va)... - nis=disrec%nooffr(1) - nsl=size(phvar%sites) -! write(*,*)'dy: ',nis,kk,disrec%latd,nsl,disrec%nooffr(2) - do ll=disrec%latd+1,nsl - do is=1,disrec%nooffr(2) - kk=kk+1 - phvar%yfr(kk)=phdis%yfr(nis+is) - enddo - enddo - endif -1000 continue - return - end subroutine disordery - -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine set_driving_force(iph,ics,dgm,ceq) -! set the driving force of a phase explicitly - implicit none - type(gtp_equilibrium_data), pointer :: ceq - integer iph,ics - double precision dgm -!\end{verbatim} - integer lokph,lokcs - call get_phase_compset(iph,ics,lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 - ceq%phase_varres(lokcs)%dgm=dgm -1000 continue - return - end subroutine set_driving_force - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine extract_massbalcond(tpval,xknown,antot,ceq) -! extract T, P, mol fractions of all components and total number of moles -! for use when minimizing G for a closed system. Probably redundant - implicit none - double precision, dimension(*) :: tpval,xknown - double precision antot - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer, dimension(4) :: indices - double precision, dimension(maxel) :: ani,abi,xset,wset - double precision mass,h298,s298,xxx,xsum,wsum - double precision sumwdivm,anisum,abisum,restmass,divisor,dividend,abtot - TYPE(gtp_condition), pointer :: current,last - character encoded*16,actual_arg(1)*16,elsym*2,elname*16,refstat*16 - integer nox,now,nc,jl,iref,iunit,ip,idf,ie,more,numberest,istv - logical allmassbal -! - ani=zero; abi=zero; xset=zero; wset=zero - antot=zero; abtot=zero - xsum=zero; wsum=zero - anisum=zero; abisum=zero - nox=0; now=0 -! -! write(*,*)"in extract massbalace 1" - last=>ceq%lastcondition - if(.not.associated(last)) then - gx%bmperr=4143; goto 1000 - endif -! write(*,*)"in extract massbalace 2" - current=>last - nc=0 - allmassbal=.TRUE. -100 continue - current=>current%next -! ignore inactive conditions - if(current%active.ne.0) goto 300 -! ignore conditions with several terms - if(current%noofterms.gt.1) goto 300 -! for debugging - istv=current%statev - do jl=1,4 - indices(jl)=current%indices(jl,1) - enddo - iref=current%iref - iunit=current%iunit - ip=1 - encoded=' ' - actual_arg=' ' - if(current%symlink1.gt.0) then -! the value is a symbol, the node to the expression is in -! svflista(current%symlink1)%linkpnode -! NOTE THIS IS NOT THE SAME AS meq_evaluate_svfun but OK as no derivative -! xxx=meq_evaluate_svfun(current%symlink1,actual_arg,1,ceq) - xxx=evaluate_svfun_old(current%symlink1,actual_arg,1,ceq) - else - xxx=current%prescribed - endif -! write(*,17)'massbal: ',encoded,istv,indices,iunit,iref,xxx -17 format(a,2x,a,2x,i3,2x,4i3,2x,2i3,1PE15.7) -! extract values of T, P, N, B, X and W - if(current%statev.eq.1) then -! this is the temperature - tpval(1)=xxx - nc=nc+1 - elseif(current%statev.eq.2) then -! this is the pressure - tpval(2)=xxx - nc=nc+1 - elseif(current%statev.eq.110) then -! this is N=value or N(element)=value - if(indices(2).gt.0) then -! this should mean the number of moles of a component in a phase, illegal here -! write(*,*)'N with 2 indices illegal in this case' - gx%bmperr=4179; goto 1000 - elseif(indices(1).gt.0) then -! N(i)=xxx - ani(indices(1))=xxx - anisum=anisum+xxx - else -! N=xxx - antot=xxx - endif - nc=nc+1 - elseif(current%statev.eq.111) then -! this is X(index1)=value, CHECK UNIT if %!!! - if(iunit.eq.100) xxx=1.0D-2*xxx - xset(current%indices(1,1))=xxx - xsum=xsum+xxx - nc=nc+1 - nox=nox+1 - elseif(current%statev.eq.120) then -! this is B=value or B(i)=value - if(indices(2).gt.0) then -! this should mean the mass of a component in a phase, illegal here - write(*,*)'B with 2 indices illegal' - gx%bmperr=4179; goto 1000 - elseif(indices(1).gt.0) then -! B(i)=xxx - abi(indices(1))=xxx - abisum=abisum+xxx - else -! B=xxx - abtot=xxx - endif - nc=nc+1 - elseif(current%statev.eq.122) then -! this is W(index1)=value, CHECK UNIT if %!!! - if(iunit.eq.100) xxx=1.0D-2*xxx - wset(current%indices(1,1))=xxx - wsum=wsum+xxx - nc=nc+1 - now=now+1 - else -! this is not a massbalance condition but continue just to check how many cond - allmassbal=.FALSE. - nc=nc+1 - endif -! take next condition if we have not done all -300 continue - if(ocv()) write(*,310)'25B massbal: ',current%prescribed,last%prescribed -310 format(a,6(1pe12.4)) - if(.not.associated(current,last)) goto 100 -!-------------------------------------- -! check if correct number of conditions found -500 continue - idf=noofel+2-nc - if(idf.ne.0) then -! if idf is not zero there are not enough conditions - gx%bmperr=4144; goto 1000 - elseif(.not.allmassbal) then -! some conditions are not massbalance - gx%bmperr=4151; goto 1000 - endif -! we have extracted all conditions N, B, X, W -! check that only one value per component - do ie=1,noel() - if(xset(ie).gt.zero) then - if(wset(ie).gt.zero) goto 1100 - if(ani(ie).gt.zero) goto 1100 - if(abi(ie).gt.zero) goto 1100 - elseif(wset(ie).gt.zero) then - if(ani(ie).gt.zero) goto 1100 - if(abi(ie).gt.zero) goto 1100 - elseif(ani(ie).gt.zero) then - if(abi(ie).gt.zero) goto 1100 - elseif(abi(ie).le.zero) then -! this can be "the rest" - if(antot.eq.zero .and. abtot.eq.zero) goto 1105 - endif - enddo -! write(*,510)'N: ',(ani(i),i=1,noel()) -! write(*,510)'B: ',(abi(i),i=1,noel()) -! write(*,510)'x: ',(xset(i),i=1,noel()) -! write(*,510)'w: ',(wset(i),i=1,noel()) -510 format(a,7F9.6) - bigif: if(antot.gt.zero) then -! we have a value for total number of moles, N, there must not be one for B - if(abtot.ne.zero) goto 1110 - more=0 - numberest=0 - sumwdivm=zero -! convert as much as possible to N(i). Sum also some data needed if there -! are conditions on mass fractions - do ie=1,noel() - call get_element_data(ie,elsym,elname,refstat,mass,h298,s298) - if(xset(ie).gt.zero) then - ani(ie)=antot*xset(ie) - anisum=anisum+ani(ie) - abisum=abisum+mass*ani(ie) - elseif(abi(ie).gt.zero) then - ani(ie)=abi(ie)/mass - anisum=anisum+ani(ie) - abisum=abisum+mass*ani(ie) - elseif(wset(ie).gt.zero) then - sumwdivm=sumwdivm+wset(ie)/mass - more=1 - elseif(ani(ie).eq.zero) then - if(numberest.gt.0) then - write(*,*)'Missing condition for two elements.' - gx%bmperr=0; goto 1000 - endif - restmass=mass - numberest=ie - endif - enddo - if(numberest.eq.0) then - write(*,*)'Error - condition on all elements and N??' - gx%bmperr=0; goto 1000 - endif - if(more.gt.0) then -! there are some mass fractions, we have to calculate B -! but first we must determine the number of moles of "the rest" element - divisor=antot-anisum-abisum/(one-wsum)*sumwdivm - dividend=one+restmass/(one-wsum)*sumwdivm - ani(numberest)=divisor/dividend - abi(numberest)=restmass*ani(numberest) - abisum=abisum+abi(numberest) -! now calculate B - abtot=abisum/(one-wsum) -! write(*,520)'nrest: ',numberest,divisor,dividend,ani(numberest),& -! abi(numberest),abtot -520 format(a,i3,6(1pe12.4)) -! now calculate moles of elements with massfractions - do ie=1,noel() - if(wset(ie).gt.zero) then - abi(ie)=abtot*wset(ie) - call get_element_data(ie,elsym,elname,refstat,mass,h298,s298) - ani(ie)=abi(ie)/mass - endif - enddo - else -! all conditions are mole fractions, just set "the rest" - ani(numberest)=antot-anisum - endif - do ie=1,noel() - xset(ie)=ani(ie)/antot - enddo - elseif(abtot.gt.zero) then -! we have a value for total mass, B, not common and too complicated -! write(*,*)'Cannot handle condition on total mass' - gx%bmperr=4180 - elseif(xsum.eq.zero .and. wsum.eq.zero) then -! just N(i)= and B(i)=, no N= nor B= and no X nor W, No rest element -! write(*,520)'N(i): ',0,anisum,(ani(j),j=1,noel()) - do ie=1,noel() - if(abi(ie).gt.zero) then - call get_element_data(ie,elsym,elname,refstat,mass,h298,s298) - ani(ie)=abi(ie)/mass - anisum=anisum+ani(ie) - endif - enddo - antot=anisum - do ie=1,noel() - xset(ie)=ani(ie)/antot - if(xset(ie).le.zero) then - write(*,*)'mass balance error: ',ie - gx%bmperr=4181; goto 1000 - endif - enddo - else -! any other combination of conditions .... - write(*,*)'Cannot handle these massbalance conditions' - gx%bmperr=4182 - endif bigif -! copy fractions to arguments -900 continue - do ie=1,noel() - xknown(ie)=xset(ie) - enddo -1000 continue - return -! errors -1100 continue - write(*,*)'Two mass balance conditions for same element',ie - gx%bmperr=4183; goto 1000 -1105 continue - write(*,*)'One component without condition' - gx%bmperr=4181; goto 1000 -1110 continue - write(*,*)'Both N and B cannot be set' - gx%bmperr=4184; goto 1000 -! - end subroutine extract_massbalcond - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine save_constitutions(ceq,copyofconst) -! copy the current phase amounts and constituitions to be restored -! if calculations fails during step/map -! DANGEROUS IF NEW COMPOSITION SETS CREATED - implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq - double precision, allocatable, dimension(:) :: copyofconst -!\end{verbatim} - integer varresx,nz,ij,syfr -! calculate dimension of copyofconst - nz=0 -! skippa varres with index 1, that is the reference phase - do varresx=2,csfree-1 - syfr=size(ceq%phase_varres(varresx)%yfr) - nz=nz+1+syfr - enddo - allocate(copyofconst(nz)) - nz=1 - do varresx=2,csfree-1 -! save 1+sfr values for each composition set - copyofconst(nz)=ceq%phase_varres(varresx)%amfu - syfr=size(ceq%phase_varres(varresx)%yfr) - do ij=1,syfr - copyofconst(nz+ij)=ceq%phase_varres(varresx)%yfr(ij) - enddo -! write(*,17)varresx,nz,syfr,(copyofconst(ij),ij=nz,nz+syfr) -17 format('25Bs:',i2,2i3,6(1pe12.4)) - nz=nz+1+syfr - enddo -1000 continue - return - end subroutine save_constitutions - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine restore_constitutions(ceq,copyofconst) -! restore the phase amounts and constituitions from copyofconst -! if calculations fails during step/map -! DANGEROUS IF NEW COMPOSITION SETS CREATED - implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq - double precision copyofconst(*) -!\end{verbatim} - integer nz,varresx,ij,syfr - nz=1 -! skippa varres with index 1, that is the reference phase - do varresx=2,csfree-1 - ceq%phase_varres(varresx)%amfu=copyofconst(nz) - syfr=size(ceq%phase_varres(varresx)%yfr) - do ij=1,syfr - ceq%phase_varres(varresx)%yfr(ij)=copyofconst(nz+ij) - enddo -! write(*,17)varresx,nz,syfr,ceq%phase_varres(varresx)%amfu,& -! (ceq%phase_varres(varresx)%yfr(ij),ij=1,syfr) -17 format('25Br:',i2,2i3,6(1pe12.4)) - nz=nz+1+size(ceq%phase_varres(varresx)%yfr) - enddo -1000 continue - return - end subroutine restore_constitutions +! +! gtp3X included in gtp3.F90 +! +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ +!> 15. Calculate things +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine calcg(iph,ics,moded,lokres,ceq) +! calculates G for phase iph and composition set ics in equilibrium ceq +! checks first that phase and composition set exists +! Data taken and stored in equilibrium record ceq +! lokres is set to the phase_varres record with all fractions and results +! moded is 0, 1 or 2 depending on calculating no, first or 2nd derivarives + implicit none + TYPE(gtp_equilibrium_data), pointer :: ceq + integer iph,ics,moded,lokres +!\end{verbatim} + integer jcs,lokcs,lokph + if(gx%bmperr.ne.0) then + write(*,*)'Error code set when calling calcg: ',gx%bmperr + goto 1000 + endif + if(iph.le.0 .or. iph.gt.noofph) then +! the selected_element_reference phase with iph=0 is calculated separtely + gx%bmperr=4050; goto 1000 + endif + lokph=phases(iph) + if(lokph.le.0 .or.lokph.gt.noofph) then + gx%bmperr=4050; goto 1000 + endif +! write(*,*)'calcg 1: ',phlista(lokph)%name +! find fractions for this composition set + if(ics.le.1) then + jcs=1 + elseif(ics.le.phlista(lokph)%noofcs) then + jcs=ics + else +! no such composition set +! write(*,*)'calcg 1 error 4072' + gx%bmperr=4072; goto 1000 + endif +! if(phlista(1)%noofcs.gt.1) then +! strange error that liquid (phase 1) has 3 composition set +! write(*,*)'csbug: ',lokph,jcs,phlista(1)%noofcs +! stop 'csbug' +! endif +! Find fraction record this composition set + lokcs=phlista(lokph)%linktocs(ics) +!----- +! mcs=1 +! lokcs=phlista(lokph)%cslink +! do while(mcs.lt.jcs) +! mcs=mcs+1 +! firsteq is the first equilibrium and a global variable in this module +! lokcs=firsteq%phase_varres(lokcs)%next +! if(lokcs.le.0) then +! write(*,*)'calcg 2 error 4072' +! gx%bmperr=4072; goto 1000 +! endif +! enddo + lokres=lokcs +! write(*,*)'calcg 7: ',lokres,ceq%eqname(1:10) +! call using the local structure phase_varres +! results can be obtained through lokres +! write(*,17)'calcg: ',lokph,lokres,ceq%phase_varres(lokres)%yfr(1) +17 format(a,2i4,1pe15.6) + call calcg_internal(lokph,moded,ceq%phase_varres(lokres),ceq) +1000 continue + return + end subroutine calcg + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine calcg_internal(lokph,moded,cps,ceq) +! Central calculating routine calculating G and everyting else for a phase +! ceq is the equilibrium record, cps is the phase_varres record for lokph +! moded is type of calculation, 0=only G, 1 G and first derivatives +! 2=G and all second derivatives +! Can also handle the ionic liquid model now .... + implicit none + integer lokph,moded + TYPE(gtp_equilibrium_data), pointer :: ceq + TYPE(gtp_phase_varres), target :: cps +!\end{verbatim} +! fractype defines fraction type (1=constituent fractions) +! empermut and ipermut permutation of fractions for phases with option F and B +! permrecord, maxprec and sameint to handle permutation in the interaction tree + integer, parameter :: permstacklimit=150 + integer fractype,epermut,ipermut,typty,pmq,maxprec + integer sameint(5) + integer, dimension(permstacklimit) :: lastpmq,maxpmq +! character bug*60 +! dimension sites(maxsubl),pushpop(maxpp) + double precision, dimension(:), allocatable :: dpyq(:),d2pyq(:),d2vals(:) + double precision, dimension(:,:), allocatable :: dvals(:,:) + double precision vals(6) + integer incffr(0:maxsubl) +! in local gz: gz%intlevel level of interaction, gz%intcon and gz%intlat are +! used also in cgint when calculating interactions. + TYPE(gtp_parcalc) :: gz +! disordered fraction set + TYPE(gtp_fraction_set) :: fracset,dislink + TYPE(gtp_phase_varres), pointer :: phres,phpart,phmain + TYPE(gtp_property), pointer :: proprec + TYPE(gtp_endmember), pointer :: endmemrec + TYPE(gtp_interaction), pointer :: intrec + TYPE(gtp_pystack), pointer :: pystack + TYPE(gtp_phase_add), pointer :: addrec +! for an ordered phase like FCC with a disordered contribution one must +! calculate the ordered part twice, one with original fractions and once +! with these replaced by the disordered fractions. and subdrahera. This means +! one must have space to save fractions and results + double precision, dimension(:), allocatable :: savey + double precision, dimension(:,:), allocatable :: saveg + double precision, dimension(:,:,:), allocatable :: savedg + double precision, dimension(:,:), allocatable :: saved2g + double precision, dimension(:,:), allocatable :: tmpd2g +! added when implicit none + double precision rtg,pyq,ymult,add1,sum,yionva,fsites,xxx + integer nofc2,nprop,nsl,msl,lokdiseq,ll,id,id1,id2,lm,jl + integer lokfun,itp,nz,intlat,ic,jd,jk,ic1,jpr,ipy,i1,j1 + integer i2,j2,ider,is,kk,ioff,norfc,iw,iw1,iw2,lprop,jonva +! to handle parameters with wildcard constituent and other things + logical wildc,nevertwice,first,chkperm,ionicliq,iliqsave,iliqva +! debugging for partitioning and ordering +! integer clist(4) +! calculate RT to normalize all Gibbs energies, ceq is current equilibrium + rtg=globaldata%rgas*ceq%tpval(1) + ceq%rtn=rtg +!----------------------- + chkperm=.false. + if(btest(phlista(lokph)%status1,PHFORD) .or. & + btest(phlista(lokph)%status1,PHBORD)) then + chkperm=.true. +! This is needed only once unless parameters are changed. It numbers the +! interaction records sequentially for the permutations + call palmtree(lokph) + if(gx%bmperr.ne.0) goto 1000 + endif +! if(ocv()) write(*,*)'in gcalc_internal: ',lokph +!----------------------------------------------------------------- +50 continue +! local work arrays for products of Y and calculated parameters are allocated + gz%nofc=phlista(lokph)%tnooffr + nofc2=gz%nofc*(gz%nofc+1)/2 +! write(*,17)'calcg, ',lokph,gz%nofc,nofc2,size(cps%d2gval),cps%nprop,& +! cps%yfr(1) +!17 format(a,5i4,1pe15.6) +! for disordered fraction sets gz%nofc must be from disordered fraction record +! maybe these should not be allocated for moded=0 and 1 +! if(ocv()) write(*,*)'First allocate: ',gz%nofc,nofc2 + allocate(dpyq(gz%nofc)) + allocate(d2pyq(nofc2)) +! these return values from excess parameters that may depend on constitution + allocate(dvals(3,gz%nofc)) + allocate(d2vals(nofc2)) + nullify(pystack) +! do they have to be zeroed? YES! + dpyq=zero + d2pyq=zero +! dimension for number of parameter properties + nprop=cps%nprop +! phres will point either to ordered or disordered results +! phmain will always point to record for ordered phase_varres + phmain=>cps + phres=>cps +! zero result arrays for all properties, maybe one should do it separately for +! each property as it is found but it may be faster to do it like this anyway + phres%gval=zero + if(moded.gt.0) then + phres%dgval=zero + if(moded.gt.1) then + phres%d2gval=zero + endif + endif +! copy current values of T, P and RT from gtp_phase_varres + gz%tpv(1)=ceq%tpval(1) + gz%tpv(2)=ceq%tpval(2) +! write(*,*)'calcg_i: ',gz%tpv + gz%rgast=ceq%tpval(1)*globaldata%rgas +! gz%rgast=ceq%tpval(1)*ceq%rgas +! this is used to check the number of times an ordered phase is calculated + first=.true. +!------------------------------------------------------------------- +! calculate configurational entropy. + nsl=phlista(lokph)%noofsubl + ionicliq=.FALSE. + if(btest(phlista(lokph)%status1,PHIONLIQ)) then + call config_entropy_i2sl(moded,nsl,phlista(lokph)%nooffr,phres,& + phlista(lokph)%i2slx,gz%tpv(1)) + ionicliq=.TRUE. + iliqsave=.FALSE. + iliqva=.FALSE. + jonva=0 +! write(*,*)'Config G 1: ',phres%gval(1,1)*rtg +! if(phlista(lokph)%i2slx(1).gt.phlista(lokph)%tnooffr .and. & +! phlista(lokph)%i2slx(2).gt.phlista(lokph)%tnooffr) then +! onlyanions=.TRUE. +! else +! onlyanions=.FALSE. +! endif + else +! NOTE: for phases with disordered fraction set this is calculated +! for the ordered original constituent fraction set only + call config_entropy(moded,nsl,phlista(lokph)%nooffr,phres,gz%tpv(1)) + endif + if(gx%bmperr.ne.0) goto 1000 +!------------------------------------------------------------------- +! start BIG LOOP for all fraction variables and parameters +! there may be several different properties in addition to G like TC, MQ& etc +! each of these are stored in separate gval(*,ipy) where ipy is an integer +! set for each property. lprop is incremented by one for each new property +! found (each phase may have different) and in listprop the original type +! of property is stored. listprop will always be associated with phmain +100 continue +! yionva is used as indicator below if there are Va or just neutrals ... + yionva=zero +! this nevertwice is probably redundant + nevertwice=.true. + lprop=2 + phmain%listprop(1)=1 + fractype=0 +! write(*,101)'calcg 100 ',nsl,phres%gval(1,1),cps%gval(1,1) +101 format(a,i4,4(1pe14.4)) +!-------------------------------------------------------------------- +! loop for different types of fractions: site fractions, mole fractions ... + fractyp: do while(fractype.lt.phlista(lokph)%nooffs) +105 continue + fractype=fractype+1 +! return here for calculating with disordered fractions for same fraction type +110 continue +! gz%nofc is number of fraction variables, msl is number of sublattices +! for this set of fractions!!! Ordering in FCC may have 5 sublattices with +! 4 participating in ordering and one interstitial. The second fraction +! set may have 2 sublattices, 1 for the 4 ordering and one interstitial + fracset=phmain%disfra + ftype: if(fractype.eq.1) then +!---------------------------------------------- ordered (or only) fraction set +! if(btest(phlista(lokph)%status1,PHMFS)) then +! there is a disordered fractions set, we need fracset later +! if(fracset%totdis.ne.0) then +! the phase can totally disorder, if disordered skip ordered part +! if(btest(phmain%status2,CSORDER)) then +! the phase is ordered, we have to calculate this part twice +! nevertwice=.false. +! independent if ordered or disordered always calculate first fraction set +! nevertwice probably redundant +! else +! the phase is disordered, skip ordered part and just calculate disordered +! goto 105 +! endif +! endif +! endif + gz%nofc=phlista(lokph)%tnooffr + msl=nsl + incffr(0)=0 + do jl=1,nsl + incffr(jl)=incffr(jl-1)+phlista(lokph)%nooffr(jl) + enddo +! the results will be stored in the results arrays indicated by phres +! it was set above for the ordered fraction set. + else +!------------------------------------------------- +! disorderd/other fraction sets, take data from gtp_fraction_set + msl=fracset%ndd + gz%nofc=fracset%tnoofxfr + incffr(0)=0 + do jl=1,msl + incffr(jl)=incffr(jl-1)+fracset%nooffr(jl) + enddo +! we have to deallocate and allocate local arrays, not if moded=0 or 1?? + deallocate(dpyq) + deallocate(d2pyq) + allocate(dpyq(gz%nofc)) + allocate(d2pyq(nofc2)) +! if(ocv()) write(*,*)'Allocated dpyq 2' + dpyq=zero + deallocate(dvals) + deallocate(d2vals) + allocate(dvals(3,gz%nofc)) + allocate(d2vals(nofc2)) + if(ocv()) write(*,*)'Allocated vals 2' +! the results will be stored in result arrays indicated by phres +! for the disordered fraction set phres must be set here and the arrays zeroed + dislink=cps%disfra +! write(*,*)'Calc internal disordred part 1A',dislink%fsites + lokdiseq=dislink%varreslink +! write(*,*)'Calc internal disordred part 1B' + phres=>ceq%phase_varres(lokdiseq) + phres%gval=zero +! write(*,*)'Calc internal disordred part 1c' + if(moded.gt.0) then + phres%dgval=zero + if(moded.gt.1) then + phres%d2gval=zero + endif + endif +! write(*,*)'Calc internal disordred part 2' + endif ftype +!========================================================== +!vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +! code below is an attempt to parallelize the calculation of each +! endmember tree for a single phase ... +! It is commented away as there has been som many changes +! +! there can be ordered and disordered fraction sets selected by fractype +! One endmember at a time but to speed up when having several +! CPU we give one endmamber plus its interaction tree to each tread. +! To handle this all endmember records should be in an array +! if(fractype.eq.1) then +! TYPE gtp_phase must be extended with these lists +! endmemrec=>phlista(lokph)%ordered +! oendmems: do i=1,phlista(lokph)%noemr +! call calc_endmemtree(lokph,moded,msl,& +! phlista(lokph)%oendmemarr(i)%p1,phres,phmain,ceq) +! enddo oendmems +! else +! endmemrec=>phlista(lokph)%disordered +! dendmems: do i=1,phlista(lokph)%ndemr +! call calc_endmemtree(lokph,moded,msl,& +! phlista(lokph)%dendmemarr(i)%p1,phres,phmain,ceq) +! enddo dendmems +! endif +! +! calculated for this fraction type, initiation for next in the beginning of +! loop but we may have to calculate once again with same fraction type but +! with the fractions as disordered fractions +! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +!========================================================== +! there can be ordered and disordered fraction sets selected by fractype + if(fractype.eq.1) then + endmemrec=>phlista(lokph)%ordered + else + endmemrec=>phlista(lokph)%disordered + endif +! +! here we take one endmember at a time but to speed up when having several +! CPU we give one endmamber plus its interaction tree to each tread. +! To handle this all endmember records should be in an array. An attempt to +! implement this was made in calcg_internal2 but not updated for permutations +! +! empermut, lastpmq and maxpmq controls permutations (option F and B) +! maxpmq is set to zero for each new endmember but keep its content +! during calculation of all permutations of the same endmember and interactions +! big loop for all permutation of fractions (ordering option F and B) +! including all interaction parameters linked from this endmember +! +! write(*,*)'Config G 2: ',phres%gval(1,1)*rtg + endmemloop: do while(associated(endmemrec)) +! +! The array maxpmq is used for interaction permutations. It must be +! initialized to zero at the first endmember permutation. It is set to +! limits for the interacton permutations for all interaction records. + maxpmq=0 + maxprec=0 + epermut=0 + sameint=0 +! write(*,*)'3X: start endmember list' + empermut: do while(epermut.lt.endmemrec%noofpermut) + epermut=epermut+1 +! calculate py, calculate parameter, calculate contribution to G etc +! py is product of all fractions, dpy are first derivatives and d2py second + pyq=one + if(moded.gt.0) then +! moded=0, only G, =1 only G and dG/dy, moded=2 all Gm dG/dy and d2G/dy2 + dpyq=zero + if(moded.gt.1) then + d2pyq=zero + endif + endif +!----------------------------------------------------- + pyqloop: do ll=1,msl + id=endmemrec%fraclinks(ll,epermut) +! remove next line when all fixed +! if(ll.lt.5) clist(ll)=id +! id negative means wildcard, independent of the fraction in this sublattice + if(id.lt.0) then + gz%yfrem(ll)=one + else + gz%yfrem(ll)=phres%yfr(id) + if(gz%yfrem(ll).lt.bmpymin) gz%yfrem(ll)=bmpymin + if(gz%yfrem(ll).gt.one) gz%yfrem(ll)=one + endif +! gz%endcon is used for interaction parameters below + gz%endcon(ll)=id + pyq=pyq*gz%yfrem(ll) + if(ionicliq .and. ll.eq.2) then +! For ionic liquid we must check when Va or neutral in second sublattice +! i2slx(1) is index of vacancy, i2slx(2) is first neutral + if(id.eq.phlista(lokph)%i2slx(1) .and. yionva.eq.zero) then + iliqva=.TRUE. + yionva=gz%yfrem(ll) + jonva=phlista(lokph)%i2slx(1) +! We found Va. Save all calculated values as the follwing terms should all +! be multiplied with Q (done after finishing calculation) + nprop=phmain%nprop + allocate(saveg(6,nprop)) + saveg=phres%gval +! if(ocv()) write(*,*)'saveg allocated 1A: ',size(saveg),& +! gz%nofc,nofc2,nprop,moded + if(moded.gt.0) then +! only allocate if needed, some "out of memory" problems here calculating grid +! with just ionic liquid phase + allocate(savedg(3,gz%nofc,nprop)) + allocate(saved2g(nofc2,nprop)) + savedg=phres%dgval + saved2g=phres%d2gval + endif +! if(ocv()) write(*,*)'saveg allocated 1B: ' +! write(*,*)'Config G 3A: ',phres%gval(1,1)*rtg + phres%gval=zero + phres%dgval=zero + phres%d2gval=zero +! write(*,*)'Config G 3B: ',phres%gval(1,1)*rtg + iliqsave=.TRUE. +! write(*,117)'Saved ionliq G at Va id: ',& +! id,yionva,saveg(1,1) +117 format(a,i3,6(1pe12.4)) + elseif(id.eq.phlista(lokph)%i2slx(2)) then +! we have a neutral in second sublattice + iliqva=.FALSE. + yionva=-one + jonva=0 + if(.not.iliqsave) then +! We may have model without Va, for exampel (Ca+2)p(O-2,SiO4-4,SiO2)q, if so +! we must save all calculated values as the rest should be multiplied with Q + nprop=phmain%nprop + allocate(saveg(6,nprop)) + allocate(savedg(3,gz%nofc,nprop)) + allocate(saved2g(nofc2,nprop)) +! if(ocv()) write(*,*)'saveg allocated 2: ',size(saveg) + saveg=phres%gval + savedg=phres%dgval + saved2g=phres%d2gval + phres%gval=zero + phres%dgval=zero + phres%d2gval=zero + iliqsave=.TRUE. +! write(*,117)'Saved ionliq G at neutral id: ',& +! id,yionva,saveg(1,1) + endif + endif + endif + enddo pyqloop + if(moded.eq.0) goto 150 +!---------------------------------------------------- first derivatives + dpyqloop: do ll=1,msl +! here pyq is known, same loop as above to calculate dpyq(i)=pyq/y_i + id=endmemrec%fraclinks(ll,epermut) + if(id.gt.0) then +! pyq was multiplied with gz%yfrem(11) above, now divide with it + dpyq(id)=pyq/gz%yfrem(ll) +! write(*,*)'3X dpq/dy: ',ll,id,dpyq(id) + elseif(.not.ionicliq) then +! wildcard in the sublattice and NOT ionic liquid + do iw=incffr(ll-1)+1,incffr(ll) + dpyq(iw)=pyq + enddo + elseif(ll.ne.1) then +! wildcard in second subl of ionic liquid, same as for CEF + do iw=incffr(ll-1)+1,incffr(ll) + dpyq(iw)=pyq + enddo +! else +! wildcard in first subl of ionic liquid then just ignore first derivatives +! with respect to constituents in first sublattice +! continue + endif + enddo dpyqloop + if(moded.le.1) goto 150 +!---------------------------------------------------- second derivatives + d2pyqloop1: do ll=1,msl + id1=endmemrec%fraclinks(ll,epermut) + d2pyloop2: do lm=ll+1,msl + id2=endmemrec%fraclinks(lm,epermut) + if(id1.gt.0) then + if(id2.gt.0) then + d2pyq(ixsym(id1,id2))=dpyq(id1)/gz%yfrem(lm) + else +! wildcard in sublattice lm + do iw=incffr(lm-1)+1,incffr(lm) + d2pyq(ixsym(id1,iw))=dpyq(id1) + enddo + endif + else +! wildcard in sublattice ll + if(id2.gt.0) then + do iw=incffr(ll-1)+1,incffr(ll) + d2pyq(ixsym(id2,iw))=one + enddo + else +! wildcards in both sublattice ll and lm + do iw1=incffr(ll-1)+1,incffr(ll) + do iw2=incffr(lm-1)+1,incffr(lm) + d2pyq(ixsym(iw1,iw2))=pyq + enddo + enddo + endif + endif + enddo d2pyloop2 + enddo d2pyqloop1 +!---- jump here if moded is 0 or 1 +150 continue +! write(*,*)'Config G 4A: ',phres%gval(1,1)*rtg +! write(*,154)'endmember permutation: ',epermut,(clist(i),i=1,4) +154 format(a,i5,4i4,'--------------------------------') +155 format(a,i5,10i4) + proprec=>endmemrec%propointer + emprop: do while(associated(proprec)) + typty=proprec%proptype + if(typty.ne.1) then +! if property different from 1 (=G) find where to store it, use phmain link + do jl=2,lprop-1 + if(phmain%listprop(jl).eq.typty) goto 170 + enddo +! a new property, save its typty in listprop and increment lprop +! note that the property index typty is not used as index in gval etc +! as that can be very large. lprop is incremented by 1 for each property +! actually used in the model of the phase. + jl=lprop + phmain%listprop(jl)=typty + if(lprop.ge.nprop) then + write(*,*)'Too many parameter properties ',& + lprop,nprop,typty + gx%bmperr=7777; goto 1000 + endif + lprop=lprop+1 + phmain%listprop(1)=lprop +170 continue + ipy=jl + else + ipy=1 + endif +! calculate function and derivatives wrt T and P +! the results from eval_tpfun must also be different in different treads ... + lokfun=proprec%degreelink(0) + call eval_tpfun(lokfun,ceq%tpval,vals,ceq%eq_tpres) +! write(*,*)'calcg calling eval_tpfun 2: ',gx%bmperr,vals(1) + if(gx%bmperr.ne.0) goto 1000 + prop1: if(ipy.eq.1) then +! property 1 i.e. Gibbs energy, should be divided by RT + vals=vals/rtg + endif prop1 +! debug +! write(*,173)'endmember: ',endmemrec%antalem,pyq,vals(1) +!173 format(a,i3,4(1pe12.4)) +! multiply with py and derivatives. vals is composition independent +! write(*,*)'Config G 4B: ',vals(1)*rtg + noderz2: if(moded.gt.0) then + derloopz2: do id=1,gz%nofc + do itp=1,3 + phres%dgval(itp,id,ipy)=phres%dgval(itp,id,ipy)+ & + dpyq(id)*vals(itp) + enddo + if(moded.gt.1 .and. dpyq(id).gt.zero) then + do jd=id+1,gz%nofc + phres%d2gval(ixsym(id,jd),ipy)= & + phres%d2gval(ixsym(id,jd),ipy)+ & + d2pyq(ixsym(id,jd))*vals(1) + enddo + endif + enddo derloopz2 + endif noderz2 + do itp=1,6 + phres%gval(itp,ipy)=phres%gval(itp,ipy)+pyq*vals(itp) + enddo + proprec=>proprec%nextpr +! write(*,*)'Config G 4C: ',phres%gval(1,1)*rtg + enddo emprop +!------------------------------------------------------------------ +! take link to interaction records, use push and pop to save pyq etc +! pmq keeps track of the location in LASTPMQ and MAXPMQ +! for each interaction record in this binary interaction tree + intrec=>endmemrec%intpointer + gz%intlevel=0 + pmq=1 +! pmq is initiated by palmtree above in the interaction records +! write(*,*)'Config G 4D: ',phres%gval(1,1)*rtg + interloop: do while(associated(intrec)) +!---------------------------------------------------------------- +! come back here an interaction at a higher level or a poped next that must +! be pushed +200 continue +! write(*,*)'Config G 4E: ',phres%gval(1,1)*rtg,gz%intlevel + gz%intlevel=gz%intlevel+1 + call push_pyval(pystack,intrec,pmq,& + pyq,dpyq,d2pyq,moded,gz%nofc) +! intrec%order is initiated by palmtree to set a sequential number + pmq=intrec%order +! write(*,155)'Pushed: ',pmq,gz%intlevel +!------------------------------------------------------------------- +! come back here for another permutation of same paremeter (no push needed) +220 continue + bford: if(chkperm) then + setipermut: if(maxpmq(pmq).eq.0) then +! ipermut must be initiated and saved in lastpmq + ipermut=1; lastpmq(pmq)=ipermut +! On level 1 the number of permutation is in first location +! On level 2 it is more complicated but the first number of perm is in 2nd loc + maxpmq(pmq)=intrec%noofip(gz%intlevel) + else +! lastpmq and maxpmq already initiated (NOTE: they are used for all +! permutations of the same endmember, that is why they are stored here +! They cannot be pushed on the stack as the stack is also popped + ipermut=lastpmq(pmq)+1 + plimit: if(ipermut.gt.maxpmq(pmq)) then +! maximum interaction level allowed when permutations is 2 + level: if(gz%intlevel.eq.1) then +! This is always simple for level 1, + maxpmq(pmq)=maxpmq(pmq)+& + intrec%noofip(1) +! write(*,155)'new limit: ',ipermut,& +! maxpmq(pmq) + if(ipermut.le.maxpmq(pmq)) goto 230 + elseif(gz%intlevel.gt.2) then + write(*,*)'Max level 2 interactions allowed' + gx%bmperr=7777; goto 1000 + else + varying: if(intrec%noofip(1).eq.1) then +! If this is 1 then noofip(2) is number of permutations each time + maxpmq(pmq)=maxpmq(pmq)+intrec%noofip(2) + if(ipermut.le.maxpmq(pmq)) goto 230 + else +! This is more complicated, different number of permutations each time +! Example: noofip=(3,2,1,0,12) means there are 3 different permutations +! first time; 2 the second time; 1 the last time none; +! 12 is the total number of permutationss (including first order) +! Example 1: end member (A:A:A:A), no permutation +! first int B in 1 with perms: 2nd int C in 2 with perms: (3,3,3,3,12) +! (AB:A:A:A) (AB:AC:A:A) (AB:A:AC:A) (AB:A:A:AC) +! (A:AB:A:A) (AC:AB:A:A) (A:AB:AC:A) (A:AB:A:AC) +! (A:A:AB:A) (AC:A:AB:A) (A:AC:AB:A) (A:A:AB:AC) +! (A:A:A:AB) (AC:A:A:AB) (A:AC:A:AB) (A:A:AC:AB) +! Example 2: end member (A:A:A:A), no permutation +! first int B in 1 with perms: 2nd int B in 2 with perms: (3,2,1,0,6) +! (AB:A:A:A) (AB:AB:A:A) (AB:A:AB:A) (AB:A:A:AB) +! (A:AB:A:A) (A:AB:AB:A) (A:AB:A:AB) +! (A:A:AB:A) (A:A:AB:AB) +! (A:A:A:AB) none +! If mod(ipermut,noofip(1)) is 0 one should start from index 2 + nz=intrec%noofip(1) +! write(*,155)'noofip: ',ipermut,pmq,maxpmq(pmq),& +! (intrec%noofip(j),j=1,nz) + if(maxpmq(pmq).gt.0) then +! Previous increase of limit was greater than zero, special case for noofip=2 + if(intrec%noofip(1).eq.2) then + maxpmq(pmq)=-maxpmq(pmq) + else + nz=mod(ipermut-1,intrec%noofip(1)) + if(nz.eq.0) then + maxpmq(pmq)=-maxpmq(pmq) + else + maxpmq(pmq)=maxpmq(pmq)+& + intrec%noofip(1+nz) + endif + endif + if(ipermut.le.maxpmq(pmq)) goto 230 + else +! Previous increase of limit was 0, start repeating values from noofip(2.. + maxpmq(pmq)=intrec%noofip(2)-& + maxpmq(pmq) + if(ipermut.le.maxpmq(pmq)) goto 230 + endif +! write(*,155)'noperm: ',ipermut,pmq,& +! lastpmq(pmq),maxpmq(pmq) + endif varying +! as we have passed the limit of permutations, take higher or next interaction +!??? if(ipermut.le.maxpmq(pmq)) goto 230 + endif level +! We have exeeded the permutation limit, we should not go to any +! higher interaction but to a next interaction on same level (if any) +! or go down one level + if(associated(intrec%highlink)) then + if(gz%intlevel.eq.2) then + write(*,229)gz%intlevel +229 format('Error, max 2 levels of interactions',/& + ' with permutations!! ',i3) + gx%bmperr=7777; goto 1000 + endif +! Take the link to higher as no more permutations here + goto 290 + endif +!.............................. +! No higher level, if we cannot pop we must return to endmember + if(gz%intlevel.eq.0) exit interloop +! we must pop lower order interaction records here to get correct permutation + call pop_pyval(pystack,intrec,pmq,& + pyq,dpyq,d2pyq,moded,gz%nofc) + gz%intlevel=gz%intlevel-1 + pmq=intrec%order +!................................. +! intrec must not be associated in the popint: do-loop + nullify(intrec) + goto 295 + endif plimit +! We have now the permutation for this interaction in ipermut +230 continue + endif setipermut +! Found the permutations for option F and B, save it in lastpmq(pmq) + lastpmq(pmq)=ipermut +! Without permutations just set ipermut=1 + else + ipermut=1 + endif bford +!------------------------------------------------------------------- +! Code below until label 290 the same with and without permutations +! extract sublattice, constituent and fraction of interacting constituent +! NOTE "ic" used several times below, do not manipulate it!!! + intlat=intrec%sublattice(ipermut) + ic=intrec%fraclink(ipermut) + gz%intlat(gz%intlevel)=intlat + gz%intcon(gz%intlevel)=ic + gz%yfrint(gz%intlevel)=phres%yfr(ic) + if(ionicliq .and. iliqsave) then + if(intlat.eq.1 .and. yionva.gt.zero) then +! iliqsave is TRUE for ionic_liquid and for excess parameters without anions +! For cation interactions multiply with yionva. If no vacancies yionva=-1.0 + gz%yfrint(gz%intlevel)=phres%yfr(ic)*yionva +! write(*,*)'3X *yionva: ',yionva,gz%yfrint(gz%intlevel) + endif + endif +! calculate new PY incl derivatives. Moded to avoid unrequested derivatives +! IF interaction endmember is WILDCARD then the interaction is special, +! L(*,A) is y_A *(1-y_A) where 1-y_A is the sum of all fractions except A +! pyq = pyq * y_ic * (y_ix + y_iy + ... ) (all_other_in_same_sublattice)) +! derivatives are calculated for all constituents in intlat +! note one can also have wildcards in other sublattices + if(gz%endcon(intlat).gt.0) then + wildc=.FALSE. + ymult=gz%yfrint(gz%intlevel) + else + if(iliqsave) then +! I sincerely hope wildcards are never used in 2nd subl of ionic liquids ... + write(*,*)'Wildcard in second sublattice is not allowed for ionic liquids' + gx%bmperr=7777; goto 1000 + endif + wildc=.TRUE. + write(*,*)'wildcard found!' + ymult=gz%yfrint(gz%intlevel)*(one-gz%yfrint(gz%intlevel)) + endif + noder3A: if(moded.gt.0) then +! ...................................... loop for first derivatives + iloop1: do id=1,gz%nofc + if(moded.gt.1) then +! ...................................... second derivatives + iloop2: do jd=id+1,gz%nofc + if(iliqsave .and. intlat.eq.1) then +! For ionic liquids interaction parameters that are multiplied with yionva +! should also be multiplied with the power of yionva which is gz%intlevel+1 + d2pyq(ixsym(id,jd))=& + (gz%intlevel+1)*d2pyq(ixsym(id,jd))*ymult + else +! For all other models it is simply ... + d2pyq(ixsym(id,jd))=d2pyq(ixsym(id,jd))*ymult + endif + enddo iloop2 +! NOTE "ic" has been set above as the interacting constituent + if(iliqsave) then + if(intlat.eq.1 .and. yionva.gt.zero) then +! For ionic liquid model the 2nd derivatives must be multipled with yionva + if(id.eq.phlista(lokph)%i2slx(1)) then +! This is the vacancy, all 2nd derivatives multiplied with a factor + d2pyq(ixsym(id,ic))=& + (gz%intlevel+1)*d2pyq(ixsym(id,ic)) + endif + else + d2pyq(ixsym(id,ic))=dpyq(id)*yionva + endif + else + d2pyq(ixsym(id,ic))=dpyq(id) + endif + endif +! ................................. this is the first derivative, must be exact +! very messy for the ionic liquid here ... + dpyq(id)=dpyq(id)*ymult + if(ionicliq .and. iliqsave) then +! write(*,*)'Extra va power: ',id,gz%intlevel,& +! gz%intlat(gz%intlevel) + if(id.eq.phlista(lokph)%i2slx(1) .and. & + gz%intlat(gz%intlevel).eq.1) then +! for vacancies there is an additional factor if interaction in first subl + dpyq(id)=(gz%intlevel+1)*dpyq(id) +! write(*,197)gz%intlevel,gz%intcon(gz%intlevel) +197 format('3X: inter: ',5i3) + endif + endif + enddo iloop1 +! we must check if any endmember is wildcard like L(*:A,B) +! Hopefully this works also for ionic liquid interaction between neutrals + do ll=1,msl + if(ll.ne.intlat) then + if(gz%endcon(ll).lt.0) then + do iw=incffr(ll-1)+1,incffr(ll) + d2pyq(ixsym(iw,ic))=pyq + enddo + endif + endif + enddo + wildcard: if(wildc) then +! The interacting constituent is a wildcard ... calculate the contribution +! to second derivate from all fractions in intlat, remember incffr(0)=0. +! Ionic liquids should never have wildcards as intercations ... ? + do iw=incffr(intlat-1)+1,incffr(intlat) + if(iw.ne.ic) then + d2pyq(ixsym(iw,ic))=dpyq(iw) + endif +! write(*,213)'529: ',iw,ic,ixsym(iw,ic),& +! gz%intlevel,intlat,incffr(intlat) + dpyq(iw)=pyq*gz%yfrint(gz%intlevel) +! dpyq(jd)=pyq*gz%yfrint(gz%intlevel) + enddo +213 format(a,10i5) + dpyq(ic)=pyq*(one-gz%yfrint(gz%intlevel)) + else +! this is the normal first derivative of pyq*y(ic) with respect to y(ic)=ymult + dpyq(ic)=pyq + if(ionicliq) then +! write(*,214)'Multiply with y_va: ',& +! iliqsave,ic,intlat,yionva,pyq +214 format(a,l,2i3,4(1pe12.4)) + if(iliqsave .and. intlat.eq.1.and.yionva.gt.zero) then +! for compatibility with substitutional liquids, multiply interactions +! of cations (in 1st subl) when vacancies in 2nd with the vacancy fraction + dpyq(ic)=pyq*yionva + endif + endif + endif wildcard +! write(*,228)'3X: dpyq: ',(dpyq(ll),ll=1,4) +!228 format(a,6(1pe12.4)) + endif noder3A +! pyq calculated identically for wildcards as ymult set differently above +! It should work for ionic liquids as ymult has been multiplied with yionva + pyq=pyq*ymult +! write(*,*)'3X pyq: ',ymult,pyq + proprec=>intrec%propointer +!.............................. + intprop: do while(associated(proprec)) +! calculate interaction parameter, can depend on composition + call cgint(lokph,proprec,moded,vals,dvals,d2vals,gz,ceq) + if(gx%bmperr.ne.0) goto 1000 +! G parameters (ipy=1) are divided by RT inside cgint + typty=proprec%proptype + if(typty.ne.1) then +! other properties than 1 (G) must be stored in different gval(*,ipy) etc + do jl=2,lprop-1 + if(phmain%listprop(jl).eq.typty) goto 250 + enddo +! a new property, save its typty in listprop and increment lprop + jl=lprop + phmain%listprop(jl)=typty + lprop=lprop+1 + phmain%listprop(1)=lprop +250 continue +! here the value of ipy is set, 1 means G + ipy=jl + else + ipy=1 + endif +! note: adding to phres%gval at the end of noder4: if(....) + noder4: if(moded.gt.0) then + iloop3: do id=1,gz%nofc + if(moded.gt.1) then + iloop4: do jd=id+1,gz%nofc + phres%d2gval(ixsym(id,jd),ipy)= & + phres%d2gval(ixsym(id,jd),ipy)+ & + d2pyq(ixsym(id,jd))*vals(1) + enddo iloop4 + endif + do itp=1,3 + phres%dgval(itp,id,ipy)=& + phres%dgval(itp,id,ipy)+ & + dpyq(id)*vals(itp) + enddo + enddo iloop3 +! write(*,211)'Interactions: ',gz%iq,jonva +211 format(a,5i3,5x,i3) +! if(jonva.gt.0) then +! write(*,212)jonva,phres%dgval(1,jonva,1)*rtg +!212 format('with va: ',i3,6(1pe12.4)) +! endif +!............................... +! below contribution to derivatives from composition dependent parameters +! the values of gz%iq represent interacting constituents and are set in cgint + cdex1: if(gz%iq(5).gt.0) then +! gz%iq(5) is nonzero only for TOOP and similar models not implemented yet ... + gx%bmperr=4086; goto 1000 + elseif(gz%iq(4).gt.0) then +!............................... +! composition dependent reciprocal parameter +! for ionic liquid one must consider extra vacancy fraction ... +! contribution to second derivatives ignored ... +! remember ipy is property type for this parameter, set above +! write(*,333)'3X comp dep reciprocal:',gz%iq,pyq,vals(1) +333 format(a,5i4,4(1pe14.6)) + if(moded.gt.0) then + do jk=1,4 + do itp=1,3 + phres%dgval(itp,gz%iq(jk),ipy)=& + phres%dgval(itp,gz%iq(jk),ipy)+& + pyq*dvals(1,gz%iq(jk)) + enddo + enddo + endif + elseif(gz%iq(3).gt.0) then !cedex1 +! composition dependent ternary interaction in same sublattice, Mats model +! PROBABLY ERRORS HERE as no consideration of derivatives wrt other endmember +! constituents, only to the 3 interacting +! ALSO used to indicate derivatives wrt vacancies in ionic liquid model ??? +!...<<<<<<<...... indentation back 2 levels + if(moded.gt.1) then + noindent1: do jk=1,3 + do jl=jk+1,3 +! the second derivative for jk=jl calculated below as it is simpler + phres%d2gval(ixsym(gz%iq(jk),gz%iq(jl)),ipy)=& + phres%d2gval(ixsym(gz%iq(jk),gz%iq(jl)),ipy)+& + dpyq(gz%iq(jk))*dvals(1,gz%iq(jl))+& + dpyq(gz%iq(jl))*dvals(1,gz%iq(jk)) + enddo + enddo noindent1 + endif + do jk=1,3 + do itp=1,3 + phres%dgval(itp,gz%iq(jk),ipy)=& + phres%dgval(itp,gz%iq(jk),ipy)& + +pyq*dvals(itp,gz%iq(jk)) + enddo + phres%d2gval(ixsym(gz%iq(jk),gz%iq(jk)),ipy)=& + phres%d2gval(ixsym(gz%iq(jk),gz%iq(jk)),ipy)+& + 2.0D0*dpyq(gz%iq(jk))*dvals(1,gz%iq(jk)) + enddo +!...>>>>>>...........indentation back + elseif(gz%iq(2).gt.0) then !cedex1 +! gz%iq(2) nonzero means composition dependent binary interaction parameter, +! only RK yet. + noder3B: if(moded.gt.1) then +! one can maybe make this loop faster by just looping throungh endmembrs +! but then one must handle wildcard endmembers .... +! and there may be other bugs here anyway .... + do ic1=1,gz%nofc + add1=dpyq(ic1)*dvals(1,gz%iq(1))+& + dpyq(gz%iq(1))*dvals(1,ic1)+& + pyq*d2vals(ixsym(ic1,gz%iq(1))) + phres%d2gval(ixsym(ic1,gz%iq(1)),ipy)=& + phres%d2gval(ixsym(ic1,gz%iq(1)),ipy)+add1 + if(ic1.ne.gz%iq(1)) then +! this IF to avoid that the second derivative gz%iq(1) and gz%iq(2) is +! calculated twice. ic1 will at some time be equal to gz%iq(1) and to gz%iq(2) + add1=dpyq(ic1)*dvals(1,gz%iq(2))+& + dpyq(gz%iq(2))*dvals(1,ic1)+& + pyq*d2vals(ixsym(ic1,gz%iq(2))) + phres%d2gval(ixsym(ic1,gz%iq(2)),ipy)=add1+& + phres%d2gval(ixsym(ic1,gz%iq(2)),ipy) + endif + enddo + endif noder3B + do itp=1,3 + phres%dgval(itp,gz%iq(1),ipy)=& + phres%dgval(itp,gz%iq(1),ipy)& + +pyq*dvals(itp,gz%iq(1)) + phres%dgval(itp,gz%iq(2),ipy)=& + phres%dgval(itp,gz%iq(2),ipy)& + +pyq*dvals(itp,gz%iq(2)) + if(ionicliq) then +! for ionic liquid when interactions involve cations there is a contribution +! due to the vacancy fraction multiplied with the cations yc1*yc2*yva**2 +! we are dealing with binary RK interactions, gz%intlevel=1, check if +! interaction is in first sublattice (between cations) and vacancy in second + if(iliqva .and. gz%intlat(1).eq.1 & + .and. jonva.gt.0) then +! add pyq multipled with the derivative with respect to vacancy fraction +! This should be done for d2gval also but I skip that at present ... + phres%dgval(itp,jonva,ipy)=& + phres%dgval(itp,jonva,ipy)+& + pyq*dvals(itp,jonva) +! write(*,*)'jonva: ',jonva,pyq,dvals(1,jonva) + endif + endif + enddo + endif cdex1 +! end contribution to derivates from composition dependent parameters +!...................... + endif noder4 +! finally add the contribution to G, G.T etc + iloop6: do itp=1,6 + phres%gval(itp,ipy)=phres%gval(itp,ipy)+pyq*vals(itp) + enddo iloop6 + proprec=>proprec%nextpr + enddo intprop +! write(*,*)'Config G 4F: ',phres%gval(1,1)*rtg +! finished one interaction (or permutation on this level), go to higher level +! note that ipermut is saved in lastpmq(pmq). If there are more +! permutations on this level they will be calculated later also including +! higher order parameters. +!------------------------------------------------------------------ +! Take link to higher level records for current permutation +290 continue + intrec=>intrec%highlink + wrong: if(chkperm .and. associated(intrec)) then +! We must go to higher as we can have interactions with different permutations? + jpr=intrec%order + if(lastpmq(jpr).gt.0 .and.lastpmq(jpr).ge.maxpmq(jpr)) then +! if we nullify here we will take next rather than higher +! nullify(intrec) +! write(*,155)'Maybe skipping higer?: ',jpr,& +! lastpmq(jpr),maxpmq(jpr),gz%intlevel +! if(maxpmq(jpr).lt.0) maxpmq(jpr)=intrec%noofip(2)-& +! maxpmq(jpr) + endif + endif wrong +! if intrec is associated then go to big "interloop: do while()" loop +295 continue + popint: do while(.not.associated(intrec)) +! No higher level, pop lower order interaction records, if no pop: endmember + if(gz%intlevel.eq.0) exit interloop + call pop_pyval(pystack,intrec,pmq,& + pyq,dpyq,d2pyq,moded,gz%nofc) + gz%intlevel=gz%intlevel-1 + pmq=intrec%order +! check if we have more permutations for this record + if(chkperm) then + if(lastpmq(pmq).lt.maxpmq(pmq)) then + goto 200 + endif + endif + intrec=>intrec%nextlink + enddo popint +! we should loop here if we found a higher order record or +! a lower order record with a next link + enddo interloop +298 continue +! write(*,*)'Config G 4X: ',phres%gval(1,1)*rtg +! take next permutation of the end member fractions + enddo empermut +300 continue +! take next end member +! write(*,155)'endmem: ',epermut,endmemrec%noofpermut,endmemrec%antalem + endmemrec=>endmemrec%nextem + enddo endmemloop +! write(*,*)'Config G 5: ',phres%gval(1,1)*rtg +!------------------------------------------------------------------------ +! end loop for this fraction type, initiation for next in the beginning of loop +! but we may have to calculate once again with same fraction type but +! with the fractions as disordered fractions +! write(*,*)' **** 3X Warning: This code should never be executed ',& +! nevertwice +! if(nevertwice) then +! goto 400 +! endif + goto 400 +!------------------------------------------------ +! the code from disord: if ... endif is redundant + disord: if(fractype.eq.1 .and. btest(phlista(lokph)%status1,phmfs) & + .and. btest(phmain%status2,csorder)) then +! Handle additions of several fraction set ?? Additions calculated +! after both ordered and disordered fraction set calculated +! write(*,611)'3X ftyp:',fractype,btest(phlista(lokph)%status1,phmfs),& +! btest(phmain%status2,csorder),first,lokph +!611 format(a,i3,3(1x,L),2i3) + if(first) then +! calculate with next fraction type +! NEW METHOD: no need to calculate with all fractions as disordered + first=.false. + write(*,*)'3X: next fraction type' + goto 400 +!------------ code below redundant until ^^^^^^^^^^^^^^^^^^^^^^^^^ +! this is no longer needed as we just add the disordered part +! but do not delete yet ... wait until I know it works ... + allocate(savey(gz%nofc)) + savey=phres%yfr +! write(*,*)'cg: ',phmain%phlink,phmain%disfra%varreslink +! ??? very uncertain how to call disordery ..... +! call disordery(phmain,phmain%disfra%varreslink,ceq) + call disordery(phmain,ceq) + nprop=phmain%nprop + allocate(saveg(6,nprop)) + allocate(savedg(3,gz%nofc,nprop)) + allocate(saved2g(nofc2,nprop)) +! write(*,*)'saveg allocated 3: ',size(saveg) + saveg=phres%gval + savedg=phres%dgval + saved2g=phres%d2gval + phres%gval=zero + phres%dgval=zero + phres%d2gval=zero + goto 110 + else +! We have now calculated the 4SL model with both as original and disordered +! We should now subreact the disordered from the ordered +! this is debug output +! do i1=1,gz%nofc +! write(*,602)'3X Gx: ',i1,phres%dgval(1,i1,1),savedg(1,i1,1) +! enddo +!602 format(a,i3,6(1pe14.6)) +! Ordered part calculated with disordered fractions, subtract this +! from the first, restore fractions and deallocate +! THIS IS TRICKY +! NOTE all sublattices are identical in this case with the same number +! of constituents +! First sum all second derivatives into tmpd2g, moded=1 means only 1st deriv + noder6A: if(moded.gt.1) then + nz=fracset%tnoofxfr + allocate(tmpd2g(nz*(nz+1)/2,nprop)) + tmpd2g=zero +! DEBUG, problem with partitioning 4 sublattice FeNi: +! write(*,613)'3X sub: ',nz,gz%nofc,fracset%latd,fracset%y2x +!613 format(a,3i3,2x,20i3) +! write(*,614)'3X dxi/dyj: ',fracset%dxidyj +!614 format(a,(10f7.4)) + do ipy=1,lprop-1 + do i1=1,gz%nofc + j1=fracset%y2x(i1) + do i2=i1,gz%nofc + j2=fracset%y2x(i2) + tmpd2g(ixsym(j1,j2),ipy)=tmpd2g(ixsym(j1,j2),ipy)+& + phres%d2gval(ixsym(i1,i2),ipy) + enddo + enddo + enddo +! tmpd2g is now d2G/dxidxj calculated with disordered fractions +! subract that from saved d2G/dyidyj saved in saved2g taking into account +! the derivatives dxi/dyj (in fracset%dxidyj) + do ipy=1,lprop-1 + do i1=1,gz%nofc + j1=fracset%y2x(i1) + do i2=i1,gz%nofc +! subtract from saved value + j2=fracset%y2x(i2) + phres%d2gval(ixsym(i1,i2),ipy)=& + saved2g(ixsym(i1,i2),ipy)-& + tmpd2g(ixsym(j1,j2),ipy)*& + fracset%dxidyj(i1)*fracset%dxidyj(i2) + enddo + enddo + enddo + deallocate(tmpd2g) + endif noder6A +!--------------------- +! sum all first partial derivates to first sublattice + noder6B: if(moded.gt.0) then +! write(*,613)'3X dG/dx: ',fracset%ndd,fracset%nooffr + do ipy=1,lprop-1 + do ider=1,3 + do is=1,fracset%nooffr(1) + sum=zero + kk=is + do ll=1,fracset%latd + sum=sum+phres%dgval(ider,kk,ipy) +! it is not really necessary to put phres%dgval it to zero, just for prudence +! phres%dgval(ider,kk,ipy)=zero + kk=kk+fracset%nooffr(1) + enddo + phres%dgval(ider,is,ipy)=sum + enddo + if(fracset%ndd.eq.2) then +! one can have 2 sets of ordered subl like (Al,Fe)(Al,Fe)...(C,Va)(C,Va)... + ioff=fracset%nooffr(1)*fracset%latd + do is=1,fracset%nooffr(2) + sum=zero + kk=ioff+is + do ll=fracset%latd+1,phlista(lokph)%noofsubl + sum=sum+phres%dgval(ider,kk,ipy) + phres%dgval(ider,kk,ipy)=zero + kk=kk+fracset%nooffr(2) + enddo + phres%dgval(ider,ioff+is,ipy)=sum + enddo + endif + enddo + enddo +!------------------------- + if(moded.gt.0) then + do ipy=1,lprop-1 +! loop in negative direction avoid destroy the values in phres%dgval first subl + do i1=gz%nofc,1,-1 +! all derivatives wrt same element from all sublattices is in first sublattice + j1=fracset%y2x(i1) + do ider=1,3 +! Finally subtract this contribution from saved values +! phres%dgval(ider,i1,ipy)=savedg(ider,i1,ipy)-& + xxx=savedg(ider,i1,ipy)-& + phres%dgval(ider,j1,ipy)*fracset%dxidyj(i1) +! write(*,615)'3X Gy-Gx: ',ider,i1,ipy,j1,& +! savedg(ider,i1,ipy),phres%dgval(ider,j1,ipy),& +! fracset%dxidyj(i1),xxx +!615 format(a,4i3,4(1pe14.6)) + phres%dgval(ider,i1,ipy)=xxx + enddo + enddo + enddo + endif + endif noder6B + do ipy=1,lprop-1 + do ider=1,6 + phres%gval(ider,ipy)=saveg(ider,ipy)-& + phres%gval(ider,ipy) + enddo + enddo +! restore ordered fractions and deallocate save arrays +! write(*,612)'3X yd: ',phres%yfr + phres%yfr=savey +! write(*,612)'3X yo: ',phres%yfr +612 format(a,6(1pe11.3),(7x,6e11.3)) +! why set to zero if I deallocate ?? +! savey=zero +! saveg=zero +! savedg=zero +! saved2g=zero +! if(ocv()) write(*,*)'saveg DE-allocated 1: ',size(saveg) + deallocate(savey) + deallocate(saveg) + deallocate(savedg) + deallocate(saved2g) + endif +! ----------------- code above redundant ^^^^^^^^^^^^^^^^^^^^^^^^ + endif disord +400 continue + enddo fractyp +!-------------------------------------------------------------- +! finished loops for all fractypes, now add together G and all +! partial derivatives for all fractypes +410 continue +! cheking for properties +! if(ocv()) then +! write(*,411)lprop-1,(phmain%listprop(j1),j1=2,lprop) +! write(*,412)'Val: ',(phmain%gval(1,j1),j1=1,lprop-1) +!411 format('Properties: ',i3,': ',10i4) +412 format(a,(6E12.4)) +! endif + norfc=phlista(lokph)%tnooffr + fractionsets: if(btest(phlista(lokph)%status1,phmfs)) then +!---------------------------------------------------------------- +! for disordered part of sigma we may have to multiply the disordered +! part with fsites to have correct formula unit +! write(*,*)'3X fsites 1: ',phmain%disfra%fsites + fsites=phmain%disfra%fsites +! add together contributions from different fractypes +! phres is last calculated part, set phpart to ordered part (phmain) + phpart=>phmain +! loop for all second and first derivatives using chain rule +! and coefficients from fracset%dxidyj +! d2f1/dyidyj = d2f2/dxkdxl*dxk/dyi*dxl/dyj +! gz%nofc are number of disordered constituents +! norfc are number of ordered constituents +! lprop-1 is number of properties to be summed +! G(tot) = GD(x)+(GO(y)-GO(y=x)) +! G(tot).yj = dGD(x).dxi*dxdyj + (GO(y).yj - GO(y=x).yj) +! configurational entropy calculated only for GO(y) + noder7A: if(moded.gt.0) then + do i1=1,norfc + j1=fracset%y2x(i1) +! second derivatives + noder7B: if(moded.gt.1) then + do i2=i1,norfc +! add the contributions from the disordered part + j2=fracset%y2x(i2) + do ipy=1,lprop-1 + phpart%d2gval(ixsym(i1,i2),ipy)=& + phpart%d2gval(ixsym(i1,i2),ipy)+& + fsites*phres%d2gval(ixsym(j1,j2),ipy)*& + fracset%dxidyj(i1)*fracset%dxidyj(i2) + enddo + enddo + endif noder7B +! first derivatives + do ipy=1,lprop-1 +! add1=phpart%dgval(1,i1,ipy) + do ider=1,3 +! phpart%dgval(ider,i1,ipy)=phpart%dgval(ider,i1,ipy)+& + xxx=phpart%dgval(ider,i1,ipy)+& + fsites*phres%dgval(ider,j1,ipy)*fracset%dxidyj(i1) +! phres have the disordred contribution +! write(*,413)'3X Gd+Go:',ider,i1,j1,& +! phpart%dgval(ider,i1,ipy),fsites,& +! phres%dgval(ider,j1,ipy),fracset%dxidyj(i1),xxx +! write(*,413)'3X Gd+Go:',ider,i1,j1,& +! phmain%dgval(ider,i1,ipy),fsites,& +! phres%dgval(ider,j1,ipy),fracset%dxidyj(i1),xxx + phpart%dgval(ider,i1,ipy)=xxx + enddo + enddo + enddo + endif noder7A +413 format(a,3i3,6(1pe12.4)) +! Integral values + do ipy=1,lprop-1 +! add1=phpart%gval(1,ipy) + do ider=1,6 + phpart%gval(ider,ipy)=phpart%gval(ider,ipy)+& + fsites*phres%gval(ider,ipy) + + enddo +! if(ocv()) write(*,413)'3X G:',ipy,0,0,& +! write(*,413)'3X G:',ipy,0,0,& +! phpart%gval(1,ipy),add1,phres%gval(1,ipy) + enddo + endif fractionsets +! now set phres to ordered+disorded results and forget phpart + phres=>phmain +!................................ +! write(*,*)'3X: ioliq+saved: ',ionicliq,iliqsave,phres%gval(1,1) + ionliqsum: if(ionicliq .and. iliqsave) then +! For ionic liquid we may have to add gsave+Q*gval (with chain rule ...) +! G = saveg + Q*phres%gval with 1st and 2nd derivatives +! NOT FINISHED !!! interaction parameters above with VA must be treated +! +!vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +! BEWHARE: FOR IONIC_LIQUID Thermo-Calc calculates G = Q G_M +! if there are no end-member parameters (G_M is the Gibbs energy per +! formula unit and Q is the number of sites in second sublattice), +! This is wrong but all endmember parameters are never zero for a real liquid. +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! +! write(*,*)'Config G 6: ',phres%gval(1,1)*rtg + if(moded.eq.0) goto 490 +! write(*,491)'3X ionliq: ',phlista(lokph)%i2slx,phlista(lokph)%nooffr +491 format(a,2i3,5x,2i3) + firstd: do i1=1,norfc + secondd: do i2=i1,norfc + do ipy=1,lprop-1 +! write(*,497)'adding: ',i1,i2,ixsym(i1,i2),ipy +497 format(a,10i3) + phres%d2gval(ixsym(i1,i2),ipy)=saved2g(ixsym(i1,i2),ipy)+& + phres%sites(2)*phres%d2gval(ixsym(i1,i2),ipy) + add1=zero +! IMPORTANT note dpqdy(i1) the the charge of iq, do not confuse with dpyq ... + if(i1.le.phlista(lokph)%nooffr(1)) then + add1=phres%dpqdy(i1)*phres%dgval(1,i2,ipy) + endif + if(i2.le.phlista(lokph)%nooffr(1)) then + add1=add1+phres%dpqdy(i2)*phres%dgval(1,i1,ipy) + endif + phres%d2gval(ixsym(i1,i2),ipy)=phres%d2gval(ixsym(i1,i2),ipy)+& + add1 + enddo + enddo secondd +! hm, when debugging here phres%dgval(1,*,1)=0 so ... + add1=savedg(1,i1,1) + sum=phres%dgval(1,i1,1) + if(phres%dpqdy(i1).lt.1.0D-60) phres%dpqdy(i1)=zero + do ipy=1,lprop-1 + do ider=1,3 +! this calculates the proper ionic liquid model, not Q times + phres%dgval(ider,i1,ipy)=& + savedg(ider,i1,ipy)+& + phres%sites(2)*phres%dgval(ider,i1,ipy) +! The contribution from the derivative of Q = \sum_i nu_i y_i, dQ/dy_i = nu_i +! G = G1 + Q G2 where +! G1 = \sum_i \sum_j y_i y_j G_ij + config.entropy +! G2 = y_va\sum_i y_i G_i + Q\sum_k y_k G_k +! Above were added: dG/dy_i = dG1/dy_i + + Q dG2/dy_i +! For cations we must add also dG/dy_i = dG/dy_i + nu_i G2 + if(i1.le.phlista(lokph)%nooffr(1)) then +! nooffr(1) is the number of constituents in first sublattice + phres%dgval(ider,i1,ipy)=phres%dgval(ider,i1,ipy)+& + phres%dpqdy(i1)*phres%gval(ider,ipy) + endif + enddo + enddo +! write(*,747)'suming: ',i1,savedg(1,i1,1)*rtg,phres%dgval(1,i1,1)*rtg,& +! phres%dpqdy(i1),phres%gval(1,1) +! write(*,747)'3Xx:',i1,add1,sum,phres%dgval(1,i1,1),phres%dpqdy(i1),& +! phres%sites(2),savedg(1,i1,1) +747 format(a,i2,6(1pe12.4)) + enddo firstd +! write(*,*)'summed: ',savedg(1,1,1)*rtg,phres%dgval(1,1,1)*rtg +! Integral values: G = saveg + Q*phres%gval with T and P derivatives +490 continue +! write(*,492)'ionsum: ',saveg(1,1),phres%gval(1,1),& +! (saveg(1,1)+phres%gval(1,1))*rtg*phres%sites(2) +492 format(a,6(1pe12.4)) +! write(*,*)'Config G 7A: ',phres%gval(1,1)*rtg + do ipy=1,lprop-1 + do ider=1,6 + phres%gval(ider,ipy)=saveg(ider,ipy)+& + phres%sites(2)*phres%gval(ider,ipy) + enddo + enddo +! write(*,*)'Config G 7B: ',phres%gval(1,1)*rtg,saveg(1,1)*rtg +! strange bug which changes the results for a calculation with only C1 +! if the ionic liquid has been non-suspended at some previous calculation ... + saveg=zero +! if(ocv()) write(*,*)'De-allocated saveg 2: ',size(saveg) +! no need to set them zero if they will be deallocated?? +! savedg=zero +! saved2g=zero + deallocate(saveg) + if(moded.gt.0) then + deallocate(savedg) + deallocate(saved2g) + endif +!499 continue + endif ionliqsum +!................................ +! calculate additions like magnetic contributions etc and add to G + addrec=>phlista(lokph)%additions + additions: do while(associated(addrec)) +! if(addlista(lokadd)%type.eq.1) then +! Note for phases with a disordered fraction set, gz%nofc is equal to +! the disordered number of fractions here +! i1=gz%nofc + gz%nofc=phlista(lokph)%tnooffr +! write(*,*)'3X gz%nofc: ',i1,gz%nofc +! moded is 0, 1 or 2 if derivatives should be calculated, phres is pointer +! to result arrays, lokadd is the addition record, listprop is needed to +! find where TC and BM are stored, gz%nofc are number of constituents + call addition_selector(addrec,moded,phres,lokph,gz%nofc,ceq) + if(gx%bmperr.ne.0) goto 1000 +! there are actually no other additions defined ... + addrec=>addrec%nextadd + enddo additions +! there are some special properties like mobilities and similar which +! have a conmponent or constituent index like MQ& +! ipy=typty/100+mod(typty,100) +! if(ipy.gt.10) then +! write(*,*)'Property ',typty,ipy +1000 continue + if(chkperm) then +! wait for checking for errors .... +! write(*,*)'Press return' +! read(*,297)ch1 +!297 format(a) + endif +! running out of memory?? + deallocate(dpyq) + deallocate(d2pyq) + deallocate(dvals) + deallocate(d2vals) +! write(*,1001)gx%bmperr,(phres%gval(i,1),i=1,4) +! write(*,1002)(phres%dgval(1,i,1),i=1,3) +! write(*,1003)(phres%d2gval(i,1),i=1,6) +1001 format('calcg g: ',i5,4(1PE15.7)) +1002 format('calcg dg: ',3(1PE15.7)) +1003 format('calcg d2g: ',6(1PE11.3)) + return + end subroutine calcg_internal + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine setendmemarr(lokph,ceq) +! stores the pointers to all ordered and disordered endmemners in arrays + implicit none + integer lokph + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer ll,nz,noemr + TYPE(gtp_endmember), pointer :: emrec + TYPE(gtp_fraction_set), pointer :: disfraset + if(allocated(phlista(lokph)%oendmemarr)) then + deallocate(phlista(lokph)%oendmemarr) +! allways allocate place for maximum endmembers (product of constituents) + nz=1 + do ll=1,phlista(lokph)%noofsubl + nz=nz*phlista(lokph)%nooffr(ll) + enddo + allocate(phlista(lokph)%oendmemarr(nz)) + noemr=0 + emrec=>phlista(lokph)%ordered + do while(associated(emrec)) + noemr=noemr+1 + phlista(lokph)%oendmemarr(noemr)%p1=>emrec + emrec=>emrec%nextem + enddo + phlista(lokph)%noemr=noemr + endif +! same for disordered endmembers (if any) +! Data for this is stored in phase_varres record, same index as phlista !!! + if(allocated(phlista(lokph)%dendmemarr)) then + deallocate(phlista(lokph)%dendmemarr) +! allways allocate place for maximum endmembers (product of constituents) + disfraset=>ceq%phase_varres(lokph)%disfra + nz=1 + do ll=1,disfraset%ndd + nz=nz*disfraset%nooffr(ll) + enddo + allocate(phlista(lokph)%dendmemarr(nz)) + noemr=0 + emrec=>phlista(lokph)%disordered + do while(associated(emrec)) + noemr=noemr+1 + phlista(lokph)%dendmemarr(noemr)%P1=>emrec + emrec=>emrec%nextem + enddo + phlista(lokph)%ndemr=noemr + endif +1000 continue + return + end subroutine setendmemarr + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine tabder(iph,ics,ceq) +! tabulate derivatives of phase iph with current constitution and T and P + implicit none + integer iph,ics + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + character name*24 + double precision kappa,napfu,t,p,rtg,g,v,s,h,u,f,cp,alpha + integer tnk,lokph,nsl,lokres,lokcs,ll,ll2,kk1,kk2,kk3,kk4,loksp +! + lokph=phases(iph) + nsl=phlista(lokph)%noofsubl +! calculate G and derivatives, lokres returns index of phase_varres + call calcg(iph,ics,2,lokres,ceq) + if(gx%bmperr.ne.0) then + goto 1000 + endif +! number of moles of atoms per formula unit + napfu=ceq%phase_varres(lokres)%abnorm(1) + T=ceq%tpval(1) + P=ceq%tpval(2) + rtg=globaldata%rgas*T + lokcs=lokres +! returned values: G, G.T=-S, G.P=V, G.T.T=-Cp/T G.T.P=V*alpha, G.P.P=-V*kappa +! all divided by RT and per mole formula unit of phase +! G=H-TS, F=U-TS, H=U+PV, S=-G.T, V=G.P +! H=G+TS=G-T*G.T, U=H-PV=(G-T*G.T)-P*G.P, CP=-T*G.T.T +! alpha= 1/V*V.T = G.T.P/V, kappa = -1/V*V.P = -G.P.P/V + G=rtg*ceq%phase_varres(lokcs)%gval(1,1) +! write(*,5)'tabder 2: ',rtg,G + S=-rtg*ceq%phase_varres(lokcs)%gval(2,1) + V=rtg*ceq%phase_varres(lokcs)%gval(3,1) + H=G+T*S + U=H-P*V + F=U-T*S + CP=-T*rtg*ceq%phase_varres(lokcs)%gval(4,1) + if(V.ne.zero) then + alpha=rtg*ceq%phase_varres(lokcs)%gval(5,1)/V + kappa=rtg*ceq%phase_varres(lokcs)%gval(6,1)/V + else + alpha=zero + kappa=zero + endif + write(kou,100)napfu,T,P,G +100 format(/'Per mole FORMULA UNIT of the phase, ',1pe12.4,' atoms'/& + 'at T= ',0pF8.2,' K and P= ',1PE13.6,' Pa',/ & + 'Gibbs energy J/mol ',28('.'),1Pe16.8) + write(kou,102)F,H,U,S,V,CP,alpha,kappa +102 format('Helmholtz energy J/mol ',24('.'),1PE16.8 & + /'Enthalpy J/mol ',32('.'),1PE16.8 & + /'Internal energy J/mol ',25('.'),1PE16.8 & + /'Entropy J/mol/K ',31('.'),1PE16.8 & + /'Volume m3 ',37('.'),1PE16.8 & + /'Heat capacity J/mol/K ',25('.'),1PE16.8 & + /'Thermal expansion 1/K ',25('.'),1PE16.8 & + /'Bulk modulus 1/Pa ',29('.'),1PE16.8) + tnk=phlista(lokph)%tnooffr + ll=1 + kk1=0 + kk2=phlista(lokph)%nooffr(ll) + dy1loop: do while(kk1.le.tnk) + kk1=kk1+1 + if(kk1.gt.kk2) then +! write(*,11)'tabder 2: ',kk1,kk2,ll,tnk,nsl +!11 format(a,10i3) + ll=ll+1 + if(ll.gt.nsl) exit + kk2=kk2+phlista(lokph)%nooffr(ll) + endif + if(phlista(lokph)%nooffr(ll).eq.1) then +! write(*,*)'tabder 1: ',kk1,kk2,ll,tnk + ll=ll+1 + if(ll.gt.nsl) exit + kk2=kk2+phlista(lokph)%nooffr(ll) + cycle + endif + loksp=phlista(lokph)%constitlist(kk1) + name=splista(loksp)%symbol + write(kou,110)name(1:len_trim(name)),ll +110 format('First partial derivative with respect to ',a,& + ' in sublattice ',i2,' of') + write(kou,120)rtg*ceq%phase_varres(lokcs)%dgval(1,kk1,1),& + rtg*(ceq%phase_varres(lokcs)%dgval(1,kk1,1)-& + T*ceq%phase_varres(lokcs)%dgval(2,kk1,1)),& + rtg*ceq%phase_varres(lokcs)%dgval(2,kk1,1),& + rtg*ceq%phase_varres(lokcs)%dgval(3,kk1,1) +120 format(5x,'G ',40('.'),1PE16.8, & + /5x,'H ',40('.'),1PE16.8, & + /5x,'G.T ',38('.'),1PE16.8, & + /5x,'G.P ',38('.'),1PE16.8) + kk3=kk1 + kk4=kk2 + ll2=ll + write(kou,150) +150 format(5x,'Second partial derivative of Gibbs energy with respect to also') + dy2loop: do while(kk3.le.tnk) + if(phlista(lokph)%nooffr(ll2).gt.1) then +! write(kou,160)name(1:len_trim(name)),ll2, & + write(kou,160)name,ll2, & + rtg*ceq%phase_varres(lokcs)%d2gval(ixsym(kk1,kk3),1) +160 format(10x,a,' in ',i2,5('.'),1PE16.8) + endif + kk3=kk3+1 + if(kk3.le.tnk) then + loksp=phlista(lokph)%constitlist(kk3) + name=splista(loksp)%symbol + endif + if(kk3.gt.kk4) then + ll2=ll2+1 + if(ll2.gt.nsl) exit + kk4=kk4+phlista(lokph)%nooffr(ll2) + endif + enddo dy2loop +! write(*,*)'tabder 7A: ',kk1,kk2 + enddo dy1loop +900 continue +! write(*,*)'tabder 7B: ',kk2 +! write(*,*)'tabder: ',rtg,rtg*phase_varres(lokcs)%gval(1,1) +1000 continue + return + end subroutine tabder + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine cgint(lokph,lokpty,moded,vals,dvals,d2vals,gz,ceq) +! calculates an excess parameter that can be composition dependent +! gz%yfrem are the site fractions in the end member record +! gz%yfrint are the site fractions in the interaction record(s) +! lokpty is the property index, lokph is the phase record +! moded=0 means only G, =1 G and dG/dy, =2 all + implicit none + integer moded,lokph + TYPE(gtp_property), pointer :: lokpty + TYPE(gtp_parcalc) :: gz + double precision vals(6),dvals(3,gz%nofc) + TYPE(gtp_equilibrium_data) :: ceq +!\end{verbatim} +! temporary data like gz%intlevel, gz%nofc etc + double precision d2vals(gz%nofc*(gz%nofc+1)/2),valtp(6) + double precision vv(0:2),fvv(0:2) + integer lfun,jdeg,jint,jl,ivax + double precision rtg,dx0,dx,dx1,dx2,ct,fvs,dvax0,dvax1,dvax2,yionva + double precision, parameter :: onethird=one/3.0D0,two=2.0D0 + logical ionicliq,iliqva,iliqneut +! zeroing 5 iq, and vals, dvals and d2vals + gz%iq=0 + vals=0 + dvals=0 + d2vals=0 + rtg=gz%rgast + if(lokpty%degree.eq.0) then +!---------------------------------------------------------------------- +! no composition dependence + lfun=lokpty%degreelink(0) + call eval_tpfun(lfun,gz%tpv,vals,ceq%eq_tpres) + if(gx%bmperr.ne.0) goto 1000 + if(lokpty%proptype.eq.1) then + vals=vals/rtg + endif + goto 1000 + endif +! set default variables for ionic liquid + ionicliq=.FALSE. + iliqva=.FALSE. + iliqneut=.FALSE. + yionva=zero + if(btest(phlista(lokph)%status1,PHIONLIQ)) then +! write(*,17)'3X RK: ',phlista(lokph)%i2slx(1),gz%endcon(gz%intlat(1)) +17 format(a,5i3) +! write(*,*)'ionicliq set true' +! write(*,*)'Const in subl: ',gz%intlat(1),gz%endcon(gz%intlat(1)) + ionicliq=.TRUE. + if(gz%endcon(2).eq.phlista(lokph)%i2slx(1)) then +! VA endmember in the 2nd sublattice, this is the complicated case + yionva=gz%yfrem(2) + ivax=phlista(lokph)%i2slx(1) + if(gz%intlat(1).eq.1) then +! interaction in sublattice 1 between two cations same as substituional L_A,B +! with each cation fraction multiplied with vacancy +! Also set TRUE for reciprocal interactions (gz%intlevel=2) + iliqva=.TRUE. + else +! interaction in sublattice 2 between Va and neutral (i.e. cation and neutral) +! same as substitutional L_A,B with cation fraction multiplied with vacancy + iliqneut=.TRUE. + endif + endif + endif + intlev: if(gz%intlevel.eq.1) then +!---------------------------------------------------------------------- +! plain binary Redlich Kister. gz%endcon can be wildcard, i.e. negative +! but for the moment give error message in that case +! A binary wildcard excess parameter means y_A ( 1 - y_A) * L_A* +! most naturally gz%intcon(1) would be negative + gz%iq(1)=gz%endcon(gz%intlat(1)) + gz%iq(2)=gz%intcon(1) + if(gz%iq(1).lt.0 .or. gz%iq(2).lt.0) then +! composition dependent wildcard interaction not implemented +! y(1-y) ( L0 + (2y-1) L1 + (2y-1)**2 L2 + ....) + gx%bmperr=4031; goto 1000 + endif +! endmember fraction minus interaction fraction + dx0=gz%yfrem(gz%intlat(1))-gz%yfrint(1) + if(ionicliq) then + if(iliqva) then +! interaction between cations with vacancy on second sublattice +! NOTE intraction fraction alreay multiplied with yionva!!! + dx0=gz%yfrem(gz%intlat(1))-gz%yfrint(1)/yionva + dvax0=dx0 + dx0=yionva*dx0 +! write(*,*)'Cation interaction with vacancies on 2nd: ',dvax0,dx0,& +! gz%yfrem(gz%intlat(1)),gz%yfrint(1),gz%iq(2),gz%intlat(1) + elseif(iliqneut) then +! interaction between vacancy and neutral in second sublattice + dvax0=gz%yfrem(gz%intlat(1)) + dx0=gz%yfrem(gz%intlat(1))*yionva-gz%yfrint(1) + endif + endif + vals=zero + dx=one + dx1=zero + dx2=zero + dvax2=zero + dvax1=zero +! write(*,*)'3X c1bug: ',ionicliq,iliqva,iliqneut +! special for ionic liquid: when two cation interacts with Va in second +! sublattice the vacancy fraction is raised by power 2 + RK: do jdeg=0,lokpty%degree + lfun=lokpty%degreelink(jdeg) + call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres) + if(gx%bmperr.ne.0) goto 1000 + if(lokpty%proptype.eq.1) then +! property type 1 is G and should be normalized by RT + valtp=valtp/rtg + endif + vals=vals+dx*valtp +! write(*,11)'3X dx: ',gz%iq(1),gz%iq(2),jdeg,dx0,dx,dx1 +11 format(a,3i2,6(1pe12.4)) +! no composition derivative. if moded=0 only G, =1 G+G.Y, =2 all + noder5: if(moded.gt.0) then +! first derivatives, jl=1: dG/dyA dG/dyB; jl=2: d2G/dTdy; jl=3: d3G/dPdy +! for iliqneut there should not be same -dx1 ... gz%iq(2) is neutral + do jl=1,3 + dvals(jl,gz%iq(1))=dvals(jl,gz%iq(1))+dx1*valtp(jl) + dvals(jl,gz%iq(2))=dvals(jl,gz%iq(2))-dx1*valtp(jl) + if(iliqva) then +! derivative with respect to vacancy fraction for (yc1-yc2)*yva: yc1-yc2 + dvals(jl,ivax)=dvals(jl,ivax)+dvax1*valtp(jl) +! if(jl.eq.1) write(*,11)'3X iliqva: ',0,0,ivax,dvax1 + elseif(iliqneut) then +! derivative with respect to vacancy fraction for (yc1*yva-yn): yc1 + dvals(jl,ivax)=dvals(jl,ivax)+dvax1*valtp(jl) + endif + enddo +! second derivatives, d2G/dyAdyA d2G/dyAdyB d2G/dyBdyB + if(moded.gt.1) then + d2vals(ixsym(gz%iq(1),gz%iq(1)))=& + d2vals(ixsym(gz%iq(1),gz%iq(1)))+dx2*valtp(1) + d2vals(ixsym(gz%iq(1),gz%iq(2)))=& + d2vals(ixsym(gz%iq(1),gz%iq(2)))-dx2*valtp(1) + d2vals(ixsym(gz%iq(2),gz%iq(2)))=& + d2vals(ixsym(gz%iq(2),gz%iq(2)))+dx2*valtp(1) +! if(iliqva) then +! unfinished d2G/dyvdyv d2G/dyvdyA d2G/dyvdyB +! d2vals(ixsym(ivax,ivax))=& +! d2vals(ixsym(ivax,ivax))+dvax2*valtp(1) +! elseif(iliqneut) then +! continue +! endif + endif + endif noder5 +! next power of dx + if(iliqva) then +! interaction between two cations, dx0=y_va*(y_c1 - y_c2) + dx2=(jdeg+1)*dx1 + dvax2=(jdeg+1)*dvax1 + if(jdeg.eq.0) then + dx1=yionva + dvax1=dvax0 + else + dx1=(jdeg+1)*dx1*dx0 + dvax1=(jdeg+1)*dvax1*dx0 + endif + dx=dx*dx0 +! write(*,23)'3X iliqvb: ',jdeg,dx,dx1,dx2,dvax0,dvax1,dvax2 +23 format(a,i2,6(1pe12.4)) + elseif(iliqneut) then +! interaction between Va and neutral a bit more complicated ... NOT TESTED + dx2=(jdeg+1)*dx1 + dvax2=(jdeg+1)*dvax1 + if(jdeg.eq.0) then + dx1=yionva + dvax1=dvax0 + else + dx1=(jdeg+1)*dx1*dx0 + dvax1=(jdeg+1)*dvax1*dx0 + endif + dx=dx*dx0 + else +! normal CEF model + dx2=(jdeg+1)*dx1 + dx1=(jdeg+1)*dx + dx=dx*dx0 + endif + enddo RK + elseif(gz%intlevel.eq.2) then !intlev +!---------------------------------------------------------------------- +! important to set ivax=0 here as tested below if not zero + ivax=0 + if(ionicliq) then +! write(*,*)'Comp.dep ternary ionic liquid parameter',iliqva + if(iliqva) then + if(gz%intlat(1).eq.1 .and. gz%intlat(2).eq.1) then +! we have 3 cations interacting in first sublattice and Va in second +! require treatment of extra vacancy fraction + write(*,*)'3 interacting cations not implemented' + gx%bmperr=7777; goto 1000 + elseif(gz%intlat(1).eq.1 .and. gz%intlat(2).eq.2) then +! we have 2 cations interacting in 1st sublattice and Va and neutral in 2nd +! require treatment of extra vacancy fraction +! write(*,*)'Reciprocal with neutrals not implemented' +! gx%bmperr=7777; goto 1000 +! yionva set above! + ivax=gz%endcon(2) + endif + elseif(gz%intcon(2).eq.phlista(lokph)%i2slx(1)) then +! vacancy is the intarction constituent + ivax=gz%intcon(2) + yionva=gz%yfrint(2) + endif +! other ternary parameters in ionic liquid OK, no extra vacancy fraction + endif +!................................................................ +! ternary composition dependent interaction + ternary: if(gz%intlat(1).eq.gz%intlat(2)) then +! Ternary composition dependent interaction in same sublattice, Hillert form. +! The idea is that the sum of vv is always unity even in higher order systems +! whereas the sum of the constituent frations are not +! If wildcard then any of the gz%iq would be negative, not allowed + gz%iq(1)=gz%endcon(gz%intlat(1)) + gz%iq(2)=gz%intcon(1) + gz%iq(3)=gz%intcon(2) + if(gz%iq(1).lt.0 .or. gz%iq(2).lt.0 .or. gz%iq(3).lt.0) then + gx%bmperr=4031; goto 1000 + endif + vv(0)=gz%yfrem(gz%intlat(1)) + vv(1)=gz%yfrint(1) + vv(2)=gz%yfrint(2) + ct=(one-vv(0)-vv(1)-vv(2))*onethird + vv=vv+ct + fvv(0)=two*onethird + fvv(1)=-onethird + fvv(2)=-onethird + terloop: do jint=0,2 +! calculate parameter + lfun=lokpty%degreelink(jint) + call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres) + if(lokpty%proptype.eq.1) then + valtp=valtp/rtg + endif +! function value + vals=vals+vv(jint)*valtp + noder6: if(moded.gt.0) then +! first derivatives + do jl=1,3 + dvals(jl,gz%iq(1))=dvals(jl,gz%iq(1))+fvv(0)*valtp(jl) + dvals(jl,gz%iq(2))=dvals(jl,gz%iq(2))+fvv(1)*valtp(jl) + dvals(jl,gz%iq(3))=dvals(jl,gz%iq(3))+fvv(2)*valtp(jl) + enddo +! there is no contribution to the second derivatives from this interaction + endif noder6 + fvs=fvv(2) + fvv(2)=fvv(1) + fvv(1)=fvv(0) + fvv(0)=fvs + enddo terloop + else +!......................................................... +! composition dependent reciprocal interactions here only degree 1 and 2 + if(lokpty%degree.gt.2) then + write(*,*)'Composition dependent reciprocal degree max 2' + gx%bmperr=4078; goto 1000 + else +! write(*,32)lokph,lokpty%degree,gz%intlat(1),gz%intlat(2),& +! gz%iq(1),gz%iq(2),gz%iq(3),gz%iq(4) +32 format('Comp.dep. rec. param: ',i3,2x,i1,2x,2i2,4i5) + endif +! Note the composition dependence is defined that +! L = y'_Ay'_By"_y"_D (0L + (y"_C-y"_D)*1L + (y'_A-y'_D)*2L) +! it is a bit strange that 2nd sublattice is 1L ... but that is the definition + gz%iq(1)=gz%endcon(1) + gz%iq(2)=gz%intcon(1) + gz%iq(3)=gz%endcon(2) + gz%iq(4)=gz%intcon(2) +! degree 0 not composition dependent, vals multiplied with pyq after return + lfun=lokpty%degreelink(0) + if(lfun.gt.0) then + call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres) + if(gx%bmperr.ne.0) goto 1000 + if(lokpty%proptype.eq.1) then + valtp=valtp/rtg + endif + vals=vals+valtp + endif +! lokpty%degree must be 1 or 2 otherwise we would not be here + lfun=lokpty%degreelink(1) + recip1: if(lfun.gt.0) then +! degree 2 can be empty, otherwise multiplied with gz%iq(3)-gz%iq(4) +! no problem with ionic liquid except there may be values in dvals + call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres) + if(gx%bmperr.ne.0) goto 1000 + if(lokpty%proptype.eq.1) then + valtp=valtp/rtg + endif + vals=vals+(gz%yfrem(gz%intlat(2))-gz%yfrint(2))*valtp +! one dvals(*,ivax) could have been assigned a value above (for ionic liquid) + do jl=1,3 + dvals(jl,gz%iq(3))=dvals(jl,gz%iq(3))+valtp(jl) + dvals(jl,gz%iq(4))=dvals(jl,gz%iq(4))-valtp(jl) + enddo + endif recip1 +! degree 2 can be empty, otherwise multiplied with y(gz%iq(1))-y(gz%iq(2)) + recip2: if(lokpty%degree.gt.1) then + lfun=lokpty%degreelink(2) + if(lfun.gt.0) then + call eval_tpfun(lfun,gz%tpv,valtp,ceq%eq_tpres) + if(gx%bmperr.ne.0) goto 1000 + if(lokpty%proptype.eq.1) then + valtp=valtp/rtg + endif + if(ivax.gt.0) then +! write(*,67)ivax,gz%iq(1),gz%iq(2),gz%iq(3),gz%iq(4),yionva +!67 format('3X ion liq recip: ',i3,2x,4i3,1pe12.4) +! interaction in ionic liquid with vacancy as one constituent in 2nd subl. + vals=vals+yionva*(gz%yfrem(gz%intlat(1))-gz%yfrint(1))*valtp + do jl=1,3 + dvals(jl,gz%iq(1))=+yionva*valtp(jl) + dvals(jl,gz%iq(2))=-yionva*valtp(jl) + enddo +! we have to take into account extra derivatives wrt vacancies if vacancy +! is a constituent in second sublattice + do jl=1,3 + dvals(jl,ivax)=& + (gz%yfrem(gz%intlat(1))-gz%yfrint(1))*valtp(jl) + enddo + else +! not ionic liquid .... puuuh + vals=vals+(gz%yfrem(gz%intlat(1))-gz%yfrint(1))*valtp + do jl=1,3 + dvals(jl,gz%iq(1))=+valtp(jl) + dvals(jl,gz%iq(2))=-valtp(jl) + enddo + endif + endif + endif recip2 + endif ternary +!---------------------------------------------------------------------- + elseif(gz%intlevel.ge.3) then !intlev +! higher interaction levels have no composition dependence + write(*,999) +999 format('Composition dependence for parameters with >2 interacting ',& + 'constituents'/'not implemented!') + gx%bmperr=4078; goto 1000 + endif intlev +!---------------------------------------------------------------------- +! finished finally .... +1000 continue + return + end subroutine cgint + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine config_entropy(moded,nsl,nkl,phvar,tval) +! calculates configurational entropy/R for phase lokph + implicit none + integer moded,nsl + integer, dimension(nsl) :: nkl + TYPE(gtp_phase_varres), pointer :: phvar +!\end{verbatim} + integer ll,kk,kall,nk,jl + double precision tval,ss,yfra,ylog + ll=0 + kall=0 + sublatticeloop: do while (ll.lt.nsl) + ll=ll+1 + nk=nkl(ll) + kk=0 + ss=zero + fractionloop: do while (kk.lt.nk) + kk=kk+1 + kall=kall+1 + if(nk.eq.1) cycle sublatticeloop + yfra=phvar%yfr(kall) + if(yfra.lt.bmpymin) yfra=bmpymin + if(yfra.gt.one) yfra=one + ylog=log(yfra) +! gval(1:6,1) are G and derivator wrt T and P +! dgval(1,1:N,1) are derivatives of G wrt fraction 1:N +! dgval(2,1:N,1) are derivatives of G wrt fraction 1:N and T +! dgval(3,1:N,1) are derivatives of G wrt fraction 1:N and P +! d2dval(ixsym(N*(N+1)/2),1) are derivatives of G wrt fractions N and M +! this is a symmetric matrix and index givem by ixsym(M,N) + ss=ss+yfra*ylog + if(moded.gt.0) then + phvar%dgval(1,kall,1)=phvar%sites(ll)*(one+ylog) + phvar%d2gval(ixsym(kall,kall),1)=phvar%sites(ll)/yfra + endif + enddo fractionloop + phvar%gval(1,1)=phvar%gval(1,1)+phvar%sites(ll)*ss + enddo sublatticeloop +! set temperature derivative of G and dG/dy + phvar%gval(2,1)=phvar%gval(1,1)/tval + if(moded.gt.0) then + do jl=1,kall + phvar%dgval(2,jl,1)=phvar%dgval(1,jl,1)/tval + enddo + endif +1000 continue + return + end subroutine config_entropy + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine config_entropy_i2sl(moded,nsl,nkl,phvar,i2slx,tval) +! calculates configurational entropy/R for ionic liquid model +! Always 2 sublattices, the sites depend on composition +! P = \sum_j (-v_j) y_j + Q y_Va +! Q = \sum_i v_i y_i +! where v is the charge on the ions. P and Q calculated by set_constitution + implicit none + integer moded,nsl,i2slx(2) + integer, dimension(nsl) :: nkl + TYPE(gtp_phase_varres), pointer :: phvar +!\end{verbatim} + integer ll,kk,kall,nk,j1,j2 + double precision tval,ss,yfra,ylog,yva,spart(2) + ll=0 + kall=0 + spart=zero + yva=zero + sublatticeloop: do while (ll.lt.nsl) + ll=ll+1 + nk=nkl(ll) + kk=0 + ss=zero + fractionloop: do while (kk.lt.nk) + kk=kk+1 + kall=kall+1 +! no cycle as we may need values of spart and yva ... +! if(nk.eq.1) cycle sublatticeloop + yfra=phvar%yfr(kall) + if(yfra.lt.bmpymin) yfra=bmpymin + if(yfra.gt.one) yfra=one +! save current value of vacancy fraction + if(kall.eq.i2slx(1)) yva=yfra +! write(*,2)'yva: ',kall,i2slx(1),yva,yfra +!2 format(a,2i3,6(1pe12.4)) + ylog=log(yfra) +! gval(1:6,1) are G and derivator wrt T and P +! dgval(1,1:N,1) are derivatives of G wrt fraction 1:N +! dgval(2,1:N,1) are derivatives of G wrt fraction 1:N and T +! dgval(3,1:N,1) are derivatives of G wrt fraction 1:N and P +! d2dval(ixsym(N*(N+1)/2),1) are derivatives of G wrt fractions N and M +! this is a symmetric matrix and index givem by ixsym(M,N) + ss=ss+yfra*ylog + if(moded.gt.0) then + phvar%dgval(1,kall,1)=phvar%sites(ll)*(one+ylog) + phvar%d2gval(ixsym(kall,kall),1)=phvar%sites(ll)/yfra + endif + enddo fractionloop + phvar%gval(1,1)=phvar%gval(1,1)+phvar%sites(ll)*ss + if(ll.eq.1) then + spart(1)=ss + else + spart(2)=ss + endif + enddo sublatticeloop + if(moded.eq.0) goto 900 +! convergence problem with ionic liquid, skip contribution to 2nd derivatuves +! localmoded=moded +! if(moded.eq.2) localmoded=1 +! write(*,*)'ionic config_entropy: ',i2slx,kall +! additional derivatives as sublattice sites depend on composition +! -------------------------- derivatives of config entropy +! S = P*S1 + Q*S2 +! S1 = \sum_i y_i*ln(y_i) +! S2 = \sum_j y_j*ln(y_j)+y_Va*ln(y_Va)+\sum_k y_k*ln(Y_k)) +! P = \sum_j (-v_j)*y_j + Q*y_Va +! Q = \sum_i v_i*y_i +! term within [...] already calculated as part of normal config.entropy +! dS/dy_i = +v_i*S2 + v_i*y_Va*S1 + [P*(1+ln(y_i)] ..cation OK +! dS/dy_j = -v_j*S1 + [Q*(1+ln(y_j))] ..anion OK +! dS/dy_Va = Q*S1 + [Q*(1+ln(y_Va))] ..Va OK +! dS/dy_k = [Q*(1+ln(y_k)] ..neutral OK +! d2S/dy_i1dy_i2 = v_i1*y_Va*(1+ln(y_i2) + v_i2*y_Va*(1+ln(y_i1) + +! [P*(1/y_i1**2)] ..last term zero unless i1=i2 OK +! d2S/dy_idy_j = v_i*(1+ln(y_j)) + (-v_j)*(1+ln(y_i)) OK +! d2S/dy_idy_Va = v_i*(1+ln(y_Va)) + v_i*S1 + Q*(1+ln(y_i)) OK +! d2S/dy_idy_k = v_i*(1+ln(y_k)) OK +! d2S/dy_j1d_j2 = [only Q/y**2 if j1=j2] OK +! d2S/dy_jdy_Va = zero OK +! d2S/dy_jdy_k = zero OK +! d2S/dy_Va2 = [only Q/y_Va**2] OK +! d2S/dy_Vady_k = zero OK +! d2S/dy_k1dy_k2 = [only Q/y_k1**2 if k1=k2] OK +! ---------------------- +! the coding is not optimal for speed, all the 1/y**2 term calculated above +! i2slx(1) is index of vacancy, i2slx(2) is index of first neutral +! if either (or both) are missing their index is higher than last constituent +! write(*,102)'va+neutral: ',i2slx +!102 format(a,10i3) +! dpqdy is calculated in gtp3X: set_constitution ?? +! write(*,108)'3X dpqdy: ',(phvar%dpqdy(j1),j1=1,nkl(1)+nkl(2)) +108 format(a,10F7.3) + cation: do j1=1,nkl(1) +! this was an attempt to improve convergence ... it did but not enough +! if(localmoded.eq.1) goto 109 + cation2: do j2=j1,nkl(1) +! d2S/dy_i1dy_i2 = v_i1*y_Va*(1+ln(y_i2) + v_i2*y_Va*(1+ln(y_i1) + +! [P*(1/y_i1**2)] ..last term already calculated OK +! write(*,103)'ij: ',j1,j2,ixsym(j1,j2),yva,& +! phvar%d2gval(ixsym(j1,j2),1),& +! phvar%dpqdy(j1),phvar%dpqdy(j2),& +! phvar%dgval(1,j1,1),phvar%dgval(1,j2,1) +!103 format(a,3i3,6(1pe11.3)) + phvar%d2gval(ixsym(j1,j2),1)=phvar%d2gval(ixsym(j1,j2),1)+& + (phvar%dpqdy(j1)*phvar%dgval(1,j2,1)+& + phvar%dpqdy(j2)*phvar%dgval(1,j1,1))*yva/phvar%sites(1) + enddo cation2 + anion2: do kk=1,nkl(2) + j2=nkl(1)+kk + if(j2.lt.min(i2slx(1),i2slx(2))) then +! d2S/dy_idy_j = v_i*(1+ln(y_j)) + (-v_j)*(1+ln(y_i)) ...cation+anion OK + phvar%d2gval(ixsym(j1,j2),1)=& + phvar%dpqdy(j1)*phvar%dgval(1,j2,1)/phvar%sites(2)+& + phvar%dpqdy(j2)*phvar%dgval(1,j1,1)/phvar%sites(1) + elseif(j2.eq.i2slx(1)) then +! d2S/dy_idy_Va = v_i*(1+ln(y_Va)) + v_i*S1 + Q*(1+ln(y_i)) ...cation+Va OK + phvar%d2gval(ixsym(j1,j2),1)=& + phvar%dpqdy(j1)*phvar%dgval(1,j2,1)/phvar%sites(2)+& + phvar%dpqdy(j1)*spart(1)+& + phvar%sites(2)*phvar%dgval(1,j1,1)/phvar%sites(1) + else +! d2S/dy_idy_k = v_i*(1+ln(y_k)) ...cation+neutral OK +! write(*,107)'i,va: ',j1,j2,phvar%dpqdy(j1),phvar%dgval(1,j2,1),& +! phvar%sites(2) +!107 format(a,2i2,6(1pe12.4)) + phvar%d2gval(ixsym(j1,j2),1)=& + phvar%dpqdy(j1)*phvar%dgval(1,j2,1)/phvar%sites(2) + endif + enddo anion2 +109 continue +! this done at the end as original dgval(1,j1,1)=P*(1+ln(y_j1))/P used above +! dS/dy_i = +v_i*S2 + v_i*y_Va*S1 + [P*(1+ln(y_i)] ..cation OK +! write(*,19)'c: ',j1,phvar%dgval(1,j1,1),& +! phvar%dpqdy(j1),spart(2),phvar%dpqdy(j1),yva,spart(1) +!19 format(a,i3,6(1pe12.4)) + phvar%dgval(1,j1,1)=phvar%dgval(1,j1,1)+& + phvar%dpqdy(j1)*spart(2)+phvar%dpqdy(j1)*yva*spart(1) + enddo cation +! this done separately as original dgval(1,j2,1)=Q*(1+ln(y_j2))/Q used above +! kall here should be total number of constituents + anion1: do j2=nkl(1)+1,min(i2slx(1),kall) + if(j2.lt.min(i2slx(1),i2slx(2))) then +! dS/dy_j = -v_j*S1 + [Q*(1+ln(y_j))] ..anion OK +! write(*,*)'anion1 A: ',j2 + phvar%dgval(1,j2,1)=phvar%dgval(1,j2,1)+phvar%dpqdy(j2)*spart(1) + elseif(j2.eq.i2slx(1)) then +! dS/dy_Va = Q*S1 + [Q*(1+ln(y_Va))] ..Va OK +! write(*,*)'anion1 B: ',j2 + phvar%dgval(1,j2,1)=phvar%dgval(1,j2,1)+phvar%sites(2)*spart(1) +! else +! dS/dy_k = nothing + [Q*(1+ln(y_k)] ..neutral OK + endif +! write(*,*)'anion1 C: ',j2 + enddo anion1 +! set temperature derivative of dG/dy + do j1=1,kall + phvar%dgval(2,j1,1)=phvar%dgval(1,j1,1)/tval + enddo +900 continue +! phvar%gval(1,1)=phvar%gval(1,1)+phvar%sites(ll)*ss +! write(*,905)'parts: ',phvar%gval(1,1),phvar%sites,spart +!905 format(a,6(1pe12.4)) +! set temperature derivative of G + phvar%gval(2,1)=phvar%gval(1,1)/tval +1000 continue + return + end subroutine config_entropy_i2sl + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine push_pyval(pystack,intrec,pmq,pyq,dpyq,d2pyq,moded,iz) +! push data when entering an interaction record + implicit none + integer pmq,moded,iz + double precision pyq,dpyq(iz),d2pyq(iz*(iz+1)/2) + type(gtp_pystack), pointer :: pystack + type(gtp_interaction), pointer :: intrec +!\end{verbatim} %+ + type(gtp_pystack), pointer :: new +! + if(associated(pystack)) then + allocate(new) + new%previous=>pystack + pystack=>new + else + allocate(pystack) + nullify(pystack%previous) + endif +! save data + pystack%intrecsave=>intrec + pystack%pmqsave=pmq + pystack%pysave=pyq + if(moded.ge.1) then +! if moded 0 there are no derivatives + allocate(pystack%dpysave(iz)) + pystack%dpysave=dpyq + if(moded.eq.2) then +! if moded 1 there are no second derivatives + allocate(pystack%d2pysave(iz*(iz+1)/2)) + pystack%d2pysave=d2pyq + endif + endif +1000 continue + return + end subroutine push_pyval + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine pop_pyval(pystack,intrec,pmq,pyq,dpyq,d2pyq,moded,iz) +! pop data when entering an interaction record + implicit none + integer iz,pmq,moded + double precision pyq,dpyq(iz),d2pyq(iz*(iz+1)/2) + type(gtp_pystack), pointer :: pystack + type(gtp_interaction), pointer :: intrec +!\end{verbatim} + type(gtp_pystack), pointer :: old + if(.not.associated(pystack)) then +! write(*,*)'Tying to pop from an empty PY stack' + gx%bmperr=4075; goto 1000 + endif +! restore data + intrec=>pystack%intrecsave + pmq=pystack%pmqsave + pyq=pystack%pysave + if(moded.ge.1) then +! if moded >0 there are derivatives + dpyq=pystack%dpysave + if(moded.eq.2) then +! if moded 2 there are second derivatives + d2pyq=pystack%d2pysave + endif + endif +! release memory + old=>pystack + pystack=>pystack%previous + deallocate(old) +1000 continue + return + end subroutine pop_pyval + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine calc_disfrac(lokph,lokcs,ceq) +! calculate and set disordered set of fractions from sitefractions +! The first derivatives are dxidyj. There are no second derivatives +! TYPE(gtp_fraction_set), pointer :: disrec + implicit none + integer lokph,lokcs + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + TYPE(gtp_fraction_set), pointer :: disrec + TYPE(gtp_phase_varres), pointer :: phord + TYPE(gtp_phase_varres), pointer :: phdis + logical ordered +! minimum difference in site fraction to be set as ordered + double precision, parameter :: yminord=1.0D-10 + integer lokdis,is +! +! write(*,*)'entering calc_disfrac' +! disrec=phord%disfra +! lokdis=disrec%varreslink +! phdis=>disrec%phdapointer +! this is the record with the ordered constitution + phord=>ceq%phase_varres(lokcs) +! this is a record within the ordered constitution record for disordered fracs + disrec=>phord%disfra +! to find the varres record with disordered fractions use varreslink +! this is the index to the phase_varres record with the ordered fractions ??? + lokdis=disrec%varreslink + phdis=>ceq%phase_varres(lokdis) +! write(*,*)'calc_disfrac 1A' +! check that some values are accessable +! write(*,*)'calc_disfra phase index: ',phord%phlink +! write(*,*)'calc_disfra disordered sublattices: ',disrec%ndd +! write(*,*)'calc_disfra ordered and disordered records: ',lokcs,lokdis +! write(*,*)'calc_disfra phase index via disordred record: ',phdis%phlink +! write(*,*)'calc_disfrac 1B' + phdis%yfr=zero +! write(*,*)'disfrac 1: ',disrec%tnoofyfr + do is=1,disrec%tnoofyfr + phdis%yfr(disrec%y2x(is))=& + phdis%yfr(disrec%y2x(is))+disrec%dxidyj(is)*phord%yfr(is) +! write(*,77)'disfrac 2: ',is,disrec%y2x(is),phdis%yfr(disrec%y2x(is)),& +! disrec%dxidyj(is),phord%yfr(is) +77 format(a,2i3,3(1pe12.4)) + enddo +! write(*,*)'calc_disfrac 2' +! check if phase is really ordered, meaning that the disordered fractions +! are equal to the ordered ones + ordered=.false. + do is=1,disrec%tnoofyfr + if(abs(phdis%yfr(disrec%y2x(is))-& + phord%yfr(is)).gt.yminord) ordered=.true. + enddo +! write(*,*)'calc_disfrac 3' + if(.not.ordered) then +! if this bit set one will not calculate the ordered part of the phase + phord%status2=ibclr(phord%status2,csorder) +! write(*,*)'calc_disfrac: disordered, clear ordered bit',lokph + else +! bit must be cleared as it might have been set at previous call + phord%status2=ibset(phord%status2,csorder) +! write(*,*)'calc_disfrac: ordered, set ordered bit',lokph + endif +! write(*,*)'calc_disfrac 4' +! copy these to the phase_varres record that belongs to this fraction set +! a derivative dGD/dyj = sum_i dGD/dxi * dxidyj +! where dGD/dxi is dgval(1,y2x(j),1) and dxidyj is disrec%dxidyj(j) +! because each y constituent contributes to only one disordered x fraction +1000 continue + return +! G(tot) = GD(xdis)+(GO(yord)-GO(yord=xdis)) +! G(tot).yj = dGD(xdis).dxi*dxdyj + GO.yj - GO.yj ... + end subroutine calc_disfrac + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine disordery(phvar,ceq) +! sets the ordered site fractions in FCC and other order/disordered phases +! equal to their disordered value in order to calculate and subtract this part +! phvar is index to phase_varres for ordered fractions + implicit none + TYPE(gtp_phase_varres), pointer :: phvar + TYPE(gtp_equilibrium_data) :: ceq +!\end{verbatim} + TYPE(gtp_fraction_set), pointer :: disrec + TYPE(gtp_phase_varres) :: phdis + integer lokdcs,kk,ll,is,nis,nsl +! find disordered fractions + lokdcs=phvar%disfra%varreslink + disrec=>phvar%disfra +! write(*,*)'disordery: ',disrec%latd,disrec%nooffr(1),lokdcs + phdis=ceq%phase_varres(lokdcs) +! write(*,*)'disordery: ',ceq%xconv +! write(*,*)'disordery: ',phdis%yfr(1) +! phdis=>ceq%disrec%phdapointer +! copy fractions, loop through all ordered sublattices in phvar +! and store fraction from lokdis + kk=0 +! here copy: +! y(ord,1,1)=y(dis,1); y(ord,1,2)=y(dis,2); y(ord,1,3)=y(dis,3); +! y(ord,2,1)=y(dis,1); y(ord,2,2)=y(dis,2); y(ord,2,3)=y(dis,3); + do ll=1,disrec%latd + do is=1,disrec%nooffr(1) + kk=kk+1 + phvar%yfr(kk)=phdis%yfr(is) + enddo + enddo + if(disrec%ndd.eq.2) then +! one can have 2 sets of ordered subl. like (Al,Fe)(Al,Fe)...(C,Va)(C,Va)... + nis=disrec%nooffr(1) + nsl=size(phvar%sites) +! write(*,*)'dy: ',nis,kk,disrec%latd,nsl,disrec%nooffr(2) + do ll=disrec%latd+1,nsl + do is=1,disrec%nooffr(2) + kk=kk+1 + phvar%yfr(kk)=phdis%yfr(nis+is) + enddo + enddo + endif +1000 continue + return + end subroutine disordery + +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine set_driving_force(iph,ics,dgm,ceq) +! set the driving force of a phase explicitly + implicit none + type(gtp_equilibrium_data), pointer :: ceq + integer iph,ics + double precision dgm +!\end{verbatim} + integer lokph,lokcs + call get_phase_compset(iph,ics,lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 + ceq%phase_varres(lokcs)%dgm=dgm +1000 continue + return + end subroutine set_driving_force + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine extract_massbalcond(tpval,xknown,antot,ceq) +! extract T, P, mol fractions of all components and total number of moles +! for use when minimizing G for a closed system. Probably redundant + implicit none + double precision, dimension(*) :: tpval,xknown + double precision antot + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer, dimension(4) :: indices + double precision, dimension(maxel) :: ani,abi,xset,wset + double precision mass,h298,s298,xxx,xsum,wsum + double precision sumwdivm,anisum,abisum,restmass,divisor,dividend,abtot + TYPE(gtp_condition), pointer :: current,last + character encoded*16,actual_arg(1)*16,elsym*2,elname*16,refstat*16 + integer nox,now,nc,jl,iref,iunit,ip,idf,ie,more,numberest,istv + logical allmassbal +! + ani=zero; abi=zero; xset=zero; wset=zero + antot=zero; abtot=zero + xsum=zero; wsum=zero + anisum=zero; abisum=zero + nox=0; now=0 +! +! write(*,*)"in extract massbalace 1" + last=>ceq%lastcondition + if(.not.associated(last)) then + gx%bmperr=4143; goto 1000 + endif +! write(*,*)"in extract massbalace 2" + current=>last + nc=0 + allmassbal=.TRUE. +100 continue + current=>current%next +! ignore inactive conditions + if(current%active.ne.0) goto 300 +! ignore conditions with several terms + if(current%noofterms.gt.1) goto 300 +! for debugging + istv=current%statev + do jl=1,4 + indices(jl)=current%indices(jl,1) + enddo + iref=current%iref + iunit=current%iunit + ip=1 + encoded=' ' + actual_arg=' ' + if(current%symlink1.gt.0) then +! the value is a symbol, the node to the expression is in +! svflista(current%symlink1)%linkpnode +! NOTE THIS IS NOT THE SAME AS meq_evaluate_svfun but OK as no derivative +! xxx=meq_evaluate_svfun(current%symlink1,actual_arg,1,ceq) + xxx=evaluate_svfun_old(current%symlink1,actual_arg,1,ceq) + else + xxx=current%prescribed + endif +! write(*,17)'massbal: ',encoded,istv,indices,iunit,iref,xxx +17 format(a,2x,a,2x,i3,2x,4i3,2x,2i3,1PE15.7) +! extract values of T, P, N, B, X and W + if(current%statev.eq.1) then +! this is the temperature + tpval(1)=xxx + nc=nc+1 + elseif(current%statev.eq.2) then +! this is the pressure + tpval(2)=xxx + nc=nc+1 + elseif(current%statev.eq.110) then +! this is N=value or N(element)=value + if(indices(2).gt.0) then +! this should mean the number of moles of a component in a phase, illegal here +! write(*,*)'N with 2 indices illegal in this case' + gx%bmperr=4179; goto 1000 + elseif(indices(1).gt.0) then +! N(i)=xxx + ani(indices(1))=xxx + anisum=anisum+xxx + else +! N=xxx + antot=xxx + endif + nc=nc+1 + elseif(current%statev.eq.111) then +! this is X(index1)=value, CHECK UNIT if %!!! + if(iunit.eq.100) xxx=1.0D-2*xxx + xset(current%indices(1,1))=xxx + xsum=xsum+xxx + nc=nc+1 + nox=nox+1 + elseif(current%statev.eq.120) then +! this is B=value or B(i)=value + if(indices(2).gt.0) then +! this should mean the mass of a component in a phase, illegal here + write(*,*)'B with 2 indices illegal' + gx%bmperr=4179; goto 1000 + elseif(indices(1).gt.0) then +! B(i)=xxx + abi(indices(1))=xxx + abisum=abisum+xxx + else +! B=xxx + abtot=xxx + endif + nc=nc+1 + elseif(current%statev.eq.122) then +! this is W(index1)=value, CHECK UNIT if %!!! + if(iunit.eq.100) xxx=1.0D-2*xxx + wset(current%indices(1,1))=xxx + wsum=wsum+xxx + nc=nc+1 + now=now+1 + else +! this is not a massbalance condition but continue just to check how many cond + allmassbal=.FALSE. + nc=nc+1 + endif +! take next condition if we have not done all +300 continue + if(ocv()) write(*,310)'3X massbal: ',current%prescribed,last%prescribed +310 format(a,6(1pe12.4)) + if(.not.associated(current,last)) goto 100 +!-------------------------------------- +! check if correct number of conditions found +500 continue + idf=noofel+2-nc + if(idf.ne.0) then +! if idf is not zero there are not enough conditions + gx%bmperr=4144; goto 1000 + elseif(.not.allmassbal) then +! some conditions are not massbalance + gx%bmperr=4151; goto 1000 + endif +! we have extracted all conditions N, B, X, W +! check that only one value per component + do ie=1,noel() + if(xset(ie).gt.zero) then + if(wset(ie).gt.zero) goto 1100 + if(ani(ie).gt.zero) goto 1100 + if(abi(ie).gt.zero) goto 1100 + elseif(wset(ie).gt.zero) then + if(ani(ie).gt.zero) goto 1100 + if(abi(ie).gt.zero) goto 1100 + elseif(ani(ie).gt.zero) then + if(abi(ie).gt.zero) goto 1100 + elseif(abi(ie).le.zero) then +! this can be "the rest" + if(antot.eq.zero .and. abtot.eq.zero) goto 1105 + endif + enddo +! write(*,510)'N: ',(ani(i),i=1,noel()) +! write(*,510)'B: ',(abi(i),i=1,noel()) +! write(*,510)'x: ',(xset(i),i=1,noel()) +! write(*,510)'w: ',(wset(i),i=1,noel()) +510 format(a,7F9.6) + bigif: if(antot.gt.zero) then +! we have a value for total number of moles, N, there must not be one for B + if(abtot.ne.zero) goto 1110 + more=0 + numberest=0 + sumwdivm=zero +! convert as much as possible to N(i). Sum also some data needed if there +! are conditions on mass fractions + do ie=1,noel() + call get_element_data(ie,elsym,elname,refstat,mass,h298,s298) + if(xset(ie).gt.zero) then + ani(ie)=antot*xset(ie) + anisum=anisum+ani(ie) + abisum=abisum+mass*ani(ie) + elseif(abi(ie).gt.zero) then + ani(ie)=abi(ie)/mass + anisum=anisum+ani(ie) + abisum=abisum+mass*ani(ie) + elseif(wset(ie).gt.zero) then + sumwdivm=sumwdivm+wset(ie)/mass + more=1 + elseif(ani(ie).eq.zero) then + if(numberest.gt.0) then + write(*,*)'Missing condition for two elements.' + gx%bmperr=0; goto 1000 + endif + restmass=mass + numberest=ie + endif + enddo + if(numberest.eq.0) then + write(*,*)'Error - condition on all elements and N??' + gx%bmperr=0; goto 1000 + endif + if(more.gt.0) then +! there are some mass fractions, we have to calculate B +! but first we must determine the number of moles of "the rest" element + divisor=antot-anisum-abisum/(one-wsum)*sumwdivm + dividend=one+restmass/(one-wsum)*sumwdivm + ani(numberest)=divisor/dividend + abi(numberest)=restmass*ani(numberest) + abisum=abisum+abi(numberest) +! now calculate B + abtot=abisum/(one-wsum) +! write(*,520)'nrest: ',numberest,divisor,dividend,ani(numberest),& +! abi(numberest),abtot +520 format(a,i3,6(1pe12.4)) +! now calculate moles of elements with massfractions + do ie=1,noel() + if(wset(ie).gt.zero) then + abi(ie)=abtot*wset(ie) + call get_element_data(ie,elsym,elname,refstat,mass,h298,s298) + ani(ie)=abi(ie)/mass + endif + enddo + else +! all conditions are mole fractions, just set "the rest" + ani(numberest)=antot-anisum + endif + do ie=1,noel() + xset(ie)=ani(ie)/antot + enddo + elseif(abtot.gt.zero) then +! we have a value for total mass, B, not common and too complicated +! write(*,*)'Cannot handle condition on total mass' + gx%bmperr=4180 + elseif(xsum.eq.zero .and. wsum.eq.zero) then +! just N(i)= and B(i)=, no N= nor B= and no X nor W, No rest element +! write(*,520)'N(i): ',0,anisum,(ani(j),j=1,noel()) + do ie=1,noel() + if(abi(ie).gt.zero) then + call get_element_data(ie,elsym,elname,refstat,mass,h298,s298) + ani(ie)=abi(ie)/mass + anisum=anisum+ani(ie) + endif + enddo + antot=anisum + do ie=1,noel() + xset(ie)=ani(ie)/antot + if(xset(ie).le.zero) then + write(*,*)'mass balance error: ',ie + gx%bmperr=4181; goto 1000 + endif + enddo + else +! any other combination of conditions .... + write(*,*)'Cannot handle these massbalance conditions' + gx%bmperr=4182 + endif bigif +! copy fractions to arguments +900 continue + do ie=1,noel() + xknown(ie)=xset(ie) + enddo +1000 continue + return +! errors +1100 continue + write(*,*)'Two mass balance conditions for same element',ie + gx%bmperr=4183; goto 1000 +1105 continue + write(*,*)'One component without condition' + gx%bmperr=4181; goto 1000 +1110 continue + write(*,*)'Both N and B cannot be set' + gx%bmperr=4184; goto 1000 +! + end subroutine extract_massbalcond + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine save_constitutions(ceq,copyofconst) +! copy the current phase amounts and constituitions to be restored +! if calculations fails during step/map +! DANGEROUS IF NEW COMPOSITION SETS CREATED + implicit none + TYPE(gtp_equilibrium_data), pointer :: ceq + double precision, allocatable, dimension(:) :: copyofconst +!\end{verbatim} %+ + integer varresx,nz,ij,syfr +! calculate dimension of copyofconst + nz=0 +! skippa varres with index 1, that is the reference phase + do varresx=2,csfree-1 + syfr=size(ceq%phase_varres(varresx)%yfr) + nz=nz+1+syfr + enddo + allocate(copyofconst(nz)) + nz=1 + do varresx=2,csfree-1 +! save 1+sfr values for each composition set + copyofconst(nz)=ceq%phase_varres(varresx)%amfu + syfr=size(ceq%phase_varres(varresx)%yfr) + do ij=1,syfr + copyofconst(nz+ij)=ceq%phase_varres(varresx)%yfr(ij) + enddo +! write(*,17)varresx,nz,syfr,(copyofconst(ij),ij=nz,nz+syfr) +17 format('3Xs:',i2,2i3,6(1pe12.4)) + nz=nz+1+syfr + enddo +1000 continue + return + end subroutine save_constitutions + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} %- + subroutine restore_constitutions(ceq,copyofconst) +! restore the phase amounts and constituitions from copyofconst +! if calculations fails during step/map +! DANGEROUS IF NEW COMPOSITION SETS CREATED + implicit none + TYPE(gtp_equilibrium_data), pointer :: ceq + double precision copyofconst(*) +!\end{verbatim} + integer nz,varresx,ij,syfr + nz=1 +! skippa varres with index 1, that is the reference phase + do varresx=2,csfree-1 + ceq%phase_varres(varresx)%amfu=copyofconst(nz) + syfr=size(ceq%phase_varres(varresx)%yfr) + do ij=1,syfr + ceq%phase_varres(varresx)%yfr(ij)=copyofconst(nz+ij) + enddo +! write(*,17)varresx,nz,syfr,ceq%phase_varres(varresx)%amfu,& +! (ceq%phase_varres(varresx)%yfr(ij),ij=1,syfr) +17 format('3Xr:',i2,2i3,6(1pe12.4)) + nz=nz+1+size(ceq%phase_varres(varresx)%yfr) + enddo +1000 continue + return + end subroutine restore_constitutions + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + diff --git a/models/pmod25J.F90 b/models/gtp3Y.F90 similarity index 76% rename from models/pmod25J.F90 rename to models/gtp3Y.F90 index 4154b38..ee19b0f 100644 --- a/models/pmod25J.F90 +++ b/models/gtp3Y.F90 @@ -1,3807 +1,4204 @@ -! -! included in pmod25.F90 -! -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ -!> 17. Grid minimizer -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - subroutine global_gridmin(what,tp,xknown,nvsph,iphl,icsl,aphl,& - nyphl,yphl,cmu,ceq) -! -! finds a set of phases that is a global start point for an equilibrium -! calculation at T and P values in tp and known mole fraction in xknown -! It is intentional that this routine is independent of current conditions -! returns: nvsph stable phases, list of phases in iphl, amounts in aphl, -! constitution in yphl (compact after each other, nyphl(i) is number of -! fractions in phase i), cmu are element chemical potentials of solution -! WHAT determine what to do with the results, 0=just return solution, -! 1=enter stable set and constitution of all phases in gtp datastructure -! and create composition sets if necessary (and allowed) -! what=-1 will check if any gridpoint below current calculated equilibrium - implicit none -! nyphl(j) is the start position of the constitiuent fractions of phase j in -! yphl that contains all the constitutions of the phases in the gridpoints - integer, dimension(*) :: iphl,nyphl,icsl - integer what,nvsph - TYPE(gtp_equilibrium_data), pointer :: ceq - double precision, dimension(2) :: tp -! cmu(1..nrel) is the chemical potentials of the solution - double precision, dimension(*) :: xknown,aphl,yphl,cmu -!\end{verbatim} - integer, parameter :: maxgrid=100000,maxy=2000,maxph=500 - integer :: starttid,endoftime - real finish2 - double precision amount,sum - integer i,ibias,ics,ics2,icsno,icsx,ie,iph,iv,j1,j2,jip,jp,kkz,kp,kph,jbias - integer lokcs,lokph,mode,ng,nocsets,noofgridpoints,nr,nrel,nrph,ny,nyz -! kphl(iph) is first gridpoint in phase iph -! ngrid(iph) is the last gridpoint for phase iph (some phases may be suspended) -! xarr(nrel,i) is the composition of gridpoint i -! garr(i) is the Gibbs energy of gridpoint i -! jgrid(j) is a gridpoint in the solution -! phfrac(j) is the amount of the phase of that gridpoint - integer, dimension(maxph) :: ngrid,kphl - integer, dimension(maxel) :: jgrid - real garr(maxgrid),starting,finished - real, dimension (:,:), allocatable :: xarr - real, dimension (maxel,maxel) :: xsol - double precision, dimension(maxel) :: phfrac,phsave - double precision qq(5),savetp(2) - integer, dimension(maxph) :: iphx - character name1*24 -! debug - logical trace -! pph is set to number of phases participating, some may be suspended - integer pph,zph,nystph,order(maxel) -! - if(btest(globaldata%status,GSNOGLOB)) then - write(*,*)'Grid minimization not allowed' - gx%bmperr=4173; goto 1000 - endif - call cpu_time(starting) - ngrid=0 -! Trace turn on output of grid on a file -! trace=.true. - trace=.false. - savetp=ceq%tpval - ceq%tpval=tp -! ceq%tpval(2)=tp(2) - nrph=noph() -! write(*,*)'ggp A: ',tp(1),ceq%tpval(1) - if(nrph.gt.maxph) then -! too many phases - write(*,*)'Too many phases for gridmin' - gx%bmperr=6663; goto 1000 - endif - nrel=noel() - sum=zero - do i=1,nrel - if(xknown(i).le.zero .or. xknown(i).ge.one) then -! write(*,*)'Illegal composition for gridmin' - gx%bmperr=4174; goto 1000 - endif - sum=sum+xknown(i) - enddo - if(ocv()) write(*,12)'gridmin: ',sum,(xknown(i),i=1,nrel) -12 format(a,1pe12.4,10(f8.4)) - if(abs(sum-one).gt.1.0D-8) then - write(*,*)'Sum of fractions larger than unity calling global_gridmin' - gx%bmperr=4174; goto 1000 - endif - kp=1 - pph=0 - ggloop: do iph=1,nrph -! if(.not.phase_status(iph,1,PHHID,ceq)) then -! skip phases that are hidden or suspended .... old 5; new -3 -! if(test_phase_status(iph,1,amount,ceq).lt.5) then -! if(test_phase_status(iph,1,amount,ceq).gt.PHHIDDEN) then - if(test_phase_status(iph,1,amount,ceq).gt.PHSUS) then - do ics=1,noofcs(iph) -! old: 1=entered, 2=fix, 3=dormant, 4=suspended -! new: -3 suspended, -2 dormant, -1,0,1 entered, 2 fixed -! ignore phases whith no composition set entered -! If a phase+compset FIX one should never be here as conditions wrong - if(test_phase_status(iph,ics,amount,ceq).lt.PHFIXED) goto 60 - enddo - cycle ggloop -! this call to find out how many gridpoints will be generated for each phase -60 continue - pph=pph+1 - kphl(pph)=kp - iphx(pph)=iph - call generate_grid(-1,iph,ng,nrel,xarr,garr,ny,yphl,ceq) - if(gx%bmperr.ne.0) goto 1000 - kp=kp+ng - ngrid(pph)=kp-1 -! if(trace) then -! call get_phase_name(iph,1,name1) -! write(*,21)iph,name1(1:12),kphl(pph),ny,ng -! endif -! write(*,22)iph,kphl(pph),ny,ng,pph - endif - enddo ggloop -! we have a grid for pph phases, note that pph is not a phase index!!! -! the phase index for phase 1..pph is in iphx(1..pph) -21 format('Gridpoints for phase ',i3,': ',a,', starts at ',i5,', with ',2i5) -22 format('Gridpoints for phase ',i3,' starts at ',i5,', with ',2i5,i8) - if(kp-1.gt.maxgrid) then - write(*,*)'Too many gridpoints' - gx%bmperr=4175; goto 1000 - endif -! we may nave no gridpoints!!! - if(kp.eq.1) then - write(*,*)'No phases, no gridpoints' - gx%bmperr=4176; goto 1000 - endif -! write(*,*)'phases and gridpoints: ',pph,kp,ngrid(pph),nrel -! total number of gridpoints is kp-1 ... but sometimes kp is wrong, why?? -! allocate(xarr(nrel,kp-1)) - allocate(xarr(nrel,kp-1+10)) - if(ocv()) write(*,*)'Gridpoints and elements: ',kp-1,nrel -! generate grid -! we must know before this loop how many gridpoints that each phase will -! need. That is a function of the number of gridpoints. - kp=1 - call system_clock(count=starttid) -! OpenMP parallellization START -! the error code gx%bmperr should also be threadprivate -!-$omp parallel do private(ng,iv),schedule(dynamic) -! phloop: do iph=1,nrph - phloop: do zph=1,pph -! for phase iphx(zph) the gridpoints will be stored from position kphl(zph) -! mole fracts in xarr, g in garr -! yphl is not used when mode=0, ng should be set to number of remaining points -! ngrid(iph) is number of gridpoints in phase iph - ng=maxgrid -!-$ jip=omp_get_thread_num() -! values in kphl set in previous call to generate_grid(-1,.....) - iv=kphl(zph) -! this call will calculate all gridpoints - call generate_grid(0,iphx(zph),ng,nrel,xarr(1,iv),garr(iv),ny,yphl,ceq) - if(gx%bmperr.ne.0) then - write(*,*)'grid error ',jip,zph,gx%bmperr - goto 1000 - gx%bmperr=0 - endif -! list xarr for all gridpoints -! do kp=1,ng -! write(*,73)iphx(zph),kp,(xarr(ie,kp),ie=1,nrel) -!73 format('gp: ',i3,i5,10(f6.3)) -! enddo -! write(*,*)'look!!!' -! read(*,74)ch1 -!74 format(a) - enddo phloop -! set how many points in -!-$omp end parallel do -! OpenMP parallellization END - call system_clock(count=endoftime) -! write(*,106)endoftime-starttid -106 format('Clockcycles: ',i12) -107 format(a,7i6) -! kp=ngrid(nrph) - kp=ngrid(pph) -! if(trace) write(*,108)kp -108 format('The total number of gridpoints are ',i5) - call cpu_time(finished) - noofgridpoints=ngrid(pph) -! If WHAT is -1 then just compare all gridpoints with plane defined by -! the chemical potentials cmu to see if any is below. -! If so insert the gridpoint furtherst below the plane and set WHAT 10*iph+ics -! write(*,*)'global_gridmin what: ',what - if(what.eq.-1) then - call gridmin_check(nystph,kp,nrel,xarr,garr,xknown,ngrid,pph,& - cmu,yphl,iphx,ceq) - goto 1000 - endif -!----------------------------------------------- -! write(*,109)ngrid(pph),finished-starting,endoftime-starttid -109 format('Calculated ',i6,' gridpoints in ',1pe12.4,' seconds, ',& - i7,' clockcycles') -! find the minimum of nrel gridpoints among the kp-1 gridpoint -! for current overall composition, xknown -! write(*,*)'globm 4: ',kp,garr(kp),xarr(1,kp) -! phfrac=zero - if(ocv()) write(*,*)'Finding the gridpoints for the minimum: ',kp-1 - call find_gridmin(kp,nrel,xarr,garr,xknown,jgrid,phfrac,cmu,trace) - if(gx%bmperr.ne.0) goto 1000 -! The solution with nrel gridpoints are in jgrid, the amount of each in phfrac -! We later want the phases in ascending order and as the gridpoints are -! in ascending order of the phases we sort the gridpoints (and amounts) -! There must be one gridpoint per component (element) -! write(*,62)(jgrid(jp),jp=1,nrel) - call sortin(jgrid,nrel,order) - do nyz=1,nrel - phsave(nyz)=phfrac(order(nyz)) - enddo - phfrac=phsave -! check -! write(*,62)(jgrid(jp),jp=1,nrel) -62 format('25J Gridp: ',10i4) -! xov=zero -! sum=zero -! do jp=1,nrel -! write(*,63)'xs: ',phfrac(jp),(xarr(nyz,jgrid(jp)),nyz=1,nrel) -! do nyz=1,nrel -! xov(nyz)=xov(nyz)+phfrac(jp)*xarr(nyz,jgrid(jp)) -! enddo -! sum=sum+phfrac(jp) -! enddo -! write(*,63)'ss: ',sum,(xov(nyz),nyz=1,nrel) -!63 format(a,1e12.4,10f7.4) -! get the phase and constitution for each - nyz=1 -! if(trace) write(*,*)'Extracting constititution' - if(trace) then - write(31,745) -745 format(/'Solution: ') - endif - solloop: do jp=1,nrel -! jgrid(jp) is a grid point in the solution, find which phase it is - mode=jgrid(jp) - ibias=0 - do zph=1,pph -! write(*,*)'mode and ibias 1: ',mode,ibias -! ngrid(zph) is the first gridpoints of phase zph - if(mode.le.ngrid(zph)) then - mode=mode-ibias - goto 315 - else - ibias=ngrid(zph) - endif - enddo - write(*,*)'gridpoint outside range ',jgrid(jp),ngrid(pph) - gx%bmperr=4147; goto 1000 -315 continue - jbias=ibias -! write(*,*)'gridpoint in solution: ',mode,ibias -! this call is to obtain the constitution of a phase in the solution -! mode gives in grid point index in phase iphx(zph), ibias irrelevant (?) -! NOTE ibias is changed by subroutine - call generate_grid(mode,iphx(zph),ibias,nrel,xarr,garr,ny,yphl(nyz),ceq) - if(gx%bmperr.ne.0) goto 1000 -! write(*,317)'gg7B: ',ny,nyz,(yphl(i),i=nyz,nyz+ny-1) -!317 format(a,2i3,6(1pe11.3)) - iphl(jp)=iphx(zph) - aphl(jp)=phfrac(jp) - nyphl(jp)=ny - nyz=nyz+ny -! finally copy the mole fractions to xsol, needed for possible merging - do ie=1,nrel - xsol(ie,jp)=xarr(ie,mode+jbias) - enddo - if(trace) then - write(31,750)jp,jgrid(jp),iphl(jp),aphl(jp),(xsol(ie,jp),ie=1,nrel) - write(31,760)(yphl(i),i=nyz-ny,nyz-1) -750 format('Point: ',i2,', gridpoint: ',i5,' phase ',i3,& - ' amount: ',1pe12.4,', Mole fractions:'/9(0pF8.5)) -760 format('Constitution:'/9(0pF8.5)) - endif - enddo solloop - if(trace) then - write(*,*)'Closing grid file' - close(31) - endif -! there must be as many phases in the solution as there are elements - nvsph=nrel - nr=nvsph - if(.not.btest(globaldata%status,GSNOMERGE)) then - call merge_gridpoints(nr,iphl,aphl,nyphl,yphl,trace,nrel,xsol,cmu,ceq) - if(gx%bmperr.ne.0) goto 1000 - endif -! number of gridpoints, nr, may have changed -! write(*,*)'After merge_gripoints: ',nr,nvsph - nvsph=nr -! if what=-1 or0 do nothing more, just exit -! if(what.eq.0) goto 1000 - if(what.le.0) goto 1000 -!------------------------------------------------------------ -! prepare for storing result: zero all phase amounts and driving forces - do iph=1,nrph - lokph=phases(iph) -! lokcs=phlista(lokph)%cslink - do ics=1,phlista(lokph)%noofcs - lokcs=phlista(lokph)%linktocs(ics) -! ceq%phase_varres(lokcs)%amount=zero - ceq%phase_varres(lokcs)%dgm=zero - ceq%phase_varres(lokcs)%amfu=zero - ceq%phase_varres(lokcs)%netcharge=zero - enddo - enddo -! store chemical potentials multiplied with RT if what not -1 - ceq%rtn=globaldata%rgas*ceq%tpval(1) - do ie=1,nrel -! write(*,*)'grid chemical potential: ',ie,cmu(ie)*ceq%rtn -! do not care about reference state for chempot(2) - ceq%complist(ie)%chempot(1)=cmu(ie)*ceq%rtn - ceq%complist(ie)%chempot(2)=cmu(ie)*ceq%rtn - enddo -! set driving force 0 for stable phases - do i=1,nvsph - call set_driving_force(iphl(i),1,zero,ceq) - if(gx%bmperr.ne.0) goto 1000 - enddo -! store the most favourable constitution of the metastable phase - call set_metastable_constitutions(kp,nrel,kphl,ngrid,xarr,garr,& - nvsph,iphl,cmu,ceq) - if(gx%bmperr.ne.0) goto 1000 -! maybe more composition sets needed - do i=1,nvsph - icsl(i)=0 - enddo - nocsets=0 -! write(*,*)'before loop1: ',nvsph,ceq%eqname - loop1: do j1=1,nvsph - if(icsl(j1).eq.0) then -! if non-zero a composition set has already been assigned - icsl(j1)=1 - icsx=1 - loop2: do j2=j1+1,nvsph - if(iphl(j1).eq.iphl(j2)) then -! one more composition set needed, does it exist? - icsx=icsx+1 - ics2=icsx - call get_phase_compset(iphl(j1),ics2,lokph,lokcs) - if(gx%bmperr.ne.0) then -! there is no such composition set, is automatic creation allowed? -! NOTE: there is a EQNOACS bit also??? - if(btest(globaldata%status,GSNOACS)) then -! write(*,*)'Not allowed to create composition sets' - gx%bmperr=4177; goto 1000 - endif - gx%bmperr=0 -! >>>>>>>>>>>>>>>>>>>< -! BEWARE >>> not only must this be done in all threads at the same time -! one must also avoid that it is done when some thread is working on a set -! of phase+composition sets trandformed to EQCALC arrays. If so the -! indices to lokcs etc will be incorrect ... ??? -! I think OMP has "secure" points where the treads can be stopped to wait -! <<<<<<<<<<<<<<<<<<<<<< - kph=iphl(j1) -! write(*,*)'25J new composition set for phase: ',j2,kph -! call add_composition_set(kph,' ','AUTO',icsno,ceq) -! call add_composition_set(kph,' ','AUTO',icsno,firsteq) -! It must be done in all equilibrium records, no equilibrium record needed!!! -! one must be careful with the status word when creating comp.sets - call add_composition_set(kph,' ','AUTO',icsno) - if(gx%bmperr.ne.0) goto 1000 - call get_phase_compset(kph,icsno,lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 - ceq%phase_varres(lokcs)%status2=& - ibset(ceq%phase_varres(lokcs)%status2,CSAUTO) - nocsets=nocsets+1 -! if(btest(ceq%phase_varres(lokcs)%status2,CSDEFCON)) then -! write(*,*)'25J defcon set',kph,icsno -! else -! write(*,*)'25J defcon not set',kph,icsno -! endif -! write(*,303)'25J Created cs:',kph,icsno,lokcs,& -! ceq%phase_varres(lokcs)%amfu,& -! ceq%phase_varres(lokcs)%abnorm -303 format(a,3i3,6(1pe12.4)) - icsl(j2)=icsno - else -! here we should check which composition set that should have which -! constitution for example one fcc is metallic and another is cubic carbide - call get_phase_name(iphl(j1),ics2,name1) - icsl(j2)=ics2 -! write(*,1711)name1,ics2 -1711 format('Using composition set for ',a,i3) -! check if the composition set is fix (2), dormant (2) or suspended (3) - kkz=test_phase_status(iphl(j1),ics2,amount,ceq) -! old kkz=2 means fix -! if(kkz.eq.2) then - if(kkz.eq.PHFIXED) then - write(*,*)'Global minimization with fix phase not allowed' - gx%bmperr=7777; goto 1000 - elseif(kkz.lt.PHENTUNST) then - write(*,*)' *** Warning, changing status for phase ',name1 - endif -! this means status entered PHSTATE -! ceq%phase_varres(lokcs)%status2=& -! ibclr(ceq%phase_varres(lokcs)%status2,CSSUS) -! ceq%phase_varres(lokcs)%status2=& -! ibclr(ceq%phase_varres(lokcs)%status2,CSFIXDORM) - ceq%phase_varres(lokcs)%phstate=0 - endif - endif - enddo loop2 - endif - enddo loop1 -! write(*,*)'after loop1: ',phlista(1)%noofcs - if(nocsets.gt.0) write(*,*)'Composition set(s) created: ',nocsets -! Above one should consider if some user created compsets are dedicated to -! certain cases (MC carbides or L1_2 ordered). These should have -! a default constitution and CSDEFCON set) -! finally store stable phase amounts and constitutions into ceq%phase_varres - j1=1 - ceqstore: do iph=1,nvsph -! write(*,*)'ggm: ',iph,iphl(iph),icsl(iph),j1 - call set_constitution(iphl(iph),icsl(iph),yphl(j1),qq,ceq) - if(gx%bmperr.ne.0) goto 1000 -! write(*,1788)'gg: ',iph,iphl(iph),icsl(iph),aphl(iph),& -! (yphl(j1+ie),ie=0,3),qq(1) -1788 format(a,3i3,f8.4,2x,4f8.4,1pe10.2) -! aphl(iph) is amount of phase per mole component - call get_phase_compset(iphl(iph),icsl(iph),lokph,lokcs) -! Here aphl is divided with the number of mole of atoms in the phase -! if(ceq%phase_varres(lokcs)%abnorm(1).ge.one) then -! aphl(iph)=aphl(iph)/ceq%phase_varres(lokcs)%abnorm(1) -! endif -! write(*,1812)iph,lokcs,aphl(iph),ceq%phase_varres(lokcs)%abnorm(1) -1812 format('aphl: ',2i3,6(1pe12.4)) - aphl(iph)=aphl(iph)/ceq%phase_varres(lokcs)%abnorm(1) -! write(*,1789)'aphl: ',iph,lokcs,aphl(iph),& -! ceq%phase_varres(lokcs)%abnorm(1) -1789 format(a,2i3,2(1pe12.4)) - ceq%phase_varres(lokcs)%amfu=aphl(iph) - j1=j1+nyphl(iph) - enddo ceqstore -1000 continue -! write(*,*)'at 1000: ',phlista(1)%noofcs -! restore tpval in ceq - ceq%tpval=savetp - call cpu_time(finish2) - if(allocated(xarr)) deallocate(xarr) - if(gx%bmperr.ne.0) then -! globaldata%status=ibset(globaldata%status,GSEQFAIL) - ceq%status=ibset(ceq%status,EQFAIL) - elseif(what.eq.-1) then - if(nystph.gt.0) what=nystph - else - write(*,1010)noofgridpoints,finish2-starting,endoftime-starttid -1010 format(' Grid minimization: ',i5,' gridpoints ',1pe12.4,' s and ',& - i7,' clockcycles') -! set the global bit that this is not a full equilibrium - ceq%status=ibset(ceq%status,EQNOEQCAL) - endif - if(ocv()) write(*,*)'leaving global_gridmin' - return - end subroutine global_gridmin - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!-\begin{verbatim} - subroutine new_gridpoint_calc(only,iph,nsl,nend,endm,jend,ifra,ny,yfra,& - xmol,gval,ceq) -! This subroutine sets the fractions according to three indicators -! and calculates the Gibbs energy of the gridpoint - implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq - integer iph,nsl,only,nend,ny,jend(3),ifra(3) - double precision yfra(*),gval,xmol(*) - integer, dimension(nsl,nend) :: endm -!-\end{verbatim} - integer lokres,ls -! preset fractions - double precision qq(5) - double precision, parameter :: yzero=1.0D-12 -! preset weights of endmembers - double precision, dimension(4), parameter:: ybas=& - [1.0D0,0.89D0,0.74D0,0.61D0] - double precision, dimension(4), parameter :: ybin=& - [0.11D0,0.26D0,0.39D0,0.15D0] - double precision, dimension(2), parameter :: yter=& - [0.11D0,0.13D0] -! When setting fractions one must have the sum of fractions in each sublattice -! equal to unity. This is done by weighting endmembers -! endm(ll,ie) is the index to constituent ie in sublattice ll -! With 3 sublattices with (2,2,4) constituents endm is -! endm(1,1)=1, endm(1,2)=2, -! endm(2,1)=3, endm(2,2)=4, -! endm(3,1)=5, endm(3,2)=6, endm(3,3)=7, endm(3,4)=8 -! jend(*) select endmember to mix, with two constitutions jend(3)=0 -! - do ls=1,ny - yfra(ls)=zero - enddo -! write(*,10)iph,jend,ifra -10 format('gix: ',i2,13x,3i3,2x,3i3) - do ls=1,nsl - yfra(endm(ls,jend(1)))=ybas(ifra(1)) - if(jend(2).gt.0) yfra(endm(ls,jend(2)))=& - yfra(endm(ls,jend(2)))+ybin(ifra(2)) - if(jend(3).gt.0) yfra(endm(ls,jend(3)))=& - yfra(endm(ls,jend(3)))+yter(ifra(3)) - enddo - if(only.gt.0) goto 1000 -! -! calculate G and composition and save - write(*,11)iph,(yfra(ls),ls=1,ny) -11 format('gyp: ',i2,25x,10(f6.3)) - call set_constitution(iph,1,yfra,qq,ceq) - if(gx%bmperr.ne.0) goto 1000 - call calcg(iph,1,0,lokres,ceq) - if(gx%bmperr.ne.0) goto 1000 -! - if(qq(1).ge.1.0D-1) then -! number of real atoms less than 10%, a gridpoint with just vacancies .... - gval=real(ceq%phase_varres(lokres)%gval(1,1)/qq(1)) - else - gval=1.0E5 - endif - call calc_phase_mol(iph,xmol,ceq) - if(gx%bmperr.ne.0) goto 1000 -1000 continue - return - end subroutine new_gridpoint_calc - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!-\begin{verbatim} - subroutine generate_grid_v2(mode,iph,ngg,nrel,xarr,garr,ny,yarr,ceq) -! generate grid for phase iph -! Different action depending of the value of mode, -! for mode<0: -! return the number of gridpoints that will be generated for phase iph -! for mode=0: -! return garr(i) gibbs energy and xarr(1,i) the compositions of gridpoint i -! for mode>0: -! return site fractions of gridpoint mode in yarr, number of fractions in ny -! iph is phase number, ngg is number of gridpoints, nrel number of elements, -! if mode=0: -! return xarr mole fractions of gridpoints, garr Gibbs energy of gridpoints, -! ngg is dimension of garr -! if mode>0: -! "mode" is a gridpoint of this phase in solution, return number of -! constituent fractions in ny and fractions in yarr for this gridpoint -! The current constitution is restored at the end of the subroutine - implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq - integer mode,iph,ngg,nrel,ny,lokph,errsave -! -!-\end{verbatim} - double precision, parameter :: yzero=1.0D-12 - real xarr(nrel,*),garr(*) - integer i,je,ll,ls,nend,ie - double precision yarr(*),xmol(maxel),ydum(maxconst) - integer ngdim,nsl,l1,l2,l3 - integer nkl(maxsubl),knr(maxconst),inkl(0:maxsubl),nofy - double precision, dimension(:), allocatable :: yfra - double precision sites(maxsubl),qq(5),gval -! endm(i,j) has constituent indices in i=1..nsl for endmember j - integer, dimension(:,:), allocatable :: endm - integer ifra(3),jend(3) -!-------------------------------- -! grid is generated by combining end endmembers -! Number of endmemers is N -! For endmember E=1..N set fraction of enmember -! 0.99*Y_E + 0.01*Y_all N of these -! 0.89*Y_E + 0.10*Y_F,F=/=E + 0.01*Y_all N*(N-1) -! 0.74*Y_E + 0.25*Y_F,F=/=E + 0.01*Y_all N*(N-1)+N*(N-1)*(N-2) -! + 0.15*Y_F + 0.1*Y_G,G=/=(E,F) + 0.01*Y_all (3 or more endmemb) -! 0.61*Y_E + 0.38*Y_F,F=/=E + 0.01*Y_all -! + 0.25*Y_F + 0.13*Y_G,G=/=(E,F) + 0.01*Y_all (3 or more endmemb) -!----- N=2: total 2+2+2+2=8 -!----- N>2: total N*(1+(N-1)*(3+2*(N-2))); N=3:33, N=20: -! with 2 endmembers: 2*(1+3)=2*4=8 -! (1.00,0.00) -! (0.89,0.11) (0.74,0.26) (0.61,39) -! (0.00,1.00) ... -! with 3 endmembers: 3*11=33 gridpoints (binary combinations) -! (1.00,0.00,0.00) 1st-------- -! (0.89,0.11,0.00)(0.89,0.00,0.11) -! (0.74,0.26,0.00)(0.74,0.00.0.26) binary -! (0.74,0.15,0.11)(0.74,0.11,0.15) ternay -! (0.61,0.39,0.00)(0.61,0.00,0.39) binary -! (0.61,0.26,0.13)(0.61,0.13,0.26) ternary -! (0.00,1.00,0.00) 2nd--------- -! (0.11,0.89,0.00)(0.00,0.89.0.11) -! ... -! with 4 endmembers: -! (0.9925,0.0025,0.0025.0.0025) -! (0.8925,0.1025,0.0025,0.0025) (-,0.0025,0.1025,-) (-,.0025,.0025,.1025) ... -!--------- -! for n>50 only endmember: 51:51, N:N -! for n=31-50 only one binary combination: -! for n=26-30 only two binary combinations: -! for n=2 and n=15-25 three binary cobinations: -! for n=11-14 three binary and one ternary combination -! for n<=10 use full grid: 2 binar and 2 ternar combinarions -! double precision, dimension(4), parameter:: ybas=& -! [1.0D0,0.89D0,0.74D0,0.61D0] -! double precision, dimension(4), parameter :: ybin=& -! [0.11D0,0.26D0,0.39D0,0.15D0] -! double precision, dimension(3), parameter :: yter=[0.0D0,0.11D0,0.13D0] -! -! write(*,*)'entering generate_grid: ',mode,iph,ngg - call get_phase_data(iph,1,nsl,nkl,knr,ydum,sites,qq,ceq) - if(gx%bmperr.ne.0) goto 1000 -! calculate the number of endmembers and index of first constituent in subl ll - nend=1 - inkl(0)=0 - do ll=1,nsl - nend=nend*nkl(ll) - inkl(ll)=inkl(ll-1)+nkl(ll) - enddo - ny=inkl(nsl) - lokph=phases(iph) - negmode: if(mode.lt.0) then -! Any changes here must be made also for mode=0 -!--------------------------------------------------------- -! just determine the number of gridpoints for this phase for global minimimum -! ideal gases should just have the endmembers .... - ngdim=ngg - ngg=nend - if(nend.eq.1 .or. nend.gt.50 .or. & - btest(phlista(lokph)%status1,PHID)) then -! >50 or 1 endmember or ideal phase: only endmembers - ngg=nend - elseif(nend.gt.30) then -! 31-50: only one binary combination - ngg=nend*nend - elseif(nend.gt.25) then -! 26-30: two binary combinations - ngg=nend*(1+2*(nend-1)) - elseif(nend.eq.2 .or. nend.ge.15) then -! 2 or 15-25: three binary combinarions - ngg=nend*(1+3*(nend-1)) - elseif(nend.gt.10) then -! 11-14: three binary and one ternary combinarion - ngg=nend*(1+(nend-1)*(3+nend-2)) ! (ternary combination skipped) - ngg=ngg+nend*(1+3*(nend-1)) -! write(*,*)' 100: -! return sitefractions (for mode=gridpoint number (part of the solution)) -! BUT: The only way to find the site fraction of a gripoint is to generate -! all gridpoints up the one specified by the value of mode (no G calculation) -!------------------------------------------------------------ -! this subroutine is not used - allocate(endm(nsl,nend)) - allocate(yfra(inkl(nsl))) - nofy=inkl(nsl) -! generate endmembers, endm(ll,ie) is set to consituent index in sublattice ll -! note: inkl(0)=0, this has to be identical to what is returned for mode=-1 - je=1 - do ll=1,nsl - endm(ll,je)=inkl(ll-1)+1 - enddo - do while(je.lt.nend) - je=je+1 - do ls=1,nsl - endm(ls,je)=endm(ls,je-1) - enddo - ll=0 -110 ll=ll+1 - if(endm(ll,je).lt.inkl(ll)) then - endm(ll,je)=endm(ll,je)+1 - elseif(ll.lt.nsl) then - endm(ll,je)=inkl(ll-1)+1 - goto 110 - else - gx%bmperr=4148; goto 1000 - endif - enddo -!========================================= -! now generate all combinations of endmembers - ngg=0 - jend=0 -!------------------------------------------------- -! loop to calculate gridpoints - endc: do l1=1,nend - yfra=yzero - do ls=1,nsl - yfra(endm(ls,l1))=one - enddo - jend(1)=jend(1)+1 - jend(2)=0 - jend(3)=0 - ifra=0 - ifra(1)=1 -! calculate gridpoint for a pure endmember vvvvvvvvvvvvvvvvvvvvvvvvvvvvv - call new_gridpoint_calc(mode,iph,nsl,nend,endm,jend,ifra,ny,yfra,& - xmol,gval,ceq) - if(gx%bmperr.ne.0) goto 1000 - ngg=ngg+1 - if(mode.eq.ngg) goto 500 - do ie=1,nrel - xarr(ie,ngg)=real(xmol(ie)) - enddo - garr(ngg)=real(gval) -!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -! Any changes here has also to be made for mode<0 above !!!! -! only endmembers (1:0:0), nend points - if(nend.eq.1 .or. nend.gt.50 .or. & - btest(phlista(lokph)%status1,PHID)) cycle endc -!------------------------------------------------- -! loop to calculate binary and ternary gridpoints - ifra(1)=2 - ifra(2)=1 - jend(2)=0 -! we may jump back here for another set of binary combinations -200 continue - binc: do l2=1,nend-1 - jend(2)=jend(2)+1 - if(jend(2).eq.jend(1)) jend(2)=jend(2)+1 -! calculate gridpoint for a binary combination of endmembers vvvvvvvvvvv - call new_gridpoint_calc(mode,iph,nsl,nend,endm,jend,ifra,ny,yfra,& - xmol,gval,ceq) - if(gx%bmperr.ne.0) goto 1000 - ngg=ngg+1 - if(mode.eq.ngg) goto 500 - do ie=1,nrel - xarr(ie,ngg)=real(xmol(ie)) - enddo - garr(ngg)=real(gval) -!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - if(nend.gt.30 .or. & - nend.gt.25 .or. & - nend.eq.2 .or. nend.gt.14) then ! nend=2 or nend>14) then -! Any changes here has also to be made for mode<0 above !!!! -! one binary combination (2:1:0), min 961, max 2500 points -! two binary combinations (2:1:0) and (3:2:0), min 1326, max 1770 points -! three binary combinations (2:1:0), (3:2:0) and (4:3:0) max 1825 points - cycle binc - endif - if(nend.gt.10) then !110: -! return site fractions of gridpoint mode in yarr, number of fractions in ny -! iph is phase number, ngg is number of gridpoints, nrel number of elements, -! if mode=0: -! return xarr mole fractions of gridpoints, garr Gibbs energy of gridpoints, -! ngg is dimension of garr -! if mode>0: -! "mode" is a gridpoint of this phase in solution, return number of -! constituent fractions in ny and fractions in yarr for this gridpoint -! The current constitution is restored at the end of the subroutine - implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq - integer mode,iph,ngg,nrel,ny - real xarr(nrel,*),garr(*) - double precision yarr(*) -!\end{verbatim} -! - integer lokph,errsave - double precision, parameter :: yzero=1.0D-12 - integer abrakadabra,i,ibas,ibin,iend,is,iter,je,jend,kend,ll,ls,nend - double precision ydum(maxconst) - integer ngdim,nsl - integer nkl(maxsubl),knr(maxconst),inkl(0:maxsubl),nofy - double precision, dimension(:), allocatable :: yfra - double precision sites(maxsubl),qq(5) -! endm(i,j) has constituent indices in i=1..nsl for endmember j - integer, dimension(:,:), allocatable :: endm -!-------------------------------- -! grid is generated by combining end endmembers -! Number of endmemers is N -! For endmember E=1..N set fraction of enmember -! 0.99*Y_E + 0.01*Y_all N of these -! 0.89*Y_E + 0.10*Y_F,F=/=E + 0.01*Y_all N*(N-1) -! 0.74*Y_E + 0.25*Y_F,F=/=E + 0.01*Y_all N*(N-1)+N*(N-1)*(N-2) -! + 0.15*Y_F + 0.1*Y_G,G=/=(E,F) + 0.01*Y_all (3 or more endmemb) -! 0.61*Y_E + 0.38*Y_F,F=/=E + 0.01*Y_all -! + 0.25*Y_F + 0.13*Y_G,G=/=(E,F) + 0.01*Y_all (3 or more endmemb) -!----- N=2: total 2+2+2+2=8 -!----- N>2: total N*(1+(N-1)*(3+2*(N-2))); N=3:33, N=20: -! with 2 endmembers: 2*(1+3)=2*4=8 -! (1.00,0.00) -! (0.89,0.11) (0.74,0.26) (0.61,39) -! (0.00,1.00) ... -! with 3 endmembers: 3*11=33 gridpoints -! (1.00,0.00,0.00) -! (0.89,0.11,0.00)(0.89,0.00,0.11) -! (0.74,0.26,0.00)(0.74,0.00.0.26)(0.74,0.15,0.11)(0.74,0.11,0.15) -! (0.61,0.38,0.00)(0.61,0.00,0.38)(0.61,0.25,0.14)(0.61,0.14,0.25) -! (0.00,1.00,0.00) -! (0.11,0.89,0.00)(0.00,0.89.0.11) -! with 4 endmembers: -! (0.9925,0.0025,0.0025.0.0025) -! (0.8925,0.1025,0.0025,0.0025) (-,0.0025,0.1025,-) (-,.0025,.0025,.1025) ... -!--------- -! for n>50 only endmember: 51:51, N:N -! for n=31-50 only one binary combination: -! for n=26-30 only two binary combinations: -! for n=2 and n=15-25 three binary cobinations: -! for n=11-14 three binary and one ternary combination -! for n<=10 use full grid: 2 binar and 2 ternar combinarions - double precision, dimension(4), parameter:: ybas=& - [1.0D0,0.89D0,0.74D0,0.61D0] - double precision, dimension(4), parameter :: ybin=& - [0.11D0,0.26D0,0.39D0,0.15D0] - double precision, dimension(3), parameter :: yter=[0.0D0,0.11D0,0.13D0] -! for output of gridpoints - integer jbas,sumngg - logical trace,isendmem - save sumngg -! -! write(*,*)'entering generate_grid: ',mode,iph,ngg - if(mode.eq.0) then -! write(*,*)'Generating grid for phase: ',iph -! trace TRUE means generate outpy for each gridpoint -! trace=.TRUE. - trace=.FALSE. - if(iph.eq.1 .and. trace) then - open(31,file='gridgen.dat ',access='sequential') - sumngg=0 - write(31,43) -43 format('The constituent fractions, y, enclosed within parentheses',& - 'for each sublattice'/'Mole fractions after x:, Gibbs energies',& - ' after G:'/) - endif - if(trace) then - call get_phase_record(iph,nend) - write(31,44)iph,phlista(nend)%name -44 format('Endmembers (EM) and gridpoints (GP) for phase: ',i3,1x,a) - endif - else - trace=.FALSE. - endif - call get_phase_data(iph,1,nsl,nkl,knr,ydum,sites,qq,ceq) - if(gx%bmperr.ne.0) goto 1000 -! calculate the number of endmembers and index of first constituent in subl ll - nend=1 - inkl(0)=0 - do ll=1,nsl - nend=nend*nkl(ll) - inkl(ll)=inkl(ll-1)+nkl(ll) - enddo - ny=inkl(nsl) -! write(*,1010)'Saved ',iph,(ydum(i),i=1,ny) - negmode: if(mode.lt.0) then -!--------------------------------------------------------- -! just determine the number of gridpoints for this phase for global minimimum -! ideal gases should just have the endmembers .... - ngdim=ngg - ngg=nend - lokph=phases(iph) - if(nend.eq.1 .or. nend.gt.50 .or. & - btest(phlista(lokph)%status1,PHID)) then -! >50 or 1 endmember or ideal phase: only endmembers - ngg=nend - elseif(nend.gt.30) then -! 31-50: only one binary combination - ngg=nend*nend - elseif(nend.gt.25) then -! 26-30: two binary combinations - ngg=nend*(1+2*(nend-1)) - elseif(nend.eq.2 .or. nend.ge.15) then -! 2 or 15-25: three binary combinarions - ngg=nend*(1+3*(nend-1)) - elseif(nend.gt.10) then -! 11-14: three binary and one ternary combinarion - ngg=nend*(1+(nend-1)*(3+nend-2)) ! (ternary combination skipped) - ngg=nend*(1+3*(nend-1)) - else -! 3-10: three binary and two ternary combinarions (all) - ngg=nend*(1+(nend-1)*(3+2*(nend-2))) ! (ternary combinations skipped) - ngg=nend*(1+3*(nend-1)) - endif -! write(*,*)'endmembers and gridpoints: ',nend,ngg -! read(*,11)ch1 -11 format(a) - if(ocv()) write(*,*)'Generate grid: ',nend,ngg - ny=nend - goto 1001 - endif negmode -!------------------------------------------------------------ -! for mode=0: -! set gridpoint sitefractions and calculate G -! for mode>0: -! return sitefractions (for mode=gridpoint number (part of the solution)) -! BUT: The only way to find the site fraction of a gripoint is to generate -! all gridpoints up the one specified by the value of mode (no G calculation) -! write(*,*)'ggy: ',mode,iph,nsl,nend,inkl(nsl) -! gx%bmperr=7777; goto 1000 - allocate(endm(nsl,nend)) - allocate(yfra(inkl(nsl))) - nofy=inkl(nsl) -! generate endmembers, endm(ll,ie) is set to consituent index in sublattice ll - je=1 - do ll=1,nsl - endm(ll,je)=inkl(ll-1)+1 - enddo -100 continue - je=je+1 - if(je.gt.nend) goto 120 - do ls=1,nsl - endm(ls,je)=endm(ls,je-1) - enddo - ll=0 -110 ll=ll+1 - if(endm(ll,je).lt.inkl(ll)) then - endm(ll,je)=endm(ll,je)+1 - elseif(ll.lt.nsl) then - endm(ll,je)=inkl(ll-1)+1 - goto 110 - else - gx%bmperr=4148; goto 1000 - endif - goto 100 -120 continue -! if(trace) then -! do i=1,nend -! write(31,125)i,(endm(ls,i),ls=1,nsl) -!125 format('endmem: ',i4,2x,10i3) -! enddo -! endif -150 continue -!--------------------------------------- -! now generate all combinations of endmembers -! write(*,*)'endmembers and gridpoints: ',nend,ngg -! read(*,11)ch1 - ngg=0 - lokph=phases(iph) - endmem: do iend=1,nend - yfra=yzero - do ls=1,nsl - yfra(endm(ls,iend))=ybas(1) - enddo - isendmem=.TRUE. -! initiate the loop veriables below for endmembers and fractions - ibas=2 - ibin=1 - iter=1 - jend=0 - kend=0 -200 continue - ngg=ngg+1 - if(mode.gt.0) then - if(ngg.eq.mode) goto 500 - else -! calculate G and composition and save -! write(*,201)ibas,ngg,(yfra(is),is=1,inkl(nsl)) -201 format('ggz: ',i2,i5,10(F6.3)) - if(ocv()) write(*,*)'Calculating gridpoint: ',ngg - call calc_gridpoint(iph,yfra,nrel,xarr(1,ngg),garr(ngg),ceq) - if(gx%bmperr.ne.0) goto 1000 -! if(ngg.eq.15) then -! write(*,520)'cgx: ',(xarr(is,ngg),is=1,nrel) -! endif - if(trace) then - if(isendmem) then - write(31,153,advance='no')sumngg+ngg -153 format('EM:',i4,' y: ') - else - write(31,154,advance='no')sumngg+ngg -154 format('GP:',i4,' y: ') - endif - jbas=0 - do ls=1,nsl - write(31,155,advance='no')(yfra(jbas+is),is=1,nkl(ls)-1) -155 format('(',10(F4.2,',')) - write(31,156,advance='no')yfra(jbas+nkl(ls)) -156 format(F4.2,')') - jbas=jbas+nkl(ls) - enddo - write(31,157)(xarr(is,ngg),is=1,nrel),garr(ngg) -157 format(' x:',3f8.5,' G:',1pe12.4) - endif - isendmem=.FALSE. - endif -! depending on nend value or ideal generate combinations - if(nend.eq.1 .or. nend.gt.50 .or. & - btest(phlista(lokph)%status1,PHID)) cycle - yfra=yzero - combend: if(nend.gt.30) then -! if nend=31..50, one binary combination, 961-2500 -! 0.89*Y_E + 0.11*Y_F,F=/=E - jend=jend+1 - if(jend.eq.iend) jend=jend+1 - if(jend.gt.nend) cycle - do ls=1,nsl - yfra(endm(ls,iend))=ybas(ibas) - yfra(endm(ls,jend))=yfra(endm(ls,jend))+ybin(ibin) - enddo - goto 200 - elseif(nend.gt.25) then -! nend=26..30 two binary combinations, 1326-1770 -! 0.89*Y_E + 0.11*Y_F,F=/=E -! 0.74*Y_E + 0.26*Y_F,F=/=E - jend=jend+1 - if(jend.eq.iend) jend=jend+1 - if(jend.gt.nend) then - if(ibas.eq.3) cycle - jend=1 - ibas=3; ibin=2 - endif - do ls=1,nsl - yfra(endm(ls,iend))=ybas(ibas) - yfra(endm(ls,jend))=yfra(endm(ls,jend))+ybin(ibin) - enddo - goto 200 - elseif(nend.eq.2 .or. nend.ge.15) then -! nend=2 or nend=15..25, three binary combinations, ??-1825 -! 0.89*Y_E + 0.11*Y_F,F=/=E -! 0.74*Y_E + 0.25*Y_F,F=/=E -! 0.61*Y_E + 0.39*Y_F,F=/=E - jend=jend+1 - if(jend.eq.iend) jend=jend+1 - if(jend.gt.nend) then - if(ibas.eq.4) cycle - ibas=ibas+1; ibin=ibin+1 - jend=1 - if(jend.eq.iend) jend=jend+1 - endif - do ls=1,nsl - yfra(endm(ls,iend))=ybas(ibas) - yfra(endm(ls,jend))=yfra(endm(ls,jend))+ybin(ibin) - enddo - goto 200 - elseif(nend.gt.10) then -! complicated here, iterating in both binary and ternary combinations .... -! nend=11..14, 3 binary and one ternary combination, 1331-2744 -! 0.89*Y_E + 0.11*Y_F,F=/=E -! 0.74*Y_E + 0.26*Y_F,F=/=E -! + 0.15*Y_F + 0.11*Y_G,G=/=(E,F) -! 0.61*Y_E + 0.39*Y_F,F=/=E - if(iter.eq.2) then -! we are interating in the ternary endmember - stop 'no ternary for 10>>> problem with gas phase test case cho1 with x(c)=.2 x(o)=x(H)=.4 -! The gridpoints returned not good, probably due to too many gridpoints ... -! -! if(trace) write(*,*)'Failed when trying to add gridpoint ',nyp - if(checkremoved) goto 950 -! just ignore this gridpoint and continue, it has been added to notuse -! and will be checked again later as "removed" - inerr=inerr+1 - if(inerr.gt.jerr) then - inerr=1 - endif - removed(inerr)=nyp - goto 200 - endif -! replace one column in qmat by new composition - do je=1,nrel - qmat(je,ie)=dble(xarr(je,nyp)) - enddo -! left side are the known composition - do je=1,nrel - qmat(je,nrel1)=xknown(je) - enddo -! solver, note qmat is destroyed inside lingld, nrel is dimension -! qmat matrix with left hand side as additional column i.e. QMAT(1..ND1,ND2) -! phfrac(ND1) is result array, nz number of unknown, ierr nonzero=error -! do ik=1,nrel1 -! write(*,317)'fm6A: ',(qmat(je,ik),je=1,nrel) -! enddo - call lingld(nrel,nrel1,qmat,phfrac,nrel,ierr) - if(ierr.ne.0) then -! error may occur and are not fatal, just try to replace next column -! write(*,*)'non-fatal error from lingld: ',ierr,nyp - qmat=qmatsave - do i=1,nrel - phfrac(i)=phfsave(i) - enddo - goto 300 - endif -! write(*,*)'fm6B: ',ie,ierr -! write(*,317)'fm6C: ',(phfrac(i),i=1,nrel) -317 format(a,6(1pe12.4)) -!----------------------- -! if solution has only positive values accept this, ierr nonzero if singular - do je=1,nrel - if(phfrac(je).le.phfmin .or. phfrac(je).gt.one) then -! maybe problems if known composition have almost zero of some components? -! restore qmat -! write(*,*)'fm6D: ',je - qmat=qmatsave - do i=1,nrel - phfrac(i)=phfsave(i) - enddo - goto 300 - endif - enddo -! if(trace) write(*,*)'Replaced column: ',ie,nyp -! we have found that column ie should be replaced -!-------------------------------------------------- -! update xmat, qmatsave and gmin -! as we may fail to find the solution for the chemical potentials later -! keep a copy that can be restored - iesave=ie - jsave=jgrid(iesave) -! mark that the replaced gridpoint should be checked again .... -! write(*,*)'25J Putting gridpoint back: ',jgrid(ie) - notuse(jgrid(ie))=0 - jgrid(ie)=nyp - xmatsave=xmat - do je=1,nrel - xmat(je,ie)=xarr(je,nyp) - qmatsave(je,ie)=dble(xarr(je,nyp)) - enddo - gmin(ie)=garr(nyp) -! do ik=1,nrel -! write(*,317)'fm6F: ',(xmat(je,ik),je=1,nrel) -! enddo -! write(*,317)'fm6G: ',(gmin(je),je=1,nrel) -! to solve for the chemical potentials we have ro replace the rows by -! columns, there is a TRANSPOSE command for symmetrical matrices - do ie=1,nrel - do je=1,nrel - zmat(ie,je)=qmatsave(je,ie) - enddo - enddo -! we have changed the solution, calculate new chemical potentials - do je=1,nrel - zmat(je,nrel1)=gmin(je) - enddo -! do ik=1,nrel1 -! write(*,317)'fm8A: ',(zmat(je,ik),je=1,nrel) -! enddo - cmusave=cmu - call lingld(nrel,nrel1,zmat,cmu,nrel,ierr) - if(ierr.ne.0) then -! this should also be handelled by ignoring the new gridpoint but -! here we must restore the xmat, qmatsave and cmu. -! write(*,*)'Failed to calculate chemical potentials',ierr -! if(trace) write(*,*)'Error from LINGLD for chem.pot.: ',ierr,nyp - if(checkremoved) goto 950 - inerr=inerr+1 - if(inerr.gt.jerr) then - inerr=1 - endif - removed(inerr)=nyp - jgrid(iesave)=jsave - cmu=cmusave - xmat=xmatsave - do ie=1,nrel - do je=1,nrel - qmatsave(ie,je)=dble(xmat(ie,je)) - enddo - enddo -! we may have successfully added a removed gridpoint - if(checkremoved) then - goto 950 - endif - goto 200 - endif -! calculate total G -! gvv=zero -! do ie=1,nrel -! do je=1,nrel -! first index is component, second is species -! gvv=gvv+xmat(je,ie)*cmu(je) -! enddo -! enddo -! if(trace) write(*,*)'New total G: ',gvv,gvvp -! check if gvv is lower than previous -! if(gvv.gt.gvvp) then -! write(*,*)' *** Gibbs energy increased, restore!' -! endif -! gvvp=gvv -!---------------------------------------------------------- -! debug output as we have changed one gridpoint -! xtx=zero -! do jjq=1,nrel -! write(*,177)'gpf: ',jgrid(jjq),phfrac(jjq),(xmat(ie,jjq),ie=1,nrel) -! do jjz=1,nrel -! xtx(jjz)=xtx(jjz)+phfrac(jjq)*xmat(jjz,jjq) -! enddo -! enddo -! gvv=zero -! do jjq=1,nrel -! gvv=gvv+xtx(jjq)*cmu(jjq) -! enddo -! write(*,175)'ny4: ',gvv,(cmu(ie),ie=1,nrel) -! write(*,317)'new cmu: ',(cmu(je),je=1,nrel) -! read(*,321)ch1 -!321 format(a) - gy=zero - do ie=1,nrel - gy=gy+xknown(ie)*cmu(ie) - enddo -! write(*,199)griter,gvvp,gy -199 format('25J Gibbs energy changed: ',i5,2(1pe15.6)) - gvvp=gy -! - if(trace) then - write(31,740)griter,nyp -740 format(/'Iteration ',i6,' found gridpoint: ',i6,', new matrix:') - do je=1,nrel - write(31,720),phfrac(je),xknown(je),(xmat(je,ie),ie=1,nrel) - enddo - write(31,730)gvvp,(cmu(je),je=1,nrel) - endif - if(checkremoved) then - write(*,198)nyp -198 format('Added previously removed gridpoint ',i6) - goto 950 - endif -!---------------------------------------------- -! here we go back to loop through all gridpoints again -! write(*,*)'New search: ',griter - goto 200 -!============================================== -900 continue -! write(*,*)'Gridmin has found a solution' -! write(*,316)'fm9A: ',(jgrid(i),i=1,nrel) -! do ik=1,nrel -! write(*,317)'fm9B: ',(xmat(je,ik),je=1,nrel) -! enddo -! write(*,317)'fm9C: ',(garr(je),je=1,nrel) -! write(*,317)'fm9D: ',(cmu(je),je=1,nrel) -! write(*,317)'fm9E: ',(phfrac(je),je=1,nrel) -316 format(a,10i5) - nj=0 -! do j=1,jerr -! if(removed(j).gt.0) then -! write(*,*)'Failed testing gridpoint ',removed(j) -! nj=nj+1 -! endif -! enddo -950 continue - nj=0 - checkremoved=.true. -! write(*,*)'Checking removed gridpoints',inerr -! xtx=zero -! do jjq=1,nrel -! write(*,177)'flp: ',jgrid(jjq),phfrac(jjq),(xmat(ie,jjq),ie=1,nrel) -! do jjz=1,nrel -! xtx(jjz)=xtx(jjz)+phfrac(jjq)*xmat(jjz,jjq) -! enddo -! enddo -! gvv=zero -! do jjq=1,nrel -! gvv=gvv+xtx(jjq)*cmu(jjq) -! enddo -! write(*,175)'cur: ',gvv,(cmu(ie),ie=1,nrel) -!---------------- - testloop: do jj=1,inerr - jp=removed(jj) -! write(*,*)'Checking removed gridpoint: ',jj,jp - if(jp.gt.0) then - gplan=zero - do iel=1,nrel - gplan=gplan+xarr(iel,jp)*cmu(iel) - enddo - dg=garr(jp)-gplan - if(dg.lt.zero) then -! if(trace) write(*,985)jp,dg,garr(jp),gplan -! write(*,982)jp,dg,garr(jp),gplan -982 format('Removed gridpoint ',i5,' is below surface ',3(1pe12.4)) -! try to include it .... - ie=0 - removed(jj)=-jp - nyp=jp - goto 300 - else -! write(*,983)jp,dg -983 format('Removed gridpoint ',i5,' above surface ',1pe12.4) - removed(jj)=-jp - endif - endif - enddo testloop - if(inerr.gt.0 .and. nj.eq.0) then -! if(trace) write(*,986)inerr -986 format('None of the ',i3,' removed gridpoints below final surface') - endif - if(trace) write(*,771)(jgrid(je),je=1,nrel) -771 format('Final set of gridpoints: '(/15i5)) -! xtx=0 -! do iii=1,nrel -! write(*,987)jgrid(iii),phfrac(iii),(xarr(i,jgrid(iii)),i=1,nrel) -!987 format('GP: ',i5,F7.4,2x,6F9.6) -! do j=1,nrel -! xtx(j)=xtx(j)+phfrac(iii)*xarr(j,jgrid(iii)) -! enddo -! enddo -! write(*,988)(xtx(i),i=1,nrel) -!988 format('MF: ',6F9.6) -! -! call chocx('fgme ',nrel,jgrid,phfrac,xmat) -1000 continue - return - end subroutine find_gridmin - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine merge_gridpoints(nv,iphl,aphl,nyphl,yphl,trace,nrel,xsol,cmu,ceq) -! -! BEWARE not adopted for parallel processing -! -! if the same phase occurs several times check if they are really separate -! (miscibility gaps) or if they can be murged. Compare them two by two -! nv is the number of phases, iphl(i) is the index of phase i, aphl(i) is the -! amount of phase i, nyphl is the number of site fractions for phase i, -! and yphl is the site fractions packed together -! - implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq - integer nv,nrel - integer, dimension(*) :: iphl,nyphl - double precision, dimension(*) :: aphl,yphl,cmu - logical trace - real xsol(maxel,*) -!\end{verbatim} - integer i,ip,iph,jp,jump,kk,klast,kp,lokres,nm,jj,mj,lokph,j - integer notuse(nv),incy(nv) - double precision ycheck(maxconst),qq(5),xerr(maxel) - double precision summu,sumam - logical igen - real xmix(maxel) - double precision a1,a2,gdf,gval1,gval2,gval3,gmindif -! -! gmindif is the value to accept to merge two gridpoints -! It should be a variable that can be set by the user for finetuning -! write(*,7)'Merge_gridpoints is dissabled for the moment',nv -!7 format(a,i3) -! NOTE, merging gripoints in ideal phases like gas - goto 1100 - if(ocv()) write(*,*)'Entering merge_gridpoints' -!--------------------- - gmindif=ceq%gmindif - notuse=0 - nm=0 - incy(1)=1 - do i=2,nv - incy(i)=incy(i-1)+nyphl(i-1) - enddo - summu=zero - xerr=zero - do jp=1,nv - summu=summu+aphl(jp) - do i=1,nrel - xerr(i)=xerr(i)+aphl(jp)*xsol(i,jp) - enddo - enddo - write(*,73)'in: ',summu,(xerr(i),i=1,nrel) -73 format(a,F5.2,2x,10f7.4) -!---------------------------------------------- -100 continue - igen=.false. - do jp=1,nv-1 - if(notuse(jp).ne.0) goto 400 - do kp=jp+1,nv - if(notuse(kp).ne.0) goto 300 - if(iphl(jp).eq.iphl(kp)) then - iph=iphl(jp) -! write(*,9876)'XP1: ',jp,(xsol(i,jp),i=1,nrel) -! write(*,9876)'XP2: ',kp,(xsol(i,kp),i=1,nrel) -9876 format(a,i4,5(1pe12.4)) -! same phase in two points, see if they are really separate -! the test is simple, just calculate the Gibbs energy at the weighted -! average and if that has lower gibbs energy then merge them -! write(*,130)'c130: ',jp,incy(jp),nyphl(jp),kp,incy(kp),nyphl(kp) -130 format(a,10i5) -! write(*,140)incy(jp),(yphl(incy(jp)+j),j=0,nyphl(jp)-1) -140 format(i4,6(1pe12.4)) - call set_constitution(iph,1,yphl(incy(jp)),qq,ceq) - if(gx%bmperr.ne.0) goto 1000 - call calcg(iph,1,0,lokres,ceq) - if(gx%bmperr.ne.0) goto 1000 - gval1=ceq%phase_varres(lokres)%gval(1,1)/qq(1) -! debug - call calc_phase_mol(iph,xerr,ceq) -! write(*,79)'Y0: ',(yphl(incy(jp)+i-1),i=1,nyphl(jp)) -! write(*,79)'X1: ',(xerr(i),i=1,nrel) -! write(*,79)'X2: ',(xsol(i,jp),i=1,nrel) -79 format(a,12(F6.3)) -! Subtract the solution, the result should be zero ?? -! The mole fractions of the gridpoints in solution is in xsol(1,jgrid(i)) - summu=zero - do jj=1,nrel - summu=summu+xsol(jj,jp)*cmu(jj) - enddo - gval1=gval1-summu -! debug output gridpoint 1 - mj=nyphl(jp)-1 -! write(*,820)'GP1:',gval1,summu,aphl(jp),(yphl(incy(jp)+jj),jj=0,mj) -820 format(a,3(1pe10.2),10(0pF5.2)) - call set_constitution(iph,1,yphl(incy(kp)),qq,ceq) - if(gx%bmperr.ne.0) goto 1000 - call calcg(iph,1,0,lokres,ceq) - if(gx%bmperr.ne.0) goto 1000 - gval2=ceq%phase_varres(lokres)%gval(1,1)/qq(1) -! Subtract the solution -! The mole fractions of the gridpoints in solution is in xsol(1,jgrid(i)) - summu=zero - do jj=1,nrel - summu=summu+xsol(jj,kp)*cmu(jj) - enddo - gval2=gval2-summu -! debug output gridpoint 2 -! write(*,820)'GP2:',gval2,summu,aphl(kp),(yphl(incy(kp)+jj),jj=0,mj) -! select the middle point -! Not very good weight by phase amounts if one has 95% FCC and 5 % MC .... -! take weighted sum of composition in the middle - a1=5.0D-01 - a2=5.0D-01 -! sumam=aphl(jp)+aphl(kp) -! a1=aphl(jp)/sumam -! a2=aphl(kp)/sumam -! SURPRISE: adding together constituent fractions does not reproduce -! the correct molefractions if the constituents are molecules .... - do i=1,nyphl(jp) - ycheck(i)=a1*yphl(incy(jp)+i-1)+a2*yphl(incy(kp)+i-1) - enddo - call set_constitution(iph,1,ycheck,qq,ceq) - if(gx%bmperr.ne.0) goto 1000 - call calcg(iph,1,0,lokres,ceq) - if(gx%bmperr.ne.0) goto 1000 - gval3=ceq%phase_varres(lokres)%gval(1,1)/qq(1) -! Check if this is below the current tangent plane -! The mole fractions of the gridpoints in solution is in xsol(1,jgrid(i)) - summu=zero - do jj=1,nrel - xmix(jj)=a1*xsol(jj,jp)+a2*xsol(jj,kp) - summu=summu+xmix(jj)*cmu(jj) - enddo -! write(*,21)'summu: ',a1,a2,qq(1),gval3,summu,gmindif - gval3=gval3-summu -21 format(a,6(1pe12.4)) - write(*,22)'dg: ',gval3,gval1,gval2,0.5*gval1+0.5*gval2 -22 format(a,6(1pe12.4)) -! debug output mix - write(*,820)'GPY:',gval3,summu,qq(1),(ycheck(jj+1),jj=0,mj) - write(*,820)'GPX:',gval3,summu,qq(1),(xmix(jj),jj=1,nrel) - gdf=gval3-a1*gval1-a2*gval2 -! gdf=gval3 -! merge require that difference is less than gmindif or phase ideal -! allways merge ideal phase as it never has miscibility gaps !!! - lokph=phases(iph) - if(gdf.lt.gmindif .or. & - btest(phlista(lokph)%status1,PHID)) then -! gridpoint in between has lower G, merge - write(*,830)'merged: ',jp,kp,gdf,iphl(jp),& - aphl(jp)+aphl(kp) -830 format('Gridpoints ',a,2i3,1pe15.4,' in phase ',i3,1pe12.4) -! write(*,840)jp,(xsol(jj,jp),jj=1,nrel) -! write(*,840)kp,(xsol(jj,kp),jj=1,nrel) -! write(*,840)jp,(xmix(jj),jj=1,nrel) -840 format('x: ',i5,10(F7.4)) -! If merging use correct phase amounts - a1=aphl(jp)/(aphl(jp)+aphl(kp)) - a2=aphl(kp)/(aphl(jp)+aphl(kp)) -! write(*,160)iph,jp,kp,incy(jp),nyphl(jp),gdf,& -! gval1,gval2,gval3,a1,a2 -160 format('Merging: ',i3,2x,4i5,1pe12.4/5(1pe12.4)) - write(*,162)'p1:',a1,(yphl(incy(jp)+j),j=0,nyphl(jp)-1) -162 format(a,F5.2,2x,(10f7.4)) - write(*,162)'p2:',a2,(yphl(incy(kp)+j),j=0,nyphl(kp)-1) -! The gridpoint jp has new amount, composition and constitution -! SURPRISE: adding together constituent fractions does not reproduce -! the correct molefractions if the constituents are molecules .... - aphl(jp)=aphl(jp)+aphl(kp) - do i=0,nyphl(jp)-1 - yphl(incy(jp)+i)=a1*yphl(incy(jp)+i)+a2*yphl(incy(kp)+i) - enddo - call set_constitution(iph,1,yphl(incy(jp)),qq,ceq) - if(gx%bmperr.ne.0) goto 1000 -! extract correct mole fractions - call calc_phase_mol(iph,xerr,ceq) - write(*,162)'ym:',0.0D0,(yphl(incy(jp)+i),i=0,nyphl(jp)-1) - write(*,162)'xj:',0.0D0,(xsol(jj,jp),jj=1,nrel) - write(*,162)'xk:',0.0D0,(xsol(jj,kp),jj=1,nrel) - write(*,162)'xy:',0.0D0,(xerr(i),i=1,nrel) - do i=1,nrel - xsol(i,jp)=xerr(i) - enddo - igen=.true. - nm=nm+1 - iphl(kp)=-iphl(kp) - notuse(kp)=1 -! check overall composition of solution ... - summu=zero - xerr=zero - do i=1,nrel - if(iphl(i).lt.0) cycle - summu=summu+aphl(i) - write(*,*)'point: ',i,aphl(i) - do jj=1,nrel - xerr(jj)=xerr(jj)+aphl(i)*xsol(jj,i) - enddo - enddo - write(*,73)'nu: ',summu,(xerr(jj),jj=1,nrel) -! the chemical potentials has changed but how? Approximate the change by -! making gmindif more negative for each merge (does not affect ideal phases) - gmindif=2.0D0*gmindif -! after merging always restart loop - goto 100 - else - write(*,830)'not merged: ',jp,kp,gdf,iphl(jp),gmindif - endif - endif -300 continue - enddo -400 continue - enddo -! if two gridpoints merged compare all again - if(igen) goto 100 -!---------------------------------------- -! shift fractions for the removed phases -450 continue -! write(*,*)'at label 450: ',nm - klast=0 - do jp=1,nv - klast=klast+nyphl(jp) - enddo -! -! uncomment listing here if error moving fractions -! write(*,502)nv,(iphl(i),i=1,nv) -! write(*,502)0,(incy(i),i=1,nv) -! write(*,502)klast,(nyphl(i),i=1,nv) -502 format('check1: ',i3,2x,20i4) -! kk=0 -! do j=1,nv -! write(*,510)j,(yphl(i),i=kk+1,kk+nyphl(j)) -! kk=kk+nyphl(j) -! enddo -! - kk=0 - jp=1 - do while(jp.lt.nv) - if(iphl(jp).lt.0) then -! shift all fractions down. klast should be updated each shift but ... - jump=nyphl(jp) -! write(*,503)jp,kk,klast,jump -503 format('check3: ',5i5) -! write(*,555)'nyy1: ',(yphl(ip),ip=kk+1,kk+jump) -555 format(a,6(1pe12.4)) - do ip=kk+1,klast-jump - yphl(ip)=yphl(ip+jump) - enddo -! write(*,555)'nyy2: ',(yphl(ip),ip=kk+1,kk+jump) - do kp=jp,nv-1 - iphl(kp)=iphl(kp+1) - aphl(kp)=aphl(kp+1) - nyphl(kp)=nyphl(kp+1) - enddo - nv=nv-1 - else - kk=kk+nyphl(jp) - jp=jp+1 - endif -500 continue - enddo - if(iphl(nv).lt.0) nv=nv-1 -! -! uncomment here if problems shifting fractions -! write(*,502)nv,(iphl(i),i=1,nv) -! write(*,502)0,(incy(i),i=1,nv) -! write(*,502)klast,(nyphl(i),i=1,nv) -! kk=0 -! do j=1,nv -! write(*,510)j,(yphl(i),i=kk+1,kk+nyphl(j)) -! kk=kk+nyphl(j) -! enddo -! if there are two or more gripoints in the same phase we have a -! miscibility gap and may have to create miscibility gaps. -! -! >>>> unfinished -! -510 format(i3,':',6(1pe12.4)) -1000 continue - if(ocv()) write(*,*)'At return from merge_gridpoints: ',nv - return -!------------------------------------------ -! emergency fix to avoid creating several composition sets in ideal phases -1100 continue - nm=0 - notuse=0 - incy(1)=1 - do i=2,nv - incy(i)=incy(i-1)+nyphl(i-1) - enddo -1110 continue - igen=.FALSE. - do jp=1,nv-1 - do kp=jp+1,nv - if(notuse(kp).ne.0) cycle - if(iphl(jp).eq.iphl(kp)) then - iph=iphl(jp) - lokph=phases(iph) - if(btest(phlista(lokph)%status1,PHID)) then -! add together gridpoints in ideal phases (gas) -! write(*,*)'merging gridpoints in ideal phase' - sumam=aphl(jp)+aphl(kp) - a1=aphl(jp)/sumam - a2=aphl(kp)/sumam - aphl(jp)=aphl(jp)+aphl(kp) -! write(*,1117)'25J: ',jp,(yphl(incy(jp)+i),i=0,nyphl(jp)-1) -! write(*,1117)'25J: ',kp,(yphl(incy(kp)+i),i=0,nyphl(kp)-1) - do i=0,nyphl(jp)-1 - yphl(incy(jp)+i)=a1*yphl(incy(jp)+i)+a2*yphl(incy(kp)+i) - enddo -! write(*,1117)'25J: ',jp,(yphl(incy(jp)+i),i=0,nyphl(jp)-1) -1117 format(a,i3,6(1pe12.4)) - notuse(kp)=1 - igen=.TRUE. - nm=nm+1 - iphl(kp)=-iphl(kp) - endif - endif - enddo - enddo - if(igen) goto 1110 - if(nm.eq.0) goto 1000 - goto 450 -! - end subroutine merge_gridpoints - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine set_metastable_constitutions(ngg,nrel,kphl,ngrid,xarr,garr,& - nr,iphl,cmu,ceq) -! this subroutine goes through all the metastable phases -! after a global minimization and sets the constituion to the most -! favourable one. Later care should be taken that composition set 2 -! and higher are not set identical or equal to the stable -! kp total number of gridpoints -! nrel number of components -! ngg number of gridpoints -! kphl array with first points calculated for phase(i) in garr -! ngrid array with last points calculated for phase(i) in garr -! garr array with Gibbs energy/RT for each gridpoint -! xarr matix with composition in all gridpoints -! nr is the number of stable phases in the solution -! iphl array with the phase numbers of the stable phases (not ordered) -! cmu are the chemical potentials/RT of the solution -! ceq equilibrium record -! called by global_gridmin - implicit none - integer ngg,nrel,nr - integer, dimension(*) :: kphl,ngrid,iphl - double precision, dimension(*) :: cmu - real garr(*),xarr(nrel,*) - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer ig1,ign,ip,iph,ics,jph,lokcs,lokph,mode,ny,ie,ig - double precision yarr(maxconst),qq(5),xxx,dgmin - real dg,gplan - if(ocv()) write(*,*)'Entering set_metastable' -! loop through the gridpoints for all unstable phases and insert the -! stable constitution that is closest to be stable -! write(*,7)'set_meta: ',kp,nrel,nr,(iphl(i),i=1,nr) -!7 format(a,i9,2i4,2x,10i3) -! do i=1,noofph -! write(*,*)'grid: ',i,kphl(i),ngrid(i) -! enddo - phloop: do iph=1,noofph - do jph=1,nr - if(iph.eq.iphl(jph)) goto 500 - enddo - call get_phase_record(iph,lokph) - if(gx%bmperr.ne.0) goto 1000 -! check if all composition sets are suspended - do ics=1,phlista(lokph)%noofcs - call get_phase_compset(iph,ics,lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 -! new -4 hidden, -3 susp, -2 dorm, -1,0,1 entered, 2 fixed - if(test_phase_status(iph,ics,xxx,ceq).ge.PHENTUNST) goto 60 - enddo - cycle -! this phase is not suspended and not stable, find gridpoints -60 continue - ig1=kphl(iph) - ign=ngrid(iph) - if(ocv()) write(*,69)'Searching gridpoints for: ',iph,ics,ig1,ign -69 format(a,2(i3,1x),2x,3(i6,1x)) -! if ig1=0 there are no gridpoints for this phase, it is suspended or dormant - if(ig1.le.0) cycle - dgmin=-1.0d12 - ip=0 -! search for gripoint closeset to stable plane - do ig=ig1,ign - gplan=zero - do ie=1,nrel - gplan=gplan+xarr(ie,ig)*cmu(ie) - enddo - dg=gplan-garr(ig) -! write(*,74)'dgx: ',ig,dg,dgmin,(xarr(i,ig),i=1,nrel) -!74 format(a,i5,2(1pe12.4),2x,6(0pf7.4)) - if(dg.gt.dgmin) then - ip=ig - dgmin=dg -! write(*,77)'lower: ',ig,gplan,garr(ig),dg,dgmin -!77 format(a,i7,4(1pe12.4)) - endif - enddo - if(ocv()) write(*,79)'Least unstable gridpoint: ',iph,ics,ig1,ign,dgmin -79 format(a,4(i6,1x),1pe12.4) -! if(ip.eq.0 .or. dgmin.gt.zero) then -! write(*,*)'This gridpoint stable: ',ip,dgmin -! write(*,*)'data: ',ip,dgmin -! endif -! retrieve constitution for this gridpoint and insert it in phase -! must provide mode and iph. The subroutine returns ny and yarr -! mode is the gridpoint in the phase, subtract ig1-1 - mode=ip-ig1+1 -! - if(ocv()) write(*,78)'calling gengrid: ',iph,ig1,ip,ign,mode,dgmin -78 format(a,5i7,1pe12.4) -! find the constitution of this gridpoint - call generate_grid(mode,iph,ign,nrel,xarr,garr,ny,yarr,ceq) - if(gx%bmperr.ne.0) goto 1000 -! write(*,451)(yarr(i),i=1,ny) -451 format('fractions: ',6(F10.6)) - call set_constitution(iph,1,yarr,qq,ceq) - if(gx%bmperr.ne.0) goto 1000 -! write(*,452)iph,ics,(yarr(i),i=1,ny) -452 format('my: ',2i2,6(1pe10.3)) -! set driving force also ... - call set_driving_force(iph,1,dgmin,ceq) -500 continue - enddo phloop -1000 continue - if(ocv()) write(*,*)'Finished set_metastable' - return - end subroutine set_metastable_constitutions - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatiom} - subroutine gridmin_check(nystph,kp,nrel,xarr,garr,xknown,ngrid,pph,& - cmu,yphl,iphx,ceq) -! This subroutine checks if a calculated solution is correct by -! checking if there are any gridpoints below the surface defined -! by the chemical potentials cmu -! nystph return 0 or 10*(phase number)+compset number for new stable phase -! there are kp gridpoints, nrel is number of components -! composition of each gridpoint in xarr, G in garr -! xknown is the known overall composition -! ngrid is last calculated gridpoint point for a phase jj -! pph is number of phases for which there is a grid -! iphx is phase numbers -! cmu are the final chemical potentials -! yphl is just needed as a dummy -! ceq is current equilibrium record -!\end{verbatiom} - implicit none - integer kp,nrel,jp,ie,mode,pph,nystph - double precision, parameter :: phfmin=1.0D-8 - real xarr(nrel,*),garr(*) - double precision xknown(*) - integer, dimension(*) :: ngrid,iphx - double precision cmu(*),gsurf,gstable,gd,yphl(*),qq(5),rtn,gdmin - TYPE(gtp_equilibrium_data), pointer :: ceq - integer lokph,lokcs,zph,ibias,ics,iph,ny -! setting a value of addph forces that gridpoint to be added, used for test -! integer :: addph=8 -! integer :: addph=100 - integer :: addph=0 - save addph -! - write(*,*)'Entering gridmin_check',addph - gstable=zero - nystph=0 - mode=0 - rtn=globaldata%rgas*ceq%tpval(1) - gdmin=-1.0D5 - do jp=1,kp - gsurf=zero - do ie=1,nrel - gsurf=gsurf+xarr(ie,jp)*cmu(ie) - enddo - gsurf=gsurf/rtn -! If garr(jp) more negative than gsurf (gd>0) this gridpoint is stable -! mixing real and double precision is not a numerical problem here - gd=gsurf-garr(jp) - if(gd.gt.gdmin) gdmin=gd -! write(*,17)'grid comarison: ',gd,garr(jp),gsurf -!17 format(a,3(1pe12.4)) - if(gd.gt.gstable) then -! this gridpoint should be set as stable and recalculate - gstable=gd - mode=jp - endif - enddo -! if mode nonzero there is a gridpoint below the calculated surface -! just for test using the FeOUZr case set mode=25, that should be in liquid -! just for test using the FeOUZr case set mode=7, that should be O2 in gas - mode=addph - addph=0 - if(mode.gt.0) then -! we have to find which phase it is, this strange loop should find that - ibias=0 - do zph=1,pph -! ngrid(zph) is the first gridpoints of phase zph - if(mode.le.ngrid(zph)) then - mode=mode-ibias - goto 115 - else - ibias=ngrid(zph) - endif - enddo -115 continue -! write(*,*)'mode, ibias and phase: ',mode,ibias,iphx(zph) - call generate_grid(mode,iphx(zph),ibias,nrel,xarr,garr,ny,yphl,ceq) - if(gx%bmperr.ne.0) goto 1000 - iph=iphx(zph) - write(*,*)'Gridmin check found new stable phase: ',iph -!------------------- -! new stable phase is iph, constituent fractions in yphl -! check if compset 1 of phase is already stable, if so maybe create compset - lokph=phases(iph) - lokcs=phlista(lokph)%linktocs(1) - ics=1 -200 continue - if(ceq%phase_varres(lokcs)%dgm.lt.zero) then -! this composition set not stable, set it as stable with fractions yphl -! finetunig needed here .... - ceq%phase_varres(lokcs)%dgm=zero -! strange, new calculation failed with small amount but worked with a lot ... -! ceq%phase_varres(lokcs)%amount(1)=one - ceq%phase_varres(lokcs)%amfu=one - write(*,222)iph,ics,ny,(yphl(ie),ie=1,ny) -222 format('added: ',3i3,10(f6.3)) - call set_constitution(iph,ics,yphl,qq,ceq) - else - ics=ics+1 - if(ics.gt.phlista(lokph)%noofcs) then -! create new composition set if allowed - if(btest(globaldata%status,GSNOACS)) then - gx%bmperr=4177; goto 1000 - endif - write(*,*)'Creating new composition set for ',iph -! call add_composition_set(iph,' ','AUTO',ics,ceq) - call add_composition_set(iph,' ','AUTO',ics) - if(gx%bmperr.ne.0) goto 1000 -! link to new compositiin set stored here -! set a negative zero driving force - lokcs=phlista(lokph)%linktocs(ics) - ceq%phase_varres(lokcs)%dgm=-one - else - lokcs=phlista(lokph)%linktocs(ics) - endif -! jump back to label 200 to test if this composition set is free - goto 200 - endif - nystph=10*iph+ics - else -! no new phase found, just to see some values - write(*,*)'DG at least unstable gridpoint: ',gdmin - endif -1000 continue - return - end subroutine gridmin_check - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ -!> 18. Miscellaneous -!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ - -!\begin{verbatim} - integer function phvarlok(lokph) -! return index of the first phase_varres record for phase with location lokph -! needed for external routines as phlista is private - implicit none - integer lokph -!\end{verbatim} - phvarlok=phlista(lokph)%linktocs(1) - return - end function phvarlok - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine palmtree(lokph) -! Initiates a numbering of all interaction trees of an endmember of a phase - implicit none - integer lokph -!\end{verbatim} - integer seq,level - type(gtp_endmember), pointer :: endm - type(gtp_interaction), pointer :: intrec - type stack - type(gtp_interaction), pointer :: p1 - end type stack - type(stack), dimension(5) :: int_stack - logical both - both=.false. - endm=>phlista(lokph)%ordered -70 continue - emloop:do while(associated(endm)) - intrec=>endm%intpointer - seq=0 - level=0 -100 continue - do while(associated(intrec)) - level=level+1 - if(level.gt.5) then - write(*,*)'Interaction more than 5 levels deep!' - gx%bmperr=7777; goto 1000 - endif - int_stack(level)%p1=>intrec - seq=seq+1 - intrec%order=seq - intrec=>intrec%highlink - enddo - if(level.gt.0) then - intrec=>int_stack(level)%p1 - level=level-1 - intrec=>intrec%nextlink - goto 100 - endif - endm=>endm%nextem - enddo emloop - if(.not.both .and. associated(phlista(lokph)%disordered)) then - endm=>phlista(lokph)%disordered - both=.true. - goto 70 - endif -1000 continue - return - end subroutine palmtree - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - logical function allowenter(mode) -! Check if certain commands are allowed -! mode=1 means entering an element or species -! mode=2 means entering a phase -! mode=3 means entering an equilibrium -! returns TRUE if command can be executed - implicit none - integer mode -!\end{verbatim} -! write(*,*)'In allowenter: ',mode - logical yesorno - yesorno=.FALSE. - if(mode.le.0 .or. mode.gt.3) goto 1000 - if(mode.eq.1) then -! enter element of species not allowed after entering first phase - if(noofph.gt.1) goto 1000 - yesorno=.TRUE. - elseif(mode.eq.2) then -! enter phases of a disordred fraction set not allowed -! if there are no elements or after entering a second equilibrium -! write(*,*)'25J allowenter ',mode,noofel,eqfree,noofph - if(noofel.eq.0) goto 1000 - if(eqfree.gt.2) goto 1000 - yesorno=.TRUE. - elseif(mode.eq.3) then -! there must be at lease one phase before entering a second equilibrium -! Note this is tested also for entering the default equilibrium -! write(*,*)'25J mode 3: ',eqfree,noofph - if(eqfree.ge.2 .and. noofph.eq.0) goto 1000 - yesorno=.TRUE. - endif -1000 continue - allowenter=yesorno -! write(*,*)'25J: allowenter:',yesorno,mode - return - end function allowenter - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - logical function proper_symbol_name(name,typ) -! checks that name is a proper name for a symbol -! A proper name must start with a letter A-Z -! for typ=0 it must contain only letters, digits and underscore -! for typ=1 it may contain also +, - maybe ? - implicit none - integer typ - character name*(*) -!\end{verbatim} - character name2*64,ch1*1 - integer jl - logical korrekt -! write(*,*)'25J entering proper_symbol_name: ',name,typ - korrekt=.FALSE. - if(typ.lt.0 .or. typ.gt.0) then - gx%bmperr=4139; goto 1000 - endif - name2=name - call capson(name2) - if(.not.ucletter(name2(1:1))) then -! the first character of a symbol must always be a letter A-Z -! write(*,*)'Wrong first letter of symbol: ',name2(1:1),':',name2(1:5) - gx%bmperr=4137; goto 1000 - endif - jl=1 -100 continue - jl=jl+1 - ch1=name2(jl:jl) -! always finish when fining a space - if(ch1.eq.' ') then - korrekt=.TRUE. - name(jl:)=' ' - goto 1000 - endif - if(typ.eq.0) then - if(ch1.ge.'0' .and. ch1.le.'9') goto 100 - if(ch1.ge.'A' .and. ch1.le.'Z') goto 100 - if(ch1.eq.'_') goto 100 - gx%bmperr=4138 -! else -! unknown type of symbol -! gx%bmperr=4139 - endif -! -1000 continue -! - proper_symbol_name=korrekt - return - end function proper_symbol_name - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!-\begin{verbatim} - subroutine list_free_lists(lut) -! for debugging the free lists and routines using them - implicit none - integer lut -!-\end{verbatim} - integer lok,last - write(lut,1007)noofel,noofsp,noofph,noofem,noofint,noofprop,& - notpf(),csfree-1,eqfree-1,nsvfun,reffree-1,addrecs -1007 format('Records for elements, species, phases: ',3i5/& - 'end members, interactions, properties: ',3i5/& - 'TP-funs, composition sets, equilibria: ',3i5/& - 'state variable functions, references, additions: ',3i5) -!---------------------------- -! csfree, free list is in firsteq -600 continue - write(lut,610)csfree,highcs -610 format('Phase_varres free list: ',2i5) - if(csfree.lt.highcs) then - lok=csfree -620 continue - last=lok - lok=firsteq%phase_varres(last)%nextfree - write(*,*)'csfree: ',last,lok - if(lok.le.0 .or. lok.gt.highcs) then - write(lut,*)'Error in phase_varres free list',last,lok - goto 1000 - elseif(lok.eq.highcs) then - goto 630 - else - goto 620 - endif - endif -! no more -630 continue -1000 continue - return - end subroutine list_free_lists - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine enter_default_constitution(iph,ics,mmyfr,ceq) -! user specification of default constitution for a composition set - implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq - integer iph,ics - real mmyfr(*) -!\end{verbatim} - integer lokph,lokcs,jl,jk - call get_phase_compset(iph,ics,lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 - jk=size(ceq%phase_varres(lokcs)%yfr) -! write(*,909)lokph,lokcs,phlista(lokph)%tnooffr,ceq%eqno,& -! size(ceq%phase_varres),size(ceq%phase_varres(lokcs)%mmyfr),jk -909 format('25J 2699: ',10i4) -! write(*,46)'25J y: ',(ceq%phase_varres(lokcs)%yfr(jl),jl=1,jk) -46 format(a,10(F7.3)) - do jl=1,phlista(lokph)%tnooffr - ceq%phase_varres(lokcs)%mmyfr(jl)=mmyfr(jl) -! write(*,47)'25J jl: ',jl,mmyfr(jl),& -! firsteq%phase_varres(lokcs)%mmyfr(jl),& -! ceq%phase_varres(lokcs)%mmyfr(jl) - enddo -47 format(a,i2,10F7.3) -! set bit indicating that this composition set has a default constitution -! write(*,*)'25J enter_default_constitution?? ',lokcs - ceq%phase_varres(lokcs)%status2=& - ibset(ceq%phase_varres(lokcs)%status2,CSDEFCON) -1000 continue - return - end subroutine enter_default_constitution - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine set_phase_amounts(jph,ics,val,ceq) -! set the amount formula units of a phase. Called from user i/f -! iph can be -1 meaning all phases, all composition sets - implicit none - integer jph,ics - double precision val - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer iph,lokph,lokcs - double precision amount - if(jph.lt.0) then - iph=1; ics=1 - else - iph=jph - endif - call get_phase_compset(iph,ics,lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 -100 continue - if(test_phase_status(iph,ics,amount,ceq).gt.3) goto 700 -! ceq%phase_varres(lokcs)%amount(1)=val - ceq%phase_varres(lokcs)%amfu=val -700 continue - if(jph.lt.0) then - ics=ics+1 -710 continue - call get_phase_compset(iph,ics,lokph,lokcs) - if(gx%bmperr.ne.0) then - gx%bmperr=0; - iph=iph+1 - if(iph.gt.noofph) goto 1000 - ics=1; goto 710 - endif - goto 100 - endif -1000 continue - return - end subroutine set_phase_amounts - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine set_as_default_constitution(jph,ics,all,ceq) -! set the current constitution of jph to its default constitution -! jph can be -1 meaning all phases, all composition sets -! if all=-1 then change constitution of all phases, else just those not stable -! do not change the amounts of the phases - implicit none - integer all,jph,ics - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} %+ -! This has been changed so it calls set_constitution !!!! - integer iph,lokph,lokcs,ky,kz,ll,n1,n2,n3,jl - double precision kvot1,kvot2,amount,rest,qq(5) - double precision, dimension(:), allocatable :: yy -! - if(jph.lt.0) then - iph=1; ics=1 - else - iph=jph - endif - call get_phase_compset(iph,ics,lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 -100 continue - if(test_phase_status(iph,ics,amount,ceq).gt.3) goto 700 -! do not change the constitution of stable phases ?? -! if(ceq%phase_varres(lokcs)%amount(1).gt.zero .and. all.ge.0) goto 700 - if(ceq%phase_varres(lokcs)%amfu.gt.zero .and. all.ge.0) goto 700 -! mmyfr defines min or max default values of each constituent -! if negative it is a min value, positive is a max value, zero means no default -! It is also used to select the composition set that should be used -! when a new composition set is needed during a calculation, for example -! if an FCC phase that could be an austenite (low carbon content) or a -! cubic carbo-nitride (high carbon or nitrogen content) - allocate(yy(phlista(lokph)%tnooffr)) - ky=0 - subl: do ll=1,phlista(lokph)%noofsubl - kz=ky - n1=0 - n2=0 - n3=0 - rest=zero - do jl=1,phlista(lokph)%nooffr(ll) - ky=ky+1 - yy(ky)=zero -! ceq%phase_varres(lokcs)%yfr(ky)=zero - if(ceq%phase_varres(lokcs)%mmyfr(ky).lt.zero) then -! if mmyfr(kk) is negative the value is a maximal value (normal -1.0D-3) -! Set fraction 1/10 of this - yy(ky)=0.1D0*abs(ceq%phase_varres(lokcs)%mmyfr(ky)) -! ceq%phase_varres(lokcs)%yfr(ky)=0.1D0*& -! abs(ceq%phase_varres(lokcs)%mmyfr(ky)) - n1=n1+1 - elseif(ceq%phase_varres(lokcs)%mmyfr(ky).gt.zero) then -! if mmyfr(kk) is positive the value is a minimal value (normal 0.5) -! Note that several constituents can have a minimal value and the total -! of these can be larger than unity -! ceq%phase_varres(lokcs)%yfr(ky)=one - yy(ky)=one - n2=n2+1 - else -! ceq%phase_varres(lokcs)%yfr(ky)=one - yy(ky)=one - n3=n3+1 - endif - enddo -! write(*,117)'yt: ',ky-kz,(ceq%phase_varres(lokcs)%yfr(j),j=kz+1,ky) -117 format(a,i2,9(F8.4)) -! for normallizing. The idea is that sum of fractions with min should be 0.9 -! and sum of fractions with max should be summin and constituents with -! no default should be 1-0.9*summax-summin - kvot1=one - if(n1.gt.0) then - kvot1=one/dble(n1) - endif - kvot2=one - rest=one - if(n2.gt.0) then - if(n3.gt.0) then - kvot2=0.9D0/dble(n2) - rest=0.1D0/dble(n3) - else - kvot2=one/dble(n2) - endif - elseif(n3.gt.0) then - rest=one/dble(n3) - endif -! write(*,17)'sums: ',ky-kz,kvot1,kvot2,rest -17 format(a,i3,6(1pe12.4)) -! It is not necessary that the sum of fractions is unity, it will be -! normallized before used in a calculation. - do jl=1,phlista(lokph)%nooffr(ll) - kz=kz+1 - if(ceq%phase_varres(lokcs)%mmyfr(kz).lt.zero) then -! ceq%phase_varres(lokcs)%yfr(kz)=kvot1*& -! ceq%phase_varres(lokcs)%yfr(kz) - yy(kz)=kvot1*yy(kz) - elseif(ceq%phase_varres(lokcs)%mmyfr(kz).gt.zero) then -! ceq%phase_varres(lokcs)%yfr(kz)=kvot2*& -! ceq%phase_varres(lokcs)%yfr(kz) - yy(kz)=kvot2*yy(kz) - else - yy(kz)=rest - endif - enddo - enddo subl -! write(*,117)'mm: ',kz,(ceq%phase_varres(lokcs)%mmyfr(j),j=1,kz) -! write(*,117)'yd: ',kz,yy(j),j=1,kz) - call set_constitution(iph,ics,yy,qq,ceq) - if(gx%bmperr.ne.0) goto 1000 -! jump here if phase skipped -700 continue - if(jph.lt.0) then - ics=ics+1 -710 continue - call get_phase_compset(iph,ics,lokph,lokcs) - if(gx%bmperr.ne.0) then - gx%bmperr=0; - iph=iph+1 - if(iph.gt.noofph) goto 1000 - ics=1; goto 710 - endif - goto 100 - endif -1000 continue - if(allocated(yy)) deallocate(yy) - return - end subroutine set_as_default_constitution - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine set_default_constitution(iph,ics,ceq) -! set the current constitution of iph composition set ics to its -! default constitution. Do not change the amounts of the phases - implicit none - integer iph,ics - TYPE(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer lokph,lokcs,ll,jj,kk,kk0 - type(gtp_phase_varres), pointer :: cset - double precision, allocatable :: yarr(:) - double precision sum, qq(5) -! - call get_phase_compset(iph,ics,lokph,lokcs) - if(gx%bmperr.ne.0) goto 1000 - cset=>ceq%phase_varres(lokcs) -! we must use set_constitution at the end to update various internal variables - allocate(yarr(phlista(lokph)%tnooffr)) - if(allocated(cset%mmyfr)) then -! there is a preset default constitution - kk=0 - subl1: do ll=1,phlista(lokph)%noofsubl - kk0=kk - sum=zero - if(phlista(lokph)%nooffr(ll).gt.1) then - do jj=1,phlista(lokph)%nooffr(ll) -! mmy(kk) is negative for small fractions with a maxium, set to 0.01 - kk=kk+1 - if(cset%mmyfr(kk).lt.0.0E0) then - yarr(kk)=0.01D0 - else - yarr(kk)=one - endif - sum=sum+yarr(kk) - enddo - kk=kk0 -! the sum of fractions should be unity, hm done in set_constitution also ... - do jj=1,phlista(lokph)%nooffr(ll) -! mmy(kk) is negative for small fractions with a maxium, set to 0.01 - kk=kk+1 - yarr(kk)=yarr(kk)/sum - enddo - else -! a single constituent, just increment kk and leave fraction as unity - kk=kk+1 - yarr(kk)=one - endif - enddo subl1 - else - kk=0 - subl2: do ll=1,phlista(lokph)%noofsubl - if(phlista(lokph)%nooffr(ll).gt.1) then -! set equal amount of all fractions - sum=one/real(phlista(lokph)%nooffr(ll)) - do jj=1,phlista(lokph)%nooffr(ll) - kk=kk+1 - yarr(kk)=sum - enddo - else -! a single constituent, just increment kk and leave fraction as unity - kk=kk+1 - yarr(kk)=one - endif - enddo subl2 - endif -! write(*,411)yarr -411 format('25J set_def_const: ',8F7.4,(10f7.4)) -! make the sum of fractions in each sublattice unity - call set_constitution(iph,ics,yarr,qq,ceq) -1000 continue - return - end subroutine set_default_constitution - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine todo_before(mode,ceq) -! this could be called before an equilibrium calculation -! It should remove any phase amounts and clears CSSTABLE -! DUMMY -! - implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq - integer mode -!\end{verbatim} - integer iph,ics,lokph,lokcs -! -! write(*,*)'Todo_before ... not implemented' - goto 1000 -! - phloop: do iph=1,noph() - lokph=phases(iph) -! skip hidden phases - if(btest(phlista(lokph)%status1,PHHID)) cycle -300 csloop: do ics=1,phlista(lokph)%noofcs - lokcs=phlista(lokph)%linktocs(ics) -! ceq%phase_varres(lokcs)%amount(1)=zero - ceq%phase_varres(lokcs)%amfu=zero - ceq%phase_varres(lokcs)%status2=& - ibclr(ceq%phase_varres(lokcs)%status2,CSSTABLE) - enddo csloop - enddo phloop -! -1000 continue - return - end subroutine todo_before - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine todo_after_found_equilibrium(mode,ceq) -! this is called after an equilibrium calculation -! It marks stable phase (set CSSTABLE and remove any CSAUTO) -! remove redundant unstable composition sets created automatically -! (CSAUTO set). It will also shift stable composition sets to loweest -! possible (it will take into account if there are default constituent -! fractions, CSDEFCON set). -! mode determine some of the actions -! -! >>>>>>>>>>> THIS IS DANGEROUS IN PARALLELL PROCESSING -! It should work in step and map as a composition set that once been stable -! will never be removed except if one does global minimization during the -! step and map. Then metallic-FCC and MC-carbides may shift composition sets. -! Such shifts should be avoided by manual entering of comp.sets with -! default constitutions, but comparing a stable constitution with a -! default is not trivial ... -! - implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq - integer mode -!\end{verbatim} - integer iph,ics,lokph,lokics,jcs,lokjcs,lastset,lokkcs,kzz,jtup,qq - integer jstat2,fit,phs - double precision val,xj1,xj2 - logical notok,noremove - character jpre*4,jsuf*4 -! - if(btest(globaldata%status,GSNOAFTEREQ)) goto 1000 -! write(*,*)'25J in todo_after' -! First shift all stable composition down to lower comp.sets - phloop1: do iph=1,noph() - lokph=phases(iph) - if(btest(phlista(lokph)%status1,PHHID)) cycle - csloop1: do ics=2,phlista(lokph)%noofcs - lokics=phlista(lokph)%linktocs(ics) - if(ceq%phase_varres(lokics)%phstate.eq.PHENTSTAB .and. & - btest(ceq%phase_varres(lokics)%status2,CSAUTO)) then - fit=100 -! This comp.set is stable, check if a lower compset is unstable - csloop2: do jcs=1,ics-1 - lokjcs=phlista(lokph)%linktocs(jcs) -! hidden=-4, suspended=-3, dormant=-1, unstable=-1, unknown=0, stable=1, fix=2 - if(ceq%phase_varres(lokjcs)%phstate.le.PHENTERED) then - if(btest(ceq%phase_varres(lokjcs)%status2,CSDEFCON)) then -! check if composition of lokics fits defaults in lokjcs - if(.not.checkdefcon(lokics,lokjcs,fit,ceq)) cycle csloop2 - endif -! write(*,*)'25J Moving comp.set ',ics,' down to ',jcs - goto 500 - elseif(jcs.eq.ics-1) then - if(fit.gt.2) then -! No lower unstable comp.set, or no one which almost fit default const, -! lokics must remain stable, remove CSAUTO bit -! Do not remove the suffix _AUTO -! write(*,*)'25J Keeping AUTO comp.set ',ics,lokics - ceq%phase_varres(lokics)%status2=& - ibclr(ceq%phase_varres(lokics)%status2,CSAUTO) - exit csloop2 - endif - else - cycle csloop2 - endif -! Accept a default consitution which almost fits the default -! write(*,*)'25D Imperfect fit to default: ',fit,lokics,lokjcs -500 continue -! move STABLE lokics to UNSTABLE lokjcs -! write(*,381)'25J Before copy',& -! lokics,ceq%phase_varres(lokics)%status2,& -! ceq%phase_varres(lokics)%phtupx,& -! ceq%phase_varres(lokics)%suffix,& -! lokjcs,ceq%phase_varres(lokjcs)%status2,& -! ceq%phase_varres(lokjcs)%phtupx,& -! ceq%phase_varres(lokjcs)%suffix -381 format(a,3i4,' "',a,'" ' ,3i4,' "',a,'"') -! list the records to switch, note default constitution?? -! write(*,380)'25J Stable and free: ',ics,lokics,jcs,lokjcs,& -! ceq%phase_varres(lokics)%phtupx,& -! ceq%phase_varres(lokjcs)%phtupx -380 format(a,10i5) -! exit csloop2 -! save some jcs values of amount, dgm, status, pre&suffix and tuple index - xj1=ceq%phase_varres(lokjcs)%amfu - xj2=ceq%phase_varres(lokjcs)%dgm - jtup=ceq%phase_varres(lokjcs)%phtupx - jstat2=ceq%phase_varres(lokjcs)%status2 - jpre=ceq%phase_varres(lokjcs)%prefix - jsuf=ceq%phase_varres(lokjcs)%suffix - phs=ceq%phase_varres(lokjcs)%phstate -! copy main content of the phase_varres(lokics) record to phase_varres(lokjcs) - ceq%phase_varres(lokjcs)=ceq%phase_varres(lokics) -! Some content in jcs must be set or restorted separately - ceq%phase_varres(lokjcs)%phtupx=jtup - ceq%phase_varres(lokjcs)%status2=jstat2 - ceq%phase_varres(lokjcs)%prefix=jpre - ceq%phase_varres(lokjcs)%suffix=jsuf - ceq%phase_varres(lokjcs)%phstate=PHENTSTAB - ceq%phase_varres(lokjcs)%status2=& - ibset(ceq%phase_varres(lokjcs)%status2,CSSTABLE) -! maybe CSAUTO bit set, always remove it! -! write(*,*)'25J Ensure CSAUTO cleared in ',jcs - ceq%phase_varres(lokjcs)%status2=& - ibclr(ceq%phase_varres(lokjcs)%status2,CSAUTO) -! Some content in ics must be set separately from saved values of jcs - ceq%phase_varres(lokics)%amfu=xj1 - ceq%phase_varres(lokics)%dgm=xj2 - ceq%phase_varres(lokics)%phstate=phs -! clear the stable bit - ceq%phase_varres(lokics)%status2=& - ibclr(ceq%phase_varres(lokics)%status2,CSSTABLE) -! check things again -! write(*,381)'25J After copy ',& -! lokics,ceq%phase_varres(lokics)%status2,& -! ceq%phase_varres(lokics)%phtupx,& -! ceq%phase_varres(lokics)%suffix,& -! lokjcs,ceq%phase_varres(lokjcs)%status2,& -! ceq%phase_varres(lokjcs)%phtupx,& -! ceq%phase_varres(lokjcs)%suffix -! write(*,380)'After copy',(phlista(lokph)%linktocs(qq),& -! qq=1,phlista(lokph)%noofcs) - exit csloop2 - enddo csloop2 - endif - enddo csloop1 - enddo phloop1 -! Here we may try to ensure that the stable comp.sets fits the -! default constitutions of their current set -! write(*,*)'25J Try to shift to match default and current constitution' - call shiftcompsets(ceq) -! -! upto now is safe ... now remove CSAUTO comp.sets if allowed -! write(*,*)'25J Now maybe remove redundant compsets.' -! goto 1000 -! check if allowed to remove - if(btest(globaldata%status,GSNOREMCS)) goto 1000 -! -! Now try to remove unstable composition sets with CSAUTO set - phloop: do iph=1,noph() - noremove=.FALSE. - lokph=phases(iph) - if(btest(phlista(lokph)%status1,PHHID)) cycle -! loop backwards for compsets to remove unstable with CSAUTO set - lastset=phlista(lokph)%noofcs - csloopdown: do ics=lastset,2,-1 - lokics=phlista(lokph)%linktocs(ics) -! write(*,*)'Checking comp.set ',ics - auto: if(btest(ceq%phase_varres(lokics)%status2,CSAUTO)) then - if(ceq%phase_varres(lokics)%phstate.le.PHENTERED) then -! comp.set was created automatically but is not stable, it can be removed - if(noeq().eq.1) then -! we have just one equilibrium, OK to remove -! write(*,*)'25J Trying to remove phase tuple ',& -! ceq%phase_varres(lokics)%phtupx - call remove_composition_set(iph,.FALSE.) - if(gx%bmperr.ne.0) goto 1000 - else -! if we cannot remove the comp.set remove the CSAUTO bit - ceq%phase_varres(lokics)%status2=& - ibclr(ceq%phase_varres(lokics)%status2,CSAUTO) - endif - else -! the comp.set is stable, remove the CSAUTO bit -! write(*,*)'Removing CSAUTO bit',ics - ceq%phase_varres(lokics)%status2=& - ibclr(ceq%phase_varres(lokics)%status2,CSAUTO) - endif -! else -! anything to be done with any other phase? - endif auto - enddo csloopdown - enddo phloop -! -1000 continue - return - end subroutine todo_after_found_equilibrium - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - logical function checkdefcon(lokics,lokjcs,fit,ceq) -! check if composition of lokics fits default constitution in lokjcs -! return TRUE if lokics moved to lokjcs -! If not moved fit returns a value how close the constitition is -! If 1 very close, 2 less etc. - integer lokics,lokjcs,fit - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer kk - logical tobeshifted - tobeshifted=.FALSE. -! A fraction with a maximum set (mmyfr<0) must be below that value -! A fraction with a minimum set (mmyfr>0) should be above that value -! write(*,*)'25J testing defaults',lokics,lokjcs - fit=0 - do kk=1,size(ceq%phase_varres(lokjcs)%yfr) - if(ceq%phase_varres(lokjcs)%mmyfr(kk).lt.0.0D0) then -! A fraction with a maximum set (mmyfr>0) must be below mmyfr(kk) - if(ceq%phase_varres(lokics)%yfr(kk).gt.& - abs(ceq%phase_varres(lokjcs)%mmyfr(kk))) fit=fit+5 -! A fraction with a minimum set (mmyfr<0) should be above mmyfr(kk) - elseif(ceq%phase_varres(lokjcs)%mmyfr(kk).gt.0.0D0) then - if(ceq%phase_varres(lokics)%yfr(kk).lt.& - abs(ceq%phase_varres(lokjcs)%mmyfr(kk))) fit=fit+1 - endif -! if mmyfr(kk)=0 there is no min/max for that fraction -! write(*,77)'25J Constitution: ',kk,ceq%phase_varres(lokjcs)%mmyfr(kk),& -! ceq%phase_varres(lokics)%yfr(kk),fit -77 format(a,i3,2(1pe12.4),i5) - enddo - if(fit.eq.0) tobeshifted=.TRUE. -! write(*,*)'25J checkdefcon: ',lokics,lokjcs,fit -1000 continue - checkdefcon=tobeshifted - return - end function checkdefcon - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine shiftcompsets(ceq) -! check phase with several composition sets if they should be shifted -! to fit the default constitution better - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer lokph,iph,ics,lokics,jcs,lokjcs,fit1,fit2,shifts - character ch1*1 - phloop: do iph=1,noofph - lokph=phases(iph) - if(phlista(lokph)%noofcs.gt.1) then - shifts=0 -100 continue - shifts=shifts+1 - if(shifts.gt.2) cycle phloop - csloop1: do ics=1,phlista(lokph)%noofcs - lokics=phlista(lokph)%linktocs(ics) - if(ceq%phase_varres(lokics)%phstate.eq.PHENTSTAB) then - if(btest(ceq%phase_varres(lokics)%status2,CSDEFCON)) then -! if TRUE then the composition fits default constitution - if(checkdefcon(lokics,lokics,fit1,ceq)) cycle csloop1 - else - fit1=-100 - endif - else - fit1=500 - endif -! The values of fit1: -! -100 there is no default constitution of ics -! >0 the degree of fit of the current constitution of ics -! 500 ics is not stable -! We come here to check if some other compset fits better -! write(*,*)'25J ics fit in ics: ',ics,fit1 - csloop2: do jcs=1,phlista(lokph)%noofcs - if(jcs.eq.ics) cycle csloop2 - lokjcs=phlista(lokph)%linktocs(jcs) - if(ceq%phase_varres(lokjcs)%phstate.eq.PHENTSTAB) then - if(btest(ceq%phase_varres(lokjcs)%status2,CSDEFCON)) then -! if this call returns TRUE then the jcs composition fits default constitution - if(checkdefcon(lokjcs,lokjcs,fit2,ceq)) then - cycle csloop2 - endif - else -! there is no default constitution in jcs - fit2=-100 -! write(*,*)'25J no default const: ',jcs,fit2 - endif - else -! jcs is not stable - fit2=500 - endif -! fit2: -! -100 jcs has no default constitution -! >0 the current fit to default constitution -! 500 jcs is not stable -! write(*,*)'25J jcs fit in jcs: ',jcs,fit2 - if(fit1.eq.500) then -! If neither ics nor jcs are stable increment jcs - if(fit2.eq.500) cycle csloop2 -! ics is unstable, but if it has a default constitution, check if jcs fits - if(btest(ceq%phase_varres(lokics)%status2,CSDEFCON)) then - if(checkdefcon(lokjcs,lokics,fit2,ceq)) continue - fit2=-fit2 - else - fit2=fit1+1 - endif - else -! ics is stable, check if jcs has a default constitution that fits better - if(btest(ceq%phase_varres(lokjcs)%status2,CSDEFCON)) then - if(checkdefcon(lokics,lokjcs,fit2,ceq)) continue - else - fit2=fit1+1 - endif - endif -! fit2: -! <=fit1 shift jcs and ics -! >fit1 do nothing -! write(*,*)'25J jcs fit in ics: ',jcs,fit2 - if(fit2.le.fit1) then -! The comp.set ics fits the default constitution of jcs better than its current -! write(*,*)'25J shifting compsets: ',ics,jcs,fit1,fit2 - call copycompsets2(lokph,ics,jcs,ceq) -! shift composition sets! Copy all via a dummy record (last phase_varres) -! That is hopefully unused ... -! ceq%phase_varres(2*maxph)=ceq%phase_varres(lokics) -! ceq%phase_varres(lokics)=ceq%phase_varres(lokjcs) -! ceq%phase_varres(lokjcs)=ceq%phase_varres(2*maxph) -! restore phtupx, pre/suffix and status word for jcs -! ceq%phase_varres(lokjcs)%phtupx=& -! ceq%phase_varres(lokics)%phtupx -! ceq%phase_varres(lokjcs)%status2=& -! ceq%phase_varres(lokics)%status2 -! ceq%phase_varres(lokjcs)%prefix=& -! ceq%phase_varres(lokics)%prefix -! ceq%phase_varres(lokjcs)%suffix=& -! ceq%phase_varres(lokics)%suffix -! restore phtupx, pre/suffix and status word for ics -! ceq%phase_varres(lokics)%phtupx=& -! ceq%phase_varres(2*maxph)%phtupx -! ceq%phase_varres(lokjcs)%status2=& -! ceq%phase_varres(2*maxph)%status2 -! ceq%phase_varres(lokics)%prefix=& -! ceq%phase_varres(2*maxph)%prefix -! ceq%phase_varres(lokics)%suffix=& -! ceq%phase_varres(2*maxph)%suffix -! restore the "end" link in last record -! ceq%phase_varres(2*maxph)%nextfree=-1 -! update fit1, fit2 will be updated automatically -! if(ceq%phase_varres(lokics)%phstate.eq.PHENTSTAB) then -! if(btest(ceq%phase_varres(lokics)%status2,CSDEFCON)) then -! if(checkdefcon(lokics,lokics,fit1,ceq)) continue -! else -! fit1=-100 -! endif -! fit1=500 - write(*,*)'25J Switched compsets: ',ics,jcs,fit1,fit2 -! read(*,99)ch1 -!99 format(a) -! start again from first comp.set - goto 100 - endif - enddo csloop2 - enddo csloop1 - endif - enddo phloop -1000 continue - return - end subroutine shiftcompsets - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine copycompsets(iph,ics1,ics2,ceq) -! copy constitution and results from ic2 to ic1 and vice versa - integer iph,ics1,ics2 - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer lokph,lokcs1,lokcs2 -! check indices are correct - call get_phase_compset(iph,ics1,lokph,lokcs1) - call get_phase_compset(iph,ics2,lokph,lokcs2) - if(gx%bmperr.ne.0) goto 1000 - call copycompsets2(lokph,ics1,ics2,ceq) -1000 continue - return - end subroutine copycompsets - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine copycompsets2(lokph,ics1,ics2,ceq) -! copy constitution and results from ic2 to ic1 and vice versa - integer lokph,ics1,ics2 - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer iph,lokcs1,lokcs2,ncon,idum,ncc - double precision, dimension(:), allocatable :: val - double precision, dimension(:,:), allocatable :: gval,d2gval - double precision, dimension(:,:,:), allocatable :: dgval - double precision qq(5),xdum -! - lokcs1=phlista(lokph)%linktocs(ics1) - lokcs2=phlista(lokph)%linktocs(ics2) -! save current constitution of lokcs1 in val - ncon=size(ceq%phase_varres(lokcs1)%yfr) - allocate(val(ncon)) - val=ceq%phase_varres(lokcs1)%yfr -! set the constitution in lokcs1 equal to that in lokcs2. This call -! also updates a number of other variables in the record - iph=phlista(lokph)%alphaindex - call set_constitution(iph,ics1,ceq%phase_varres(lokcs2)%yfr,qq,ceq) - if(gx%bmperr.ne.0) goto 1000 - call set_constitution(iph,ics2,val,qq,ceq) - if(gx%bmperr.ne.0) goto 1000 -! copy some variables: phstate, amfu and dgm - idum=ceq%phase_varres(lokcs1)%phstate - ceq%phase_varres(lokcs1)%phstate=ceq%phase_varres(lokcs2)%phstate - ceq%phase_varres(lokcs2)%phstate=idum - xdum=ceq%phase_varres(lokcs1)%amfu - ceq%phase_varres(lokcs1)%amfu=ceq%phase_varres(lokcs2)%amfu - ceq%phase_varres(lokcs2)%amfu=xdum - xdum=ceq%phase_varres(lokcs1)%dgm - ceq%phase_varres(lokcs1)%dgm=ceq%phase_varres(lokcs2)%dgm - ceq%phase_varres(lokcs2)%dgm=xdum -! listprop will be the same -! Now copy result arrays - ncon=ceq%phase_varres(lokcs1)%nprop - allocate(gval(6,ncon)) - gval=ceq%phase_varres(lokcs1)%gval - ceq%phase_varres(lokcs1)%gval=ceq%phase_varres(lokcs2)%gval - ceq%phase_varres(lokcs2)%gval=gval - ncc=ceq%phase_varres(lokcs1)%ncc - allocate(dgval(3,ncc,ncon)) - dgval=ceq%phase_varres(lokcs1)%dgval - ceq%phase_varres(lokcs1)%dgval=ceq%phase_varres(lokcs2)%dgval - ceq%phase_varres(lokcs2)%dgval=dgval - allocate(d2gval(ncc*(ncc+1)/2,ncon)) - d2gval=ceq%phase_varres(lokcs1)%d2gval - ceq%phase_varres(lokcs1)%d2gval=ceq%phase_varres(lokcs2)%d2gval - ceq%phase_varres(lokcs2)%d2gval=d2gval -! curlat, cinvy, cxmol, cdxmol? -1000 continue - return - end subroutine copycompsets2 - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine shiftcompsets2(lokph,ceq) -! check if the composition sets of phase lokph -! should be shifted to fit the default constitution better - integer lokph - type(gtp_equilibrium_data), pointer :: ceq -!\end{verbatim} - integer kk,lokics,lokjcs,fit -! A fraction with a maximum set (mmyfr>0) must be below that value -! A fraction with a minimum set (mmyfr<0) should be above that value - write(*,*)'Not implemented testing defaults' - fit=0 - do kk=1,size(ceq%phase_varres(lokics)%yfr) - write(*,*)'25J defconst: ',kk,ceq%phase_varres(lokics)%mmyfr(kk) - if(ceq%phase_varres(lokics)%mmyfr(kk).gt.0.0D0) then -! A fraction with a maximum set (mmyfr>0) must be below that value - if(ceq%phase_varres(lokjcs)%yfr(kk).gt.& - ceq%phase_varres(lokics)%mmyfr(kk)) fit=fit+5 -! A fraction with a minimum set (mmyfr<0) should be above that value - elseif(ceq%phase_varres(lokics)%mmyfr(kk).lt.0.0D0) then - if(ceq%phase_varres(lokjcs)%yfr(kk).lt.& - abs(ceq%phase_varres(lokics)%mmyfr(kk))) fit=fit+1 - endif - enddo -1000 continue - return - end subroutine shiftcompsets2 - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!\begin{verbatim} - subroutine select_composition_set(iph,ics,yarr,ceq) -! if phase iph wants to become stable and there are several composition sets -! this subroutine selects the one with default composition set that fits best. -! For example if an FCC phase that could be an austenite (low carbon content) -! or a cubic carbo-nitride (high carbon or nitrogen content, low vacancy) -! Less easy to handle ordered phases like B2 or L1_2 as ordering can be -! in any sublatittice ... option B and F needed - implicit none - TYPE(gtp_equilibrium_data), pointer :: ceq - double precision, dimension(*) :: yarr - integer iph,ics -!\end{verbatim} - double precision, parameter :: yl=0.1D0,yh=0.5D0 - integer best,lokph,maxnh,ncc,jcs,lokcs,nh,jl - lokph=phases(iph) - best=1 - maxnh=0 - ncc=phlista(lokph)%tnooffr - do jcs=1,phlista(lokph)%noofcs -! loop through all composition sets - lokcs=phlista(lokph)%linktocs(jcs) -! compare yarr with ceq%phase_varres(lokcs)%mmyfr - nh=0 - do jl=1,ncc - if(ceq%phase_varres(lokcs)%mmyfr(jl).lt.zero) then - if(yarr(jl).lt.yl) nh=nh+1 - elseif(ceq%phase_varres(lokcs)%mmyfr(jl).gt.zero) then - if(yarr(jl).gt.yh) nh=nh+1 - endif - enddo - if(nh.gt.maxnh) then - maxnh=nh - best=jcs - endif - enddo -! if only one compset return 1 - ics=best -! -1000 continue - return - end subroutine select_composition_set - -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - -!-\begin{verbatim} - subroutine sort_multidim_array(nrel,ng,xarr) -! sorts values in xarr in decending order for each column (element) -! xarr(1..nrel,jp) is the composition of gridpoint jp -! UNFINISHED - implicit none - integer nrel,ng - real xarr(nrel,*) -!-\end{verbatim} - integer i1,j1,k1,l1,m1,bounds(nrel,10),nb,b1,c1 - real, dimension(:,:), allocatable :: xord - real xx,xsame -! allocate ordered array and zero. All values in xarr>0 - allocate(xord(nrel,ng)) - xord=zero -! sort first column, increment is nrel, very brute force - loop1: do j1=1,ng,nrel - xx=xarr(1,j1) - do k1=1,j1-1 - if(xx.gt.xord(1,k1)) then -! store xarr here but first shift all values in xord after k1 up, loop bacwards - do l1=j1,k1,-1 - do m1=1,nrel - xord(m1,l1+1)=xord(m1,l1) - enddo - enddo - do m1=1,nrel - xord(m1,k1)=xarr(m1,j1) - enddo - cycle loop1 - endif - do m1=1,nrel - xord(m1,j1)=xarr(m1,j1) - enddo - enddo - enddo loop1 -! detect the bounds - xsame=xord(1,1) - bounds(1,1)=1 - j1=1 - do i1=1,ng - if(xord(1,i1).lt.xsame) then - xsame=xord(1,i1) - j1=j1+1 - bounds(j1,1)=j1 - endif - enddo - nb=j1 - write(*,11)'bounds column 1: ',nb,(bounds(k1,1),k1=1,nb) -11 format(a,i3,10i5) -! now the first column sorted and all values are in xord, sort columns 2 etc -! separately for each lower column bounds -! keep the ordering in the lower columns. No need to sort Last column - column: do c1=1,nrel - boundloop: do b1=2,nb - loop2: do i1=bounds(b1-1,c1),bounds(b1,c1) - loop3: do j1=2,ng,nrel - if(xord(i1-1,j1).lt.xsame) then - xsame=xord(i1-1,1) - xx=xord(i1,j1) - do k1=1,ng - if(xx.gt.xord(i1,k1)) then -! store xx here, shift up (all values in xord) - do l1=j1,k1,-1 - do m1=1,nrel - xord(m1,l1+1)=xord(m1,l1) - enddo - enddo - endif - xord(i1,k1)=xx - cycle loop3 - enddo - endif - enddo loop3 - enddo loop2 - enddo boundloop - enddo column -1000 continue - deallocate(xord) - return -! UNFINISHED - end subroutine sort_multidim_array -! -!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ - +! +! gtp3Y included in gtp3.F90 +! +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ +!> 16. Grid minimizer +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + subroutine global_gridmin(what,tp,xknown,nvsph,iphl,icsl,aphl,& + nyphl,yphl,cmu,ceq) +! +! finds a set of phases that is a global start point for an equilibrium +! calculation at T and P values in tp, total amount of atoms in totan +! and known mole fraction in xknown +! It is intentional that this routine is independent of current conditions +! It returns: nvsph stable phases, list of phases in iphl, amounts in aphl, +! constitution in yphl (compact after each other, nyphl(i) is number of +! fractions in phase i), cmu are element chemical potentials of solution +! WHAT determine what to do with the results, 0=just return solution, +! 1=enter stable set and constitution of all phases in gtp datastructure +! and create composition sets if necessary (and allowed) +! what=-1 will check if any gridpoint below current calculated equilibrium + implicit none +! nyphl(j) is the start position of the constitiuent fractions of phase j in +! yphl that contains all the constitutions of the phases in the gridpoints + integer, dimension(*) :: iphl,nyphl,icsl + integer what,nvsph + TYPE(gtp_equilibrium_data), pointer :: ceq + double precision, dimension(2) :: tp +! cmu(1..nrel) is the chemical potentials of the solution + double precision, dimension(*) :: xknown,aphl,yphl,cmu +!\end{verbatim} + integer, parameter :: maxgrid=400000,maxy=2000,maxph=500 + integer :: starttid,endoftime + real finish2 + double precision amount,sum + integer i,ibias,ics,ics2,icsno,icsx,ie,iph,iv,j1,j2,jip,jp,kkz,kp,kph,jbias + integer lokcs,lokph,mode,ng,nocsets,noofgridpoints,nr,nrel,nrph,ny,nyz +! kphl(iph) is first gridpoint in phase iph +! ngrid(iph) is the last gridpoint for phase iph (some phases may be suspended) +! xarr(nrel,i) is the composition of gridpoint i +! garr(i) is the Gibbs energy of gridpoint i +! jgrid(j) is a gridpoint in the solution +! phfrac(j) is the amount of the phase of that gridpoint + integer, dimension(0:maxph) :: ngrid,kphl + integer, dimension(maxel) :: jgrid + real garr(maxgrid),starting,finished + real, dimension (:,:), allocatable :: xarr + real, dimension (maxel,maxel) :: xsol + double precision, dimension(maxel) :: phfrac,phsave + double precision qq(5),savetp(2) + integer, dimension(maxph) :: iphx + character name1*24 +! debug + logical trace +! sort phases depending on number of gridpoints + integer, dimension(:), allocatable :: gridpoints,phord +! pph is set to number of phases participating, some may be suspended + integer pph,zph,nystph,order(maxel) +! + if(btest(globaldata%status,GSNOGLOB)) then + write(*,*)'Grid minimization not allowed' + gx%bmperr=4173; goto 1000 + endif + call cpu_time(starting) + ngrid=0 +! Trace turn on output of grid on a file +! trace=.true. + trace=.FALSE. + if(trace) write(*,*)'Trace set TRUE' + savetp=ceq%tpval + ceq%tpval=tp +! ceq%tpval(2)=tp(2) + nrph=noph() +! write(*,*)'ggp A: ',tp(1),ceq%tpval(1) + if(nrph.gt.maxph) then +! too many phases + write(*,*)'Too many phases for gridmin' + gx%bmperr=6663; goto 1000 + endif + nrel=noel() + sum=zero + do i=1,nrel + if(xknown(i).le.zero .or. xknown(i).ge.one) then +! write(*,*)'Illegal composition for gridmin' + gx%bmperr=4174; goto 1000 + endif + sum=sum+xknown(i) + enddo + if(ocv()) write(*,12)'gridmin: ',sum,(xknown(i),i=1,nrel) +12 format(a,1pe12.4,10(f8.4)) + if(abs(sum-one).gt.1.0D-8) then + write(*,*)'Sum of fractions larger than unity calling global_gridmin' + gx%bmperr=4174; goto 1000 + endif + kp=1 + pph=0 + kphl(0)=0 + allocate(gridpoints(nrph)) + allocate(phord(nrph)) + ggloop: do iph=1,nrph +! if(.not.phase_status(iph,1,PHHID,ceq)) then +! skip phases that are hidden or suspended .... old 5; new -3 +! if(test_phase_status(iph,1,amount,ceq).lt.5) then +! if(test_phase_status(iph,1,amount,ceq).gt.PHHIDDEN) then +! if(test_phase_status(iph,1,amount,ceq).gt.PHSUS) then +! skip dormant phases +! include phases with first composition set entered (only once!) + ent1: if(test_phase_status(iph,1,amount,ceq).gt.PHDORM) then + do ics=1,noofcs(iph) +! new: -3 suspended, -2 dormant, -1,0,1 entered, 2 fixed +! ignore phases whith no composition set entered +! If a phase+compset FIX one should never be here as conditions wrong + if(test_phase_status(iph,ics,amount,ceq).lt.PHFIXED) goto 60 + enddo + cycle ggloop +! this call to find out how many gridpoints will be generated for each phase +60 continue + pph=pph+1 + kphl(pph)=kp + iphx(pph)=iph + call generate_grid(-1,iph,ng,nrel,xarr,garr,ny,yphl,ceq) + if(gx%bmperr.ne.0) goto 1000 + kp=kp+ng + ngrid(pph)=kp-1 + gridpoints(pph)=ng +! write(*,61)'3Y gpno: ',pph,iph,ngrid(pph),gridpoints(pph) +61 format(a,10i7) +! if(trace) then + call get_phase_name(iph,1,name1) +! write(*,21)iph,name1(1:12),kphl(pph),ng +! endif +! write(*,22)iph,kphl(pph),ny,ng,pph + endif ent1 + enddo ggloop +! we have a grid for pph phases, note that pph is not a phase index!!! +! the phase index for phase 1..pph is in iphx(1..pph) +21 format('Gridpoints for phase ',i3,': ',a,', starts ',i7,', with ',2i7) +22 format('Gridpoints for phase ',i3,' starts at ',i5,', with ',2i5,i8) + if(kp-1.gt.maxgrid) then + write(*,*)'Too many gridpoints' + gx%bmperr=4175; goto 1000 + endif +! we may have no gridpoints!!! + if(kp.eq.1) then + write(*,*)'No phases, no gridpoints' + gx%bmperr=4176; goto 1000 + endif +! write(*,*)'phases and gridpoints: ',pph,kp,ngrid(pph),nrel +! total number of gridpoints is kp-1 ... but sometimes kp is wrong, why?? +! allocate(xarr(nrel,kp-1)) + allocate(xarr(nrel,kp-1+10)) + if(ocv()) write(*,*)'Gridpoints and elements: ',kp-1,nrel +! we should sort iphx to have phases with many gripoints first +! kphl must be shifted at the same time +!$ call sortin(gridpoints,pph,phord) +!-$ write(*,32)(kp,phord(kp),gridpoints(kp),kp=1,pph) +32 format(4('3Y ord: ',i2,i3,i6,' : ')) +! generate grid +! we must know before this loop how many gridpoints that each phase will +! need. That is a function of the number of gridpoints. + kp=1 + call system_clock(count=starttid) +! write(*,*)'Start calculate gridvalues' +! OpenMP parallellization START +! the error code gx%bmperr should also be threadprivate +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! for parallelizing: +! YOU MUST UNCOMMENT USE OMP_LIB IN GTP3.F90 +! YOU MUST USE THE SWICH -fopenmp FOR COMPILATION AND WHEN LINKING +!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +!-$omp parallel do private(ng,iv,iph),schedule(dynamic) +!--$omp parallel do private(ng,iv),schedule(dynamic) +!--$omp parallel do +! phloop: do iph=1,nrph + phloop: do zph=1,pph +! for phase iphx(zph) the gridpoints will be stored from position kphl(zph) +! mole fracts in xarr, g in garr +! yphl is not used when mode=0, ng should be set to number of remaining points +! ngrid(iph) is number of gridpoints in phase iph + ng=maxgrid +! values in kphl set in previous call to generate_grid(-1,.....) + iv=kphl(zph) +! when not parallel set iph=zph + iph=zph +! for parallel take the phases from phord(pph), phord(pph-1) .... 2, 1 +!-$ iph=phord(pph+1-zph) +!-$ iv=kphl(iph) +!--$ write(*,42)'Thread: ',omp_get_thread_num(),zph,iph,& +!--$ iphx(iph),iv,gridpoints(pph+1-zph) +42 format(a,10i7) +! this call will calculate all gridpoints, that may take time ... +! call generate_grid(0,iphx(iph),ng,nrel,xarr(1,iv),garr(iv),ny,yphl,ceq) + call generate_grid(0,iphx(iph),ng,nrel,xarr(1,iv),garr(iv),ny,yphl,ceq) + if(gx%bmperr.ne.0) then + write(*,*)'grid error ',jip,zph,gx%bmperr +! this jump illegal when openmp +! goto 1000 + gx%bmperr=0 + endif +! list xarr for all gridpoints +! do kp=1,ng +! write(*,73)iphx(zph),kp,(xarr(ie,kp),ie=1,nrel) +!73 format('gp: ',i3,i5,10(f6.3)) +! enddo +! write(*,*)'look!!!' +! read(*,74)ch1 +!74 format(a) + enddo phloop +! set how many points in +!-$omp end parallel do +! OpenMP parallellization END + call system_clock(count=endoftime) +! write(*,106)endoftime-starttid +106 format('Clockcycles: ',i12) +107 format(a,7i6) +! kp=ngrid(nrph) + kp=ngrid(pph) +! if(trace) write(*,108)kp +108 format('The total number of gridpoints are ',i5) + call cpu_time(finished) + noofgridpoints=ngrid(pph) +! If WHAT is -1 then just compare all gridpoints with plane defined by +! the chemical potentials cmu to see if any is below. +! If so insert the gridpoint furtherst below the plane and set WHAT 10*iph+ics +! write(*,*)'global_gridmin what: ',what + if(what.eq.-1) then + call gridmin_check(nystph,kp,nrel,xarr,garr,xknown,ngrid,pph,& + cmu,yphl,iphx,ceq) + goto 1000 + endif +!----------------------------------------------- +! write(*,109)ngrid(pph),finished-starting,endoftime-starttid +109 format('Calculated ',i6,' gridpoints in ',1pe12.4,' seconds, ',& + i7,' clockcycles') +! find the minimum of nrel gridpoints among the kp-1 gridpoint +! for current overall composition, xknown +! write(*,*)'globm 4: ',kp,garr(kp),xarr(1,kp) +! phfrac=zero + if(ocv()) write(*,*)'Finding the gridpoints for the minimum: ',kp-1 + call find_gridmin(kp,nrel,xarr,garr,xknown,jgrid,phfrac,cmu,trace) + if(gx%bmperr.ne.0) goto 1000 +! The solution with nrel gridpoints are in jgrid, the amount of each in phfrac +! We later want the phases in ascending order and as the gridpoints are +! in ascending order of the phases we sort the gridpoints (and amounts) +! There must be one gridpoint per component (element) +! write(*,62)(jgrid(jp),jp=1,nrel) + call sortin(jgrid,nrel,order) + do nyz=1,nrel + phsave(nyz)=phfrac(order(nyz)) + enddo + phfrac=phsave +! check +! write(*,62)(jgrid(jp),jp=1,nrel) +62 format('3Y Gridp: ',10i4) +! xov=zero +! sum=zero +! do jp=1,nrel +! write(*,63)'xs: ',phfrac(jp),(xarr(nyz,jgrid(jp)),nyz=1,nrel) +! do nyz=1,nrel +! xov(nyz)=xov(nyz)+phfrac(jp)*xarr(nyz,jgrid(jp)) +! enddo +! sum=sum+phfrac(jp) +! enddo +! write(*,63)'ss: ',sum,(xov(nyz),nyz=1,nrel) +!63 format(a,1e12.4,10f7.4) +! get the phase and constitution for each + nyz=1 +! if(trace) write(*,*)'Extracting constititution' + if(trace) then + write(31,745) +745 format(/'Solution: ') + endif + solloop: do jp=1,nrel +! jgrid(jp) is a grid point in the solution, find which phase it is + mode=jgrid(jp) + ibias=0 + do zph=1,pph +! write(*,*)'mode and ibias 1: ',mode,ibias +! ngrid(zph) is the first gridpoints of phase zph + if(mode.le.ngrid(zph)) then + mode=mode-ibias + goto 315 + else + ibias=ngrid(zph) + endif + enddo + write(*,*)'gridpoint outside range ',jgrid(jp),ngrid(pph) + gx%bmperr=4147; goto 1000 +315 continue + jbias=ibias +! write(*,*)'gridpoint in solution: ',mode,ibias +! this call is to obtain the constitution of a phase in the solution +! mode gives in grid point index in phase iphx(zph), ibias irrelevant (?) +! NOTE ibias is changed by subroutine + call generate_grid(mode,iphx(zph),ibias,nrel,xarr,garr,ny,yphl(nyz),ceq) + if(gx%bmperr.ne.0) goto 1000 +! write(*,317)'gg7B: ',ny,nyz,(yphl(i),i=nyz,nyz+ny-1) +!317 format(a,2i3,6(1pe11.3)) + iphl(jp)=iphx(zph) + aphl(jp)=phfrac(jp) + nyphl(jp)=ny + nyz=nyz+ny +! finally copy the mole fractions to xsol, needed for possible merging + do ie=1,nrel + xsol(ie,jp)=xarr(ie,mode+jbias) + enddo + if(trace) then + write(31,750)jp,jgrid(jp),iphl(jp),aphl(jp),(xsol(ie,jp),ie=1,nrel) + write(31,760)(yphl(i),i=nyz-ny,nyz-1) +750 format('Point: ',i2,', gridpoint: ',i5,' phase ',i3,& + ' amount: ',1pe12.4,', Mole fractions:'/9(0pF8.5)) +760 format('Constitution:'/9(0pF8.5)) + endif + enddo solloop + if(trace) then + write(*,*)'Closing grid file' + close(31) + endif +! there must be as many phases in the solution as there are elements + nvsph=nrel + nr=nvsph + if(.not.btest(globaldata%status,GSNOMERGE)) then + call merge_gridpoints(nr,iphl,aphl,nyphl,yphl,trace,nrel,xsol,cmu,ceq) + if(gx%bmperr.ne.0) goto 1000 + endif +! number of gridpoints, nr, may have changed +! write(*,*)'After merge_gripoints: ',nr,nvsph + nvsph=nr +! if what=-1 or0 do nothing more, just exit +! if(what.eq.0) goto 1000 + if(what.le.0) goto 1000 +!------------------------------------------------------------ +! prepare for storing result: zero all phase amounts and driving forces + do iph=1,nrph + lokph=phases(iph) +! lokcs=phlista(lokph)%cslink + do ics=1,phlista(lokph)%noofcs + lokcs=phlista(lokph)%linktocs(ics) +! ceq%phase_varres(lokcs)%amount=zero + ceq%phase_varres(lokcs)%dgm=zero + ceq%phase_varres(lokcs)%amfu=zero + ceq%phase_varres(lokcs)%netcharge=zero + if(ceq%phase_varres(lokcs)%phstate.eq.phentstab) then +! reset status of "entered and stable" to just "entered" + ceq%phase_varres(lokcs)%phstate=phentered + endif + enddo + enddo +! store chemical potentials multiplied with RT if what not -1 + ceq%rtn=globaldata%rgas*ceq%tpval(1) + do ie=1,nrel +! write(*,*)'grid chemical potential: ',ie,cmu(ie)*ceq%rtn +! do not care about reference state for chempot(2) + ceq%complist(ie)%chempot(1)=cmu(ie)*ceq%rtn + ceq%complist(ie)%chempot(2)=cmu(ie)*ceq%rtn + enddo +! set driving force 0 for stable phases + do i=1,nvsph + call set_driving_force(iphl(i),1,zero,ceq) + if(gx%bmperr.ne.0) goto 1000 + enddo +! store the most favourable constitution of the metastable phase + call set_metastable_constitutions(kp,nrel,kphl,ngrid,xarr,garr,& + nvsph,iphl,cmu,ceq) + if(gx%bmperr.ne.0) goto 1000 +! maybe more composition sets needed + do i=1,nvsph + icsl(i)=0 + enddo + nocsets=0 +! write(*,*)'before loop1: ',nvsph,ceq%eqname + loop1: do j1=1,nvsph + if(icsl(j1).eq.0) then +! if non-zero a composition set has already been assigned + icsl(j1)=1 + icsx=1 + loop2: do j2=j1+1,nvsph + if(iphl(j1).eq.iphl(j2)) then +! one more composition set needed, does it exist? + icsx=icsx+1 + ics2=icsx + call get_phase_compset(iphl(j1),ics2,lokph,lokcs) + if(gx%bmperr.ne.0) then +! there is no such composition set, is automatic creation allowed? +! NOTE: there is a EQNOACS bit also??? + if(btest(globaldata%status,GSNOACS)) then +! write(*,*)'Not allowed to create composition sets' + gx%bmperr=4177; goto 1000 + endif + gx%bmperr=0 +! >>>>>>>>>>>>>>>>>>>< +! BEWARE >>> not only must this be done in all threads at the same time +! one must also avoid that it is done when some thread is working on a set +! of phase+composition sets trandformed to EQCALC arrays. If so the +! indices to lokcs etc will be incorrect ... ??? +! I think OMP has "secure" points where the treads can be stopped to wait +! <<<<<<<<<<<<<<<<<<<<<< + kph=iphl(j1) +! write(*,*)'3Y new composition set for phase: ',j2,kph +! It must be done in all equilibrium records, no equilibrium record needed!!! +! one must be careful with the status word when creating comp.sets + call enter_composition_set(kph,' ','AUTO',icsno) + if(gx%bmperr.ne.0) goto 1000 + call get_phase_compset(kph,icsno,lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 + ceq%phase_varres(lokcs)%status2=& + ibset(ceq%phase_varres(lokcs)%status2,CSAUTO) + nocsets=nocsets+1 +! if(btest(ceq%phase_varres(lokcs)%status2,CSDEFCON)) then +! write(*,*)'3Y defcon set',kph,icsno +! else +! write(*,*)'3Y defcon not set',kph,icsno +! endif +! write(*,303)'3Y Created cs:',kph,icsno,lokcs,& +! ceq%phase_varres(lokcs)%amfu,& +! ceq%phase_varres(lokcs)%abnorm +303 format(a,3i3,6(1pe12.4)) + icsl(j2)=icsno + else +! here we should check which composition set that should have which +! constitution for example one fcc is metallic and another is cubic carbide + call get_phase_name(iphl(j1),ics2,name1) + icsl(j2)=ics2 +! write(*,1711)name1,ics2 +1711 format('Using composition set for ',a,i3) +! check if the composition set is fix (2), dormant (2) or suspended (3) + kkz=test_phase_status(iphl(j1),ics2,amount,ceq) +! old kkz=2 means fix +! if(kkz.eq.2) then + if(kkz.eq.PHFIXED) then + write(*,*)'Global minimization with fix phase not allowed' + gx%bmperr=7777; goto 1000 + elseif(kkz.lt.PHENTUNST) then + write(*,*)' *** Warning, changing status for phase ',name1 + endif +! this means status entered PHSTATE +! ceq%phase_varres(lokcs)%status2=& +! ibclr(ceq%phase_varres(lokcs)%status2,CSSUS) +! ceq%phase_varres(lokcs)%status2=& +! ibclr(ceq%phase_varres(lokcs)%status2,CSFIXDORM) + ceq%phase_varres(lokcs)%phstate=0 + endif + endif + enddo loop2 + endif + enddo loop1 +! write(*,*)'after loop1: ',phlista(1)%noofcs + if(nocsets.gt.0) write(*,*)'Composition set(s) created: ',nocsets +! Above one should consider if some user created compsets are dedicated to +! certain cases (MC carbides or L1_2 ordered). These should have +! a default constitution and CSDEFCON set) +! finally store stable phase amounts and constitutions into ceq%phase_varres + j1=1 + ceqstore: do iph=1,nvsph +! write(*,*)'ggm: ',iph,iphl(iph),icsl(iph),j1 + call set_constitution(iphl(iph),icsl(iph),yphl(j1),qq,ceq) + if(gx%bmperr.ne.0) goto 1000 +! write(*,1788)'gg: ',iph,iphl(iph),icsl(iph),aphl(iph),& +! (yphl(j1+ie),ie=0,3),qq(1) +1788 format(a,3i3,f8.4,2x,4f8.4,1pe10.2) +! aphl(iph) is amount of phase per mole component + call get_phase_compset(iphl(iph),icsl(iph),lokph,lokcs) +! Here aphl is divided with the number of mole of atoms in the phase +! if(ceq%phase_varres(lokcs)%abnorm(1).ge.one) then +! aphl(iph)=aphl(iph)/ceq%phase_varres(lokcs)%abnorm(1) +! endif +! write(*,1812)iph,lokcs,aphl(iph),ceq%phase_varres(lokcs)%abnorm(1) +1812 format('aphl: ',2i3,6(1pe12.4)) + aphl(iph)=aphl(iph)/ceq%phase_varres(lokcs)%abnorm(1) +! write(*,1789)'aphl: ',iph,lokcs,aphl(iph),& +! ceq%phase_varres(lokcs)%abnorm(1) +1789 format(a,2i3,2(1pe12.4)) + ceq%phase_varres(lokcs)%amfu=aphl(iph) + ceq%phase_varres(lokcs)%phstate=PHENTSTAB +! write(*,*)'3Y gridmin stable: ',lokcs,ceq%phase_varres(lokcs)%phtupx + j1=j1+nyphl(iph) + enddo ceqstore +1000 continue +! write(*,*)'at 1000: ',phlista(1)%noofcs +! restore tpval in ceq + ceq%tpval=savetp + call cpu_time(finish2) + if(allocated(xarr)) deallocate(xarr) + if(gx%bmperr.ne.0) then +! globaldata%status=ibset(globaldata%status,GSEQFAIL) + ceq%status=ibset(ceq%status,EQFAIL) + elseif(what.eq.-1) then + if(nystph.gt.0) what=nystph + else + write(*,1010)noofgridpoints,finish2-starting,endoftime-starttid +1010 format(' Grid minimization: ',i7,' gridpoints ',1pe12.4,' s and ',& + i7,' clockcycles') +! set the global bit that this is not a full equilibrium + ceq%status=ibset(ceq%status,EQNOEQCAL) + endif + if(ocv()) write(*,*)'leaving global_gridmin' + return + end subroutine global_gridmin + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!-\begin{verbatim} + subroutine new_gridpoint_calc(only,iph,nsl,nend,endm,jend,ifra,ny,yfra,& + xmol,gval,ceq) +! This subroutine sets the fractions according to three indicators +! and calculates the Gibbs energy of the gridpoint + implicit none + TYPE(gtp_equilibrium_data), pointer :: ceq + integer iph,nsl,only,nend,ny,jend(3),ifra(3) + double precision yfra(*),gval,xmol(*) + integer, dimension(nsl,nend) :: endm +!-\end{verbatim} + integer lokres,ls +! preset fractions + double precision qq(5) + double precision, parameter :: yzero=1.0D-12 +! preset weights of endmembers + double precision, dimension(4), parameter:: ybas=& + [1.0D0,0.89D0,0.74D0,0.61D0] + double precision, dimension(4), parameter :: ybin=& + [0.11D0,0.26D0,0.39D0,0.15D0] + double precision, dimension(2), parameter :: yter=& + [0.11D0,0.13D0] +! When setting fractions one must have the sum of fractions in each sublattice +! equal to unity. This is done by weighting endmembers +! endm(ll,ie) is the index to constituent ie in sublattice ll +! With 3 sublattices with (2,2,4) constituents endm is +! endm(1,1)=1, endm(1,2)=2, +! endm(2,1)=3, endm(2,2)=4, +! endm(3,1)=5, endm(3,2)=6, endm(3,3)=7, endm(3,4)=8 +! jend(*) select endmember to mix, with two constitutions jend(3)=0 +! + do ls=1,ny + yfra(ls)=zero + enddo +! write(*,10)iph,jend,ifra +10 format('gix: ',i2,13x,3i3,2x,3i3) + do ls=1,nsl + yfra(endm(ls,jend(1)))=ybas(ifra(1)) + if(jend(2).gt.0) yfra(endm(ls,jend(2)))=& + yfra(endm(ls,jend(2)))+ybin(ifra(2)) + if(jend(3).gt.0) yfra(endm(ls,jend(3)))=& + yfra(endm(ls,jend(3)))+yter(ifra(3)) + enddo + if(only.gt.0) goto 1000 +! +! calculate G and composition and save + write(*,11)iph,(yfra(ls),ls=1,ny) +11 format('gyp: ',i2,25x,10(f6.3)) + call set_constitution(iph,1,yfra,qq,ceq) + if(gx%bmperr.ne.0) goto 1000 + call calcg(iph,1,0,lokres,ceq) + if(gx%bmperr.ne.0) goto 1000 +! + if(qq(1).ge.1.0D-1) then +! number of real atoms less than 10%, a gridpoint with just vacancies .... + gval=real(ceq%phase_varres(lokres)%gval(1,1)/qq(1)) + else + gval=1.0E5 + endif + call calc_phase_mol(iph,xmol,ceq) + if(gx%bmperr.ne.0) goto 1000 +1000 continue + return + end subroutine new_gridpoint_calc + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine generate_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,ceq) +! Different action depending of the value of mode, +! for mode<0: +! return the number of gridpoints that will be generated for phase iph in ngg +! for mode=0: +! return garr(i) gibbs energy and xarr(1,i) the compositions of gridpoint i +! for mode>0: +! return site fractions of gridpoint mode in yarr, number of fractions in ny +! iph is phase number, ngg is number of gridpoints, nrel number of elements, +! if mode=0: +! return xarr mole fractions of gridpoints, garr Gibbs energy of gridpoints, +! ngg is dimension of garr +! if mode>0: +! "mode" is a gridpoint of this phase in solution, return number of +! constituent fractions in ny and fractions in yarr for this gridpoint +! The current constitution is restored at the end of the subroutine + implicit none + TYPE(gtp_equilibrium_data), pointer :: ceq + integer mode,iph,ngg,nrel,ny + real xarr(nrel,*),garr(*) + double precision yarr(*) +!\end{verbatim} +! + integer lokph,errsave + double precision, parameter :: yzero=1.0D-12 + integer abrakadabra,i,ibas,ibin,iend,is,iter,je,jend,kend,ll,ls,nend + double precision ydum(maxconst) + integer ngdim,nsl + integer nkl(maxsubl),knr(maxconst),inkl(0:maxsubl),nofy + double precision, dimension(:), allocatable :: yfra + double precision sites(maxsubl),qq(5) +! endm(i,j) has constituent indices in i=1..nsl for endmember j + integer, dimension(:,:), allocatable :: endm +!-------------------------------- +! grid is generated by combining end endmembers +! Number of endmemers is N +! For endmember E=1..N set fraction of enmember +! 0.99*Y_E + 0.01*Y_all N of these +! 0.89*Y_E + 0.10*Y_F,F=/=E + 0.01*Y_all N*(N-1) +! 0.74*Y_E + 0.25*Y_F,F=/=E + 0.01*Y_all N*(N-1)+N*(N-1)*(N-2) +! + 0.15*Y_F + 0.1*Y_G,G=/=(E,F) + 0.01*Y_all (3 or more endmemb) +! 0.61*Y_E + 0.38*Y_F,F=/=E + 0.01*Y_all +! + 0.25*Y_F + 0.13*Y_G,G=/=(E,F) + 0.01*Y_all (3 or more endmemb) +!----- N=2: total 2+2+2+2=8 +!----- N>2: total N*(1+(N-1)*(3+2*(N-2))); N=3:33, N=20: +! with 2 endmembers: 2*(1+3)=2*4=8 +! (1.00,0.00) +! (0.89,0.11) (0.74,0.26) (0.61,39) +! (0.00,1.00) ... +! with 3 endmembers: 3*11=33 gridpoints +! (1.00,0.00,0.00) +! (0.89,0.11,0.00)(0.89,0.00,0.11) +! (0.74,0.26,0.00)(0.74,0.00.0.26)(0.74,0.15,0.11)(0.74,0.11,0.15) +! (0.61,0.38,0.00)(0.61,0.00,0.38)(0.61,0.25,0.14)(0.61,0.14,0.25) +! (0.00,1.00,0.00) +! (0.11,0.89,0.00)(0.00,0.89.0.11) +! with 4 endmembers: +! (0.9925,0.0025,0.0025.0.0025) +! (0.8925,0.1025,0.0025,0.0025) (-,0.0025,0.1025,-) (-,.0025,.0025,.1025) ... +!--------- +! for n>50 only endmember: 51:51, N:N +! for n=31-50 only one binary combination: +! for n=26-30 only two binary combinations: +! for n=2 and n=15-25 three binary cobinations: +! for n=11-14 three binary and one ternary combination +! for n<=10 use full grid: 2 binar and 2 ternar combinarions + double precision, dimension(4), parameter:: ybas=& + [1.0D0,0.89D0,0.74D0,0.61D0] + double precision, dimension(4), parameter :: ybin=& + [0.11D0,0.26D0,0.39D0,0.15D0] + double precision, dimension(3), parameter :: yter=[0.0D0,0.11D0,0.13D0] +! for output of gridpoints + integer jbas,sumngg,loksp + logical trace,isendmem + save sumngg +! +! write(*,*)'entering generate_grid: ',mode,iph,ngg + if(test_phase_status_bit(iph,PHEXCB)) then +! This phase has charged endmembers, generate neutral gridpoints + call generate_charged_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,ceq) + goto 1000 + elseif(test_phase_status_bit(iph,PHFORD)) then +! this phase has 4 sublattice fcc/hcp tetrahedral ordering, +! this reduces the number of gridpoints + call generate_fccord_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,ceq) +! not implemented so ignore at present +! goto 1000 + endif + if(mode.eq.0) then +! write(*,*)'Generating grid for phase: ',iph +! trace TRUE means generate outpt for each gridpoint +! trace=.TRUE. + trace=.FALSE. + if(iph.eq.1 .and. trace) then + open(31,file='gridgen.dat ',access='sequential') + sumngg=0 + write(31,43) +43 format('The constituent fractions, y, enclosed within parentheses',& + 'for each sublattice'/'Mole fractions after x:, Gibbs energies',& + ' after G:'/) + endif + if(trace) then + call get_phase_record(iph,nend) + write(31,44)iph,phlista(nend)%name +44 format('Endmembers (EM) and gridpoints (GP) for phase: ',i3,1x,a) + endif + else + trace=.FALSE. + endif + call get_phase_data(iph,1,nsl,nkl,knr,ydum,sites,qq,ceq) + if(gx%bmperr.ne.0) goto 1000 +! calculate the number of endmembers and index of first constituent in subl ll + nend=1 + inkl(0)=0 + do ll=1,nsl + nend=nend*nkl(ll) + inkl(ll)=inkl(ll-1)+nkl(ll) + enddo +! iliqneut=0 +! ionic liquids with neutrals .... +! if(test_phase_status_bit(iph,PHIONLIQ)) then +! loksp=0 +! do ny=nkl(1)+1,inkl(2) +! loksp=knr(ny) +! write(*,63)'3Y species: ',ny,knr(ny),loksp,& +! splista(loksp)%charge,splista(loksp)%symbol +63 format(a,3i4,F10.5,2x,a) +! if(.not.btest(splista(loksp)%status,SPVA) .and. & +! abs(splista(loksp)%charge).eq.zero) then +! we have a neutral (vacancies has no mass), add an endmember for that +! iliqneut=iliqneut+1 +! write(*,*)'3Y check for neutral: ',ny,iliqneut +! endif +! enddo +! endif +! + ny=inkl(nsl) +! write(*,1010)'Saved ',iph,(ydum(i),i=1,ny) + negmode: if(mode.lt.0) then +!--------------------------------------------------------- +! just determine the number of gridpoints for this phase for global minimimum +! ideal gases should just have the endmembers .... +! Hm, gases with ions?? + ngdim=ngg + ngg=nend + lokph=phases(iph) + if(nend.eq.1 .or. nend.gt.50 .or. & + btest(phlista(lokph)%status1,PHID)) then +! >50 or 1 endmember or ideal phase: only endmembers + ngg=nend + elseif(nend.gt.30) then +! 31-50: only one binary combination + ngg=nend*nend + elseif(nend.gt.25) then +! 26-30: two binary combinations + ngg=nend*(1+2*(nend-1)) + elseif(nend.eq.2 .or. nend.ge.15) then +! 2 or 15-25: three binary combinarions + ngg=nend*(1+3*(nend-1)) + elseif(nend.gt.10) then +! 11-14: three binary and one ternary combinarion + ngg=nend*(1+(nend-1)*(3+nend-2)) ! (ternary combination skipped) + ngg=nend*(1+3*(nend-1)) + else +! 3-10: three binary and two ternary combinarions (all) + ngg=nend*(1+(nend-1)*(3+2*(nend-2))) ! (ternary combinations skipped) + ngg=nend*(1+3*(nend-1)) + endif +! write(*,*)'endmembers and gridpoints: ',nend,ngg +! read(*,11)ch1 +11 format(a) +! ngg=ngg+iliqneut + ngg=ngg + if(ocv()) write(*,*)'Generate grid: ',nend,ngg + ny=nend + goto 1001 + endif negmode +!------------------------------------------------------------ +! for mode=0: +! set gridpoint sitefractions and calculate G +! for mode>0: +! return sitefractions (for mode=gridpoint number (part of the solution)) +! BUT: The only way to find the site fraction of a gripoint is to generate +! all gridpoints up the one specified by the value of mode (no G calculation) +! write(*,*)'ggy: ',mode,iph,nsl,nend,inkl(nsl) +! gx%bmperr=7777; goto 1000 + allocate(endm(nsl,nend)) + allocate(yfra(inkl(nsl))) + nofy=inkl(nsl) +! generate endmembers, endm(ll,ie) is set to consituent index in sublattice ll + je=1 + do ll=1,nsl + endm(ll,je)=inkl(ll-1)+1 + enddo +100 continue + je=je+1 + if(je.gt.nend) goto 120 + do ls=1,nsl + endm(ls,je)=endm(ls,je-1) + enddo + ll=0 +110 ll=ll+1 + if(endm(ll,je).lt.inkl(ll)) then + endm(ll,je)=endm(ll,je)+1 + elseif(ll.lt.nsl) then + endm(ll,je)=inkl(ll-1)+1 + goto 110 + else + gx%bmperr=4148; goto 1000 + endif + goto 100 +120 continue +! if(trace) then +! do i=1,nend +! write(31,125)i,(endm(ls,i),ls=1,nsl) +!125 format('endmem: ',i4,2x,10i3) +! enddo +! endif +150 continue +!--------------------------------------- +! now generate all combinations of endmembers +! write(*,*)'endmembers and gridpoints: ',nend,ngg +! read(*,11)ch1 + ngg=0 + lokph=phases(iph) + endmem: do iend=1,nend + yfra=yzero + do ls=1,nsl + yfra(endm(ls,iend))=ybas(1) + enddo + isendmem=.TRUE. +! initiate the loop veriables below for endmembers and fractions + ibas=2 + ibin=1 + iter=1 + jend=0 + kend=0 +200 continue + ngg=ngg+1 + if(mode.gt.0) then + if(ngg.eq.mode) goto 500 + else +! calculate G and composition and save +! write(*,201)ibas,ngg,(yfra(is),is=1,inkl(nsl)) +201 format('ggz: ',i2,i5,10(F6.3)) + if(ocv()) write(*,*)'Calculating gridpoint: ',ngg + call calc_gridpoint(iph,yfra,nrel,xarr(1,ngg),garr(ngg),ceq) + if(gx%bmperr.ne.0) goto 1000 +! if(ngg.eq.15) then +! write(*,520)'cgx: ',(xarr(is,ngg),is=1,nrel) +! endif + if(trace) then + if(isendmem) then + write(31,153,advance='no')sumngg+ngg +153 format('EM:',i4,' y: ') + else + write(31,154,advance='no')sumngg+ngg +154 format('GP:',i4,' y: ') + endif + jbas=0 + do ls=1,nsl + write(31,155,advance='no')(yfra(jbas+is),is=1,nkl(ls)-1) +155 format('(',10(F4.2,',')) + write(31,156,advance='no')yfra(jbas+nkl(ls)) +156 format(F4.2,')') + jbas=jbas+nkl(ls) + enddo + write(31,157)(xarr(is,ngg),is=1,nrel),garr(ngg) +157 format(' x:',3f8.5,' G:',1pe12.4) + endif + isendmem=.FALSE. + endif +! depending on nend value or ideal generate combinations + if(nend.eq.1 .or. nend.gt.50 .or. & + btest(phlista(lokph)%status1,PHID)) cycle + yfra=yzero + combend: if(nend.gt.30) then +! if nend=31..50, one binary combination, 961-2500 +! 0.89*Y_E + 0.11*Y_F,F=/=E + jend=jend+1 + if(jend.eq.iend) jend=jend+1 + if(jend.gt.nend) cycle + do ls=1,nsl + yfra(endm(ls,iend))=ybas(ibas) + yfra(endm(ls,jend))=yfra(endm(ls,jend))+ybin(ibin) + enddo + goto 200 + elseif(nend.gt.25) then +! nend=26..30 two binary combinations, 1326-1770 +! 0.89*Y_E + 0.11*Y_F,F=/=E +! 0.74*Y_E + 0.26*Y_F,F=/=E + jend=jend+1 + if(jend.eq.iend) jend=jend+1 + if(jend.gt.nend) then + if(ibas.eq.3) cycle + jend=1 + ibas=3; ibin=2 + endif + do ls=1,nsl + yfra(endm(ls,iend))=ybas(ibas) + yfra(endm(ls,jend))=yfra(endm(ls,jend))+ybin(ibin) + enddo + goto 200 + elseif(nend.eq.2 .or. nend.ge.15) then +! nend=2 or nend=15..25, three binary combinations, ??-1825 +! 0.89*Y_E + 0.11*Y_F,F=/=E +! 0.74*Y_E + 0.25*Y_F,F=/=E +! 0.61*Y_E + 0.39*Y_F,F=/=E + jend=jend+1 + if(jend.eq.iend) jend=jend+1 + if(jend.gt.nend) then + if(ibas.eq.4) cycle + ibas=ibas+1; ibin=ibin+1 + jend=1 + if(jend.eq.iend) jend=jend+1 + endif + do ls=1,nsl + yfra(endm(ls,iend))=ybas(ibas) + yfra(endm(ls,jend))=yfra(endm(ls,jend))+ybin(ibin) + enddo + goto 200 + elseif(nend.gt.10) then +! complicated here, iterating in both binary and ternary combinations .... +! nend=11..14, 3 binary and one ternary combination, 1331-2744 +! 0.89*Y_E + 0.11*Y_F,F=/=E +! 0.74*Y_E + 0.26*Y_F,F=/=E +! + 0.15*Y_F + 0.11*Y_G,G=/=(E,F) +! 0.61*Y_E + 0.39*Y_F,F=/=E + if(iter.eq.2) then +! we are interating in the ternary endmember + stop 'no ternary for 10>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! the gridpoint has net charge, qq(2), make gval more positive. +! Note gval(1,1) is divided by RT so around -5<0 +! A better method is needed by combining charged gripoints!!!! +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! gval=real(ceq%phase_varres(lokres)%gval(1,1)/qq(1)+20*qq(2)**2) +! gval=real(ceq%phase_varres(lokres)%gval(1,1)/qq(1)+5*qq(2)**2) + gval=real(ceq%phase_varres(lokres)%gval(1,1)/qq(1)+qq(2)**2) + if(ocv()) write(*,66)'3Y charged gp: ',& + ceq%phase_varres(lokres)%gval(1,1)/qq(1),qq(1),abs(qq(2)) +66 format(a,6(1pe12.4)) + else + gval=real(ceq%phase_varres(lokres)%gval(1,1)/qq(1)) + endif +! read(*,20)ch1 +20 format(a) +1000 continue +! check for parallel +! jip=omp_get_thread_num() +! write(*,1010)jip,gval,gx%bmperr +1010 format('Thread ',i3,', gval: ',1pe15.6,', error: ',i6) + return + end subroutine calc_gridpoint + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine generate_fccord_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,ceq) +! This generates grid for a phase with 4 sublattice fcc/hcp ordering +! mode<0 just number of gridpoints in ngg, needed for allocations +! mode=0 calculate mole fraction and G for all gridpoints +! mode>0 return constitution for gridpoint mode in yarr + implicit none + integer mode,iph,ngg,nrel,ny + real xarr(nrel,*),garr(*) + double precision yarr(*) + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} +! NOTHING IMPLEMENTED YET + write(*,*)'FCC/HCP tetraherdal ordering not handelled gracefully' +1000 continue + return + end subroutine generate_fccord_grid + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine generate_charged_grid(mode,iph,ngg,nrel,xarr,garr,ny,yarr,ceq) +! This generates grid for a phase with charged constituents +! mode<0 just number of gridpoints in ngg, needed for allocations +! mode=0 calculate mole fraction and G for all gridpoints +! mode>0 return constitution for gridpoint mode in yarr + implicit none + integer mode,iph,ngg,nrel,ny + real xarr(nrel,*),garr(*) + double precision yarr(*) + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer nkl(maxsubl),knr(maxconst),inkl(0:maxsubl) + double precision, dimension(:), allocatable :: yfra + double precision sites(maxsubl),ydum(maxconst),qq(5) + integer nend,ll,nsl,i1,i2,i3,loksp,mm,lokph,lokcs,np,nm,nn,ncc,iz,loopf + integer, dimension(:,:), allocatable :: neutral + integer, dimension(:), allocatable :: savengg +! integer ielno(10) +! double precision stoi(10),smass,qsp + double precision charge,ratio1,ratio2 + double precision, dimension(:), allocatable :: y1,y2,y3,y4,y5 + real xdum(nrel),gdum + integer, parameter :: ncf5=5,ncf3=3 + integer ncf +! These are used to combine endmembers + double precision, dimension(7), parameter :: nfact=& + [0.01D0,0.1D0,0.33D0,0.51D0,0.67D0,0.9D0,0.99D0] + double precision, dimension(ncf5), parameter :: cfact5=& + [0.05D0,0.3D0,0.5D0,0.7D0,0.95D0] + double precision, dimension(ncf3), parameter :: cfact3=& + [0.1D0,0.5D0,0.9D0] + logical single +! all endmembers will have a record of this type + type gtp_charged_endmem +! one species number for each sublattice + integer, dimension(:), allocatable :: constit + double precision charge + end type gtp_charged_endmem + type(gtp_charged_endmem), dimension(:), allocatable :: endmem +! this should be saved or passed as argument + save savengg +! here we will be able to select 5 or 3 gripoints + ncf=ncf5 + if(.not.allocated(savengg)) then + allocate(savengg(noofph)) + savengg=0 + endif +! get the phase data + call get_phase_data(iph,1,nsl,nkl,knr,ydum,sites,qq,ceq) + if(gx%bmperr.ne.0) goto 1000 +! +! I will handle this in a very clumsy way by generate all endmembers +! with their charge and then try to combine them to get neutral gridpoints. + nend=1 + inkl(0)=0 + do ll=1,nsl + nend=nend*nkl(ll) +! inkl(ll) is the number of constituents up to and including sublattice ll + inkl(ll)=inkl(ll-1)+nkl(ll) + enddo +! write(*,*)'Charged grid for phase ',iph,mode,nend + if(nend.eq.1) then +! a single endmember, just check it is neutral + ngg=1 + do ll=1,nsl + loksp=knr(ll) + charge=charge+sites(ll)*splista(loksp)%charge + enddo + if(charge.eq.zero) then + np=ngg + if(mode.eq.0) then +! if mode=0 calculate G for this endmember +! write(*,*)'3Y a single neutral endmember for ',iph,mode + call calc_gridpoint(iph,ydum,nrel,xarr(1,ngg),garr(ngg),ceq) + if(gx%bmperr.ne.0) goto 1000 +! elseif(mode,gt.0) then +! if mode>0 return constitution, already set + endif +! finally remove the request for external charge balance !!! +! write(*,*)'No external charge balance for phase:',iph,lokcs,mode + call get_phase_compset(iph,1,lokph,lokcs) + phlista(lokph)%status1=ibclr(phlista(lokph)%status1,PHEXCB) + goto 1000 + endif + ngg=0 + call get_phase_compset(iph,1,lokph,lokcs) + write(*,*)'Phase suspended as net charge: ',phlista(lokph)%name +! suspend all composition sets + do mm=1,phlista(lokph)%noofcs + lokcs=phlista(lokph)%linktocs(mm) + ceq%phase_varres(lokcs)%phstate=PHSUS + enddo + goto 1000 + endif + np=0 + nm=0 + nn=0 +! write(*,10)'3Y nend: ',nend,0.0D0,(nkl(ll),ll=1,nsl) +10 format(a,i3,5x,1pe12.4,10i3) +! allocate a record for each endmembers + allocate(endmem(nend)) + allocate(endmem(1)%constit(nsl)) + charge=zero + do ll=1,nsl + endmem(1)%constit(ll)=inkl(ll-1)+1 + loksp=knr(endmem(1)%constit(ll)) +! write(*,*)'3Y species location: ',loksp +! call get_species_data(loksp,mm,ielno,stoi,smass,qsp) +! if(gx%bmperr.ne.0) goto 1000 + charge=charge+sites(ll)*splista(loksp)%charge + enddo + endmem(1)%charge=charge +! write(*,15)'3Y end1: ',mode,iph,nsl,charge,1,endmem(1)%constit +15 format(a,3i3,1pe12.4,i4,2x,8i3) + if(charge.gt.zero) then + np=np+1 + elseif(charge.lt.zero) then + nm=nm+1 + else + nn=nn+1 + endif +! write(*,10)'3Y endmem: ',1,charge,endmem(1)%constit + emloop: do i2=2,nend + allocate(endmem(i2)%constit(nsl)) + endmem(i2)%constit=endmem(i2-1)%constit + sloop: do ll=1,nsl + if(endmem(i2)%constit(ll).lt.inkl(ll)) then + exit sloop + elseif(ll.lt.nsl) then + endmem(i2)%constit(ll)=endmem(1)%constit(ll) + else + exit emloop + endif + enddo sloop + endmem(i2)%constit(ll)=endmem(i2)%constit(ll)+1 + charge=zero + do mm=1,nsl + loksp=knr(endmem(i2)%constit(mm)) + charge=charge+sites(mm)*splista(loksp)%charge + enddo + endmem(i2)%charge=charge +! write(*,15)'3Y endx: ',mode,iph,nsl,charge,i2,endmem(i2)%constit + if(charge.gt.zero) then + np=np+1 + elseif(charge.lt.zero) then + nm=nm+1 + else + nn=nn+1 + endif + enddo emloop +! write(*,22)'3Y endmem: ',iph,np,nm,nn +22 format(a,i3,10i4) +! write(*,10)'3Y endmem: ',i2,endmem(i2)%charge,& +! (splista(knr(endmem(i2)%constit(ll)))%alphaindex,ll=1,nsl) +! enddo +! calculate the number of gridpoints, consider single endmembers, +! binary and ternary combinations in a triple loop + np=0 + nn=0 + if(mode.ge.0) then +! we have saved the number of gridpoints from the mode=-1 call here + np=savengg(iph) +! write(*,*)'3Y allocate neutral',mode,np + allocate(neutral(np,0:3)) + neutral=0 + endif + np=0 + loop1: do i1=1,nend + charge1A: if(endmem(i1)%charge.eq.zero) then +! first endmember neutral, one gridpoint + np=np+1 + if(mode.ge.0) then +! for generating Y and G we save which endmembers to combine in neutral(*,0) + neutral(np,0)=0 + neutral(np,1)=i1 + endif +! write(*,298)'3Y generating 1 gp: ',np,1,mode,0,i1,0,0 +298 format(a,i5,i2,i5,i2,2x,3i3) + endif charge1A + loop2: do i2=i1+1,nend + charge1: if(endmem(i1)%charge.eq.zero) then +! first endmember neutral, that gridpoint already created + charge2A: if(endmem(i2)%charge.eq.zero) then +!----------------------------------------------------------------------- +! second endmember neutral, generate 7 points between them, (the point at pure +! i2 that will be generated later): 0.01; 0.1; 0.34; 0.51; 0.67; 0.9; 0.99 + if(mode.ge.0) then + do ll=1,7 + neutral(np+ll,0)=1 + neutral(np+ll,1)=i1 + neutral(np+ll,2)=i2 + enddo + endif +! write(*,298)'3Y generating 7 gps: ',np+1,3,mode,1,i1,i2,0 + np=np+7 + else +!----------------------------------------------------------------------- +! second endmember has charge, a third endmember needed with opposite charge + loop3A: do i3=i2+1,nend + if(endmem(i2)%charge*endmem(i3)%charge.lt.zero) then +! second and third endmembers have opposite charge, we have ncf gridpoints +! I1_n(I2_(1/c2)I3_(1/c3)_(1-n) where c2 is charge of i2 and c3 charge of i3 + if(mode.ge.0) then + do ll=1,ncf + neutral(np+ll,0)=2 + neutral(np+ll,1)=i1 + neutral(np+ll,2)=i2 + neutral(np+ll,3)=i3 + enddo + endif +! write(*,298)'3Y generating 3 gps: ',np+1,3,mode,2,i1,i2,i3 + np=np+ncf + endif + enddo loop3A + endif charge2A +!======================================================================= +! first endmember has a charge + elseif(endmem(i2)%charge.eq.zero) then +! second endmember is neutral, we need a third with opposite charge to first + loop3B: do i3=i2+1,nend + if(endmem(i1)%charge*endmem(i3)%charge.lt.zero) then +! first and third endmembers have opposite charge, we have ncf gridpoints +! (I1_(1/c1)I3_(1/c3))_n(I2)_(1-n) where c1 is charge of i1 and c3 charge of i3 +! where n is 0.1; 0.5; 0.9 + if(mode.ge.0) then + do ll=1,ncf + neutral(np+ll,0)=3 + neutral(np+ll,1)=i1 + neutral(np+ll,2)=i2 + neutral(np+ll,3)=i3 + enddo + endif +! write(*,298)'3Y generating 3 gps: ',np+1,3,mode,3,i1,i2,i3 + np=np+ncf + endif + enddo loop3B +!----------------------------------------------------------------------- +! first and second endmembers have charge with opposite sign + elseif(endmem(i1)%charge*endmem(i2)%charge.lt.zero) then +! we have one gridpoint I1_(1/c1)I2_(1/c2) + np=np+1 + if(mode.ge.0) then + neutral(np,0)=4 + neutral(np,1)=i1 + neutral(np,2)=i2 + endif +! write(*,298)'3Y generating 1 gp: ',np,1,mode,4,i1,i2,0 +!----------------------------------------------------------------------- + loop3C: do i3=i2+1,nend + charge3A: if(endmem(i3)%charge.eq.zero) then +! third is neutral, we have ncf more gripoints +! at (I1_(1/c1)I2_(1/c2))_n(I3)_(1-n) + if(mode.ge.0) then + do ll=1,ncf + neutral(np+ll,0)=5 + neutral(np+ll,1)=i1 + neutral(np+ll,2)=i2 + neutral(np+ll,3)=i3 + enddo + endif +! write(*,298)'3Y generating 3 gps: ',np+1,3,mode,5,i1,i2,i3 + np=np+ncf + elseif(endmem(i1)%charge*endmem(i3)%charge.lt.zero) then +!------------------------------------------------------------- +! all 3 endmembers are charged, those of i2 and i3 have same sign, ncf gridp +! (I1_(1/c1)I2_(1/c2))_n(I1_(1/c1)I3_(1/c3))_(1-n) + if(mode.ge.0) then + do ll=1,ncf + neutral(np+ll,0)=6 + neutral(np+ll,1)=i1 + neutral(np+ll,2)=i2 + neutral(np+ll,3)=i3 + enddo + endif +! write(*,298)'3Y generating 3 gps: ',np+1,3,mode,6,i1,i2,i3 + np=np+ncf + else +!------------------------------------------------------------- +! all 3 endmembers are charged, those of i1 and i3 have same sign, ncf gridp +! (I1_(1/c1)I2_(1/c2))_n(I2_(1/c2)I3_(1/c3))_(1-n) + if(mode.ge.0) then + do ll=1,ncf + neutral(np+ll,0)=7 + neutral(np+ll,1)=i1 + neutral(np+ll,2)=i2 + neutral(np+ll,3)=i3 + enddo + endif +! write(*,298)'3Y generating 3 gps: ',np+1,3,mode,7,i1,i2,i3 + np=np+ncf + endif charge3A + enddo loop3C +!----------------------------------------------------------------------- +! first and second endmembers have charge with same sign + else +! we need a third endmember with opposite charge + loop3D: do i3=i2+1,nend + if(endmem(i1)%charge*endmem(i3)%charge.lt.zero) then +! all 3 endmembers are charged, those of i1 and i2 have same sign, ncf gridp +! (I1_(1/c1)I3_(1/c2))_n(I2_(1/c1)I3_(1/c3))_(1-n) + if(mode.ge.0) then + do ll=1,ncf + neutral(np+ll,0)=8 + neutral(np+ll,1)=i1 + neutral(np+ll,2)=i2 + neutral(np+ll,3)=i3 + enddo + endif +! write(*,298)'3Y generating 3 gps: ',np+1,3,mode,8,i1,i2,i3 + np=np+ncf + endif + enddo loop3D + endif charge1 + enddo loop2 + enddo loop1 +!======================================================================= + if(mode.lt.0) then +! we have just calculated the number of gridpoints, save and exit +! write(*,*)'3Y neutral gridpoints: ',np + ngg=np + savengg(iph)=ngg + else +! Generate the composition of the gridpoints from 1-3 endmembers and +! if mode=0 calculate the composition and Gibbs energy for the gridpoints +! if mode>0 return the constitution of gridpoint mode. +! How do I know mode is mode gridpoint in this phase?? +! write(*,29)'3Y we are here?',iph,mode,np,nsl,inkl(nsl) +29 format(a,10i5) + ncc=inkl(nsl) + allocate(y1(ncc)) + allocate(y2(ncc)) + allocate(y3(ncc)) + allocate(y4(ncc)) +! loopf keeps track if several gridpoints belong together + loopf=0 + ygen: do nm=1,np +! neutral(nm,0) is endmember combination (0 to 8), ,1..3) is endmember index + nn=neutral(nm,0) + i1=neutral(nm,1) + i2=neutral(nm,2) + i3=neutral(nm,3) + if(loopf.eq.0) then +! when loopf=0 we have a new set of endmembers, zero yi + y1=zero + y2=zero + y3=zero + endif +! we must generate all gridpoints to have corrrect loopf +! if(mode.gt.0) then +! if(mode.ne.nm) exit +! cycle +! endif +! now we must generate correct constituent fractions and calculate G (mode=0) + select case(nn) + case default + write(*,*)'3Y case error in generate_charged_grid!!' +!----------------------- first endmember is neutral, 1 gridpoint +! single neutral endmember + case(0) + do ll=1,nsl + y1(endmem(i1)%constit(ll))=one + enddo + y4=y1 +! write(*,300)'3Y gp* ',nm,nn,loopf,i1,i2,i3,zero,y4 +300 format(a,i4,2i2,3i3,1pe10.2,8(0pf6.3)) +!----------------------- first and second endmembers are neutral, 7 gridpoints +! combine with factors: 0.01; 0.10; 0.33; 0.51; 0.67; 0.9; 0.01 + case(1) + if(loopf.eq.0) then + do ll=1,nsl + y1(endmem(i1)%constit(ll))=one + y2(endmem(i2)%constit(ll))=one + enddo + endif + loopf=loopf+1 + do iz=1,ncc + y4(iz)=nfact(loopf)*y1(iz)+nfact(8-loopf)*y2(iz) + enddo + if(loopf.ge.7) loopf=0 +! write(*,300)'3Y gp* ',nm,nn,loopf,i1,i2,i3,zero,y4 +!----------------------- first endmember is neutral, 2 and 3 charged, 3 gridp +! ratio 2/3 depend on charge, ratio 1/(2+3) + case(2) + if(loopf.eq.0) then + do ll=1,nsl + y1(endmem(i1)%constit(ll))=one + y2(endmem(i2)%constit(ll))=one + y3(endmem(i3)%constit(ll))=one + enddo + ratio1=abs(endmem(i3)%charge)/& + (abs(endmem(i2)%charge)+abs(endmem(i3)%charge)) + ratio2=abs(endmem(i2)%charge)/& + (abs(endmem(i2)%charge)+abs(endmem(i3)%charge)) + do iz=1,ncc + y2(iz)=ratio1*y2(iz)+ratio2*y3(iz) + enddo + charge=ratio1*endmem(i2)%charge+ratio2*endmem(i3)%charge + endif + loopf=loopf+1 + do iz=1,ncc + y4(iz)=cfact5(loopf)*y1(iz)+cfact5(ncf+1-loopf)*y2(iz) + enddo + if(loopf.ge.ncf) loopf=0 +! write(*,300)'3Y gp* ',nm,nn,loopf,i1,i2,i3,charge,y4 +!----------------------- first charged, second neutral, third charged, 3 gridp +! ratio 1/3 depend on charge, ratio 2/(1+3): 0.1; 0.5; 0.9 + case(3) + if(loopf.eq.0) then + do ll=1,nsl + y1(endmem(i1)%constit(ll))=one + y2(endmem(i2)%constit(ll))=one + y3(endmem(i3)%constit(ll))=one + enddo +! neutral combination of 1 and 3 + ratio1=abs(endmem(i3)%charge)/& + (abs(endmem(i3)%charge)+abs(endmem(i1)%charge)) + ratio2=abs(endmem(i1)%charge)/& + (abs(endmem(i3)%charge)+abs(endmem(i1)%charge)) + do iz=1,ncc + y1(iz)=ratio1*y1(iz)+ratio2*y3(iz) + enddo + charge=ratio1*endmem(i1)%charge+ratio2*endmem(i3)%charge + endif + loopf=loopf+1 + do iz=1,ncc + y4(iz)=cfact5(loopf)*y1(iz)+cfact5(ncf+1-loopf)*y2(iz) + enddo + if(loopf.ge.ncf) loopf=0 +! write(*,300)'3Y gp* ',nm,nn,loopf,i1,i2,i3,charge,y4 +!----------------------- first charged, second opposite, 1 gridp +! ratio 1/2 depend on charge + case(4) + do ll=1,nsl + y1(endmem(i1)%constit(ll))=one + y2(endmem(i2)%constit(ll))=one + enddo +! neutral combination of 1 and 2 + ratio1=abs(endmem(i2)%charge)/& + (abs(endmem(i1)%charge)+abs(endmem(i2)%charge)) + ratio2=abs(endmem(i1)%charge)/& + (abs(endmem(i1)%charge)+abs(endmem(i2)%charge)) + do iz=1,ncc + y4(iz)=ratio1*y1(iz)+ratio2*y2(iz) + enddo + charge=ratio1*endmem(i1)%charge+ratio2*endmem(i2)%charge +! write(*,300)'3Y gp* ',nm,nn,loopf,i1,i2,i3,charge,y4 +!----------------------- first charged, second opposite, third neutral, 3 gridp +! ratio 1/2 depend on charge, ratio 3(1+2): 0.1; 0.5; 0.9 + case(5) + if(loopf.eq.0) then + do ll=1,nsl + y1(endmem(i1)%constit(ll))=one + y2(endmem(i2)%constit(ll))=one + y3(endmem(i3)%constit(ll))=one + enddo +! neutral combination of 1 and 2 + ratio1=abs(endmem(i2)%charge)/& + (abs(endmem(i1)%charge)+abs(endmem(i2)%charge)) + ratio2=abs(endmem(i1)%charge)/& + (abs(endmem(i1)%charge)+abs(endmem(i2)%charge)) + do iz=1,ncc + y1(iz)=ratio1*y1(iz)+ratio2*y2(iz) + enddo + charge=ratio1*endmem(i1)%charge+ratio2*endmem(i2)%charge + endif + loopf=loopf+1 + do iz=1,ncc + y4(iz)=cfact5(loopf)*y1(iz)+cfact5(ncf+1-loopf)*y3(iz) + enddo + if(loopf.ge.ncf) loopf=0 +! write(*,300)'3Y gp* ',nm,nn,loopf,i1,i2,i3,charge,y4 +!----------------------- all charged, 2 and 3 same sign, 3 gridp +! ratio depend on charge + case(6) + if(loopf.eq.0) then + do ll=1,nsl + y1(endmem(i1)%constit(ll))=one + y2(endmem(i2)%constit(ll))=one + y3(endmem(i3)%constit(ll))=one + enddo +! neutral combination of 1 and 3 + ratio1=abs(endmem(i3)%charge)/& + (abs(endmem(i3)%charge)+abs(endmem(i1)%charge)) + ratio2=abs(endmem(i1)%charge)/& + (abs(endmem(i3)%charge)+abs(endmem(i1)%charge)) + do iz=1,ncc + y3(iz)=ratio1*y1(iz)+ratio2*y3(iz) + enddo + charge=ratio1*endmem(i1)%charge+ratio2*endmem(i3)%charge +! write(*,410)'3Y gp charge 1+3: ',nm,i1,i2,i3,& +! endmem(i1)%charge,endmem(i2)%charge,endmem(i3)%charge,& +! ratio1,ratio2,charge +! neutral combination of 1 and 2 + ratio1=abs(endmem(i2)%charge)/& + (abs(endmem(i1)%charge)+abs(endmem(i2)%charge)) + ratio2=abs(endmem(i1)%charge)/& + (abs(endmem(i1)%charge)+abs(endmem(i2)%charge)) + do iz=1,ncc + y1(iz)=ratio1*y1(iz)+ratio2*y2(iz) + enddo + charge=ratio1*endmem(i1)%charge+ratio2*endmem(i2)%charge + endif + loopf=loopf+1 + do iz=1,ncc + y4(iz)=cfact5(loopf)*y1(iz)+cfact5(ncf+1-loopf)*y3(iz) + enddo + if(loopf.ge.ncf) loopf=0 +! write(*,300)'3Y gp* ',nm,nn,loopf,i1,i2,i3,charge,y4 +!----------------------- all charged, 1 and 3 same sign, 3 gridp +! ratio depend on charge + case(7) + if(loopf.eq.0) then + do ll=1,nsl + y1(endmem(i1)%constit(ll))=one + y2(endmem(i2)%constit(ll))=one + y3(endmem(i3)%constit(ll))=one + enddo +! neutral combination of 1 and 2 + ratio1=abs(endmem(i2)%charge)/& + (abs(endmem(i2)%charge)+abs(endmem(i1)%charge)) + ratio2=abs(endmem(i1)%charge)/& + (abs(endmem(i2)%charge)+abs(endmem(i1)%charge)) + do iz=1,ncc + y1(iz)=ratio1*y1(iz)+ratio2*y2(iz) + enddo + charge=ratio1*endmem(i1)%charge+ratio2*endmem(i2)%charge +! write(*,410)'3Y gp charge 1+2: ',nm,i1,i2,i3,& +! endmem(i1)%charge,endmem(i2)%charge,endmem(i3)%charge,& +! ratio1,ratio2,charge +! neutral combination of 2 and 3 + ratio1=abs(endmem(i3)%charge)/& + (abs(endmem(i3)%charge)+abs(endmem(i2)%charge)) + ratio2=abs(endmem(i2)%charge)/& + (abs(endmem(i3)%charge)+abs(endmem(i2)%charge)) + do iz=1,ncc + y2(iz)=ratio1*y2(iz)+ratio2*y3(iz) + enddo + charge=ratio1*endmem(i2)%charge+ratio2*endmem(i3)%charge + endif + loopf=loopf+1 + do iz=1,ncc + y4(iz)=cfact5(loopf)*y1(iz)+cfact5(ncf+1-loopf)*y2(iz) + enddo + if(loopf.ge.ncf) loopf=0 +! write(*,300)'3Y gp* ',nm,nn,loopf,i1,i2,i3,charge,y4 +!----------------------- all charged, 1 and 2 same sign, 3 gridp +! ratio depend on charge + case(8) + if(loopf.eq.0) then + do ll=1,nsl + y1(endmem(i1)%constit(ll))=one + y2(endmem(i2)%constit(ll))=one + y3(endmem(i3)%constit(ll))=one + enddo +! neutral combination of 1 and 3 + ratio1=abs(endmem(i3)%charge)/& + (abs(endmem(i3)%charge)+abs(endmem(i1)%charge)) + ratio2=abs(endmem(i1)%charge)/& + (abs(endmem(i3)%charge)+abs(endmem(i1)%charge)) + do iz=1,ncc + y1(iz)=ratio1*y1(iz)+ratio2*y3(iz) + enddo + charge=ratio1*endmem(i1)%charge+ratio2*endmem(i3)%charge +! write(*,410)'3Y gp charge 1+3: ',nm,i1,i2,i3,& +! endmem(i1)%charge,endmem(i2)%charge,endmem(i3)%charge,& +! ratio1,ratio2,charge +410 format(a,i4,3i3,6(1pe10.2)) +! neutral combination of 2 and 3 + ratio1=abs(endmem(i3)%charge)/& + (abs(endmem(i3)%charge)+abs(endmem(i2)%charge)) + ratio2=abs(endmem(i2)%charge)/& + (abs(endmem(i3)%charge)+abs(endmem(i2)%charge)) + do iz=1,ncc + y2(iz)=ratio1*y2(iz)+ratio2*y3(iz) + enddo + charge=ratio1*endmem(i2)%charge+ratio2*endmem(i3)%charge + endif + loopf=loopf+1 + do iz=1,ncc + y4(iz)=cfact5(loopf)*y1(iz)+cfact5(ncf+1-loopf)*y2(iz) + enddo + if(loopf.ge.ncf) loopf=0 +! write(*,300)'3Y gp* ',nm,nn,loopf,i1,i2,i3,charge,y4 +!----------------------- + end select +!=============================================================== +! Here we have the neutral constituent fraction in y4 +! if mode>0 we have found the requested constitution + if(mode.lt.0) then + write(*,*)'We should never be here ...' + goto 1000 + elseif(mode.gt.0) then + if(mode.eq.nm) then + ny=ncc + do ll=1,ny + yarr(ll)=y4(ll) + enddo +! write(*,507)'3Y Solution gp: ',mode,iph,y4 +507 format(a,i5,i4,10F7.4) + goto 1000 + endif +! continue searching for correct gridpoint of the solution + else +! for mode=0 we must calculate G +! this is just for debugging +! call set_constitution(iph,1,y4,qq,ceq) +! if(gx%bmperr.ne.0) goto 1000 +! if(abs(qq(2)).gt.1.0D-6) then +! write(*,511)'3Y gp with charge: ',nm,iph,nn,qq(2) +511 format(a,i5,i4,i3,1pe12.4) +! endif +! +! call calc_gridpoint(iph,y4,nrel,xdum,gdum,ceq) + call calc_gridpoint(iph,y4,nrel,xarr(1,nm),garr(nm),ceq) + if(gx%bmperr.ne.0) goto 1000 +! write(*,512)nm,qq(2),gdum,xdum +512 format('3Y gridpoint: ',i4,2(1pe12.4),7(0pF7.4)) + endif + enddo ygen +! + endif +1000 continue +! restore original constitution +! write(*,*)'3Y Gridpoints for: ',iph,mode,np + call set_constitution(iph,1,ydum,qq,ceq) + if(gx%bmperr.ne.0) then + write(*,*)'Error restoring constitution for: ',iph,gx%bmperr + endif + return + end subroutine generate_charged_grid + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine calcg_endmember(iph,endmember,gval,ceq) +! calculates G for one mole of real atoms for a single end member +! used for reference states. Restores current composition (but not G or deriv) +! endmember contains indices in the constituent array, not species index +! one for each sublattice + implicit none + integer iph + double precision gval + integer endmember(maxsubl) + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} %+ + integer ierr,kk0,ll,lokres,nsl + integer nkl(maxsubl),knr(maxconst) + double precision savey(maxconst),sites(maxsubl),qq(5),yfra(maxconst) +! + call get_phase_data(iph,1,nsl,nkl,knr,savey,sites,qq,ceq) + if(gx%bmperr.ne.0) goto 1100 +! set constitution to be just the endmember +! It is difficult to make this simpler as one can have magnetic contributions +! to G, this it is not suffiecient jyst to calculate the G function, one must +! calculate TC etc. + yfra=zero + kk0=0 + do ll=1,nsl + if(endmember(ll).gt.kk0 .and. endmember(ll).le.kk0+nkl(ll)) then + yfra(endmember(ll))=one + else +! write(*,16)'3Y endmember index outside range',ll,endmember(ll),& +! kk0,nkl(ll) +16 format(a,10i5) + gx%bmperr=4160; goto 1100 + endif + kk0=kk0+nkl(ll) + enddo +! write(*,17)'set: ',kk0,(yfra(i),i=1,kk0) +17 format(a,i3,5(1pe12.4)) + call set_constitution(iph,1,yfra,qq,ceq) + if(gx%bmperr.ne.0) goto 1000 + call calcg(iph,1,0,lokres,ceq) + if(gx%bmperr.ne.0) goto 1000 + if(qq(1).ge.1.0D-3) then +! avoid calculating endmembers with too many vacancies. gval is divided by RT + gval=real(ceq%phase_varres(lokres)%gval(1,1)/qq(1)) +! write(*,*)'gval: ',gval,qq(1) + else +! write(*,*)'End member has no atoms' + gx%bmperr=4161; goto 1000 + endif +1000 continue + ierr=gx%bmperr + if(gx%bmperr.ne.0) gx%bmperr=0 +! restore constitution +! write(*,17)'res: ',kk0,(savey(i),i=1,kk0) + call set_constitution(iph,1,savey,qq,ceq) + if(gx%bmperr.ne.0) then + if(ierr.ne.0) then + write(*,*)'Double errors in calcg_endmember: ',ierr,gx%bmperr + endif + endif +! return first error if any + if(ierr.ne.0) gx%bmperr=ierr +1100 continue + return + end subroutine calcg_endmember + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} %- + subroutine calcg_endmember6(iph,endmember,gval,ceq) +! calculates G and all derivatevs wrt T and P for one mole of real atoms +! for a single end member, used for reference states. +! Restores current composition (but not G or deriv) +! endmember contains indices in the constituent array, not species index +! one for each sublattice + implicit none + integer iph + double precision gval(6) + integer endmember(maxsubl) + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer ierr,kk0,ll,lokres,lokph,nsl + integer nkl(maxsubl),knr(maxconst),ics + double precision savey(maxconst),sites(maxsubl),qq(5),yfra(maxconst) + double precision saveg(6) +! + call get_phase_data(iph,1,nsl,nkl,knr,savey,sites,qq,ceq) + if(gx%bmperr.ne.0) goto 1100 +! set constitution to be just the endmember +! It is difficult to make this simpler as one can have magnetic contributions +! to G, this it is not sufficient just to calculate the G function, one must +! calculate TC etc. + yfra=zero + kk0=0 +! write(*,11)'3Y refstate: ',iph,nsl,nkl(1),endmember(1) +11 format(a,10i5) + do ll=1,nsl + if(endmember(ll).gt.kk0 .and. endmember(ll).le.kk0+nkl(ll)) then + yfra(endmember(ll))=one + else +! write(*,16)'3Y endmember index outside range',ll,endmember(ll),& +! kk0,nkl(ll) +16 format(a,10i5) + gx%bmperr=4160; goto 1100 + endif + kk0=kk0+nkl(ll) + enddo +! write(*,17)'set: ',kk0,(yfra(i),i=1,kk0) +17 format(a,i3,5(1pe12.4)) + call set_constitution(iph,1,yfra,qq,ceq) + if(gx%bmperr.ne.0) goto 1000 +! we do not know lokres here !! + ics=1 + call get_phase_compset(iph,ics,lokph,lokres) + if(gx%bmperr.ne.0) goto 1000 + do ll=1,6 + saveg(ll)=ceq%phase_varres(lokres)%gval(ll,1)/qq(1) + enddo +! write(*,432)saveg +432 format('3Y::',6(1pe12.4)) +! third argument to calcg is 2 to calculate all derivatives + call calcg(iph,1,2,lokres,ceq) + if(gx%bmperr.ne.0) goto 1000 + if(qq(1).ge.1.0D-2) then +! avoid calculating endmembers with too many vacancies. gval is divided by RT +! gval(1..6,1) are G, G.T, G.P, G.T.T, G.T.P and G.P.P + do ll=1,6 + gval(ll)=ceq%phase_varres(lokres)%gval(ll,1)/qq(1) + enddo +! write(*,*)'gval: ',gval,qq(1) + else +! write(*,*)'End member has no atoms' + gx%bmperr=4161; goto 1000 + endif +! we do not restore values of other properties like TC BMAGN etc + do ll=1,6 + ceq%phase_varres(lokres)%gval(ll,1)=saveg(ll) + enddo +1000 continue + ierr=gx%bmperr + if(gx%bmperr.ne.0) gx%bmperr=0 +! restore constitution +! write(*,17)'res: ',kk0,(savey(i),i=1,kk0) + call set_constitution(iph,1,savey,qq,ceq) + if(gx%bmperr.ne.0) then + if(ierr.ne.0) then + write(*,*)'Double errors in calcg_endmember: ',ierr,gx%bmperr + endif + endif +! return first error if any + if(ierr.ne.0) gx%bmperr=ierr +1100 continue + return + end subroutine calcg_endmember6 + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!-\begin{verbatim} + subroutine calcg_endmember2(lokph,endmember,tpref,gval,ceq) +! calculates G for one mole of real atoms for a single end member +! used for reference states. Restores current composition (but not G or deriv) +! endmember contains indices in the constituent array, not species index +! THIS ONE NOT USED + implicit none + integer lokph + double precision gval,tpref(2) + integer endmember(maxsubl) + TYPE(gtp_equilibrium_data), pointer :: ceq +!-\end{verbatim} + integer ierr,kk0,ll,lokres,nsl,iph + integer nkl(maxsubl),knr(maxconst) + double precision savey(maxconst),sites(maxsubl),qq(5),yfra(maxconst),tps(2) +! + iph=phlista(lokph)%alphaindex + call get_phase_data(iph,1,nsl,nkl,knr,savey,sites,qq,ceq) + if(gx%bmperr.ne.0) goto 1100 +! set constitution to be just the endmember + yfra=zero + kk0=0 + do ll=1,nsl + if(endmember(ll).gt.kk0 .and. endmember(ll).le.nkl(ll)) then + yfra(endmember(ll))=one + else + write(*,11)'3Y endmember index outside range',ll,endmember(ll),nkl(ll) +11 format(a,10i4) + gx%bmperr=4160; goto 1100 + endif + kk0=kk0+nkl(ll) + enddo +! write(*,17)'set: ',kk0,(yfra(i),i=1,kk0) +!17 format(a,i3,5(1pe12.4)) + call set_constitution(iph,1,yfra,qq,ceq) + if(gx%bmperr.ne.0) goto 1000 +! if tpref(1) is negative use current T, else use T and P as in tpref + tps=ceq%tpval + if(tpref(1).gt.zero) then + ceq%tpval=tpref + endif + call calcg(iph,1,0,lokres,ceq) + if(gx%bmperr.ne.0) then + gval=zero + else + gval=ceq%phase_varres(lokres)%gval(1,1)/qq(1) + endif +!-------------------------------- +1000 continue + ceq%tpval=tps + ierr=0 + if(gx%bmperr.ne.0) then + ierr=gx%bmperr; gx%bmperr=0 + endif +! restore constitution and T and P +! write(*,17)'res: ',kk0,(savey(i),i=1,kk0) + call set_constitution(iph,1,savey,qq,ceq) + if(gx%bmperr.ne.0) then + if(ierr.ne.0) then + write(*,*)'Double errors: ',ierr,gx%bmperr + endif +! return first error + gx%bmperr=ierr + endif +1100 continue + return + end subroutine calcg_endmember2 + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine find_gridmin(kp,nrel,xarr,garr,xknown,jgrid,phfrac,cmu,trace) +! there are kp gridpoints, nrel is number of components +! composition of each gridpoint in xarr, G in garr +! xknown is the known overall composition +! return the gridpoints of the solution in jgrid, the phase fraction in phfrac +! cmu are the final chemical potentials + implicit none + integer, parameter :: jerr=50 + integer kp,nrel + integer, dimension(*) :: jgrid + real xarr(nrel,*),garr(*) + double precision xknown(*),phfrac(*),cmu(nrel) + logical trace +!\end{verbatim} + double precision, parameter :: phfmin=1.0D-8 + real xmat(nrel,nrel),xmatsave(nrel,nrel),xmaxx(nrel) +! used to solve the linear system of equations + double precision qmat(nrel,nrel+1),qmatsave(nrel,nrel+1) + double precision zmat(nrel,nrel+1),cmusave(nrel) + integer notuse(kp),i,ie,iel,ierr,iesave,inerr,inuse,ip,je,jj,jp,jsave,nj + integer nrel1,nyp,griter,nopure(nrel),gpfail + double precision phfsave(nrel) + integer, dimension(jerr) :: removed + real gmin(nrel),dg,dgmin,gplan,gy,gvvp +! gridpoints that has less difference with the plane than this limit is ignored + real, parameter :: dgminlim=1.0D-6 + logical checkremoved +! if trace then open file to write grid + if(trace) then + write(*,*)'Writing grid solution on file ocgrid.dat' + open(31,file='ocgrid.dat ',access='sequential') + write(31,700)nrel,kp,(xknown(inuse),inuse=1,nrel) +700 format('Output from OC gridmin'/' Elements: ',i2,', gridpoints: 'i5,& + ', composition: '/6(F7.4)) + write(31,*)' Gridpoints: ' + do inuse=1,kp + write(31,710)inuse,(xarr(inerr,inuse),inerr=1,nrel),garr(inuse) +710 format(i6,6(1pe12.4)) + enddo + endif +! initiallize local arrays + inuse=kp + inerr=0 + removed=0 + notuse=0 + cmu=zero + xmat=zero + qmat=zero + do je=1,nrel + xmat(je,je)=9.9D-1 + jgrid(je)=0 + enddo + nrel1=nrel+1 + checkremoved=.false. +! write(*,11)'fm8: ',(xknown(i),i=1,nrel) +!11 format(a,7(F8.4)) +! Find the lowest Gibbs energy as close as possible to each pure element +! or with max content + nopure=0 + do ip=1,kp +! write(*,118)'3Y pure: ',ip,(xarr(je,ip),je=1,nrel) +118 format(a,i5,10F6.3) + do je=1,nrel + if(xarr(je,ip).ge.xmat(je,je)) then + if(jgrid(je).gt.0) then + if(garr(ip).gt.gmin(je)) goto 120 +! if(gmin(je).lt.garr(ip) .and. & +! xarr(je,ip).eq.xmat(je,je)) then +! goto 120 +! endif + endif + xmat(je,je)=xarr(je,ip) + jgrid(je)=ip + gmin(je)=garr(ip) +! write(*,*)'pure: ',je,ip,gmin(je) +! elseif(jgrid(je).eq.0 .and. xarr(je,ip).gt.xmaxx(je)) then +! failed attempt to handle cases with no gridpoint for a pure element +! xmaxx(je)=xarr(je,ip) +! nopure(je)=ip +! gmin=garr(ip) +! write(*,*)'3Y nopure: ',je,ip,xarr(je,ip) + endif +120 continue + enddo + enddo +! check that we have nrel gridpoints + do je=1,nrel + if(jgrid(je).eq.0) then +! no gridpoint assigned to this element!! error (note C in pure fcc has no gp) +! gx%bmperr=4149; goto 1000 + write(*,122)'Warning, no gridpoint for pure element ',je +! nopure(je),xmaxx(je) +122 format(a,2i5,2F7.4) + if(nopure(je).eq.0) then +! write(*,122)'No solubility in any phase for element ',je + gx%bmperr=4149; goto 1000 + elseif(xarr(je,nopure(je)).gt.xknown(je)) then +! accept gripoint with highest content of element je outside known composition + do ie=1,nrel + xmat(ie,je)=xarr(ie,nopure(je)) + enddo + gmin(je)=garr(ip) + phfrac(je)=xknown(je) + else + write(*,122)'Composition outside phase compositions for element',& + je,nopure(je),xmaxx(je),xknown(je) + gx%bmperr=4149; goto 1000 + endif + else + ip=jgrid(je) + do ie=1,nrel + xmat(ie,je)=xarr(ie,ip) + enddo + gmin(je)=garr(ip) + phfrac(je)=xknown(je) + endif + enddo +! output of start matrix +! do ip=1,nrel +! write(*,123)ip,phfrac(ip),(xmat(je,ip),je=1,nrel) +! enddo +123 format('3Y: ',i2,1pe12.4,10(0pf6.3)) +! looking for tbase calculation error +! if(trace) write(*,770)(jgrid(je),je=1,nrel) +!770 format('Initial set of gridpoints: '(/15i5)) + do je=1,nrel + if(one-xmat(je,je).lt.1.0d-12) then + cmu(je)=dble(gmin(je)) + else +! we should have a composition for an almost pure element + gx%bmperr=4150; goto 1000 + endif + enddo +! copy this into qmat (double precision) + do ie=1,nrel + do je=1,nrel + qmat(je,ie)=dble(xmat(je,ie)) + enddo + enddo + qmatsave=qmat +! debug output +! do je=1,nrel +! write(*,177)'fm4: ',jgrid(je),phfrac(je),(xmat(ie,je),ie=1,nrel) +! enddo +177 format(a,i5,1pe11.3,2x,5(1pe11.3)) + gvvp=zero + do ie=1,nrel + gvvp=gvvp+xknown(ie)*cmu(ie) + enddo + if(trace) then + write(31,715)nrel +715 format(/'3Y Initial matrix:',i3) + do je=1,nrel + write(31,720),xknown(je),xknown(je),(xmat(ie,je),ie=1,nrel) + enddo +720 format('3Y& ',2F7.4,1x,8f8.5) + write(31,730)gvvp,(cmu(je),je=1,nrel) +730 format('3Y Gibbs energy: ',1pe14.6/'Chemical potentials: '/6(1pe12.4)) + endif + griter=0 + gpfail=0 +! write(*,175)'ini: ',gvvp,(cmu(ie),ie=1,nrel) +175 format(a,(1e12.4),2x,6(1pe12.4)) +! write(*,*)'gvvp: ',gvvp +! check we have the correct global composition +! call chocx('fgm1 ',nrel,jgrid,phfrac,xmat) +! if(gx%bmperr.ne.0) goto 1000 +! write(*,173)gvvp,(jgrid(i),i=1,nrel) +173 format('fms: ',1pe12.4,10i5) +! read(*,174)ch1 +!174 format(a) +!---------------------------------------------------------- +! All setup for starting the search +! search the gridpoint most below the current hyperplane, cmu are +! the chemical potentials of each pure element for the current lowest plane. +! set notuse nonzero for all points above so they can be skipped next time +! TBASE problem, notuse suspended as a point may fall below later ... ??? +200 continue + griter=griter+1 + dgmin=zero + nyp=0 +! write(*,*)'Gridpoints in use: ',inuse +! ovall=zero +! do i=1,nrel +! ovall=ovall+xknown(i)*cmu(i) +! enddo +! write(*,203)'ff:',inuse,ovall,(cmu(je),je=1,nrel) +203 format(a,i4,1pe12.4,6(1pe11.3)) + pointloop: do jp=1,kp + included: if(notuse(jp).eq.0) then + gplan=zero +! first index in xarr is component, second is gridpoint + do iel=1,nrel + gplan=gplan+xarr(iel,jp)*cmu(iel) + enddo + dg=garr(jp)-gplan +! write(*,209)'fmz: ',dg,garr(jp),gplan +209 format(a,3(1pe12.4)) + if(dg.gt.zero) then +! inuse=inuse-1 +! we cannot be sure that a point that has a positive value will always be +! above the surface of the chemical potentials!!! +! notuse(jp)=1 + else +! if this is the most negative dg we should include it in the solution + if(dg.lt.dgmin) then + dgmin=dg; nyp=jp +! write(*,*)'3Y Lower G: ',griter,nyp,kp,dgmin + endif +! debugging LC_CsI (61) and SC_CsI (94) +! if(jp.eq.61 .or. jp.eq.94) & +! write(*,44)'3Y extra: ',jp,dg,dgmin,garr(jp),gplan +44 format(a,i5,5(1pe12.4)) + endif +! else +! write(*,*)'Excluded: ',griter,jp + endif included + enddo pointloop +! write(*,*)'3Y Finished loop for all gridpoints: ',jp,kp +! TBASE bug------------------------ +! jp=94 +! do iel=1,nrel +! gplan=gplan+xarr(iel,jp)*cmu(iel) +! enddo +! dg=garr(jp)-gplan +! write(*,7677)jp,gplan,garr(jp),dg,(xarr(iel,jp),iel=1,nrel) +!7677 format('Gridpoint: ',i5,3(1pe12.4)/(10f7.4)) +! TBASE bug------------------------end +! if nyp=0 we have found the lowest tangent plane including the composition + if(nyp.eq.0 .or. abs(dgmin).lt.dgminlim) then + if(trace) write(31,*)'Found the solution after iterations: ',griter,dgmin +! write(31,*)'Found the solution after iterations: ',griter,dgmin + goto 900 + else + if(trace) write(*,*)'3Y new gridpoint: ',griter,nyp,dgmin + endif +! inuse=inuse-1 + notuse(nyp)=1 +! write(*,211)'ny:',nyp,dgmin,(xarr(ie,nyp),ie=1,nrel) + if(trace) write(*,212)'3Y Found gridpoint ',nyp,inuse,dgmin,garr(nyp) +!211 format(a,i4,1pe12.4,0pf8.4,6(f8.4)) +212 format(a,2i8,6(1pe11.3)) +!------------------------------------------------------------------------- +! Replace one point with the new nyp keeping the overall composition inside. +! This is done by replacing one row at a time in xmat and solve a linear +! equation for the phase fractions and accept the only solution which has +! positive phasefractions. +! +! check the overall composition +! xov=zero +! do i=1,nrel +! do ie=1,nrel +! xov(ie)=xov(ie)+phfrac(i)*xmat(ie,i) +! enddo +! enddo +! write(*,277)'xov: ',nyp,(xov(i),i=1,nrel) +! write(*,277)'phfrac:',0,(phfrac(i),i=1,nrel) +!277 format(a,i5,10F7.4) +! +!----------------------------------------------------------------------- + qmat=qmatsave + do i=1,nrel + phfsave(i)=phfrac(i) + enddo + ie=0 +! loop to try to replace an old gridpoint by nyp. Try to replace all. +300 continue + ie=ie+1 + if(ie.gt.nrel) then +! tried to change all coumns but no solution, error +! write(*,301)'Failed gp: ',nyp,inerr,dgmin,(xarr(i,nyp),i=1,nrel) +301 format(a,i7,i3,1pe10.2,2x,6(0pF7.4)) + gpfail=gpfail+1 +! listing restored solution ...... +! xtx=zero +! do jjq=1,nrel +! write(*,177)'flp: ',jgrid(jjq),phfrac(jjq),(xmat(ie,jjq),ie=1,nrel) +! do jjz=1,nrel +! xtx(jjz)=xtx(jjz)+phfrac(jjq)*xmat(jjz,jjq) +! enddo +! enddo +! gvv=zero +! do jjq=1,nrel +! gvv=gvv+xtx(jjq)*cmu(jjq) +! enddo +! write(*,175)'cur: ',gvv,(cmu(ie),ie=1,nrel) +! +! >>>> problem with gas phase test case cho1 with x(c)=.2 x(o)=x(H)=.4 +! The gridpoints returned not good, probably due to too many gridpoints ... +! +! if(trace) write(*,*)'Failed when trying to add gridpoint ',nyp + if(checkremoved) goto 950 +! just ignore this gridpoint and continue, it has been added to notuse +! and will be checked again later as "removed" + inerr=inerr+1 + if(inerr.gt.jerr) then + inerr=1 + endif + removed(inerr)=nyp + goto 200 + endif +! replace one column in qmat by new composition + do je=1,nrel + qmat(je,ie)=dble(xarr(je,nyp)) + enddo +! left side are the known composition + do je=1,nrel + qmat(je,nrel1)=xknown(je) + enddo +! solver, note qmat is destroyed inside lingld, nrel is dimension +! qmat matrix with left hand side as additional column i.e. QMAT(1..ND1,ND2) +! phfrac(ND1) is result array, nz number of unknown, ierr nonzero=error +! do ik=1,nrel1 +! write(*,317)'fm6A: ',(qmat(je,ik),je=1,nrel) +! enddo + call lingld(nrel,nrel1,qmat,phfrac,nrel,ierr) + if(ierr.ne.0) then +! error may occur and are not fatal, just try to replace next column +! write(*,*)'non-fatal error from lingld: ',ierr,nyp + qmat=qmatsave + do i=1,nrel + phfrac(i)=phfsave(i) + enddo + goto 300 + endif +! write(*,*)'fm6B: ',ie,ierr +! write(*,317)'fm6C: ',(phfrac(i),i=1,nrel) +317 format(a,6(1pe12.4)) +!----------------------- +! if solution has only positive values accept this, ierr nonzero if singular + do je=1,nrel + if(phfrac(je).le.phfmin .or. phfrac(je).gt.one) then +! maybe problems if known composition have almost zero of some components? +! restore qmat +! write(*,*)'fm6D: ',je + qmat=qmatsave + do i=1,nrel + phfrac(i)=phfsave(i) + enddo + goto 300 + endif + enddo +! if(trace) write(*,*)'Replaced column: ',ie,nyp +! we have found that column ie should be replaced +!-------------------------------------------------- +! update xmat, qmatsave and gmin +! as we may fail to find the solution for the chemical potentials later +! keep a copy that can be restored + iesave=ie + jsave=jgrid(iesave) +! mark that the replaced gridpoint should be checked again .... +! write(*,*)'3Y Putting gridpoint back: ',jgrid(ie) + notuse(jgrid(ie))=0 + jgrid(ie)=nyp + xmatsave=xmat + do je=1,nrel + xmat(je,ie)=xarr(je,nyp) + qmatsave(je,ie)=dble(xarr(je,nyp)) + enddo + gmin(ie)=garr(nyp) +! do ik=1,nrel +! write(*,317)'fm6F: ',(xmat(je,ik),je=1,nrel) +! enddo +! write(*,317)'fm6G: ',(gmin(je),je=1,nrel) +! to solve for the chemical potentials we have ro replace the rows by +! columns, there is a TRANSPOSE command for symmetrical matrices + do ie=1,nrel + do je=1,nrel + zmat(ie,je)=qmatsave(je,ie) + enddo + enddo +! we have changed the solution, calculate new chemical potentials + do je=1,nrel + zmat(je,nrel1)=gmin(je) + enddo +! do ik=1,nrel1 +! write(*,317)'fm8A: ',(zmat(je,ik),je=1,nrel) +! enddo + cmusave=cmu + call lingld(nrel,nrel1,zmat,cmu,nrel,ierr) + if(ierr.ne.0) then +! this should also be handelled by ignoring the new gridpoint but +! here we must restore the xmat, qmatsave and cmu. +! write(*,*)'Failed to calculate chemical potentials',ierr +! if(trace) write(*,*)'Error from LINGLD for chem.pot.: ',ierr,nyp + if(checkremoved) goto 950 + inerr=inerr+1 + if(inerr.gt.jerr) then + inerr=1 + endif + removed(inerr)=nyp + jgrid(iesave)=jsave + cmu=cmusave + xmat=xmatsave + do ie=1,nrel + do je=1,nrel + qmatsave(ie,je)=dble(xmat(ie,je)) + enddo + enddo +! we may have successfully added a removed gridpoint + if(checkremoved) then + goto 950 + endif + goto 200 + endif +! calculate total G +! gvv=zero +! do ie=1,nrel +! do je=1,nrel +! first index is component, second is species +! gvv=gvv+xmat(je,ie)*cmu(je) +! enddo +! enddo +! if(trace) write(*,*)'New total G: ',gvv,gvvp +! check if gvv is lower than previous +! if(gvv.gt.gvvp) then +! write(*,*)' *** Gibbs energy increased, restore!' +! endif +! gvvp=gvv +!---------------------------------------------------------- +! debug output as we have changed one gridpoint +! xtx=zero +! do jjq=1,nrel +! write(*,177)'gpf: ',jgrid(jjq),phfrac(jjq),(xmat(ie,jjq),ie=1,nrel) +! do jjz=1,nrel +! xtx(jjz)=xtx(jjz)+phfrac(jjq)*xmat(jjz,jjq) +! enddo +! enddo +! gvv=zero +! do jjq=1,nrel +! gvv=gvv+xtx(jjq)*cmu(jjq) +! enddo +! write(*,175)'ny4: ',gvv,(cmu(ie),ie=1,nrel) +! write(*,317)'new cmu: ',(cmu(je),je=1,nrel) +! read(*,321)ch1 +!321 format(a) + gy=zero + do ie=1,nrel + gy=gy+xknown(ie)*cmu(ie) + enddo +! write(*,199)griter,gvvp,gy +199 format('3Y Gibbs energy changed: ',i5,2(1pe15.6)) + gvvp=gy +! + if(trace) then + write(31,740)griter,nyp +740 format(/'Iteration ',i6,' found gridpoint: ',i6,', new matrix:') + do je=1,nrel + write(*,720),phfrac(je),xknown(je),(xmat(je,ie),ie=1,nrel) + enddo + write(31,730)gvvp,(cmu(je),je=1,nrel) + endif + if(checkremoved) then + write(*,198)nyp +198 format('Added previously removed gridpoint ',i6) + goto 950 + endif +!---------------------------------------------- +! here we go back to loop through all gridpoints again +! write(*,*)'New search: ',griter + goto 200 +!============================================== +900 continue + if(gpfail.gt.0) then + write(*,906)gpfail +906 format('Failed using ',i7,' gridpoints') + endif +! write(*,*)'Gridmin has found a solution' +! write(*,316)'fm9A: ',(jgrid(i),i=1,nrel) +! do ik=1,nrel +! write(*,317)'fm9B: ',(xmat(je,ik),je=1,nrel) +! enddo +! write(*,317)'fm9C: ',(garr(je),je=1,nrel) +! write(*,317)'fm9D: ',(cmu(je),je=1,nrel) +! write(*,317)'fm9E: ',(phfrac(je),je=1,nrel) +316 format(a,10i5) + nj=0 +! do j=1,jerr +! if(removed(j).gt.0) then +! write(*,*)'Failed testing gridpoint ',removed(j) +! nj=nj+1 +! endif +! enddo +950 continue + nj=0 + checkremoved=.true. +! write(*,*)'Checking removed gridpoints',inerr +! xtx=zero +! do jjq=1,nrel +! write(*,177)'flp: ',jgrid(jjq),phfrac(jjq),(xmat(ie,jjq),ie=1,nrel) +! do jjz=1,nrel +! xtx(jjz)=xtx(jjz)+phfrac(jjq)*xmat(jjz,jjq) +! enddo +! enddo +! gvv=zero +! do jjq=1,nrel +! gvv=gvv+xtx(jjq)*cmu(jjq) +! enddo +! write(*,175)'cur: ',gvv,(cmu(ie),ie=1,nrel) +!---------------- + testloop: do jj=1,inerr + jp=removed(jj) +! write(*,*)'Checking removed gridpoint: ',jj,jp + if(jp.gt.0) then + gplan=zero + do iel=1,nrel + gplan=gplan+xarr(iel,jp)*cmu(iel) + enddo + dg=garr(jp)-gplan + if(dg.lt.zero) then +! if(trace) write(*,985)jp,dg,garr(jp),gplan +! write(*,982)jp,dg,garr(jp),gplan +982 format('Removed gridpoint ',i5,' is below surface ',3(1pe12.4)) +! try to include it .... + ie=0 + removed(jj)=-jp + nyp=jp + goto 300 + else +! write(*,983)jp,dg +983 format('Removed gridpoint ',i5,' above surface ',1pe12.4) + removed(jj)=-jp + endif + endif + enddo testloop + if(inerr.gt.0 .and. nj.eq.0) then +! if(trace) write(*,986)inerr +986 format('None of the ',i3,' removed gridpoints below final surface') + endif + if(trace) write(*,771)(jgrid(je),je=1,nrel) +771 format('Final set of gridpoints: '(/15i5)) +! xtx=0 +! do iii=1,nrel +! write(*,987)jgrid(iii),phfrac(iii),(xarr(i,jgrid(iii)),i=1,nrel) +!987 format('GP: ',i5,F7.4,2x,6F9.6) +! do j=1,nrel +! xtx(j)=xtx(j)+phfrac(iii)*xarr(j,jgrid(iii)) +! enddo +! enddo +! write(*,988)(xtx(i),i=1,nrel) +!988 format('MF: ',6F9.6) +! +! call chocx('fgme ',nrel,jgrid,phfrac,xmat) +1000 continue + return + end subroutine find_gridmin + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine merge_gridpoints(nv,iphl,aphl,nyphl,yphl,trace,nrel,xsol,cmu,ceq) +! +! BEWARE not adopted for parallel processing +! +! if the same phase occurs several times check if they are really separate +! (miscibility gaps) or if they can be murged. Compare them two by two +! nv is the number of phases, iphl(i) is the index of phase i, aphl(i) is the +! amount of phase i, nyphl is the number of site fractions for phase i, +! and yphl is the site fractions packed together +! + implicit none + TYPE(gtp_equilibrium_data), pointer :: ceq + integer nv,nrel + integer, dimension(*) :: iphl,nyphl + double precision, dimension(*) :: aphl,yphl,cmu + logical trace + real xsol(maxel,*) +!\end{verbatim} + integer i,ip,iph,jp,jump,kk,klast,kp,lokres,nm,jj,mj,lokph,j + integer notuse(nv),incy(nv) + double precision ycheck(maxconst),qq(5),xerr(maxel) + double precision summu,sumam + logical igen + real xmix(maxel) + double precision a1,a2,gdf,gval1,gval2,gval3,gmindif +! +! gmindif is the value to accept to merge two gridpoints +! It should be a variable that can be set by the user for finetuning +! write(*,7)'Merge_gridpoints is dissabled for the moment',nv +!7 format(a,i3) +! NOTE, merging gripoints in ideal phases like gas + goto 1100 + if(ocv()) write(*,*)'Entering merge_gridpoints' +!--------------------- + gmindif=ceq%gmindif + notuse=0 + nm=0 + incy(1)=1 + do i=2,nv + incy(i)=incy(i-1)+nyphl(i-1) + enddo + summu=zero + xerr=zero + do jp=1,nv + summu=summu+aphl(jp) + do i=1,nrel + xerr(i)=xerr(i)+aphl(jp)*xsol(i,jp) + enddo + enddo + write(*,73)'in: ',summu,(xerr(i),i=1,nrel) +73 format(a,F5.2,2x,10f7.4) +!---------------------------------------------- +100 continue + igen=.false. + do jp=1,nv-1 + if(notuse(jp).ne.0) goto 400 + do kp=jp+1,nv + if(notuse(kp).ne.0) goto 300 + if(iphl(jp).eq.iphl(kp)) then + iph=iphl(jp) +! write(*,9876)'XP1: ',jp,(xsol(i,jp),i=1,nrel) +! write(*,9876)'XP2: ',kp,(xsol(i,kp),i=1,nrel) +9876 format(a,i4,5(1pe12.4)) +! same phase in two points, see if they are really separate +! the test is simple, just calculate the Gibbs energy at the weighted +! average and if that has lower gibbs energy then merge them +! write(*,130)'c130: ',jp,incy(jp),nyphl(jp),kp,incy(kp),nyphl(kp) +130 format(a,10i5) +! write(*,140)incy(jp),(yphl(incy(jp)+j),j=0,nyphl(jp)-1) +140 format(i4,6(1pe12.4)) + call set_constitution(iph,1,yphl(incy(jp)),qq,ceq) + if(gx%bmperr.ne.0) goto 1000 + call calcg(iph,1,0,lokres,ceq) + if(gx%bmperr.ne.0) goto 1000 + gval1=ceq%phase_varres(lokres)%gval(1,1)/qq(1) +! debug + call calc_phase_mol(iph,xerr,ceq) +! write(*,79)'Y0: ',(yphl(incy(jp)+i-1),i=1,nyphl(jp)) +! write(*,79)'X1: ',(xerr(i),i=1,nrel) +! write(*,79)'X2: ',(xsol(i,jp),i=1,nrel) +79 format(a,12(F6.3)) +! Subtract the solution, the result should be zero ?? +! The mole fractions of the gridpoints in solution is in xsol(1,jgrid(i)) + summu=zero + do jj=1,nrel + summu=summu+xsol(jj,jp)*cmu(jj) + enddo + gval1=gval1-summu +! debug output gridpoint 1 + mj=nyphl(jp)-1 +! write(*,820)'GP1:',gval1,summu,aphl(jp),(yphl(incy(jp)+jj),jj=0,mj) +820 format(a,3(1pe10.2),10(0pF5.2)) + call set_constitution(iph,1,yphl(incy(kp)),qq,ceq) + if(gx%bmperr.ne.0) goto 1000 + call calcg(iph,1,0,lokres,ceq) + if(gx%bmperr.ne.0) goto 1000 + gval2=ceq%phase_varres(lokres)%gval(1,1)/qq(1) +! Subtract the solution +! The mole fractions of the gridpoints in solution is in xsol(1,jgrid(i)) + summu=zero + do jj=1,nrel + summu=summu+xsol(jj,kp)*cmu(jj) + enddo + gval2=gval2-summu +! debug output gridpoint 2 +! write(*,820)'GP2:',gval2,summu,aphl(kp),(yphl(incy(kp)+jj),jj=0,mj) +! select the middle point +! Not very good weight by phase amounts if one has 95% FCC and 5 % MC .... +! take weighted sum of composition in the middle + a1=5.0D-01 + a2=5.0D-01 +! sumam=aphl(jp)+aphl(kp) +! a1=aphl(jp)/sumam +! a2=aphl(kp)/sumam +! SURPRISE: adding together constituent fractions does not reproduce +! the correct molefractions if the constituents are molecules .... + do i=1,nyphl(jp) + ycheck(i)=a1*yphl(incy(jp)+i-1)+a2*yphl(incy(kp)+i-1) + enddo + call set_constitution(iph,1,ycheck,qq,ceq) + if(gx%bmperr.ne.0) goto 1000 + call calcg(iph,1,0,lokres,ceq) + if(gx%bmperr.ne.0) goto 1000 + gval3=ceq%phase_varres(lokres)%gval(1,1)/qq(1) +! Check if this is below the current tangent plane +! The mole fractions of the gridpoints in solution is in xsol(1,jgrid(i)) + summu=zero + do jj=1,nrel + xmix(jj)=a1*xsol(jj,jp)+a2*xsol(jj,kp) + summu=summu+xmix(jj)*cmu(jj) + enddo +! write(*,21)'summu: ',a1,a2,qq(1),gval3,summu,gmindif + gval3=gval3-summu +21 format(a,6(1pe12.4)) + write(*,22)'dg: ',gval3,gval1,gval2,0.5*gval1+0.5*gval2 +22 format(a,6(1pe12.4)) +! debug output mix + write(*,820)'GPY:',gval3,summu,qq(1),(ycheck(jj+1),jj=0,mj) + write(*,820)'GPX:',gval3,summu,qq(1),(xmix(jj),jj=1,nrel) + gdf=gval3-a1*gval1-a2*gval2 +! gdf=gval3 +! merge require that difference is less than gmindif or phase ideal +! allways merge ideal phase as it never has miscibility gaps !!! + lokph=phases(iph) + if(gdf.lt.gmindif .or. & + btest(phlista(lokph)%status1,PHID)) then +! gridpoint in between has lower G, merge + write(*,830)'merged: ',jp,kp,gdf,iphl(jp),& + aphl(jp)+aphl(kp) +830 format('Gridpoints ',a,2i3,1pe15.4,' in phase ',i3,1pe12.4) +! write(*,840)jp,(xsol(jj,jp),jj=1,nrel) +! write(*,840)kp,(xsol(jj,kp),jj=1,nrel) +! write(*,840)jp,(xmix(jj),jj=1,nrel) +840 format('x: ',i5,10(F7.4)) +! If merging use correct phase amounts + a1=aphl(jp)/(aphl(jp)+aphl(kp)) + a2=aphl(kp)/(aphl(jp)+aphl(kp)) +! write(*,160)iph,jp,kp,incy(jp),nyphl(jp),gdf,& +! gval1,gval2,gval3,a1,a2 +160 format('Merging: ',i3,2x,4i5,1pe12.4/5(1pe12.4)) + write(*,162)'p1:',a1,(yphl(incy(jp)+j),j=0,nyphl(jp)-1) +162 format(a,F5.2,2x,(10f7.4)) + write(*,162)'p2:',a2,(yphl(incy(kp)+j),j=0,nyphl(kp)-1) +! The gridpoint jp has new amount, composition and constitution +! SURPRISE: adding together constituent fractions does not reproduce +! the correct molefractions if the constituents are molecules .... + aphl(jp)=aphl(jp)+aphl(kp) + do i=0,nyphl(jp)-1 + yphl(incy(jp)+i)=a1*yphl(incy(jp)+i)+a2*yphl(incy(kp)+i) + enddo + call set_constitution(iph,1,yphl(incy(jp)),qq,ceq) + if(gx%bmperr.ne.0) goto 1000 +! extract correct mole fractions + call calc_phase_mol(iph,xerr,ceq) + write(*,162)'ym:',0.0D0,(yphl(incy(jp)+i),i=0,nyphl(jp)-1) + write(*,162)'xj:',0.0D0,(xsol(jj,jp),jj=1,nrel) + write(*,162)'xk:',0.0D0,(xsol(jj,kp),jj=1,nrel) + write(*,162)'xy:',0.0D0,(xerr(i),i=1,nrel) + do i=1,nrel + xsol(i,jp)=xerr(i) + enddo + igen=.true. + nm=nm+1 + iphl(kp)=-iphl(kp) + notuse(kp)=1 +! check overall composition of solution ... + summu=zero + xerr=zero + do i=1,nrel + if(iphl(i).lt.0) cycle + summu=summu+aphl(i) + write(*,*)'point: ',i,aphl(i) + do jj=1,nrel + xerr(jj)=xerr(jj)+aphl(i)*xsol(jj,i) + enddo + enddo + write(*,73)'nu: ',summu,(xerr(jj),jj=1,nrel) +! the chemical potentials has changed but how? Approximate the change by +! making gmindif more negative for each merge (does not affect ideal phases) + gmindif=2.0D0*gmindif +! after merging always restart loop + goto 100 + else + write(*,830)'not merged: ',jp,kp,gdf,iphl(jp),gmindif + endif + endif +300 continue + enddo +400 continue + enddo +! if two gridpoints merged compare all again + if(igen) goto 100 +!---------------------------------------- +! shift fractions for the removed phases +450 continue +! write(*,*)'at label 450: ',nm + klast=0 + do jp=1,nv + klast=klast+nyphl(jp) + enddo +! +! uncomment listing here if error moving fractions +! write(*,502)nv,(iphl(i),i=1,nv) +! write(*,502)0,(incy(i),i=1,nv) +! write(*,502)klast,(nyphl(i),i=1,nv) +502 format('check1: ',i3,2x,20i4) +! kk=0 +! do j=1,nv +! write(*,510)j,(yphl(i),i=kk+1,kk+nyphl(j)) +! kk=kk+nyphl(j) +! enddo +! + kk=0 + jp=1 + do while(jp.lt.nv) + if(iphl(jp).lt.0) then +! shift all fractions down. klast should be updated each shift but ... + jump=nyphl(jp) +! write(*,503)jp,kk,klast,jump +503 format('check3: ',5i5) +! write(*,555)'nyy1: ',(yphl(ip),ip=kk+1,kk+jump) +555 format(a,6(1pe12.4)) + do ip=kk+1,klast-jump + yphl(ip)=yphl(ip+jump) + enddo +! write(*,555)'nyy2: ',(yphl(ip),ip=kk+1,kk+jump) + do kp=jp,nv-1 + iphl(kp)=iphl(kp+1) + aphl(kp)=aphl(kp+1) + nyphl(kp)=nyphl(kp+1) + enddo + nv=nv-1 + else + kk=kk+nyphl(jp) + jp=jp+1 + endif +500 continue + enddo + if(iphl(nv).lt.0) nv=nv-1 +! +! uncomment here if problems shifting fractions +! write(*,502)nv,(iphl(i),i=1,nv) +! write(*,502)0,(incy(i),i=1,nv) +! write(*,502)klast,(nyphl(i),i=1,nv) +! kk=0 +! do j=1,nv +! write(*,510)j,(yphl(i),i=kk+1,kk+nyphl(j)) +! kk=kk+nyphl(j) +! enddo +! if there are two or more gripoints in the same phase we have a +! miscibility gap and may have to create miscibility gaps. +! +! >>>> unfinished +! +510 format(i3,':',6(1pe12.4)) +1000 continue + if(ocv()) write(*,*)'At return from merge_gridpoints: ',nv + return +!------------------------------------------ +! emergency fix to avoid creating several composition sets in ideal phases +1100 continue + nm=0 + notuse=0 + incy(1)=1 + do i=2,nv + incy(i)=incy(i-1)+nyphl(i-1) + enddo +1110 continue + igen=.FALSE. + do jp=1,nv-1 + do kp=jp+1,nv + if(notuse(kp).ne.0) cycle + if(iphl(jp).eq.iphl(kp)) then + iph=iphl(jp) + lokph=phases(iph) + if(btest(phlista(lokph)%status1,PHID)) then +! add together gridpoints in ideal phases (gas) +! write(*,*)'merging gridpoints in ideal phase' + sumam=aphl(jp)+aphl(kp) + a1=aphl(jp)/sumam + a2=aphl(kp)/sumam + aphl(jp)=aphl(jp)+aphl(kp) +! write(*,1117)'3Y: ',jp,(yphl(incy(jp)+i),i=0,nyphl(jp)-1) +! write(*,1117)'3Y: ',kp,(yphl(incy(kp)+i),i=0,nyphl(kp)-1) + do i=0,nyphl(jp)-1 + yphl(incy(jp)+i)=a1*yphl(incy(jp)+i)+a2*yphl(incy(kp)+i) + enddo +! write(*,1117)'3Y: ',jp,(yphl(incy(jp)+i),i=0,nyphl(jp)-1) +1117 format(a,i3,6(1pe12.4)) + notuse(kp)=1 + igen=.TRUE. + nm=nm+1 + iphl(kp)=-iphl(kp) + endif + endif + enddo + enddo + if(igen) goto 1110 + if(nm.eq.0) goto 1000 + goto 450 +! + end subroutine merge_gridpoints + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine set_metastable_constitutions(ngg,nrel,kphl,ngrid,xarr,garr,& + nr,iphl,cmu,ceq) +! this subroutine goes through all the metastable phases +! after a global minimization and sets the constituion to the most +! favourable one. Later care should be taken that composition set 2 +! and higher are not set identical or equal to the stable +! kp total number of gridpoints +! nrel number of components +! ngg number of gridpoints +! kphl array with first points calculated for phase(i) in garr +! ngrid array with last points calculated for phase(i) in garr +! garr array with Gibbs energy/RT for each gridpoint +! xarr matix with composition in all gridpoints +! nr is the number of stable phases in the solution +! iphl array with the phase numbers of the stable phases (not ordered) +! cmu are the chemical potentials/RT of the solution +! ceq equilibrium record +! called by global_gridmin + implicit none + integer ngg,nrel,nr + integer, dimension(*) :: kphl,ngrid,iphl + double precision, dimension(*) :: cmu + real garr(*),xarr(nrel,*) + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer ig1,ign,ip,iph,ics,jph,lokcs,lokph,mode,ny,ie,ig + double precision yarr(maxconst),qq(5),xxx,dgmin + real dg,gplan + if(ocv()) write(*,*)'Entering set_metastable' +! loop through the gridpoints for all unstable phases and insert the +! stable constitution that is closest to be stable +! write(*,7)'set_meta: ',kp,nrel,nr,(iphl(i),i=1,nr) +!7 format(a,i9,2i4,2x,10i3) +! do i=1,noofph +! write(*,*)'grid: ',i,kphl(i),ngrid(i) +! enddo + phloop: do iph=1,noofph + do jph=1,nr + if(iph.eq.iphl(jph)) goto 500 + enddo + call get_phase_record(iph,lokph) + if(gx%bmperr.ne.0) goto 1000 +! check if all composition sets are suspended + do ics=1,phlista(lokph)%noofcs + call get_phase_compset(iph,ics,lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 +! new -4 hidden, -3 susp, -2 dorm, -1,0,1 entered, 2 fixed + if(test_phase_status(iph,ics,xxx,ceq).ge.PHENTUNST) goto 60 + enddo + cycle +! this phase is not suspended and not stable, find gridpoints +60 continue + ig1=kphl(iph) + ign=ngrid(iph) + if(ocv()) write(*,69)'Searching gridpoints for: ',iph,ics,ig1,ign +69 format(a,2(i3,1x),2x,3(i6,1x)) +! if ig1=0 there are no gridpoints for this phase, it is suspended or dormant + if(ig1.le.0) cycle + dgmin=-1.0d12 + ip=0 +! search for gripoint closeset to stable plane + do ig=ig1,ign + gplan=zero + do ie=1,nrel + gplan=gplan+xarr(ie,ig)*cmu(ie) + enddo + dg=gplan-garr(ig) +! write(*,74)'dgx: ',ig,dg,dgmin,(xarr(i,ig),i=1,nrel) +!74 format(a,i5,2(1pe12.4),2x,6(0pf7.4)) + if(dg.gt.dgmin) then + ip=ig + dgmin=dg +! write(*,77)'lower: ',ig,gplan,garr(ig),dg,dgmin +!77 format(a,i7,4(1pe12.4)) + endif + enddo + if(ocv()) write(*,79)'Least unstable gridpoint: ',iph,ics,ig1,ign,dgmin +79 format(a,4(i6,1x),1pe12.4) +! if(ip.eq.0 .or. dgmin.gt.zero) then +! write(*,*)'This gridpoint stable: ',ip,dgmin +! write(*,*)'data: ',ip,dgmin +! endif +! retrieve constitution for this gridpoint and insert it in phase +! must provide mode and iph. The subroutine returns ny and yarr +! mode is the gridpoint in the phase, subtract ig1-1 + mode=ip-ig1+1 +! + if(ocv()) write(*,78)'calling gengrid: ',iph,ig1,ip,ign,mode,dgmin +78 format(a,5i7,1pe12.4) +! find the constitution of this gridpoint + call generate_grid(mode,iph,ign,nrel,xarr,garr,ny,yarr,ceq) + if(gx%bmperr.ne.0) goto 1000 +! write(*,451)(yarr(i),i=1,ny) +451 format('fractions: ',6(F10.6)) + call set_constitution(iph,1,yarr,qq,ceq) + if(gx%bmperr.ne.0) goto 1000 +! write(*,452)iph,ics,(yarr(i),i=1,ny) +452 format('my: ',2i2,6(1pe10.3)) +! set driving force also ... + call set_driving_force(iph,1,dgmin,ceq) +500 continue + enddo phloop +1000 continue + if(ocv()) write(*,*)'Finished set_metastable' + return + end subroutine set_metastable_constitutions + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatiom} + subroutine gridmin_check(nystph,kp,nrel,xarr,garr,xknown,ngrid,pph,& + cmu,yphl,iphx,ceq) +! This subroutine checks if a calculated solution is correct by +! checking if there are any gridpoints below the surface defined +! by the chemical potentials cmu +! nystph return 0 or 10*(phase number)+compset number for new stable phase +! there are kp gridpoints, nrel is number of components +! composition of each gridpoint in xarr, G in garr +! xknown is the known overall composition +! ngrid is last calculated gridpoint point for a phase jj +! pph is number of phases for which there is a grid +! iphx is phase numbers +! cmu are the final chemical potentials +! yphl is just needed as a dummy +! ceq is current equilibrium record +!\end{verbatiom} + implicit none + integer kp,nrel,jp,ie,mode,pph,nystph + double precision, parameter :: phfmin=1.0D-8 + real xarr(nrel,*),garr(*) + double precision xknown(*) + integer, dimension(*) :: ngrid,iphx + double precision cmu(*),gsurf,gstable,gd,yphl(*),qq(5),rtn,gdmin + TYPE(gtp_equilibrium_data), pointer :: ceq + integer lokph,lokcs,zph,ibias,ics,iph,ny +! setting a value of addph forces that gridpoint to be added, used for test +! integer :: addph=8 +! integer :: addph=100 + integer :: addph=0 + save addph +! + write(*,*)'Entering gridmin_check',addph + gstable=zero + nystph=0 + mode=0 + rtn=globaldata%rgas*ceq%tpval(1) + gdmin=-1.0D5 + do jp=1,kp + gsurf=zero + do ie=1,nrel + gsurf=gsurf+xarr(ie,jp)*cmu(ie) + enddo + gsurf=gsurf/rtn +! If garr(jp) more negative than gsurf (gd>0) this gridpoint is stable +! mixing real and double precision is not a numerical problem here + gd=gsurf-garr(jp) + if(gd.gt.gdmin) gdmin=gd +! write(*,17)'grid comarison: ',gd,garr(jp),gsurf +!17 format(a,3(1pe12.4)) + if(gd.gt.gstable) then +! this gridpoint should be set as stable and recalculate + gstable=gd + mode=jp + endif + enddo +! if mode nonzero there is a gridpoint below the calculated surface +! just for test using the FeOUZr case set mode=25, that should be in liquid +! just for test using the FeOUZr case set mode=7, that should be O2 in gas + mode=addph + addph=0 + if(mode.gt.0) then +! we have to find which phase it is, this strange loop should find that + ibias=0 + do zph=1,pph +! ngrid(zph) is the first gridpoints of phase zph + if(mode.le.ngrid(zph)) then + mode=mode-ibias + goto 115 + else + ibias=ngrid(zph) + endif + enddo +115 continue +! write(*,*)'mode, ibias and phase: ',mode,ibias,iphx(zph) + call generate_grid(mode,iphx(zph),ibias,nrel,xarr,garr,ny,yphl,ceq) + if(gx%bmperr.ne.0) goto 1000 + iph=iphx(zph) + write(*,*)'Gridmin check found new stable phase: ',iph +!------------------- +! new stable phase is iph, constituent fractions in yphl +! check if compset 1 of phase is already stable, if so maybe create compset + lokph=phases(iph) + lokcs=phlista(lokph)%linktocs(1) + ics=1 +200 continue + if(ceq%phase_varres(lokcs)%dgm.lt.zero) then +! this composition set not stable, set it as stable with fractions yphl +! finetunig needed here .... + ceq%phase_varres(lokcs)%dgm=zero +! strange, new calculation failed with small amount but worked with a lot ... +! ceq%phase_varres(lokcs)%amount(1)=one + ceq%phase_varres(lokcs)%amfu=one + write(*,222)iph,ics,ny,(yphl(ie),ie=1,ny) +222 format('added: ',3i3,10(f6.3)) + call set_constitution(iph,ics,yphl,qq,ceq) + else + ics=ics+1 + if(ics.gt.phlista(lokph)%noofcs) then +! create new composition set if allowed + if(btest(globaldata%status,GSNOACS)) then + gx%bmperr=4177; goto 1000 + endif + write(*,*)'Creating new composition set for ',iph + call enter_composition_set(iph,' ','AUTO',ics) + if(gx%bmperr.ne.0) goto 1000 +! link to new compositiin set stored here +! set a negative zero driving force + lokcs=phlista(lokph)%linktocs(ics) + ceq%phase_varres(lokcs)%dgm=-one + else + lokcs=phlista(lokph)%linktocs(ics) + endif +! jump back to label 200 to test if this composition set is free + goto 200 + endif + nystph=10*iph+ics + else +! no new phase found, just to see some values + write(*,*)'DG at least unstable gridpoint: ',gdmin + endif +1000 continue + return + end subroutine gridmin_check + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ +!> 17. Miscellaneous +!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ + +!\begin{verbatim} + integer function phvarlok(lokph) +! return index of the first phase_varres record for phase with location lokph +! needed for external routines as phlista is private + implicit none + integer lokph +!\end{verbatim} + phvarlok=phlista(lokph)%linktocs(1) + return + end function phvarlok + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine palmtree(lokph) +! Initiates a numbering of all interaction trees of an endmember of a phase + implicit none + integer lokph +!\end{verbatim} + integer seq,level + type(gtp_endmember), pointer :: endm + type(gtp_interaction), pointer :: intrec + type stack + type(gtp_interaction), pointer :: p1 + end type stack + type(stack), dimension(5) :: int_stack + logical both + both=.false. + endm=>phlista(lokph)%ordered +70 continue + emloop:do while(associated(endm)) + intrec=>endm%intpointer + seq=0 + level=0 +100 continue + do while(associated(intrec)) + level=level+1 + if(level.gt.5) then + write(*,*)'Interaction more than 5 levels deep!' + gx%bmperr=7777; goto 1000 + endif + int_stack(level)%p1=>intrec + seq=seq+1 + intrec%order=seq + intrec=>intrec%highlink + enddo + if(level.gt.0) then + intrec=>int_stack(level)%p1 + level=level-1 + intrec=>intrec%nextlink + goto 100 + endif + endm=>endm%nextem + enddo emloop + if(.not.both .and. associated(phlista(lokph)%disordered)) then + endm=>phlista(lokph)%disordered + both=.true. + goto 70 + endif +1000 continue + return + end subroutine palmtree + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + logical function allowenter(mode) +! Check if certain commands are allowed +! mode=1 means entering an element or species +! mode=2 means entering a phase +! mode=3 means entering an equilibrium +! returns TRUE if command can be executed + implicit none + integer mode +!\end{verbatim} +! write(*,*)'In allowenter: ',mode + logical yesorno + yesorno=.FALSE. + if(mode.le.0 .or. mode.gt.3) goto 1000 + if(mode.eq.1) then +! enter element of species not allowed after entering first phase + if(noofph.gt.1) goto 1000 + yesorno=.TRUE. + elseif(mode.eq.2) then +! enter phases of a disordred fraction set not allowed +! if there are no elements or after entering a second equilibrium +! write(*,*)'3Y allowenter ',mode,noofel,eqfree,noofph + if(noofel.eq.0) goto 1000 + if(eqfree.gt.2) goto 1000 + yesorno=.TRUE. + elseif(mode.eq.3) then +! there must be at lease one phase before entering a second equilibrium +! Note this is tested also for entering the default equilibrium +! write(*,*)'3Y mode 3: ',eqfree,noofph + if(eqfree.ge.2 .and. noofph.eq.0) goto 1000 + yesorno=.TRUE. + endif +1000 continue + allowenter=yesorno +! write(*,*)'3Y: allowenter:',yesorno,mode + return + end function allowenter + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + logical function proper_symbol_name(name,typ) +! checks that name is a proper name for a symbol +! A proper name must start with a letter A-Z +! for typ=0 it must contain only letters, digits and underscore +! for typ=1 it may contain also +, - maybe ? + implicit none + integer typ + character name*(*) +!\end{verbatim} + character name2*64,ch1*1 + integer jl + logical korrekt +! write(*,*)'3Y entering proper_symbol_name: ',name,typ + korrekt=.FALSE. + if(typ.lt.0 .or. typ.gt.0) then + gx%bmperr=4139; goto 1000 + endif + name2=name + call capson(name2) + if(.not.ucletter(name2(1:1))) then +! the first character of a symbol must always be a letter A-Z +! write(*,*)'Wrong first letter of symbol: ',name2(1:1),':',name2(1:5) + gx%bmperr=4137; goto 1000 + endif + jl=1 +100 continue + jl=jl+1 + ch1=name2(jl:jl) +! always finish when fining a space + if(ch1.eq.' ') then + korrekt=.TRUE. + name(jl:)=' ' + goto 1000 + endif + if(typ.eq.0) then + if(ch1.ge.'0' .and. ch1.le.'9') goto 100 + if(ch1.ge.'A' .and. ch1.le.'Z') goto 100 + if(ch1.eq.'_') goto 100 + gx%bmperr=4138 +! else +! unknown type of symbol +! gx%bmperr=4139 + endif +! +1000 continue +! + proper_symbol_name=korrekt + return + end function proper_symbol_name + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!-\begin{verbatim} + subroutine list_free_lists(lut) +! for debugging the free lists and routines using them + implicit none + integer lut +!-\end{verbatim} + integer lok,last + write(lut,1007)noofel,noofsp,noofph,noofem,noofint,noofprop,& + notpf(),csfree-1,eqfree-1,nsvfun,reffree-1,addrecs +1007 format('Records for elements, species, phases: ',3i5/& + 'end members, interactions, properties: ',3i5/& + 'TP-funs, composition sets, equilibria: ',3i5/& + 'state variable functions, references, additions: ',3i5) +!---------------------------- +! csfree, free list is in firsteq +600 continue + write(lut,610)csfree,highcs +610 format('Phase_varres free list: ',2i5) + if(csfree.lt.highcs) then + lok=csfree +620 continue + last=lok + lok=firsteq%phase_varres(last)%nextfree + write(*,*)'csfree: ',last,lok + if(lok.le.0 .or. lok.gt.highcs) then + write(lut,*)'Error in phase_varres free list',last,lok + goto 1000 + elseif(lok.eq.highcs) then + goto 630 + else + goto 620 + endif + endif +! no more +630 continue +1000 continue + return + end subroutine list_free_lists + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine enter_default_constitution(iph,ics,mmyfr,ceq) +! user specification of default constitution for a composition set + implicit none + TYPE(gtp_equilibrium_data), pointer :: ceq + integer iph,ics + real mmyfr(*) +!\end{verbatim} + integer lokph,lokcs,jl,jk + call get_phase_compset(iph,ics,lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 + jk=size(ceq%phase_varres(lokcs)%yfr) +! write(*,909)lokph,lokcs,phlista(lokph)%tnooffr,ceq%eqno,& +! size(ceq%phase_varres),size(ceq%phase_varres(lokcs)%mmyfr),jk +909 format('3Y 2699: ',10i4) +! write(*,46)'3Y y: ',(ceq%phase_varres(lokcs)%yfr(jl),jl=1,jk) +46 format(a,10(F7.3)) + do jl=1,phlista(lokph)%tnooffr + ceq%phase_varres(lokcs)%mmyfr(jl)=mmyfr(jl) +! write(*,47)'3Y jl: ',jl,mmyfr(jl),& +! firsteq%phase_varres(lokcs)%mmyfr(jl),& +! ceq%phase_varres(lokcs)%mmyfr(jl) + enddo +47 format(a,i2,10F7.3) +! set bit indicating that this composition set has a default constitution +! write(*,*)'3Y enter_default_constitution?? ',lokcs + ceq%phase_varres(lokcs)%status2=& + ibset(ceq%phase_varres(lokcs)%status2,CSDEFCON) +1000 continue + return + end subroutine enter_default_constitution + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine set_phase_amounts(jph,ics,val,ceq) +! set the amount formula units of a phase. Called from user i/f +! iph can be -1 meaning all phases, all composition sets + implicit none + integer jph,ics + double precision val + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer iph,lokph,lokcs + double precision amount + if(jph.lt.0) then + iph=1; ics=1 + else + iph=jph + endif + call get_phase_compset(iph,ics,lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 +100 continue + if(test_phase_status(iph,ics,amount,ceq).gt.3) goto 700 +! ceq%phase_varres(lokcs)%amount(1)=val + ceq%phase_varres(lokcs)%amfu=val +700 continue + if(jph.lt.0) then + ics=ics+1 +710 continue + call get_phase_compset(iph,ics,lokph,lokcs) + if(gx%bmperr.ne.0) then + gx%bmperr=0; + iph=iph+1 + if(iph.gt.noofph) goto 1000 + ics=1; goto 710 + endif + goto 100 + endif +1000 continue + return + end subroutine set_phase_amounts + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine old_set_default_constitution(jph,ics,all,ceq) +! set the current constitution of jph to its default constitution +! jph can be -1 meaning all phases, all composition sets +! if all=-1 then change constitution of all phases, else just those not stable +! do not change the amounts of the phases + implicit none + integer all,jph,ics + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} %+ +! This has been changed so it calls set_constitution !!!! + integer iph,lokph,lokcs,ky,kz,ll,n1,n2,n3,jl + double precision kvot1,kvot2,amount,rest,qq(5) + double precision, dimension(:), allocatable :: yy +! + if(jph.lt.0) then + iph=1; ics=1 + else + iph=jph + endif + call get_phase_compset(iph,ics,lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 +100 continue + if(test_phase_status(iph,ics,amount,ceq).gt.3) goto 700 +! do not change the constitution of stable phases ?? +! if(ceq%phase_varres(lokcs)%amount(1).gt.zero .and. all.ge.0) goto 700 + if(ceq%phase_varres(lokcs)%amfu.gt.zero .and. all.ge.0) goto 700 +! mmyfr defines min or max default values of each constituent +! if negative it is a min value, positive is a max value, zero means no default +! It is also used to select the composition set that should be used +! when a new composition set is needed during a calculation, for example +! if an FCC phase that could be an austenite (low carbon content) or a +! cubic carbo-nitride (high carbon or nitrogen content) + allocate(yy(phlista(lokph)%tnooffr)) + ky=0 + subl: do ll=1,phlista(lokph)%noofsubl + kz=ky + n1=0 + n2=0 + n3=0 + rest=zero + do jl=1,phlista(lokph)%nooffr(ll) + ky=ky+1 + yy(ky)=zero +! ceq%phase_varres(lokcs)%yfr(ky)=zero + if(ceq%phase_varres(lokcs)%mmyfr(ky).lt.zero) then +! if mmyfr(kk) is negative the value is a maximal value (normal -1.0D-3) +! Set fraction 1/10 of this + yy(ky)=0.1D0*abs(ceq%phase_varres(lokcs)%mmyfr(ky)) +! ceq%phase_varres(lokcs)%yfr(ky)=0.1D0*& +! abs(ceq%phase_varres(lokcs)%mmyfr(ky)) + n1=n1+1 + elseif(ceq%phase_varres(lokcs)%mmyfr(ky).gt.zero) then +! if mmyfr(kk) is positive the value is a minimal value (normal 0.5) +! Note that several constituents can have a minimal value and the total +! of these can be larger than unity +! ceq%phase_varres(lokcs)%yfr(ky)=one + yy(ky)=one + n2=n2+1 + else +! ceq%phase_varres(lokcs)%yfr(ky)=one + yy(ky)=one + n3=n3+1 + endif + enddo +! write(*,117)'yt: ',ky-kz,(ceq%phase_varres(lokcs)%yfr(j),j=kz+1,ky) +117 format(a,i2,9(F8.4)) +! for normallizing. The idea is that sum of fractions with min should be 0.9 +! and sum of fractions with max should be summin and constituents with +! no default should be 1-0.9*summax-summin + kvot1=one + if(n1.gt.0) then + kvot1=one/dble(n1) + endif + kvot2=one + rest=one + if(n2.gt.0) then + if(n3.gt.0) then + kvot2=0.9D0/dble(n2) + rest=0.1D0/dble(n3) + else + kvot2=one/dble(n2) + endif + elseif(n3.gt.0) then + rest=one/dble(n3) + endif +! write(*,17)'sums: ',ky-kz,kvot1,kvot2,rest +17 format(a,i3,6(1pe12.4)) +! It is not necessary that the sum of fractions is unity, it will be +! normallized before used in a calculation. + do jl=1,phlista(lokph)%nooffr(ll) + kz=kz+1 + if(ceq%phase_varres(lokcs)%mmyfr(kz).lt.zero) then +! ceq%phase_varres(lokcs)%yfr(kz)=kvot1*& +! ceq%phase_varres(lokcs)%yfr(kz) + yy(kz)=kvot1*yy(kz) + elseif(ceq%phase_varres(lokcs)%mmyfr(kz).gt.zero) then +! ceq%phase_varres(lokcs)%yfr(kz)=kvot2*& +! ceq%phase_varres(lokcs)%yfr(kz) + yy(kz)=kvot2*yy(kz) + else + yy(kz)=rest + endif + enddo + enddo subl +! write(*,117)'mm: ',kz,(ceq%phase_varres(lokcs)%mmyfr(j),j=1,kz) +! write(*,117)'yd: ',kz,yy(j),j=1,kz) + call set_constitution(iph,ics,yy,qq,ceq) + if(gx%bmperr.ne.0) goto 1000 +! jump here if phase skipped +700 continue + if(jph.lt.0) then + ics=ics+1 +710 continue + call get_phase_compset(iph,ics,lokph,lokcs) + if(gx%bmperr.ne.0) then + gx%bmperr=0; + iph=iph+1 + if(iph.gt.noofph) goto 1000 + ics=1; goto 710 + endif + goto 100 + endif +1000 continue + if(allocated(yy)) deallocate(yy) + return + end subroutine old_set_default_constitution + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine set_default_constitution(iph,ics,ceq) +! set the current constitution of iph composition set ics to its +! default constitution (if any). Do not change the amounts of the phases + implicit none + integer iph,ics + TYPE(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer lokph,lokcs,ll,jj,kk,kk0 + type(gtp_phase_varres), pointer :: cset + double precision, allocatable :: yarr(:) + double precision sum, qq(5) +! + call get_phase_compset(iph,ics,lokph,lokcs) + if(gx%bmperr.ne.0) goto 1000 + cset=>ceq%phase_varres(lokcs) +! we must use set_constitution at the end to update various internal variables + allocate(yarr(phlista(lokph)%tnooffr)) + if(allocated(cset%mmyfr)) then +! there is a preset default constitution + kk=0 + subl1: do ll=1,phlista(lokph)%noofsubl + kk0=kk + sum=zero + if(phlista(lokph)%nooffr(ll).gt.1) then + do jj=1,phlista(lokph)%nooffr(ll) +! mmy(kk) is negative for small fractions with a maxium, set to 0.01 + kk=kk+1 + if(cset%mmyfr(kk).lt.0.0E0) then + yarr(kk)=0.01D0 + else + yarr(kk)=one + endif + sum=sum+yarr(kk) + enddo + kk=kk0 +! the sum of fractions should be unity, hm done in set_constitution also ... + do jj=1,phlista(lokph)%nooffr(ll) +! mmy(kk) is negative for small fractions with a maxium, set to 0.01 + kk=kk+1 + yarr(kk)=yarr(kk)/sum + enddo + else +! a single constituent, just increment kk and leave fraction as unity + kk=kk+1 + yarr(kk)=one + endif + enddo subl1 + else +! there is no default constitution, set equal amount of all fractions + kk=0 + subl2: do ll=1,phlista(lokph)%noofsubl + if(phlista(lokph)%nooffr(ll).gt.1) then +! set equal amount of all fractions + sum=one/real(phlista(lokph)%nooffr(ll)) + do jj=1,phlista(lokph)%nooffr(ll) + kk=kk+1 + yarr(kk)=sum + enddo + else +! a single constituent, just increment kk and leave fraction as unity + kk=kk+1 + yarr(kk)=one + endif + enddo subl2 + endif +! write(*,411)yarr +411 format('3Y set_def_const: ',8F7.4,(10f7.4)) +! in this routine the fractions in each sublattice is normallized to be unity + call set_constitution(iph,ics,yarr,qq,ceq) +1000 continue + return + end subroutine set_default_constitution + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine todo_before(mode,ceq) +! this could be called before an equilibrium calculation +! It should remove any phase amounts and clears CSSTABLE +! DUMMY +! + implicit none + TYPE(gtp_equilibrium_data), pointer :: ceq + integer mode +!\end{verbatim} + integer iph,ics,lokph,lokcs +! +! write(*,*)'Todo_before ... not implemented' + goto 1000 +! + phloop: do iph=1,noph() + lokph=phases(iph) +! skip hidden phases + if(btest(phlista(lokph)%status1,PHHID)) cycle +300 csloop: do ics=1,phlista(lokph)%noofcs + lokcs=phlista(lokph)%linktocs(ics) +! ceq%phase_varres(lokcs)%amount(1)=zero + ceq%phase_varres(lokcs)%amfu=zero + ceq%phase_varres(lokcs)%status2=& + ibclr(ceq%phase_varres(lokcs)%status2,CSSTABLE) + enddo csloop + enddo phloop +! +1000 continue + return + end subroutine todo_before + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine todo_after_found_equilibrium(mode,ceq) +! this is called after an equilibrium calculation +! It marks stable phase (set CSSTABLE and remove any CSAUTO) +! remove redundant unstable composition sets created automatically +! (CSAUTO set). It will also shift stable composition sets to loweest +! possible (it will take into account if there are default constituent +! fractions, CSDEFCON set). +! mode determine some of the actions +! +! >>>>>>>>>>> THIS IS DANGEROUS IN PARALLELL PROCESSING +! It should work in step and map as a composition set that once been stable +! will never be removed except if one does global minimization during the +! step and map. Then metallic-FCC and MC-carbides may shift composition sets. +! Such shifts should be avoided by manual entering of comp.sets with +! default constitutions, but comparing a stable constitution with a +! default is not trivial ... +! + implicit none + TYPE(gtp_equilibrium_data), pointer :: ceq + integer mode +!\end{verbatim} + integer iph,ics,lokph,lokics,jcs,lokjcs,lastset,lokkcs,kzz,jtup,qq + integer jstat2,fit,phs + double precision val,xj1,xj2 + logical notok,noremove + character jpre*4,jsuf*4 +! + if(btest(globaldata%status,GSNOAFTEREQ)) goto 1000 +! write(*,*)'3Y in todo_after' +! First shift all stable composition down to lower comp.sets + phloop1: do iph=1,noph() + lokph=phases(iph) + if(btest(phlista(lokph)%status1,PHHID)) cycle + csloop1: do ics=2,phlista(lokph)%noofcs + lokics=phlista(lokph)%linktocs(ics) + if(ceq%phase_varres(lokics)%phstate.eq.PHENTSTAB .and. & + btest(ceq%phase_varres(lokics)%status2,CSAUTO)) then + fit=100 +! This comp.set is stable, check if a lower compset is unstable + csloop2: do jcs=1,ics-1 + lokjcs=phlista(lokph)%linktocs(jcs) +! hidden=-4, suspended=-3, dormant=-1, unstable=-1, unknown=0, stable=1, fix=2 + if(ceq%phase_varres(lokjcs)%phstate.le.PHENTERED) then + if(btest(ceq%phase_varres(lokjcs)%status2,CSDEFCON)) then +! check if composition of lokics fits defaults in lokjcs + if(.not.checkdefcon(lokics,lokjcs,fit,ceq)) cycle csloop2 + endif +! write(*,*)'3Y Moving comp.set ',ics,' down to ',jcs + goto 500 + elseif(jcs.eq.ics-1) then + if(fit.gt.2) then +! No lower unstable comp.set, or no one which almost fit default const, +! lokics must remain stable, remove CSAUTO bit +! Do not remove the suffix _AUTO +! write(*,*)'3Y Keeping AUTO comp.set ',ics,lokics + ceq%phase_varres(lokics)%status2=& + ibclr(ceq%phase_varres(lokics)%status2,CSAUTO) + exit csloop2 + endif + else + cycle csloop2 + endif +! Accept a default consitution which almost fits the default +! write(*,*)'3Y Imperfect fit to default: ',fit,lokics,lokjcs +500 continue +! move STABLE lokics to UNSTABLE lokjcs +! write(*,381)'3Y Before copy',& +! lokics,ceq%phase_varres(lokics)%status2,& +! ceq%phase_varres(lokics)%phtupx,& +! ceq%phase_varres(lokics)%suffix,& +! lokjcs,ceq%phase_varres(lokjcs)%status2,& +! ceq%phase_varres(lokjcs)%phtupx,& +! ceq%phase_varres(lokjcs)%suffix +381 format(a,3i4,' "',a,'" ' ,3i4,' "',a,'"') +! list the records to switch, note default constitution?? +! write(*,380)'3Y Stable and free: ',ics,lokics,jcs,lokjcs,& +! ceq%phase_varres(lokics)%phtupx,& +! ceq%phase_varres(lokjcs)%phtupx +380 format(a,10i5) +! exit csloop2 +! save some jcs values of amount, dgm, status, pre&suffix and tuple index + xj1=ceq%phase_varres(lokjcs)%amfu + xj2=ceq%phase_varres(lokjcs)%dgm + jtup=ceq%phase_varres(lokjcs)%phtupx + jstat2=ceq%phase_varres(lokjcs)%status2 + jpre=ceq%phase_varres(lokjcs)%prefix + jsuf=ceq%phase_varres(lokjcs)%suffix + phs=ceq%phase_varres(lokjcs)%phstate +! copy main content of the phase_varres(lokics) record to phase_varres(lokjcs) + ceq%phase_varres(lokjcs)=ceq%phase_varres(lokics) +! Some content in jcs must be set or restorted separately + ceq%phase_varres(lokjcs)%phtupx=jtup + ceq%phase_varres(lokjcs)%status2=jstat2 + ceq%phase_varres(lokjcs)%prefix=jpre + ceq%phase_varres(lokjcs)%suffix=jsuf + ceq%phase_varres(lokjcs)%phstate=PHENTSTAB + ceq%phase_varres(lokjcs)%status2=& + ibset(ceq%phase_varres(lokjcs)%status2,CSSTABLE) +! maybe CSAUTO bit set, always remove it! +! write(*,*)'3Y Ensure CSAUTO cleared in ',jcs + ceq%phase_varres(lokjcs)%status2=& + ibclr(ceq%phase_varres(lokjcs)%status2,CSAUTO) +! Some content in ics must be set separately from saved values of jcs + ceq%phase_varres(lokics)%amfu=xj1 + ceq%phase_varres(lokics)%dgm=xj2 + ceq%phase_varres(lokics)%phstate=phs +! clear the stable bit + ceq%phase_varres(lokics)%status2=& + ibclr(ceq%phase_varres(lokics)%status2,CSSTABLE) +! check things again +! write(*,381)'3Y After copy ',& +! lokics,ceq%phase_varres(lokics)%status2,& +! ceq%phase_varres(lokics)%phtupx,& +! ceq%phase_varres(lokics)%suffix,& +! lokjcs,ceq%phase_varres(lokjcs)%status2,& +! ceq%phase_varres(lokjcs)%phtupx,& +! ceq%phase_varres(lokjcs)%suffix +! write(*,380)'After copy',(phlista(lokph)%linktocs(qq),& +! qq=1,phlista(lokph)%noofcs) + exit csloop2 + enddo csloop2 + endif + enddo csloop1 + enddo phloop1 +! Here we may try to ensure that the stable comp.sets fits the +! default constitutions of their current set +! write(*,*)'3Y Try to shift to match default and current constitution' + call shiftcompsets(ceq) +! +! upto now is safe ... now remove CSAUTO comp.sets if allowed +! write(*,*)'3Y Now maybe remove redundant compsets.' +! goto 1000 +! check if allowed to remove + if(btest(globaldata%status,GSNOREMCS)) goto 1000 +! +! Now try to remove unstable composition sets with CSAUTO set + phloop: do iph=1,noph() + noremove=.FALSE. + lokph=phases(iph) + if(btest(phlista(lokph)%status1,PHHID)) cycle +! loop backwards for compsets to remove unstable with CSAUTO set + lastset=phlista(lokph)%noofcs + csloopdown: do ics=lastset,2,-1 + lokics=phlista(lokph)%linktocs(ics) +! write(*,*)'Checking comp.set ',ics + auto: if(btest(ceq%phase_varres(lokics)%status2,CSAUTO)) then + if(ceq%phase_varres(lokics)%phstate.le.PHENTERED) then +! comp.set was created automatically but is not stable, it can be removed + if(noeq().eq.1) then +! we have just one equilibrium, OK to remove +! write(*,*)'3Y Trying to remove phase tuple ',& +! ceq%phase_varres(lokics)%phtupx + call remove_composition_set(iph,.FALSE.) + if(gx%bmperr.ne.0) goto 1000 + else +! if we cannot remove the comp.set remove the CSAUTO bit + ceq%phase_varres(lokics)%status2=& + ibclr(ceq%phase_varres(lokics)%status2,CSAUTO) + endif + else +! the comp.set is stable, remove the CSAUTO bit +! write(*,*)'Removing CSAUTO bit',ics + ceq%phase_varres(lokics)%status2=& + ibclr(ceq%phase_varres(lokics)%status2,CSAUTO) + endif +! else +! anything to be done with any other phase? + endif auto + enddo csloopdown + enddo phloop +! +1000 continue + return + end subroutine todo_after_found_equilibrium + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + logical function checkdefcon(lokics,lokjcs,fit,ceq) +! check if composition of lokics fits default constitution in lokjcs +! return TRUE if lokics moved to lokjcs +! If not moved fit returns a value how close the constitition is +! If 1 very close, 2 less etc. + integer lokics,lokjcs,fit + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} %+ + integer kk + logical tobeshifted + tobeshifted=.FALSE. +! A fraction with a maximum set (mmyfr<0) must be below that value +! A fraction with a minimum set (mmyfr>0) should be above that value +! write(*,*)'3Y testing defaults',lokics,lokjcs + fit=0 + do kk=1,size(ceq%phase_varres(lokjcs)%yfr) + if(ceq%phase_varres(lokjcs)%mmyfr(kk).lt.0.0D0) then +! A fraction with a maximum set (mmyfr>0) must be below mmyfr(kk) + if(ceq%phase_varres(lokics)%yfr(kk).gt.& + abs(ceq%phase_varres(lokjcs)%mmyfr(kk))) fit=fit+5 +! A fraction with a minimum set (mmyfr<0) should be above mmyfr(kk) + elseif(ceq%phase_varres(lokjcs)%mmyfr(kk).gt.0.0D0) then + if(ceq%phase_varres(lokics)%yfr(kk).lt.& + abs(ceq%phase_varres(lokjcs)%mmyfr(kk))) fit=fit+1 + endif +! if mmyfr(kk)=0 there is no min/max for that fraction +! write(*,77)'3Y Constitution: ',kk,ceq%phase_varres(lokjcs)%mmyfr(kk),& +! ceq%phase_varres(lokics)%yfr(kk),fit +77 format(a,i3,2(1pe12.4),i5) + enddo + if(fit.eq.0) tobeshifted=.TRUE. +! write(*,*)'3Y checkdefcon: ',lokics,lokjcs,fit +1000 continue + checkdefcon=tobeshifted + return + end function checkdefcon + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} %- + subroutine shiftcompsets(ceq) +! check phase with several composition sets if they should be shifted +! to fit the default constitution better + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} %+ + integer lokph,iph,ics,lokics,jcs,lokjcs,fit1,fit2,shifts + character ch1*1 + phloop: do iph=1,noofph + lokph=phases(iph) + if(phlista(lokph)%noofcs.gt.1) then + shifts=0 +100 continue + shifts=shifts+1 + if(shifts.gt.2) cycle phloop + csloop1: do ics=1,phlista(lokph)%noofcs + lokics=phlista(lokph)%linktocs(ics) + if(ceq%phase_varres(lokics)%phstate.eq.PHENTSTAB) then + if(btest(ceq%phase_varres(lokics)%status2,CSDEFCON)) then +! if TRUE then the composition fits default constitution + if(checkdefcon(lokics,lokics,fit1,ceq)) cycle csloop1 + else + fit1=-100 + endif + else + fit1=500 + endif +! The values of fit1: +! -100 there is no default constitution of ics +! >0 the degree of fit of the current constitution of ics +! 500 ics is not stable +! We come here to check if some other compset fits better +! write(*,*)'3Y ics fit in ics: ',ics,fit1 + csloop2: do jcs=1,phlista(lokph)%noofcs + if(jcs.eq.ics) cycle csloop2 + lokjcs=phlista(lokph)%linktocs(jcs) + if(ceq%phase_varres(lokjcs)%phstate.eq.PHENTSTAB) then + if(btest(ceq%phase_varres(lokjcs)%status2,CSDEFCON)) then +! if this call returns TRUE then the jcs composition fits default constitution + if(checkdefcon(lokjcs,lokjcs,fit2,ceq)) then + cycle csloop2 + endif + else +! there is no default constitution in jcs + fit2=-100 +! write(*,*)'3Y no default const: ',jcs,fit2 + endif + else +! jcs is not stable + fit2=500 + endif +! fit2: +! -100 jcs has no default constitution +! >0 the current fit to default constitution +! 500 jcs is not stable +! write(*,*)'3Y jcs fit in jcs: ',jcs,fit2 + if(fit1.eq.500) then +! If neither ics nor jcs are stable increment jcs + if(fit2.eq.500) cycle csloop2 +! ics is unstable, but if it has a default constitution, check if jcs fits + if(btest(ceq%phase_varres(lokics)%status2,CSDEFCON)) then + if(checkdefcon(lokjcs,lokics,fit2,ceq)) continue + fit2=-fit2 + else + fit2=fit1+1 + endif + else +! ics is stable, check if jcs has a default constitution that fits better + if(btest(ceq%phase_varres(lokjcs)%status2,CSDEFCON)) then + if(checkdefcon(lokics,lokjcs,fit2,ceq)) continue + else + fit2=fit1+1 + endif + endif +! fit2: +! <=fit1 shift jcs and ics +! >fit1 do nothing +! write(*,*)'3Y jcs fit in ics: ',jcs,fit2 + if(fit2.le.fit1) then +! The comp.set ics fits the default constitution of jcs better than its current +! write(*,*)'3Y shifting compsets: ',ics,jcs,fit1,fit2 + call copycompsets2(lokph,ics,jcs,ceq) +! shift composition sets! Copy all via a dummy record (last phase_varres) +! That is hopefully unused ... +! ceq%phase_varres(2*maxph)=ceq%phase_varres(lokics) +! ceq%phase_varres(lokics)=ceq%phase_varres(lokjcs) +! ceq%phase_varres(lokjcs)=ceq%phase_varres(2*maxph) +! restore phtupx, pre/suffix and status word for jcs +! ceq%phase_varres(lokjcs)%phtupx=& +! ceq%phase_varres(lokics)%phtupx +! ceq%phase_varres(lokjcs)%status2=& +! ceq%phase_varres(lokics)%status2 +! ceq%phase_varres(lokjcs)%prefix=& +! ceq%phase_varres(lokics)%prefix +! ceq%phase_varres(lokjcs)%suffix=& +! ceq%phase_varres(lokics)%suffix +! restore phtupx, pre/suffix and status word for ics +! ceq%phase_varres(lokics)%phtupx=& +! ceq%phase_varres(2*maxph)%phtupx +! ceq%phase_varres(lokjcs)%status2=& +! ceq%phase_varres(2*maxph)%status2 +! ceq%phase_varres(lokics)%prefix=& +! ceq%phase_varres(2*maxph)%prefix +! ceq%phase_varres(lokics)%suffix=& +! ceq%phase_varres(2*maxph)%suffix +! restore the "end" link in last record +! ceq%phase_varres(2*maxph)%nextfree=-1 +! update fit1, fit2 will be updated automatically +! if(ceq%phase_varres(lokics)%phstate.eq.PHENTSTAB) then +! if(btest(ceq%phase_varres(lokics)%status2,CSDEFCON)) then +! if(checkdefcon(lokics,lokics,fit1,ceq)) continue +! else +! fit1=-100 +! endif +! fit1=500 +! write(*,*)'3Y Switched compsets: ',ics,jcs,fit1,fit2 +! read(*,99)ch1 +!99 format(a) +! start again from first comp.set + goto 100 + endif + enddo csloop2 + enddo csloop1 + endif + enddo phloop +1000 continue + return + end subroutine shiftcompsets + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} %- + subroutine copycompsets(iph,ics1,ics2,ceq) +! copy constitution and results from ic2 to ic1 and vice versa + integer iph,ics1,ics2 + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} %+ + integer lokph,lokcs1,lokcs2 +! check indices are correct + call get_phase_compset(iph,ics1,lokph,lokcs1) + call get_phase_compset(iph,ics2,lokph,lokcs2) + if(gx%bmperr.ne.0) goto 1000 + call copycompsets2(lokph,ics1,ics2,ceq) +1000 continue + return + end subroutine copycompsets + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} %- + subroutine copycompsets2(lokph,ics1,ics2,ceq) +! copy constitution and results from ic2 to ic1 and vice versa + integer lokph,ics1,ics2 + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} %+ + integer iph,lokcs1,lokcs2,ncon,idum,ncc + double precision, dimension(:), allocatable :: val + double precision, dimension(:,:), allocatable :: gval,d2gval + double precision, dimension(:,:,:), allocatable :: dgval + double precision qq(5),xdum +! + lokcs1=phlista(lokph)%linktocs(ics1) + lokcs2=phlista(lokph)%linktocs(ics2) +! save current constitution of lokcs1 in val + ncon=size(ceq%phase_varres(lokcs1)%yfr) + allocate(val(ncon)) + val=ceq%phase_varres(lokcs1)%yfr +! set the constitution in lokcs1 equal to that in lokcs2. This call +! also updates a number of other variables in the record + iph=phlista(lokph)%alphaindex + call set_constitution(iph,ics1,ceq%phase_varres(lokcs2)%yfr,qq,ceq) + if(gx%bmperr.ne.0) goto 1000 + call set_constitution(iph,ics2,val,qq,ceq) + if(gx%bmperr.ne.0) goto 1000 +! copy some variables: phstate, amfu and dgm + idum=ceq%phase_varres(lokcs1)%phstate + ceq%phase_varres(lokcs1)%phstate=ceq%phase_varres(lokcs2)%phstate + ceq%phase_varres(lokcs2)%phstate=idum + xdum=ceq%phase_varres(lokcs1)%amfu + ceq%phase_varres(lokcs1)%amfu=ceq%phase_varres(lokcs2)%amfu + ceq%phase_varres(lokcs2)%amfu=xdum + xdum=ceq%phase_varres(lokcs1)%dgm + ceq%phase_varres(lokcs1)%dgm=ceq%phase_varres(lokcs2)%dgm + ceq%phase_varres(lokcs2)%dgm=xdum +! listprop will be the same +! Now copy result arrays + ncon=ceq%phase_varres(lokcs1)%nprop + allocate(gval(6,ncon)) + gval=ceq%phase_varres(lokcs1)%gval + ceq%phase_varres(lokcs1)%gval=ceq%phase_varres(lokcs2)%gval + ceq%phase_varres(lokcs2)%gval=gval +! ceq%phase_varres(lokph1)%ncc is not the dimension of dgval, why?? + ncc=size(ceq%phase_varres(lokcs1)%yfr) + allocate(dgval(3,ncc,ncon)) +! write(*,77)'3Y copycomp: ',ncc,ncon,& +! size(dgval),size(ceq%phase_varres(lokcs1)%dgval),& +! ceq%phase_varres(lokcs2)%ncc, +!77 format(a,10i5) + dgval=ceq%phase_varres(lokcs1)%dgval + ceq%phase_varres(lokcs1)%dgval=ceq%phase_varres(lokcs2)%dgval + ceq%phase_varres(lokcs2)%dgval=dgval + allocate(d2gval(ncc*(ncc+1)/2,ncon)) + d2gval=ceq%phase_varres(lokcs1)%d2gval + ceq%phase_varres(lokcs1)%d2gval=ceq%phase_varres(lokcs2)%d2gval + ceq%phase_varres(lokcs2)%d2gval=d2gval +! curlat, cinvy, cxmol, cdxmol? +1000 continue + return + end subroutine copycompsets2 + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} %- + subroutine shiftcompsets2(lokph,ceq) +! check if the composition sets of phase lokph +! should be shifted to fit the default constitution better + integer lokph + type(gtp_equilibrium_data), pointer :: ceq +!\end{verbatim} + integer kk,lokics,lokjcs,fit +! A fraction with a maximum set (mmyfr>0) must be below that value +! A fraction with a minimum set (mmyfr<0) should be above that value + write(*,*)'Not implemented testing defaults' + fit=0 + do kk=1,size(ceq%phase_varres(lokics)%yfr) + write(*,*)'3Y defconst: ',kk,ceq%phase_varres(lokics)%mmyfr(kk) + if(ceq%phase_varres(lokics)%mmyfr(kk).gt.0.0D0) then +! A fraction with a maximum set (mmyfr>0) must be below that value + if(ceq%phase_varres(lokjcs)%yfr(kk).gt.& + ceq%phase_varres(lokics)%mmyfr(kk)) fit=fit+5 +! A fraction with a minimum set (mmyfr<0) should be above that value + elseif(ceq%phase_varres(lokics)%mmyfr(kk).lt.0.0D0) then + if(ceq%phase_varres(lokjcs)%yfr(kk).lt.& + abs(ceq%phase_varres(lokics)%mmyfr(kk))) fit=fit+1 + endif + enddo +1000 continue + return + end subroutine shiftcompsets2 + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!\begin{verbatim} + subroutine select_composition_set(iph,ics,yarr,ceq) +! if phase iph wants to become stable and there are several composition sets +! this subroutine selects the one with default composition set that fits best. +! For example if an FCC phase that could be an austenite (low carbon content) +! or a cubic carbo-nitride (high carbon or nitrogen content, low vacancy) +! Less easy to handle ordered phases like B2 or L1_2 as ordering can be +! in any sublatittice ... option B and F needed + implicit none + TYPE(gtp_equilibrium_data), pointer :: ceq + double precision, dimension(*) :: yarr + integer iph,ics +!\end{verbatim} + double precision, parameter :: yl=0.1D0,yh=0.5D0 + integer best,lokph,maxnh,ncc,jcs,lokcs,nh,jl + lokph=phases(iph) + best=1 + maxnh=0 + ncc=phlista(lokph)%tnooffr + do jcs=1,phlista(lokph)%noofcs +! loop through all composition sets + lokcs=phlista(lokph)%linktocs(jcs) +! compare yarr with ceq%phase_varres(lokcs)%mmyfr + nh=0 + do jl=1,ncc + if(ceq%phase_varres(lokcs)%mmyfr(jl).lt.zero) then + if(yarr(jl).lt.yl) nh=nh+1 + elseif(ceq%phase_varres(lokcs)%mmyfr(jl).gt.zero) then + if(yarr(jl).gt.yh) nh=nh+1 + endif + enddo + if(nh.gt.maxnh) then + maxnh=nh + best=jcs + endif + enddo +! if only one compset return 1 + ics=best +! +1000 continue + return + end subroutine select_composition_set + +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + +!-\begin{verbatim} + subroutine sort_multidim_array(nrel,ng,xarr) +! sorts values in xarr in decending order for each column (element) +! xarr(1..nrel,jp) is the composition of gridpoint jp +! UNFINISHED + implicit none + integer nrel,ng + real xarr(nrel,*) +!-\end{verbatim} + integer i1,j1,k1,l1,m1,bounds(nrel,10),nb,b1,c1 + real, dimension(:,:), allocatable :: xord + real xx,xsame +! allocate ordered array and zero. All values in xarr>0 + allocate(xord(nrel,ng)) + xord=zero +! sort first column, increment is nrel, very brute force + loop1: do j1=1,ng,nrel + xx=xarr(1,j1) + do k1=1,j1-1 + if(xx.gt.xord(1,k1)) then +! store xarr here but first shift all values in xord after k1 up, loop bacwards + do l1=j1,k1,-1 + do m1=1,nrel + xord(m1,l1+1)=xord(m1,l1) + enddo + enddo + do m1=1,nrel + xord(m1,k1)=xarr(m1,j1) + enddo + cycle loop1 + endif + do m1=1,nrel + xord(m1,j1)=xarr(m1,j1) + enddo + enddo + enddo loop1 +! detect the bounds + xsame=xord(1,1) + bounds(1,1)=1 + j1=1 + do i1=1,ng + if(xord(1,i1).lt.xsame) then + xsame=xord(1,i1) + j1=j1+1 + bounds(j1,1)=j1 + endif + enddo + nb=j1 + write(*,11)'bounds column 1: ',nb,(bounds(k1,1),k1=1,nb) +11 format(a,i3,10i5) +! now the first column sorted and all values are in xord, sort columns 2 etc +! separately for each lower column bounds +! keep the ordering in the lower columns. No need to sort Last column + column: do c1=1,nrel + boundloop: do b1=2,nb + loop2: do i1=bounds(b1-1,c1),bounds(b1,c1) + loop3: do j1=2,ng,nrel + if(xord(i1-1,j1).lt.xsame) then + xsame=xord(i1-1,1) + xx=xord(i1,j1) + do k1=1,ng + if(xx.gt.xord(i1,k1)) then +! store xx here, shift up (all values in xord) + do l1=j1,k1,-1 + do m1=1,nrel + xord(m1,l1+1)=xord(m1,l1) + enddo + enddo + endif + xord(i1,k1)=xx + cycle loop3 + enddo + endif + enddo loop3 + enddo loop2 + enddo boundloop + enddo column +1000 continue + deallocate(xord) + return +! UNFINISHED + end subroutine sort_multidim_array +! +!/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\/!\ + diff --git a/news-oc2.tex b/news-oc2.tex new file mode 100644 index 0000000..5f2f607 --- /dev/null +++ b/news-oc2.tex @@ -0,0 +1,501 @@ +\documentclass[12pt]{article} +\usepackage[latin1]{inputenc} +\usepackage{graphicx,subfigure} +\topmargin -1mm +\oddsidemargin -1mm +\evensidemargin -1mm +\textwidth 165mm +\textheight 220mm +\parskip 2mm +\parindent 3mm +%\pagestyle{empty} + +\begin{document} + +{\bf \Large New features in the Open Calphad software version 2} + +\bigskip + +Bo Sundman, \today + +\section{Background} + +The Open Calphad (OC) initiative started in 2010 when a group of +scientists decided that there was a need of a high quality open source +software to gain acceptance of computational thermodynamics (CT) as a +useful tool in materials science. The use of thermodynamic +calculations in many applications is severely restricted by the cost +as well as the hardware and software requirements imposed by the +proprietary thermodynamic software. Providing a free software would +simplify such implementations and open a much larger market also for +the high quality databases provided by the commercial vendors. + +Another aim was to support the scientific interest in new +thermodynamic models and improved algorithms for multicomponent +thermodynamic calculations and a better software for thermodynamic +assessments as decrsibed in the book by Lukas et al.\cite{07Luk}. At +present such developments can only be done by scientists who are +affiliated to the commercial software companies. + +The current OC software is available on~\cite{ocweb}. For software +collaborations there is also a repository called opencalphad +at~\cite{github}. + +The OC software in its present state is mainly of interest for +researchers, scientists and students with programming skills. In a +few years it may be as stable as the commercial software and can be +used also for teaching computational thermodynamics. + +\section{Structure of the OC software} + +The software is divided into packages. There are well defined +software interfaces between the packages that makes it possible to +extend and change them independently. + +\begin{itemize} +\item The General Thermodynamic Package. (GTP) which has data + structures for storing model parameters, conditions and calculated + results and code to calculate the Gibbs energy and its first and + second derivatives of phase when the $T, P$ and constitution of the + phase is known. + + As this was the first package developed it includes a number of + general untility facilities needed also by the other packages: + +\begin{itemize} +\item The TP function package for storing and calculating functions + that depend on $T$ and $P$, including first and second derivatives. +\item The METLIB utility package mainly for use by the interactive + user interface. Originally written in Fortran 77 and modified to the + new Fortran standard but it includes features that are depreciated + like ENTRY. +\item The command line user interface with a VAX/VMS flavour is part + of the METLIB package. +\item The numlib routines for inverting a matrix and solving a system + of linear equations. Currently very old and stable but rather + inefficient routines are used. +\end{itemize} + +\item The HMS minimizer implementing the algorithm by + Hillert\cite{81Hil} for finding the equilibrium state in a + multicomponent system for many different kinds of external + conditions. It makes use of GTP for calculating the Gibbs energy + and derivatives for each phase. + +\item The step/map/plot (SMP) package for calculating and plotting + diagrams. It uses HMS for calculating equilibria for conditions + varying along the axis and the free software GNUPLOT for plotting on + various devices. + +\item The OC-TQ software interface to integrate OC in general + application software for various simulations. + +\end{itemize} + +\section{Features in version 1} + +The version 1 release of OC in 2013 could calculate multicomponent +equilibra using Hillert's algorithm\cite{81Hil} for models based on +the Compound Energy Formalism (CEF)\cite{01Hil,07Luk}. It included a +possibility to read unencrypted TDB files and a simple command +interface with macro facilities to set conditions, calculate +equilibria and list results. It has a grid minimizer to ensure +finding the global minimum and detect miscibility gaps. There was +also a limited application software interface called OC-TQ. + +\section{New features in version 2} + +The most important new facilities since version 1 are generating +property and phase diagrams. However, these and many of the other +features are still incomplete and fragile and may not work properly in +many cases. Feedback from users (providing the data and a macro file +reproducing the problem) is the best way to obtain a more stable and +error free software. + +A compiler for Fortran 95 like GNU gfortran 4.8 or later is required. + +A new documentation of the code, a user guide and additional examples +as macro files is also be provded. However, as a complete revision of +both data structures and subroutines are planned for version 3 the +docummentation is not fully up to date. + +\begin{enumerate} +\item The STEP procedure for property diagram. Such diagrams are + calculated with a single axis variable and the user can calculate + and plot how various state variables or model properties depend on + the axis variable. A primitive version of the step procedure was + available also in version 1 but in the new version the exact value + of the change of the set of stable phases is calculated. + + There is also a ``step separate'' option for Gibbs energy curves and + similar things when each phase is calculated separately along the + axis. + + There is a problem with the STEP procedure in a binary system using + a composition as axis. The STEP will stop at a phase boundary and + it does not take into accound that nothing changes in a two-phase + region except the amount of the phases. + +\item The MAP procedure for phase diagrams. This calculates lines + where the set of stable phases changes for different values of the + axis variables. At present only two axis are allowed but in a + future release up to 5 axis will be implemented. + + As the mapping has some problems to calculate all lines it is + possible to execute several map commands and append to the previous + results. As an emergency one can remove lines that are wrong by + editing the input file to GNUPLOT. + + Mapping of binary systems is fairly stable although there are + problems at the top of miscibility gaps and crossing congruent + transformations. This can usually be handelled by several start + points. + + Mapping of multicomponent system is possible but in general many + lines are missing. There is an unresilved problem to exit from + certain node points. Invariant equilibria in ternary or higher + order systems is not implemented. + + The present version of mapping will not discover miscibility gaps. + The phase diagram for Cr-Fe looks horrible. Things like that will + be taken care of in a future release. + + During both MAP and STEP all calculated equilibria are saved and it + is possible to plot various properties. All node points are saved + as equilibria which can be inspected individually and it is also + possible to copy equilibria along a line to a current equilibria and + extract values. + + It is not possible to save the results from a STEP or MAP command on + a file. The user should create MACRO files for calculations he + would like to repeat. + +\item GNUPLOT version 4.6 or later is used for generate the graphics. + In the user interface of OC some additional graphics options, like a + title and ranges of the x and y axis, has been added. It is also + possible to edit the output files from OC to take advantage of all + the graphics facilities of GNUPLOT. + +% GNUPLOT does not support triangular diagrams. + +\item The ``dot derivative'' method to calculate derivatives of state + variables has been implemented. This allows calculation of + properties like the heat capacity without resorting to numerical + derivatives. It makes use of the analytical first and second + derivatives of the Gibbs energy for $T, P$ and all constituent + fractions implemented in the model package. + + The implementation is not finished but derivatives of several state + variables with respect to $T$ are available. + +\item The ionic two-sublattice liquid model (I2SL) which can handle + liquids with and without short range ordering is now implemented. + +\item For the OC-TQ interface a new method has been introduced to + identify phases called ``phase tuples''. A phase tuple is a Fortan + 95 structure (TYPE) with two integer values, one for the phase and + the other for the composition set. The user interface of OC also + use phase tuples when listing phases and composition sets. + + When a phase is entered it has one composition set with number 1 and + a phase tuple is created with the same index as the phase and the + composition set index equal to 1. When a new composition set is + entered for a phase, either by the user or by the software itself, + for example the grid minimizer, the phase tuple index for the new + composition set will be higher than any of the phases and have as + values the phase number and a composition set number 2 or higher. + + There is an example calling the OC-TQ interface from C/C++. It is + rather clumsy and a better way to transfer data should be developed. + +\item Minor things +\begin{itemize} +\item The user can select the reference state of the elements for the + thermodynamic properties. This should be done before any MAP or + STEP command. + +\item The partitioning of the Gibbs energy for phases with + order/disorder transformations has been revised and simplified. + +\item The grid minimizer for global equilibria has been improved + handling phases with ions. + +\item An UNFORMATTED output to a file of the data and results from a + single equilibrium calculation is now possible and the file can be + read back with all data and results. It is not yet possible to save + the result from a STEP or MAP calculation on a file. + +\item The user can enter several equilibria for the same system and + have different conditions in each and calculate them separately and + transfer data between them. This facility is used for storing + step/map results and is a preparation for the software to assess + model parameters from experimental data. Each equilibrium is + independent and they be calculated in parallel. + +\item OC has a flexible way to handle properties like mobilities, + elastic constants etc that may depend on the phase, $T, P$ and the + phase constitution. Some properties are predefined but a skilled + programmer can easily add a specific property and a model to use it + in a calculation. The values of such properties can be obtained + interactivly or by application software in the same way as + thermodynamic state variables. + +\item Reading TDB files is now less strict and it is possible to + specify the elements to be selected from the database. With some + editing of the TDB file it is also possible to read data for ordered + phases modelled with the Thermo-Calc partitioned method. + + There is still no output of TDB files from OC. If you enter + parameters interactivly and want to keep a copy of these on a text + file use the ``set log'' command in advance. + +\item Parallelization has been tested for the grid minimizer and for + the calculation of the inverse phase matrices. It has been + indicated in the code where it can be useful to speed up other parts + of the calculations. A simple test of the parallelization of + calulating and inverting of the phase matrices at each iteration + reduced the time for some calculations by 25\%. + + Mapping of phase diagrams can also be done in parallel for all the + lines. For assessments all equilibria representing experimental + data can be calculated in parallel. + +\item Composition sets created automatically by the grid minimizer + should normally be removed if they are not needed after the full + equilibrium has been calculated. + + If the user has created composition sets for phases that may appear + with specific constitutions, like the cubic MC carbide as a + composition set of the FCC phase, the OC software will try to assign + the correct composition to the approriate composition set. + +\item Phases with order/disorder transformations like FCC (L1$_2$ and + L1$_0$) modelled with 4 sublattices can have an ``FCC\_PERMUTATION'' + bit set to simplify entering the parameters. With this bit set the + user needs to enter each unique parameter only once, not all the + permutations. All kinds of interaction parameters can be entered up + to second order. For the BCC ordering permutations are more + complicated and has not yet been implemented. + +\item Phases with LRO ordering (including phases with LRO that never + disorder like $\sigma, \mu$ and Laves) one can have a disordered + fraction set for parameters that depend on the overall composition + of the phase but are independent of the phase constitution. +\end{itemize} + +\end{enumerate} + +\section{Known bugs and problems and features not yet implemented} + +Some things are problemnatic and from the long list of things we wanted +to implement but did not manage this time, these are a few: + +\begin{itemize} +\item Ternary isothermal sections are difficult to calculate and + cannot be plotted (even in a square diagram). + +\item Redefinition of the components to other species than the + elements is still not possible. + +\item Conditions on state variables like $V, H$ etc are not yet + implemented. + +\item Conditions which are expressions are not implemented. + +\item The corrected quasichemical model for liquids is not + implemented. + +\item There is no check on miscibility gaps during a step or map + command. + +\item Saving results from step and map on a file is not possible + except graphically with GNUPLOT. + +\item The mapping is very fragile, lines are frequently missing or + incomplete. + +\item Conditions are not restored after finished step/map. + +\item There is no plot of tie-lines. + +\item The Scheil-Gulliver solidification model is not implemented. + +\end{itemize} + +As OC is open source anyone who is interested to implement a +particular feature is welcome to start working on it. + +\section{Next release} + +Adding the STEP and MAP has shown some problems with the original data +structure. Thus a complete revision of the data structure will be +made for the version 3. + +All kinds of state variables will be available for conditions and also +expressions of state variables. + +The ``dot derivative'' facility will be extended. + +The STEP and MAP will be able to handle multicomponent invariant +equilibria and detect miscibility gaps during mapping. + +Parallelization will be extended to STEP and MAP calculaions. + +\section{Long term goals} + +\begin{itemize} +\item A full Fortran/C++ application software interface including the + use of compatible data structures. + +\item An assessment module for model parameters with a lot of help for + beginners. + +\item A teaching package for computational thermodynamics and phase + diagrams. + +\end{itemize} + +\begin{thebibliography}{77Zzz} +\bibitem[81Hil]{81Hil} M Hillert, Physica, {\bf 103B} (1981) 31 +\bibitem[01Hil]{01Hil} M Hillert, J of Alloys and Comp {\bf 320} (2001) 161 +\bibitem[07Luk]{07Luk} H L Lukas, S G Fries and B Sundman, {\em Computational +Thermodynamics}, Cambridge Univ Press (2007) +\bibitem[http://www.opencalphad.org]{ocweb} http://www.opencalphad.org +\bibitem[http://github.com]{github} opencalphad at http://github.com. +\end{thebibliography} + +\newpage + +\section{Some diagrams generated with OCv2 macro files} + +\begin{figure}[!ht] +\subfigure[\label{fg:s1a}]{ +\includegraphics[width=35mm,angle=-90]{figs2/step1np.ps}} +\subfigure[\label{fg:s1b}]{ +\includegraphics[width=35mm,angle=-90]{figs2/step1wcr.ps}} +\subfigure[\label{fg:s1c}]{ +\includegraphics[width=35mm,angle=-90]{figs2/step1h.ps}} +\subfigure[\label{fg:s1d}]{ +\includegraphics[width=35mm,angle=-90]{figs2/step1cp.ps}} +% +\subfigure[\label{fg:s2a}]{ +\includegraphics[width=35mm,angle=-90]{figs2/step2g.ps}} +% +\subfigure[\label{fg:s3a}]{ +\includegraphics[width=35mm,angle=-90]{figs2/step3y.ps}} +\subfigure[\label{fg:s3b}]{ +\includegraphics[width=35mm,angle=-90]{figs2/step3h.ps}} +\subfigure[\label{fg:s3c}]{ +\includegraphics[width=35mm,angle=-90]{figs2/step3cp.ps}} +% +\subfigure[\label{fg:s4a}]{ +\includegraphics[width=35mm,angle=-90]{figs2/step4g.ps}} +\subfigure[\label{fg:s4b}]{ +\includegraphics[width=35mm,angle=-90]{figs2/step4y.ps}} +% +\subfigure[\label{fg:s5a}]{ +\includegraphics[width=35mm,angle=-90]{figs2/step5y.ps}} +\subfigure[\label{fg:s5b}]{ +\includegraphics[width=35mm,angle=-90]{figs2/step5cp.ps}} +% +% +\caption{In \ref{fg:s1a} to \ref{fg:s1d} diagrams for a high speed + steel generated with macro file step2-agcu. In \ref{fg:s2a} Gibbs + energy curves in Ag-Cu generated with macro file step2-agcu. In + \ref{fg:s3a} to \ref{fg:s3c} the speciation of a gas with H and O as + function of $T$ and its effect on enthalpy and heat capacity + generated with macro file step3-hogas. In \ref{fg:s4a} and + \ref{fg:s4b} the Gibbs energy curves at 400~K in the Fe-Ni system + for the fcc ordering generated with macro file step4-feni. The + variation of ordering in FeNi$_3$ as function of $T$, in + \ref{fg:s5a} the constituent fractions and in \ref{fg:s5b} the heat + capacity. Generated with macro file step5-feni.} +\end{figure} + + +\begin{figure} +\begin{center} +\subfigure[\label{fg:s6a}]{ +\includegraphics[width=35mm,angle=-90]{figs2/step6g.ps}} +% +\subfigure[\label{fg:s7a}]{ +\includegraphics[width=35mm,angle=-90]{figs2/step7npt.ps}} +\subfigure[\label{fg:s7b}]{ +\includegraphics[width=35mm,angle=-90]{figs2/step7npn.ps}} +\subfigure[\label{fg:s7c}]{ +\includegraphics[width=35mm,angle=-90]{figs2/step7pref.ps}} +\subfigure[\label{fg:s7d}]{ +\includegraphics[width=35mm,angle=-90]{figs2/step7preb.ps}} +% +\subfigure[\label{fg:m1a}]{ +\includegraphics[width=35mm,angle=-90]{figs2/map1pd.ps}} +\subfigure[\label{fg:m1b}]{ +\includegraphics[width=35mm,angle=-90]{figs2/map1pdzoom.ps}} +\subfigure[\label{fg:m1c}]{ +\includegraphics[width=35mm,angle=-90]{figs2/map1pdrotate.ps}} +\subfigure[\label{fg:m1d}]{ +\includegraphics[width=35mm,angle=-90]{figs2/map1ac.ps}} +% +\subfigure[\label{fg:m2a}]{ +\includegraphics[width=35mm,angle=-90]{figs2/map2pd.ps}} +\subfigure[\label{fg:m2b}]{ +\includegraphics[width=35mm,angle=-90]{figs2/map2pdzoom.ps}} +\end{center} +% +\caption{In \ref{fg:s6a} the Gibbs energy curves for the different + phases in Fe-Mo at 1400~K, generated with macro file step6-femo. In + \ref{fg:s7a} to \ref{fg:s7d} calculated phase amounts as function of + $T$ or mass fraction of N and ``pitting corrosion equivalents'', + generated with macro file step7-saf. In \ref{fg:m1a} to + \ref{fg:m1d} the phase diagram for the Ag-Cu system generated with + macro file map1-agcu. In \ref{fg:m2a} to \ref{fg:m2b} the phase + diagram for the Cr-Mo system generated with macro file map2-crmo.} +\end{figure} + + +\begin{figure} +\begin{center} +\subfigure[\label{fg:m3a}]{ +\includegraphics[width=35mm,angle=-90]{figs2/map3pd.ps}} +\subfigure[\label{fg:m3b}]{ +\includegraphics[width=35mm,angle=-90]{figs2/map3pdzoom.ps}} +% +\subfigure[\label{fg:m4a}]{ +\includegraphics[width=35mm,angle=-90]{figs2/map4pd.ps}} +\subfigure[\label{fg:m4b}]{ +\includegraphics[width=35mm,angle=-90]{figs2/map4pdzoom.ps}} +% +\subfigure[\label{fg:m5a}]{ +\includegraphics[width=35mm,angle=-90]{figs2/map5pd.ps}} +\subfigure[\label{fg:m5b}]{ +\includegraphics[width=35mm,angle=-90]{figs2/map5pdzoom.ps}} +% +\subfigure[\label{fg:m6a}]{ +\includegraphics[width=35mm,angle=-90]{figs2/map6pd.ps}} +% +\subfigure[\label{fg:m7a}]{ +\includegraphics[width=35mm,angle=-90]{figs2/map7pdx.ps}} +% +\subfigure[\label{fg:m8a}]{ +\includegraphics[width=35mm,angle=-90]{figs2/map8pd.ps}} +% +\end{center} +% +\caption{ In \ref{fg:m3a} to \ref{fg:m3b} the phase diagram for the + C-Fe system generated with macro file map3-cfe. In \ref{fg:m4a} to + \ref{fg:m4b} the phase diagram for the O-U system generated with + macro file map4-ou. In \ref{fg:m5a} to \ref{fg:m5b} the phase + diagram for the Fe-Mo system generated with macro file map5-femo. + In \ref{fg:m6a} the isopleth diagram for the Cr-Fe-Ni system at 8 + mass\%Ni generated with macro file map6-ss. In \ref{fg:m7a} an + isopleth calclation for a high speed steel generated with macro file + map7-hss. As can be seen there are still problems with mapping. In + \ref{fg:m8a} a metastable phase diagram for the ordered fcc phase in + Fe-Ni generated with macro file map8-feni. } +\end{figure} + + +\end{document} + + + diff --git a/ochelp.hlp b/ochelp.hlp new file mode 100644 index 0000000..6704fdc --- /dev/null +++ b/ochelp.hlp @@ -0,0 +1,1353 @@ +\documentclass[12pt]{article} +\usepackage[latin1]{inputenc} +\topmargin -1mm +\oddsidemargin -1mm +\evensidemargin -1mm +\textwidth 155mm +\textheight 220mm +\parskip 2mm +\parindent 3mm +\setcounter{secnumdepth}{5} +%\pagestyle{empty} + +% look for this to continue update +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% current place +% +% This is a file used for a printable PDF version of the user guide +% AND as on-line help, either directly or processed to remove LaTeX specials +% +%--------------------------------------------------- +% +% The first version of this is generated manually but eventially a +% software program should be developed to update this automatically whenever +% the software is changed +% +%--------------------------------------------------- +% +% Some advice: +% +% The commands and subcommands are arranged alphabetically +% +% It will be difficult to update the help text for the +% questions after the commands and subcommands as they are normally +% not part of the command monitor. +% +% The _ used in many commands must be replaced by \_ or just - +% +%--------------------------------------------------- +% +% The on-line help software will react if the user types a ? +% as answer to a question. It will search for the help text starting by +% the main command, any subcommand and finally question texts. +% The quesntion text may be difficult to update as already mentioned. +% Any text found in this file between the start of a question and the next will +% be written on the screen and then the question will be asked again. +% +%--------------------------------------------------- +% +\begin{document} + +\begin{center} + +{\Huge \bf User Guide to the + +Open Calphad software package + +version 2.0 + +} + +VERY PRELIMINARY + +Bo Sundman, \today + +\end{center} + +This is a very preliminary version for version 2 + +\section{Introduction} + +The Open Calphad software project aims to provide a hig quality +software for thermodynamic calculations for inorganic systems i.e. +gases. liquid, alloys with may different crystalline phases. + +It also provides a framwork to store many different composition +dependent properties of materials. + +\section{Some general features} + +The command monitor has a menu of command and each of these usually +has submenus and finally some questions may be asked like phase names, +a value or an expression. At any level the user should be able to +type a ? and get some help, usually an extract from this manual, a +menue or possible answers. + +\subsection{Names and symbols} + +There are many symbols and names used in this package. A symbol or +name MUST start with a letter A-Z. It usually can contain digits and +the underscore character after the intitial letter. Some special +symbols are also used: + +\begin{itemize} +\item /- is used to denote the electron. /+ can be used for a psoitiv charge. +\item \# are used to identify composition sets after a phase name or +sublattice after a constituent name. +\item \& are used in some parameter identifiers to specify the + constituent for the parameter, mobilites. +\end{itemize} + +\subsection{Parameters} + +All data is organized relative to a phase and the phase is identified +by a name. Each phase can have a different model for the composition +dependence but the way to enter model parameters is the same for all +models. However, the meaning of a model parameter may depend on the +model of the phase. + +Many types of data can be stored as explained in the section on +parameter identifiers. The parameter also has a constituent +specification explained in the constituent array section and possibly +a degree, the meaning of which is model dependent. + +The basic syntax of a parameter is + +``identifier'' ( ``phase name'' , ``constituent array'' ; ``degree'' ) ``expression'' ``reference'' + +These parts will now be explained in more detail. + +\subsubsection{Parameter Identifiers} + +The OC thermodynamic pacakage can handle any property that depend on +composition using the composition models implemented. It is easy to +extend the number of properties by declaring property identifiers in +ths source code. The value of such identifiers can be obtained by the +command ``list symbol''. If the parameters should have an influence +on the Gibbs energy (like the Curie temperature) or a diffusion +coefficient (like the mobility) the necessary code to calculate this +must be added also. + +The list here is tentative. Insensitive to case. + +\begin{itemize} +\item G, the Gibbs energy or an interaction parameter. +\item TC, the critical temperature for ferro or antiferro magnetic +ordering using the Inden model. +\item BMAGN, the avarage Bohr magneton number using the Inden model. +\item CTA, the Curie temperature for ferromagnetic ordering using +a modified Inden model. +\item NTA, the Neel temperature for antiferromagnetic ordering using a +modified Inden model. +\item IBM\&C, the individual Bohr magneton number for constituent C +using a modified Inden model. For example IBM\&FE(BCC,FE) is the Bohr +magneton number for BCC Fe. The identifier IBM\&FE(BCC,CR) means the +Bohr magneton number of a single Fe atom in BCC Cr. An identifier +IBM\&FE(BCC,CR,FE) can be used to decribe the composition dependence of +the Bohr magneton number for Fe in BCC. +\item THET, the Debye or Einstein temperature. +\item MOBQ\&C, the logarithm of the mobility of constituent C +\item RHO, the electrical resistivity +\item MAGS, the magnetic suseptibility +\item GTT, the glas transition temperature +\item VISC, the viscosity +\item LPAX, the lattic parameter in X direction +\item LPAY, the lattic parameter in Y direction +\item LPAZ, the lattic parameter in Z direction +\item LPTH, the deviation from cubic structure +\item EC11A, the elastic constrant C11 +\item EC12A, the elastic constrant C12 +\item EC44A, the elastic constrant C44 +\end{itemize} + +\subsection{Constituent array and degrees} + +A constituent array specifies one or more constituent in each +sublattice. A constituent must be entered as a species with fixed +stoichiometry. Between constituents in different sublattices one must +give a colon, ":", between interacting constituents in the same +sublattice one must give a comma, ",". A constituent array with +exactly one constituent in each sublattice is also called an +``endmember'' as it give the value for a ``compound'' with fixed +stoichiometry. Constituent arrays with one or more interaction +describe the composition dependence of the property, without such +parameter the property will vary liearly between the endmembers. + +If there are no sublattices, like in the gas, one just give the phase +and the constituent + +G(gas,C1O2) + +If no degree is specified it is assumed to be zero. For endmembers +the degree must be zero but it may sometimes be useful to specify the +zero in order to distinguish the parameter from the expression for the +chemical potential of a component. In the gas phase one normally +assumes there are no interactions but it is possible to add such +parameters. For an fcc phase with 4 sublattice for ordering and one +for interstitials an endmember parameter is + +G(fcc,AL:NI:NI:NI:VA) + +This would be the Gibbs energy of an Al1NI3 compound. + +An interaction between vacancies and carbon in the austenite is + +G(fcc,Fe:C,VA;0) + +For interaction one should always specify a degree but also in this +case an omitted degree is interpreted as zero. + +% +% "identifier" ( "phase name" , "constituent array" ; "degree" ) "expression" +% ``reference'' +% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% +% Below is an extract of the OC command interface. +% Comparing this with the current software is be way to know +% where to update the user guide. +% +%F ! basic commands +%F character (len=16), dimension(ncbas) :: cbas=& +%F ['AMEND ','CALCULATE ','SET ',& +%F 'ENTER ','EXIT ','LIST ',& +%F 'QUIT ','READ ','SAVE ',& +%F 'HELP ','INFORMATION ','BACK ',& +%F 'NEW ','MACRO ','ABOUT ',& +%F 'DEBUG ','SELECT ','DELETE ',& +%F 'STEP ','MAP ','PLOT ',& +%F 'HPCALC ','FIN ',' '] +%F ! in French +%F ! 'MODIFIEZ ','CALCULEZ ','REGLEZ ',& +%F ! 'ENTREZ ','EXIT ','AFFICHER ',& +%F ! 'QUIT ','LIRE ','SAUVGARDE ',& +%F ! 'AIDEZ ','INFORMATION ','RETURNEZ ',& +%F ! 'NOUVEAU ','MACRO ','ABOUT ',& +%F ! 'DEBUG ','SELECTIONEZ ','EFFACEZ ',& +%F ! 'STEP ','MAP ','DESSINEZ ',& +%F ! 'HPCALC ','FIN ',' '] +%F ! options preceeded by - +%F ! for example "list -out=myfile.dat all_data" or +%F ! "list all_data -out=myfile.dat" +%F character (len=16), dimension(ncopt) :: copt=& +%F ['OUTPUT ','ALL ','FORCE ',& +%F 'VERBOSE ','SILENT ',' '] +%F !------------------- +%F ! subcommands to LIST +%F character (len=16), dimension(nclist) :: clist=& +%F ['DATA ','SHORT ','PHASE ',& +%F 'STATE_VARIABLES ','BIBLIOGRAPHY ','PARAMETER_IDENTI',& +%F 'AXIS ','TPFUN_SYMBOLS ','QUIT ',& +%F ' ','EQUILIBRIA ','RESULTS ',& +%F 'CONDITIONS ','SYMBOLS ','LINE_EQULIBRIA '] <<< +%F!------------------- +%F! subsubcommands to LIST DATA +%F character (len=16), dimension(nlform) :: llform=& +%F ['SCREEN ','TDB ','MACRO ',& +%F 'LATEX ',' ',' '] +%F !------------------- +%F ! subsubcommands to LIST PHASE +%F character (len=16), dimension(nclph) :: clph=& +%F ['DATA ','CONSTITUTION ','MODEL ',& +%F ' ',' ',' '] +%F !------------------- +%F ! subcommands to CALCULATE +%F character (len=16), dimension(ncalc) :: ccalc=& +%F ['TPFUN_SYMBOLS ','PHASE ','NO_GLOBAL ',& +%F 'TRANSITION ','QUIT ','GLOBAL_GRIDMIN ',& << +%F 'SYMBOL ','EQUILIBRIUM ','ALL_EQUILIBRIA '] +%F !------------------- +%F ! subcommands to CALCULATE PHASE +%F character (len=16), dimension(nccph) :: ccph=& +%F ['ONLY_G ','G_AND_DGDY ','ALL_DERIVATIVES '] +%F !------------------- +%F ! subcommands to ENTER +%F character (len=16), dimension(ncent) :: center=& +%F ['TPFUN_SYMBOL ','ELEMENT ','SPECIES ',& +%F 'PHASE ','PARAMETER ','BIBLIOGRAPY ',& +%F 'CONSTITUTION ','EXPERIMENT ','QUIT ',& +%F 'EQUILIBRIUM ','SYMBOL ','OPTIMIZE_COEFF ',& +%F 'COPY_OF_EQUILIB ',' ',' '] +%F !------------------- +%F ! subcommands to READ +%F character (len=16), dimension(ncread) :: cread=& +%F ['UNFORMATTED ','TDB ','QUIT ',& +%F 'DIRECT ',' ',' '] +%F!------------------- +%F! subcommands to SAVE +%F character (len=16), dimension(ncsave) :: csave=& +%F ['UNFORMATTED ','TDB ','MACRO ',& +%F 'DIRECT ','LATEX ','QUIT '] +%F !------------------- +%F ! subcommands to AMEND first level (very few implemented) +%F ! many of these should be subcommands to PHASE +%F character (len=16), dimension(ncam1) :: cam1=& +%F ['SYMBOL ','ELEMENT ','SPECIES ',& +%F 'PHASE ','PARAMETER ','BIBLIOGRAPHY ',& +%F 'TPFUN_SYMBOL ','CONSTITUTION ','QUIT ',& +%F 'COMPONENTS ','GENERAL ','DEBYE_MODEL '] +%F !------------------- +%F ! subsubcommands to AMEND PHASE +%F character (len=16), dimension(ncamph) :: camph=& +%F ['MAGNETIC_CONTRIB','COMPOSITION_SET ','DISORDERED_FRACS',& +%F 'GLAS_TRANSITION ','QUIT ','DEFAULT_CONSTIT ',& +%F 'DEBYE_MODEL ','EINSTEIN_CP_MDL ','INDEN_WEI_MAGMOD',& +%F 'ELASTIC_MODEL_A ',' ',' '] +%F !------------------- +%F ! subcommands to SET. +%F character (len=16), dimension(ncset) :: cset=& +%F ['CONDITION ','STATUS ','ADVANCED ',& +%F 'LEVEL ','INTERACTIVE ','REFERENCE_STATE ',& +%F 'QUIT ','ECHO ','PHASE ',& +%F 'UNITS ','LOG_FILE ','WEIGHT ',& +%F 'NUMERIC_OPTIONS ','AXIS ','INPUT_AMOUNTS ',& +%F 'VERBOSE ','AS_START_EQUILIB',' '] +%F ! subsubcommands to SET STATUS +%F character (len=16), dimension(ncstat) :: cstatus=& +%F ['ELEMENT ','SPECIES ','PHASE ',& +%F 'CONSTITUENT ',' ',' '] +%F ! 123456789.123456---123456789.123456---123456789.123456 +%F ! subsubcommands to SET ADVANCED +%F character (len=16), dimension(ncadv) :: cadv=& +%F ['EQUILIB_TRANSF ','QUIT ',' '] +%F ! 123456789.123456---123456789.123456---123456789.123456 +%F ! subsubcommands to SET PHASE +%F character (len=16), dimension(nsetph) :: csetph=& +%F ['QUIT ','STATUS ','DEFAULT_CONSTITU',& +%F 'AMOUNT ','BITS ',' '] +%F ! 123456789.123456---123456789.123456---123456789.123456 +%F !------------------- +%F ! subsubsubcommands to SET PHASE BITS +%F character (len=16), dimension(nsetphbits) :: csetphbits=& +%F ['FCC_PERMUTATIONS','BCC_PERMUTATIONS','IONIC_LIQUID_MDL',& +%F 'AQUEOUS_MODEL ','QUASICHEMICAL ','FCC_CVM_TETRADRN',& +%F 'FACT_QUASICHEMCL','NO_AUTO_COMP_SET',' ',& +%F ' ',' ',' ',& +%F ' ',' ',' '] +%F ! 123456789.123456---123456789.123456---123456789.123456 +%F!------------------- +%F! subcommands to STEP <<< +%F character (len=16), dimension(nstepop) :: cstepop=& +%F ['NORMAL ','SEPARATE ','QUIT ',& +%F 'CONDITIONAL ',' ',' '] +%F! 123456789.123456---123456789.123456---123456789.123456 +%F !------------------- +%F ! subcommands to DEBUG +%F character (len=16), dimension(ncdebug) :: cdebug=& +%F ['FREE_LISTS ','STOP_ON_ERROR ','ELASTICITY ',& +%F ' ',' ',' '] +%F !------------------- +%F ! subcommands to SELECT, maybe some should be CUSTOMMIZE ?? +%F character (len=16), dimension(nselect) :: cselect=& +%F ['EQUILIBRIUM ','MINIMIZER ','GRAPHICS ',& +%F 'LANGUAGE ',' ',' '] +%F !------------------- +%F ! subcommands to DELETE +%F character (len=16), dimension(nrej) :: crej=& +%F ['ELEMENTS ','SPECIES ','PHASE ',& +%F 'QUIT ','COMPOSITION_SET ','EQUILIBRIUM '] +%F !------------------- +%F ! subcommands to PLOT OPTIONS +%F character (len=16), dimension(nplt) :: cplot=& +%F ['PLOT ','XRANGE ','YRANGE ',& +%F 'XTEXT ','YTEXT ','TITLE '] +%F !------------------- +%F +% +%! end extract of command user interface +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% +% below the commands are arranged in alphabetical order + +\section{All commands} + +The commands in alphabetica order as listed with the ? + +\begin{tabular}{llll} +ABOUT & ENTER & LIST & READ \\ +AMEND & EXIT & MACRO & SAVE \\ +BACK & FIN & MAP & SELECT \\ +CALCULATE & HELP & NEW & SET \\ +DEBUG & HPCALC & PLOT & STEP \\ +DELETE & INFORMATION & QUIT \\ +\end{tabular} + +Many of the commands have ``subcommands'' and usually there is a +default (listed within slashes //) which is selected by pressing +return. One can type commands and subcommands and other parameters on +the same line if one knows the order, using a comma, ``,'' to select +the default. + +There some options that can be set for the whole session or for just a +single command. The options are idenfified by a - in front like +-output=myfile.dat. + +\subsection{Option} + +These should be possible to specify at each command. But +they are not yet implemented. + +\begin{itemize} +\item -OUTPUT {\em file name} +\item -ALL apply for all +\item -FORCE override normal restrictions +\item -VERBOSE write information while executing +\item -SILENT do not write anything except fatal error messages +\end{itemize} +%=================================================================== +\section{About} + +Some information about the software. + +%=================================================================== +\section{Amend} + +Intended to allow changes of already entered data. Only some +of the subcommands are implemented. + +%-------------------------------- +\subsection{Element} + +Not implemented yet. + +%-------------------------------- +\subsection{Debye\_Model} + +Not implemented yet. + +%-------------------------------- +\subsection{Components} + +By default the elements are the components. Ths command can set any +orthogonal set of species as components. The number of components +cannot be changed. + +Not implemented yet. + +%-------------------------------- +\subsection{Constitution} + +The user can set a constitution of a phase before a calculation. This +will be used as initial constitution for a calculation. + +%-------------------------------- +\subsection{General} + +A number of user specific settings for defaults can be made: + +\begin{itemize} +\item The name of the system. + +\item The level of the user (beginner, frequent user, expert). This +may affect the behaviour of the program. + +\item If global minimization is allowed or not. + +\item If gridpoints should be merged after global minimization. By +default not. + +\item Automatic creation or deletion of composition sets not allowed. +\end{itemize} + +%-------------------------------- +\subsection{Parameter} + +The possible parameters are defined by the model of the phase. By +specifying a parameter the user can change its expression. See the +ENTER PARAMETER command. Not implemented yet. + +%-------------------------------- +\subsection{Phase} + +Some of the properties of the phase can be amended by this command. + +%......................... +\subsubsection{Magnetic\_Contrib} + +A model for the magnetic contribution to the Gibbs energy can be set +by this command. + +%......................... +\subsubsection{Composition\_Set} + +More composition sets of a phase can be created or deleted. Phases +with miscibility gaps or which can exist with different chemical +ordering like A2 and B2 must be treated as different composition sets. +The user can specify a prefix and suffix for the composition set. The +composition set will always habe a suffix \#digit where digiit is a +number between 1 and 9. One cannot have more than 9 composition sets. + +Composition sets can also be created automatically by the software. In +such a case the composition set will have the suffix \_AUTO, + +In some cases it may be interesting to calculate metastable states inside +miscibility gaps and one can prevent automatic creation of composition +sets by {\rm AMEND GENERAL} or for an individual phase by {\em SET +PHASE BIT {\em phase} NO\_AUTO\_COMP\_SET} + +%......................... +\subsubsection{Default\_Constit} + +The default constitution of a phase can be set. This will be used +when the first calculation with the phase is made and sometimes if +there are convergence probems. Depending on the minimizing software +used the initial consititution can be important to find the correct +quilibrium if the phase has ordering or a miscibility gap. + +%......................... +\subsubsection{Disordered\_Fracs} + +For phases with several sublattices the Gibbs energy of the phase can +be divided into two sets of fractions where the second or +``disordered'' set have only one or two sublattice and the fractions +on these represent the sum of fraction on some or all of the first or +``ordered'' set of sublattices. This is particularly important for +phases with ordering like FCC, BCC and HCP and for intermediate phases +like SIGMA, MU etc. + +%......................... +\subsubsection{Glas\_Transition} + +Not implemented yet. + +%......................... +\subsubsection{Quit} + +Do not amend anything for the phase. + +%-------------------------------- +\subsection{Quit} + +Do not amend anything. + +%-------------------------------- +\subsection{Bibliography} + +The bibliographic reference for a parameter can be amended. + +%-------------------------------- +\subsection{Species} + +Not implemented yet. + +%-------------------------------- +\subsection{Symbol} + +Not implemented yet. + +%-------------------------------- +\subsection{Tpfun\_Symbol} + +You can replace a TP function with a new expression. + +This is somewhat dangerous if you have several equilibria because each +equilibria has its own list of most recently calculated values of the +function and they may not be aware of a change of the function and go +on using the already calculated value unless you change $T$ or $P$, in +eqch equilibrium, which will force recalculation. I am thinking of a +way to handle this. + +%=================================================================== +\section{Back } + +Return back from the command monitor to the application program. In +the OC software itself it means terminate the program. + +%=================================================================== +\section{Calculate } + +Different things can be calculated. The normal thing to calculate is +{\bf equilibrium}, the other things are special. + +%-------------------------------- +\subsection{All\_Equilibria} + +Intended for the assessment procedure. Not implemented yet. + +%-------------------------------- +\subsection{Equilibrium} + +The normal command to calculate the equilibrium of a system for the +current set of conditions and phase status. You can calculate a +metastable equilibrium if some phases that should be stable have been +set dormant or suspended or if automatic creation of composition sets +is not allowed. + +%-------------------------------- +\subsection{Global\_Gridmin} + +Calculate with the global grid minimizer without using this result as a +start point for the general minimizer. Used to debug the grid +minimizer. + +%-------------------------------- +\subsection{No\_Global} + +Calculate the equilibrium with the current minimizer without using a +global gid minimizer to generate start constitutions. The current +equilibrium is used as start point. Can be quicker when just a small +change of conditions made since previous calculation. It means no +check of new miscibility gaps. + +%-------------------------------- +\subsection{Phase} + +The Gibbs energy of a phase and possible derivatives are calculated. +Mainly for debugging the implementation of models. + +\subsubsection{Only\_G} + +The Gibbs energy and all T and P derivatives calculated and listed. + +\subsubsection{G\_and\_dGdy} + +The Gibbs energy, all T and P derivatives and all first +derivatives with respect to constituents are calculated and listed. + +\subsubsection{All\_Derivatives} + +The Gibbs energy, all T and P derivatives and all first and second +derivatives with respect to constituents are calculated and listed. + +%-------------------------------- +\subsection{Quit} + +Quit calculating. + +%-------------------------------- +\subsection{Symbol} + +A state variable symbol or function is calculated using the results +from the last equilibrium or grid minimizer calculation. It is used +in particular for calculation of ``dot derivatives'' like H.T for the +heat capacity. + +%-------------------------------- +\subsection{Tpfun\_Symbols} + +All or a specific TPFUN symbol is calculated for current values of T +and P. + +%-------------------------------- +\subsection{Transition} + +You can calculate the value of a state variable when a new phase will +be stable, for example the melting temperature. You must have +calculate an equilibrium and you will be asked to specify the phase +and the condition to be released. + +%=================================================================== +\section{Debug } + +Several possibilities to trace calculations will be implemented in +order to find errors. The only implemented feature is to stop the +program whenever an error occurs. This is useful to find errors using +macro files so the macro not just goes on doing other things. + +\subsection{Stop\_on\_Error} + +The program will stop at the command level after printing the error +message if an error has occured when using macro file. This makes it +easier to use macro files to find errors. + +%=================================================================== +\section{Delete } + +Not implemented yet and may never be, it is not so easy to allow +deleting things when the data structure is so involved, it may be +better to enter the data again without the data that should be +deleted. + +\section{Exit } + +Terminate the OC software. + +%=================================================================== +\section{Enter } + +In most cases data will be read from a database file. But it is +possible to enter all thermodynamic data interactivly. This should +normally start by entering all elements, then all species (the +elements will automatically also be species) and then the phases. + +A species have a fixed stoichiometry and possibly a charge. The +species are the constituents of the phases. + +A phase can have sublattices and various additions like magnetic or +elastic (the latter not implemented yet). + +TPFUN symbols can be used to describe common parts of model +parameters. + +Each parameter of a phase is entered separately. One may use +TPFUN symbols which are already entered. + +At present the multicomponent CEF model and the ionic 2-sublattice +liquid model are the only one implemented. This includes the gas +phase, regular solutions with Redlich-Kister Muggianu model and phases +with up to 10 sublattices and magnetic contributions. + +%-------------------------------- +\subsection{Constitution} + +The constitution (fraction of all constituents) of a phase can be +entered. This is a way to provide start values for a calculation or +to calculate the Gibbs enegy for a specific phase at a specific +constitution using {\bf calculate phase}. + +%-------------------------------- +\subsection{Element} + +The data for an element is entered. It consists of is symbol, name, +reference state, mass, H298-H0 and S298. The latter two values are +never used for any calculation. + +%-------------------------------- +\subsection{Equilibrium} + +One can have several equilibria each with a unique set of conditions +incuding phase status (dormant, suspended, fix or entered). This is +useful for compare different states, to simulate transformations and +to assess model parameters as each experimental or theoretical +information represented as an equilibrium. + +Each equilibrium is independent and they can be calculated in +parallel. + +%-------------------------------- +\subsection{Experiment} + +This is for assessment, not implemented yet. + +%-------------------------------- +\subsection{Parameter} + +A parameter is definded by its identifier, the phase and constituent +array. A parameter can be a constant or depend on T and P. The +parameter will be multiplied with the fractions of the constituents +given by its constituent array. + +For example G(LIQUID,CR) is the Gibbs energy of liquid Cr relative to +its reference state, normally the stable state of Cr at 298.15 K and 1 +bar. + +For a gas molecule G(GAS,C1O2) is the Gibbs energy of the C1O2 molecule +relative to the reference states of C (carbon) and O (oxygen). + +For phases with sublattices the constituents in each sublattice are +separated by a semicolon, ``:'' and interacting constituents in +the same sublattice by a comma, ``,''. For example + +G(FCC,FE:C,VA) is the interaction between C (carbon) and VA (vacant +interstitial sites) in the FCC phase. + +One can store many different types of data in OC using the parameter +identifier. A description of the identifiers currently implemeneted +are given in the introduction. Here is a short list. + +\begin{itemize} +\item G, the Gibbs energy or an interaction parameter +\item TC, the critical temperature for ferro or antiferro magnetic ordering +\item BMAGN, the avarage Bohr magneton number +\item CTA, the Curie temperature for ferromagnetic ordering +\item NTA, the Neel temperature for antiferromagnetic ordering +\item IBM\&C, the individual Bohr magneton number for constituent C +\item THETA, the Debye or Einstein temperature +\item MOBQ\&C, the logarithm of the mobility of constituent C +\item RHO, the electrical resistivity +\item MAGS, the magnetic suseptibility +\item GTT, the glas transition temperature +\item VISC, the viscosity +\item LPAX, the lattice parameter in X direction +\item LPTH, the deviation from cubic structure +\item EC11A, the elastic constrant C11 +\item EC12A, the elastic constrant C12 +\item EC44A, the elastic constrant C44 +\end{itemize} + +The current list can be obtained by the command LIST PARAMETER\_ID. + +%-------------------------------- +\subsection{Phase} + +All thermodynamic data are connected to a phase as defined by its +parameters, see {\bf enter parameter}. A phase has a name with can +contain letters, digits and the underscore character. + +A phase can have 1 or more sublattices and the user must specify the +number of sites on each. He must also specify the constituents on +each sublattice. For some models, like the ionic liquid model, the +number of sites may change with composition. + +By default the model for a phase is assumed to be the Compound Energy +Formalism (CEF). If any onther model should be used that is set by +the {\bf amend} or {\bf set phase bit} commands. + +%-------------------------------- +\subsection{Quit} + +Quit entering things. + +%-------------------------------- +\subsection{Bibligraphy} + +Each parameter must have a reference. When entering a parameter a +reference symbol is given and with this command one can give a full +reference text for that symbol like a published paper or report. + +%-------------------------------- +\subsection{Species} + +A species consists of a name and a stochiometric formula. It can have +a valence or charge. The name is often the stoichiometric formula +but it does not have to be that. Examples: + +\begin{itemize} +\item enter species water h2o +\item enter species c2h2cl1\_trans c2h2cl2 +\item enter species c2h2cl1\_cis c2h2cl2 +\item enter species h+ h1/- -1 +\end{itemize} + +Single letter element names must be followed by a stocichiometric +factor unless it is the last element when 1 is assumed. Two-letter +element names have by default the stoichiometric factor 1. + +\begin{itemize} +\item enter species carbonmonoxide c1o1 +\item enter species cobaltoxide coo +\item enter species carbondioxide c1o2 +\end{itemize} + +The species name is important as it is the name, not the +stoichiometry, that is used when referring to the species elsewhere +like as constituent. + +%-------------------------------- +\subsection{Symbol} + +The OC package has both ``symbols'' and ``tpfun\_symbols'', the latter +has a very special syntax and can be used when entering parameters. + +The symbols are designed to handle relations between state variables, +one can define expressions like + +enter symbol K = X(LIQUID,CR)/X(BCC,CR); + +where K is set to the partition of the Cr mole fractions between +liquid and bcc. + +The symbols also include ``dot derivatives'' like H.T which is the +temperature derivative of the enthalpy for the current system at the +given set of conditions, i.e. the heat capacity. + +%-------------------------------- +\subsection{Tpfun\_Symbol} + +This symbol is an expression depending on T and P that can be used +when entering parameters. A TPfun can refer to another TPfun. + +TPFUNS have a strict syntax because the software must be able to +calculate first and second derivatives with respect to $T$ and $P$. + +%=================================================================== +\section{Exit} + +Terminate the OC software in English. + +%=================================================================== +\section{Fin } + +Terminate the OC software in French. + +%=================================================================== +\section{Help } + +Can give a list if commands or subcommands or parts of this help text. + +%=================================================================== +\section{HPCALC } + +A reverse polish calculator. + +%=================================================================== +\section{Information } + +Not implemeneted yet. + +%=================================================================== +\section{List } + +Many things can be listed. Output is normally on the screen unless it +is redirected by the -output option. + +%-------------------------------- +\subsection{Axis} + +Lists the axis set by the user. + +%-------------------------------- +\subsection{Conditions} + +Lists the conditions set by the user. + +%-------------------------------- +\subsection{Data} + +Lists all thermodynamic data. + +%-------------------------------- +\subsection{Equilibria} + +Lists the equilibria entered (not the result ...). + +%-------------------------------- +\subsection{Phase} + +List data for a phase + +%................... +\subsubsection{Data} + +List the model and thermodynamic data. + +%................... +\subsubsection{Constitution} + +List the constitution of the phase. + +%................... +\subsubsection{Model} + +List some model data for example if there is a disordered fraction set. + +%-------------------------------- +\subsection{Quit} + +You did not really want to list anyting. + +%-------------------------------- +\subsection{Bibliography} + +List the bibliographic references for the data. + +%-------------------------------- +\subsection{Results} + +List the results of an equilibrium calculation. This is the most +frequent list command. The listing will contain the current set of +conditions, a table with global data, a table with component specific +data and a list of stable phases with amounts, compositions and +possibly constitutions. It is possible to list also unstable phases. + +%\subsubsection{Output mode} +There are 9 modes for the output: +\begin{itemize} +\item 1 output in mole fractions, phase composition in value order + (constituent with highest fraction first) +\item 2 as 1 but include also the phase constitution (sublattices and + their fractions) +\item 3 as 1 with the phase composition in alphabetical order (do not work) +\item 4 as 1 but with mass fractions +\item 5 as 4 with the phase composition in alphabetical order (do not work) +\item 6 as 4 and also include the phase constitutions +\item 7 all phases will be listed with composition in mass fractions and + in alphabetical order of the elements. A negative driving force for + a phase means the phase is not stable. +\item 8 all phases will be listed with composition in mole fraction in + value order and the driving force. +\item 9 all phases will be listed with composition and constitutions in + alphabetical order of the elements and the driving force. +\end{itemize} + +For each phase the name, status and driving force (in dimensionless +units) is given on the first line. + +The second line has the amount of the phase in moles and mass of +components (zero if not stable) and its volume (zero if no pressure data). + +The third line has the number of formula units of the phase (zero if +not stable) and the moles of atoms per formula unit. Multiplying +these values together gives the first value on the second line. +Phases with molecules (the gas) or with vacancies have a varying +amount of moles of atoms per formula units. + +%-------------------------------- +\subsection{Short} + +A listing with a single line for each element, species and phase with +some essential data. + +%-------------------------------- +\subsection{State\_Variables} + +Values of state variables like G, HM(LIQUID) etc. can be listed. +Terminated by an empty line. Note that symbols cannot be listed here, +they are calculated by the CALCULATE SYMBOL command. + +%-------------------------------- +\subsection{Symbols} + +All state variable symbols listed but not their values, they are +calculated by the CALCULATE SYMBOL command. + +%-------------------------------- +\subsection{Tpfun\_Symbols} + +All TPFUN symbols are listed. + +%=================================================================== +\section{Macro } + +By specifying a file name commands will be read from that file. The +default extention is OCM. A macro file can open another macro file +(max 5 levels). When a mcro file finish with SET INTERACTIVE the +calling macro file will continue. + +%=================================================================== +\section{Map } + +For phase diagram calculations. One must first ste two axis with +state variables also set as conditions. + +If one gives several MAP commands one can erase or keep the previous +results. + +During mapping each calculated equilibria is saved and then different +kinds of state vaiables can be used for plotting. + +%=================================================================== +\section{New } + +To remove all data so a new system can be entered. Fragile + +%=================================================================== +\section{Plot } + +Plot the result from a STEP or MAP calculation. A simple interface to +gnuplot has been implemented. One can select state variables for the +plot axis and some options like range and title. + +%=================================================================== +\section{Quit } + +Terminate the OC software in Swedish. + +%=================================================================== +\section{Read } + +At present there a very limited SAVE command implemented in OC as it +is difficult to do that before the datastructure is well defined. + +It is possible to read a (non-encrypted) TDB file but it should be not +too different from what is generated by the LIST\_DATA command in TC. + +%-------------------------------- +\subsection{Quit} + +You did not really want to read anything. + +%-------------------------------- +\subsection{TDB} + +A TDB file (with extention TDB) should be specified. The TDB file +must not deviate very much from the output of Thermo-Calc. + +%-------------------------------- +\subsection{Unformatted} + +For use to read a file created with a SAVE UNFORMATTED command. It +will not always work as the datastructure is not fixed. + +%=================================================================== +\section{Save } + +There are several forms of save, three forms write a text file that +can be read and modified with a normal editor. Two forms are +unformatted, either on a sequential file or a direct (random access) +file. + +%-------------------------------- +\subsection{Direct} + +It will eventually be possible to save the result of STEP and MAP +commands on a random access file for later processing. + +%-------------------------------- +\subsection{LaTeX} + +The thermodynatic data will be formatted according to LaTeX for later +inclusion in publications. Not implemented. + +%-------------------------------- +\subsection{Macro} + +The thermodynamic data will be written as a macro file that can later +be read back into the OC software. Not implemented. + +%-------------------------------- +\subsection{Quit} + +You did not want to save. + +%-------------------------------- +\subsection{TDB} + +The thermodynamic data will be written in a text form that can be later +read by OC or other software. Not implemented. + +%-------------------------------- +\subsection{Unformatted} + +The intention is that one will be able to save the current status of +the calculations on a file and then reassume the calculations by +reading this file. A tentative version is implemented. + + +%=================================================================== +\section{Select } + +%-------------------------------- +\subsection{Equilibrium} + +As the user can enter several equilibria with different conditions +this command allows him to select the current eqilibria. + +%-------------------------------- +\subsection{Graphics} + +Not implemented yet. + +%-------------------------------- +\subsection{Minimizer} + +Not implemented yet + +%=================================================================== +\section{Set } + +Many things can be set. Things to be ``set'' and ``amended'' +sometimes overlap. + +%-------------------------------- +\subsection{Advanced} + +Not implemented yet + +%-------------------------------- +\subsection{Axis} + +A condition can be set as an axis variable with a low and high limit +and a maximum increement. With 2 or more axis one will calculate a +phase diagram, i.e. lines where the set of stable phases changes. + +With one axis one calculates the set of stable phases and their +properties while changing the axis variable. + +%-------------------------------- +\subsection{Condition} + +A condition is a value assigned to a state variable or an expression +of state variables. By setting the status of a phase to fix one has +also set a condition. + +%-------------------------------- +\subsection{Echo} + +This is useful command in macro files. + +%-------------------------------- +\subsection{Input\_Amounts} + +This allows the user to specify a system by giving a redundant amount +of various species in the system. The software will tranform this to +conditions on the amounts of the components. + +%-------------------------------- +\subsection{Interactive} + +The usual end of a macro file. Gives command back to the keyboard of +the user, or to the calling macro file. Without this the program will +just terminate. + +%-------------------------------- +\subsection{Level} + +I am no longer sure what this should do and if it is needed ... + +%-------------------------------- +\subsection{Log\_File} + +A useful command to save all interactive input while running OC. The +log file can easily be transformed to a macro file. All bug reports +should be accompanied by a log file which reproduces the bug. + +%-------------------------------- +\subsection{Numeric\_Options} + +Some numeric option can be set. + +%-------------------------------- +\subsection{Phase} + +Some phase specific things can be set, also for the model. + +%.................... +\subsubsection{AMOUNT} + +One can specify the amount of the phase which is used as initial value +for an equilibrium calculation. + +%.................... +\subsubsection{BITS} + +Some of the models and data storage depend on the bits of the phase. +These are + +%. . . . . . . . . . +\begin{itemize} +%\subsubsubsection{FCC\_PERMUTATIONS] +\item FCC\_PERMUTATIONS is intended for the 4 sublattice CEF model for +fcc ordering. Setting this bit means that only unique model +parameters needs to be entered, the software will take care of all +permutations. HCP permutations is also handelled by this bit as they +are identical in the 4 sublattice model. + +%. . . . . . . . . . +%\subsubsubsection{BCC\_PERMUTATIONS} +\item BCC\_PERMUTATIONS is intended for the 4 sublattice CEF model for +BCC ordering. The BCC tetrahedron is unsymmetric which makes it a bit +more complicated. Not implemented yet. + +%. . . . . . . . . . +%\subsubsubsection{IONIC\_LIQUID\_MDL} +\item IONIC\_LIQUID\_MDL. By setting this bit the phase is treated +with the 2 sublattice paritally ionic liquid model. It must have been +entered with 2 sublattices and only cations in the first sublattice +and only anions, vacancy and neutrals in the second. + +%. . . . . . . . . . +%\subsubsubsection{AQUEOUS\_MODEL} +\item AQUEOUS\_MODEL. Not implemented yet. + +%. . . . . . . . . . +%\subsubsubsection{QUASICHEMICAL} +\item QUASICHEMICAL. Is intended for the classical quasichemical +model for crystalline phases. Not implemented yet. + +%. . . . . . . . . . +%\subsubsubsection{FCC\_CVM\_TETRADRN} +\item FCC\_CVM\_TETRADRN. Is intended for the CVM tetrahedron model. +Not implemented yet. + +%. . . . . . . . . . +%\subsubsubsection{FACT\_QUASICHEMCL} +\item FACT\_QUASICHEMCL. Is intended for one for the FACT modified +quasichemical liquid models. Not implemented yet. + +%. . . . . . . . . . +%\subsubsubsection{NO\_AUTO\_COMP\_SET} +\item NO\_AUTO\_COMP\_SET. This makes it possible to prevent that a +specific phase has automatic composition set created during +calculations. + +%. . . . . . . . . . +%\subsubsubsection{ELASTIC\_MODEL\_A} +\item ELASTIC\_MODEL\_A. This should specify the elastic model to be +used. Not implemented yet. +\end{itemize} + +%.................... +\subsubsection{CONSTITUTION} + +This is the same as {\bf amend phase constitution}. + +%.................... +\subsubsection{DEFAULT\_CONSTITU} + +Same as {\bf amend phase default\_constit}. + +%.................... +\subsubsection{STATUS} + +A phase can have 4 status + +\begin{itemize} +\item entered, this is the default. The phase will be stable if that +would give the most stable state for the current conditions. The user +can give a tentative amount. +\item suspended, the phase will not be included in any calculations. +\item dormant, the phase will be included in the calculations but will +not be allowed to become stable even if that would give the most +stable equilibrium. In such a case the phase will have a positive +driving force. +\item fixed means that it is a condition that the phase is stable with +the specified amount. Note that for solution phases the composition +is not known. +\end{itemize} + +%-------------------------------- +\subsection{Quit} + +You did not really want to set anything + +%-------------------------------- +\subsection{Reference\_State} + +For each component (also when not the elements) one should be able to +specify a phase at a given temperature and pressure as reference +state. The phase must exist for the pure component. + +%-------------------------------- +\subsection{Status} + +%.................... +\subsection{Constituent} + +A constituent of a phase can be suspended. Not yet implemented. + +%.................... +\subsection{Element} + +An element can be ENTERED or SUSPENDED. If an element is suspended +all species with this element is automatically suspended. + +%.................... +\subsection{Phase} + +A phase can have 4 status as described for the SET PHASE STATUS +command above. Changing the pase status does not affect anything +except the phase itself. + +%.................... +\subsection{Species} + +A species can be ENTERED or SUSPENDED. If a species is suspended +all phases that have this as single constituent in a sublattice +will be automatically suspened. + +%-------------------------------- +\subsection{Units} + +For each property the unit can be specified like Kelvin, Farenheit or +Celsius for temperature. Not implemented yet. + +%-------------------------------- +\subsection{Weight} + +Intended for assessments. Not implemented yet. + +%=================================================================== +\section{Step } + +Requires that a single axis is set. + +Calculates equilibria from the low axis limit to the high at each +increment. + +%=================================================================== +% Using this file for on-line help there must be a section after last command +\section{Summary } + +That's all. + +\end{document} diff --git a/pmain1-save.F90 b/pmain1-save.F90 index d7dbedf..539015e 100644 --- a/pmain1-save.F90 +++ b/pmain1-save.F90 @@ -17,11 +17,11 @@ PROGRAM pmain1 double precision dblvar(10) ! ! the next line overwritten with current linkdate by linkocdate - linkdate='01-01-2012' + linkdate='01-01-2015' ! this is the overall version identifier - version=' 2.0' + version=' 3.0' ! intvar and dblvar will eventually be used for allocations and defaults - intvar(1)=20 + intvar(1)=30 call init_gtp(intvar,dblvar) if(gx%bmperr.ne.0) then stop 'Error initiating GTP data structures' diff --git a/readme.tex b/readme.tex deleted file mode 100644 index e0b8be8..0000000 --- a/readme.tex +++ /dev/null @@ -1,315 +0,0 @@ -\documentclass[12pt]{article} -\usepackage[latin1]{inputenc} -\usepackage{graphicx,subfigure} -\topmargin -1mm -\oddsidemargin -1mm -\evensidemargin -1mm -\textwidth 165mm -\textheight 220mm -\parskip 2mm -\parindent 3mm -%\pagestyle{empty} - -\begin{document} -\begin{center} -{\Large \bf Some important facts about this test release of the -OC software.} - -Bo Sundman, \today - -http://www.opencalphad.org - -bo.sundman@gmail.com -\end{center} - -{\large \bf Please be aware that this software is a beta test version. -Your feedback about problems and errors is important to make it -better.} - -OC cannot replace your favourite thermodynamic software today or -tomorrow but the main advantage is that you have access to the source -code and can (with some efforts) add or fix things yourself that you -are missing in your favourite software. - -\section{Getting started} - -\begin{itemize} -\item The code is written in the new Fortran standard and requires -a compiler like GNU Fortran 4.4 or similar. - -\item The development is made on Windows with MinGW installed and -there is a file ``linkmake.txt'' which you should rename to -``linkmake.cmd'' in order to compile and link an executable program -from the source code. If you are using UNIX you can modify this file -or write a Makefile. - -\item There is a website, http:://www.opencalphad.com, for -information, questions and discussions on the software and databases. - -\item The documentation of the source code is in the directory -``documentationupdate''. A very rudimentary user guide (also -available on line in the file ``ochelp.hlp'') is the -``manual''directory). The ``macro'' directory has examples for a -variety of calculations. In some test releases these are not included -but they can be downloaded from the web site. - -\item For the graphics you must download and install the GNUPLOT - software. That is freely available from the web. - -\item Contributions of new and improved source code are welcome. -Contact Bo Sundman if you want to know how. - -\item The command line interface has a ``VAX/VMS'' flavour which -reflects the age of the developer. It means the commands are -``verbs'' like {\em set, list, calculate, enter etc.}. After the verb -several objects are usually possible. There is some redundancy so the -same effect can be achieved by different combinations of verbs and -objects. Each command and subcommand can be abbreviated. - -If you are burning to develop another user interface you are welcome -to do so. - -\item Thermodynamic data can be read from a (unencrypted) TDB file -{\em read tdb ``filename''} or entered interactively. You can specify -which elements you want from the TDB file but not exclude any phases. - -\item There are some exception from how data are entered into OC -comparared to Thermo-Calc, most important perhaps the ``partitioning'' -of a phase into an ordered and disordered part. OC has implemeneted -this in a different way and at present it is not possible for OC to -read such partitioned data from a TDB file. - -\item You can save the thermodynamic data and results from a -calculation on an unformatted file {\em save un ``filename''} -and this can be read back into the program {\em read un ``filename''}. - -If you already have data in the program you have to confirm that you -want to overwrite them. You can also remove the data by the command -{\em new YES}. - -You can list data on the screen but there is no way to write a TDB -file from OC yet. The OC format for TDB files will be slightly -different from that used by Thermo-Calc. - -\item You can also have data entered from a macro file as well as -commands for calculations. In order to document errors or problems -please send a complete macro file reproducing the error. You can -generate a macro file interactivly by setting a log file {\em set log -``filename''} and then (after some editing) use the log file as a -macro. - -\item Setting conditions is very similar to the Thermo-Calc software. -Each condition is set separately by the command is {\em set cond -``state variable'' = ``value''}. The safest conditions for -calculating an equilibrium, i.e. which has most chance to converge, is -to set values on T, P and N(element), i.e. the total amount of each -element. The table at the end gives a list of state variable symbols -and their meaning. - -It is also possible to set conditions on chemical potentials and that -a phase is stable (fix). See the macro file examples how this is -done. Note that many commands are fragile and they may also change -between releases of the test versions of the OC software, depending on -suggestions by users. - -The intention is that you should be able to combine any set of -conditions to calculate the equilibrium, i.e. you can combine -conditions on mole fractions, mass fractions, fix phases, chemical -potentials etc. In the next release the plan is to allow expressions -of conditions, not just a single state variable. - -\item The command {\em calculate equilibrium (c e)} tries to calculate -the equilibrium. As the minimizer needs a guess of stable phases and -their start constitution, the OC software tries first to invoke a -global grid minimizer. If you want to provide a guess of the set of -stable phases you can use the {\em set phase ``name'' const} followed -by the command {\em calculate no\_global (c n)}. - -\item The grid minimizer that calculates start points for the general -minimizer is very primitive. If you have ideas how to improve it you -are welcome to provide advice or code. - -\item The convergence has improved a lot compared to the first release -but you will still frequently have problems with convergence, many -times there will be error messages and sometimes the software may -converge to the wrong equilibrium. In this test version you should -always check the results with you favourite thermodynamic software. - -If the calculation does not converge try to use the command {\em ``c -n''} two or three times to continue to iterate from the set of phases -you have. The {\em ``c e''} command runs the grid minimiser and, -therefore, will give the same result each time. - -You can also try to increase the number of iterations {\em set num 500 -,,,,}. Or you can manually set the phases you think are stable {\em -set phase const} followed by {\em ``c n''}. You can suspend -metastable phases that you think cause problems {\em set status phase -``name'' sus}. - -You can try to simplify the conditions for a first calculation and -then change them to those you are interested in and for each change -calculate using {\em ``c n''}. Calculations at temperatures and -compositions where the system is single phase have a higher chance of -success. The algorithm to change the set of stable phases is fragile -and has not been fine tuned. - -\item There is a simple step procedure to calculate property diagrams. -It uses gnuplot to handle the graphics. If you are interested in this -feature there will be a discussion group on the future design of the -step and map (of phase diagrams) commands and graphical output. - -\item To report errors and problems please attach a macro file that -reproduces the problem. To create a macro file run the command -interface with a log file and edit the log file to be a macro. Both -the macro file and the model parameters (preferably in a tdb file) -must be submitted. Try to find the simplest case that reproduces the -error. - -\end{itemize} - -\section{A summary of state variables.} - -The state variables in the user interface have their common symbols, -$T$ for temperature, $P$ for pressure, $N$ for the total amount of -moles, ``$N$(element)'' for the amount of moles of a component, -``$X$(element)'' for the mole fraction ``$MU$(element)'' for the -chemical potential, ``$AC$(element)'' for the activity. The symbol -$B$ is used for the total mass (copied from the Thermo-Calc software), -``$B$(element)'' for the mass of an element and ``$W$(element)'' for -the mass fraction. There are many more state variables like $H$, $G$ -etc, see the table, but not all of them can be used as conditions. - -\begin{table} -\caption{A very preliminary table with the state variables and their -internal representation. Some model parameter properties are also -included.}\label{tab:statevar} -\begin{tabular}{|llccll|}\hline -Symbol & Id & \multicolumn{2}{c}{Index} & Normalizing & Meaning\\ - & & 1 & 2 & suffix & \\\hline -\multicolumn{6}{|c|}{Intensive properties}\\\hline -T & 1 & - & - & - & Temperature\\ -P & 2 & - & - & - & Pressure\\ -MU & 3 & component & -/phase & - & Chemical potential\\ -AC & 4 & component & -/phase & - & Activity\\ -LNAC & 5 & component & -/phase & - & LN(activity)\\\hline -\multicolumn{6}{|c|}{Extensive properties}\\\hline -U & 10 & -/phase\#set & - & - & Internal energy for system\\ -UM & 11 & -/phase\#set & - & M & Internal energy per mole\\ -UW & 12 & -/phase\#set & - & W & Internal energy per mass\\ -UV & 13 & -/phase\#set & - & V & Internal energy per m$^3$\\ -UF & 14 & phase\#set & - & F & Internal energy per formula unit\\ -Sz & 2z & -/phase\#set & - & - & entropy\\ -Vz & 3z & -/phase\#set & - & - & volume\\ -Hz & 4z & -/phase\#set & - & - & enthalpy\\ -Az & 5z & -/phase\#set & - & - & Helmholtz energy\\ -Gz & 6z & -/phase\#set & - & - & Gibbs energy\\ -NPz & 7z & phase\#set & - & - & Moles of phase\\ -BPz & 8z & phase\#set & - & - & Mass of phase\\ -Qz & 9z & phase\#set & - & - & Stability of phase\\ -DGz & 10z & phase\#set & - & - & Driving force of phase\\ -Nz & 11z & -/phase\#set/comp & -/comp & - & Moles of component\\ -X & 111 & phase\#set/comp & -/comp & 0 & Mole fraction\\ -X\% & 111 & phase\#set/comp & -/comp & 100 & Mole per cent\\ -Bz & 12z & -/phase\#set/comp & -/comp & - & Mass of component\\ -W & 122 & phase\#set/comp & -/comp & 0 & Mass per cent\\ -W\% & 122 & phase\#set/comp & -/comp & 100 & Mass per cent\\ -Y & 130 & phase\#set & const\#subl & -& Constituent fraction\\\hline -\multicolumn{6}{|c|}{Some model parameter identifiers}\\\hline -TC & - & phase\#set & - & - & Curie temperature\\ -BMAG & - & phase\#set & - & - & Aver. Bohr magneton number\\ -MQ\& & - & phase\#set & constituent & - & Mobility\\ -THET & - & phase\#set & - & - & Debye temperature\\\hline -\end{tabular} -\end{table} - -You can specify that a phases should be stable by the command {\em set -status phase}. For example to calculate the melting point of an alloy -after specifying the composition and making a calculation at fixed T -and P, you can give the commands {\em set cond T=none; set status -liquid=fix 0; c n}. (The commands must be given on separate lines). - -In some cases it is convenient to use the command {\em set input -amount} to specify the amounts of a redundant set of species that are -added together to make up the overall composition. - -\section{Manipulating the source code} - -The OC software is provided with a GNU license which means that you -have the source code and can use it and modify it as you wish as long -as you do not try to make money of it. If you want to include the OC -software in a commercial program you must contact the copyright -owners. - -There is a fairly extensive documentation of the source code in the -directory ``documentationupdate'' and if you look at the code itself -there are some comments there too. I have spent a lot of effort to -make the datastructures general and flexible to handle multicomponent -and multiphase systems. But there was quite a lot of redundancy -introduced during the development that eventually will be removed. -The set of subroutines is less structured and one problem has been -that this code was my first attempt to use the new Fortran standard so -there are probably many things that can be made simpler. You are -welcome to point out where this can be done. The hope is to have a -new release before the end of 2013 with an improved version of this -part of the code and some more thermodynamic models and facilities for -conditions and generating diagrams will be available. - -As I have understood the data structures (TYPE) in the new Fortran -standard is more or less identical to those used in C++ so it should -not be too difficult to combine code written in these languages. - -\section{Application software library} - -There are some routines provided that makes it possible to integrate -the OC software in application programs. Those can be found in the -directory ``TQlib'' together with a sample test program. To compile -and run this the OClib.a file and some of the ``mod'' files must be -copied to this directory. - -The test program has also been converted to C although without any -user interctivity, anyone knowledgable about C is welcome to improve -this. - -Use only subroutines in this library to access the OC software, do not -call directly subroutines inside the OC code as they may not be -available or have different functionallity in a future release. If -you miss some routines please contact the OC software group. - -\section{Examples} - -To help you get started calculating a number of examples is -provided in the ``macro'' directory. - -\begin{enumerate} -\item Entering data manually for an ideallized system (Al-Ni) with -ordering, setting ordering options and conditions and calculating an -equilibrium, ocex01A. - -\item Combining reading a TDB file and entering data manually in a -ternary system (Al-Cr-Ni), with fcc and bcc ordering. Setting -ordering options and conditions and calculating some equilibria, -ocex01B. - -\item Entering some parameters for various physical models for a -fictive binary system. Checking how they vary with composition, -ocex01C. - -\item Reading a TDB file for a binary system (Cr-Fe), setting -conditions and calculating several equilibria for different -conditions, ocex02A. - -\item Reading a TDB file for a ternary system (C-Cr-Fe), and calculate -several equilibrium for different conditions, ocex02B. - -\item Reading a TDB file for a binary gas system (H-O), setting -various conditions and calculating equilibria, ocex02C. - -\item Reading a TDB file for a multcomponent steel, setting conditions -and calculating an equilibrium. Setting an axis, stepping and -plotting some curves, ocex03A. -\end{enumerate} - -{\large \bf Have fun and help make OC useful!} - -\end{document} - diff --git a/stepmapplot/smp1.F90 b/stepmapplot/smp1.F90 index 4951153..8da733a 100644 --- a/stepmapplot/smp1.F90 +++ b/stepmapplot/smp1.F90 @@ -201,7 +201,7 @@ MODULE ocsmp ! ndx is mumber of plot axis, pltax is text with plotaxis variables ! filename is intermediary file (maybe not needed) ! maptop is map_node record with all results -! form is type of output (screen or postscript) +! form is type of output (screen or postscript or jpeg) integer rangedefaults(3) double precision, dimension(3) :: plotmin,plotmax double precision, dimension(3) :: dfltmin,dfltmax @@ -211,6 +211,10 @@ MODULE ocsmp ! label 1 is heading, 2 is x-axis text, 3 is y-axis text character*64, dimension(3) :: plotlabels logical gibbstriangle +! the set key command in GNUPLOT specifies where the line id is written +! it can be on/off, placed inside/outside, left/right/center, top/bottom/center, +! and some more options that may be implemented later ... + character labelkey*24 ! many more options can easily be added when desired, linetypes etc end TYPE graphics_options !\end{verbatim} @@ -377,7 +381,7 @@ subroutine map_setup(maptop,nax,axarr,starteq) ! xxx=zzz+mapline%axandir*yyy xxx=zzz !>>>>>>>>>>>>>>>>>>>>>>>>>>>> -! restore constitutions, not a good idea ... +! restore constitutions, not a good idea ?? ... write(*,*)'Restore constitutions 1' call restore_constitutions(ceq,copyofconst) ! @@ -554,7 +558,7 @@ subroutine map_setup(maptop,nax,axarr,starteq) ! calculate with half the step 5 times. If axvalok=0 no previous axis value write(*,*)'Phases want to appear/disappear: ',iadd,irem ! restore constitutions - write(*,*)'Restore constitutions 3' + write(*,*)'Restore constitutions 3',axvalok,ceq%tpval(1) call restore_constitutions(ceq,copyofconst) call map_halfstep(halfstep,axvalok,mapline,axarr,ceq) if(gx%bmperr.eq.0) then @@ -1518,8 +1522,9 @@ subroutine map_store(mapline,axarr,nax,saveceq) double precision value ! pointer to last calculated (can be zero) and last free ! store last calulated axis values in axarr(iax)%lastaxval -! write(*,*)'In map_store' - do jj=1,mapline%start%number_ofaxis +! write(*,*)'In map_store',mapline%start%number_ofaxis,nax +! do jj=1,mapline%start%number_ofaxis + do jj=1,nax axstv1=axarr(jj)%axcond(1) axstv=>axstv1 call state_variable_val(axstv,value,mapline%lineceq) @@ -2352,7 +2357,7 @@ subroutine map_calcnode(irem,iadd,maptop,mapline,meqrec,axarr,ceq) endif !-------------- ! mark that the phase is fix, we have to be careful not to exceed size -! Sigh, the fixed phases must be in sequential order ... not done here +! Sigh, the fixed phases must be in sequential order ??? ... not done here ! ... maybe not needed ?? meqrec%nfixph=meqrec%nfixph+1 if(meqrec%nfixph.gt.size(meqrec%fixpham)) then @@ -2374,12 +2379,12 @@ subroutine map_calcnode(irem,iadd,maptop,mapline,meqrec,axarr,ceq) ! If there is a phase change (iadd or irem nonzeri) or error it exits 200 continue iadd=0; irem=0 -! write(*,*)'In map_calcnode calling sameset for new node: ',& -! meqrec%nstph,meqrec%nfixph + write(*,*)'In map_calcnode calling sameset for new node: ',& + meqrec%nstph,meqrec%nfixph ! call meq_sameset(irem,iadd,meqrec,meqrec%phr,ceq) ! -! write(*,202)'Calculated with fix phase: ',gx%bmperr,irem,iadd,ceq%tpval + write(*,202)'Calculated with fix phase: ',gx%bmperr,irem,iadd,ceq%tpval 202 format(a,3i4,2(1pe12.4)) !------------------------------------------------- ! trouble if error or another phase wants to be stable/dissapear @@ -2399,6 +2404,7 @@ subroutine map_calcnode(irem,iadd,maptop,mapline,meqrec,axarr,ceq) endif ! Problems, the simplest is to go back and try a smaller step ! But we must first remove the fix phase and restore the axis condition + write(*,*)'Error calculating node point, take shorter step' if(ocv()) write(*,*)'Error calculating node point, take shorter step' pcond%active=0 pcond%prescribed=axval @@ -2740,6 +2746,7 @@ subroutine map_newnode(mapline,meqrec,maptop,axval,lastax,axarr,phfix,ceq) ! correct value of lines will be set later newnode%lines=0 newnode%tieline_inplane=maptop%tieline_inplane +! this seems to be wrong, maptop%number_ofaxis is zero when step separate newnode%number_ofaxis=maptop%number_ofaxis ! save index of the phase set fix at the node ! write(*,*)'Saving index of fix phase: ',phfix @@ -3342,7 +3349,8 @@ subroutine map_findline(maptop,axarr,mapfix,mapline) integer nyline,jp,seqy,iph,ics,lokph,lokcs,ip double precision finc character eqname*24 - character phaseset*72 +! sometimes there are many phases with long names ... + character phaseset*512 mapnode=>maptop ! for the moment skip this for tie-lines not in the plane ! write(*,*)'In map_findline: ',mapnode%tieline_inplane @@ -3441,7 +3449,7 @@ subroutine map_findline(maptop,axarr,mapfix,mapline) ! write(*,*)'Findline: Tie-lines not in plane: ',nyline,ip ! create a heading text for the line phaseset=' ' - call phase_name(mapfix%fixph(1),phaseset) + call get_phasetup_name(mapfix%fixph(1),phaseset) if(gx%bmperr.ne.0) goto 1000 ip=len_trim(phaseset)+4 phaseset(ip-2:ip-2)='+' @@ -3458,7 +3466,7 @@ subroutine map_findline(maptop,axarr,mapfix,mapline) do jp=1,mapfix%nstabph ! this is stored only for "real" nodes mapfix%stableph(jp)=mapnode%linehead(nyline)%stableph(jp) - call phase_name(mapfix%stableph(jp),phaseset(ip:)) + call get_phasetup_name(mapfix%stableph(jp),phaseset(ip:)) if(gx%bmperr.ne.0) goto 1000 ! this values hould perhaps be in linehead?? ! mapfix%stablepham(jp)=mapnode%linehead(nyline)%stablepham(jp) @@ -3497,7 +3505,7 @@ subroutine map_findline(maptop,axarr,mapfix,mapline) mapfix%fixph=mapline%linefixph(1) ! create a heading text for the line phaseset=' ' - call phase_name(mapfix%fixph(1),phaseset) + call get_phasetup_name(mapfix%fixph(1),phaseset) if(gx%bmperr.ne.0) goto 1000 ip=len_trim(phaseset)+4 phaseset(ip-2:ip-2)='+' @@ -3507,7 +3515,7 @@ subroutine map_findline(maptop,axarr,mapfix,mapline) ! this is stored only for "real" nodes mapfix%nstabph=1 mapfix%stableph(1)=mapnode%linehead(nyline)%stableph(1) - call phase_name(mapfix%stableph(1),phaseset(ip:)) + call get_phasetup_name(mapfix%stableph(1),phaseset(ip:)) if(gx%bmperr.ne.0) goto 1000 ! set positive amount both in mapfix and in phase_varres ... ! mapfix%stablepham(1)=mapnode%linehead(nyline)%stablepham(1) @@ -3548,7 +3556,7 @@ subroutine map_findline(maptop,axarr,mapfix,mapline) phaseset=' ' ip=1 do jp=1,mapnode%linehead(1)%nstabph - call phase_name(mapnode%linehead(1)%stableph(jp),phaseset(ip:)) + call get_phasetup_name(mapnode%linehead(1)%stableph(jp),phaseset(ip:)) if(gx%bmperr.ne.0) goto 1000 ip=len_trim(phaseset)+2 enddo @@ -3642,7 +3650,7 @@ end function tieline_inplane !\begin{verbatim} integer function invariant_equilibrium(lines,mapnode) -! Only called for tieöines not in plane. If tie-lines in plane then all +! Only called for tie-lines not in plane. If tie-lines in plane then all ! nodes are invariants. integer lines type(map_node), pointer :: mapnode @@ -3676,8 +3684,8 @@ subroutine map_problems(maptop,mapline,axarr,xxx,typ) character ch1*1 integer oldaxis write(*,7)'In map_problem: ',typ,mapline%problems,mapline%axandir,& - mapline%nodfixph,xxx -7 format(a,4i4,6(1pe14.6)) + mapline%nodfixph,maptop%number_ofaxis,xxx +7 format(a,5i4,6(1pe14.6)) ! we can list the current conditions here, ! note fix phases for mapping not included as condition!! ! call list_conditions(kou,mapline%lineceq) @@ -3694,12 +3702,28 @@ subroutine map_problems(maptop,mapline,axarr,xxx,typ) endif gx%bmperr=9876; goto 1000 endif +! list current conditions + call list_conditions(kou,mapline%lineceq) + if(maptop%number_ofaxis.eq.1) then +! for step only take smaller steps or calculate with grid minimizer + if(typ.eq.1) then +! take a smaller step +! current axis condition value is xxx, mapline%firstinc is the step taken + xxx=xxx-0.999*mapline%firstinc + else + write(*,*)'Unknown problem ',typ + gx%bmperr=3333 + endif + goto 1000 + endif +!======================================================= +! two or more axis select case(typ) case default write(*,*)'Unknown problem ',typ gx%bmperr=3333 !------------------------------------------------------ - case(1) ! error at first step + case(1) ! error at first step, for map opposite direction ! current axis condition value is xxx, mapline%firstinc is the step taken yyy=xxx ! write(*,*)'First increment: ',mapline%axandir,mapline%firstinc @@ -3715,8 +3739,6 @@ subroutine map_problems(maptop,mapline,axarr,xxx,typ) !>> xxx=yyy+0.02D0*mapline%firstinc best tested value xxx=yyy+0.02D0*mapline%firstinc mapline%axandir=-mapline%axandir -! list current conditions -! call list_conditions(kou,mapline%lineceq) elseif(mapline%problems.eq.3) then ! third time take small step in other axis ! write(*,*)'Changing active axis' @@ -3821,14 +3843,14 @@ end subroutine list_stored_equilibria !/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\ !\begin{verbatim} - subroutine ocplot2(ndx,pltax,filename,maptop,axarr,graphopt,form,ceq) + subroutine ocplot2(ndx,pltax,filename,maptop,axarr,graphopt,pform,ceq) ! ndx is mumber of plot axis, pltax is text with plotaxis variables ! filename is intermediary file (maybe not needed) ! maptop is map_node record with all results -! form is type of output (screen or postscript) +! pform is type of output (screen or postscript or jpeg) implicit none integer ndx - character pltax(*)*(*),filename*(*),form*(*) + character pltax(*)*(*),filename*(*),pform*(*) type(map_axis), dimension(*) :: axarr type(map_node), pointer :: maptop type(graphics_options) :: graphopt @@ -3846,22 +3868,32 @@ subroutine ocplot2(ndx,pltax,filename,maptop,axarr,graphopt,form,ceq) integer, parameter :: maxval=10000 integer, dimension(:), allocatable :: nonzero,linzero,linesep ! integer, dimension(:), allocatable :: linesep - character statevar*64,encoded*64 +! encoded2 stores returned text from get_many ... 2048 is too short ... + character statevar*64,encoded1*64,encoded2*4096 character*64, dimension(:), allocatable :: phaseline integer i,ic,jj,k3,kk,kkk,lokcs,nnp,np,nrv,nv,nzp,ip,nstep,nnv integer nr,line,next,seqx,nlinesep,ksep,iax,anpax,notanp double precision xmax,xmin,ymax,ymin,value,anpmin,anpmax - integer giveup,nax,ikol,maxanp - character date*8,mdate*12,title*80 +! lhpos is last used position in lineheader + integer giveup,nax,ikol,maxanp,lcolor,lhpos + character date*8,mdate*12,title*128,backslash*2,lineheader*1024 + character deftitle*64 logical overflow,first,last +! line identification (title) + character*16, dimension(:), allocatable :: lid +! logical nolid ! ! write(*,*)'In ocplot2, looking for segmentation fault 1' call date_and_time(date) mdate=" "//date(1:4)//'-'//date(5:6)//'-'//date(7:8)//" " + deftitle='Open Calphad 3.0'//mdate//': with GNUPLOT' if(graphopt%labeldefaults(1).eq.0) then - title='Open Calphad 2.0 with Gnuplot '//mdate + title=deftitle else - title=graphopt%plotlabels(1)(1:graphopt%labeldefaults(1))//' '//mdate +! alwas inlcude open calphad and date, add user title at the end +! 123456789.123456789.123456789 +! 'Open Calphad 3.0 2015-03-16 : with GNUPLOT' + title=deftitle(1:30)//graphopt%plotlabels(1) endif ! if(.not.associated(maptop)) then @@ -4002,13 +4034,11 @@ subroutine ocplot2(ndx,pltax,filename,maptop,axarr,graphopt,form,ceq) do jj=1,noph() do ic=1,noofcs(jj) k3=test_phase_status(jj,ic,value,curceq) -! write(*,*)'In ocplot2, looking for segmentation fault 4B' if(k3.gt.0) then ! this phase is stable or fix call get_phase_name(jj,ic,dummy) phaseline(nlinesep)(kk:)=dummy kk=len_trim(phaseline(nlinesep))+2 -! write(*,*)'In ocplot2, looking for segmentation fault 4C' endif enddo enddo @@ -4017,11 +4047,9 @@ subroutine ocplot2(ndx,pltax,filename,maptop,axarr,graphopt,form,ceq) ! the segmentation fault was that linzero not always allocated .... if(allocated(linzero)) linzero=0 endif -! write(*,*)'In ocplot2, looking for segmentation fault 4G' -! no wildcards allowed on one axis +! no wildcards allowed on this axis statevar=pltax(notanp) -! call get_state_var_value(statevar,value,encoded,curceq) - call meq_get_state_varorfun_value(statevar,value,encoded,curceq) + call meq_get_state_varorfun_value(statevar,value,encoded1,curceq) if(gx%bmperr.ne.0) then ! this error should not prevent plotting the other points write(*,212)'Skipping this point 1: ',statevar(1:10),& @@ -4040,16 +4068,18 @@ subroutine ocplot2(ndx,pltax,filename,maptop,axarr,graphopt,form,ceq) statevar=pltax(anpax) if(wildcard) then ! write(*,*)'Getting a wildcard value 1: ',nr,statevar(1:20) - call get_many_svar(statevar,yyy,nzp,np,encoded,curceq) + call get_many_svar(statevar,yyy,nzp,np,encoded2,curceq) ! write(*,*)'Values: ',np,(yyy(i),i=1,np) if(gx%bmperr.ne.0) then ! write(*,*)'yaxis error: "',statevar(1:20),'"' goto 1000 endif +! write(*,111)encoded2(1:len_trim(encoded2)),(yyy(ic),ic=1,np) ! write(*,16)'val: ',kp,nr,gx%bmperr,(yyy(i),i=1,np) 16 format(a,2i3,i5,6(1pe11.3)) anpmin=1.0D20 anpmax=-1.0D20 + lcolor=0 do jj=1,np if(last) then if(linzero(jj).ne.0) then @@ -4067,14 +4097,29 @@ subroutine ocplot2(ndx,pltax,filename,maptop,axarr,graphopt,form,ceq) if(ikol.eq.0) ikol=jj if(anp(jj,nv).gt.anpmax) anpmax=anp(jj,nv) if(anp(jj,nv).lt.anpmin) anpmin=anp(jj,nv) +! extract state variable jj + if(.not.allocated(lid)) then + allocate(lid(np)) +! write(*,*)'Allocate lid: ',np + endif +! getext( , ,2, , , ) returns next text item up to a space + call getext(encoded2,lcolor,2,encoded1,'x',lhpos) + lid(jj)=encoded1 + kk=len_trim(encoded1) + if(kk.gt.len(lid(jj))) then + lid(jj)(7:)='..'//encoded1(kk-6:kk) + else + endif + else +! skip state variable + call getext(encoded2,lcolor,2,encoded1,'x ',lhpos) endif endif enddo ! write(*,*)'OK Point: ',nr,nv,xax(nv) else -! write(*,*)'Single state variable value: ',statevar(1:20),nr -! call get_state_var_value(statevar,value,encoded,curceq) - call meq_get_state_varorfun_value(statevar,value,encoded,curceq) +! More than one state variable or function value + call meq_get_state_varorfun_value(statevar,value,encoded1,curceq) if(gx%bmperr.ne.0) then write(*,212)'Skipping this point 2: ',statevar(1:10),& curceq%tpval(1),nv,nr @@ -4105,7 +4150,6 @@ subroutine ocplot2(ndx,pltax,filename,maptop,axarr,graphopt,form,ceq) enddo plot1 220 continue ! finished one line -! write(*,*)'In ocplot2, looking for segmentation fault 4K' if(nax.gt.1) then !------------------ special for invariant lines ! for phase diagram always move to the new line @@ -4147,9 +4191,8 @@ subroutine ocplot2(ndx,pltax,filename,maptop,axarr,graphopt,form,ceq) !------------------- ! axis without wildcard statevar=pltax(notanp) -! call get_state_var_value(statevar,value,encoded,curceq) call meq_get_state_varorfun_value(statevar,value,& - encoded,curceq) + encoded1,curceq) if(gx%bmperr.ne.0) then write(*,212)'Skipping this point 3: ',statevar,& curceq%tpval(1),nv,0 @@ -4170,9 +4213,8 @@ subroutine ocplot2(ndx,pltax,filename,maptop,axarr,graphopt,form,ceq) if(wildcard) then ! this cannot be a state variable derivative ! write(*,*)'Getting a wildcard value 2: ',nr,statevar(1:20) - call get_many_svar(statevar,yyy,nzp,np,encoded,curceq) + call get_many_svar(statevar,yyy,nzp,np,encoded2,curceq) if(gx%bmperr.ne.0) goto 1000 -! write(*,*)'Line with ',np,' state variables' ! save one non-zero value per line, 3 lines ic=0 do jj=1,np @@ -4196,7 +4238,7 @@ subroutine ocplot2(ndx,pltax,filename,maptop,axarr,graphopt,form,ceq) !---------------------------------- np=1 call meq_get_state_varorfun_value(statevar,& - value,encoded,curceq) + value,encoded1,curceq) if(gx%bmperr.ne.0) then write(*,212)'Skipping point 4: ',statevar(1:10),& curceq%tpval(1),nv,0 @@ -4311,6 +4353,7 @@ subroutine ocplot2(ndx,pltax,filename,maptop,axarr,graphopt,form,ceq) ! write(*,*)'Extracted values: ',nrv goto 800 endif +!============================================================ ! remove columns that are only zeroes ! write(*,*)'Now remove colums with just zeros',nv,nrv ! read(*,17)ch1 @@ -4337,6 +4380,8 @@ subroutine ocplot2(ndx,pltax,filename,maptop,axarr,graphopt,form,ceq) anp(jj,nnv)=anp(jj+1,nnv) enddo nonzero(jj)=nonzero(jj+1) +! also shift label + lid(jj)=lid(jj+1) enddo nnp=nnp-1 goto 660 @@ -4353,7 +4398,6 @@ subroutine ocplot2(ndx,pltax,filename,maptop,axarr,graphopt,form,ceq) goto 800 !============================================ 800 continue -! write(*,*)'In ocplot2, looking for segmentation fault 6' write(*,808)np,nv,maxanp,maxval 808 format('plot data used: ',2i7,' out of ',2i7) if(np.eq.0) then @@ -4362,6 +4406,28 @@ subroutine ocplot2(ndx,pltax,filename,maptop,axarr,graphopt,form,ceq) goto 1000 endif !------------------------------------------------------------ +! copy from lineheader to lid, each item separated by a space +! allocate(lid(np)) +! at present I have no idea what is in the lines ... just set numbers +! kk=1 +! do i=1,np +! call wriint(lineheader,kk,i) +! kk=kk+1 +! enddo +! kk=0 +! do i=1,np +! call getext(lineheader,kk,1,lid(i),'x ',lhpos) +! enddo + if(.not.allocated(lid)) then + if(np.gt.1) then +! lid should always be allocated if np>1, but ... one never knows + allocate(lid(np)) + do i=1,np + lid(i)='unknown ' + enddo + endif + endif +!------------------------------------------------------------ ! gnuplot output, first the data file if(np+1.gt.maxval) then write(*,*)'To many points to plot: ',maxval @@ -4370,10 +4436,19 @@ subroutine ocplot2(ndx,pltax,filename,maptop,axarr,graphopt,form,ceq) kk=len_trim(filename) pfd=filename(1:kk)//'.'//'dat ' open(21,file=pfd,access='sequential',status='unknown') - write(21,810)(i,i=1,np+1) -810 format('# Open Calphad output for GNUPLOT'/'#',i7,(1000i14)) + if(np.gt.1) then + write(21,810)(lid(i)(1:12),i=1,np) +810 format('# Open Calphad output for GNUPLOT'/'# Indx Indep.var. ',& + 1000(a12,2x)) + else + write(21,810)'Depend. var.' + endif +!------------- +! NOTE OC does not generate a new line for phase changes that are not +! invariant equilibria. Maybe that should be changed. The list of +! stable phase is not correct write(21,811)phaseline(1)(1:len_trim(phaseline(1))) -811 format('# Line 1, with these stable phase:'/'# ',a) +811 format('# Line 1, with these stable phases at the end:'/'# ',a) ! if anpax=1 then we must put the first colum after the colon in gnuplot ksep=2 do nv=1,nrv @@ -4401,24 +4476,22 @@ subroutine ocplot2(ndx,pltax,filename,maptop,axarr,graphopt,form,ceq) endif enddo ! finish the data file with some comments how to plot it manually -! anpax=1 specifies the single value axis after the colon if(anpax.eq.2) then +! anpax=2 specifies the single value axis before the colon write(21,830) +830 format('# plot "ocgnu.dat" using 2:3 with lines lt 1,',& + ' "" using 2:4 with lines lt 1, ...'/'# set term postscript'/& + '# set output "ocg.ps"'/'# plot ... '/'# ps2pdf ocg.ps') else +! anpax=1 specifies the single value axis after the colon write(21,831) +831 format('# plot "ocgnu.dat" using 2:1 with lines lt 1,',& + ' "" using 3:1 with lines lt 1, ...'/'# set term postscript'/& + '# set output "ocg.ps"'/'# plot ... '/'# ps2pdf ocg.ps') endif ! now I plot all lines with broad black lines (should be lt 7 ...) -! the linetype 16 (lt 16) was the most black I could find .... -! 'set linetype 1 lc rgb "black" lw 2 pt 11' -! This caused trouble on GNUPLOT 4.0 .... ! these format statements are comments written at the end of the dat file -830 format('# plot "ocgnu.dat" using 2:3 with lines lt 1,',& - ' "" using 2:4 with lines lt 1, ...'/'# set term postscript'/& - '# set output "ocg.ps"'/'# plot ... '/'# ps2pdf ocg.ps') ! -831 format('# plot "ocgnu.dat" using 2:1 with lines lt 1,',& - ' "" using 3:1 with lines lt 1, ...'/'# set term postscript'/& - '# set output "ocg.ps"'/'# plot ... '/'# ps2pdf ocg.ps') close(21) write(*,*)'Gnuplot data file : ',pfd(1:kk+4) !---------------------------------------------------------------------- @@ -4428,89 +4501,94 @@ subroutine ocplot2(ndx,pltax,filename,maptop,axarr,graphopt,form,ceq) pfc=filename(1:kk)//'.'//'plt ' kkk=kk+4 open(21,file=pfc,access='sequential',status='unknown') - if(form(1:1).eq.'P') then + if(pform(1:1).eq.'P') then pfh=filename(1:kk)//'.'//'ps ' write(21,850)pfh(1:len_trim(pfh)) 850 format('set terminal postscript'/'set output "',a,'"') + elseif(pform(1:1).eq.'G') then + pfh=filename(1:kk)//'.'//'gif ' + write(21,851)pfh(1:len_trim(pfh)) +851 format('set terminal gif'/'set output "',a,'"') + endif +! this part is independent of which axis is a single value +!------------------ some GNUPLOT colors: +! colors are black: #000000, red: #ff000, web-green: #00C000, web-blue: #0080FF +! dark-yellow: #C8C800, royal-blue: #4169E1, steel-blue #306080, +! gray: #C0C0C0, cyan: #00FFFF, orchid4: #804080, chartreuse: 7CFF40 + write(21,860)title(1:len_trim(title)),pltax(1)(1:len_trim(pltax(1))),& + pltax(2)(1:len_trim(pltax(2))),graphopt%labelkey +860 format('set title "',a,'"'/& + 'set xlabel "',a,'"'/'set ylabel "',a,'"'/& + 'set key ',a/& + 'set style line 1 lt 2 lc rgb "#000000" lw 2'/& + 'set style line 2 lt 2 lc rgb "#FF0000" lw 2'/& + 'set style line 3 lt 2 lc rgb "#00C000" lw 2'/& + 'set style line 4 lt 2 lc rgb "#0080FF" lw 2'/& + 'set style line 5 lt 2 lc rgb "#C8C800" lw 2'/& + 'set style line 6 lt 2 lc rgb "#4169E1" lw 2'/& + 'set style line 7 lt 2 lc rgb "#C0C0C0" lw 2'/& + 'set style line 8 lt 2 lc rgb "#00FFFF" lw 2'/& + 'set style line 9 lt 2 lc rgb "#804080" lw 2'/& + 'set style line 10 lt 2 lc rgb "#7CFF40" lw 2') +! + if(graphopt%rangedefaults(1).ne.0) then +! user defined ranges for x axis + write(21,870)'x',graphopt%plotmin(1),graphopt%plotmax(1) +870 format('set ',a1,'range [',1pe12.4,':',1pe12.4,'] ') + endif + if(graphopt%rangedefaults(2).ne.0) then +! user defined ranges for y axis + write(21,870)'y',graphopt%plotmin(2),graphopt%plotmax(2) endif !---------------------- + backslash=',\' + lcolor=1 +! write(*,*)'backslash "',backslash,'" ' if(anpax.eq.2) then ! anpax=2 means the single valued axis is colum 2 and possibly multiple ! values in column 3 and higher - write(21,870)title(1:len_trim(title)),pltax(1)(1:len_trim(pltax(1))),& - pltax(2)(1:len_trim(pltax(2))) -870 format('set title "',a,'"'/& - 'set xlabel "',a,'"'/'set ylabel "',a,'"'/& - 'set linetype 1 lc rgb "black" lw 1 pt 11') - if(graphopt%rangedefaults(1).ne.0) then -! user defined ranges for x axis - write(21,930)'x',graphopt%plotmin(1),graphopt%plotmax(1) - endif - if(graphopt%rangedefaults(2).ne.0) then -! user defined ranges for y axis - write(21,930)'y',graphopt%plotmin(2),graphopt%plotmax(2) - endif ! this is the multiple plot, file name only given once!! ! last line tuple on a separate format statement, if np>2 - if(np.eq.2) then - write(21,892)pfd(1:kkk) -892 format('plot "',a,'" using 2:3 with lines lt 1,',& - '"" using 2:4 with lines lt 1') +! np is number of columns + if(np.eq.1) then + write(21,880)pfd(1:kkk),lcolor,' ',' ' else - write(21,890,advance='no')pfd(1:kkk),(i,i=3,np+1) - write(21,891,advance='no')np+2 -890 format('plot "',a,'" using 2:',i3,' with lines lt 1',& - 999(',"" using 2:',i3,' with lines lt 1')) -891 format(i3,' with lines lt 1'/) -! write(21,970) -! this is the first attempt with file name given for each line pair -! write(21,890,advance='no')(pfd(1:kkk),i,i=3,np+2) -!890 format('plot "',a,'" using 2:',i3,' with lines lt 1,',& -! 999('"',a,'" using 2:',i3,' with lines lt 1,')) -! write(21,970) + write(21,880)pfd(1:kkk),lcolor,lid(1)(1:len_trim(lid(1))),backslash +880 format('plot "',a,'" using 2:3 with lines ls ',i2,' title "'a,'"',a) endif + do i=2,np-1 + lcolor=lcolor+1 + if(lcolor.gt.10) lcolor=1 + write(21,882)i+2,lcolor,lid(i)(1:len_trim(lid(i))),backslash +882 format('"" using 2:',i3,' with lines ls ',i2,' title "'a,'"',a) + enddo + lcolor=lcolor+1 + if(lcolor.gt.10) lcolor=1 + if(np.ge.2) write(21,882)np+2,lcolor,lid(np)(1:len_trim(lid(np))),' ' +! old plot format +!890 format('plot "',a,'" using 2:',i3,' with lines ls ',2,& +! ' title ",a,'" ',& +! 999(',"" using 2:',i3,' with lines ls ',i2,' title ",a,'" ') else -! If I finish with 'lines' without a "," then OK. -! If I add a ; on same line OK, trying the latter - write(21,910)title(1:len_trim(title)),pltax(2)(1:len_trim(pltax(2))),& - pltax(1)(1:len_trim(pltax(1))) -! Note the xrange/yrange commands are comments -910 format('set title "',a,'"'/& - 'set ylabel "',a,'"'/'set xlabel "',a,'"'/& - 'set linetype 1 lc rgb "black" lw 1 pt 11'/& - '# set xrange [0:1]'/'# set yrange [300:3000]') - if(graphopt%rangedefaults(1).ne.0) then -! user defined ranges for x axis - write(21,930)'x',graphopt%plotmin(1),graphopt%plotmax(1) -930 format('set ',a1,'range [',1pe12.4,':',1pe12.4,'] ') - endif - if(graphopt%rangedefaults(2).ne.0) then -! user defined ranges for y axis - write(21,930)'y',graphopt%plotmin(2),graphopt%plotmax(2) - endif +! anpax=2 means the single valued axis is colum 2 ! this writes the file name only once and last line separate if np>2 - if(np.eq.2) then - write(21,952)pfd(1:kkk) -952 format('plot "',a,'" using 3:2 with lines lt 1,',& - '"" using 4:2 with lines lt 1') + if(np.eq.1) then + write(21,890)pfd(1:kkk),lcolor,' ',' ' else - write(21,950,advance='no')pfd(1:kkk),(i,i=3,np+1) - write(21,951,advance='no')np+2 -950 format('plot "',a,'" using ',i3,':2 with lines lt 1',& - 999(',"" using ',i3,':2 with lines lt 1')) -951 format(i3,':2 with lines lt 1'/) -! write(21,970) -!970 format(';') -! this was the old way of writing the file name for each line -! write(21,950,advance='no')(pfd(1:kkk),i,i=3,np+2) -!950 format('plot "',a,'" using ',i3,':2 with lines lt 1,',& -! 999('"',a,'" using ',i3,':2 with lines lt 1,')) -! write(21,970) -!970 format(';') + write(21,890)pfd(1:kkk),lcolor,lid(1)(1:len_trim(lid(1))),backslash +890 format('plot "',a,'" using 3:2 with lines ls ',i2,' title "',a,'"',a) endif + lcolor=2 + do i=2,np-1 + write(21,892)i+2,lcolor,lid(i)(1:len_trim(lid(i))),backslash +892 format('"" using ',i3,':2 with lines ls ',i2,' title "'a,'"',a) + lcolor=lcolor+1 + if(lcolor.gt.10) lcolor=1 + enddo + if(np.ge.2) write(21,892)np+2,lcolor,lid(np)(1:len_trim(lid(np))),' ' endif - if(form(1:1).ne.'P') then -! if(form(1:1).eq.' ') then +! if(pform(1:1).ne.'P') then + if(pform(1:1).eq.' ') then ! if not hardcopy pause gnuplot. Mouse means clicking in the graphics window ! will close it. I would like to have an option to keep the graphics window... write(21,990) @@ -4522,13 +4600,15 @@ subroutine ocplot2(ndx,pltax,filename,maptop,axarr,graphopt,form,ceq) ! execute the GNUPLOT command file ! gnuplotline='gnuplot '//pfc(1:kkk)//' ' +! if gnuplot cannot be started with gnuplot give normal path ... +! gnuplotline='"c:\program files\gnuplot\bin\wgnuplot.exe" '//pfc(1:kkk)//' ' k3=len_trim(gnuplotline)+1 write(*,*)'Gnuplot command file: ',pfc(1:kk+4) - if(form(1:1).eq.'P') then - write(*,*)'Gnuplot postscript file: ',pfh(1:kk+4) + if(pform(1:1).ne.' ') then + write(*,*)'Graphics output file: ',pfh(1:kk+4) endif call system(gnuplotline(1:k3)) -! deallocate +! deallocate, not really needed for local arrays deallocate(anp) deallocate(xax) deallocate(linesep) @@ -4637,7 +4717,7 @@ subroutine step_separate(maptop,noofaxis,axarr,starteq) ! this call calculates the value of the axis condition with default composition call state_variable_val(svr,val,ceq) if(gx%bmperr.ne.0) goto 500 - call phase_name(entphcs(itup),name) + call get_phasetup_name(entphcs(itup),name) ! axis variable is composition, skip hases with no variance call get_phase_variance(entphcs(itup)%phase,nv) if(nv.eq.0) then @@ -4703,6 +4783,15 @@ subroutine step_separate(maptop,noofaxis,axarr,starteq) write(*,*)'Error at first equilibrium: ',gx%bmperr,& mapline%axandir endif +! if step turn on grid minimizer + write(*,*)'Turn on grid minimizer' + if(maptop%number_ofaxis.eq.1) then + call calceq7(mode,meqrec,mapfix,ceq) + if(gx%bmperr.ne.0) then + write(kou,*)'Failed calling grid minimizer',gx%bmperr + gx%bmperr=0 + endif + endif ! reset error code and take another line write(*,*)'Generating mapline%meqrec failed: ',gx%bmperr gx%bmperr=0; goto 333 diff --git a/userif/pmon6.F90 b/userif/pmon6.F90 index ef977c5..079b9c5 100644 --- a/userif/pmon6.F90 +++ b/userif/pmon6.F90 @@ -22,10 +22,9 @@ MODULE cmon1oc !------------------------------------------------------------------ ! !************************************ -! first version of a command monitor for OC +! command line monitor for OC version 3 !************************************ ! -! currently the step/map/plot is included in liboceq use ocsmp ! use liboceq ! @@ -44,10 +43,10 @@ subroutine oc_command_monitor(version,linkdate) implicit none ! ! various symbols and texts - character symbol*24,name1*24,name2*24,name3*24,line*80,model*72 - integer, parameter :: ocmonversion=20 + character symbol*24,name1*24,name2*24,name3*24,line*80,model*72,chshort + integer, parameter :: ocmonversion=21 ! element symbol and array of element symbols - character elsym*2,ellist(20)*2 + character elsym*2,ellist(maxel)*2 ! more texts for various purposes character text*72,string*256,chc*3,phtype*1,ch1*1,defansw*16,selection*27 character axplot(3)*24,axplotdef(3)*24 @@ -90,7 +89,7 @@ subroutine oc_command_monitor(version,linkdate) ! used for element data and R*T double precision h298,s298,rgast ! temporary reals - double precision xxx,xxy + double precision xxx,xxy,totam ! array for constituent in endmember and interaction, parameter property type integer endm(10),lint(2,3),typty ! input data for grid minimizer @@ -99,8 +98,8 @@ subroutine oc_command_monitor(version,linkdate) integer, dimension(maxel) :: iphl,icsl,nyphl ! selected kommand and subcommands integer kom,kom1,kom2,kom3,kom4 -! selected output mode for results and the default - integer listresopt,lrodef +! selected output mode for results and the default, list output unit lut + integer listresopt,lrodef,lut,afo ! integers used for elements, phases, composition sets, equilibria, defaults integer iel,iph,ics,ieq,idef !------------------- @@ -109,7 +108,7 @@ subroutine oc_command_monitor(version,linkdate) ! more temporary integers integer jp,kl,svss,language,last ! and more temporary integers - integer ll,lokcs,lokfil,lokph,lokres,loksp,lrot,maxax + integer ll,lokcs,lokph,lokres,loksp,lrot,maxax ! and more temporary integers integer minimizer,mode,ndl,neqdef,noelx,nofc,nopl,nops,nsl,nv,nystat ! temporary matrix @@ -175,15 +174,15 @@ subroutine oc_command_monitor(version,linkdate) ! subcommands to LIST character (len=16), dimension(nclist) :: clist=& ['DATA ','SHORT ','PHASE ',& - 'STATE_VARIABLES ','BIBLIOGRAPHY ','PARAMETER_IDENTI',& + 'STATE_VARIABLES ','BIBLIOGRAPHY ','MODEL_PARAM_ID ',& 'AXIS ','TPFUN_SYMBOLS ','QUIT ',& - ' ','EQUILIBRIA ','RESULTS ',& + 'PARAMETER ','EQUILIBRIA ','RESULTS ',& 'CONDITIONS ','SYMBOLS ','LINE_EQUILIBRIA '] !------------------- ! subsubcommands to LIST DATA character (len=16), dimension(nlform) :: llform=& ['SCREEN ','TDB ','MACRO ',& - 'LATEX ',' ',' '] + 'LATEX ','ODB ',' '] !------------------- ! subsubcommands to LIST PHASE character (len=16), dimension(nclph) :: clph=& @@ -214,9 +213,10 @@ subroutine oc_command_monitor(version,linkdate) 'DIRECT ',' ',' '] !------------------- ! subcommands to SAVE +! note SAVE TDB, MACRO, LATEX part of LIST DATA !! character (len=16), dimension(ncsave) :: csave=& - ['UNFORMATTED ','TDB ','MACRO ',& - 'DIRECT ','LATEX ','QUIT '] + ['UNFORMATTED ',' ',' ',& + 'DIRECT ',' ','QUIT '] !------------------- ! subcommands to AMEND first level ! many of these should be subcommands to PHASE @@ -260,7 +260,7 @@ subroutine oc_command_monitor(version,linkdate) character (len=16), dimension(nsetphbits) :: csetphbits=& ['FCC_PERMUTATIONS','BCC_PERMUTATIONS','IONIC_LIQUID_MDL',& 'AQUEOUS_MODEL ','QUASICHEMICAL ','FCC_CVM_TETRADRN',& - 'FACT_QUASICHEMCL','NO_AUTO_COMP_SET',' ',& + 'FACT_QUASICHEMCL','NO_AUTO_COMP_SET','QUIT ',& ' ',' ',' ',& ' ',' ',' '] ! 123456789.123456---123456789.123456---123456789.123456 @@ -288,10 +288,10 @@ subroutine oc_command_monitor(version,linkdate) !------------------- ! subcommands to PLOT OPTIONS character (len=16), dimension(nplt) :: cplot=& - ['PLOT ','XRANGE ','YRANGE ',& + ['RENDER ','XRANGE ','YRANGE ',& 'XTEXT ','YTEXT ','TITLE ',& - 'TERMINAL_FORMAT ','OUTPUT_FILE ','GIBBS_TRIANGLE ',& - 'QUIT ',' ',' '] + 'GRAPHICS_FORMAT ','OUTPUT_FILE ','GIBBS_TRIANGLE ',& + 'QUIT ','POSITION_OF_KEYS',' '] !------------------- ! 123456789.123456---123456789.123456---123456789.123456 ! minimizers @@ -307,7 +307,7 @@ subroutine oc_command_monitor(version,linkdate) write(kou,10)version,linkdate(1:len_trim(linkdate)),ocmonversion,& gtpversion,hmsversion,smpversion 10 format(/'Open Calphad (OC) software version ',a,' linked ',a,/& - 'with command line monitor ',i2//& + 'with command line monitor version ',i2//& 'This program is available with a GNU General Public License.'/& 'It includes the General Thermodynamic Package, version ',A/& "and Hillert's equilibrium calculation algorithm version ",A/& @@ -325,15 +325,20 @@ subroutine oc_command_monitor(version,linkdate) graphopt%dfltmin=zero graphopt%plotmax=one graphopt%dfltmax=one + graphopt%labelkey='top right' plotfile='ocgnu' plotform=' ' +! default list unit + optionsset%lut=kou +! default for list short + chshort='A' ! initiate on-line help call init_help('ochelp.hlp ') -! set default minimizer +! set default minimizer, 2 is matsmin, 1 does not work ... minimizer=2 -! by default no stop on error and no nogfile +! by default no stop on error and no logfile stop_on_error=.false. - lokfil=0 + logfil=0 ! ! in init_gtp the first equilibrium record is created and ! firsteq has been set to that @@ -373,7 +378,7 @@ subroutine oc_command_monitor(version,linkdate) 100 continue if(gx%bmperr.ne.0) goto 990 if(buperr.ne.0) goto 990 -! turn off options set +! turn off any options set call ocmon_reset_options(optionsset) ! initiate command level for help routines call helplevel1('Initiate help level for OC') @@ -381,7 +386,7 @@ subroutine oc_command_monitor(version,linkdate) last=len(aline) aline=' ' cline=' ' - call gparc('OC2: ',aline,last,5,cline,' ',tophlp) + call gparc('OC3: ',aline,last,5,cline,' ',tophlp) jl=1 ! with empty line just prompt again if(eolch(cline,jl)) goto 100 @@ -412,10 +417,11 @@ subroutine oc_command_monitor(version,linkdate) write(kou,*)'Error reading option' buperr=0; goto 100 endif - call ocmon_set_options(option) -! nops=nops+1 -! oplist(nops)=option -! write(kou,*)'found option: ',oplist(nops) + call ocmon_set_options(option,afo,optionsset) + if(afo.ne.0) then + write(kou,*)'Please give the command again' + goto 100 + endif goto 110 else ! set "last" back one character to prepare for next call of GPARx @@ -535,8 +541,7 @@ subroutine oc_command_monitor(version,linkdate) if(ch1.eq.'Y' .or. ch1.eq.'y') then call gparc('Prefix: ',cline,last,1,prefix,' ',q1help) call gparc('Suffix: ',cline,last,1,suffix,' ',q1help) -! call add_composition_set(iph,prefix,suffix,ics,ceq) - call add_composition_set(iph,prefix,suffix,ics) + call enter_composition_set(iph,prefix,suffix,ics) if(gx%bmperr.ne.0) goto 990 ! list the number of new composition set write(kou,*)'New composition set number is ',ics @@ -601,7 +606,7 @@ subroutine oc_command_monitor(version,linkdate) END SELECT !------------------------- case(5) ! amend parameter - write(kou,*)'Not implemented yet' + write(kou,*)'Not implemented yet, only ENTER PARAMETER' !------------------------- case(6) ! amend bibliography call enter_reference_interactivly(cline,last,1,jl) @@ -658,22 +663,28 @@ subroutine oc_command_monitor(version,linkdate) kom2=submenu(cbas(kom),cline,last,ccalc,ncalc,8) SELECT CASE(kom2) CASE DEFAULT - write(kou,*)'calculate subcommand error' + write(kou,*)'No such calculate command' goto 100 !------------------------- CASE(1) ! calculate TPFUN symbols , use current values of T and P - write(kou,2011)notpf(),ceq%tpval + write(*,*)'Output unit: ',optionsset%lut +! if(optionsset%lut.ne.kou) then +! lut=optionsset%lut +! else +! lut=kou +! endif + write(lut,2011)notpf(),ceq%tpval 2011 format(/'Calculating ',i3,' functions for T,P=',F10.2,1PE15.7/& 3x,'No F',11x,'F.T',9x,'F.P',9x,'F.T.T',7x,'F.T.P',7x,'F.P.P') call cpu_time(starting) do jl=1,notpf() call eval_tpfun(jl,ceq%tpval,val,ceq%eq_tpres) if(gx%bmperr.gt.0) goto 990 - write(kou,2012)jl,val + write(lut,2012)jl,val 2012 format(I5,1x,6(1PE12.4)) enddo call cpu_time(ending) - write(kou,2013)ending-starting +! write(kou,2013)ending-starting 2013 format('CPU time used: ',1pe15.6) !--------------------------------------------------------------- case(2) ! calculate phase, _all _only_g or _g_and_dgdy, separated later @@ -692,6 +703,7 @@ subroutine oc_command_monitor(version,linkdate) ! if(kom2.le.0) goto 100 ! ph-a ph-G ph-G+dg/dy defcp=kom3 + lut=optionsset%lut SELECT CASE(kom3) !....................................................... CASE DEFAULT @@ -701,8 +713,8 @@ subroutine oc_command_monitor(version,linkdate) call calcg(iph,ics,0,lokres,ceq) if(gx%bmperr.ne.0) goto 990 parres=>ceq%phase_varres(lokres) - write(kou,2031)(rgast*parres%gval(jl,1),jl=1,4) - write(kou,2032)parres%gval(1,1)/parres%abnorm(1),parres%abnorm(1) + write(lut,2031)(rgast*parres%gval(jl,1),jl=1,4) + write(lut,2032)parres%gval(1,1)/parres%abnorm(1),parres%abnorm(1) 2031 format('G/N, dG/dT:',4(1PE16.8)) 2032 format('G/N/RT, N:',2(1PE16.8)) !....................................................... @@ -711,8 +723,8 @@ subroutine oc_command_monitor(version,linkdate) if(gx%bmperr.ne.0) goto 990 parres=>ceq%phase_varres(lokres) nofc=noconst(iph,ics,firsteq) - write(kou,2031)(rgast*parres%gval(jl,1),jl=1,4) - write(kou,2041)(rgast*parres%dgval(1,jl,1),jl=1,nofc) + write(lut,2031)(rgast*parres%gval(jl,1),jl=1,4) + write(lut,2041)(rgast*parres%dgval(1,jl,1),jl=1,nofc) 2041 format('dG/dy: ',4(1PE16.8)) !....................................................... case(3) ! calculate phase < > all @@ -735,7 +747,7 @@ subroutine oc_command_monitor(version,linkdate) ! set a phase fix and remove one condition. One must have calculated an ! equilibrium write(kou,2090) -2090 format('To calculate when a phase will appear/dissapear',& +2090 format('To calculate when a phase will appear/disappear',& ' by releasing a condition.') if(btest(ceq%status,EQNOEQCAL)) then write(kou,2095) @@ -796,24 +808,32 @@ subroutine oc_command_monitor(version,linkdate) !----------------------------------------------------------- case(6) ! calculate global grid minimum ! extract values for mass balance calculation from conditions - call extract_massbalcond(ceq%tpval,xknown,xxx,ceq) + call extract_massbalcond(ceq%tpval,xknown,totam,ceq) if(gx%bmperr.ne.0) goto 990 ! debug output -! write(*,2101)xxx,(xknown(i),i=1,noel()) +! write(*,2101)totam,(xknown(jl),jl=1,noel()) 2101 format('N&x: ',F6.3,9F8.5) ! generate grid and find the phases and constitutions for the minimum. - call global_gridmin(1,ceq%tpval,xknown,nv,iphl,icsl,aphl,nyphl,& - yarr,cmu,ceq) +! Note: global_gridmin calculates for total 1 mole of atoms, not totam +! call global_gridmin(1,ceq%tpval,totam,xknown,nv,iphl,icsl,& + call global_gridmin(1,ceq%tpval,xknown,nv,iphl,icsl,& + aphl,nyphl,yarr,cmu,ceq) if(gx%bmperr.ne.0) goto 990 - write(kou,2102)'Phases: ',nv,(iphl(jl),icsl(jl),jl=1,nv) -2102 format(a,i2,11(i4,i2)) + write(kou,2102)nv,(iphl(jl),icsl(jl),jl=1,nv) +2102 format('Stable ',i2,': ',11(i4,i2)) +! we must multiply the amount of the stable phases with totam + do jl=1,nv + call get_phase_compset(iphl(jl),icsl(jl),lokph,lokcs) + ceq%phase_varres(lokcs)%amfu=totam*ceq%phase_varres(lokcs)%amfu + enddo +!2103 format('Stable phase ',2i4,': ',a) !--------------------------------------------------------------- case(7) ! calculate symbol ! call evaluate_all_svfun(kou,ceq) ! to calculate derivatives this must be in the minimizer module call gparcd('Name ',cline,last,1,name1,'*',q1help) if(name1(1:1).eq.'*') then - call meq_evaluate_all_svfun(kou,ceq) + call meq_evaluate_all_svfun(lut,ceq) else call capson(name1) call find_svfun(name1,istv,ceq) @@ -821,6 +841,7 @@ subroutine oc_command_monitor(version,linkdate) mode=1 actual_arg=' ' xxx=meq_evaluate_svfun(istv,actual_arg,mode,ceq) + if(gx%bmperr.ne.0) goto 990 write(*,2047)name1(1:len_trim(name1)),xxx 2047 format(a,'= ',1pe16.8) endif @@ -888,63 +909,56 @@ subroutine oc_command_monitor(version,linkdate) endif !................................................................. case(3) ! set status phase (ENTERED, FIX, DORMANT, SUSPEND or HIDDEN) - call gparc('Phase name: ',cline,last,1,name1,' ',q1help) - call find_phase_by_name(name1,iph,ics) - if(gx%bmperr.ne.0) then - if(name1(1:2).eq.'* ') then - iph=-1 - gx%bmperr=0 - else - goto 990 - endif +! Now allow multiple phase names and *S, *D and *E +! call gparc('Phase name(s): ',cline,last,1,name1,' ',q1help) +! argument 5 means whole input line + call gparc('Phase name(s): ',cline,last,5,line,'=',q1help) + string=line +3017 continue + ll=index(string,'=') + if(ll.eq.0) then + call gparc('More phase name(s): ',cline,last,5,line,'=',q1help) + string(len_trim(string)+2:)=line + goto 3017 + endif +3018 continue +! exttract first letter after = (if any) + jl=ll + call getext(string,jl,1,name1,' ',iph) + ch1=name1(1:1) +! if user has given "=e 0" then keep the amount is cline + cline=string(jl:) + string(ll:)=' ' +! write(*,*)'s1: ',jl,cline(1:len_trim(cline)) + if(ch1.eq.' ') then +! if ll==1 then input was finished by equal sign, ask for status + call gparcd(& + 'New status S(uspend), D(ormant), E(ntered) or F(ixed)?',& + cline,last,1,name1,'E',q1help) + ch1=name1(1:1) else - jl=get_phase_status(iph,ics,text,i1,xxx,ceq) - if(gx%bmperr.ne.0) goto 100 - if(xxx.ge.zero) then - write(kou,3046)text(1:i1),xxx -3046 format('Current status is ',a,' with ',1pe15.6,& - ' formula units.') - else - write(kou,3047)text(1:i1) -3047 format('Current status is ',a) - endif + last=0 endif - call gparcd(& - 'Suspend, Dormant, Entered, Fixed, Hidden or Not hidden?',& - cline,last,1,ch1,'SUSPEND',q1help) nystat=99 call capson(ch1) ! new values of status ?? - if(ch1.eq.'E') nystat=phentered if(ch1.eq.'S') nystat=phsus if(ch1.eq.'D') nystat=phdorm + if(ch1.eq.'E') nystat=phentered if(ch1.eq.'F') nystat=phfixed - if(ch1.eq.'H') nystat=phhidden +! if(ch1.eq.'H') nystat=phhidden ! no longer available if(ch1.eq.'N') nystat=5 if(nystat.eq.99) then write(kou,*)'No such status' goto 100 endif xxx=zero +! write(*,*)'s2: ',last,cline(1:len_trim(cline)) if(nystat.eq.phentered .or. nystat.eq.phfixed) then call gparrd('Amount: ',cline,last,xxx,zero,q1help) endif - call change_phase_status(iph,ics,nystat,xxx,ceq) + call change_many_phase_status(string,nystat,xxx,ceq) if(gx%bmperr.ne.0) goto 100 - if(iph.gt.0) then - jl=get_phase_status(iph,ics,text,i1,xxy,ceq) - if(gx%bmperr.ne.0) goto 100 - if(xxy.ge.zero) then - write(kou,3048)text(1:i1),xxy -3048 format('New status is ',a,' with ',1pe15.6,& - ' formula units.') - else - write(kou,3049)text(1:i1) -3049 format('New status is ',a) - endif - else - write(kou,*)'New status set for all phases' - endif !................................................................. CASE(4) ! set status constituent write(kou,*)'Not implemented yet' @@ -958,7 +972,7 @@ subroutine oc_command_monitor(version,linkdate) !----------------------------------------------------------- case(3) ! set ADVANCED name1='advanced command' - kom3=submenu(name1,cline,last,cadv,ncadv,1) + kom3=submenu(name1,cline,last,cadv,ncadv,2) select case(kom3) !................................................................. CASE DEFAULT @@ -1012,12 +1026,12 @@ subroutine oc_command_monitor(version,linkdate) call macend(cline,last,logok) !----------------------------------------------------------- case(6) ! set REFERENCE_STATE -! write(kou,*)'Reference states not implemented yet' call gparc('Component name: ',cline,last,1,name1,' ',q1help) call find_component_by_name(name1,iel,ceq) if(gx%bmperr.ne.0) goto 100 - call gparc('Reference phase: ',cline,last,1,name1,' ',q1help) + call gparc('Reference phase: ',cline,last,1,name1,'SER ',q1help) if(name1(1:4).eq.'SER ') then + write(kou,*)'Reference state is stable phase at 298.15 K and 1 bar' ! this means no reference phase, SER is at 298.15K and 1 bar iph=-1 else @@ -1085,8 +1099,11 @@ subroutine oc_command_monitor(version,linkdate) if(gx%bmperr.ne.0) goto 100 if(xxx.ge.zero) then write(kou,3046)text(1:i1),xxx +3046 format('Current status is ',a,' with ',1pe15.6,& + ' formula units.') else write(kou,3047)text(1:i1) +3047 format('Current status is ',a) endif endif call gparcd(& @@ -1116,18 +1133,23 @@ subroutine oc_command_monitor(version,linkdate) if(gx%bmperr.ne.0) goto 100 if(xxy.ge.zero) then write(kou,3048)text(1:i1),xxy +3048 format('New status is ',a,' with ',1pe15.6,& + ' formula units.') else write(kou,3049)text(1:i1) +3049 format('New status is ',a) endif else write(kou,*)'New status set for all phases' endif ! end copied from 3045 !............................................................ - case(3:4) !set phase default constitution wildcard allod, also AMOUNT + case(3:4) !set phase default_constitution wildcard allod, also AMOUNT + write(*,*)'SET PHASE AMOUNT or DEFAULT_CONST',kom3,iph,ics if(kom3.eq.3) then -! set phase default constituntion - call set_default_constitution(iph,ics,ceq) +! set default constituntion of phase +! call set_default_constitution(iph,ics,ceq) + call ask_default_constitution(cline,last,iph,ics,ceq) else ! set phase amount call gparrd('Amount: ',cline,last,xxx,zero,q1help) @@ -1141,7 +1163,7 @@ subroutine oc_command_monitor(version,linkdate) goto 100 endif call get_phase_record(iph,lokph) - kom4=submenu('Set which bit?',cline,last,csetphbits,nsetphbits,8) + kom4=submenu('Set which bit?',cline,last,csetphbits,nsetphbits,9) SELECT CASE(kom4) CASE DEFAULT write(kou,*)'Set phase bit subcommand error' @@ -1154,20 +1176,26 @@ subroutine oc_command_monitor(version,linkdate) case(2) ! BCC_PERMUTATIONS BORD if(check_minimal_ford(lokph)) goto 100 call set_phase_status_bit(lokph,PHBORD) - case(3) ! IONIC_LIQUID_MDL + case(3) ! IONIC_LIQUID_MDL this may require tests and +! other bits changed .. call set_phase_status_bit(lokph,PHIONLIQ) case(4) ! AQUEOUS_MODEL - call set_phase_status_bit(lokph,PHAQ1) + write(*,*)'Not implemented yet' +! call set_phase_status_bit(lokph,PHAQ1) case(5) ! QUASICHEMICAL - call set_phase_status_bit(lokph,PHQCE) + write(*,*)'Not implemented yet' +! call set_phase_status_bit(lokph,PHQCE) case(6) ! FCC_CVM_TETRADRN - call set_phase_status_bit(lokph,PHCVMCE) + write(*,*)'Not implemented yet' +! call set_phase_status_bit(lokph,PHCVMCE) case(7) ! FACT_QUASICHEMCL - call set_phase_status_bit(lokph,PHFACTCE) + write(*,*)'Not implemented yet' +! call set_phase_status_bit(lokph,PHFACTCE) case(8) ! NO_AUTO_COMP_SET, not allod to create compsets automatic call set_phase_status_bit(lokph,PHNOCS) - case(9) ! ELASTIC_MODEL_A -! set by amend?? + case(9) ! QUIT +! just quit + write(kou,*)'No bit changed' continue end SELECT !............................................................ @@ -1265,8 +1293,10 @@ subroutine oc_command_monitor(version,linkdate) do i2=iax,noofaxis axarr(i2)=axarr(i2+1) enddo - noofaxis=noofaxis-1 - write(kou,*)'One axis removed' + if(noofaxis.gt.1) then + noofaxis=noofaxis-1 + write(kou,*)'One axis removed' + endif goto 100 else ! add or change axis variable i1=len_trim(text) @@ -1386,14 +1416,23 @@ subroutine oc_command_monitor(version,linkdate) call set_input_amounts(cline,last,ceq) !------------------------- case(16) ! SET VERBOSE -! This sets permanent verbose for all commands. If on turn it off - write(kou,*)'Not implemented yet' +! This toggles verbose for all commands. If on turn it off + if(btest(globaldata%status,GSVERBOSE)) then + globaldata%status=ibclr(globaldata%status,GSVERBOSE) + else + globaldata%status=ibset(globaldata%status,GSVERBOSE) + endif + if(ocv()) then + write(kou,*)'Verbose mode on' + else + write(kou,*)'Verbose mode off' + endif !------------------------- ! the current set of condition sill be used as start equilibrium for map/step ! Calculate the equilibrium and ask for a direction. case(17) ! SET AS_START_EQUILIBRIUM if(noofaxis.lt.2) then - write(kou,*)'You must set two axis forst' + write(kou,*)'You must set two axis first' goto 100 endif call calceq2(1,ceq) @@ -1423,15 +1462,35 @@ subroutine oc_command_monitor(version,linkdate) write(*,*)'A copy of current equilibrium linked as start eqilibrium' !------------------------- case(18) ! SET BIT (all kinds of bits) just global implemented - write(*,*)'Only global status bits can be set' - call gpari('Bit (from 0):',cline,last,ll,-1,q1help) - if(ll.lt.0 .or. ll.gt.31) goto 100 - if(testb(globaldata%status,ll)) then - globaldata%status=ibclr(globaldata%status,ll) - write(*,*)'Bit cleared' + write(kou,3710)globaldata%status +3710 format('Toggles global status word ',z8,' (only for experts): '/& + 'Bit Used for'/' 0 set if user is a beginner'/& + ' 1 set if occational user'/' 2 set if expert'/& + ' 3 set if gridminimizer not allowed'/& + ' 4 set if gridminimizer is not allowed to merge comp.sets.'/& + ' 5 set if these is no data'/' 6 set if there is no phases'/& + ' 7 set if not allowed to create comp.sets automatically'/& + ' 8 set if not allowed to delete comp.sets automatically'/& + ' 9 set if data changed since last save'/& + '10 set if verbose'/'11 explicit setting of verbose'/& + '12 set if very silent'/& + '13 set if no cleanup after an equilibrium calculation') + call gparid('Toggle bit (from 0-31, -1 quits):',& + cline,last,ll,-1,q1help) + if(ll.lt.0 .or. ll.gt.31) then + write(kou,*)'No bit changed' + elseif(btest(globaldata%status,2) .or. ll.le.2) then +! user must have expert bit set to change any other bit than the user type bit + if(btest(globaldata%status,ll)) then + globaldata%status=ibclr(globaldata%status,ll) + write(*,3711)'cleared',globaldata%status +3711 format('Bit ',a,', new value: ',z8) + else + globaldata%status=ibset(globaldata%status,ll) + write(*,3711)'set',globaldata%status + endif else - globaldata%status=ibset(globaldata%status,ll) - write(*,*)'Bit set' + write(kou,*)'You must have expert status to set this!' endif END SELECT !================================================================= @@ -1507,7 +1566,7 @@ subroutine oc_command_monitor(version,linkdate) if(buperr.ne.0) goto 990 call gparr('Element S298: ',cline,last,s298,one,q1help) if(buperr.ne.0) goto 990 - call new_element(elsym,name1,name2,mass,h298,s298) + call enter_element(elsym,name1,name2,mass,h298,s298) if(gx%bmperr.ne.0) goto 990 !--------------------------------------------------------------- case(3) ! enter species @@ -1519,7 +1578,7 @@ subroutine oc_command_monitor(version,linkdate) call gparc('Species stoichiometry: ',cline,last,1,name2,' ',q1help) call decode_stoik(name2,noelx,ellist,stoik) if(gx%bmperr.ne.0) goto 990 - call new_species(name1,noelx,ellist,stoik) + call enter_species(name1,noelx,ellist,stoik) if(gx%bmperr.ne.0) goto 990 !--------------------------------------------------------------- case(4) ! enter phase @@ -1550,8 +1609,8 @@ subroutine oc_command_monitor(version,linkdate) if(nsl.le.0) then write(kou,*)'At least one configurational space!!!' goto 100 - elseif(nsl.gt.10) then - write(kou,*)'Maximum 10 sublattices' + elseif(nsl.ge.10) then + write(kou,*)'Maximum 9 sublattices' goto 100 endif icon=0 @@ -1610,11 +1669,11 @@ subroutine oc_command_monitor(version,linkdate) buperr=0 4049 continue enddo sloop - call new_phase(name1,nsl,knr,const,sites,model,phtype) + call enter_phase(name1,nsl,knr,const,sites,model,phtype) if(gx%bmperr.ne.0) goto 990 !--------------------------------------------------------------- case(5) ! enter parameter is always allowed - call enter_parameter_interactivly(cline,last) + call enter_parameter_interactivly(cline,last,0) if(gx%bmperr.ne.0) goto 990 !--------------------------------------------------------------- case(6) ! enter bibliography @@ -1682,6 +1741,7 @@ subroutine oc_command_monitor(version,linkdate) CASE(6) kom2=submenu(cbas(kom),cline,last,clist,nclist,12) if(kom2.le.0) goto 100 + lut=optionsset%lut SELECT CASE(kom2) !----------------------------------------------------------- CASE DEFAULT @@ -1689,22 +1749,48 @@ subroutine oc_command_monitor(version,linkdate) goto 100 !----------------------------------------------------------- case(1) ! list data for everything, not dependent on equilibrium!! -! NOTE output file set by /output= +! NOTE output file for SCREEN can be set by /output= +! LIST DATA SCREEN/TDB/MACRO/LaTeX kom3=submenu('Output format?',cline,last,llform,nlform,1) if(kom.gt.0) then - call list_many_formats(kom3,kou) + call list_many_formats(cline,last,kom3,kou) else write(kou,*)'Unknown format' endif !----------------------------------------------------------- case(2) ! list short with status bits - write(kou,6022)ceq%eqname,globaldata%rgasuser,& + call gparcd('Option ',cline,last,1,ch1,chshort,q1help) + call capson(ch1) + write(lut,6022)ceq%eqname,globaldata%rgasuser,& globaldata%pnorm,globaldata%status 6022 format('Equilibrium name',9x,'Gas constant Pressure norm',& 22x,'Status'/1x,a,1pe12.4,2x,1pe12.4,20x,z8) - call list_all_elements(kou) - call list_all_species(kou) - call list_all_phases(kou,ceq) +! options are + if(ch1.eq.'A') then +! A all + chshort='A' + call list_all_elements(lut) + call list_all_species(lut) + call list_all_phases(lut,ceq) + elseif(ch1.eq.'P') then +! just the phases +! P phases sorted: stable/ unstable in driving force order/ dormant the same + chshort='P' + call list_sorted_phases(lut,ceq) + elseif(ch1.eq.'C') then +! global values and the chemical potentials + chshort='C' + write(kou,*) + call list_global_results(lut,ceq) + write(lut,6303)'Some component data ....................' + jl=1 + if(listresopt.ge.4 .and. listresopt.le.7) then + jl=2 + endif + call list_components_result(lut,jl,ceq) + else + write(kou,*)'Only option A and P implemented' + endif !----------------------------------------------------------- case(3) ! list phase subcommands call gparc('Phase name: ',cline,last,1,name1,' ',q1help) @@ -1718,33 +1804,34 @@ subroutine oc_command_monitor(version,linkdate) write(kou,*)'list phase subcommand error' !............................................................... CASE(1) ! list phase data - call list_phase_data(iph,kou) + call list_phase_data(iph,lut) !............................................................... ! list phase constitution case(2) ! list phase constitution - idef=110 - call gparid('Output mode: ',cline,last,mode,idef,q1help) - if(buperr.ne.0) goto 990 +! idef=110 +! call gparid('Output mode: ',cline,last,mode,idef,q1help) +! if(buperr.ne.0) goto 990 ! call list_phase_results(iph,ics,mode,kou,firsteq) - write(kou,6051)ceq%eqno,ceq%eqname + write(lut,6051)ceq%eqno,ceq%eqname 6051 format('Output for equilibrium: ',i3,', ',a) - call list_phase_results(iph,ics,mode,kou,ceq) + mode=110 + call list_phase_results(iph,ics,mode,lut,ceq) if(gx%bmperr.ne.0) goto 990 !............................................................... case(3) ! list phase model (including disordered fractions) write(kou,6070)'For ',ceq%eqno,ceq%eqname 6070 format(a,'equilibrium: ',i3,', ',a) - call list_phase_model(iph,ics,kou,ceq) + call list_phase_model(iph,ics,lut,ceq) END SELECT !------------------------------ case(4) ! list state variable or parameter identifier value, loop. 6099 continue if(btest(ceq%status,EQNOEQCAL) .or. btest(ceq%status,EQFAIL)) then - write(kou,6101) + write(lut,6101) 6101 format(' *** Warning,',& 'equilibrium not calculated, values are probably wrong') elseif(btest(ceq%status,EQINCON)) then - write(kou,6102) + write(lut,6102) 6102 format(' *** Warning, values can be inconsistent with',& ' current conditions') endif @@ -1762,54 +1849,59 @@ subroutine oc_command_monitor(version,linkdate) model=' ' if(index(line,'*').gt.0) then ! generate many values -! i1 values are resturned in yarr with dimension maxconst. "model" not used - call get_many_svar(line,yarr,maxconst,i1,model,ceq) +! i1 values are resturned in yarr with dimension maxconst. +! longstring are the state variable symbols for the values ... + call get_many_svar(line,yarr,maxconst,i1,longstring,ceq) if(gx%bmperr.eq.0) then - write(kou,6107)(yarr(i2),i2=1,i1) +! not a nice output FIX!! + write(lut,*)longstring(1:len_trim(longstring)) + write(lut,6107)(yarr(i2),i2=1,i1) 6107 format('Values: ',5(1pe14.6)/(8x,5(1pe14.6))) endif else ! in model the state variable is returned as generated by the program call get_state_var_value(line,xxx,model,ceq) if(gx%bmperr.eq.0) then - write(kou,6108)model(1:len_trim(model)),xxx + write(lut,6108)model(1:len_trim(model)),xxx 6108 format(1x,a,'=',1PE15.7) endif endif if(gx%bmperr.ge.4000 .and. gx%bmperr.le.nooferm) then - write(kou,*)bmperrmess(gx%bmperr) + write(lut,*)bmperrmess(gx%bmperr) elseif(gx%bmperr.ne.0) then - write(kou,*)'Error code ',gx%bmperr + write(lut,*)'Error code ',gx%bmperr endif gx%bmperr=0 goto 6105 !----------------------------------------------------------- case(5) ! list data bibliography - call list_bibliography(kou) + call gparcd('Bibliographic id:',cline,last,1,name1,'ALL',q1help) + if(name1.eq.'ALL ') name1=' ' + call list_bibliography(name1,lut) !----------------------------------------------------------- - case(6) ! list parameter symbols - call list_defined_properties(kou) + case(6) ! list model_parameter_identifiers + call list_defined_properties(lut) !----------------------------------------------------------- case(7) ! list axis if(noofaxis.le.0) then write(kou,*)'No axis set' goto 100 endif - write(kou,6131) + write(lut,6131) 6131 format(4x,'Axis variable',12x,'Min',9x,'Max',9x,'Max increment') !6131 format(4x,'Axis variable',12x,'Start',7x,'Final',7x,'Increment') do iax=1,noofaxis jp=1 call get_one_condition(jp,text,axarr(iax)%seqz,ceq) if(gx%bmperr.ne.0) then - write(*,*)'Condition sequential index: ',iax,axarr(iax)%seqz + write(kou,*)'Condition sequential index: ',iax,axarr(iax)%seqz goto 990 endif ! we just want the expression, remove the value including the = sign jp=index(text,'=') text(jp:)=' ' ! write(kou,6132)iax,axvar(iax),(axval(jl,iax),jl=1,3) - write(kou,6132)iax,text(1:24),& + write(lut,6132)iax,text(1:24),& axarr(iax)%axmin,axarr(iax)%axmax,axarr(iax)%axinc 6132 format(i2,2x,a,3(1pe12.4)) enddo @@ -1828,36 +1920,36 @@ subroutine oc_command_monitor(version,linkdate) gx%bmperr=0 else call list_tpfun(lrot,0,longstring) - call wrice2(kou,0,12,78,1,longstring) + call wrice2(lut,0,12,78,1,longstring) if(iel.gt.1) goto 6140 endif else - call list_all_funs(kou) + call list_all_funs(lut) endif !------------------------------------------------------------ case(9) ! list quit !------------------------------------------------------------ - case(10) ! unused list subcommand - continue + case(10) ! list parameter for a phase (just one) + call enter_parameter_interactivly(cline,last,1) !----------------------------------------------------------- case(11) ! list equilibria (not result) do iel=1,noeq() if(associated(ceq,eqlista(iel))) then - write(kou,6202)iel,eqlista(iel)%eqname + write(lut,6202)iel,eqlista(iel)%eqname 6202 format(i5,2x,'**',2x,a) else - write(kou,6203)iel,eqlista(iel)%eqname -6203 format(i5,6x,a) + write(lut,6203)iel,eqlista(iel)%eqname,eqlista(iel)%tpval(1) +6203 format(i5,6x,a,F8.2) endif enddo !------------------------------ case(12) ! list results call gparid('Output mode: ',cline,last,listresopt,lrodef,q1help) lrodef=listresopt - write(kou,6051)ceq%eqno,ceq%eqname + write(lut,6051)ceq%eqno,ceq%eqname ! if(btest(globaldata%status,GSEQFAIL)) then if(btest(ceq%status,EQFAIL)) then - write(kou,6305) + write(lut,6305) 6305 format(/' *** The results listed are not a valid equilibrium',& ' as last calculation failed'/) elseif(btest(globaldata%status,GSNOPHASE)) then @@ -1865,27 +1957,27 @@ subroutine oc_command_monitor(version,linkdate) goto 100 ! elseif(btest(globaldata%status,GSNOEQCAL)) then elseif(btest(ceq%status,EQNOEQCAL)) then - write(kou,6307) + write(lut,6307) 6307 format(/' *** The results listed does not represent',& ' a calculated equilibrium'/) elseif(btest(ceq%status,EQINCON)) then - write(kou,6306) + write(lut,6306) 6306 format(/' *** The results listed may be inconsistent',& ' with the current conditions'/) endif - write(kou,6302)'Conditions .........' -6302 format(a,40('.'),':') -6303 format(/a,40('.'),':') - call list_conditions(kou,ceq) - write(kou,6303)'Some global data ...' - call list_global_results(kou,ceq) - write(kou,6303)'Some component data ' + write(lut,6302)'Conditions .............................' +6302 format(a,20('.'),':') +6303 format(/a,20('.'),':') + call list_conditions(lut,ceq) + write(lut,6303)'Some global data, reference state SER ..' + call list_global_results(lut,ceq) + write(lut,6303)'Some component data ....................' jl=1 if(listresopt.ge.4 .and. listresopt.le.7) then jl=2 endif - call list_components_result(kou,jl,ceq) - write(kou,6303)'Some Phase data ....' + call list_components_result(lut,jl,ceq) + write(lut,6303)'Some Phase data ........................' ! mode >1000 lists stable phases only if(listresopt.le.1) then ! stable phases with mole fractions @@ -1923,7 +2015,7 @@ subroutine oc_command_monitor(version,linkdate) ics=0 6310 continue ics=ics+1 - call list_phase_results(iph,ics,mode,kou,ceq) + call list_phase_results(iph,ics,mode,lut,ceq) if(gx%bmperr.ne.0) then ! if error take next phase gx%bmperr=0 @@ -1932,30 +2024,27 @@ subroutine oc_command_monitor(version,linkdate) goto 6310 endif enddo -! write(kou,*) - call list_phases_with_positive_dgm(mode,kou,ceq) -! if(btest(globaldata%status,GSEQFAIL)) then +! make sure phases with positive DGM listed + call list_phases_with_positive_dgm(mode,lut,ceq) if(btest(ceq%status,EQFAIL)) then - write(kou,6305) -! elseif(btest(globaldata%status,GSNOEQCAL)) then + write(lut,6305) elseif(btest(ceq%status,EQNOEQCAL)) then - write(kou,6307) -! elseif(btest(globaldata%status,GSINCON)) then + write(lut,6307) elseif(btest(ceq%status,EQINCON)) then - write(kou,6306) + write(lut,6306) endif !------------------------------ case(13) ! list conditions write(kou,6070)'Conditions for ',ceq%eqno,ceq%eqname - call list_conditions(kou,ceq) + call list_conditions(lut,ceq) !------------------------------ case(14) ! list symbols (state variable functions, not TP funs) - call list_all_svfun(kou,ceq) + call list_all_svfun(lut,ceq) !------------------------------ ! list lines, output of calculated and stored equilibria case(15) ! temporary listing of all stored equilibria as test - call list_stored_equilibria(kou,axarr,maptop) + call list_stored_equilibria(lut,axarr,maptop) end SELECT !================================================================= ! quit @@ -1963,7 +2052,7 @@ subroutine oc_command_monitor(version,linkdate) if(cline(1:1).eq.'q') then call gparcd('Are you sure?',cline,last,1,ch1,'N',q1help) else -! upper case Q will quit +! upper case Q will quit without question ch1='y' endif if(ch1.eq.'y' .or. ch1.eq.'Y') then @@ -2068,6 +2157,9 @@ subroutine oc_command_monitor(version,linkdate) stop 'Good luck fixing the TDB file' endif endif +! also list the bibliography + call list_bibliography(' ',kou) + write(kou,*) !----------------------------------------------------------- !8300 continue case(3) ! read quit @@ -2083,7 +2175,7 @@ subroutine oc_command_monitor(version,linkdate) goto 100 end SELECT !================================================================= -! save unformatted +! save in various formats case(9) kom2=submenu(cbas(kom),cline,last,csave,ncsave,1) if(kom2.le.0 .or. kom2.gt.ncsave) goto 100 @@ -2116,52 +2208,6 @@ subroutine oc_command_monitor(version,linkdate) if(jp.gt.0) ocufile(jp+1:)='.ocu ' text='U '//model call gtpsave(ocufile,text) -!----------------------------------------------------------- - case(2) ! save TDB - if(tdbfile(1:1).ne.' ') then - text=tdbfile - call gparcd('File name: ',cline,last,1,tdbfile,text,q1help) - else - call gparc('File name: ',cline,last,1,tdbfile,' ',q1help) - endif - jp=0 - kl=index(tdbfile,'.') - if(kl.le.0) then - jp=len_trim(tdbfile) - elseif(tdbfile(kl+1:kl+1).eq.' ') then -! just ending a filename with . not accepted as extention - jp=kl - endif - if(kl.le.0 .and. jp.le.0) then - write(kou,*)'Missing file name' - goto 100 - endif - if(jp.gt.0) tdbfile(jp+1:)='.TDB ' - text='T '//model - call gtpsave(tdbfile,text) -!----------------------------------------------------------- - case(3) ! save MACRO - if(ocmfile(1:1).ne.' ') then - text=ocmfile - call gparcd('File name: ',cline,last,1,ocmfile,text,q1help) - else - call gparc('File name: ',cline,last,1,ocmfile,' ',q1help) - endif - jp=0 - kl=index(ocmfile,'.') - if(kl.le.0) then - jp=len_trim(ocmfile) - elseif(ocmfile(kl+1:kl+1).eq.' ') then -! just ending a filename with . not accepted as extention - jp=kl - endif - if(kl.le.0 .and. jp.le.0) then - write(kou,*)'Missing file name' - goto 100 - endif - if(jp.gt.0) ocmfile(jp+1:)='.OCM ' - text='M '//model - call gtpsave(ocmfile,text) !----------------------------------------------------------- case(4) ! save DIRECT if(ocdfile(1:1).ne.' ') then @@ -2185,35 +2231,12 @@ subroutine oc_command_monitor(version,linkdate) if(jp.gt.0) ocdfile(jp+1:)='.ocd ' text='M '//model call gtpsave(ocdfile,text) -!----------------------------------------------------------- - case(5) ! save LaTeX format for publishing - if(texfile(1:1).ne.' ') then - text=texfile - call gparcd('File name: ',cline,last,1,texfile,text,q1help) - else - call gparc('File name: ',cline,last,1,texfile,' ',q1help) - endif - jp=0 - kl=index(texfile,'.') - if(kl.le.0) then - jp=len_trim(texfile) - elseif(texfile(kl+1:kl+1).eq.' ') then -! just ending a filename with . not accepted as extention - jp=kl - endif - if(kl.le.0 .and. jp.le.0) then - write(kou,*)'Missing file name' - goto 100 - endif - if(jp.gt.0) texfile(jp+1:)='.tex ' - text='M '//model - call gtpsave(texfile,text) !----------------------------------------------------------- case(6) ! save quit continue end SELECT !================================================================= -! help ... just list commands +! help ... just list the commands case(10) call q3help(cline,last,cbas,ncbas) goto 100 @@ -2225,7 +2248,11 @@ subroutine oc_command_monitor(version,linkdate) !================================================================= ! back / goto, return to calling (main) program case(12) - return + call gparcd('Are you sure?',cline,last,1,ch1,'N',q1help) + if(ch1.eq.'y' .or. ch1.eq.'Y') then + write(*,*)'Welcome back!' + return + endif !================================================================= ! NEW command, same as reinitiate case(13) @@ -2264,8 +2291,10 @@ subroutine oc_command_monitor(version,linkdate) case(15) write(kou,15010)linkdate 15010 format(/'This is Open Calphad (OC), a free software for ',& - 'thermodynamic calculations,'/& - 'available for download at http://www.opencalphad.com'//& + 'thermodynamic calculations'/& + 'described in the open access journal:'/& + 'Integrating Materials and Manufacturing Innovation (2015) 4:1'/& + 'It is available for download at http://www.opencalphad.com'//& 'This software is protected by the GNU General Public License'/& 'You may freely distribute copies as long as you also provide ',& 'the source code.'/'The software is provided "as is" without ',& @@ -2273,26 +2302,25 @@ subroutine oc_command_monitor(version,linkdate) 'The full license text is provided with the software or can be ',& 'obtained from'/'the Free Software Foundation ',& 'http://www.fsf.org'//& - 'Copyright 2010-2014, several persons.'/& + 'Copyright 2010-2015, several persons.'/& 'Contact person Bo Sundman, bo.sundman@gmail.com'/& 'This version linked ',a/) - goto 100 !================================================================= ! debug subcommands case(16) ! write(*,*)'Calculating equilibrium record size' kom2=ceqsize(ceq) write(kou,*)'Equilibrium record size: ',kom2 - kom2=submenu(cbas(kom),cline,last,cdebug,ncdebug,0) + kom2=submenu(cbas(kom),cline,last,cdebug,ncdebug,1) SELECT CASE (kom2) !------------------------------ CASE DEFAULT - write(kou,*)'Default case ',kom2 + write(kou,*)'Debug subcommand error ',kom2 !------------------------------ ! debug free lists CASE(1) ! list all tuples - do jp=1,nooftuples + do jp=1,nooftup() write(kou,16020)jp,phasetuple(jp)%phase,phasetuple(jp)%compset 16020 format(i3,': ',2i4) enddo @@ -2302,24 +2330,25 @@ subroutine oc_command_monitor(version,linkdate) CASE(2) stop_on_error=.true. !------------------------------ -! debug elasticity +! debug elasticity (this is temporary) CASE(3) - write(kou,*)'Input current lattice parameter values (3x3 matrix)',& - ' for phase 1' - iph=1 - ics=1 - xxx=7.1D-6 - xxy=1.0D-12 - call gparrd('lattice par (1,1):',cline,last,latpos(1,1),xxx,nohelp) - call gparrd('lattice par (1,2):',cline,last,latpos(1,2),xxy,nohelp) - call gparrd('lattice par (1,3):',cline,last,latpos(1,3),xxy,nohelp) - call gparrd('lattice par (2,1):',cline,last,latpos(2,1),xxy,nohelp) - call gparrd('lattice par (2,2):',cline,last,latpos(2,2),xxx,nohelp) - call gparrd('lattice par (2,3):',cline,last,latpos(2,3),xxy,nohelp) - call gparrd('lattice par (3,1):',cline,last,latpos(3,1),xxy,nohelp) - call gparrd('lattice par (3,2):',cline,last,latpos(3,2),xxy,nohelp) - call gparrd('lattice par (3,3):',cline,last,latpos(3,3),xxx,nohelp) - call set_lattice_parameters(iph,ics,latpos,ceq) + write(*,*)'Not implemented yet' +! write(kou,*)'Input current lattice parameter values (3x3 matrix)',& +! ' for phase 1' +! iph=1 +! ics=1 +! xxx=7.1D-6 +! xxy=1.0D-12 +! call gparrd('lattice par (1,1):',cline,last,latpos(1,1),xxx,nohelp) +! call gparrd('lattice par (1,2):',cline,last,latpos(1,2),xxy,nohelp) +! call gparrd('lattice par (1,3):',cline,last,latpos(1,3),xxy,nohelp) +! call gparrd('lattice par (2,1):',cline,last,latpos(2,1),xxy,nohelp) +! call gparrd('lattice par (2,2):',cline,last,latpos(2,2),xxx,nohelp) +! call gparrd('lattice par (2,3):',cline,last,latpos(2,3),xxy,nohelp) +! call gparrd('lattice par (3,1):',cline,last,latpos(3,1),xxy,nohelp) +! call gparrd('lattice par (3,2):',cline,last,latpos(3,2),xxy,nohelp) +! call gparrd('lattice par (3,3):',cline,last,latpos(3,3),xxx,nohelp) +! call set_lattice_parameters(iph,ics,latpos,ceq) END SELECT !================================================================= ! select command @@ -2439,7 +2468,7 @@ subroutine oc_command_monitor(version,linkdate) case(6) call gparcd('Equilibrium name: ',cline,last,1,name1,'_MAP* ',q1help) if(buperr.ne.0) goto 990 - call delete_equilibria(name1,ceq) + call delete_equilibrium(name1,ceq) if(gx%bmperr.ne.0) goto 990 end SELECT !================================================================= @@ -2459,13 +2488,14 @@ subroutine oc_command_monitor(version,linkdate) deallocate(maptop%saveceq) nullify(maptop) nullify(maptopsave) + write(kou,*)'Previous results removed' else - write(kou,*)'Results removed' maptopsave=>maptop nullify(maptop) + write(kou,*)'Previous results kept' endif ! this should preferably be done directly after map/step, but kept for debug - call delete_equilibria('_MAP*',ceq) + call delete_equilibrium('_MAP*',ceq) endif kom2=submenu('Options?',cline,last,cstepop,nstepop,1) SELECT CASE(kom2) @@ -2554,7 +2584,7 @@ subroutine oc_command_monitor(version,linkdate) nullify(maptop) nullify(maptopsave) ! this should preferably be done directly after map/step, but kept for debug - call delete_equilibria('_MAP*',ceq) + call delete_equilibrium('_MAP*',ceq) if(gx%bmperr.ne.0) then write(kou,*)'Error removing old MAP equilibria' goto 990 @@ -2564,7 +2594,7 @@ subroutine oc_command_monitor(version,linkdate) nullify(maptop) endif ! this should preferably be done directly after map/step, but kept for debug - call delete_equilibria('_MAP*',ceq) + call delete_equilibrium('_MAP*',ceq) endif ! maptop is returned as main map/step record for results ! noofaxis is current number of axis, axarr is array with axis data @@ -2670,15 +2700,22 @@ subroutine oc_command_monitor(version,linkdate) !----------------------------------------------------------- ! plot options subcommand, default is PLOT, NONE does not work ... 21100 continue -! give an empty line as a sublte alert for plot options - write(kou,*) + if(plotform(1:1).eq.'P') then + write(kou,21110)plotfile(1:len_trim(plotfile)) +21110 format(/'Graphics output in postscript format on file: ',a,'.ps ') + elseif(plotform(1:1).eq.'G') then + write(kou,21111)plotfile(1:len_trim(plotfile)) +21111 format(/'Graphics output in GIF format on: ',a,'.gif ') + endif + write(kou,21112) +21112 format(/'Note: give only one option per line!') kom2=submenu('Options?',cline,last,cplot,nplt,1) SELECT CASE(kom2) !----------------------------------------------------------- CASE DEFAULT write(kou,*)'No such plot option' !----------------------------------------------------------- -! no more options, just PLOT! +! no more options to plot, just RENDER! case(1) ! added ceq in the call to make it possible to handle change of reference states !2190 continue @@ -2787,19 +2824,24 @@ subroutine oc_command_monitor(version,linkdate) endif goto 21100 !----------------------------------------------------------- -! PLOT TERMINAL_FORMAT -! for terminal format always also ask for plot file +! PLOT GRAPHICS_FORMAT +! when setting graphics format always also ask for plot file case(7,8) if(kom2.eq.7) then call gparcd('Plot terminal',cline,last,1,ch1,'SCREEN',q1help) if(ch1.eq.'p' .or. ch1.eq.'P') then + write(kou,*)'Plotting set to postscript' plotform='P' + elseif(ch1.eq.'g' .or. ch1.eq.'G') then + write(kou,*)'Plotting set to gif' + plotform='G' else + write(kou,*)'Plotting set to screen' plotform=' ' endif endif !----------------------------------------------------------- -! PLOT OUTPUT_FILE +! PLOT OUTPUT_FILE, always asked when changing terminal call gparcd('Plot file',cline,last,1,plotfile,'ocgnu',q1help) goto 21100 !----------------------------------------------------------- @@ -2818,8 +2860,13 @@ subroutine oc_command_monitor(version,linkdate) case(10) !return to command level !----------------------------------------------------------- -! PLOT not used +! PLOT position of line labels (keys) case(11) + write(kou,21200) +21200 format('Key to lines can be positioned: '/& + 'top/bottom left/center/right inside/outside on/off') + call gparcd('Position?',cline,last,5,line,'top right',q1help) + graphopt%labelkey=line goto 21100 !----------------------------------------------------------- ! PLOT not used @@ -2977,19 +3024,32 @@ end function submenu !\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/!\!/ !\begin{verbatim} - subroutine ocmon_set_options(option) + subroutine ocmon_set_options(option,afo,optionsset) implicit none character*(*) option + integer afo TYPE(ocoptions) :: optionsset -! TYPE(ocoptions), pointer :: optionsset !\end{verbatim} - integer next,kom,slen - character string*64 - integer, parameter :: nopt=6 + integer next,kom,slen,errno + character string*64,dummy*128,date*8,time*10 + integer, parameter :: nopt=9 character (len=16), dimension(nopt) :: copt=& ['OUTPUT ','ALL ','FORCE ',& - 'VERBOSE ','SILENT ',' '] + 'VERBOSE ','SILENT ','APPEND ',& + ' ',' ',' '] ! +! /? will list options + afo=0 + if(option(1:2).eq.'? ') then + write(kou,10) +10 format('Available options (preceeded by /) are:') + next=1 + dummy=' * ' + call q3help(dummy,next,copt,nopt) +! write(*,*)'Back from q3help' + afo=1 + goto 1000 + endif kom=ncomp(option,copt,nopt,next) if(kom.le.0) then write(kou,*)'Unknown option ignored: ',option(1:len_trim(option)) @@ -2997,13 +3057,32 @@ subroutine ocmon_set_options(option) else select case(kom) case default - write(*,*)'Option not implemented: ',option(1:len_trim(option)) + write(kou,*)'Option not implemented: ',option(1:len_trim(option)) + write(kou,10) + next=1 + dummy=' * ' + call q3help(dummy,next,copt,nopt) + afo=1 !----------------------------------- - case(1) ! /output means APPEND + case(1) ! /output means ovewrite any previous content ! write(*,*)'Option not implemented: ',option(1:len_trim(option)) ! next argument after = must be a file name call getext(option,next,2,string,' ',slen) - write(*,*)'should append to file: ',string(1:len_trim(string)) +! add extention .dat if to extenstion provided + if(index(string,'.').le.0) then + string(slen+1:)='.dat ' + endif +! close any previous output file + close(21) + open(21,file=string,access='sequential',status='unknown',& + err=900, iostat=errno) + optionsset%lut=21 +! write a header + call date_and_time(date,time) +232 format(/'%%%%%%%%%% OC output ',a,a4,'-',a2,'-',a2,2x,a2,'h',a2) + write(21,232)'written: ',date(1:4),date(5:6),date(7:8),& + time(1:2),time(3:4) + write(*,*)'output to file: ',string(1:len_trim(string)),optionsset%lut !----------------------------------- case(2) ! /all ?? write(*,*)'Option not implemented: ',option(1:len_trim(option)) @@ -3019,11 +3098,49 @@ subroutine ocmon_set_options(option) globaldata%status=ibclr(globaldata%status,GSVERBOSE) globaldata%status=ibset(globaldata%status,GSSILENT) !----------------------------------- - case(6) ! / - write(*,*)'Option not implemented: ',option(1:len_trim(option)) + case(6) ! /APPEND, open file and write at end +! write(*,*)'Option not implemented: ',option(1:len_trim(option)) +! next argument after = must be a file name + call getext(option,next,2,string,' ',slen) +! add extention .dat if to extenstion provided + if(index(string,'.').le.0) then + string(slen+1:)='.dat ' + endif +! close any previous output file (should not be necessary) + close(21) + open(21,file=string,access='sequential',status='unknown',& + err=900, iostat=errno) + optionsset%lut=21 +! read until end-of-file +200 continue + read(21,210,end=220)dummy +210 format(a) + goto 200 +! write not allowed after fininfg EOF, we must backspace +220 continue + backspace(21) +! write a header + call date_and_time(date,time) + write(21,232)'appended: ',date(1:4),date(5:6),date(7:8),& + time(1:2),time(3:4) + write(kou,231)string(1:len_trim(string)) +231 format('Output will be appended to file: ',a) +!----------------------------------- + case(7) ! + continue !----------------------------------- + case(8) ! + continue +!----------------------------------- + case(9) ! + continue end select endif + goto 1000 +! errors +900 continue + write(kou,*)'Failed to open output file, error cofe=',errno + goto 1000 1000 continue return end subroutine ocmon_set_options @@ -3036,13 +3153,19 @@ subroutine ocmon_reset_options(optionsset) TYPE(ocoptions) :: optionsset ! TYPE(ocoptions), pointer :: optionsset !\end{verbatim} -! The only thing tested here is verbose if(btest(globaldata%status,GSVERBOSE)) then +! reset verbose option if(.not.btest(globaldata%status,GSSETVERB)) then ! if user has SET VERBOSE do not resest VERBOSE globaldata%status=ibclr(globaldata%status,GSVERBOSE) endif endif +! reset output unit option + if(optionsset%lut.ne.kou) then + close(optionsset%lut) + optionsset%lut=kou + write(*,*)'ouput unit reset to screen',optionsset%lut + endif 1000 continue return end subroutine ocmon_reset_options diff --git a/utilities/metlib3.F90 b/utilities/metlib3.F90 index 2948d53..6296d4e 100644 --- a/utilities/metlib3.F90 +++ b/utilities/metlib3.F90 @@ -101,7 +101,7 @@ MODULE METLIB character*32, dimension(maxhelplevel) :: cpath END TYPE help_str ! this record is used to file the appropriate help text - type(help_str) :: helprec + type(help_str), save :: helprec !vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ! Data structures for putfun below @@ -4825,8 +4825,9 @@ SUBROUTINE Q3HELP(LINE,LAST,COMM,NC) ! To avoid storing "COMMAND" in the helprec%cpath ! if(helprec%level.gt.2) helprec%level=helprec%level-1 !.. HELP HELP not OK if(helprec%level.gt.3) helprec%level=helprec%level-1 -! write(*,*)'Asking for command:' +! write(*,*)'q3help: asking for command for help:',line(1:2),last CALL GPARC('COMMAND: ',LINE,LAST,1,CMD,'*',tophlp) +! write(*,*)'q3help: command:',cmd IF(CMD(1:1).EQ.'*') THEN !...LIST ALL COMMANDS IN UNIX ALPHABETICAL ORDER NKPL=80/(LEN(COMM(1))+1) diff --git a/utilities/tpfun4.F90 b/utilities/tpfun4.F90 index 4f1b114..a272096 100644 --- a/utilities/tpfun4.F90 +++ b/utilities/tpfun4.F90 @@ -407,24 +407,24 @@ subroutine list_all_funs(lut) ! nosym=0 means the local symbol name is included in the listing once=.TRUE. nosym=0 - write(kou,10) + write(lut,10) 10 format(/'List of all symbols used in phase parameters (TP-functions):'/ & ' Predefined symbols:'/& ' BELOW(TB) = EXP(20*(1-T/TB))/(1+EXP(20*(1-T/TB)));'/& ' ABOVE(TB) = 1-EXP(20*(1-T/TB))/(1+EXP(20*(1-T/TB)));'/& ' Nr Name',8x,'T-low expression; T-high Y/N') -20 format(I3,1x,A) +20 format(I4,1x,A) do ifun=1,freetpfun-1 write(str,20)ifun - call list_tpfun(ifun,nosym,str(5:)) - if(str(5:9).eq.'_A00 ') then + call list_tpfun(ifun,nosym,str(6:)) + if(str(6:9).eq.'_A00 ') then if(once) then write(lut,30) 30 format(' *** Not listing optimizing coefficents that are zero') once=.FALSE. endif else - if(str(5:5).ne.'_') call wrice2(lut,0,12,78,1,str) + if(str(6:6).ne.'_') call wrice2(lut,0,12,78,1,str) endif enddo return @@ -819,7 +819,10 @@ subroutine ct1getsym(string,ip,symbol) (jp.gt.0 .and. ch1.eq.'_') .or. & (jp.gt.0 .and. (ch1.ge.'0' .and. ch1.le.'9'))) then jp=jp+1 - localsym(jp:jp)=ch1 +! ignore characters after length of localsym + if(jp.le.len(localsym)) then + localsym(jp:jp)=ch1 + endif ip=ip+1 goto 100 endif @@ -1551,6 +1554,7 @@ subroutine ct1wfn(exprot,tps,string,ip) ic=0 level=1 lpar=0 +! write(*,*)'in ct1wfn',nc 200 ic=ic+1 if(ic.gt.nc) goto 1000 coeff(level)=exprot%coeffs(ic) @@ -1571,6 +1575,8 @@ subroutine ct1wfn(exprot,tps,string,ip) ! 71 format(A,I5,1PE15.6,5I5) is=koder(5,level) +! write(*,202)'ct1wfn: ',ic,ip,is,koder(1,level),string(1:ip) +!202 format(a,4i4,a) symbol: if(is.ne.0) then !...reference to symbol or unary function, write coefficient only if not one if(abs(coeff(level)).ne.one) then @@ -1609,6 +1615,7 @@ subroutine ct1wfn(exprot,tps,string,ip) string(ip:)=unary(-is)(1:kk)//'(' ip=ip+kk+1 lpar=koder(4,level) +! write(*,*)'lpar: ',string(1:ip),' ',lpar else ! an external symbol, possibly a sign and power if(nos.eq.1) then @@ -1658,6 +1665,8 @@ subroutine ct1wfn(exprot,tps,string,ip) call ct1wpow(string,ip,tps(1),-1,koder(1,level)) call ct1wpow(string,ip,tps(2),-1,koder(2,level)) ! fixing missing ) after unary function of symbol like exp(s1) +! write(*,*)'problem here??:',string(1:ip),' ',lpar +! We got one extra ) as lpar not reset below if(lpar.gt.0) then string(ip:ip)=')' ip=ip+1 @@ -1673,10 +1682,20 @@ subroutine ct1wfn(exprot,tps,string,ip) else ! in the case of a single value exactly 1 without unary or T or P power ! the number was never written +! write(*,203)'ct1wfn2: ',(koder(i,level),i=1,4),coeff(level) +203 format(a,4i4,1pe12.4) do i=1,4 - if(koder(i,level).ne.0) goto 220 + if(koder(i,level).ne.0) goto 219 enddo +! without this the Inden magnetic function will miss its initial 1.0 call wrinum(string,ip,2,0,coeff(level)) + goto 220 +219 continue +! missing coefficient discovered by Mauro, as the coefficient is unity +! it is not written. Check with -1 maybe sign problems? +! call wrinum(string,ip,2,1,coeff(level)) + string(ip:ip)='+' + ip=ip+1 220 continue mult=0 endif @@ -1686,6 +1705,10 @@ subroutine ct1wfn(exprot,tps,string,ip) if(koder(4,level).eq.1) then string(ip:ip)=')' ip=ip+1 +! lpar was not reset here causing an extra ) later in expression ... + lpar=0 +! write(*,*)'lpar not reset?:',string(1:ip) +! write(*,*)lpar,koder(4,level) endif goto 200 1000 return @@ -2004,6 +2027,7 @@ subroutine nested_tpfun(lrot,tpval,nyrot) write(*,*)'nested constant: ',nr,lrot else write(*,*)'A never never error evaluation a TP function',lrot + write(*,*)'Function name: ',tpfuns(lrot)%symbol gx%bmperr=6666; goto 1000 endif elseif(nr.eq.1) then