PROGRAM COE2GES
C
C-------------------------------------------------------------------------
C
C Conversion from BINGSS ab.coe file to a GES setup file
C Copyright 1994 Bo Sundman
C
C This program is free software: you can redistribute it and/or modify
C it under the terms of the GNU General Public License as published by
C the Free Software Foundation version 3 of the License
C
C This program is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
C along with this program. If not, see .
C
C Contact through http://www.computational-thermodynamics.mpg.de
C
C-----------------------------------------------------------------------
C
C currently implemented models 0-9,12,14,23,24,27,28,90-93
C creating functions, phases and parameter names OK
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
PARAMETER (ZERO=0.0D0,ONE=1.0D0,EPS=1.0D-20)
CHARACTER LINE*80,FIL1*20,FIL2*20,SYS*40,ELNAM(2)*2,CH1*1
CHARACTER BIG*1000,ENTPH*100,ENTP*200,CREF(2,10)*7,NAME*24
CHARACTER ENTTC1*100,ENTTC2*100,ENTTC3*100,SPNAM*30,DLIN*80
CHARACTER*2 WSEA1,WSEB1,WSEA2,WSEB2
CHARACTER*5 CATION,ANION
CHARACTER NUMBER*2
DIMENSION CC(15),CC1(15),CC2(15),CC3(15),CC4(15)
DIMENSION IUNKN(6),JUNKN(6),IEI(5),NPREF(2),NTPOW(15)
LOGICAL EOLCH
VERS=1.1
WRITE(*,3)VERS
3 FORMAT(/' This is a program to convert BINGSS "coe" files',
&' with parameters'/' to command input files to Thermo-Calc'/
&' Version ',F3.1//' The BINGSS file',
&' must be named after the system like cumg.coe for Cu-Mg,'/
&' the output file will have the same name but extention .TCM'//
&' There are a number of restrictions on the models in BINGSS'/
&' that can be converted,',
&' currently implemented models are:'/
&' 0-9, 12, 14, 23, 24, 27, 28, 34-36, 38, 39, 70-78, 80-88,',
&' 90-93'/' Magnetic parameters included and',
&' model 37 maybe added soon.'//
&' NOTE that the Wagner-Schottky models 50-58 should no longer',
&' be used as'/' they are now replaced by the Thermo-Calc',
&' compatible models 70-78 or 80-88'/
&' which also can describe Bragg-Williams ordering'//
&' The program cannot handle the BINGSS parameter correlations,'/
&' these have to be edited on the output file.'//
&' You will be asked for reference state and mass for the',
&' elements'/' but this can be edited on the output file later.',
&' To have command echo from'/' Thermo-Calc may be useful if there',
&' are some problems.'/' The program will ask for major',
&' constituents of the solution phases.'/' If no major then just',
&' give return.'/)
NUMBER='AA'
WRITE(*,*)'System file (like cumg): '
READ(*,7)SYS
7 FORMAT(A)
8 WRITE(*,*)'Insert variables to be optimized (y or n)'
READ(*,7)CH1
IF(CH1.EQ.'y' .OR. CH1.EQ.'Y') THEN
IVAR=1
ELSEIF(CH1.EQ.'n' .OR. CH1.EQ.'N') THEN
IVAR=0
ELSE
WRITE(*,*)'Please answer y or n'
GOTO 8
ENDIF
FIL1=SYS(1:LENS(SYS))//'.coe'
FIL2=SYS(1:LENS(SYS))//'.TCM'
OPEN(21,FILE=FIL1,ACCESS='SEQUENTIAL',STATUS='OLD')
OPEN(22,FILE=FIL2,ACCESS='SEQUENTIAL',STATUS='UNKNOWN')
NOVA=0
C
10 FORMAT(2I3,1X,2A2,4I3,F8.2)
16 FORMAT(F8.2,4D16.8)
18 FORMAT(2D15.7,3D14.6)
C
20 FORMAT(F8.2,4D16.8/2D15.7,3D14.6)
21 FORMAT(F8.2,4D16.8/2D15.7,3D14.6/2D15.7,3D14.6)
22 FORMAT('@@',F8.2,4D16.8/'@@',2D15.7,3D14.6/'@@',2D15.7,3D14.6)
30 FORMAT(I3,A12,I2,8I3)
31 FORMAT('@@'/'@@',I3,A12,I2,8I3)
40 FORMAT(T2,6I1,F11.2,F11.5,F11.6,3P,F11.6,0P,F11.0,6P,F10.5)
41 FORMAT('@@',6I1,F11.2,F11.5,F11.6,3P,F11.6,0P,F11.0,6P,F10.5)
50 FORMAT(T8,F11.2,F11.5)
60 FORMAT(I3,1X,A12)
70 FORMAT(24I3)
80 FORMAT(T2,I2,2I3,D15.8)
C
CALL IGNCOM(21,DLIN)
READ(DLIN,10)NP,NT,ELNAM(1),ELNAM(2),
& NPREF(1),NPREF(2),NTU,ITMAT,TMAX
IF(NTU.GT.9) THEN
CALL IGNCOM(21,DLIN)
READ(DLIN,70)(NTPOW(I),I=1,NTU-9)
ENDIF
CALL CAPSON(ELNAM(1))
CALL CAPSON(ELNAM(2))
C...handeling of sign for subregular parameter
IRKS=1
IF(ELNAM(1).GT.ELNAM(2)) IRKS=-1
WRITE(*,*)'Reference state for ',ELNAM(1)
READ(*,7)NAME
CALL CAPSON(NAME)
IF(NAME(1:1).EQ.' ') NAME='UNKNOWN'
WRITE(*,*)'Mass (g/mol) for ',ELNAM(1)
READ(*,*)AM1
WRITE(*,*)'Reference state for ',ELNAM(2)
READ(*,7)SPNAM
CALL CAPSON(SPNAM)
IF(SPNAM(1:1).EQ.' ') SPNAM='UNKNOWN'
WRITE(*,*)'Mass (g/mol) for ',ELNAM(2)
READ(*,*)AM2
WRITE(*,*)'Do you want command echo from Thermo-Calc? (y or n)'
READ(*,7)CH1
IF(CH1.EQ.'Y' .OR. CH1.EQ.'y') THEN
WRITE(22,17)ELNAM,VERS,ELNAM,ELNAM(1),NAME,AM1,ELNAM(2),SPNAM,AM2
ELSE
WRITE(22,19)ELNAM,VERS,ELNAM,ELNAM(1),NAME,AM1,ELNAM(2),SPNAM,AM2
ENDIF
17 FORMAT('@@ setup file for GES converted from BINGSS format'/
& '@@ for the system ',A,' and ',A/
& '@@ Conversion program version ',F4.1,', Bo Sundman'/
& ' go SYS'/
& ' set-log-file xxx test'/
& ' go Gibbs_Energy_System'/
& ' ent_element VA ',A,' ',A/
& ' am_element_data ',A,' ',A12,1X,F10.6,' 0 0 2'/
& ' am_element_data ',A,' ',A12,1X,F10.6,' 0 0 2')
19 FORMAT('@@ setup file for GES converted from BINGSS format'/
& '@@ for the system ',A,' and ',A/
& '@@ Conversion program version ',F4.1,', Bo Sundman'/
& ' go Gibbs_Energy_System'/
& ' ent_element VA ',A,' ',A/
& ' am_element_data ',A,' ',A12,1X,F10.6,' 0 0 2'/
& ' am_element_data ',A,' ',A12,1X,F10.6,' 0 0 2')
C...reading pure element functions
BIG='ent_symbol function '
DO 99 IC=1,2
DO 98 KP=1,NPREF(IC)
CALL IGNCOM(21,DLIN)
READ(DLIN,60)NRANGE,LINE
C WRITE(22,61)NRANGE,LINE
61 FORMAT('@@ ',I3,1X,A12)
C... Line should have as "Ag Liquid"
CALL CAPSON(LINE)
M=0
IF(EOLCH(LINE,M)) THEN
WRITE(*,*)' Missing reference function information'
STOP
ELSE
K=INDEX(LINE(M:),' ')+M-1
ENDIF
IF(LINE(K+1:K+3).EQ.'LIQ' .OR. LINE(K+1:K+3).EQ.'liq') THEN
C... function type GALLIQ
CREF(IC,KP)='G'//ELNAM(IC)
JP=LENS(CREF(IC,KP))
CREF(IC,KP)(JP+1:JP+3)=LINE(K+1:K+3)
JP=JP+4
ELSE
C... function type GHSERAL
CREF(IC,KP)='G'//ELNAM(IC)(1:LENS(ELNAM(IC)))//'_'//NUMBER
CALL FNIC(NUMBER)
JP=LENS(CREF(IC,KP))
ENDIF
IP=23
BIG(IP:IP+JP+1)=CREF(IC,KP)
IP=IP+JP+1
DO 97 J=1,NRANGE
CALL IGNCOM(21,DLIN)
READ(DLIN,16)(CC(L),L=1,5)
IF(NTU.GT.5) THEN
CALL IGNCOM(21,DLIN)
READ(DLIN,18)(CC(L),L=6,10)
ENDIF
IF(NTU.GT.9) THEN
CALL IGNCOM(21,DLIN)
READ(DLIN,18)(CC(L),L=11,15)
ENDIF
C WRITE(22,22)(CC(L),L=1,NTU+1)
C... low T limit
CALL WRINUM(BIG,IP,12,-1,CC(1))
IF(J.GT.1) THEN
BIG(IP:IP+2)=' Y'
IP=IP+3
ELSE
BIG(IP:IP+1)=' '
IP=IP+1
ENDIF
CALL WRICC(BIG,IP,CC,NTU,NTPOW,ITMAT)
97 CONTINUE
CALL WRINUM(BIG,IP,12,-1,TMAX)
BIG(IP:IP+2)=' N '
CALL AWRICE(22,1,1,78,'@',BIG(1:IP+2))
98 CONTINUE
99 CONTINUE
100 CONTINUE
L1=LENS(ELNAM(1))
L2=LENS(ELNAM(2))
NPH=0
110 NPH=NPH+1
IF(NPH.GT.NP) THEN
WRITE(*,*)'Read data for all phases, normal termination.'
WRITE(*,*)'TC macro file is ',FIL2
GOTO 900
ENDIF
CALL IGNCOM(21,DLIN)
READ(DLIN,30)LINES,NAME,(IEI(J),J=1,5),NME,NF,IP1,IP2
IF(IP1.GT.10 .OR. IP2.GT.10) THEN
WRITE(*,*)'Too many functions, increase dimension of CREF'
STOP 0
ENDIF
IF(LINES.EQ.0) GOTO 900
C WRITE(22,31)LINES,NAME,(IEI(J),J=1,5),NME,NF,IP1,IP2
CALL CHKPHN(NAME)
L3=LENS(NAME)
IF(IEI(1).EQ.10 .OR. IEI(1).EQ.15 .OR. IEI(1).EQ.16 .OR.
& IEI(1).EQ.19 .OR. IEI(1).EQ.20 .OR. IEI(1).EQ.29 .OR.
& (IEI(1).GE.40 .AND. IEI(1).LE.49) .OR.
& (IEI(1).GE.59 .AND. IEI(1).LE.64) .OR.
& (IEI(1).GE.67 .AND. IEI(1).LE.69) .OR. IEI(1).EQ.79 .OR.
& IEI(1).EQ.89 .OR. (IEI(1).GE.95 .AND. IEI(1).LE.99)) THEN
WRITE(*,*)'Model no ',IEI(1),' does not exist'
DO 992 I=1,LINES
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
992 CONTINUE
ELSEIF(IEI(1).EQ.11 .OR. IEI(1).EQ.13 .OR. IEI(1).EQ.21 .OR.
& IEI(1).EQ.22 .OR. IEI(1).EQ.25 .OR. IEI(1).EQ.26) THEN
WRITE(*,*)'Please use Redlich-Kister type for model ',IEI(1)
DO 993 I=1,LINES
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
993 CONTINUE
GOTO 110
ELSEIF(IEI(1).EQ.17 .OR. IEI(1).EQ.18 .OR. IEI(1).EQ.94) THEN
WRITE(*,*)'Please try model 14 instead of model ',IEI(1)
DO 994 I=1,LINES
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
994 CONTINUE
GOTO 110
ELSEIF(IEI(1).GE.30 .AND. IEI(1).LE.33) THEN
WRITE(*,*)'Please use model 34 instead of model ',IEI(1)
DO 995 I=1,LINES
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
995 CONTINUE
GOTO 110
ELSEIF(IEI(1).EQ.37) THEN
WRITE(*,*)'Sorry, cannot handle model ',IEI(1)
DO 996 I=1,LINES
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
996 CONTINUE
GOTO 110
ELSEIF(IEI(1).GE.50 .AND. IEI(1).LE.58) THEN
WRITE(*,*)'Please use corresponding model 70-78 instead of ',
& IEI(1)
DO 997 I=1,LINES
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
997 CONTINUE
GOTO 110
ELSEIF(IEI(1).EQ.65) THEN
WRITE(*,*)'Sorry, cannot handle model ',IEI(1)
DO 998 I=1,LINES
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
998 CONTINUE
GOTO 110
ELSEIF(IEI(1).EQ.66) THEN
WRITE(*,*)'Please use model 36 instead of model ',IEI(1)
DO 999 I=1,LINES
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
999 CONTINUE
GOTO 110
ENDIF
C
C...implemented models below
C
IF(IEI(1).LE.9 .OR. IEI(1).EQ.90) THEN
C.... stoichiometric phase
TOTAL=IEI(2)+IEI(3)
IF(IEI(1).EQ.90) TOTAL=ONE
AS1=FLOAT(IEI(2))/TOTAL
AS2=FLOAT(IEI(3))/TOTAL
ENTPH='ent_phase '//NAME(1:L3)//' , 2'
IP=LENS(ENTPH)+2
ENTP='ent_parameter G('//NAME
KP=LENS(ENTP)+1
IF(IEI(2).GT.0 .AND. IEI(3).GT.0) THEN
CALL WRINUM(ENTPH,IP,12,-1,AS1)
IP=IP+1
CALL WRINUM(ENTPH,IP,12,-1,AS2)
ENTPH(IP:)=' '//ELNAM(1)//'; '//ELNAM(2)//';,,, '
ENTP(KP:)=','//ELNAM(1)(1:L1)//':'//ELNAM(2)(1:L2)//';0)'
NOS=0
ELSEIF(IEI(2).GT.0) THEN
ENTPH(IP-2:IP-2)='1'
ENTPH(IP:)=' '//ELNAM(1)//';,,, '
ENTP(KP:)=','//ELNAM(1)(1:L1)//';0)'
NOS=1
ELSE
ENTPH(IP-2:IP-2)='1'
ENTPH(IP:)=' '//ELNAM(2)//';,,, '
ENTP(KP:)=','//ELNAM(2)(1:L2)//';0)'
NOS=2
ENDIF
IP=LENS(ENTPH)
ENTTC1=ENTP(1:IP)
WRITE(22,7)ENTPH(1:IP)
IF(LINES.EQ.3) THEN
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
IF(IVAR.GT.0) CALL CHKOV(IUNKN)
DO 111 J=1,NT
111 CC1(J)=AS1*CC(J)
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
IF(IVAR.GT.0) CALL CHKOV(IUNKN)
DO 112 J=1,NT
112 CC1(J)=CC1(J)+AS2*CC(J)
ELSE
DO 113 J=1,NT
113 CC1(J)=ZERO
ENDIF
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
DO 114 J=1,NT
114 CC(J)=CC(J)+CC1(J)
IP=LENS(ENTP)+2
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC,NT,ITMAT)
IF(NOS.NE.2) THEN
CALL WRINUM(ENTP,IP,12,1,AS1)
ENTP(IP:)='*'//CREF(1,IP1)
IP=IP+8
ENDIF
IF(NOS.NE.1) THEN
CALL WRINUM(ENTP,IP,12,1,AS2)
ENTP(IP:)='*'//CREF(2,IP2)
IP=IP+8
ENDIF
ENTP(IP:IP+5)=';,,,, '
IP=IP+6
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP))
C...end of stoichiometric phase, 0-9
ELSEIF(IEI(1).EQ.12) THEN
C...Redlich-Kister substitutional solution
ENTPH='ent_phase '//NAME(1:L3)//' , 1 '//
& ELNAM(1)//' '//ELNAM(2)//';,,, '
IF(NAME(1:3).EQ.'GAS') THEN
ENTPH(L3+12:L3+12)='G'
ELSEIF(NAME(1:3).EQ.'LIQ') THEN
ENTPH(L3+12:L3+12)='L'
ENDIF
WRITE(22,115)ENTPH(1:LENS(ENTPH))
115 FORMAT(2X,A)
WRITE(*,*)'Please give the major constituent of ',NAME,
& '(empty lines means none)'
READ(*,7)WSEA1
IF(WSEA1.NE.' ') THEN
WRITE(22,*)' am_phase ',NAME(1:L3),' major 1 ',WSEA1
ENDIF
C
DO 120 I=1,15
120 CC(I)=0.0D0
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
ENTP='ent_parameter G('//NAME(1:L3)//','
KP=LENS(ENTP)+1
ENTP(KP:)=ELNAM(1)(1:L1)//';0) '
IP=KP+L1+5
ENTTC1=ENTP(1:IP)
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC,NT,ITMAT)
ENTP(IP:)='+'//CREF(1,IP1)//';,,, '
IP=IP+13
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP))
C
DO 130 I=1,15
130 CC(I)=0.0D0
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
ENTP(KP:)=ELNAM(2)(1:L2)//';0) '
IP=KP+L2+5
ENTTC2=ENTP(1:IP)
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC,NT,ITMAT)
ENTP(IP:)='+'//CREF(2,IP2)//';,,, '
IP=IP+13
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP))
ENTP(KP:)=ELNAM(1)(1:L1)//','//ELNAM(2)(1:L2)//';'
KP=LENS(ENTP)+1
JREF=2
GOTO 700
C...end of substitutional solution, 12
ELSEIF(IEI(1).EQ.14 .OR. IEI(1).EQ.91) THEN
C...Phase with stoichiometric constraint and
C mixing on last sublattice (type sigma, laves)
C Default 3 sublattices but note that sublattice 1 or 2 can be void!
150 TOTAL=IEI(2)+IEI(3)+IEI(4)
IF(IEI(1).EQ.91) TOTAL=ONE
ENTPH='ent_phase '//NAME(1:L3)//' , 3'
JP=LENS(ENTPH)
IP=JP+2
C
IF(IEI(2).NE.0) THEN
AS1=FLOAT(IEI(2))/TOTAL
CALL WRINUM(ENTPH,IP,12,-1,AS1)
IP=IP+1
NOS=0
ELSE
AS1=ZERO
NOS=1
ENDIF
IF(IEI(3).NE.0) THEN
AS2=FLOAT(IEI(3))/TOTAL
CALL WRINUM(ENTPH,IP,12,-1,AS2)
IP=IP+1
ELSE
AS2=ZERO
IF(NOS.EQ.1) THEN
C... sublattice 1 and 2 empty, i.e. a substitutional phase!
WRITE(*,9910)NAME,IEI
9910 FORMAT(' Illegal use of model 14 or 19, use 12 for ',A,5I4)
STOP
ENDIF
NOS=2
ENDIF
IF(NOS.NE.0) ENTPH(JP:JP)='2'
AS3=FLOAT(IEI(4))/TOTAL
CALL WRINUM(ENTPH,IP,12,-1,AS3)
IP=IP+1
ENTP='ent_parameter G('//NAME(1:L3)//','
KP=LENS(ENTP)+1
IF(NOS.NE.1) THEN
ENTPH(IP:IP+3)=ELNAM(1)//'; '
ENTP(KP:)=ELNAM(1)(1:L1)//':'
IP=IP+4
KP=KP+L1+1
ENDIF
IF(NOS.NE.2) THEN
ENTPH(IP:IP+3)=ELNAM(2)//'; '
ENTP(KP:)=ELNAM(2)(1:L2)//': '
IP=IP+4
KP=KP+L2+1
ENDIF
ENTPH(IP:)=ELNAM(1)//' '//ELNAM(2)//';,,, '
IP=LENS(ENTPH)
WRITE(22,7)ENTPH(1:IP)
C
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC1(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC1(J),J=1,NT)
IF(IVAR.GT.0) CALL CHKOV(IUNKN)
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC2(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC2(J),J=1,NT)
IF(IVAR.GT.0) CALL CHKOV(IUNKN)
C
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
ENTP(KP:)=ELNAM(1)(1:L1)//';0) '
IP=KP+L1+5
ENTTC1=ENTP(1:IP)
DO 155 J=1,NT
CC3(J)=CC(J)+(AS1+AS3)*CC1(J)
IF(NOS.NE.2) CC3(J)=CC3(J)+AS2*CC2(J)
155 CONTINUE
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC3,NT,ITMAT)
CALL WRINUM(ENTP,IP,12,1,AS1+AS3)
ENTP(IP:)='*'//CREF(1,IP1)
IP=IP+8
IF(NOS.NE.2) THEN
CALL WRINUM(ENTP,IP,12,1,AS2)
ENTP(IP:)='*'//CREF(2,IP2)
IP=IP+8
ENDIF
ENTP(IP:IP+5)=';,,,, '
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP+5))
C
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
ENTP(KP:)=ELNAM(2)(1:L2)//';0) '
IP=KP+L2+5
ENTTC2=ENTP(1:IP)
DO 156 J=1,NT
CC3(J)=CC(J)+(AS2+AS3)*CC1(J)
IF(NOS.NE.1) CC3(J)=CC3(J)+AS1*CC2(J)
156 CONTINUE
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC3,NT,ITMAT)
IF(NOS.NE.1) THEN
CALL WRINUM(ENTP,IP,12,1,AS1)
ENTP(IP:)='*'//CREF(1,IP1)
IP=IP+8
ENDIF
CALL WRINUM(ENTP,IP,12,1,AS2+AS3)
ENTP(IP:)='*'//CREF(2,IP2)//';,,,, '
IP=IP+14
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP))
ENTP(KP:)=ELNAM(1)(1:L1)//','//ELNAM(2)(1:L2)//';'
KP=LENS(ENTP)+1
JREF=4
GOTO 700
C...end phase with mixing and stoichiometric constraint, 14 and 91
ELSEIF(IEI(1).EQ.23 .OR. IEI(1).EQ.24 .OR.
& IEI(1).EQ.27 .OR. IEI(1).EQ.28 .OR.
& IEI(1).EQ.92 .OR. IEI(1).EQ.93) THEN
C...Interstital solutions of various types
160 TOTAL=IEI(2)+IEI(3)+IEI(4)
IEI1=IEI(1)
IF(IEI1.EQ.92 .OR. IEI1.EQ.93) TOTAL=ONE
IF(NOVA.EQ.0) THEN
WRITE(22,161)
161 FORMAT(' ent_element VA')
NOVA=1
ENDIF
ENTPH='ent_phase '//NAME(1:L3)//' , 3'
JP=LENS(ENTPH)
IP=JP+2
C
IF(IEI1.EQ.24) THEN
AS1=ZERO
IEI(4)=IEI(3)
IEI(3)=IEI(2)
NOS=1
ELSEIF(IEI(2).NE.0) THEN
AS1=FLOAT(IEI(2))/TOTAL
CALL WRINUM(ENTPH,IP,12,-1,AS1)
IP=IP+1
NOS=0
ELSE
AS1=ZERO
NOS=1
ENDIF
IF(IEI1.EQ.23) THEN
AS2=ZERO
IEI(4)=IEI(3)
IF(NOS.NE.0) STOP 'Illegal use of type 23 or 24'
NOS=2
ELSEIF(IEI(3).NE.0) THEN
AS2=FLOAT(IEI(3))/TOTAL
CALL WRINUM(ENTPH,IP,12,-1,AS2)
IP=IP+1
ELSE
AS2=ZERO
IF(NOS.EQ.1) THEN
C... sublattice 1 and 2 empty, illegal when VA in 3rd sublattice
WRITE(*,9911)NAME,IEI
9911 FORMAT(' Illegal model for ',A,5I4)
STOP
ENDIF
NOS=2
ENDIF
IF(NOS.NE.0) ENTPH(JP:JP)='2'
AS3=FLOAT(IEI(4))/TOTAL
CALL WRINUM(ENTPH,IP,12,-1,AS3)
IP=IP+1
ENTP='ent_parameter G('//NAME(1:L3)//','
KP=LENS(ENTP)+1
IF(NOS.NE.1) THEN
ENTPH(IP:IP+3)=ELNAM(1)//'; '
ENTP(KP:)=ELNAM(1)(1:L1)//':'
IP=IP+4
KP=KP+L1+1
ENDIF
IF(NOS.NE.2) THEN
ENTPH(IP:IP+3)=ELNAM(2)//'; '
ENTP(KP:)=ELNAM(2)(1:L2)//': '
IP=IP+4
KP=KP+L2+1
ENDIF
IF(IEI1.EQ.23 .OR. IEI1.EQ.27 .OR.IEI1.EQ.93) THEN
ENTPH(IP:)='VA '//ELNAM(2)//';,,, '
ELSE
ENTPH(IP:)='VA '//ELNAM(1)//';,,, '
ENDIF
IP=LENS(ENTPH)
WRITE(22,7)ENTPH(1:IP)
C
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC1(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC1(J),J=1,NT)
IF(IVAR.GT.0) CALL CHKOV(IUNKN)
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC2(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC2(J),J=1,NT)
IF(IVAR.GT.0) CALL CHKOV(IUNKN)
IF(IEI1.EQ.23 .OR. IEI1.EQ.24) THEN
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
JREF=3
ELSE
CALL IGNCOM(21,DLIN)
READ(DLIN,40)JUNKN,(CC4(J),J=1,NT)
C WRITE(22,41)JUNKN,(CC4(J),J=1,NT)
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
JREF=4
ENDIF
IF(IEI1.EQ.23 .OR. IEI1.EQ.27 .OR. IEI1.EQ.93) THEN
C...element B interstital i.e. (A:B:B) or (A:B)
ENTP(KP:)=ELNAM(2)(1:L2)//';0) '
IP=KP+L2+5
ENTTC1=ENTP(1:IP)
DO 170 J=1,NT
CC3(J)=CC(J)+AS1*CC1(J)+(AS2+AS3)*CC2(J)
170 CONTINUE
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC3,NT,ITMAT)
CALL WRINUM(ENTP,IP,12,1,AS1)
ENTP(IP:)='*'//CREF(1,IP1)
IP=IP+8
CALL WRINUM(ENTP,IP,12,1,AS2+AS3)
ENTP(IP:)='*'//CREF(2,IP2)//';,,,, '
IP=IP+14
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP))
ELSE
C...element A interstital i.e. (A:B:A) or (B:A)
ENTP(KP:)=ELNAM(1)(1:L1)//';0) '
IP=KP+L1+5
ENTTC1=ENTP(1:IP)
DO 171 J=1,NT
171 CC3(J)=CC(J)+(AS1+AS3)*CC1(J)+AS2*CC2(J)
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC3,NT,ITMAT)
CALL WRINUM(ENTP,IP,12,1,AS1+AS3)
ENTP(IP:)='*'//CREF(1,IP1)
IP=IP+8
CALL WRINUM(ENTP,IP,12,1,AS2)
ENTP(IP:)='*'//CREF(2,IP2)//';,,,, '
IP=IP+14
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP))
ENDIF
DO 173 I=1,6
173 IUNKN(I)=0
ENTP(KP:)='VA;0) '
IP=KP+7
ENTTC2=ENTP(1:IP)
IF(IEI1.EQ.23) THEN
C...(A:VA) i.e. pure A
DO 175 J=1,NT
175 CC3(J)=AS1*CC1(J)
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC3,NT,ITMAT)
CALL WRINUM(ENTP,IP,12,1,AS1)
ENTP(IP:)='*'//CREF(1,IP1)
IP=IP+8
ELSEIF(IEI1.EQ.24) THEN
C...(B:VA) i.e. pure B
DO 176 J=1,NT
176 CC3(J)=AS2*CC2(J)
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC3,NT,ITMAT)
CALL WRINUM(ENTP,IP,12,1,AS2)
ENTP(IP:)='*'//CREF(2,IP2)
IP=IP+8
ELSE
C...(A:B:VA), note A or B may be missing!
DO 177 J=1,NT
177 CC3(J)=CC4(J)+AS1*CC1(J)+AS2*CC2(J)
CALL WRIEXV(ENTP,IP,IVAR,JUNKN,CC3,NT,ITMAT)
IF(NOS.NE.1) THEN
CALL WRINUM(ENTP,IP,12,1,AS1)
ENTP(IP:)='*'//CREF(1,IP1)
IP=IP+8
ENDIF
IF(NOS.NE.2) THEN
CALL WRINUM(ENTP,IP,12,1,AS2)
ENTP(IP:)='*'//CREF(2,IP2)
IP=IP+8
ENDIF
ENDIF
C
ENTP(IP:IP+5)=';,,,, '
IP=IP+5
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP))
IF(IEI1.EQ.23 .OR. IEI1.EQ.27 .OR. IEI1.EQ.93) THEN
ENTP(KP:)='VA,'//ELNAM(2)(1:L2)//';'
KP=LENS(ENTP)+1
ELSE
ENTP(KP:)='VA,'//ELNAM(1)(1:L1)//';'
KP=LENS(ENTP)+1
ENDIF
GOTO 700
C...end phase with interstitials, 23, 24, 27, 28, 93, 94
ELSEIF(IEI(1).EQ.34 .OR. IEI(1).EQ.35 .OR. IEI(1).EQ.38) THEN
C...start associated model
190 STP=IEI(2)
STQ=IEI(3)
IEI1=IEI(1)
IF(IEI(4).NE.0) THEN
STP=STP/IEI(4)
STQ=STQ/IEI(4)
ENDIF
SPNAM=ELNAM(1)
IP=LENS(SPNAM)+1
CALL WRINUM(SPNAM,IP,8,-1,STP)
SPNAM(IP:)=ELNAM(2)
IP=LENS(SPNAM)+1
CALL WRINUM(SPNAM,IP,8,-1,STQ)
ENTPH=' ent_species '//SPNAM(1:IP)//SPNAM
WRITE(22,7)ENTPH(1:LENS(ENTPH))
ENTPH='ent_phase '//NAME(1:L3)//' , 1 '//ELNAM(1)
IP=LENS(ENTPH)+2
ENTPH(IP:)=ELNAM(2)//' '//SPNAM(1:LENS(SPNAM))//'; N N '
IP=LENS(ENTPH)
CALL AWRICE(22,1,1,78,'@',ENTPH(1:IP))
IRKS12=1
IRKS31=1
IRKS23=1
IF(ELNAM(1).GT.SPNAM) IRKS12=-1
IF(SPNAM.GT.ELNAM(2)) IRKS23=-1
IF(ELNAM(1).GT.ELNAM(2)) IRKS31=-1
C
ENTP='ent_parameter G('//NAME(1:L3)//','
KP=LENS(ENTP)+1
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC1(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC1(J),J=1,NT)
IF(IVAR.GT.0) CALL CHKOV(IUNKN)
ENTP(KP:)=ELNAM(1)(1:LENS(ELNAM(1)))//';0) '
IP=LENS(ENTP)+1
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC1,NT,ITMAT)
ENTP(IP:)='+'//CREF(1,IP1)
IP=IP+8
ENTP(IP:IP+5)=';,,,,'
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP+5))
C
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC2(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC2(J),J=1,NT)
IF(IVAR.GT.0) CALL CHKOV(IUNKN)
ENTP(KP:)=ELNAM(2)(1:LENS(ELNAM(2)))//';0) '
IP=LENS(ENTP)+1
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC2,NT,ITMAT)
ENTP(IP:)='+'//CREF(2,IP2)
IP=IP+8
ENTP(IP:IP+5)=';,,,,'
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP+5))
C
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
DO 192 I=1,NT
192 CC(I)=CC(I)+STP*CC1(I)+STQ*CC2(I)
ENTP(KP:)=SPNAM(1:LENS(SPNAM))//';0) '
IP=LENS(ENTP)+1
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC,NT,ITMAT)
IF(IEI(1).NE.38) THEN
CALL WRINUM(ENTP,IP,8,1,STP)
ENTP(IP:)='*'//CREF(1,IP1)
IP=IP+8
CALL WRINUM(ENTP,IP,8,1,STQ)
ENTP(IP:)='*'//CREF(2,IP2)
IP=IP+8
ENDIF
ENTP(IP:IP+5)=';,,,,'
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP+5))
IDEG=-1
NLR=3
C...excess parameters
195 CONTINUE
IDEG=IDEG+1
IF(NLR.LT.LINES) THEN
NLR=NLR+1
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
ENTP(KP:)=ELNAM(1)(1:LENS(ELNAM(1)))//','//
& SPNAM(1:LENS(SPNAM))//';0) '
IP=LENS(ENTP)+1
JP=IP
C write(*,*)'irks12',IRKS12,IDEG
IF(IRKS12.LT.ZERO .AND. MOD(IDEG,2).NE.0) THEN
DO 1951 I=1,NT
1951 CC(I)=-CC(I)
ENDIF
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC,NT,ITMAT)
IF(IP.GT.JP+9) THEN
ENTP(IP:IP+5)=';,,,,'
CALL INSDEG(ENTP,IDEG)
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP+5))
ENDIF
ENDIF
IF(NLR.LT.LINES) THEN
NLR=NLR+1
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
ENTP(KP:)=ELNAM(1)(1:LENS(ELNAM(1)))//','//
& ELNAM(2)(1:LENS(ELNAM(2)))//';0) '
IP=LENS(ENTP)+1
JP=IP
C write(*,*)'irks23',IRKS23,IDEG
IF(IRKS23.LT.ZERO .AND. MOD(IDEG,2).NE.0) THEN
DO 1952 I=1,NT
1952 CC(I)=-CC(I)
ENDIF
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC,NT,ITMAT)
IF(IP.GT.JP+9) THEN
ENTP(IP:IP+5)=';,,,,'
CALL INSDEG(ENTP,IDEG)
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP+5))
ENDIF
ENDIF
IF(NLR.LT.LINES) THEN
NLR=NLR+1
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
ENTP(KP:)=ELNAM(2)(1:LENS(ELNAM(2)))//','//
& SPNAM(1:LENS(SPNAM))//';0) '
IP=LENS(ENTP)+1
JP=IP
C write(*,*)'irks31',IRKS31,IDEG
IF(IRKS31.LT.ZERO .AND. MOD(IDEG,2).NE.0) THEN
DO 1953 I=1,NT
1953 CC(I)=-CC(I)
ENDIF
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC,NT,ITMAT)
IF(IP.GT.JP+9) THEN
ENTP(IP:IP+5)=';,,,,'
CALL INSDEG(ENTP,IDEG)
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP+5))
ENDIF
ENDIF
IF(NLR.LT.LINES .AND. (IDEG.EQ.0 .OR. IDEG.GT.2)) GOTO 195
C...ternary
IF(IDEG.EQ.2) THEN
NSKIP=0
197 IF(NLR.LT.LINES) THEN
NLR=NLR+1
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
NSKIP=NSKIP+1
IF(NSKIP.LT.3) GOTO 197
ENDIF
IF(NSKIP.GT.0) WRITE(*,*)' Ternary composition dependent',
& ' terms in the associated model ignored.'
GOTO 195
ENDIF
IF(NLR.LT.LINES) THEN
NLR=NLR+1
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
ENTP(KP:)=ELNAM(1)(1:LENS(ELNAM(1)))//','//
& ELNAM(2)(1:LENS(ELNAM(2)))//','//
& SPNAM(1:LENS(SPNAM))//';0) '
IP=LENS(ENTP)+1
JP=IP
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC,NT,ITMAT)
IF(IP.GT.JP+9) THEN
ENTP(IP:IP+5)=';,,,,'
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP+5))
ENDIF
ENDIF
IF(NLR.LT.LINES) GOTO 195
C...end associated model (34, 35 and 38)
ELSEIF(IEI(1).EQ.36 .OR. IEI(1).EQ.39) THEN
C...start ionic liquid model
300 STP=IEI(2)
STQ=IEI(3)
C WRITE(*,*)' *** Warning: model 36 and 39 not finished'
IEI1=IEI(1)
IF(IEI(4).NE.0) THEN
STP=STP/IEI(4)
STQ=STQ/IEI(4)
ENDIF
IF(NOVA.EQ.0) THEN
C...enter vacancies
WRITE(22,161)
NOVA=1
ENDIF
C...enter cation and ionin species
SPNAM=ELNAM(1)
IP=LENS(SPNAM)+1
SPNAM(IP:IP+1)='/+'
IP=IP+2
CALL WRINUM(SPNAM,IP,8,-1,STQ)
ENTPH=' ent_species '//SPNAM//' '//SPNAM
CATION=SPNAM
WRITE(22,7)ENTPH(1:LENS(ENTPH))
SPNAM=ELNAM(2)
IP=LENS(SPNAM)+1
SPNAM(IP:IP+1)='/-'
IP=IP+2
CALL WRINUM(SPNAM,IP,8,-1,STP)
ENTPH=' ent_species '//SPNAM//' '//SPNAM
WRITE(22,7)ENTPH(1:LENS(ENTPH))
ANION=SPNAM
C write(*,*)ANION,CATION,SPNAM,STP,STQ
C...phase
ENTPH='ent_phase '//NAME(1:L3)//' Y '//CATION//'; '
IP=LENS(ENTPH)+2
ENTPH(IP:)=ANION//' VA '//ELNAM(2)//'; N N '
IP=LENS(ENTPH)
CALL AWRICE(22,1,1,78,'@',ENTPH(1:IP))
IRKS12=1
IRKS31=1
IRKS23=1
C IF(ELNAM(1).GT.SPNAM) IRKS12=-1
C IF(SPNAM.GT.ELNAM(2)) IRKS23=-1
C IF(ELNAM(1).GT.ELNAM(2)) IRKS31=-1
C
C...(A+:VA)
ENTP='ent_parameter G('//NAME(1:L3)//','//CATION//':'
KP=LENS(ENTP)+1
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC1(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC1(J),J=1,NT)
IF(IVAR.GT.0) CALL CHKOV(IUNKN)
ENTP(KP:)='VA;0) '
IP=LENS(ENTP)+1
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC1,NT,ITMAT)
ENTP(IP:)='+'//CREF(1,IP1)
IP=IP+8
ENTP(IP:IP+5)=';,,,,'
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP+5))
C...(A+:B)
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC2(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC2(J),J=1,NT)
IF(IVAR.GT.0) CALL CHKOV(IUNKN)
ENTP(KP:)=ELNAM(2)(1:LENS(ELNAM(2)))//';0) '
IP=LENS(ENTP)+1
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC2,NT,ITMAT)
ENTP(IP:)='+'//CREF(2,IP2)
IP=IP+8
ENTP(IP:IP+5)=';,,,,'
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP+5))
C...(A+:B-)
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
DO 302 I=1,NT
302 CC(I)=CC(I)+STP*CC1(I)+STQ*CC2(I)
ENTP(KP:)=ANION//';0) '
IP=LENS(ENTP)+1
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC,NT,ITMAT)
CALL WRINUM(ENTP,IP,8,1,STP)
ENTP(IP:)='*'//CREF(1,IP1)
IP=IP+8
CALL WRINUM(ENTP,IP,8,1,STQ)
ENTP(IP:)='*'//CREF(2,IP2)
IP=IP+8
ENTP(IP:IP+5)=';,,,,'
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP+5))
IDEG=-1
NLR=3
C...excess parameters
305 CONTINUE
IDEG=IDEG+1
IF(NLR.LT.LINES) THEN
NLR=NLR+1
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
C..(A+:B-,VA)
ENTP(KP:)=ANION//',VA;0)'
IP=LENS(ENTP)+1
JP=IP
IF(MOD(IDEG,2).NE.0) THEN
DO 351 I=1,NT
351 CC(I)=-CC(I)
ENDIF
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC,NT,ITMAT)
IF(IP.GT.JP+9) THEN
ENTP(IP:IP+5)=';,,,,'
CALL INSDEG(ENTP,IDEG)
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP+5))
ENDIF
ENDIF
IF(NLR.LT.LINES) THEN
NLR=NLR+1
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
C..(A+:VA,B)
ENTP(KP:)='VA,'//ELNAM(2)//';0)'
IP=LENS(ENTP)+1
JP=IP
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC,NT,ITMAT)
IF(IP.GT.JP+9) THEN
ENTP(IP:IP+5)=';,,,,'
CALL INSDEG(ENTP,IDEG)
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP+5))
ENDIF
ENDIF
IF(NLR.LT.LINES) THEN
NLR=NLR+1
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
C..(A+:B-,B)
ENTP(KP:)=ANION//','//ELNAM(2)//';0)'
IP=LENS(ENTP)+1
JP=IP
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC,NT,ITMAT)
IF(IP.GT.JP+9) THEN
ENTP(IP:IP+5)=';,,,,'
CALL INSDEG(ENTP,IDEG)
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP+5))
ENDIF
ENDIF
IF(NLR.LT.LINES .AND. (IDEG.EQ.0 .OR. IDEG.GT.2)) GOTO 305
C...ternary
IF(IDEG.EQ.2) THEN
NSKIP=0
360 IF(NLR.LT.LINES) THEN
NLR=NLR+1
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
NSKIP=NSKIP+1
IF(NSKIP.LE.3) GOTO 360
ENDIF
IF(NSKIP.GT.0) WRITE(*,*)' Ternary composition dependent',
& ' terms in the ionic model ignored.'
GOTO 305
ENDIF
IF(NLR.LT.LINES) THEN
NLR=NLR+1
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
ENTP(KP:)=ANION//',VA,'//ELNAM(2)//';0)'
IP=LENS(ENTP)+1
JP=IP
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC,NT,ITMAT)
IF(IP.GT.JP+9) THEN
ENTP(IP:IP+5)=';,,,,'
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP+5))
ENDIF
ENDIF
IF(NLR.LT.LINES) GOTO 305
C...end ionic liquid model
ELSEIF(IEI(1).GE.70 .AND. IEI(1).LE.88) THEN
C...start Wagner-Shottky models, Thermo-Calc compatible: 70-88
180 CONTINUE
C TOTAL=IEI(2)+IEI(3)+IEI(4)+IEI(5)
TOTAL=ONE
IEI1=IEI(1)
C write(*,*)IEI1
IF(IEI1.EQ.79) STOP 'Model 79 and 89 do not exist'
ENTPH='ent_phase '//NAME(1:L3)//' , 4'
IP=LENS(ENTPH)+2
C
IF(IEI(2).EQ.0 .OR. IEI(3).EQ.0) THEN
WRITE(*,*)'Please use another model for ',NAME
STOP
ELSE
AS1=FLOAT(IEI(2))/TOTAL
AS2=FLOAT(IEI(3))/TOTAL
CALL WRINUM(ENTPH,IP,12,-1,AS1)
IP=IP+1
CALL WRINUM(ENTPH,IP,12,-1,AS2)
IP=IP+1
ENDIF
IF(IEI(4).NE.0) THEN
AS3=FLOAT(IEI(4))/TOTAL
CALL WRINUM(ENTPH,IP,12,-1,AS3)
IP=IP+1
NOS3=0
ELSE
AS3=ZERO
NOS3=1
ENDIF
IF(IEI(5).NE.0) THEN
AS4=FLOAT(IEI(5))/TOTAL
CALL WRINUM(ENTPH,IP,12,-1,AS4)
IP=IP+1
NOS4=0
ELSE
AS4=ZERO
NOS4=1
ENDIF
WSEA1=ELNAM(1)
WSEB1=ELNAM(2)
WSEB2=ELNAM(2)
WSEA2=ELNAM(1)
IF(IEI1.EQ.71 .OR. IEI1.EQ.74 .OR. IEI1.EQ.77) THEN
WSEB1='VA'
IF(IEI1.EQ.71) WSEA2='VA'
IF(IEI1.EQ.77) WSEB2='VA'
ELSEIF(IEI1.EQ.72 .OR. IEI1.EQ.76 .OR. IEI1.EQ.78) THEN
WSEA1='VA'
IF(IEI1.EQ.72) WSEB2='VA'
IF(IEI1.EQ.78) WSEA2='VA'
ELSEIF(IEI1.EQ.73) THEN
WSEA2='VA'
ELSEIF(IEI1.EQ.75) THEN
WSEB2='VA'
ENDIF
ENTPH(IP:IP+11)=WSEA1//' '//WSEB1//'; '//
& WSEB2//' '//WSEA2
IP=IP+12
IF(NOS3.GT.0 .AND. NOS4.GT.0) THEN
ENTPH(14+L3:14+L3)='2'
LINE=' '
JP=1
ELSE
IF(NOS3.EQ.0) THEN
ENTPH(IP:IP+3)='; '//ELNAM(1)
IP=IP+4
LINE=':'//ELNAM(1)(1:L1)
JP=L1+1
ELSE
ENTPH(14+L3:14+L3)='3'
ENDIF
IF(NOS4.EQ.0) THEN
ENTPH(IP:IP+3)='; '//ELNAM(2)
IP=IP+4
LINE(JP+1:JP+L2+1)=':'//ELNAM(2)(1:L2)
JP=JP+L2+2
ELSE
ENTPH(14+L3:14+L3)='3'
ENDIF
ENDIF
ENTPH(IP:IP+3)=';,,, '
WRITE(22,7)ENTPH(1:IP+4)
C23456789.123456789.123456789.123456789.123456789.123456789.123456789.123456789
IF(IEI1.EQ.70.OR.IEI1.EQ.80.OR.IEI1.EQ.71.OR.IEI1.EQ.81) THEN
WRITE(22,183)NAME(1:L3),ELNAM(1),ELNAM(2),ELNAM(1),ELNAM(2)
ELSEIF(IEI1.EQ.72.OR.IEI1.EQ.82) THEN
WRITE(22,183)NAME(1:L3),'VA','VA',ELNAM(1),ELNAM(2)
ELSEIF(IEI1.EQ.73.OR.IEI1.EQ.83.OR.IEI1.EQ.74.OR.IEI1.EQ.84) THEN
WRITE(22,183)NAME(1:L3),ELNAM(1),ELNAM(2),ELNAM(1),ELNAM(2)
ELSEIF(IEI1.EQ.75.OR.IEI1.EQ.85.OR.IEI1.EQ.77.OR.IEI1.EQ.87) THEN
WRITE(22,183)NAME(1:L3),ELNAM(1),'VA',ELNAM(1),ELNAM(2)
ELSEIF(IEI1.EQ.76.OR.IEI1.EQ.86.OR.IEI1.EQ.78.OR.IEI1.EQ.88) THEN
WRITE(22,183)NAME(1:L3),'VA',ELNAM(2),ELNAM(1),ELNAM(2)
ENDIF
183 FORMAT(' am_phase_description ',A,' major 1 ',
& A,':',A,':',A,':',A)
C
ENTP='ent_parameter G('//NAME(1:L3)//','
KP=LENS(ENTP)+1
LINE(JP:JP+2)=';0) '
JP=JP+3
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC1(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC1(J),J=1,NT)
IF(IVAR.GT.0) CALL CHKOV(IUNKN)
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC2(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC2(J),J=1,NT)
IF(IVAR.GT.0) CALL CHKOV(IUNKN)
C...(A1:B2:A:B)
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
IF(IEI1.EQ.72) THEN
BS1=ZERO
BS2=ZERO
WSEA1='VA'
WSEB2='VA'
ELSEIF(IEI1.EQ.76 .OR. IEI1.EQ.78) THEN
BS1=ZERO
BS2=AS1
WSEA1='VA'
WSEB2=ELNAM(2)
ELSEIF(IEI1.EQ.75 .OR. IEI1.EQ.77) THEn
BS1=AS1
BS2=ZERO
WSEA1=ELNAM(1)
WSEB2='VA'
ELSE
BS1=AS1
BS2=AS2
WSEA1=ELNAM(1)
WSEB2=ELNAM(2)
ENDIF
ENTP(KP:)=WSEA1//':'//WSEB2//LINE(1:JP)
IP=KP+JP+5
ENTTC1=ENTP
DO 185 I=1,NT
CC(I)=CC(I)+(BS1+AS3)*CC1(I)+(BS2+AS4)*CC2(I)
185 CONTINUE
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC,NT,ITMAT)
C...models 80-88 have no reference state for first parameter
IF(IEI1.LT.80 .AND. BS1+AS3.GT.ZERO) THEN
CALL WRINUM(ENTP,IP,12,1,BS1+AS3)
ENTP(IP:)='*'//CREF(1,IP1)
IP=IP+8
ENDIF
IF(IEI1.LT.80 .AND. BS2+AS4.GT.ZERO) THEN
CALL WRINUM(ENTP,IP,12,1,BS2+AS4)
ENTP(IP:)='*'//CREF(2,IP2)
IP=IP+8
ENDIF
ENTP(IP:IP+5)=';,,,, '
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP+5))
C...(A1:A2:A:B)
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
IF(IEI1.EQ.71 .OR. IEI1.EQ.73 .OR. IEI1.EQ.78) THEN
BS2=ZERO
WSEA2='VA'
ELSE
BS2=AS2
WSEA2=ELNAM(1)
ENDIF
ENTP(KP:)=WSEA1//':'//WSEA2//LINE(1:JP)
IP=KP+JP+5
ENTTC2=ENTP
DO 186 I=1,NT
186 CC(I)=CC(I)+(BS1+BS2+AS3)*CC1(I)+AS4*CC2(I)
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC,NT,ITMAT)
IF(BS1+BS2+AS3.GT.ZERO) THEN
CALL WRINUM(ENTP,IP,12,1,BS1+BS2+AS3)
ENTP(IP:)='*'//CREF(1,IP1)
IP=IP+8
ENDIF
IF(NOS4.EQ.0) THEN
CALL WRINUM(ENTP,IP,12,1,AS4)
ENTP(IP:)='*'//CREF(2,IP2)
IP=IP+8
ENDIF
ENTP(IP:IP+5)=';,,,, '
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP+5))
C...(B1:B2:A:B), note B1 or B2 can be vacancies
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
IF(IEI1.EQ.71 .OR. IEI1.EQ.74 .OR. IEI1.EQ.77) THEN
BS1=ZERO
WSEB1='VA'
BS2=AS2
ELSE
BS1=AS1
WSEB1=ELNAM(2)
BS2=AS2
ENDIF
ENTP(KP:)=WSEB1//':'//WSEB2//LINE(1:JP)
IP=KP+JP+5
ENTTC3=ENTP
DO 187 I=1,NT
187 CC(I)=CC(I)+AS3*CC1(I)+(BS1+BS2+AS4)*CC2(I)
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC,NT,ITMAT)
IF(NOS3.EQ.0) THEN
CALL WRINUM(ENTP,IP,12,1,AS3)
ENTP(IP:)='*'//CREF(1,IP1)
IP=IP+8
ENDIF
IF(BS1+BS2+AS4.GT.ZERO) THEN
CALL WRINUM(ENTP,IP,12,1,BS1+BS2+AS4)
ENTP(IP:)='*'//CREF(2,IP2)
ENDIF
ENTP(IP+8:IP+12)=';,,,, '
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP+13))
C...(B1:A2:A:B)
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
IF(IEI1.EQ.71 .OR. IEI1.EQ.73 .OR. IEI1.EQ.78) THEN
BS2=ZERO
ELSE
BS2=AS2
ENDIF
ENTP(KP:)=WSEB1//':'//WSEA2//LINE(1:JP)
IP=KP+JP+5
DO 188 I=1,NT
188 CC(I)=CC(I)+(BS2+AS3)*CC1(I)+(BS1+AS4)*CC2(I)
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC,NT,ITMAT)
IF(BS2+AS3.GT.ZERO) THEN
CALL WRINUM(ENTP,IP,12,1,BS2+AS3)
ENTP(IP:)='*'//CREF(1,IP1)
IP=IP+8
ENDIF
IF(BS1+AS4.GT.ZERO) THEN
CALL WRINUM(ENTP,IP,12,1,BS1+AS4)
ENTP(IP:)='*'//CREF(2,IP2)
ENDIF
ENTP(IP+8:IP+12)=';,,,, '
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP+13))
JREF=6
C...ppppppuuuuuuuuuhhhhhhhhh, all Gibbs energies of formation
IDEG=0
IMAG=0
ENTP(15:15)='L'
189 IF(JREF.GE.LINES) GOTO 800
C write(*,*)'Cannot yet convert excess terms for model',IEI(1)
C IMAG=IMAG+1
IF(IMAG.EQ.4) THEN
IMAG=0
IDEG=IDEG+1
IF(IDEG.EQ.1) LINE(JP-3:JP)=';1) '
IF(IDEG.EQ.2) LINE(JP-3:JP)=';2) '
ENDIF
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
IF(IMAG.EQ.0) THEN
ENTP(KP:)=WSEA1//','//WSEB1//':'//WSEB2//LINE(1:JP)
ELSEIF(IMAG.EQ.1) THEN
ENTP(KP:)=WSEA1//','//WSEB1//':'//WSEA2//LINE(1:JP)
ELSEIF(IMAG.EQ.2) THEN
ENTP(KP:)=WSEA1//':'//WSEB2//','//WSEA2//LINE(1:JP)
ELSEIF(IMAG.EQ.3) THEN
ENTP(KP:)=WSEB1//':'//WSEB2//','//WSEA2//LINE(1:JP)
ENDIF
IP=KP+JP+8
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC,NT,ITMAT)
IF(IVAR.GT.50) WRITE(*,721)
ENTP(IP:IP+4)=';,,, '
IP=IP+4
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP))
JREF=JREF+1
IMAG=IMAG+1
GOTO 189
C ELSE
C WRITE(*,*)'Model ',IEI(1),' for ',NAME,' not implemented yet'
C STOP 'Abnormal ending code 644FF0AC (just for fun)'
ENDIF
GOTO 800
C...end Wagner-Shottky models
C
C....excess part of some models
700 IDEG=-1
ENTP(15:15)='L'
710 IDEG=IDEG+1
IF(IDEG+JREF.GE.LINES) GOTO 800
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
ENTP(KP:)=CHAR(IDEG+ICHAR('0'))//') '
IP=KP+3
C...correct for alphabetical order of elements
IF(IRKS.LT.ZERO .AND. MOD(IDEG,2).NE.0) THEN
DO 720 I=1,NT
CC(I)=-CC(I)
720 CONTINUE
ENDIF
CALL WRIEXV(ENTP,IP,IVAR,IUNKN,CC,NT,ITMAT)
IF(IVAR.GT.50) WRITE(*,721)
721 FORMAT(' *** Warning: too many optimizing variables')
ENTP(IP:IP+4)=';,,, '
IP=IP+4
CALL AWRICE(22,1,1,78,'@',ENTP(1:IP))
GOTO 710
C
C...magnetic terms
798 FORMAT(' am_phase_description ',A,' magn -3 0.280,,,,')
799 FORMAT(' am_phase_description ',A,' magn -1 0.400,,,,')
800 CONTINUE
IF(NME.NE.0) THEN
IF(NF.EQ.280) THEN
WRITE(22,798)NAME
ELSE
WRITE(22,799)NAME
ENDIF
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
JP=LENS(ENTTC1)+2
IP=JP
C magnetic parameters
C ENTTC1(15:17)=' TC'
ENTTC1(13:15)=' TC'
CALL WRIEX(ENTTC1,IP,CC(1),1,1)
ENTTC1(IP:IP+4)=';,,, '
WRITE(22,801)ENTTC1(1:IP+4)
801 FORMAT(2X,A)
IP=JP
ENTTC1(13:15)=' BM'
CALL WRIEX(ENTTC1,IP,CC(2),1,1)
ENTTC1(IP:IP+4)=';,,, '
WRITE(22,801)ENTTC1(1:IP+4)
IF(NME.GT.1) THEN
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
JP=LENS(ENTTC2)+2
IP=JP
ENTTC2(13:15)=' TC'
CALL WRIEX(ENTTC2,IP,CC(1),1,1)
ENTTC2(IP:IP+4)=';,,, '
WRITE(22,801)ENTTC2(1:IP+4)
IP=JP
ENTTC2(13:15)=' BM'
CALL WRIEX(ENTTC2,IP,CC(2),1,1)
ENTTC2(IP:IP+4)=';,,, '
WRITE(22,801)ENTTC2(1:IP+4)
ENDIF
IF(NME.GT.2) THEN
C...magnetic interaction terms
KP=INDEX(ENTTC1,':')
IF(KP.GT.0) THEN
LP=INDEX(ENTTC1(KP+1:),':')+KP
IF(LP.GT.KP) THEN
KP=LP+1
ELSE
KP=KP+1
ENDIF
ELSE
KP=INDEX(ENTTC1,',')+1
ENDIF
LP=INDEX(ENTTC2,';')-1
MP=INDEX(ENTTC1,';')
ENTTC1(MP:)=','//ENTTC2(KP:LP)//';0) '
KP=LENS(ENTTC1)-1
IDEG=-1
810 IDEG=IDEG+1
IF(IDEG+3.LE.NME) THEN
CALL IGNCOM(21,DLIN)
READ(DLIN,40)IUNKN,(CC(J),J=1,NT)
C WRITE(22,41)IUNKN,(CC(J),J=1,NT)
C...correct for alphabetical order of elements
IF(IRKS.LT.ZERO .AND. MOD(IDEG,2).NE.0) THEN
DO 820 I=1,NT
CC(I)=-CC(I)
820 CONTINUE
ENDIF
ENTTC1(KP:KP)=CHAR(IDEG+ICHAR('0'))
IP=KP+3
ENTTC1(13:15)=' TC'
CALL WRIEX(ENTTC1,IP,CC(1),1,1)
ENTTC1(IP:IP+4)=';,,, '
WRITE(22,801)ENTTC1(1:IP+4)
IP=KP+3
ENTTC1(13:15)=' BM'
CALL WRIEX(ENTTC1,IP,CC(2),1,1)
ENTTC1(IP:IP+4)=';,,, '
WRITE(22,801)ENTTC1(1:IP+4)
GOTO 810
ENDIF
ENDIF
ENDIF
GOTO 110
C
900 CONTINUE
CLOSE(21)
WRITE(22,910)SYS,SYS
910 FORMAT(' save ',A/' go parrot'/' set_output_level 1 Y Y N N N'/
& ' create ',A/' go sys'/' set_interactive')
END
SUBROUTINE WRIEX(BIG,IP,CC,NT,ITMAT)
C...to write a reference parameter
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
PARAMETER (EPS=1.0D-20)
CHARACTER BIG*(*)
DIMENSION CC(*)
C...no low T limit
BIG(IP:IP+8)=' 298.15 '
IP=IP+9
IF(NT.GT.3) STOP 'not implemented NT>3'
IF(ITMAT.EQ.0) THEN
C... convert from HL to SGTE
CC(2)=CC(3)-CC(2)
CC(3)=-CC(3)
ENDIF
IF(NT.GT.0 .AND. ABS(CC(1)).GT.EPS) THEN
CALL WRINUM(BIG,IP,12,1,CC(1))
ENDIF
IF(NT.GT.1 .AND. ABS(CC(2)).GT.EPS) THEN
CALL WRINUM(BIG,IP,12,1,CC(2))
BIG(IP:IP+1)='*T'
IP=IP+2
ENDIF
IF(NT.GT.2 .AND. ABS(CC(3)).GT.EPS) THEN
CALL WRINUM(BIG,IP,12,1,CC(3))
BIG(IP:IP+7)='*T*LN(T)'
IP=IP+8
ENDIF
900 RETURN
END
SUBROUTINE WRIEXV(BIG,IP,IVAR,IUNKN,CC,NT,ITMAT)
C...to write a parameter including possible V variables for optimizing
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
PARAMETER (EPS=1.0D-20)
CHARACTER BIG*(*)
DIMENSION CC(*),IUNKN(6)
NOP=0
LP=IP
C...no low T limit
BIG(IP:IP+8)=' 298.15 '
IP=IP+9
IF(NT.GT.6) STOP 'not implemented NT>6'
IF(ITMAT.EQ.0) THEN
C... convert from HL to SGTE
CC(2)=CC(3)-CC(2)
CC(3)=-CC(3)
CC(4)=-0.5*CC(4)
CC(5)=-0.5*CC(5)
CC(6)=-CC(6)/6.0D0
ENDIF
17 FORMAT(I7,' ',6I1)
IF(NT.GT.0 .AND. (ABS(CC(1)).GT.EPS .OR. IUNKN(1).EQ.1)) THEN
CALL WRIVON(BIG,IP,IUNKN(1),IVAR,NOP,CC(1))
ENDIF
IF(NT.GT.1 .AND. (ABS(CC(2)).GT.EPS .OR. IUNKN(2).EQ.1)) THEN
CALL WRIVON(BIG,IP,IUNKN(2),IVAR,NOP,CC(2))
BIG(IP:IP+1)='*T'
IP=IP+2
ENDIF
IF(NT.GT.2 .AND. (ABS(CC(3)).GT.EPS. OR. IUNKN(3).EQ.1)) THEN
CALL WRIVON(BIG,IP,IUNKN(3),IVAR,NOP,CC(3))
BIG(IP:IP+7)='*T*LN(T)'
IP=IP+8
ENDIF
IF(NT.GT.3 .AND. ABS(CC(4)).GT.EPS .OR. IUNKN(4).EQ.1) THEN
CALL WRIVON(BIG,IP,IUNKN(4),IVAR,NOP,CC(4))
BIG(IP:IP+4)='*T**2'
IP=IP+5
ENDIF
IF(NT.GT.4 .AND. ABS(CC(5)).GT.EPS .OR. IUNKN(5).EQ.1) THEN
CALL WRIVON(BIG,IP,IUNKN(5),IVAR,NOP,CC(5))
C CALL WRINUM(BIG,IP,12,1,CC(6))
BIG(IP:IP+7)='*T**(-1)'
IP=IP+8
ENDIF
IF(NT.GT.5 .AND. ABS(CC(6)).GT.EPS .OR. IUNKN(6).EQ.1) THEN
CALL WRIVON(BIG,IP,IUNKN(6),IVAR,NOP,CC(6))
BIG(IP:IP+4)='*T**3'
IP=IP+5
ENDIF
IF(NOP.GT.0) WRITE(22,810)
810 FORMAT(' back')
900 RETURN
END
SUBROUTINE WRIVON(BIG,IP,II,IVAR,NOP,CC)
C...write coefficient or V
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CHARACTER BIG*(*)
PARAMETER (EPS=1.0D-20)
IF(IVAR.EQ.0 .OR. II.EQ.0) THEN
IF(ABS(CC).GT.EPS) CALL WRINUM(BIG,IP,12,1,CC)
ELSEIF(IVAR.GT.0) THEN
IF(ABS(CC).GT.EPS) THEN
IF(NOP.EQ.0) THEN
WRITE(22,800)IVAR,CC,CC
NOP=1
ELSE
WRITE(22,801)IVAR,CC,CC
ENDIF
ELSEIF(NOP.EQ.0) THEN
WRITE(22,802)IVAR
NOP=1
ELSE
WRITE(22,803)IVAR
ENDIF
BIG(IP:IP+1)='+V'
IP=IP+2
IF(IVAR.LT.10) THEN
BIG(IP:IP)=CHAR(IVAR+ICHAR('0'))
IP=IP+1
ELSE
JVAR=IVAR/10
KVAR=MOD(IVAR,10)
BIG(IP:IP+1)=CHAR(JVAR+ICHAR('0'))//
& CHAR(KVAR+ICHAR('0'))
IP=IP+2
ENDIF
IF(IVAR.GT.0) IVAR=IVAR+1
ENDIF
800 FORMAT(' goto parrot'/' set_optimizing_variable ',I2,' ',
& 2(1PE16.8))
801 FORMAT(' set_optimizing_variable ',I2,' ',2(1PE16.8))
802 FORMAT(' goto parrot'/' set_fix_variable ',I2,' 0.0 ')
803 FORMAT(' set_fix_variable ',I2,',, ')
900 RETURN
END
SUBROUTINE WRICC(BIG,IP,CC,NTU,NTPOW,ITMAT)
C...to write a function
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CHARACTER BIG*(*)
DIMENSION CC(*),NTPOW(*)
PARAMETER (EPS=1.0D-20)
C IF(NTU.NE.9) STOP 'Cannot convert when NTU not 9'
IF(ITMAT.EQ.0) THEN
IF(NTU.GT.9) STOP 'Cannot handle NTU>9 and ITMAT=0'
C... convert from HL to SGTE
CC(3)=CC(4)-CC(3)
CC(4)=-CC(4)
CC(5)=-0.5*CC(5)
CC(6)=-0.5*CC(6)
CC(7)=-CC(7)/6.0D0
CC(8)=-CC(8)/12.0D0
CC(9)=-CC(9)/42.0D0
CC(10)=-CC(10)/9.0D1
ENDIF
CALL WRINUM(BIG,IP,12,1,CC(2))
IF(ABS(CC(3)).GT.EPS) THEN
CALL WRINUM(BIG,IP,12,1,CC(3))
BIG(IP:IP+1)='*T'
IP=IP+2
ENDIF
IF(ABS(CC(4)).GT.EPS) THEN
CALL WRINUM(BIG,IP,12,1,CC(4))
BIG(IP:IP+7)='*T*LN(T)'
IP=IP+8
ENDIF
IF(ABS(CC(5)).GT.EPS) THEN
CALL WRINUM(BIG,IP,12,1,CC(5))
BIG(IP:IP+4)='*T**2'
IP=IP+5
ENDIF
IF(ABS(CC(6)).GT.EPS) THEN
CALL WRINUM(BIG,IP,12,1,CC(6))
BIG(IP:IP+7)='*T**(-1)'
IP=IP+8
ENDIF
IF(ABS(CC(7)).GT.EPS) THEN
CALL WRINUM(BIG,IP,12,1,CC(7))
BIG(IP:IP+4)='*T**3'
IP=IP+5
ENDIF
IF(ABS(CC(8)).GT.EPS) THEN
CALL WRINUM(BIG,IP,12,1,CC(8))
BIG(IP:IP+4)='*T**4'
IP=IP+5
ENDIF
IF(ABS(CC(9)).GT.EPS) THEN
CALL WRINUM(BIG,IP,12,1,CC(9))
BIG(IP:IP+4)='*T**7'
IP=IP+5
ENDIF
IF(ABS(CC(10)).GT.EPS) THEN
CALL WRINUM(BIG,IP,12,1,CC(10))
BIG(IP:IP+7)='*T**(-9)'
IP=IP+8
ENDIF
IF(NTU.GT.9) THEN
KK=0
800 KK=KK+1
IF(KK.GT.NTU-9) GOTO 890
IF(ABS(CC(10+KK)).GT.EPS) THEN
CALL WRINUM(BIG,IP,12,1,CC(10+KK))
KP=NTPOW(KK)
C write(*,*)(NTPOW(I),I=1,5)
IF(KP.LT.0) THEN
BIG(IP:IP+5)='*T**(-'
IP=IP+6
KP=-KP
ELSEIF(KP.GT.0) THEN
BIG(IP:IP+3)='*T**'
IP=IP+4
ELSE
STOP'Zero power in NTPOW???'
ENDIF
IF(KP.GE.100) THEN
STOP'Power>100 in NTPOW???'
ELSEIF(KP.GE.10) THEN
KL=KP/10
BIG(IP:IP)=CHAR(KL+ICHAR('0'))
IP=IP+1
KP=KP-10*KL
ENDIF
BIG(IP:IP)=CHAR(KP+ICHAR('0'))
IP=IP+1
IF(NTPOW(KK).LT.0) THEN
BIG(IP:IP)=')'
IP=IP+1
ENDIF
ENDIF
GOTO 800
ENDIF
890 BIG(IP:IP+1)='; '
IP=IP+2
900 RETURN
END
SUBROUTINE CHKPHN(NAME)
CHARACTER NAME*(*),CH1*1
CALL CAPSON(NAME)
C...convert illegal characters to _
K=LENS(NAME)
10 M=INDEX(NAME,' ')
IF(M.GT.0 .AND. M.LT.K) THEN
NAME(M:M)='_'
GOTO 10
ENDIF
DO 20 I=1,K
CH1=NAME(I:I)
IF(.NOT.((CH1.GE.'A' .AND. CH1.LE.'Z') .OR.
& (CH1.GE.'0' .AND. CH1.LE.'9'))) NAME(I:I)='_'
20 CONTINUE
IF(NAME(1:1).LT.'A' .OR. NAME(1:1).GT.'Z') NAME(1:1)='Q'
900 RETURN
END
SUBROUTINE CHKOV(IUNKN)
DIMENSION IUNKN(6)
DO 10 I=1,6
IF(IUNKN(I).GT.0) GOTO 910
10 CONTINUE
900 RETURN
910 WRITE(*,*)
&'*** Warning: A variable which cannot be optimized found'
WRITE(22,911)
911 FORMAT('@@$ Cannot optimize the variable above')
GOTO 900
END
SUBROUTINE INSDEG(STR,IDEG)
CHARACTER STR*(*)
IF(IDEG.NE.0) THEN
K=INDEX(STR,';')
IF(K.GT.0) THEN
STR(K+1:K+1)=CHAR(ICHAR('0')+IDEG)
ELSE
STOP 'MISSING ;'
ENDIF
ENDIF
RETURN
END
SUBROUTINE IGNCOM(INF,LINE)
CHARACTER LINE*(*)
1 READ(INF,10)LINE
10 FORMAT(A)
WRITE(22,11)LINE(1:LENS(LINE))
11 FORMAT('@@ ',A)
IF(LINE(1:1).EQ.'$') GOTO 1
RETURN
END
SUBROUTINE FNIC(FUNA)
CHARACTER FUNA*(*),CH1*1
K=LENS(FUNA)
CH1=FUNA(K:K)
IF(CH1.LE.'Z') THEN
FUNA(K:K)=CHAR(ICHAR(CH1)+1)
ELSE
FUNA(K-1:K-1)=CHAR(ICHAR(FUNA(K-1:K-1))+1)
FUNA(K:K)='A'
ENDIF
RETURN
END
C Extracted from METLIB
C ====================================
INTEGER FUNCTION LENS(STR)
C...SUBROUTINE LENS
C...TO FIND THE LENGTH OF A STRING STRIPPED FROM TRAILING SPACES
CHARACTER STR*(*)
L=LEN(STR)
100 IF(LGT(STR(L:L),' ')) GOTO 900
L=L-1
IF(L.GT.0) GOTO 100
900 LENS=L
RETURN
END
C ============
SUBROUTINE CAPSON(LINE)
C...Converts lower case letters in LINE to upper case
C INDEPENDENT OF BIGLET
CHARACTER LINE*(*),CH1*1
L=LENS(LINE)
IDIFF=ICHAR('A')-ICHAR('a')
DO 10 J=1,L
CH1=LINE(J:J)
IF(LGE(CH1,'a') .AND. LLE(CH1,'z'))
$ LINE(J:J)=CHAR(ICHAR(CH1)+IDIFF)
10 CONTINUE
RETURN
END
C ============
LOGICAL FUNCTION EOLCH(STR,IP)
C SUBROUTINE EOLCH(STR,IP)
C$...TO SKIP SPACES FROM IP. RETURNS .TRUE. IF ONLY SPACES
C....MODIFIED TO SKIP TAB CHARACTERS ALSO
CHARACTER STR*(*)
PARAMETER (ITAB=9)
EOLCH=.FALSE.
IF(IP.LE.0) IP=1
100 IF(IP.GT.LEN(STR)) GOTO 110
IF(STR(IP:IP).NE.' ' .AND. ICHAR(STR(IP:IP)).NE.ITAB) GOTO 900
IP=IP+1
GOTO 100
110 EOLCH=.TRUE.
900 RETURN
END
C ==============
SUBROUTINE WRINUM(STR,IP,NNW,JSIGN,VALUE)
C...EDITS A REAL NUMBER INTO STR WITH LEAST NUMBER OF DIGITS
C NNW IS MAXIMUM NUMBER OF SIGNIFICANT DIGITS (00 INDICATES THAT + SIGN SHOULD BE WRITTEN
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CHARACTER STR*(*),CSTR*20,CFRMT*11
PARAMETER (ZERO=0.0D0,TEN=1.0D1,EPS=1.0D-7)
CSTR=' '
NW=NNW
IF(NW.LE.0) NW=1
IF(NW.GT.15) NW=15
IF(IP+NW.GT.LEN(STR)) GOTO 910
IF(VALUE.EQ.ZERO) THEN
IF(JSIGN.GT.0) THEN
STR(IP:IP+1)='+0'
IP=IP+2
ELSE
STR(IP:IP)='0'
IP=IP+1
ENDIF
GOTO 900
ELSEIF(VALUE.LT.ZERO) THEN
STR(IP:IP)='-'
IP=IP+1
ELSEIF(JSIGN.GT.0) THEN
STR(IP:IP)='+'
IP=IP+1
ENDIF
CC=ABS(VALUE)
XX=LOG10(CC+EPS)
K=INT(XX)
IF(XX.GT.ZERO) K=K+1
IF(K.GE.NW .OR. K.LT.-2) THEN
C...FLOATING FORMAT
WRITE(CFRMT,100)NW+5,NW-1
100 FORMAT('(1P,E',I2,'.',I2,')')
WRITE(CSTR,CFRMT)CC
JJ=NW+1
150 IF(CSTR(JJ:JJ).EQ.'0') THEN
JJ=JJ-1
GOTO 150
ENDIF
IF(CSTR(JJ:JJ).EQ.'.') JJ=JJ-1
STR(IP:IP+JJ-1)=CSTR(1:JJ)
STR(IP+JJ:IP+JJ+3)=CSTR(NW+2:NW+5)
IP=IP+JJ+4
ELSE
C...FIXED FORMAT
NWD=NW-K
WRITE(CFRMT,200)MAX(NW,NWD)+1,NWD
200 FORMAT('(F',I2,'.',I2,') ')
WRITE(CSTR,CFRMT)CC
JJ=MAX(NW,NWD)+1
250 IF(CSTR(JJ:JJ).EQ.'0') THEN
JJ=JJ-1
GOTO 250
ENDIF
IF(CSTR(JJ:JJ).EQ.'.') JJ=JJ-1
STR(IP:IP+JJ-1)=CSTR(1:JJ)
IP=IP+JJ
ENDIF
900 RETURN
910 CALL ST2ERR(1268,'WRINUM','OVERFLOW IN OUTPUT FORMAT')
GOTO 900
END
C =========
SUBROUTINE AWRICE(KOU,MARG1,MARG2,KOL1,LFCHR,STRING)
C...ROUTINE TO WRITE A CHARACTER OVER SEVERAL LINES
C SPLIT UP AT ACCEPTABLE PORTIONS OR AT LFCHR
C ENTRY: KOU is output unit
C MARG1 is left margin at first line (NOTE! ZERO MEANS NO MARGINAL)
C MARG2 is left margin for subsequent lines
C LFCHR is a character which forces new line
C KOL1 is number of characters per line
C STRING is character to be written
CHARACTER STRING*(*),CH1*1,CH2*1,MARGIN*41,LFCHR*1
DATA MARGIN/' '/
IF(KOU.LE.0) GOTO 900
MARG=MARG1+1
IF(MARG.LT.1) MARG=1
IF(MARG.GT.41) MARG=41
MARGB=MARG2+1
IF(MARGB.LT.1) MARGB=1
IF(MARGB.GT.41) MARGB=41
KOL=KOL1-MARG+1
IF(KOL.LE.0 .OR. KOL1-MARGB+1.LE.0) GOTO 910
IP=1
LMAX=LENS(STRING)
100 CONTINUE
IF(LMAX-IP+1.LT.KOL) THEN
C... Print to last character or LFCHR and exit
110 IF(IP.GT.LMAX)GOTO 900
JJ=INDEX(STRING(IP:LMAX),LFCHR)
IF(JJ.GT.0) THEN
LAST=IP+JJ-2
IF(IP.GT.LAST)THEN
WRITE(KOU,500)MARGIN(1:MARG)
ELSE
WRITE(KOU,500)MARGIN(1:MARG),STRING(IP:LAST)
ENDIF
MARG=MARGB
KOL=KOL1-MARG+1
IP=IP+JJ
GOTO 110
ELSEIF(IP.LE.LMAX) THEN
WRITE(KOU,500)MARGIN(1:MARG),STRING(IP:LMAX)
ENDIF
GOTO 900
ELSE
C... Search for a natural place to split the line
C Never at a letter or digit
C Never at a + or - preceeded by E (may be an exponent)
C Never at a . preceeded by a digit (may be a decimal point)
C Never at a ( or ) or # (terminator of symbols!)
LAST=IP+KOL-2
JJ=INDEX(STRING(IP:LAST),LFCHR)
IF(JJ.GT.0 .AND. JJ.LT.KOL) THEN
LAST=IP+JJ-2
IF(IP.GT.LAST)THEN
WRITE(KOU,500)MARGIN(1:MARG)
ELSE
WRITE(KOU,500)MARGIN(1:MARG),STRING(IP:LAST)
ENDIF
IP=LAST+2
GOTO 230
ENDIF
200 LAST=LAST-1
IF(LAST.EQ.IP) THEN
C... No natural place to split, write maximum
LAST=IP+KOL-1
GOTO 220
ENDIF
CH1=STRING(LAST:LAST)
C...DO NOT BREAK INSIDE A WORD OR A NUMBER OPENING
C NOTE: LGE AND LLE IS VERY SLOW ON IBM MAINFRAMES (EBCDIC)
C PARENTHESIS, MULTIPLICATION OR DIVISION
IF(LGE(CH1,'A') .OR.
$ (CH1.GE.'0' .AND. CH1.LE.'9') .OR.
$ CH1.EQ.'(' .OR. CH1.EQ.')' .OR. CH1.EQ.'#' .OR.
$ CH1.EQ.'.' .OR. CH1.EQ.'*' .OR. CH1.EQ.'/') GOTO 200
CH2=STRING(LAST-1:LAST-1)
C...DO NOT BREAK AT EXPONENT (E+ OR E-) OR DECIMAL POINT PRECEDED BY NUMBER
IF( ( (CH1.EQ.'+' .OR. CH1.EQ.'-') .AND.
$ (CH2.EQ.'E' .OR. CH2.EQ.'(') ) .OR.
$ (CH1.EQ.'.' .AND. (CH2.GE.'0' .AND. CH2.LE.'9') ))
$ GOTO 200
C...MAKE CERTAIN THAT SIGN IS ON SAME LINE AS NUMBER
IF(CH1.EQ.'+' .OR. CH1.EQ.'-') LAST=LAST-1
C
C $ (CH1.EQ.'.' .AND. (LGE(CH2,'0') .AND. LLE(CH2,'9')) ))
220 WRITE(KOU,500)MARGIN(1:MARG),STRING(IP:LAST)
IP=LAST+1
C220 WRITE(KOU,500)MARGIN(1:MARG),STRING(IP:LAST-1)
C IP=LAST
230 MARG=MARGB
IF(KOL.EQ.15) GOTO 900
KOL=KOL1-MARG+1
ENDIF
500 FORMAT(A,A)
GOTO 100
900 RETURN
910 CALL ST2ERR(1050,'AWRICE','LEFT MARGIN EXCEEDS RIGHT MARGIN')
GOTO 900
END
SUBROUTINE ST2ERR(IERR,SUBR,MESS)
CHARACTER SUBR*(*),MESS*(*)
RETURN
END