home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istpt / PTLIB.MAC.f < prev   
Encoding:
Text File  |  1989-03-04  |  59.7 KB  |  1,715 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.4
  3. C---------------------------------------------------------
  4. C---------------------------------------------------------
  5. C    TOOLPACK/1    Release: 2.4
  6. C---------------------------------------------------------
  7. C---------------------------------------------------------
  8. C    TOOLPACK/1    Release: 2.4
  9. C---------------------------------------------------------
  10. C---------------------------------------------------------
  11. C    TOOLPACK/1    Release: 2.4
  12. C---------------------------------------------------------
  13.  
  14.  
  15.  
  16.  
  17.  
  18.  
  19.  
  20.  
  21. C                                   parameter length
  22.  
  23.  
  24.  
  25.  
  26.  
  27.  
  28.  
  29.  
  30.  
  31. C following are for ZYCSDT (Canonicalise Symbol Data Types)
  32.         SUBROUTINE PT(OPTSTR,CMTFD,DESC,NERRS,NWARNS)
  33.         INTEGER OPTSTR(81),CMTFD,DESC,NERRS,NWARNS
  34.  
  35. C ----------------------------------------------------------------------
  36. C
  37. C       I S T P T   -   Toolpack Precision Transformer
  38. C
  39. C       Changes the precision of a Fortran-77 program unit from REAL to
  40. C       DOUBLE PRECISION and vice versa.  Complex arithmetic is not
  41. C       handled and not checked for (COMPLEX variables are noticed, and
  42. C       a warning given if they exist).
  43. C
  44. C       Malcolm Cohen, NAG Central Office, 1984
  45. C
  46. C       Modified: Remove need for all names to be explicitly typed.
  47. C                 Malcolm Cohen, March 1985.
  48. C
  49. C       Modified: Turn the body of the code into a callable subroutine
  50. C                 for "monolithification" of tools.
  51. C                 Malcolm Cohen, July 1985.
  52. C
  53. C       Modified: Add DOUBLE COMPLEX conversions.
  54. C                 Malcolm Cohen, November 1985
  55. C
  56. C       Modified: Add REAL*n and COMPLEX*n handling code.
  57. C                 Malcolm Cohen, December 1985
  58. C
  59. C ----------------------------------------------------------------------
  60.  
  61.         COMMON/PTIO/ IODCMT,TKDESC
  62.         INTEGER IODCMT,TKDESC
  63.  
  64.         COMMON/PTERRC/NERROR,NWARN,PUNUM,STMTNO
  65.         INTEGER NERROR,NWARN,PUNUM,STMTNO
  66.  
  67.         COMMON/OPTS/CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
  68.         LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
  69.         INTEGER DTFORM
  70.  
  71. C---------------------------------------------------------
  72. C    TOOLPACK/1    Release: 2.4
  73. C---------------------------------------------------------
  74. C
  75. C  TKLAST = LAST TOKEN NUMBER
  76. C
  77.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  78.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  79.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  80.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  81.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  82.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  83.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  84.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  85.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  86.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  87.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  88.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  89.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  90.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  91.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  92.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  93.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  94.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  95.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  96.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  97.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  98.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  99.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  100.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  101.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  102.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  103.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  104.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  105.  
  106.  
  107.         INTEGER ZYDOWN,ZYNEXT,ZYROOT
  108.         EXTERNAL ZYDOWN,ZYNEXT,ZYROOT,ZTOKWR
  109.  
  110.         SAVE
  111.  
  112.         INTEGER PTR,DUMMY(2)
  113.  
  114.         DATA DUMMY(1)/129/
  115.  
  116.         NERROR=NERRS
  117.         NWARN=NWARNS
  118.  
  119.         CALL PTOPT(OPTSTR)
  120.         IF (NERROR.GT.0) THEN
  121.             NERRS=NERROR
  122.             NWARNS=NWARN
  123.             RETURN
  124.         END IF
  125.         PTR=ZYDOWN(ZYROOT())
  126.         PUNUM=0
  127.  
  128. C Initialise i/o descriptors
  129.         IODCMT=CMTFD
  130.         TKDESC=DESC
  131.  
  132. C Canonicalise symbol data types so we can process them
  133.         CALL ZYCSDT(1,.FALSE.)
  134.  
  135.  100    IF (PTR.GT.0) THEN
  136.             PUNUM=PUNUM+1
  137.             CALL PROPU(PTR)
  138.             PTR=ZYNEXT(PTR)
  139.             GO TO 100
  140.         END IF
  141.         CALL ZTOKWR(TZEOF,0,DUMMY,TKDESC)
  142.         NERRS=NERROR
  143.         NWARNS=NWARN
  144.  
  145.         END
  146. C ----------------------------------------------------------------------
  147. C
  148. C       P R O P U   -   Process Program-Unit
  149. C
  150.  
  151.         SUBROUTINE PROPU(PUROOT)
  152.         INTEGER PUROOT
  153.  
  154.         COMMON/PTERRC/NERROR,NWARN,PUNUM,STMTNO
  155.         INTEGER NERROR,NWARN,PUNUM,STMTNO
  156.  
  157.         INTEGER SPTR,SNUM,BUFF(134),STYPE,PPTR,PTMP,SYMBOL(8)
  158.         LOGICAL SECT1,ESECT1
  159.  
  160. C SECT1: Still in section 1 of a program unit (p.u. header statement,
  161. C        parameter, format, entry and implicit statements)
  162. C ESECT1: Found the end of section 1 (so it is ok to o/p type stmts)
  163.  
  164.         COMMON/PTIO/ IODCMT,TKDESC
  165.         INTEGER IODCMT,TKDESC
  166.  
  167.         COMMON/PUNAMC/PUNAME
  168.         CHARACTER*6 PUNAME
  169.  
  170.         INTEGER ZYDOWN,ZYNEXT,ZYGTCM,ZYGNCM,LENGTH,ZYNTYP
  171.         EXTERNAL ZYDOWN,ZYNEXT,ZYGTCM,ZYGNCM,LENGTH,YSTMT,ZTOKWR,ZYNTYP,
  172.      +           ZYGTSY,ZYGTST
  173.  
  174. C---------------------------------------------------------
  175. C    TOOLPACK/1    Release: 2.4
  176. C---------------------------------------------------------
  177. C
  178. C  TKLAST = LAST TOKEN NUMBER
  179. C
  180.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  181.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  182.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  183.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  184.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  185.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  186.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  187.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  188.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  189.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  190.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  191.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  192.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  193.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  194.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  195.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  196.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  197.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  198.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  199.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  200.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  201.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  202.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  203.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  204.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  205.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  206.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  207.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  208.  
  209.  
  210.         SAVE
  211.  
  212.         DATA SNUM/1/
  213.  
  214.         SPTR=ZYDOWN(PUROOT)
  215.         SECT1=.TRUE.
  216.         ESECT1=.FALSE.
  217.         STYPE=ZYNTYP(SPTR)
  218.         IF (STYPE.EQ.7 .OR. STYPE.EQ.19 .OR.
  219.      +      STYPE.EQ.16 .OR. STYPE.EQ.8) THEN
  220.             PPTR=ZYDOWN(SPTR)
  221.   50        IF (ZYNTYP(PPTR).EQ.108) THEN
  222.                 CALL ZYGTSY(-ZYDOWN(PPTR),SYMBOL)
  223.                 CALL ZYGTST(SYMBOL(2),BUFF)
  224.                 CALL ZITOF(BUFF,1,6,PUNAME,.FALSE.)
  225.             ELSE
  226.                 PPTR=ZYNEXT(PPTR)
  227.                 IF (PPTR.NE.0) GOTO 50
  228.                 PUNAME='$BLOCK'
  229.             END IF
  230.         ELSE
  231.             PUNAME='$MAIN'
  232.         END IF
  233.         PPTR=0
  234.         STMTNO=1
  235.  
  236.  100    IF (ZYGTCM(IODCMT,SNUM,BUFF).EQ.-2) THEN
  237.  200        CALL ZTOKWR(TCMMNT,LENGTH(BUFF),BUFF,TKDESC)
  238.             IF (ZYGNCM(IODCMT,BUFF).EQ.-2) GO TO 200
  239.         END IF
  240.         IF (SECT1) THEN
  241.             STYPE=ZYNTYP(SPTR)
  242.             ESECT1=STYPE.NE.7 .AND. STYPE.NE.8 .AND.
  243.      +             STYPE.NE.16 .AND. STYPE.NE.19 .AND.
  244.      +             STYPE.NE.35 .AND. STYPE.NE.32 .AND.
  245.      +             STYPE.NE.78 .AND. STYPE.NE.18
  246.         END IF
  247.         IF (ESECT1) THEN
  248.             SECT1=.FALSE.
  249.             ESECT1=.FALSE.
  250.             CALL DODECL
  251.             IF (PPTR.NE.0) CALL PTPARA(PPTR,SPTR)
  252.         END IF
  253.         IF (SECT1 .AND. STYPE.EQ.35) THEN
  254.             CALL DOPARA(SPTR,PTMP)
  255.             IF (PTMP.EQ.0) CALL YSTMT(SPTR,TKDESC)
  256.             IF (PPTR.EQ.0) PPTR=PTMP
  257.         ELSE
  258.             CALL DOSTMT(SPTR)
  259.             CALL YSTMT(SPTR,TKDESC)
  260.         END IF
  261.         SNUM=SNUM+1
  262.         STMTNO=STMTNO+1
  263.         SPTR=ZYNEXT(SPTR)
  264.         IF (SPTR.NE.0) GOTO 100
  265.  
  266.         END
  267. C ----------------------------------------------------------------------
  268. C
  269. C       P T O P T   -   Decode an ISTPT option string.
  270. C
  271.  
  272.         SUBROUTINE PTOPT(OPTSTR)
  273.         INTEGER OPTSTR(81)
  274.  
  275.         COMMON/OPTS/CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
  276.         LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
  277.         INTEGER DTFORM
  278.  
  279.         INTEGER OPTTBL(86),STRING(134),POINT,DCFTBL(26),OPTNUM,
  280.      +          LHS(134),RHS(134)
  281.  
  282.         SAVE OPTTBL,DCFTBL,/OPTS/
  283.  
  284.         INTEGER ZKWLUK,GETWRD,ZSPLIT
  285.         EXTERNAL ZKWLUK,GETWRD,ZSPLIT,ZCHOUT,PUTLIN,ZMESS
  286.  
  287.         DATA OPTTBL/8,
  288.      +      97,117,120,105,108,105,97,114,121,95,
  289.      +99,111,110,118,101,114,116,129,
  290.      +      99,111,109,109,111,110,95,99,111,110,118,
  291.      +101,114,116,129,
  292.      +      99,111,110,118,101,114,116,95,110,97,109,
  293.      +101,115,129,
  294.      +      100,99,102,111,114,109,129,
  295.      +      100,111,117,98,108,101,129,
  296.      +      110,97,103,95,114,111,117,116,105,110,101,
  297.      +129,
  298.      +      110,111,110,101,129,
  299.      +      115,105,110,103,108,101,129/
  300.  
  301.         DATA DCFTBL/2,
  302.      +       107,101,121,119,111,114,100,129,
  303.      +       108,101,110,103,116,104,95,115,112,101,99,
  304.      +105,102,105,101,114,129/
  305.  
  306.         CVTNAM=.FALSE.
  307.         CVTAUX=.FALSE.
  308.         CVTCOM=.FALSE.
  309.         RTODBL=.TRUE.
  310.         DTFORM=1
  311.         POINT=1
  312.  
  313.  100    IF (GETWRD(OPTSTR,POINT,STRING).EQ.0) RETURN
  314.         IF (ZSPLIT(STRING,LHS,RHS).NE.-2) THEN
  315.             CALL SCOPY(STRING,1,LHS,1)
  316.             RHS(1)=129
  317.         END IF
  318.         OPTNUM=ZKWLUK(LHS,OPTTBL)
  319.         IF (OPTNUM.LE.0) THEN
  320.             IF (OPTNUM.EQ.0) CALL ZCHOUT('Warning: Ambiguous',2)
  321.             IF (OPTNUM.EQ.-1)  CALL ZCHOUT('Warning: Unknown',2)
  322.             CALL ZCHOUT(' Option "',2)
  323.             CALL PUTLIN(STRING,2)
  324.             CALL ZMESS('" Ignored',2)
  325.         ELSE IF (OPTNUM.EQ.1) THEN
  326.             CVTAUX=.TRUE.
  327.         ELSE IF (OPTNUM.EQ.2) THEN
  328.             CVTCOM=.TRUE.
  329.         ELSE IF (OPTNUM.EQ.3) THEN
  330.             CVTNAM=.TRUE.
  331.         ELSE IF (OPTNUM.EQ.4) THEN
  332.             OPTNUM=ZKWLUK(RHS,DCFTBL)
  333.             IF (OPTNUM.LT.1) THEN
  334.                 CALL REMARK('Warning: Invalid value for option DCFORM')
  335.             ELSE IF (OPTNUM.EQ.1) THEN
  336.                 DTFORM=1
  337.             ELSE
  338.                 DTFORM=3
  339.             END IF
  340.         ELSE IF (OPTNUM.EQ.5) THEN
  341.             RTODBL=.TRUE.
  342.         ELSE IF (OPTNUM.EQ.6) THEN
  343.             CVTNAM=.TRUE.
  344.             CVTAUX=.TRUE.
  345.             CVTCOM=.TRUE.
  346.         ELSE IF (OPTNUM.EQ.8) THEN
  347.             RTODBL=.FALSE.
  348.         END IF
  349.         GOTO 100
  350.  
  351.         END
  352. C ----------------------------------------------------------------------
  353. C
  354. C       D O P A R A   -   Scan PARAMETER statement for implicitly typed
  355. C                         names which have changed type
  356. C
  357.  
  358.         SUBROUTINE DOPARA(SPTR,PPTR)
  359.         INTEGER SPTR,PPTR
  360.  
  361.         COMMON/OPTS/ CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
  362.         LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
  363.         INTEGER DTFORM
  364.  
  365.         COMMON/PTIO/ IODCMT,TKDESC
  366.         INTEGER IODCMT,TKDESC
  367.  
  368. C---------------------------------------------------------
  369. C    TOOLPACK/1    Release: 2.4
  370. C---------------------------------------------------------
  371. C
  372. C  TKLAST = LAST TOKEN NUMBER
  373. C
  374.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  375.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  376.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  377.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  378.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  379.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  380.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  381.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  382.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  383.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  384.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  385.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  386.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  387.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  388.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  389.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  390.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  391.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  392.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  393.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  394.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  395.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  396.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  397.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  398.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  399.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  400.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  401.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  402.  
  403.  
  404.         INTEGER PTR,SYMBOL(8),DUMMY(2)
  405.         LOGICAL FIRST
  406.  
  407.         SAVE /OPTS/,/PTIO/
  408.  
  409.         INTEGER ZYDOWN,ZYNEXT,ZIAND
  410.         EXTERNAL ZYDOWN,ZYNEXT,ZIAND,ZYGTSY,ZTOKWR,YLEAF,YEXPR
  411.  
  412.         DATA DUMMY(1)/129/
  413.  
  414.         PPTR=0
  415.         PTR=ZYDOWN(SPTR)
  416.  100    CALL ZYGTSY(-ZYDOWN(ZYDOWN(PTR)),SYMBOL)
  417.         IF ((RTODBL .AND.
  418.      +          (SYMBOL(4).EQ.2 .OR.
  419.      +           SYMBOL(4).EQ.4) .OR.
  420.      +      .NOT.RTODBL .AND.
  421.      +          (SYMBOL(4).EQ.5 .OR.
  422.      +           SYMBOL(4).EQ.7)) .AND.
  423.      +      ZIAND(SYMBOL(6),
  424.      +            8+4096+2).EQ.0) THEN
  425.             PPTR=SPTR
  426.         END IF
  427.         PTR=ZYNEXT(PTR)
  428.         IF (PTR.NE.0) GOTO 100
  429.         IF (PPTR.NE.SPTR) RETURN
  430.  
  431. C Found a nasty-type PARAMETER statement - output anything from it that
  432. C we must
  433.  
  434.         PTR=ZYDOWN(SPTR)
  435.         FIRST=.TRUE.
  436.  200    CALL ZYGTSY(-ZYDOWN(ZYDOWN(PTR)),SYMBOL)
  437.         IF (.NOT.(
  438.      +          (RTODBL .AND.
  439.      +              (SYMBOL(4).EQ.2 .OR.
  440.      +               SYMBOL(4).EQ.4) .OR.
  441.      +          .NOT.RTODBL .AND.
  442.      +              (SYMBOL(4).EQ.5 .OR.
  443.      +               SYMBOL(4).EQ.7)) .AND.
  444.      +          ZIAND(SYMBOL(6),
  445.      +              8+4096+2).EQ.0)) THEN
  446.             IF (FIRST) THEN
  447.                 CALL ZTOKWR(TPARAM,0,DUMMY,TKDESC)
  448.                 CALL ZTOKWR(TLPARN,0,DUMMY,TKDESC)
  449.                 FIRST=.FALSE.
  450.             ELSE
  451.                 CALL ZTOKWR(TCOMMA,0,DUMMY,TKDESC)
  452.             END IF
  453.             CALL YLEAF(ZYDOWN(PTR),TKDESC)
  454.             CALL ZTOKWR(TEQUAL,0,DUMMY,TKDESC)
  455.             CALL YEXPR(ZYNEXT(ZYDOWN(PTR)),TKDESC)
  456.         END IF
  457.         PTR=ZYNEXT(PTR)
  458.         IF (PTR.NE.0) GOTO 200
  459.         IF (.NOT.FIRST) THEN
  460.             CALL ZTOKWR(TRPARN,0,DUMMY,TKDESC)
  461.             CALL ZTOKWR(TZEOS,0,DUMMY,TKDESC)
  462.         END IF
  463.  
  464.         END
  465. C ----------------------------------------------------------------------
  466. C
  467. C       P T P A R A   -   Put extra PARAMETER statements out now, after
  468. C                         the appropriate type statements
  469. C
  470.  
  471.         SUBROUTINE PTPARA(PPTR,FPTR)
  472.         INTEGER PPTR,FPTR
  473.  
  474.         COMMON/OPTS/ CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
  475.         LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
  476.         INTEGER DTFORM
  477.  
  478.         COMMON/PTIO/ IODCMT,TKDESC
  479.         INTEGER IODCMT,TKDESC
  480.  
  481. C---------------------------------------------------------
  482. C    TOOLPACK/1    Release: 2.4
  483. C---------------------------------------------------------
  484. C
  485. C  TKLAST = LAST TOKEN NUMBER
  486. C
  487.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  488.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  489.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  490.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  491.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  492.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  493.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  494.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  495.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  496.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  497.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  498.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  499.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  500.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  501.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  502.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  503.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  504.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  505.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  506.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  507.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  508.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  509.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  510.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  511.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  512.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  513.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  514.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  515.  
  516.  
  517.         INTEGER PTR,SYMBOL(8),SPTR,DUMMY(2)
  518.  
  519.         SAVE /OPTS/,/PTIO/
  520.  
  521.         INTEGER ZYDOWN,ZYNEXT,ZIAND,ZYNTYP
  522.         EXTERNAL ZYDOWN,ZYNEXT,ZIAND,ZYNTYP,ZYGTSY,ZTOKWR,YLEAF,YEXPR
  523.  
  524.         DATA DUMMY(1)/129/
  525.  
  526.         SPTR=PPTR
  527.  100    PTR=ZYDOWN(SPTR)
  528.         CALL DOSTMT(SPTR)
  529.  200    CALL ZYGTSY(-ZYDOWN(ZYDOWN(PTR)),SYMBOL)
  530.         IF ((RTODBL .AND.
  531.      +          (SYMBOL(4).EQ.2 .OR.
  532.      +           SYMBOL(4).EQ.4) .OR.
  533.      +      .NOT.RTODBL .AND.
  534.      +          (SYMBOL(4).EQ.5 .OR.
  535.      +           SYMBOL(4).EQ.7)) .AND.
  536.      +      ZIAND(SYMBOL(6),
  537.      +            8+4096+2).EQ.0) THEN
  538.             CALL ZTOKWR(TPARAM,0,DUMMY,TKDESC)
  539.             CALL ZTOKWR(TLPARN,0,DUMMY,TKDESC)
  540.             CALL YLEAF(ZYDOWN(PTR),TKDESC)
  541.             CALL ZTOKWR(TEQUAL,0,DUMMY,TKDESC)
  542.             CALL YEXPR(ZYNEXT(ZYDOWN(PTR)),TKDESC)
  543.             CALL ZTOKWR(TRPARN,0,DUMMY,TKDESC)
  544.             CALL ZTOKWR(TZEOS,0,DUMMY,TKDESC)
  545.         END IF
  546.         PTR=ZYNEXT(PTR)
  547.         IF (PTR.NE.0) GOTO 200
  548.  300    SPTR=ZYNEXT(SPTR)
  549.         IF (SPTR.NE.FPTR) THEN
  550.             IF (ZYNTYP(SPTR).EQ.35) GOTO 100
  551.             GOTO 300
  552.         END IF
  553.  
  554.         END
  555. C ----------------------------------------------------------------------
  556. C
  557. C       D O D E C L   -   Do declare implicitly typed names
  558. C
  559.  
  560.         SUBROUTINE DODECL
  561.  
  562.         COMMON/PTERRC/NERROR,NWARN,PUNUM,STMTNO
  563.         INTEGER NERROR,NWARN,PUNUM,STMTNO
  564.  
  565.         COMMON/OPTS/ CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
  566.         LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
  567.         INTEGER DTFORM
  568.  
  569.         COMMON/PTIO/ IODCMT,TKDESC
  570.         INTEGER IODCMT,TKDESC
  571.  
  572. C---------------------------------------------------------
  573. C    TOOLPACK/1    Release: 2.4
  574. C---------------------------------------------------------
  575. C
  576. C  TKLAST = LAST TOKEN NUMBER
  577. C
  578.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  579.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  580.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  581.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  582.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  583.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  584.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  585.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  586.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  587.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  588.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  589.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  590.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  591.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  592.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  593.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  594.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  595.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  596.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  597.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  598.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  599.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  600.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  601.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  602.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  603.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  604.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  605.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  606.  
  607.  
  608.         SAVE /PTERRC/,/OPTS/,/PTIO/
  609.  
  610.         INTEGER SYMPTR,SYMBOL(8),TEXT(134),TEXT2(134)
  611.  
  612.         LOGICAL NAMCH1
  613.  
  614.         INTEGER ZYGNSW,ZIAND,LENGTH
  615.         EXTERNAL ZYGNSW,ZIAND,YDTYPE,ZYGTST,LENGTH,SCOPY
  616.  
  617.         SYMPTR=0
  618.         IF (ZYGNSW(SYMPTR,PUNUM,SYMBOL).NE.-2)
  619.      +      CALL ERROR('No symbols in program unit')
  620.  100    IF ((RTODBL .AND.
  621.      +          (SYMBOL(4).EQ.2 .OR.
  622.      +           SYMBOL(4).EQ.4) .OR.
  623.      +      .NOT.RTODBL .AND.
  624.      +          (SYMBOL(4).EQ.5 .OR.
  625.      +           SYMBOL(4).EQ.7)) .AND.
  626.      +      ZIAND(SYMBOL(6),
  627.      +            8+4096+2).EQ.0) THEN
  628.             CALL ZYGTST(SYMBOL(2),TEXT)
  629.             IF (CVTNAM .OR. CVTAUX) THEN
  630.                 IF (NAMCH1(TEXT,TEXT2)) CALL SCOPY(TEXT2,1,TEXT,1)
  631.             END IF
  632.             IF (SYMBOL(4).EQ.2 .AND.
  633.      +          SYMBOL(5).EQ.0) THEN
  634.                 CALL YDTYPE(5,0,TKDESC)
  635.             ELSE IF (SYMBOL(4).EQ.2) THEN
  636.                 CALL YDTYPE(2,SYMBOL(5),TKDESC)
  637.             ELSE IF (SYMBOL(4).EQ.4) THEN
  638.                 IF (DTFORM.EQ.1) THEN
  639.                     CALL YDTYPE(7,0,TKDESC)
  640.                 ELSE
  641.                     CALL YDTYPE(4,4*4,TKDESC)
  642.                 END IF
  643.             ELSE IF (SYMBOL(4).EQ.5) THEN
  644.                 CALL YDTYPE(2,0,TKDESC)
  645.             ELSE
  646.                 CALL YDTYPE(4,0,TKDESC)
  647.             END IF
  648.             CALL ZTOKWR(TNAME,LENGTH(TEXT),TEXT,TKDESC)
  649.             TEXT(1)=129
  650.             CALL ZTOKWR(TZEOS,0,TEXT,TKDESC)
  651.         END IF
  652.         IF (ZYGNSW(SYMPTR,PUNUM,SYMBOL).EQ.-2) GOTO 100
  653.  
  654.         END
  655. C ----------------------------------------------------------------------
  656. C
  657. C       D O S T M T   -   Process statement
  658. C
  659.  
  660.         SUBROUTINE DOSTMT(SROOT)
  661.         INTEGER SROOT
  662.  
  663.         COMMON/OPTS/ CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
  664.         LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
  665.         INTEGER DTFORM
  666.  
  667.         INTEGER PTR,STYPE,NTYPE,DFR(6),DFP(27),RFR(6),RFP(27),STATUS,
  668.      +          STR1(134),STR2(134),STRPTR,NEXT,PTR2,VALUE
  669.  
  670.         SAVE /OPTS/,DFP,RFP,DFR,RFR
  671.  
  672.         INTEGER ZYNTYP,ZYNEXT,ZYDOWN,ZSETP,ZSETR,ZPREPL,ADDSTR,ZYUP,
  673.      +          CTOI,ITOC,ZYASTR,ZYCRND
  674.         EXTERNAL ZYNTYP,ZYNEXT,ZYDOWN,ZSETP,ZSETR,ZPREPL,ZYGTST,ADDSTR,
  675.      +           ZYSATT,ZYUP,ZYCHNT,ZYDELT,CTOI,ITOC,SKIPBL,ZYASTR,
  676.      +           ZYCRND,ZYADSN
  677.  
  678. C RFP "%<[0-9]*>E<[0-9]*.[0-9]*>$"
  679. C DFP "%<[0-9]*>D<[0-9]*.[0-9]*>$"
  680. C RFR "&1E&2"
  681. C DFR "&1D&2"
  682.  
  683.         DATA RFP/37,60,91,48,45,57,93,42,62,
  684.      +69,60,91,48,45,57,93,42,46,91,48,
  685.      +45,57,93,42,62,36,129/
  686.         DATA DFP/37,60,91,48,45,57,93,42,62,
  687.      +68,60,91,48,45,57,93,42,46,91,48,
  688.      +45,57,93,42,62,36,129/
  689.         DATA RFR/38,49,69,38,50,129/
  690.         DATA DFR/38,49,68,38,50,129/
  691.  
  692.         STYPE=ZYNTYP(SROOT)
  693.         PTR=ZYDOWN(SROOT)
  694.         IF (STYPE.EQ.78) THEN
  695. C FORMAT
  696.             IF (RTODBL) THEN
  697.                 STATUS=ZSETP(RFP,.TRUE.)
  698.                 STATUS=ZSETR(DFR)
  699.             ELSE
  700.                 STATUS=ZSETP(DFP,.TRUE.)
  701.                 STATUS=ZSETR(RFR)
  702.             END IF
  703.  100        IF (ZYNTYP(PTR).EQ.112) THEN
  704.                 CALL ZYGTST(-ZYDOWN(PTR),STR1)
  705.                 IF (ZPREPL(STR1,STR2,.FALSE.).EQ.-2) THEN
  706.                     STRPTR=ADDSTR(STR2)
  707.                     CALL ZYCHDN(PTR,-STRPTR)
  708.                 END IF
  709.             END IF
  710.             NEXT=ZYDOWN(PTR)
  711.  200        IF (NEXT.LE.0) NEXT=ZYNEXT(PTR)
  712.             IF (NEXT.LE.0) THEN
  713.                 PTR=ZYUP(PTR)
  714.                 IF (PTR.NE.SROOT) GO TO 200
  715.             END IF
  716.             IF (NEXT.GT.0) THEN
  717.                 PTR=NEXT
  718.                 GO TO 100
  719.             END IF
  720.         ELSE IF (STYPE.EQ.24) THEN
  721. C EQUIVALENCE
  722.             CALL CHKEQV(PTR)
  723.         ELSE IF (STYPE.NE.20 .AND.
  724.      +      (STYPE.NE.26 .OR. CVTCOM)) THEN
  725. C All other appropriate statements
  726.             IF (STYPE.EQ.8 .OR. STYPE.EQ.30) THEN
  727. C FUNCTION/TYPE only
  728.                 IF (ZYNTYP(PTR).EQ.115) PTR=ZYNEXT(PTR)
  729.                 NTYPE=ZYNTYP(PTR)
  730.                 IF (NTYPE.EQ.10) THEN
  731.                     PTR2=ZYDOWN(PTR)
  732.                     IF (PTR2.NE.0) THEN
  733. C Handle REAL*n cases by converting them to their equivalents
  734.                         CALL ZYGTST(-ZYDOWN(PTR2),STR1)
  735.                         PTR2=1
  736.                         VALUE=CTOI(STR1,PTR2)
  737.                         IF (VALUE.EQ.4*4) THEN
  738.                             CALL OUTERR(
  739.      +                          'Cannot handle quadruple precision')
  740.                         ELSE IF (VALUE.EQ.2*4) THEN
  741.                             CALL ZYCHNT(PTR,11)
  742.                             NTYPE=11
  743.                         ELSE IF (VALUE.NE.4) THEN
  744.                             CALL  OUTERR('Invalid REAL*value')
  745.                         END IF
  746.                         IF (VALUE.EQ.4 .OR.
  747.      +                      VALUE.EQ.2*4)
  748.      +                      CALL ZYDELT(ZYDOWN(PTR))
  749.                     END IF
  750.                 ELSE IF (NTYPE.EQ.12) THEN
  751.                     PTR2=ZYDOWN(PTR)
  752.                     IF (PTR2.NE.0) THEN
  753. C Ditto COMPLEX*n
  754.                         CALL ZYGTST(-ZYDOWN(PTR2),STR1)
  755.                         PTR2=1
  756.                         VALUE=CTOI(STR1,PTR2)
  757.                         IF (VALUE.EQ.4*4) THEN
  758.                             CALL ZYCHNT(PTR,125)
  759.                             NTYPE=125
  760.                         ELSE IF (VALUE.NE.2*4) THEN
  761.                             CALL OUTERR('Invalid COMPLEX*value')
  762.                         END IF
  763.                         IF (VALUE.EQ.2*4 .OR.
  764.      +                      VALUE.EQ.4*4)
  765.      +                      CALL ZYDELT(ZYDOWN(PTR))
  766.                     END IF
  767.                 END IF
  768.                 IF (NTYPE.EQ.10 .AND. ZYDOWN(PTR).EQ.0) THEN
  769.                     IF (RTODBL) THEN
  770.                         CALL ZYCHNT(PTR,11)
  771.                     ELSE
  772.                         CALL OUTWRN('Already single-precision')
  773.                     END IF
  774.                 ELSE IF (NTYPE.EQ.11) THEN
  775.                     IF (RTODBL) THEN
  776.                         CALL OUTWRN('Already double-precision')
  777.                     ELSE
  778.                         CALL ZYCHNT(PTR,10)
  779.                     END IF
  780.                 ELSE IF (NTYPE.EQ.12) THEN
  781.                     IF (RTODBL) THEN
  782.                         IF (DTFORM.EQ.1) THEN
  783.                             CALL ZYCHNT(PTR,125)
  784.                         ELSE
  785.                             PTR2=ITOC(4*4,STR1,3)
  786.                             PTR2=1
  787.                             CALL SKIPBL(STR1,PTR2)
  788.                             CALL ZYADSN(PTR,ZYCRND(107,
  789.      +                                             -ADDSTR(STR1(PTR2))))
  790.                         END IF
  791.                     ELSE
  792.                         CALL OUTWRN('Already single-precision complex')
  793.                     END IF
  794.                 ELSE IF (NTYPE.EQ.125) THEN
  795.                     IF (RTODBL) THEN
  796.                         CALL OUTWRN('Already double-precision complex')
  797.                         IF (DTFORM.NE.1) THEN
  798.                             CALL ZYCHNT(PTR,12)
  799.                             PTR2=ITOC(4*4,STR1,3)
  800.                             PTR2=1
  801.                             CALL SKIPBL(STR1,PTR2)
  802.                             CALL ZYADSN(PTR,ZYCRND(107,
  803.      +                                             -ADDSTR(STR1(PTR2))))
  804.                         END IF
  805.                     ELSE
  806.                         CALL ZYCHNT(PTR,12)
  807.                     END IF
  808.                 END IF
  809.             END IF
  810. C All including FUNCTION/TYPE (but not FORMAT/EQUIVALENCE/etc.
  811.             IF (PTR.EQ.0) RETURN
  812.  300        NTYPE=ZYNTYP(PTR)
  813.             IF (NTYPE.EQ.110 .OR. NTYPE.EQ.111 .OR.
  814.      +          NTYPE.EQ.102) THEN
  815.                 CALL CHCNST(PTR,NTYPE)
  816.             ELSE IF (NTYPE.EQ.108) THEN
  817.                 CALL CHNAME(PTR)
  818.             ELSE IF (NTYPE.EQ.40 .AND. CVTCOM) THEN
  819.                 CALL CHCNAM(PTR)
  820.             END IF
  821.             NEXT=ZYDOWN(PTR)
  822.  400        IF (NEXT.LE.0) NEXT=ZYNEXT(PTR)
  823.             IF (NEXT.LE.0) THEN
  824.                 PTR=ZYUP(PTR)
  825.                 IF (PTR.NE.SROOT) GO TO 400
  826.             END IF
  827.             IF (NEXT.GT.0) THEN
  828.                 PTR=NEXT
  829.                 GO TO 300
  830.             END IF
  831.         END IF
  832.  
  833.         END
  834. C ----------------------------------------------------------------------
  835. C
  836. C       C H K E Q V   -   Check EQUIVALENCE statement for badness
  837. C
  838.  
  839.         SUBROUTINE CHKEQV(NODE)
  840.         INTEGER NODE
  841.  
  842.         COMMON/OPTS/CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
  843.         LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
  844.         INTEGER DTFORM
  845.  
  846.         INTEGER SETPTR,ELTPTR,NXITMS,NOITMS,SYMBOL(8),PTR
  847.  
  848.         INTEGER ZYNTYP,ZYDOWN,ZYNEXT
  849.         EXTERNAL ZYNTYP,ZYDOWN,ZYNEXT,ZYGTSY
  850.  
  851.         SAVE /OPTS/
  852.  
  853.         SETPTR=NODE
  854.  
  855.  100    ELTPTR=ZYDOWN(SETPTR)
  856.         NXITMS=0
  857.         NOITMS=0
  858.  
  859.  200    IF (ZYNTYP(ELTPTR).EQ.108) THEN
  860.             CALL ZYGTSY(-ZYDOWN(ELTPTR),SYMBOL)
  861.         ELSE
  862.             PTR=ZYDOWN(ELTPTR)
  863.             IF (ZYNTYP(PTR).NE.108) PTR=ZYDOWN(PTR)
  864.             CALL ZYGTSY(-ZYDOWN(PTR),SYMBOL)
  865.         END IF
  866.         IF (((SYMBOL(4).EQ.2 .OR.
  867.      +      SYMBOL(4).EQ.4).AND. RTODBL) .OR.
  868.      +      ((SYMBOL(4).EQ.5 .OR.
  869.      +      SYMBOL(4).EQ.7) .AND. .NOT.RTODBL)) THEN
  870.             NXITMS=NXITMS+1
  871.         ELSE
  872.             NOITMS=NOITMS+1
  873.         END IF
  874.         ELTPTR=ZYNEXT(ELTPTR)
  875.         IF (ELTPTR.GT.0) GO TO 200
  876.         IF (NXITMS.GT.0 .AND. NOITMS.GT.0) THEN
  877.             CALL OUTERR('EQUIVALENCE statement has changed meaning')
  878.         ELSE
  879.             SETPTR=ZYNEXT(SETPTR)
  880.             IF (SETPTR.GT.0) GO TO 100
  881.         END IF
  882.  
  883.         END
  884. C ----------------------------------------------------------------------
  885. C
  886. C       C H C N S T   -   Change constant
  887. C
  888.  
  889.         SUBROUTINE CHCNST(PTR,NTYPE)
  890.         INTEGER PTR,NTYPE
  891.  
  892.         COMMON/OPTS/ CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
  893.         LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
  894.         INTEGER DTFORM
  895.  
  896.         INTEGER STRPTR,STR1(134),STR2(134),STATUS,RR1(3),RR2(6),
  897.      +          DR1(6),DR2(5),RCP1(35),RCP2(19),DCP1(20),DCP2(35),P1,P2,
  898.      +          I
  899.  
  900.         SAVE RR1,DR1,RR2,DR2,RCP1,RCP2,DCP1,DCP2,/OPTS/
  901.  
  902.         INTEGER ADDSTR,ZPREPL,ZSETR,ZSETP,ZYDOWN,ZYNTYP,ZYNEXT,LENGTH
  903.         EXTERNAL ZYGTST,ADDSTR,ZYCHDN,ZSETP,ZSETR,ZPREPL,ZYDOWN,ZYNTYP,
  904.      +           ZYNEXT,LENGTH
  905.  
  906. C RCP1 "%<[0-9]*.*[0-9]*>E<[+@- ]*[0-9]*>$"
  907. C RCP2 "%<[0-9]*.*[0-9]*>$"
  908. C DCP1 "%<[0-9]*.[0-9]*>D0$"
  909. C DCP2 "%<[0-9]*.*[0-9]*>D<[+@- ]*[0-9]*>$"
  910. C RR1 "&1"
  911. C DR1 "&1D&2"
  912. C RR2 "&1E&2"
  913. C DR2 "&1D0"
  914.  
  915.         DATA RCP1/37,60,91,48,45,57,93,42,
  916.      +46,42,91,48,45,57,93,42,62,69,60,
  917.      +91,64,43,45,32,93,42,91,48,45,57,
  918.      +93,42,62,36,129/
  919.         DATA RCP2/37,60,91,48,45,57,93,42,
  920.      +46,42,91,48,45,57,93,42,62,36,129/
  921.         DATA DCP1/37,60,91,48,45,57,93,42,
  922.      +46,91,48,45,57,93,42,62,68,48,
  923.      +36,129/
  924.         DATA DCP2/37,60,91,48,45,57,93,42,
  925.      +46,42,91,48,45,57,93,42,62,68,60,
  926.      +91,43,64,45,32,93,42,91,48,45,57,
  927.      +93,42,62,36,129/
  928.         DATA RR2/38,49,69,38,50,129/
  929.         DATA DR1/38,49,68,38,50,129/
  930.         DATA RR1/38,49,129/
  931.         DATA DR2/38,49,68,48,129/
  932.  
  933.         IF (NTYPE.NE.102) CALL ZYGTST(-ZYDOWN(PTR),STR1)
  934.         IF (NTYPE.EQ.110) THEN
  935.             IF (RTODBL) THEN
  936.                 STATUS=ZSETP(RCP1,.TRUE.)
  937.                 STATUS=ZSETR(DR1)
  938.                 STATUS=ZPREPL(STR1,STR2,.FALSE.)
  939.                 IF (STATUS.NE.-2) THEN
  940.                     STATUS=ZSETP(RCP2,.TRUE.)
  941.                     STATUS=ZSETR(DR2)
  942.                     STATUS=ZPREPL(STR1,STR2,.FALSE.)
  943.                 END IF
  944.                 IF (STATUS.NE.-2) THEN
  945.                     CALL OUTERR('Invalid real constant format')
  946.                 ELSE
  947.                     STRPTR=ADDSTR(STR2)
  948.                     CALL ZYCHDN(PTR,-STRPTR)
  949.                     CALL ZYCHNT(PTR,111)
  950.                 END IF
  951.             ELSE
  952.                 CALL OUTWRN('Constant already single-precision')
  953.             END IF
  954.  
  955.         ELSE IF (NTYPE.EQ.111) THEN
  956.             IF (RTODBL) THEN
  957.                 CALL OUTWRN('Constant already double-precision')
  958.             ELSE
  959.                 STATUS=ZSETP(DCP1,.TRUE.)
  960.                 STATUS=ZSETR(RR1)
  961.                 STATUS=ZPREPL(STR1,STR2,.FALSE.)
  962.                 IF (STATUS.NE.-2) THEN
  963.                     STATUS=ZSETP(DCP2,.TRUE.)
  964.                     STATUS=ZSETR(RR2)
  965.                     STATUS=ZPREPL(STR1,STR2,.FALSE.)
  966.                 END IF
  967.                 IF (STATUS.NE.-2) THEN
  968.                     CALL OUTERR('Invalid double precision constant')
  969.                 ELSE
  970.                     STRPTR=ADDSTR(STR2)
  971.                     CALL ZYCHDN(PTR,-STRPTR)
  972.                     CALL ZYCHNT(PTR,110)
  973.                 END IF
  974.             END IF
  975.         ELSE IF (NTYPE.EQ.102) THEN
  976.             P1=ZYDOWN(PTR)
  977.             P2=ZYNEXT(P1)
  978.             IF (ZYNTYP(P1).EQ.46) P1=ZYDOWN(P1)
  979.             IF (ZYNTYP(P2).EQ.46) P2=ZYDOWN(P2)
  980.             IF (ZYNTYP(P1).EQ.107 .AND. ZYNTYP(P2).EQ.107)
  981.      +      THEN
  982. C Complex constant with both parts integral - change first to real so
  983. C it will be converted to the correct type of constant later.
  984.                 CALL ZYGTST(-ZYDOWN(P1),STR1)
  985.                 I=LENGTH(STR1)+1
  986.                 STR1(I)=69
  987.                 STR1(I+1)=48
  988.                 STR1(I+2)=129
  989.                 STRPTR=ADDSTR(STR1)
  990.                 CALL ZYCHDN(P1,-STRPTR)
  991.                 CALL ZYCHNT(P1,110)
  992.             END IF
  993.         END IF
  994.  
  995.         END
  996. C ----------------------------------------------------------------------
  997. C
  998. C       C H N A M E   -   Change name if necessary
  999. C
  1000.  
  1001.         SUBROUTINE CHNAME(PTR)
  1002.         INTEGER PTR
  1003.  
  1004.         INTEGER NRTODF,NDTORF,NBADF
  1005.         PARAMETER (NRTODF=9,NDTORF=19,NBADF=11)
  1006.  
  1007.         COMMON/OPTS/ CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
  1008.         LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
  1009.         INTEGER DTFORM
  1010.  
  1011.         COMMON/PTERRC/NERROR,NWARN,PUNUM,STMTNO
  1012.         INTEGER NERROR,NWARN,PUNUM,STMTNO
  1013.  
  1014.         INTEGER SYMBOL(8),TEXT1(134),TEXT2(134),
  1015.      +          STRPTR,I,SYMPTR,NTYPE
  1016.         LOGICAL CHG
  1017.         CHARACTER*6 FNAME,RTODFN(2,NRTODF),DTORFN(2,NDTORF),
  1018.      +              BADFNS(NBADF)
  1019.  
  1020.         SAVE /OPTS/,RTODFN,DTORFN,BADFNS,/PTERRC/
  1021.  
  1022.         LOGICAL BADFUN,NAMCH1
  1023.         INTEGER ZYDOWN,ZIAND,ZYNTYP,ZYUP,ADDSTR,ZYASYM
  1024.         EXTERNAL ZYDOWN,ZIAND,ZYGTSY,ZYGTST,ZITOF,ZYASYM,ZYCHDN,
  1025.      +           ZFTOI,ZYNTYP,ZYUP,ZSTRIP,ADDSTR
  1026.  
  1027.         DATA RTODFN/'AMOD','DMOD','AMAX1','DMAX1','AMIN1','DMIN1',
  1028.      +'ALOG','DLOG','ALOG10','DLOG10','AIMAG','DIMAG',
  1029.      +'CMPLX','DCMPLX','CONJG','DCONJG','CABS','CDABS'/,
  1030.      +       DTORFN/'DINT','AINT','DNINT','ANINT','IDNINT','NINT',
  1031.      +'DABS','ABS','DSIGN','SIGN','DDIM','DIM','DSQRT','SQRT',
  1032.      +'DEXP','EXP','DSIN','SIN','DCOS','COS','DTAN','TAN',
  1033.      +'DASIN','ASIN','DACOS','ACOS','DATAN','ATAN','DATAN2','ATAN2',
  1034.      +'DSINH','SINH','DCOSH','COSH','DTANH','TANH','IDINT','INT'/,
  1035.      +       BADFNS/'INT','SNGL','DBLE','DPROD','MAX1','AMAX0',
  1036.      +'AMIN0','MIN1','REAL','FLOAT','IFIX'/
  1037.  
  1038. C RTODFN: Functions which must always be changed from one to the other
  1039. C         (we do not attempt to genericise the program at all).
  1040. C DTORFN: Functions which must always be changed from double precision,
  1041. C         but whose single-precision forms are generic names, so need only
  1042. C         be changed when used as an actual parameter.
  1043. C BADFNS: Functions which need special checking or special processing, such
  1044. C         as type conversion functions involving real or double.
  1045.  
  1046.         CALL ZYGTSY(-ZYDOWN(PTR),SYMBOL)
  1047.         IF (SYMBOL(1).NE.7 .AND.
  1048.      +      SYMBOL(1).NE.4) RETURN
  1049.         CALL ZYGTST(SYMBOL(2),TEXT1)
  1050.         IF (ZIAND(SYMBOL(6),4096).EQ.0) THEN
  1051.             IF (NAMCH1(TEXT1,TEXT2)) THEN
  1052.                 STRPTR=ADDSTR(TEXT2)
  1053.                 SYMPTR=ZYASYM(STRPTR,PUNUM,SYMBOL(1))
  1054.                 CALL ZYCHDN(PTR,-SYMPTR)
  1055.             END IF
  1056.         ELSE
  1057.             CHG=.FALSE.
  1058.             CALL ZITOF(TEXT1,1,6,FNAME,.FALSE.)
  1059.             IF (RTODBL) THEN
  1060.                 I=0
  1061.  100            I=I+1
  1062.                 IF (I.LT.NRTODF .AND. RTODFN(1,I).NE.FNAME) GOTO 100
  1063.                 NTYPE=ZYNTYP(ZYUP(PTR))
  1064.                 IF (RTODFN(1,I).EQ.FNAME) THEN
  1065.                     FNAME=RTODFN(2,I)
  1066.                     CHG=.TRUE.
  1067.                 ELSE IF (NTYPE.NE.119 .AND.
  1068.      +                   NTYPE.NE.38) THEN
  1069.                     I=0
  1070.  200                I=I+1
  1071.                     IF (I.LT.NDTORF .AND. DTORFN(2,I).NE.FNAME) GOTO 200
  1072.                     IF (DTORFN(2,I).EQ.FNAME) THEN
  1073.                         FNAME=DTORFN(1,I)
  1074.                         CHG=.TRUE.
  1075.                     END IF
  1076.                 END IF
  1077.             ELSE
  1078.                 I=0
  1079.  300            I=I+1
  1080.                 IF (I.LT.NDTORF .AND. DTORFN(1,I).NE.FNAME) GOTO 300
  1081.                 IF (DTORFN(1,I).EQ.FNAME) THEN
  1082.                     FNAME=DTORFN(2,I)
  1083.                     CHG=.TRUE.
  1084.                 ELSE
  1085.                     I=0
  1086.  400                I=I+1
  1087.                     IF (I.LT.NRTODF .AND. RTODFN(2,I).NE.FNAME) GOTO 400
  1088.                     IF (RTODFN(2,I).EQ.FNAME) THEN
  1089.                         FNAME=RTODFN(1,I)
  1090.                         CHG=.TRUE.
  1091.                     END IF
  1092.                 END IF
  1093.             END IF
  1094.             IF (.NOT.CHG) THEN
  1095.                 I=0
  1096.  500            I=I+1
  1097.                 IF (I.LT.NBADF .AND. BADFNS(I).NE.FNAME) GOTO 500
  1098.                 IF (BADFNS(I).EQ.FNAME) CHG=BADFUN(PTR,FNAME,I)
  1099.             END IF
  1100.             IF (CHG) THEN
  1101.                 CALL ZFTOI(FNAME,1,6,TEXT2,.FALSE.)
  1102.                 CALL ZSTRIP(TEXT2)
  1103.                 STRPTR=ADDSTR(TEXT2)
  1104.                 SYMPTR=ZYASYM(STRPTR,PUNUM,7)
  1105.                 CALL ZYCHDN(PTR,-SYMPTR)
  1106.             END IF
  1107.         END IF
  1108.  
  1109.         END
  1110. C ----------------------------------------------------------------------
  1111. C
  1112. C       N A M C H 1   -   Change name type 1: ordinary (not intrinsic)
  1113. C
  1114.  
  1115.         LOGICAL FUNCTION NAMCH1(TEXT1,TEXT2)
  1116.         INTEGER TEXT1(*),TEXT2(*)
  1117.  
  1118.         COMMON/OPTS/ CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
  1119.         LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
  1120.         INTEGER DTFORM
  1121.  
  1122.         INTEGER DP(31),RP(31),DR(4),RR(4),RAP(38),DAP(38),AR(5),STATUS
  1123.  
  1124.         SAVE /OPTS/,DP,RP,DR,RR,RAP,DAP,AR
  1125.  
  1126.         INTEGER ZSETR,ZSETP,ZPREPL
  1127.         EXTERNAL ZSETR,ZSETP,ZPREPL
  1128.  
  1129. C DP: "%<[A-Z][0-9][0-9][A-Z][A-Z]>D$"  [Nag routine name, double]
  1130. C RP: "%<[A-Z][0-9][0-9][A-Z][A-Z]>F$"  [Nag routine name, single]
  1131. C DR: "&1D" [Change to double]
  1132. C RR: "&1F" [Change to single]
  1133. C RAP: "%<[A-Z][0-9][0-9]><[A-Z][A-Z][BG-Z]>$" [Nag aux name, single]
  1134. C DAP: "%<[A-Z][A-Z][BG-Z]><[A-Z][0-9][0-9]>$" [Nag aux name, double]
  1135. C AR: "&2&1" [Change between aux single/double, either way]
  1136.  
  1137.         DATA DP/37,60,91,65,45,90,93,91,48,
  1138.      +45,57,93,91,48,45,57,93,91,65,45,
  1139.      +90,93,91,65,45,90,93,62,68,36,129/
  1140.         DATA RP/37,60,91,65,45,90,93,91,48,
  1141.      +45,57,93,91,48,45,57,93,91,65,45,
  1142.      +90,93,91,65,45,90,93,62,70,36,129/
  1143.         DATA DR/38,49,68,129/
  1144.         DATA RR/38,49,70,129/
  1145.         DATA RAP/37,60,91,65,45,90,93,91,48,
  1146.      +45,57,93,91,48,45,57,93,62,60,91,
  1147.      +65,45,90,93,91,65,45,90,93,91,66,
  1148.      +71,45,90,93,62,36,129/
  1149.         DATA DAP/37,60,91,65,45,90,93,91,65,
  1150.      +45,90,93,91,66,71,45,90,93,62,60,
  1151.      +91,65,45,90,93,91,48,45,57,93,91,
  1152.      +48,45,57,93,62,36,129/
  1153.         DATA AR/38,50,38,49,129/
  1154.  
  1155.         NAMCH1=.FALSE.
  1156.         IF (CVTNAM) THEN
  1157.             IF (RTODBL) THEN
  1158.                 STATUS=ZSETP(RP,.TRUE.)
  1159.                 STATUS=ZSETR(DR)
  1160.             ELSE
  1161.                 STATUS=ZSETP(DP,.TRUE.)
  1162.                 STATUS=ZSETR(RR)
  1163.             END IF
  1164.             NAMCH1=ZPREPL(TEXT1,TEXT2,.FALSE.).EQ.-2
  1165.         END IF
  1166.         IF (CVTAUX .AND. .NOT.NAMCH1) THEN
  1167.             IF (RTODBL) THEN
  1168.                 STATUS=ZSETP(RAP,.TRUE.)
  1169.             ELSE
  1170.                 STATUS=ZSETP(DAP,.TRUE.)
  1171.             END IF
  1172.             STATUS=ZSETR(AR)
  1173.             NAMCH1=ZPREPL(TEXT1,TEXT2,.FALSE.).EQ.-2
  1174.         END IF
  1175.  
  1176.         END
  1177. C ----------------------------------------------------------------------
  1178. C
  1179. C       B A D F U N   -   Handle bad intrinsic functions
  1180. C                         (result = change function name?)
  1181. C
  1182.  
  1183.         LOGICAL FUNCTION BADFUN(PTR,FNAME,INDX)
  1184.         INTEGER PTR,INDX
  1185.         CHARACTER*6 FNAME
  1186.  
  1187.         COMMON/PTERRC/NERROR,NWARN,PUNUM,STMTNO
  1188.         INTEGER NERROR,NWARN,PUNUM,STMTNO
  1189.  
  1190.         COMMON/OPTS/ CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
  1191.         LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
  1192.         INTEGER DTFORM
  1193.  
  1194.         INTEGER NTYPE,TMP,SYMBOL(8),TEXT(134),
  1195.      +          REALTX(5),DBLETX(5),INTTXT(4)
  1196.         LOGICAL TEST
  1197.  
  1198.         SAVE /OPTS/,REALTX,DBLETX,INTTXT,/PTERRC/
  1199.  
  1200.         INTEGER ZYUP,ZYNTYP,ZYDOWN,ZYNEXT,EQUAL,ZIAND,ZYPREV,ADDSTR,
  1201.      +          ZYASYM,ZYCRND
  1202.         EXTERNAL ZYUP,ZYNTYP,ZYDOWN,ZYNEXT,ZYREPL,ZYCHNT,ZYDELT,ZYGTSY,
  1203.      +           ZYGTST,EQUAL,ZTOCAP,ZIAND,ZYPREV,ADDSTR,ZYASYM,ZYCRND
  1204.  
  1205.         DATA REALTX/82,69,65,76,129/,
  1206.      +       DBLETX/68,66,76,69,129/,
  1207.      +       INTTXT/73,78,84,129/
  1208.  
  1209.         NTYPE=ZYNTYP(ZYUP(PTR))
  1210.         BADFUN=.FALSE.
  1211.         GOTO (1000,2000,3000,4000,5000,6000,7000,8000,9000,10000,11000)
  1212.      +       INDX
  1213.         CALL ERROR('INTERNAL ERROR - PROGRAM ABORTED')
  1214.  
  1215. C INT
  1216.  1000   CONTINUE
  1217.         IF (NTYPE.NE.119 .AND. NTYPE.NE.38) THEN
  1218.             IF (RTODBL) THEN
  1219.                 FNAME='IDINT'
  1220.                 BADFUN=.TRUE.
  1221.             ELSE
  1222.                 CALL OUTWRN('Already single-precision (INT)')
  1223.             END IF
  1224.         END IF
  1225.         RETURN
  1226.  
  1227. C SNGL
  1228.  2000   CONTINUE
  1229.         IF (.NOT.RTODBL) THEN
  1230.             CALL OUTWRN('Already single-precision (SNGL)')
  1231.             IF (NTYPE.EQ.119)
  1232.      +          CALL OUTERR('Probably incorrect code (SNGL)')
  1233.         ELSE IF (NTYPE.EQ.119) THEN
  1234.             TMP=ZYNEXT(PTR)
  1235.             CALL ZYREPL(ZYUP(PTR),TMP)
  1236.             PTR=ZYPREV(TMP)
  1237.             IF (ZYNEXT(PTR).EQ.0) PTR=ZYUP(TMP)
  1238.             CALL OUTWRN('Non-reversible tranformation (SNGL)')
  1239.         ELSE IF (NTYPE.EQ.38) THEN
  1240.             IF (ZYNEXT(PTR).NE.0) THEN
  1241.                 PTR=ZYPREV(PTR)
  1242.                 CALL ZYREPL(ZYNEXT(PTR),ZYNEXT(ZYNEXT(PTR)))
  1243.             ELSE
  1244.                 CALL OUTINF('Probably unnecessary SNGL declaration')
  1245.             END IF
  1246.         ELSE
  1247.             CALL OUTERR('Couldn''t transform SNGL usage')
  1248.         END IF
  1249.         RETURN
  1250.  
  1251. C DBLE
  1252.  3000   CONTINUE
  1253.         IF (RTODBL) THEN
  1254.             CALL OUTWRN('Already double-precision (DBLE)')
  1255.         ELSE
  1256.             FNAME='REAL'
  1257.             BADFUN=.TRUE.
  1258.         END IF
  1259.         RETURN
  1260.  
  1261. C DPROD
  1262.  4000   CONTINUE
  1263.         IF (RTODBL) THEN
  1264.             IF (NTYPE.EQ.119) THEN
  1265.                 CALL OUTWRN('DPROD found - result may be incorrect')
  1266.                 PTR=ZYUP(PTR)
  1267.                 CALL ZYCHNT(PTR,98)
  1268.                 CALL ZYDELT(ZYDOWN(PTR))
  1269. C Now put brackets around the arguments if necessary
  1270.                 TMP=ZYDOWN(PTR)
  1271.                 NTYPE=ZYNTYP(TMP)
  1272.                 IF (NTYPE.EQ.95 .OR. NTYPE.EQ.96 .OR.
  1273.      +              NTYPE.EQ.97 .OR. NTYPE.EQ.46) THEN
  1274.                     CALL ZYDELT(TMP)
  1275.                     TMP=ZYCRND(101,TMP)
  1276.                     CALL ZYADNX(TMP,ZYDOWN(PTR))
  1277. C Reverse the reversed arguments
  1278.                     CALL ZYADNX(ZYDOWN(PTR),ZYNEXT(ZYDOWN(PTR)))
  1279.                 END IF
  1280.                 TMP=ZYNEXT(ZYDOWN(PTR))
  1281.                 NTYPE=ZYNTYP(TMP)
  1282.                 IF (NTYPE.EQ.95 .OR. NTYPE.EQ.96 .OR.
  1283.      +              NTYPE.EQ.98 .OR. NTYPE.EQ.99 .OR.
  1284.      +              NTYPE.EQ.97 .OR. NTYPE.EQ.46) THEN
  1285.                     CALL ZYDELT(TMP)
  1286.                     TMP=ZYCRND(101,TMP)
  1287.                     CALL ZYADNX(TMP,ZYDOWN(PTR))
  1288.                 END IF
  1289.             ELSE IF (NTYPE.EQ.38) THEN
  1290.                 IF (ZYNEXT(PTR).NE.0) THEN
  1291.                     PTR=ZYPREV(PTR)
  1292.                     CALL ZYDELT(ZYNEXT(PTR))
  1293.                 ELSE
  1294.                     CALL OUTINF('Probably unnecessary DPROD decl')
  1295.                 END IF
  1296.             ELSE
  1297.                 CALL OUTERR('Couldn''t transform DPROD usage')
  1298.             END IF
  1299.         ELSE
  1300.             CALL OUTERR('DP Code uses DPROD - too complicated')
  1301.         END IF
  1302.         RETURN
  1303.  
  1304. C MAX1
  1305.  5000   CONTINUE
  1306.         IF (RTODBL) THEN
  1307.             IF (NTYPE.EQ.119) THEN
  1308.                 TMP=ZYCRND(119,ZYCRND(108,-ZYASYM(
  1309.      +                  ADDSTR(INTTXT),PUNUM,7)))
  1310.                 CALL ZYREPL(ZYUP(PTR),TMP)
  1311.                 CALL ZYADNX(ZYUP(PTR),ZYDOWN(TMP))
  1312.                 FNAME='MAX'
  1313.                 BADFUN=.TRUE.
  1314.             ELSE IF (NTYPE.EQ.38) THEN
  1315.                 IF (ZYNEXT(PTR).NE.0) THEN
  1316.                     PTR=ZYPREV(PTR)
  1317.                     CALL ZYDELT(ZYNEXT(PTR))
  1318.                 ELSE
  1319.                     CALL OUTINF('Probably unneeded MAX1 declaration')
  1320.                 END IF
  1321.             ELSE
  1322.                 CALL OUTERR('Couldn''t transform MAX1 usage')
  1323.             END IF
  1324.         ELSE
  1325.             CALL OUTERR('DP code uses MAX1 - too complicated')
  1326.         END IF
  1327.         RETURN
  1328.  
  1329. C AMAX0
  1330.  6000   CONTINUE
  1331.         IF (RTODBL) THEN
  1332.             IF (NTYPE.EQ.119) THEN
  1333.                 TMP=ZYCRND(119,ZYCRND(108,-ZYASYM(
  1334.      +                  ADDSTR(DBLETX),PUNUM,7)))
  1335.                 CALL ZYREPL(ZYUP(PTR),TMP)
  1336.                 CALL ZYADNX(ZYUP(PTR),ZYDOWN(TMP))
  1337.                 FNAME='MAX'
  1338.                 BADFUN=.TRUE.
  1339.             ELSE IF (NTYPE.EQ.38) THEN
  1340.                 IF (ZYNEXT(PTR).NE.0) THEN
  1341.                     PTR=ZYPREV(PTR)
  1342.                     CALL ZYDELT(ZYNEXT(PTR))
  1343.                 ELSE
  1344.                     CALL OUTINF('Probably unneeded AMAX0 declaration')
  1345.                 END IF
  1346.             ELSE
  1347.                 CALL OUTERR('Couldn''t transform AMAX0 usage')
  1348.             END IF
  1349.         ELSE
  1350.             TMP=ZYUP(ZYUP(PTR))
  1351.             IF (NTYPE.EQ.119 .AND. ZYNTYP(TMP).EQ.119) THEN
  1352. C Must check for REAL(AMAX0 generated from DBLE(AMAX0
  1353.                 CALL ZYGTSY(-ZYDOWN(ZYDOWN(TMP)),SYMBOL)
  1354.                 CALL ZYGTST(SYMBOL(2),TEXT)
  1355.                 CALL ZTOCAP(TEXT)
  1356.                 TEST=EQUAL(TEXT,REALTX).EQ.-2
  1357.             ELSE
  1358.                 TEST=.FALSE.
  1359.             END IF
  1360.             IF (TEST) THEN
  1361.                 CALL ZYREPL(TMP,ZYUP(PTR))
  1362.             ELSE
  1363.                 CALL OUTERR('Couldn''t transform AMAX0 usage')
  1364.             END IF
  1365.         END IF
  1366.         RETURN
  1367.  
  1368. C AMIN0
  1369.  7000   CONTINUE
  1370.         IF (RTODBL) THEN
  1371.             IF (NTYPE.EQ.119) THEN
  1372.                 TMP=ZYCRND(119,ZYCRND(108,-ZYASYM(
  1373.      +                  ADDSTR(DBLETX),PUNUM,7)))
  1374.                 CALL ZYREPL(ZYUP(PTR),TMP)
  1375.                 CALL ZYADNX(ZYUP(PTR),ZYDOWN(TMP))
  1376.                 FNAME='MIN'
  1377.                 BADFUN=.TRUE.
  1378.             ELSE IF (NTYPE.EQ.38) THEN
  1379.                 IF (ZYNEXT(PTR).NE.0) THEN
  1380.                     PTR=ZYPREV(PTR)
  1381.                     CALL ZYDELT(ZYNEXT(PTR))
  1382.                 ELSE
  1383.                     CALL OUTINF('Probably unneeded AMIN0 declaration')
  1384.                 END IF
  1385.             ELSE
  1386.                 CALL OUTERR('Couldn''t transform AMIN0 usage')
  1387.             END IF
  1388.         ELSE
  1389.             TMP=ZYUP(ZYUP(PTR))
  1390.             IF (NTYPE.EQ.119 .AND. ZYNTYP(TMP).EQ.119) THEN
  1391. C Must check for REAL(AMIN0 generated from DBLE(AMIN0
  1392.                 CALL ZYGTSY(-ZYDOWN(ZYDOWN(TMP)),SYMBOL)
  1393.                 CALL ZYGTST(SYMBOL(2),TEXT)
  1394.                 CALL ZTOCAP(TEXT)
  1395.                 TEST=EQUAL(TEXT,REALTX).EQ.-2
  1396.             ELSE
  1397.                 TEST=.FALSE.
  1398.             END IF
  1399.             IF (TEST) THEN
  1400.                 CALL ZYREPL(TMP,ZYUP(PTR))
  1401.             ELSE
  1402.                 CALL OUTERR('Couldn''t transform AMIN0 usage')
  1403.             END IF
  1404.         END IF
  1405.         RETURN
  1406.  
  1407. C MIN1
  1408.  8000   CONTINUE
  1409.         IF (RTODBL) THEN
  1410.             IF (NTYPE.EQ.119) THEN
  1411.                 TMP=ZYCRND(119,ZYCRND(108,-ZYASYM(
  1412.      +                  ADDSTR(INTTXT),PUNUM,7)))
  1413.                 CALL ZYREPL(ZYUP(PTR),TMP)
  1414.                 CALL ZYADNX(ZYUP(PTR),ZYDOWN(TMP))
  1415.                 FNAME='MIN'
  1416.                 BADFUN=.TRUE.
  1417.             ELSE IF (NTYPE.EQ.38) THEN
  1418.                 IF (ZYNEXT(PTR).NE.0) THEN
  1419.                     PTR=ZYPREV(PTR)
  1420.                     CALL ZYDELT(ZYNEXT(PTR))
  1421.                 ELSE
  1422.                     CALL OUTINF('Probably unneeded MIN1 declaration')
  1423.                 END IF
  1424.             ELSE
  1425.                 CALL OUTERR('Couldn''t transform MIN1 usage')
  1426.             END IF
  1427.         ELSE
  1428.             CALL OUTERR('DP code uses MIN1 - too complicated')
  1429.         END IF
  1430.         RETURN
  1431.  
  1432. C REAL
  1433.  9000   CONTINUE
  1434.         IF (RTODBL) THEN
  1435.             FNAME='DBLE'
  1436.             BADFUN=.TRUE.
  1437.         ELSE
  1438.             CALL OUTWRN('Already single-precision (REAL)')
  1439.         END IF
  1440.         RETURN
  1441.  
  1442. C FLOAT
  1443. 10000   CONTINUE
  1444.         IF (RTODBL) THEN
  1445.             IF (NTYPE.EQ.119) THEN
  1446.                 FNAME='DBLE'
  1447.                 BADFUN=.TRUE.
  1448.             ELSE IF (NTYPE.EQ.38 .OR. NTYPE.EQ.30) THEN
  1449.                 CALL OUTINF('Probably unnecessary FLOAT declaration')
  1450.             ELSE
  1451.                 CALL OUTERR('Cannot transform FLOAT usage')
  1452.             END IF
  1453.         ELSE
  1454.             CALL OUTWRN('Already single-precision (FLOAT)')
  1455.         END IF
  1456.         RETURN
  1457.  
  1458. C IFIX
  1459. 11000   CONTINUE
  1460.         IF (RTODBL) THEN
  1461.             IF (NTYPE.EQ.119) THEN
  1462.                 FNAME='INT'
  1463.                 BADFUN=.TRUE.
  1464.             ELSE IF (NTYPE.EQ.38) THEN
  1465.                 IF (ZYNEXT(PTR).NE.0) THEN
  1466.                     PTR=ZYPREV(PTR)
  1467.                     CALL ZYDELT(ZYNEXT(PTR))
  1468.                 ELSE
  1469.                     CALL OUTINF('Unnecessary IFIX declaration')
  1470.                 END IF
  1471.             ELSE
  1472.                 FNAME='IDINT'
  1473.                 BADFUN=.TRUE.
  1474.                 CALL OUTERR('Invalid IFIX usage - changed to IDINT')
  1475.             END IF
  1476.         ELSE
  1477.             CALL OUTWRN('Already single-precision (IFIX)')
  1478.         END IF
  1479.  
  1480.         END
  1481. C ----------------------------------------------------------------------
  1482. C
  1483. C       C H C N A M   -   Change COMMON block name (NAG routines only)
  1484. C
  1485.  
  1486.         SUBROUTINE CHCNAM(NODE)
  1487.         INTEGER NODE
  1488.  
  1489.         COMMON/OPTS/CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
  1490.         LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
  1491.         INTEGER DTFORM
  1492.  
  1493. C CRP "%<[A-Z]><[A-Z][0-9][0-9]><[A-Z][A-Z]>$"
  1494. C CDP "%<[A-Z][A-Z]><[A-Z][0-9][0-9]><[A-Z]>$"
  1495. C CR "&3&2&1"
  1496.  
  1497.         INTEGER CRP(39),CDP(39),CR(7),STATUS,SYMBOL(8),
  1498.      +          TEXT1(134),TEXT2(134),STRPTR,SYMPTR
  1499.  
  1500.         INTEGER ZSETP,ZSETR,ZPREPL,ZYDOWN,ZYASYM,ADDSTR
  1501.         EXTERNAL ZSETP,ZSETR,ZPREPL,ZYDOWN,ZYASYM,ADDSTR,ZYGTSY,ZMESS,
  1502.      +           ERROR
  1503.  
  1504.         SAVE CRP,CDP,CR,/OPTS/
  1505.  
  1506.         DATA CRP/37,60,91,65,45,90,93,62,
  1507.      +60,91,65,45,90,93,91,48,45,57,93,
  1508.      +91,48,45,57,93,62,60,91,65,45,90,
  1509.      +93,91,65,45,90,93,62,36,129/,
  1510.      +       CDP/37,60,91,65,45,90,93,91,65,
  1511.      +45,90,93,62,60,91,65,45,90,93,
  1512.      +91,48,45,57,93,91,48,45,57,93,
  1513.      +62,60,91,65,45,90,93,62,36,129/,
  1514.      +       CR/38,51,38,50,38,49,129/
  1515.  
  1516.         CALL ZYGTSY(-ZYDOWN(NODE),SYMBOL)
  1517.         IF (SYMBOL(1).NE.2) THEN
  1518.             CALL ZMESS('ISTPT: Common pointers invalid',2)
  1519.             CALL ERROR('Fatal Error - Invalid Input')
  1520.         END IF
  1521.         CALL ZYGTST(SYMBOL(2),TEXT1)
  1522.         IF (RTODBL) THEN
  1523.             STATUS=ZSETP(CRP,.TRUE.)
  1524.         ELSE
  1525.             STATUS=ZSETP(CDP,.TRUE.)
  1526.         END IF
  1527.         STATUS=ZSETR(CR)
  1528.         IF (ZPREPL(TEXT1,TEXT2,.FALSE.).EQ.-2) THEN
  1529.             STRPTR=ADDSTR(TEXT2)
  1530.             SYMPTR=ZYASYM(STRPTR,SYMBOL(3),SYMBOL(1))
  1531.             CALL ZYCHDN(NODE,-SYMPTR)
  1532.         END IF
  1533.  
  1534.         END
  1535. C ----------------------------------------------------------------------
  1536. C
  1537. C       O U T E R R   -   Output an error message to the tty & the prog
  1538. C
  1539.  
  1540.         SUBROUTINE OUTERR(ERRTXT)
  1541.         CHARACTER*(*) ERRTXT
  1542.  
  1543.         COMMON/PTIO/ IODCMT,TKDESC
  1544.         INTEGER IODCMT,TKDESC
  1545.  
  1546.         COMMON/PTERRC/NERROR,NWARN,PUNUM,STMTNO
  1547.         INTEGER NERROR,NWARN,PUNUM,STMTNO
  1548.  
  1549.         COMMON/PUNAMC/PUNAME
  1550.         CHARACTER*6 PUNAME
  1551.  
  1552. C---------------------------------------------------------
  1553. C    TOOLPACK/1    Release: 2.4
  1554. C---------------------------------------------------------
  1555. C
  1556. C  TKLAST = LAST TOKEN NUMBER
  1557. C
  1558.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  1559.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  1560.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  1561.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  1562.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  1563.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  1564.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  1565.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  1566.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  1567.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  1568.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  1569.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  1570.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  1571.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  1572.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  1573.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  1574.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  1575.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  1576.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  1577.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  1578.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  1579.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  1580.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  1581.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  1582.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  1583.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  1584.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  1585.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  1586.  
  1587.  
  1588.         INTEGER ERRMSG(134)
  1589.  
  1590.         SAVE
  1591.  
  1592.         INTEGER LENGTH
  1593.         EXTERNAL ZCHOUT,ZFTOI,ZTOKWR,LENGTH,PUTCH,ZPTINT
  1594.  
  1595.         DATA (ERRMSG(I),I=1,12)/67,42,80,84,42,69,82,82,79,
  1596.      +82,42,32/
  1597.  
  1598.         CALL ZCHOUT('Error: ',2)
  1599.         CALL ZCHOUT(ERRTXT,2)
  1600.         IF (PUNAME.NE.' ') THEN
  1601.             CALL ZCHOUT(' at statement ',2)
  1602.             CALL ZPTINT(STMTNO,1,2)
  1603.             CALL ZCHOUT(' in '//PUNAME,2)
  1604.         END IF
  1605.         CALL PUTCH(10,2)
  1606.         CALL ZFTOI(ERRTXT,1,132,ERRMSG(13),.TRUE.)
  1607.         CALL ZTOKWR(TCMMNT,LENGTH(ERRMSG),ERRMSG,TKDESC)
  1608.         NERROR=NERROR+1
  1609.  
  1610.         END
  1611. C ----------------------------------------------------------------------
  1612. C
  1613. C       O U T W R N   -   Output a warning message to the tty & the prog
  1614. C
  1615.  
  1616.         SUBROUTINE OUTWRN(ERRTXT)
  1617.         CHARACTER*(*) ERRTXT
  1618.  
  1619.         COMMON/PTIO/ IODCMT,TKDESC
  1620.         INTEGER IODCMT,TKDESC
  1621.  
  1622.         COMMON/PTERRC/NERROR,NWARN,PUNUM,STMTNO
  1623.         INTEGER NERROR,NWARN,PUNUM,STMTNO
  1624.  
  1625.         COMMON/PUNAMC/PUNAME
  1626.         CHARACTER*6 PUNAME
  1627.  
  1628. C---------------------------------------------------------
  1629. C    TOOLPACK/1    Release: 2.4
  1630. C---------------------------------------------------------
  1631. C
  1632. C  TKLAST = LAST TOKEN NUMBER
  1633. C
  1634.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  1635.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  1636.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  1637.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  1638.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  1639.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  1640.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  1641.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  1642.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  1643.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  1644.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  1645.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  1646.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  1647.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  1648.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  1649.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  1650.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  1651.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  1652.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  1653.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  1654.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  1655.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  1656.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  1657.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  1658.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  1659.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  1660.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  1661.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  1662.  
  1663.  
  1664.         INTEGER ERRMSG(134)
  1665.  
  1666.         SAVE
  1667.  
  1668.         INTEGER LENGTH
  1669.         EXTERNAL ZCHOUT,ZMESS,ZFTOI,ZTOKWR,LENGTH
  1670.  
  1671.         DATA (ERRMSG(I),I=1,14)/67,42,80,84,42,87,65,82,78,
  1672.      +73,78,71,42,32/
  1673.  
  1674.         CALL ZCHOUT('Warning: ',2)
  1675.         CALL ZCHOUT(ERRTXT,2)
  1676.         IF (PUNAME.NE.' ') THEN
  1677.             CALL ZCHOUT(' at statement ',2)
  1678.             CALL ZPTINT(STMTNO,1,2)
  1679.             CALL ZCHOUT(' in '//PUNAME,2)
  1680.         END IF
  1681.         CALL PUTCH(10,2)
  1682.         CALL ZFTOI(ERRTXT,1,132,ERRMSG(15),.TRUE.)
  1683.         CALL ZTOKWR(TCMMNT,LENGTH(ERRMSG),ERRMSG,TKDESC)
  1684.         NWARN=NWARN+1
  1685.  
  1686.         END
  1687. C ----------------------------------------------------------------------
  1688. C
  1689. C       O U T I N F   -   Output an informational message
  1690. C
  1691.  
  1692.         SUBROUTINE OUTINF(ERRTXT)
  1693.         CHARACTER*(*) ERRTXT
  1694.  
  1695.         COMMON/PTERRC/NERROR,NWARN,PUNUM,STMTNO
  1696.         INTEGER NERROR,NWARN,PUNUM,STMTNO
  1697.  
  1698.         COMMON/PUNAMC/PUNAME
  1699.         CHARACTER*6 PUNAME
  1700.  
  1701.         SAVE
  1702.  
  1703.         EXTERNAL ZCHOUT,PUTCH,ZPTINT
  1704.  
  1705.         CALL ZCHOUT('Info: ',2)
  1706.         CALL ZCHOUT(ERRTXT,2)
  1707.         IF (PUNAME.NE.' ') THEN
  1708.             CALL ZCHOUT(' at statement ',2)
  1709.             CALL ZPTINT(STMTNO,1,2)
  1710.             CALL ZCHOUT(' in '//PUNAME,2)
  1711.         END IF
  1712.         CALL PUTCH(10,2)
  1713.  
  1714.         END
  1715.