C
C-------------------------------------------------------------------------
C
C Program to replace PARROT V1-V99 with numeric value in a TDB file
C Copyright 2002 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
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CHARACTER LINE*100,LINJE*200,V9(9)*2,V50(91)*3
CHARACTER FIL*50,PHASES(100)*24,ORD*24,DIS*24
DIMENSION V(100)
LOGICAL SG1ERR,EOLCH
DATA V9/'V1','V2','V3','V4','V5','V6','V7','V8','V9'/
DATA V50/
& 'V10','V11','V12','V13','V14','V15','V16','V17','V18','V19',
& 'V20','V21','V22','V23','V24','V25','V26','V27','V28','V29',
& 'V30','V31','V32','V33','V34','V35','V36','V37','V38','V39',
& 'V40','V41','V42','V43','V44','V45','V46','V47','V48','V49',
& 'V50','V51','V52','V53','V54','V55','V56','V57','V58','V59',
& 'V60','V61','V62','V63','V64','V65','V66','V67','V68','V69',
& 'V70','V71','V72','V73','V74','V75','V76','V77','V78','V79',
& 'V80','V81','V82','V83','V84','V85','V86','V87','V88','V89',
& 'V90','V91','V92','V93','V94','V95','V96','V97','V98','V99',
& 'V00'/
C
DO 3 I=1,100
3 V(I)=0.0D0
C
WRITE(*,5)
5 FORMAT(//' This program replaces the variables V1 to V99'/
& ' in a list file from GES with their values. Note that the'/
& ' output file needs editing afterwards'/
& ' Output is written on a new file with same name as input file'/
& ' but with extention .NOV')
WRITE(*,10)
READ(*,20)FIL
10 FORMAT(/'GES LIST FILE NAME: ')
20 FORMAT(A)
OPEN(21,FILE=FIL,ACCESS='SEQUENTIAL',STATUS='OLD')
NPH=0
NV=0
WRITE(*,*)'OBTAINING VALUES FOR V'
NL=0
NLS=0
NLV=0
30 CALL RESERR
READ(21,20,END=90)LINE
NL=NL+1
IF(LINE(1:1).EQ.'$') GOTO 30
IF(LINE(6:6).EQ.'V') THEN
IPOS=7
CALL GETINT(LINE,IPOS,IV)
IF(SG1ERR(IERR)) GOTO 30
IF(IV.LT.0 .OR. IV.GT.99) GOTO 30
CALL GETINT(LINE,IPOS,I)
IF(I.NE.48000000) GOTO 30
IF(NLV.EQ.0) NLV=NL
CALL GETREL(LINE,IPOS,V(IV))
NV=NV+1
IF(IV.LT.10) WRITE(*,40)IV,V(IV)
IF(IV.GE.10) WRITE(*,41)IV,V(IV)
40 FORMAT(' V',I1,' = ',E15.8)
41 FORMAT(' V',I2,' = ',E15.8)
ELSEIF(NLV.GT.0 .AND. NLS.EQ.0) THEN
NLS=NL-1
ENDIF
C...warning about phase orders
IF(LINE(1:7).EQ.' PHASE ') THEN
K=INDEX(LINE(8:),' ')+7
NPH=NPH+1
PHASES(NPH)=LINE(8:K)
ENDIF
K=INDEX(LINE,' DIS_PART ')
IF(K.GT.0) THEN
L=INDEX(LINE(K+10:),',')+K+9
DIS=LINE(K+10:L-1)
L=INDEX(LINE,'_DESCRIPTION ')+13
ORD=LINE(L:K-1)
DO 50 K=1,NPH
IF(PHASES(K).EQ.ORD) GOTO 30
50 CONTINUE
WRITE(*,*)' *** WARNING: Rearrange phases so ',
& ORD(1:LENS(ORD)),' comes before ',DIS(1:LENS(DIS))
ENDIF
GOTO 30
C
90 CONTINUE
IF(NV.EQ.0) THEN
WRITE(*,*)'No variables to replace'
GOTO 500
ENDIF
C
C...rewind and start replacing V
C
REWIND(21)
K=INDEX(FIL,'.')
IF(K.LE.0) THEN
K=LENS(FIL)
FIL(K+1:)='.NOV'
ELSE
FIL(K+1:)='NOV'
ENDIF
OPEN(22,FILE=FIL,ACCESS='SEQUENTIAL',STATUS='UNKNOWN')
NL=0
100 READ(21,20,END=500)LINE
NL=NL+1
LINJE=LINE
I=1
IF(EOLCH(LINE,I)) GOTO 300
IF(LINE(I:I).EQ.'$') GOTO 300
200 CONTINUE
LINJE=LINE
C...SKIP LINES WHERE V ARE STORED
IF(NL.GE.NLV .AND. NL.LE.NLS) THEN
K=MAX(LENS(LINJE),1)
WRITE(22,201)LINJE(1:K)
201 FORMAT('$ ',A)
GOTO 100
ENDIF
IF(INDEX(LINE,'V').EQ.0) GOTO 300
IPOS1=1
DO 210 I=1,9
K=INDEX(LINE,V9(I))
IF(K.GT.0.AND.(LINE(K+2:K+2).LT.'0'.OR.LINE(K+2:K+2).GT.'9'))
& CALL SUBSTV(LINE,LINJE,K,IPOS1,V9(I),V(I))
IF(INDEX(LINE,'V').EQ.0) GOTO 300
210 CONTINUE
IPOS1=1
DO 220 I=1,91
K=INDEX(LINE,V50(I))
IF(K.GT.0) CALL SUBSTV(LINE,LINJE,K,IPOS1,V50(I),V(I+9))
IF(INDEX(LINE,'V').EQ.0) GOTO 300
220 CONTINUE
300 K=MAX(LENS(LINJE),1)
IF(K.LE.78) THEN
WRITE(22,310)LINJE(1:K)
ELSE
M=78
305 M=M-1
IF(LINJE(M:M).NE.' ') GOTO 305
WRITE(22,310)LINJE(1:M)
WRITE(22,320)LINJE(M+1:K)
310 FORMAT(A)
320 FORMAT(10X,A)
ENDIF
GOTO 100
500 WRITE(*,*)'Read ',NL,' lines'
800 CONTINUE
810 CONTINUE
CLOSE(21)
CLOSE(22)
C...sorting functions no longer needed
C CALL SORTF(FIL)
write(KOU,820)FIL
820 FORMAT(' Output on ',A)
END
SUBROUTINE SUBSTV(LIN1,LIN2,K,IPOS,NAME,VALUE)
C...replacing V with numbers
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CHARACTER LIN1*(*),LIN2*(*),NAME*(*),CH1*1,LOLIN*80
PARAMETER (ONE=1.0D0)
LOLIN=LIN1
IPOS=K+LENS(NAME)
IF(LIN1(IPOS:IPOS).EQ.'#') IPOS=IPOS+1
ZZ=ONE
KSIGN=1
IF(LIN1(K-1:K-1).EQ.'+' .OR. LIN1(K-1:K-1).EQ.'-') THEN
K=K-1
IF(LIN1(K:K).EQ.'-') KSIGN=-1
ELSEIF(LIN1(K-1:K-1).EQ.'*') THEN
C IF CONSTANT MULTIPLY THEM TOGETHER, BACKSPACE OVER NUMBER
II=K-1
7 II=II-1
IF(LIN1(II:II).GE.'0' .AND. LIN1(II:II).LE.'9') GOTO 7
IF((LIN1(II:II).EQ.'+' .OR. LIN1(II:II).EQ.'-') .AND.
& LIN1(II-1:II-1).EQ.'E') THEN
II=II-1
GOTO 7
ENDIF
IF(LIN1(II:II).EQ.'.') GOTO 7
IF(LIN1(II:II).NE.'+' .AND. LIN1(II:II).NE.'-') THEN
C.... TOO COMPLICATED!
WRITE(*,10)LIN1(1:LENS(LIN1))
10 FORMAT(' *** WARNING: Variable used in expression,',
& ' not replaced:'/1X,A)
GOTO 900
ENDIF
C... A FACTOR BETWEEN LIN1(II+1:K-2)
C K=II+1
K=II
CALL GETREL(LIN1,II,ZZ)
ENDIF
IF(KSIGN.EQ.-1) ZZ=-ZZ
IF(ABS(VALUE).LT.1.0D-30) THEN
C... check if any *T etc, then copy expression until next term!
IF(LIN1(IPOS:IPOS).EQ.'*') THEN
NOPAR=0
100 IPOS=IPOS+1
CH1=LIN1(IPOS:IPOS)
C write(*,*)IPOS,CH1,' : ',LIN1(1:60)
IF(CH1.EQ.'(') THEN
C...this if loop is to bypass anything within ( ... )
NOPAR=NOPAR+1
GOTO 100
ELSEIF(CH1.EQ.')') THEN
NOPAR=NOPAR-1
GOTO 100
ELSEIF(NOPAR.GT.0) THEN
GOTO 100
ENDIF
IF(.NOT.(CH1.EQ.' ' .OR. CH1.EQ.'+' .OR. CH1.EQ.'-' .OR.
& CH1.EQ.';')) GOTO 100
ELSE
LIN2(K:)=' +ZERO#'
K=K+7
ENDIF
ELSE
LIN2(K:K)=' '
K=K+1
CALL WRINUM(LIN2,K,8,1,ZZ*VALUE)
ENDIF
LIN2(K:)=LIN1(IPOS:)
LIN1=LIN2
900 RETURN
END
C
SUBROUTINE SORTF(FIL)
C...sort functions so that a called function is already defined
PARAMETER (MFUN=1000,NFUN=5)
CHARACTER LINE*80,FUNS(MFUN)*8,CFUNS(NFUN,MFUN)*8
CHARACTER FUN*8,AFUN*8,NAME*8,FIL*(*)
CHARACTER STORE(2*MFUN)*80
DIMENSION LFUN(MFUN),LENF(MFUN)
LOGICAL EOLCH,SG1ERR,GASCON,DEBUG
write(*,17)
17 FORMAT(/'Rearranging functions in calling order'/
& 'Output on a file with same name but extention .FCO'/)
GASCON=.FALSE.
KZERO=0
FUN='FUNCTION'
DEBUG=.FALSE.
C
OPEN(21,FILE=FIL,ACCESS='SEQUENTIAL',STATUS='OLD')
NL=1
NF=0
100 READ(21,110,END=200)LINE
110 FORMAT(A)
NL=NL+1
IP=1
IF(EOLCH(LINE,IP)) GOTO 100
IF(LINE(IP:IP).EQ.'$') GOTO 100
K=INDEX(LINE(IP:),' ')-1
IF(LINE(IP:IP+K).EQ.FUN(1:K)) THEN
IP=IP+K
IF(EOLCH(LINE,IP)) GOTO 910
NF=NF+1
IF(NF.GT.MFUN) GOTO 920
K=INDEX(LINE(IP:),' ')-1
FUNS(NF)=LINE(IP:IP+K)
IF(FUNS(NF)(1:5).EQ.'ZERO ') THEN
C... ignore ZERO
KZERO=1
NF=NF-1
GOTO 100
ENDIF
MF=0
DO 115 I=1,NFUN
115 CFUNS(I,NF)=' '
IP=IP+K
120 K=INDEX(LINE(IP:),'#')
IF(K.GT.0) THEN
IP=IP+K-1
JP=IP
130 JP=JP-1
IF(LINE(JP:JP).EQ.' ' .OR. LINE(JP:JP).EQ.'+' .OR.
& LINE(JP:JP).EQ.'(' .OR.
& LINE(JP:JP).EQ.'-' .OR. LINE(JP:JP).EQ.'*') THEN
NAME=LINE(JP+1:IP-1)
C...check if not already called
DO 140 IZ=1,MF
IF(NAME.EQ.CFUNS(IZ,NF)) GOTO 145
140 CONTINUE
MF=MF+1
IF(MF.GT.NFUN) GOTO 930
CFUNS(MF,NF)=NAME
IF(DEBUG) WRITE(*,*)FUNS(NF),' calls ',CFUNS(MF,NF)
145 IP=IP+1
IF(CFUNS(MF,NF)(1:2).EQ.'R ') THEN
GASCON=.TRUE.
CFUNS(MF,NF)=' '
MF=MF-1
ENDIF
IF(CFUNS(MF,NF)(1:5).EQ.'ZERO ') THEN
C... try to remove a ZERO if there are other coefficients
IF(KZERO.EQ.0) KZERO=1
CFUNS(MF,NF)=' '
MF=MF-1
ENDIF
GOTO 120
ELSEIF(IP-JP.LT.8) THEN
GOTO 130
ELSE
GOTO 940
ENDIF
ELSE
K=INDEX(LINE,'!')
IF(K.GT.0) GOTO 100
READ(21,110,END=950)LINE
NL=NL+1
IP=1
GOTO 120
ENDIF
ENDIF
GOTO 100
200 CONTINUE
IF(DEBUG) THEN
DO 202 I=1,NF
write(*,*)FUNS(I),(CFUNS(J,I),J=1,5)
202 CONTINUE
ENDIF
C...check that all functions exist!!!
DO 204 I=1,NF
J=0
2030 J=J+1
IF(CFUNS(J,I)(1:1).NE.' ') THEN
C DO 203 K=I+1,NF
DO 203 K=1,NF
IF(K.NE.I) THEN
IF(CFUNS(J,I).EQ.FUNS(K)) GOTO 2030
ENDIF
203 CONTINUE
WRITE(*,2041)FUNS(I),CFUNS(J,I)
2041 FORMAT(' *** SEVERE ERROR IN INPUT FILE ***'/
& 'Function ',A,' calls nonexisting function ',A)
STOP
ENDIF
204 CONTINUE
C...COPY FUNCTIONS TO NEW FILE, WITH ALL FUNCTIONS CALLING ANOTHER AT THE END
205 REWIND(21)
NL=INDEX(FIL,'.')
FIL(NL+1:)='FCO'
OPEN(22,FILE=FIL,ACCESS='SEQUENTIAL',STATUS='UNKNOWN')
NL=0
NFF=0
NST=0
210 READ(21,110)LINE
IP=1
IF(EOLCH(LINE,IP) .OR. LINE(IP:IP).EQ.'$') THEN
WRITE(22,290)LINE(1:LENS(LINE))
GOTO 210
ENDIF
K=INDEX(LINE(IP:),' ')-1
IF(LINE(IP:IP+K).EQ.FUN(1:K)) THEN
IF(NFF.EQ.0 .AND. GASCON)
& WRITE(22,290)' FUNCTION R 1 8.31451; 20000 N !'
IF(NFF.EQ.0 .AND. KZERO.EQ.1)
& WRITE(22,290)' FUNCTION ZERO 1 0; 20000 N !'
IP=IP+K
IF(EOLCH(LINE,IP)) GOTO 910
K=INDEX(LINE(IP:),' ')-1
AFUN=LINE(IP:IP+K)
C??? functions not in same order any more
C NFF=NFF+1
DO 213 NFF=1,NF
IF(AFUN.EQ.FUNS(NFF)) GOTO 215
213 CONTINUE
NFF=0
215 IF(NFF.EQ.0) THEN
IF(DEBUG) write(*,*)'Writing ',AFUN
WRITE(22,110)LINE(1:LENS(LINE))
C...copy rest of function to file
217 IF(INDEX(LINE,'!').GT.0) GOTO 210
READ(21,110)LINE
WRITE(22,290)LINE(1:LENS(LINE))
GOTO 217
ELSEIF(CFUNS(1,NFF).EQ.' ') THEN
IF(DEBUG) write(*,*)'Writing and erasing calls to ',AFUN
WRITE(22,110)LINE(1:LENS(LINE))
DO 230 I=1,NF
J=1
223 IF(CFUNS(J,I).EQ.' ') GOTO 230
IF(CFUNS(J,I).EQ.AFUN) THEN
DO 225 J=J,4
225 CFUNS(J,I)=CFUNS(J+1,I)
CFUNS(5,I)=' '
ELSE
J=J+1
IF(J.LE.5) GOTO 223
ENDIF
230 CONTINUE
FUNS(NFF)=' '
C...copy rest of function to file
235 IF(INDEX(LINE,'!').GT.0) GOTO 210
READ(21,110)LINE
WRITE(22,290)LINE(1:LENS(LINE))
GOTO 235
ELSE
IF(DEBUG) write(*,*)'Storing ',AFUN,' calling ',CFUNS(1,NFF)
NST=NST+1
LFUN(NFF)=NST
C...store function in memory
240 STORE(NST)=LINE
IF(INDEX(LINE,'!').GT.0) THEN
LENF(NFF)=NST
IF(DEBUG) write(*,*)'Stored in ',NFF,LFUN(NFF),LENF(NFF)
GOTO 210
ENDIF
READ(21,110)LINE
NST=NST+1
GOTO 240
ENDIF
ELSE
WRITE(22,290)LINE(1:LENS(LINE))
290 FORMAT(A)
ENDIF
IF(NFF.LT.NF) GOTO 210
C...write stored functions
300 CONTINUE
NFF=0
IF(IGEN.GT.0)WRITE(*,*)'Functions with forward references:',IGEN
IGEN=0
310 NFF=NFF+1
IF(NFF.GT.NF) THEN
C IF(IGEN.EQ.0) GOTO 400
IF(IGEN.LE.1) GOTO 400
GOTO 300
ENDIF
IF(FUNS(NFF).EQ.' ') GOTO 310
IF(CFUNS(1,NFF).EQ.' ') THEN
DO 330 I=1,NF
IF(FUNS(I).EQ.' ') GOTO 330
J=1
323 IF(CFUNS(J,I).EQ.' ') GOTO 330
IF(CFUNS(J,I).EQ.FUNS(NFF)) THEN
DO 325 J=J,4
325 CFUNS(J,I)=CFUNS(J+1,I)
CFUNS(5,I)=' '
ELSE
J=J+1
IF(J.LE.5) GOTO 323
ENDIF
330 CONTINUE
K=LFUN(NFF)
L=LENF(NFF)
IF(DEBUG) write(*,*)'Writing ',FUNS(NFF),NFF,LFUN(NFF)
DO 340 K=K,L
340 WRITE(22,290)STORE(K)(1:LENS(STORE(K)))
FUNS(NFF)=' '
ELSE
IF(DEBUG) write(*,*)FUNS(NFF),' still calling ',CFUNS(1,NFF)
IGEN=IGEN+1
ENDIF
GOTO 310
C...write rest of file
400 READ(21,110,END=500)LINE
WRITE(22,290)LINE(1:LENS(LINE))
GOTO 400
C
500 CLOSE(21)
CLOSE(22)
900 RETURN
C...ERRORS
910 WRITE(*,911)NL
911 FORMAT(' NO NAME AFTER FUNCTION KEYWORD ON LINE ',I5)
GOTO 900
920 WRITE(*,921)NF,NL
921 FORMAT(' TOO MANY FUNCTIONS, INCREASE NF=',I5,' LINE ',I5)
GOTO 900
930 WRITE(*,931)FUNS(MF),NL
931 FORMAT(' FUNCTION ',A,' DEPEND ON TOO MANY FUNCTIONS,',
& ' LINE ',I5)
GOTO 900
940 WRITE(*,941)NL
941 FORMAT(' NO START OF FUNCTION ON LINE ',I5)
GOTO 900
950 WRITE(*,951)NL
951 FORMAT(' END-OF-FILE INSIDE FUNCTION ON LINE ',I5)
GOTO 900
END
C
SUBROUTINE RMZERO(FIL)
C...remove redundant ZERO, replaces functions that are ZERO with ZERO etc
C not used
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
CHARACTER FIL*(*),LINE*120
CHARACTER FUNS(100)*8,CH1*1,FUNEX*2000
LOGICAL EOLCH
write(*,17)
17 FORMAT('Now all zero functions will be removed'/
& 'Output on a file with same name but extention .NOZ')
OPEN(21,FILE=FIL,ACCESS='SEQUENTIAL',STATUS='OLD')
K=INDEX(FIL,'.')
FIL(K:)='.NOZ'
OPEN(22,FILE=FIL,ACCESS='SEQUENTIAL',STATUS='UNKNOWN')
C...start reading the file again
90 NL=0
NF=0
MODS=0
100 READ(21,110,END=200)LINE
110 FORMAT(A)
NL=NL+1
120 K=INDEX(LINE,'ZERO#')
IF(LINE(1:1).EQ.'$' .OR. K.LE.0) THEN
WRITE(22,110)LINE(1:LENS(LINE))
GOTO 100
ENDIF
C...remove any *T etc.
L=K+5
CH1=LINE(L:L)
IF(CH1.NE.'*') GOTO 150
130 M=L+1
CH1=LINE(M:M)
IF(.NOT.(CH1.EQ.' ' .OR. CH1.EQ.'+' .OR. CH1.EQ.'-'
& .OR. CH1.EQ.';')) GOTO 130
write(*,*)'Erasing ',LINE(L:M),' of ',LINE(1:25)
LINE(L:M)=' '
MODS=MODS+1
C...determine if more terms or everything zero ...
150 I=K-1
CH1=LINE(I:I)
IF(.NOT.(CH1.EQ.'+' .OR. CH1.EQ.'-')) GOTO 150
C...the line has a ZERO in it, check if only that. Set I to be inside the
C "low T limit value"
M=INDEX(LINE(25:),' ')+24
IF(EOLCH(LINE,M)) GOTO 910
IF(M.LE.I) THEN
C...this zero the first ... check if anything later
IF(EOLCH(LINE,L)) GOTO 910
IF(LINE(L:L).EQ.'+' .OR. LINE(L:L).EQ.'-') THEN
write(*,*)'Erasing ',LINE(I:K+5),' of ',LINE(1:25)
LINE(I:K+5)=' '
MODS=MODS+1
ELSEIF(LINE(1:10).EQ.' FUNCTION ') THEN
NF=NF+1
FUNS(NF)=LINE(11:18)
LINE=' '
ENDIF
ELSE
C...there are someting more on the line
write(*,*)'Erasing ',LINE(I:K+5),' of ',LINE(1:25)
LINE(I:K+5)=' '
MODS=MODS+1
ENDIF
GOTO 100
200 CONTINUE
REWIND(21)
REWIND(22)
IF(NF.EQ.0) GOTO 900
C...copy the files!
300 READ(22,110,END=400)LINE
WRITE(21,110)LINE(1:LENS(LINE))
REWIND(21)
REWIND(22)
GOTO 90
C...no more changes made, write it out
400 CONTINUE
900 RETURN
910 WRITE(*,911)NL
911 FORMAT(' Impossible error on line ',I5)
STOP
END
C
C--------- subroutines extracted from METLIB
C
SUBROUTINE RESERR
C...RESTORES THE ERROR CODE
CHARACTER SUBR*6,MESSAG*72
COMMON/FEL1/IERR
COMMON/FEL2/SUBR,MESSAG
COMMON/FEL3/IWR
C...FOR COMPATIBILITY WITH POLY-1
COMMON/ALLA/JERR,JJJJ
IERR=0
SUBR=' '
MESSAG=' '
IWR=0
JERR=0
900 RETURN
END
C
SUBROUTINE ST1ERR(KERR,SUBA,MESS)
C...TO SET THE ERROR CODE
CHARACTER SUBA*(*),MESS*(*)
CHARACTER SUBR*6,MESSAG*72
LOGICAL SG1ERR
COMMON/FEL1/IERR
COMMON/FEL2/SUBR,MESSAG
COMMON/FEL3/IWR
INCLUDE 'allsun.h'
C...FOR COMPATIBILITY WITH POLY-1
COMMON/ALLA/JERR,JJJJ
C...IF ERROR CODE ALREADY SET INFORM ABOUT THAT ERROR!!!!
C IF(SG1ERR(MERR)) GOTO 5
5 IERR=KERR
JERR=KERR
SUBR=SUBA
MESSAG=MESS
IF(LER.GT.0) THEN
JJJ=LENS(MESSAG)
WRITE(LER,10)IERR,SUBR,MESSAG(1:JJJ)
10 FORMAT(/' *** ERROR ',I5,' IN ',A/' *** ',A)
IWR=1
ELSE
IWR=0
ENDIF
900 RETURN
END
C
SUBROUTINE ST2ERR(KERR,SUBA,MESS)
C...TO SET THE ERROR CODE
CHARACTER SUBA*(*),MESS*(*)
CHARACTER SUBR*6,MESSAG*72
LOGICAL SG1ERR
COMMON/FEL1/IERR
COMMON/FEL2/SUBR,MESSAG
COMMON/FEL3/IWR
C...FOR COMPATIBILITY WITH POLY-1
COMMON/ALLA/JERR,JJJJ
C...IF ERROR CODE ALREADY SET INFORM ABOUT THAT ERROR!!!!
C IF(SG1ERR(MERR)) GOTO 5
5 IERR=KERR
JERR=KERR
IWR=0
SUBR=SUBA
MESSAG=MESS
900 RETURN
END
C
LOGICAL FUNCTION SG1ERR(KERR)
C...SUBROUTINE SG1ERR
CHARACTER SUBR*6,MESSAG*72
COMMON/FEL1/IERR
COMMON/FEL2/SUBR,MESSAG
COMMON/FEL3/IWR
INCLUDE 'allsun.h'
KERR=IERR
IF(KERR.NE.0) THEN
IF(LER.GT.0 .AND. IWR.EQ.0) THEN
IWR=1
JJJ=LENS(MESSAG)
WRITE(LER,10)IERR,SUBR,MESSAG(1:JJJ)
ENDIF
10 FORMAT(/' *** ERROR ',I5,' IN ',A/' *** ',A)
SG1ERR=.TRUE.
ELSE
SG1ERR=.FALSE.
ENDIF
900 RETURN
END
C
LOGICAL FUNCTION SG2ERR(KERR)
C...SUBROUTINE SG2ERR
CHARACTER SUBR*6,MESSAG*72
COMMON/FEL1/IERR
COMMON/FEL2/SUBR,MESSAG
COMMON/FEL3/IWR
KERR=IERR
IF(KERR.NE.0) THEN
SG2ERR=.TRUE.
ELSE
SG2ERR=.FALSE.
ENDIF
900 RETURN
END
C
C ==================
SUBROUTINE GETINT(SVAR,LAST,IVAL)
C...DECODES AN INTEGER FROM A TEXT
C IT MAY BE PRECCEDED BY SPACES AND A + OR -
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
INCLUDE 'allsun.h'
INTEGER GPS
LOGICAL EOLCH
CHARACTER SVAR*(*)
IF(EOLCH(SVAR,LAST)) THEN
CALL ST2ERR(1031,'GETINT','LINE EMPTY')
ELSEIF(SVAR(LAST:MIN(LEN(SVAR),LAST+3)).EQ.'NONE') THEN
IVAL=NONE
IERR=0
ELSE
IERR=GPS(SVAR,LAST,VALUE)
IF(IERR.EQ.0) THEN
IF(VALUE.GT.REAL(MAXINT) .OR. VALUE.LT.REAL(MININT)) THEN
CALL ST2ERR(1033,'GETINT','TOO LARGE INTEGER VALUE')
IVAL=0
ELSE
IVAL=VALUE
ENDIF
ELSE
CALL ST2ERR(IERR,'GETINT','NO DIGIT')
IVAL=0
ENDIF
ENDIF
900 RETURN
END
C ======================
SUBROUTINE GETREL(SVAR,LAST,VALUE)
C...DECODES A REAL NUMBER FROM A TEXT
C IT MAY BE PRECEEDED BY SPACES AND A + OR -
C THERE MUST BE AT LEAST ONE NUMBER BEFORE OR AFTER A PERIOD
C THERE MUST BE AT LEAST ONE NUMBER BEFORE AN "E" OR "D"
C AFTER AN "E" OR "D" THERE MAY BE A + OR - AND MUST BE ONE OR TWO NUMBERS
C 840310 CHANGE TO ALLOW SPACES AFTER A SIGN I.E. + 2.2 IS ALLOWED
C 860201 EXPONENTIAL D ACCEPTED
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
INCLUDE 'allsun.h'
LOGICAL EOLCH
PARAMETER (ZERO=0.0D0,ONE=1.0D0,TEN=1.0D1)
CHARACTER SVAR*(*),CH*1,BIGLET*1
INTEGER GPS,GPN
IENT=1
GOTO 3
C --------------------
ENTRY GETFIX(SVAR,LAST,VALUE)
IENT=2
3 CONTINUE
IF(EOLCH(SVAR,LAST)) THEN
CALL ST2ERR(1031,'GETREL','LINE EMPTY')
GOTO 900
ELSEIF(LAST.LT.LEN(SVAR)-2.AND.SVAR(LAST:LAST+3).EQ.'NONE') THEN
VALUE=RNONE
IERR=0
GOTO 900
ENDIF
CH=SVAR(LAST:LAST)
IF(CH.EQ.'-') THEN
LAST=LAST+1
ISIG=-1
IERR=1036
ELSE
ISIG=1
IF(CH.EQ.'+') THEN
IERR=1035
LAST=LAST+1
ELSE
IERR=0
ENDIF
ENDIF
C 840310 NEXT LINE ADDED TO ALLOW FOR SPACES AFTER A SIGN
IF(EOLCH(SVAR,LAST)) GOTO 900
CH=SVAR(LAST:LAST)
10 IF(CH.NE.'.') THEN
JERR=GPN(SVAR,LAST,HEL)
IF(JERR.NE.0) THEN
IF(IERR.EQ.0) IERR=JERR
CALL ST2ERR(IERR,'GETREL','NO DIGIT')
GOTO 900
ELSE
C... REMOVE POSSIBLE ERROR CODE SET BY NEGATIVE SIGN
IERR=0
ENDIF
ELSE
C... MARK THAT THERE WHERE NO DIGITS BEFORE THE DECIMAL POINT
IF(IERR.EQ.0) IERR=1037
HEL=ZERO
ENDIF
C...If the next character is a period then decode the decimal part.
C If there is no numbers after the period, JERR is nonzero.
C Then check if IERR is nonzero otherwise there is no numbers at all
C before or after the period. If so return with error code.
20 IF(SVAR(LAST:LAST).EQ.'.') THEN
LAST=LAST+1
I=LAST
JERR=GPN(SVAR,LAST,DEC)
IF(JERR.EQ.0) THEN
IERR=0
I=LAST-I
DEC=DEC/(TEN**I)
ELSEIF(IERR.EQ.0) THEN
DEC=ZERO
ELSE
C... NO DIGITS BEFORE OR AFTER A DECIMAL POINT
CALL ST2ERR(IERR,'GETREL','DECIMAL POINT WITHOUT DIGITS')
GOTO 900
ENDIF
ELSE
DEC=ZERO
ENDIF
30 EXPO=ONE
IF(IENT.EQ.2) GOTO 800
IF(BIGLET(SVAR(LAST:LAST)).EQ.'E'
& .OR. BIGLET(SVAR(LAST:LAST)).EQ.'D') THEN
LAST=LAST+1
IERR=GPS(SVAR,LAST,EXPO)
IF(IERR.NE.0) THEN
CALL ST2ERR(1038,'GETREL','NO DIGITS AFTER EXPONTENTIAL E')
GOTO 900
ENDIF
IF(INT(ABS(EXPO)).GT.99) THEN
CALL ST2ERR(1039,'GETREL','EXPONENT TOO LARGE')
GOTO 900
ENDIF
I=EXPO
EXPO=TEN**I
ENDIF
800 VALUE=ISIG*(HEL+DEC)*EXPO
900 RETURN
END
C ====================
INTEGER FUNCTION GPS(SVAR,LAST,VALUE)
C...SUBROUTINE GPS
C...DECODES A NUMBER WITH OR WITHOUT A SIGN
DOUBLE PRECISION VALUE
CHARACTER SVAR*(*),SIG*1
INTEGER GPN
SIG=SVAR(LAST:LAST)
IF(SIG.EQ.'-') THEN
LAST=LAST+1
ISIG=-1
IERR=1036
ELSE
ISIG=1
IF(SIG.EQ.'+') THEN
LAST=LAST+1
IERR=1035
ELSE
IERR=1037
ENDIF
ENDIF
JERR=GPN(SVAR,LAST,VALUE)
IF(JERR.EQ.0) IERR=0
GPS=IERR
VALUE=ISIG*VALUE
RETURN
END
C ===============================================
INTEGER FUNCTION GPN(SVAR,LAST,VALUE)
C...SUBROUTINE GPN
C...DECODES A NUMBER WITOUT SIGN
DOUBLE PRECISION ZERO,TEN,VALUE
INCLUDE 'allsun.h'
PARAMETER (ZERO=0.0D0,TEN=1.0D1)
CHARACTER SVAR*(*)
L=LEN(SVAR)
VALUE=ZERO
IERR=1034
DO 100 LAST=LAST,L
N=ICHAR(SVAR(LAST:LAST))-ICHAR('0')
IF(N.LT.0 .OR. N.GT.9) GOTO 800
IERR=0
VALUE=TEN*VALUE+N
100 CONTINUE
800 GPN=IERR
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 ============
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
FUNCTION BIGLET(CH1)
C...SUBROUTINE BIGLET
C...CONVERTS FROM LOWER TO UPPER CASE
C NOTE LOWER CASE LETTERS AS CONSTANTS!
CHARACTER*1 CH1,CHLAST,BIGLET
PARAMETER (CHLAST='z')
IF(CH1.GE.'a' .AND. CH1.LE.CHLAST) THEN
BIGLET=CHAR(ICHAR(CH1)+ICHAR('A')-ICHAR('a'))
ELSE
BIGLET=CH1
ENDIF
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 ==============