* CARDIN file SUBROUTINE CTRTXT(NN,TXT) * interprete/translate text TXT * * Interpretation of text strings with parameter definitions * * Subroutine CTRTXT and related subroutines perform analysis and * interpretation of text and numerical values in text (character) * strings. Text strings assume to contains keywords followed * optional by numerical values, either without decimal point * (integers) or with decimal point, optionally followed by an * exponent * * * Keywords optionally followed by numerical values * * Example: * twodata -0.32 12 pi 0.31415E1 ! this is comment text * * In this the character string contains two keywords. The first * keyword is (after conversion to uppercase characters) TWODATA, the * two numerical values connected to it are -0.32 and 12. The second * keyword is PI and has the numerical value 3.1415 connected to it. * * * The code fragment below shows the necssary calls for the access to * the data from interpretation of the text. * * * * STATMT = character string * CALL CTRTXT(NKW,STATMT) ! analyse character string STATMT * ! NKW = number of keywords * CALL CTRPRT ! optional for tests to print * ! result of analysis * DO IK=1,NKW ! Loop on all keywords * CALL TVAR(IK,KEYWRD,NUM,ia,ib)! get keyword IK in upper case * ! NUM = number of numerical values * CALL TVAR(-IK,TEXT,NUM,ia,ib) ! get keyword IK as in STATMT * ! NUM = number of numerical values * DO I=1,NUM ! Loop on all numerical values * INTV(I) = IVAR(IK,I) ! Get number I from keyword IK * ! as integer * FLTV(I) = FVAR(IK,I) ! Get number I from keyword IK * ! as floating point number * END DO ! End of loop on index I * END DO ! End of loop on all keywords * CALL TVAR(0,COMENT,NDUM,ia,ib) ! Get comment (text after !) * * CHARACTER*(*) TXT * C------------------- PARAMETER (NDKEY=10) COMMON/NUMTXT/NKW,LKW(4,NDKEY),NT,NPT(NDKEY+1),NFR(100),LFR(100) REAL FFR(100) EQUIVALENCE (FFR(1),NFR(1)) CHARACTER*16 KEYWD, COMENT*80, STEXT*256 COMMON/CHATXT/KEYWD(NDKEY),COMENT,STEXT * C------------------- * NKW = number of keywords * KEYWD(.) = keyword * COMENT = comment text after ! * LKW(1,I) = index of first character of keyword * LKW(2,I) = index of last character * LKW(3,I) = index of first character of accompanying text * LKW(4,I) = inde of last character * NPT(i) = pointer j to first integer of keyword I * NT = number of numeric values * NFR(j) = number j, if integer * FFR(j) = number j, if floating point * LFR(j) = 1 means integer number, =2 means floating point number * * convert from character string to array of integers, real numbers, * text data for free format input DOUBLE PRECISION FUMB * integers: * string of decimal digits, containing no decimal point and no * blank, optionally signed. * real numbers: * string of decimal digits with a decimal point and without * blank, optionally signed and optionally followed by exponent * with a letter e or d and an integer. * text data: * string of characters (except apostroph), enclosed in * apostrophs (stored with 4 characters per word). * The result of the conversion is stored in the COMMON/COMCNV/ * LABEL = see below * ISL = 1 if first data is integer and followed by a slash * = 0 otherwise * NT = number of data items * NFR/FFR(100)= data words * LFR(100) = flag for data word =1 for integer, =2 for real numb. * = 3 for text data * LABEL: * the characters of the first four columns before the first digit * or any of the charcaters '+-. * Comment: * all characters after an apostroph as well as any additional * characters are treated as comment and ignored. * * ... NN =0 KEYWD(1)=' ' NPT(1) =0 STEXT =TXT NKW =0 NT =0 COMENT =' ' IF(TXT.EQ.' ') RETURN IA=1 * IA ... IZ will be analysed IZ=LEN(TXT) IIZZ=IZ ICHAR0=ICHAR('0') 10 IN=IA C WRITE(*,*) 'NEXT START WITH CHARACTER ',TXT(IA:IA),' IA=',IA,IZ * find start of item in character IA ... IZ DO 12 I=IA,IZ * these characters do not start a keyword IF(TXT(I:I).EQ.' '.OR.TXT(I:I).EQ.','.OR.TXT(I:I).EQ.'.'.OR. + TXT(I:I).EQ.'+'.OR.TXT(I:I).EQ.'-'.OR.TXT(I:I).EQ.'='.OR. + TXT(I:I).EQ.';') GOTO 12 * a start character has been found - branch * start of comment IF(TXT(I:I).EQ.'!') GOTO 60 * start of text string IF(TXT(I:I).EQ.''''.OR.TXT(I:I).EQ.'"') GOTO 20 * start of a number N=ICHAR(TXT(I:I))-ICHAR0 IF(N.GE.0.AND.N.LE.9) GOTO 30 * else start of a keyword GOTO 50 12 CONTINUE * no further item found GOTO 100 * * text within ' or within " will be stored as KEYWD(.) * 20 IA=I+1 DO I=IA,IZ * text string ends with same symbol IF(TXT(I:I).EQ.TXT(IA-1:IA-1)) GOTO 24 END DO * assume final delimiter I=IZ+1 * limiting string found 24 NKW=NKW+1 NPT(NKW)=NT LKW(1,NKW)=IA LKW(2,NKW)=I-1 LKW(3,NKW)=I LKW(4,NKW)=0 IF(I.LE.IA) THEN KEYWD(NKW)=' ' ELSE KEYWD(NKW)=TXT(IA:I-1) END IF IA=I+1 GOTO 10 * * number started * 30 IF(NKW.EQ.0) THEN * assume blank keyword NKW=1 LKW(1,1)=1 LKW(2,1)=1 LKW(3,1)=I LKW(4,I)=0 KEYWD(NKW)=' ' END IF IA =I NUMB=0 FUMB=0.0 NDIG=0 NPNT=-1 IF(IA.GT.1) THEN * number starts with a dot IF(TXT(IA-1:IA-1).EQ.'.') IA=IA-1 END IF DO 32 I=IA,IZ N=ICHAR(TXT(I:I))-ICHAR0 IF(N.GE.0.AND.N.LE.9) THEN * digit IF(NDIG.EQ.9) FUMB=NUMB NDIG=NDIG+1 IF(NDIG.LE.9) THEN NUMB=10*NUMB+N ELSE FUMB=10.0*FUMB+FLOAT(N) END IF ELSE IF(TXT(I:I).EQ.'.') THEN * decimal point NPNT=NDIG ELSE * stop because neither digit nor point GOTO 34 END IF 32 CONTINUE I =IZ+1 * IS is next start index 34 IS=I * check sign before number DO 36 I=IA-1,IN,-1 IF(TXT(I:I).EQ.'+'.OR.TXT(I:I).EQ.'-') THEN IF(TXT(I:I).EQ.'-') NUMB=-NUMB IF(TXT(I:I).EQ.'-') FUMB=-FUMB IE=I-1 ELSE IF(TXT(I:I).EQ.' ') THEN * continue search for blank GOTO 36 ELSE IE=I END IF GOTO 38 36 CONTINUE IE=IN-1 * check exponent following: E e D d 38 NUMEX=-1 DO I=IS,IZ IF(TXT(I:I).NE.' ') THEN IF(TXT(I:I).NE.'E'.AND.TXT(I:I).NE.'e'.AND. + TXT(I:I).NE.'D'.AND.TXT(I:I).NE.'d') GOTO 49 GOTO 39 END IF END DO GOTO 49 39 IQ=I+1 * sign or digit ISIGN=+1 N=-1 DO I=IQ,IZ IF(TXT(I:I).NE.' ') THEN IF(TXT(I:I).EQ.'+') THEN ISIGN=+1 ELSE IF(TXT(I:I).EQ.'-') THEN ISIGN=-1 ELSE N=ICHAR(TXT(I:I))-ICHAR0 IF(N.LT.0.OR.N.GT.9) GOTO 49 END IF GOTO 40 END IF END DO GOTO 49 * digits 40 IQ=I+1 IF(N.GE.0) IQ=I DO I=IQ,IZ IF(TXT(I:I).NE.' ') THEN N=ICHAR(TXT(I:I))-ICHAR0 IF(N.LT.0.OR.N.GT.9) GOTO 48 IF(NUMEX.LT.0) NUMEX=0 NUMEX=10*NUMEX+N ELSE IF(NUMEX.GE.0) GOTO 48 END IF END DO I=IZ+1 48 IF(NUMEX.GE.0) IS=I * store new number 49 NT=NT+1 IF(NPNT.LT.0.AND.NUMEX.LT.0.AND.DABS(FUMB).LT.2.147E9) THEN * integer NFR(NT)=NUMB IF(NDIG.GE.10) THEN NFR(NT)=DABS(FUMB) IF(FUMB.LT.0.0) NFR(NT)=-NFR(NT) END IF LFR(NT)=1 ELSE * floating point number IF(NPNT.LT.0) NPNT=NDIG IF(NDIG.LT.10) FUMB=NUMB FFR(NT)=FUMB/10.0**(NDIG-NPNT) LFR(NT)=2 IF(NUMEX.GE.0) THEN NUMEX=NUMEX*ISIGN IF(NUMEX.GT.32) NUMEX=32 IF(NUMEX.LT.(-32)) NUMEX=-32 FFR(NT)=FFR(NT)*10.0**NUMEX END IF END IF IA=IS GOTO 10 * keyword without extra quotes 50 IA=I DO I=IA,IZ * check end character IF(TXT(I:I).EQ.' '.OR.TXT(I:I).EQ.','.OR.TXT(I:I).EQ.';') GOTO 52 C + TXT(I:I).EQ.'+'.OR.TXT(I:I).EQ.'-') GOTO 52 * start of comment IF(TXT(I:I).EQ.'!') GOTO 52 * start of text string IF(TXT(I:I).EQ.''''.OR.TXT(I:I).EQ.'"') GOTO 52 END DO * assume final delimiter I=IZ+1 * limiting string found 52 NKW=NKW+1 NPT(NKW)=NT LKW(1,NKW)=IA LKW(2,NKW)=I-1 LKW(3,NKW)=I LKW(4,NKW)=0 KEYWD(NKW)=' ' C WRITE(*,*) NKW,TXT(IA:I-1) IF(IA.LE.I-1) KEYWD(NKW)=TXT(IA:I-1) CALL CASEUP(KEYWD(NKW)) IA=I C WRITE(*,*) 'NEXT IA=',IA GOTO 10 * * comment after ! is stored as comment * 60 IIZZ=I-1 IA=I DO I=IA+1,IZ IF(TXT(I:I).NE.' ') GOTO 65 END DO GOTO 100 65 COMENT=TXT(I:IZ) 100 IF(NKW.EQ.0) NKW=1 NPT(NKW+1)=NT NN=NKW DO I=1,NKW-1 LKW(4,I)=LKW(1,I+1)-2 END DO LKW(4,NKW)=IIZZ END FUNCTION IVAR(I,J) * get integer value j for keyword I * C------------------- PARAMETER (NDKEY=10) COMMON/NUMTXT/NKW,LKW(4,NDKEY),NT,NPT(NDKEY+1),NFR(100),LFR(100) REAL FFR(100) EQUIVALENCE (FFR(1),NFR(1)) CHARACTER*16 KEYWD, COMENT*80, STEXT*256 COMMON/CHATXT/KEYWD(NDKEY),COMENT,STEXT * C------------------- * ... IVAR=0 * test index of keyword IF(I.LE.0.OR.I.GT.NKW) GOTO 100 INDEX=NPT(I)+J IF(INDEX.GT.NPT(I+1)) GOTO 100 IF(LFR(INDEX).EQ.2) THEN * convert from floating point number IVAR=ABS(FFR(INDEX)) IF(FFR(INDEX).LT.0.0) IVAR=-IVAR ELSE IVAR=NFR(INDEX) END IF 100 RETURN END FUNCTION FVAR(I,J) * get floating point value j for keyword I * C------------------- PARAMETER (NDKEY=10) COMMON/NUMTXT/NKW,LKW(4,NDKEY),NT,NPT(NDKEY+1),NFR(100),LFR(100) REAL FFR(100) EQUIVALENCE (FFR(1),NFR(1)) CHARACTER*16 KEYWD, COMENT*80, STEXT*256 COMMON/CHATXT/KEYWD(NDKEY),COMENT,STEXT * C------------------- * ... FVAR=0.0 * test index of keyword IF(I.LE.0.OR.I.GT.NKW) GOTO 100 INDEX=NPT(I)+J IF(INDEX.GT.NPT(I+1)) GOTO 100 IF(INDEX.LE.0.OR.INDEX.GT.NT) GOTO 100 IF(LFR(INDEX).EQ.1) THEN * convert from integer number FVAR=NFR(INDEX) ELSE FVAR=FFR(INDEX) END IF 100 RETURN END SUBROUTINE TVAR(I,TEXT,NN,IA,IB) * get text for keyword I and number of numerical values CHARACTER*(*) TEXT * C------------------- PARAMETER (NDKEY=10) COMMON/NUMTXT/NKW,LKW(4,NDKEY),NT,NPT(NDKEY+1),NFR(100),LFR(100) REAL FFR(100) EQUIVALENCE (FFR(1),NFR(1)) CHARACTER*16 KEYWD, COMENT*80,STEXT*256 COMMON/CHATXT/KEYWD(NDKEY),COMENT,STEXT * C------------------- * ... TEXT=' ' NN=-1 II=IABS(I) IA=0 IB=0 IF(II.NE.0) THEN NN=-1 * test index of keyword IF(II.LE.0.OR.II.GT.NKW) GOTO 100 IF(I.GT.0) THEN TEXT=KEYWD(II) ELSE TEXT=KEYWD(II) IF(TEXT.NE.' ') TEXT=STEXT(LKW(1,II):LKW(2,II)) END IF NN=NPT(II+1)-NPT(II) IA=LKW(3,II) IB=LKW(4,II) ELSE NN=0 TEXT=COMENT END IF 100 RETURN END SUBROUTINE CASEUP(TEXT) * convert text to upper case characters * CHARACTER*(*) TEXT * LOGICAL START CHARACTER*26 CHU,CHL INTEGER NJ(0:255) DATA CHU/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ DATA CHL/'abcdefghijklmnopqrstuvwxyz'/ DATA START/.TRUE./ DATA NJ/256*0/ * ... IF(START) THEN START=.FALSE. DO I=1,26 J=ICHAR(CHL(I:I)) NJ(J)=I END DO END IF DO I=1,LEN(TEXT) IF(TEXT(I:I).NE.' ') THEN J=ICHAR(TEXT(I:I)) IF(NJ(J).NE.0) TEXT(I:I)=CHU(NJ(J):NJ(J)) END IF END DO END SUBROUTINE CTRPRT * C------------------- PARAMETER (NDKEY=10) COMMON/NUMTXT/NKW,LKW(4,NDKEY),NT,NPT(NDKEY+1),NFR(100),LFR(100) REAL FFR(100) EQUIVALENCE (FFR(1),NFR(1)) CHARACTER*16 KEYWD, COMENT*80, STEXT*256 COMMON/CHATXT/KEYWD(NDKEY),COMENT,STEXT * C------------------- * print interpretation CHARACTER*16 KEYWRD, TEXT*80 WRITE(*,101) WRITE(*,101) 'Printout from interpretation of last text line' I=0 10 CALL TVAR(I+1,KEYWRD,NN,IA,IB) IF(NN.LT.0) GOTO 20 I=I+1 CALL TVAR(-I,TEXT,NN,IA,IB) IF(I.EQ.1) WRITE(*,102) WRITE(*,103) I,KEYWRD,NN,TEXT IF(NN.EQ.0) GOTO 10 DO J=1,NN NINT=IVAR(I,J) FINT=FVAR(I,J) WRITE(*,104) NINT,FINT END DO TEXT=STEXT(IA:IB) LBL=LENBLK(TEXT) IF(LBL.NE.0) THEN WRITE(*,106) '/',TEXT(1:LBL),'/' END IF GOTO 10 20 CALL TVAR(0,TEXT,NN,IA,IB) IF(TEXT.NE.' ') WRITE(*,105) TEXT WRITE(*,101) 100 RETURN 101 FORMAT(1X,A) 102 FORMAT(' I Keyword......... NUM Text...') 103 FORMAT(1X,I3,1X,A16,I4,1X,A) 104 FORMAT(26X,I12,G16.6) 105 FORMAT(26X,A) 106 FORMAT(1X,A1,A,A1) END SUBROUTINE HLTOCH(IHL,NHL,FMT,NCH) * Copy hollerith text (integer, 4 char per word) to character text * CHARACTER*(*) FMT INTEGER IHL(*) * ... L=LEN(FMT) IF(NHL.LE.0) THEN FMT(1:1)=' ' NCH=1 RETURN END IF NCH=MIN0(L,4*NHL) DO I=1,NHL ICH=IHL(I) IF(ICH.LT.0) THEN K4=MOD(ICH,256)+256 ICH=16777215+ICH/256 ELSE K4=MOD(ICH,256) ICH=ICH/256 END IF FMT(4*I-3:MIN0(L,4*I))=CHAR(ICH/65536)//CHAR(MOD(ICH/256,256))// + CHAR(MOD(ICH,256))//CHAR(K4) END DO * check trailing blanks IF(FMT(NCH:NCH).EQ.' ') THEN NCH=NCH-1 IF(FMT(NCH:NCH).EQ.' ') THEN NCH=NCH-1 IF(FMT(NCH:NCH).EQ.' ') THEN NCH=NCH-1 END IF END IF END IF END SUBROUTINE CHTOHL(FMT,IHL,NHL) * Copy character text to hollerith text (integer, 4 char per word) CHARACTER*(*) FMT INTEGER IHL(*) CHARACTER CHA*4 * ... L=LEN(FMT) NHL=(L+3)/4 DO I=1,NHL CHA=FMT(4*I-3:MIN0(L,4*I)) ICH=((ICHAR(CHA(1:1))*256+ICHAR(CHA(2:2)))*256+ICHAR(CHA(3:3))) + *256+ICHAR(CHA(4:4)) IHL(I)=ICH END DO END FUNCTION LENBLK(TEXT) * LENBLK(TEXT) = length of non-blank text * CHARACTER*(*) TEXT * ... IF(TEXT.EQ.' ') THEN LENBLK=0 ELSE LE=LEN(TEXT) 10 IF(LE.GT.4) THEN IF(TEXT(LE/2:LE).EQ.' ') THEN LE=LE/2-1 GOTO 10 END IF END IF DO I=LE,1,-1 IF(TEXT(I:I).NE.' ') GOTO 20 END DO 20 LENBLK=I END IF END SUBROUTINE PNVE(FLT,STR,JS) * CHARACTER*(*) STR * ************************************************************************ * * Make exponent only: STR='E+1' or 'E-7' * ************************************************************************ * DATA ICHAR0/0/ IF(ICHAR0.EQ.0) ICHAR0=ICHAR('0') STR=' ' IE=IFIX(ALOG10(ABS(FLT))+100.01)-100 STR(1:1)='E' JS=1 IF(IE.LT.0) THEN JS=JS+1 STR(JS:JS)='-' END IF JE=MIN0(99,IABS(IE)) IF(JE.GE.10) THEN JS=JS+1 STR(JS:JS)=CHAR(ICHAR0+JE/10) JE=MOD(JE,10) END IF JS=JS+1 STR(JS:JS)=CHAR(ICHAR0+JE) * 100 RETURN END SUBROUTINE PNVF(FLT,STR,JS) * CHARACTER*(*) STR * ************************************************************************ * * Convert floating point number FLT into string STR with JS * non-blank characters. JS = 2 ... 12 * * Examples: * CALL PNVF( -1.200,STR,JS) -> STR='-1.2' ; JS = 4 * CALL PNVF(1.0/3.0,STR,JS) -> STR='0.333333' ; JS = 8 * CALL PNVF(-123.00,STR,JS) -> STR='-123.' ; JS = 5 * STR will contain up to 6 digits, trailing zeros are suppressed. * STR will contain one decimal point. * Range of floating point numbers is 10E-36 ... 10E+36 (due to * limitations on certain machines. * * Binary representation of NaN and Infinity on the SGI : * NaN = (7F810000) * Inf = (7F800000) * ************************************************************************ * CHARACTER*1 DIG(0:9) INTEGER ND(12),KD(6) DOUBLE PRECISION FEX(-3:5) DATA DIG/'0','1','2','3','4','5','6','7','8','9'/ DATA FEX/1.0D8,1.0D7,1.0D6,1.0D5,1.0D4,1.0D3,1.0D2,1.0D1,1.0D0/ DATA KD/100000,10000,1000,100,10,1/ DATA IJ0/0/ * IF(IJ0.EQ.0) THEN IJ0=ICHAR('0') IJ9=ICHAR('9') END IF JS=0 X=FLT IF(X.NE.0.0) THEN * limited range on certain machines IF(ABS(X).LT.1.0E-36) X=SIGN(1.0E-36,FLT) IF(ABS(X).GT.1.0E+36) X=SIGN(1.0E+36,FLT) ELSE GOTO 22 END IF N=IFIX(ALOG10(ABS(X))+100.0)-100 20 IF(N.LE.5.AND.N+3.GE.0) THEN K=DBLE(ABS(X))*FEX(N)+0.5D0 ELSE K=DBLE(ABS(X))*10.0D0**(5-N)+0.5D0 END IF 21 IF(K.GT.999999) THEN N=N+1 GOTO 20 END IF * rounding IF(MOD(K,100).EQ.99) THEN K=K+1 GOTO 21 ELSE IF(MOD(K,100).EQ.01) THEN K=K-1 END IF * determine number of digits KDUP=K DO 40 I=1,6 IF(MOD(KDUP,10).NE.0) GOTO 50 KDUP=KDUP/10 40 CONTINUE I=6 50 NDIG=7-I * 22 IF(X.EQ.0.0) THEN GOTO 23 ELSE IF(N.GT.5) THEN * N greater than +5 NFL=(N/3)*3 M=MOD(N,3)+1 ELSE IF(N+3.GE.0) THEN * N between +5 and -3 NFL=0 M=MAX0(0,N+1) ELSE * N less than -3 NFL=-((2-N)/3)*3 M=3-MOD(2-N,3) * calculate length, if exponent modified by 3 NLG=MAX0(M-3,NDIG)+4 IF(X.LT.0.0) NLG=NLG+1 IF(M.LT.3) NLG=NLG+1 IF(M.LT.2) NLG=NLG+1 IF(NFL.LT.(-12)) NLG=NLG+1 * if not more than 12 bytes, add 3 to exponent IF(NLG.LE.12) THEN NFL=NFL+3 M =M-3 N =N+3 END IF END IF * * K = 6-digit number * N = exponent (or +3) * NFL = printed exponent * M = position of point * NDIG = number of nonzero digits * 23 STR=' ' * IF(X.EQ.0.0) THEN JS=JS+1 STR(JS:JS+1)='0.' JS=JS+1 GOTO 100 ELSE IF(X.LT.0) THEN JS=JS+1 STR(JS:JS)='-' END IF * IF(NFL.GE.0.AND.(N+1.LE.0.AND.N+3.GE.0)) THEN * special case for N= -1 or -2 or -3 (0. or 0.0 or 0.00) JS=JS+1 STR(JS:JS-N+1)='0.00' JS=JS-N * added code to avois some problems ELSE IF(NFL.LT.0.AND.M.LE.0) THEN NFL=NFL-3 M=M+3 END IF * DO 24 I=1,6 J=K/KD(I) K=K-KD(I)*J JS=JS+1 STR(JS:JS)=DIG(J) IF(I.EQ.M) THEN JS=JS+1 STR(JS:JS)='.' END IF IF(I.GE.M.AND.K.EQ.0) GOTO 26 24 CONTINUE * 26 IF(NFL.EQ.0) GOTO 100 JS=JS+1 STR(JS:JS)='E' * K=IABS(NFL) DO 30 I=1,2 ND(I)=MOD(K,10) K =K/10 IF(K.EQ.0) GOTO 32 30 CONTINUE I=2 32 IF(NFL.LT.0) THEN JS=JS+1 STR(JS:JS)='-' END IF DO 34 J=I,1,-1 JS=JS+1 34 STR(JS:JS)=DIG(ND(J)) * 100 RETURN END SUBROUTINE PNVG(FLT,STR,JS) * CHARACTER*(*) STR * ************************************************************************ * * The same as PNVF, but for graphics. * ************************************************************************ * CHARACTER*12 TTR IF(FLT.EQ.0.0) THEN STR='0' JS=1 GOTO 100 END IF CALL PNVF(FLT,STR,JS) IE=INDEX(STR(1:JS),'E') IF(IE.EQ.0) THEN IF(STR(JS:JS).EQ.'.') THEN STR(JS:JS)=' ' JS=JS-1 END IF ELSE IF(STR(IE-1:IE-1).EQ.'.') THEN NE=1+JS-IE TTR(1:NE)=STR(IE:JS) STR(IE-1:IE-2+NE)=TTR(1:NE) JS=JS-1 END IF END IF * 100 RETURN END SUBROUTINE PNVI(NUM,STR,JS) * CHARACTER*(*) STR * ************************************************************************ * * Convert integer NUM into character string STR with JS non-blank * characters. JS = 1 ... 12 * Examples: CALL PNVI( -1,STR,JS) -> STR='-1' ; JS = 2 * CALL PNVI(317,STR,JS) -> STR='317' ; JS = 3 * ************************************************************************ * CHARACTER*12 DIG(0:9)*1 INTEGER ND(12) DATA DIG/'0','1','2','3','4','5','6','7','8','9'/ JS=0 * K=IABS(NUM) DO 10 I=1,12 ND(I)=MOD(K,10) K =K/10 IF(K.EQ.0) GOTO 12 10 CONTINUE I=12 12 STR=' ' IF(NUM.LT.0) THEN JS=JS+1 STR(JS:JS)='-' END IF DO 14 J=I,1,-1 JS=JS+1 14 STR(JS:JS)=DIG(ND(J)) * RETURN END SUBROUTINE PNVZ(NUM,STR,JS) * CHARACTER*(*) STR * ************************************************************************ * * Convert integer NUM into character string STR, JS non-blank * characters,. JS = 8) in hexadecimal representation * Examples: * CALL PNVZ( 15,STR,JS) -> STR='0000000F' ; JS = 8 * CALL PNVZ(255,STR,JS) -> STR='000000FF' ; JS = 8 * ************************************************************************ * CHARACTER*12 DIG(0:15)*1 DATA DIG/'0','1','2','3','4','5','6','7','8','9', + 'A','B','C','D','E','F'/ JS=8 KHEX=NUM DO 10 I=0,7 * extract rightmost hex number JHEX from KHEX and shift JHEX= IAND(KHEX,15) KHEX=ISHFT(KHEX,-4) 10 STR(JS-I:JS-I)=DIG(JHEX) * 100 RETURN END SUBROUTINE PNVC(FLT,STR,JS) * CHARACTER*(*) STR * ************************************************************************ * * Convert floating point number FLT into string STR with JS * non-blank characters. JS = 2 ... 12 * for cm units up to four decimals * Examples: * CALL PNVC( -1.200,STR,JS) -> STR='-1.2' ; JS = 4 * CALL PNVC(1.0/3.0,STR,JS) -> STR='0.333333' ; JS = 8 * CALL PNVC(-123.00,STR,JS) -> STR='-123.' ; JS = 5 * STR will contain up to 6 digits, trailing zeros are suppressed. * STR will contain one decimal point. * ************************************************************************ * PARAMETER (PNT=0.000351460) CHARACTER*1 DIG(0:9) INTEGER KD(6) DOUBLE PRECISION FEX(-5:7) DATA DIG/'0','1','2','3','4','5','6','7','8','9'/ DATA FEX/1.D10,1.D9,1.0D8,1.0D7,1.0D6,1.0D5, + 1.0D4,1.0D3,1.0D2,1.0D1,1.0D0,1.0D-1,1.0D-2/ DATA KD/100000,10000,1000,100,10,1/ DATA IJ0/0/ * ... * rounding of value VAL=FLT IF(ABS(VAL).LT.0.00005) VAL=0.0 IF(ABS(VAL).GT.100.0) VAL=SIGN(100.0,VAL) IF(VAL.GE.0.0) THEN M=VAL/PNT VAL=FLOAT(M)*PNT M= 10000.0*VAL+0.5 ELSE M=-VAL/PNT VAL=FLOAT(M)*PNT M= 10000.0*VAL+0.5 M=-M END IF X=0.0001*FLOAT(M) * IF(IJ0.EQ.0) THEN IJ0=ICHAR('0') IJ9=ICHAR('9') END IF JS=0 IF(X.EQ.0.0) GOTO 22 N=IFIX(ALOG10(ABS(X))+100.0)-100 C 20 IF(N.LE.5.AND.N+3.GE.0) THEN 20 CONTINUE K=DBLE(ABS(X))*FEX(N)+0.5D0 21 IF(K.GT.999999) THEN N=N+1 GOTO 20 END IF * rounding IF(MOD(K,100).EQ.99) THEN K=K+1 GOTO 21 ELSE IF(MOD(K,100).EQ.01) THEN K=K-1 END IF * determine number of digits KDUP=K DO 40 I=1,6 IF(MOD(KDUP,10).NE.0) GOTO 50 KDUP=KDUP/10 40 CONTINUE I=6 50 NDIG=7-I * 22 IF(X.NE.0.0) THEN M=MAX0(0,N+1) END IF * * K = 6-digit number * N = exponent (or +3) * M = position of point * NDIG = number of nonzero digits * 23 STR=' ' * IF(X.EQ.0.0) THEN JS=JS+1 STR(JS:JS+1)='0.' JS=JS+1 GOTO 100 ELSE IF(X.LT.0.0) THEN JS=JS+1 STR(JS:JS)='-' END IF * IF(N+1.LE.0.AND.N+4.GE.0) THEN * special case for N= -1 or -2 or -3 or -4 (0. or 0.0 or 0.00) JS=JS+1 STR(JS:JS-N+1)='0.000' JS=JS-N END IF * DO I=1,6 J=K/KD(I) K=K-KD(I)*J JS=JS+1 STR(JS:JS)=DIG(J) IF(I.EQ.M) THEN JS=JS+1 STR(JS:JS)='.' END IF IF(I.GE.M.AND.K.EQ.0) GOTO 100 END DO * * 100 RETURN END SUBROUTINE PUTSTR(LUN,LSTRNG) * * define parameters for PUT STRING * LUN = unit for output * LSTRNG = maximum length of string COMMON/CPUTST/LUNT,LSTT,LST * ... LUNT=LUN LST =LSTRNG END SUBROUTINE PSTGD(STR) * * output of string STR * STR = ' ' means writeout and clear buffer COMMON/CPUTST/LUNT,LSTT,LST * IAST = index of start character PARAMETER (IAST=2) CHARACTER*255 STRING, STR*(*) DATA STRING/' '/,NST/0/ * ... IF(STR.EQ.' ') THEN * input string blank => output and clear IF(NST.GT.IAST) THEN WRITE(LUNT,101) STRING(1:NST) END IF * reset STRING=' ' NST=IAST-1 ELSE * input string non blank JS=LEN(STR) IF(NST.LE.0) THEN * reset STRING=' ' NST=IAST-1 ELSE IF(NST+JS+3.GT.LST) THEN * full => write out WRITE(LUNT,101) STRING(1:NST) * reset STRING=' ' NST=IAST-1 END IF * add to buffer string STRING(NST+1:NST+JS)=STR(1:JS) NST=NST+JS END IF GOTO 100 ENTRY PSTGC(STR) * * add comment right-adjusted, if space enough * JS=LEN(STR) IF(LST-JS+1.LE.NST) GOTO 100 STRING(LST-JS+1:LST)=STR NST=LST 100 RETURN 101 FORMAT(A) END SUBROUTINE PSTGF(CHA,VALUE) * * single floating point value 5 digit * CHARACTER*12 STR, CH*1, CHA*(*) CH=CHA * rounding of values FAC=1.0 IF(VALUE.GT.0.0) THEN MEXP=ALOG10(VALUE)+100.0 MEXP=104-MEXP FAC=10.0**MEXP M= FAC*VALUE+0.5 ELSE IF(VALUE.LT.0.0) THEN MEXP=ALOG10(-VALUE)+100.0 MEXP=104-MEXP FAC=10.0**MEXP M=-FAC*VALUE+0.5 M=-M ELSE M=0 END IF CALL PNVF(FLOAT(M)/FAC,STR,JS) CALL PSTGD(CH//STR(1:JS)) GOTO 100 ENTRY PSTGM(CHA,VALUE) * * single floating point value IN CM * CH=CHA CALL PNVC(VALUE,STR,JS) CALL PSTGD(CH//STR(1:JS)) GOTO 100 ENTRY PSTGG(CHA,VALUE) * * single floating point value for graphics TeX CH=CHA CALL PNVG(VALUE,STR,JS) I=INDEX(STR(1:JS),'E') IF(I.EQ.0) THEN CALL PSTGD(CH//STR(1:JS)) ELSE IF(STR(1:I-1).EQ.'1') THEN CALL PSTGD(CH//'$10^{') ELSE CALL PSTGD(CH//'$'//STR(1:I-1)) CALL PSTGD('\cdot 10^{') END IF CALL PSTGD(STR(I+1:JS)) CALL PSTGD('}$') END IF 100 RETURN END SUBROUTINE PSTGI(CHA,IVALUE) * * single integer value * CHARACTER*12 STR, CH*1, CHA*(*) CH=CHA * ... CH=CHA CALL PNVI(IVALUE,STR,JS) CALL PSTGD(CH//STR(1:JS)) RETURN END