SUBROUTINE SCVTR (VALUE, PICTUR, STRING) C***************************************************************************** C C Description : Routine to convert a real value to a string according C to a given lay-out (picture-string) C C Arguments : VALUE = REAL value to be converted C C PICTUR = STRING containing the picture code characters: C 9 - numeric position C Z - zero-suppressed numeric position (for non- C exponential notation only) C S - forces sign to be printed C for non-exponential notation: C S followed by a Z indicates floating position C S followed by a 9 or as the last character of C the picture-string indicates fixed position C for exponential notation: C S must be the first character in the picture C otherwise it will cause unpredictable results C E - indicates exponential notation (must be the C last char. in the picture-string, if present) C C The last character in the picture-string, C other than 9,Z or S , and before the eventual E, C will be treated as the decimal point. C The picture-string may be max. 39 characters long. C C STRING = STRING returning the value-string C In case of an invalid picture-string or a picture- C string too small to reproduce the number in VALUE, C the resultstring has a minimum length of 12 charac- C ters (11 number characters + zero-byte). C C Author : F.A.Minkema C AKZO PHARMA, Oss Holland C dept. SDA C C Version : V1.0 Date : 1-dec-82 C C Module name : SCVTR.FTN C C Package : RSX-LIBRARY C C Compilation/Linking : FOR/F4P/TR:NONE SCVTR C C Updates : name version C C description : C C***************************************************************************** BYTE BUF(40),PICT(40),PCHAR(4),SGNSTR(4),CHAR(2), 1 ZERO,ES,NINE,ZET,MINUS,BLANK,PICTUR(1),STRING(1) EQUIVALENCE (ES ,PCHAR(1)) EQUIVALENCE (NINE ,PCHAR(2)) EQUIVALENCE (ZET ,PCHAR(3)) EQUIVALENCE (MINUS,SGNSTR(1)) EQUIVALENCE (BLANK,SGNSTR(2)) DATA PCHAR /'S','9','Z',0/, SGNSTR /'-',' ','+',0/, 1 CHAR /2*0/, ZERO /'0'/ C C C initialize C IF (LEN(PICTUR).GT.39) GOTO 9000 CALL SCOPY(PICTUR,PICT) 10 AVAL=VALUE CALL TRIM(PICT) LPICT=LEN(PICT) IMLT=0 IRND=0 IFIX=0 IEXP=0 IEX=0 IPD=0 ND=0 NN=0 NS=0 C C check occurrance of E-character for exponential notation C IF (PICT(LPICT).EQ.'E' .OR. PICT(LPICT).EQ.'e') 12,20,20 C THEN 12 IEX=1 LPICT=LPICT-1 C ENDIF C C check and decode rest of picture-string C 20 IF (LPICT.LE.0) GOTO 9000 DO 40 I=LPICT,1,-1 CHAR(1)=PICT(I) IX=INDEX(PCHAR,CHAR) IF (IX.GE.2 .AND. IX.LE.3) NN=NN+1 ! count numeric pos. IF (IX.EQ.1) 22,30,30 C THEN 22 IF (IEX.EQ.0 .OR. I.EQ.1) NS=NS+1 ! count sign pos. IF (IEX.EQ.0 .AND. 1 (I.EQ.LPICT .OR. PICT(I+1).EQ.NINE)) IFIX=1 ! fix sign C ENDIF 30 IF (IX.EQ.0 .AND. IPD.EQ.0) 32,40,40 C THEN 32 IPD=I ! position of decimal character ND=NN NN=0 C ENDIF 40 CONTINUE C C check value and round C ISIGN=NS IF (ISIGN.GT.1) ISIGN=1 IF (AVAL.LT.0.) ISIGN=-1 IASGN=IABS(ISIGN) AVAL=ABS(AVAL) 50 HVAL=AVAL NVPOS=0 60 NVPOS=NVPOS+1 HVAL=HVAL/10. IF (HVAL.GE.1.) GOTO 60 IF (AVAL.LT.1.) NVPOS=0 C C choose default picture if invalid or overflowing picture C IF (NS.GT.1 .OR. NN+ND+NS.LE.IASGN .OR. 1 (IEX.EQ.0 .AND. NVPOS+IASGN.GT.NN+NS) .OR. 1 (IEX.EQ.1 .AND. (IPD.EQ.0 .OR. IASGN.GT.NN+NS))) GOTO 9000 C C fit number in picture in case of exponential notation C IF (IEX.EQ.1 .AND. AVAL.NE.0. .AND. IMLT.EQ.0) 70,130,130 C THEN 70 IMLT=1 ! determine extreme value HEXTR=1. IF (NN+NS.GT.IASGN) 72,90,90 C THEN 72 DO 80 I=1,NN+NS-IASGN HEXTR=HEXTR*10. 80 CONTINUE C ENDIF 90 IF (AVAL.LT.HEXTR) 100,110,110 C THEN ! multiply by 10 100 HVAL=10.*AVAL IF (HVAL.LT.HEXTR) 102,50,50 C THEN 102 AVAL=HVAL IEXP=IEXP-1 GOTO 100 C ENDIF C ELSE 110 HEXTR=0.1*HEXTR 120 HVAL=0.1*AVAL ! devide by 10 IF (HVAL.GE.HEXTR) 122,50,50 C THEN 122 AVAL=HVAL IEXP=IEXP+1 GOTO 120 C ENDIF C ENDIF C C round number if possible C 130 IF (IRND.EQ.0 .AND. AVAL-AINT(AVAL).NE.0.) 132,150,150 C THEN 132 IRND=1 HVAL=1. DO 140 I=1,ND IF (I.GT.ND) GOTO 140 HVAL=0.1*HVAL 140 CONTINUE AVAL=AVAL+0.5*HVAL IMLT=0 GOTO 50 C ENDIF C C decode value and place in buffer C 150 BUF(1)=SGNSTR(ISIGN+2) HVAL=AINT(AVAL) ! integer part DO 160 I=1,NVPOS IF (I.GT.NVPOS) GOTO 160 HHVAL=0.1*HVAL HVAL=AINT(HHVAL) IVAL=(HHVAL-HVAL)*10.+.5 BUF(NVPOS+2-I)=IVAL+ZERO 160 CONTINUE C IF (IPD.NE.0) BUF(NVPOS+2)=PICT(IPD) ! decimal character C HVAL=AVAL-AINT(AVAL) ! decimal part DO 170 I=1,ND IF (I.GT.ND) GOTO 170 HVAL=10.*HVAL IVAL=AINT(HVAL)+.5 BUF(NVPOS+2+I)=IVAL+ZERO HVAL=HVAL-IVAL 170 CONTINUE C C copy buffer to output variable according to picture C IPV=NVPOS+ND+1 IF (IPD.NE.0) IPV=IPV+1 IPS=LPICT DO 270 I=LPICT,1,-1 STRING(I)=BLANK IF (IPV.LT.1) GOTO 270 CHAR(1)=PICT(I) GOTO (210,220,230,240) INDEX(PCHAR,CHAR)+1 C 210 IF (IPV.GT.1 .OR. 1 (I.GT.1 .AND. PICT(I-1).EQ.NINE)) 212,270,270 C THEN 212 STRING(IPS)=PICT(I) ! copy 'special' characters IF (I.EQ.IPD) GOTO 250 GOTO 260 C ENDIF C 220 IF (IFIX.EQ.0) GOTO 240 STRING(IPS)=BUF(1) ! put sign at fix position BUF(1)=BLANK GOTO 260 C 230 STRING(IPS)=ZERO IF (IPV.EQ.1 .AND. I.GT.1) GOTO 260 C 240 IF (BUF(IPV).EQ.BLANK) GOTO 270 STRING(IPS)=BUF(IPV) ! copy numeric 250 IPV=IPV-1 260 IPS=IPS-1 270 CONTINUE C C complete output string C IF (IEX.EQ.1) 310,320,320 C THEN ! add 'E' and exponent 310 IF (AVAL.EQ.0.) 312,316,316 C THEN 312 DO 314 I=1,LPICT+4 ! for zero: non-exponential notation STRING(I)=BLANK IF (I.EQ.IPD) STRING(I)=PICT(IPD) IF (I.EQ.IPD-1 .OR. 1 (I.EQ.IPD+1 .AND. I.LE.LPICT)) STRING(I)=ZERO 314 CONTINUE STRING(LPICT+5)=0 GOTO 899 C ELSE 316 CALL SCOPY('E+ ',STRING(LPICT+1)) IF (IEXP.LT.0) STRING(LPICT+2)=MINUS IEXP=IABS(IEXP) STRING(LPICT+3)=(IEXP/10)+ZERO STRING(LPICT+4)=MOD(IEXP,10)+ZERO GOTO 899 C ENDIF C ELSE ! delete trailing zeroes 320 STRING(LPICT+1)=0 IF (IPD.EQ.0 .OR. IPD.EQ.LPICT) GOTO 340 DO 330 I=LPICT,IPD,-1 IF (I.NE.IPD .AND. 1 (PICT(I).NE.ZET .OR. STRING(I).NE.ZERO)) GOTO 340 STRING(I)=BLANK 330 CONTINUE 340 DO 350 I=1,LPICT ! check for special characters CHAR(1)=STRING(I) IF (INDEX(SGNSTR,CHAR).EQ.0 .AND. 1 (IPD.EQ.0 .OR. STRING(I).NE.PICT(IPD))) GOTO 899 350 CONTINUE DO 360 I=1,LPICT ! clear special character(s) between blanks STRING(I)=BLANK 360 CONTINUE C ENDIF C C go back to calling routine C 899 RETURN C C errors C 9000 CALL SCOPY('9.99999E',PICT) ! use default E-picture GOTO 10 END