Usenet 1994 October/usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso/misc/volume12/ffccc/part10

Text File | 1990-05-14 | 48KB | 1,439 lines

Newsgroups: comp.sources.misc
organization: CERN, Geneva, Switzerland
keywords: fortran
subject: v12i096: Floppy - Fortran Coding Convention Checker Part 10/11
from: [e-mail] (julian bunn)
Sender: [e-mail] (Brandon S. Allbery - comp.sources.misc)

Posting-number: Volume 12, Issue 96
Submitted-by: [e-mail] (julian bunn)
Archive-name: ffccc/part10

#!/bin/sh
echo 'Start of Floppy, part 10 of 11:'
echo 'x - BINSRC.f'
sed 's/^X//' > BINSRC.f << '/'
X      SUBROUTINE BINSRC(KELEM,KLIST,NLIST,IPOS,LAST)
X*-----------------------------------------------------------------------
X*
X*---Purpose:    finds number in sorted list (ascending)
X*               with binary search.
X*
X*---Input
X*   KELEM           number to be looked up
X*   KLIST           table
X*   NLIST           length of table
X*
X*---Output
X*   IPOS            = 0: name not in table
X*                   > 0: position in table
X*   LAST            for IPOS=0, position behind which number belongs
X*
X*---Author :    HG      date: 17.5.79     last revision: 20.6.84
X*
X*-----------------------------------------------------------------------
X      DIMENSION KLIST(*)
X      IPOS=0
X      LAST=0
X      N=NLIST
X      IF(N.GT.0)  THEN
X         KPOS=0
X   10    M=(N+1)/2
X         LAST=KPOS+M
X         IF (KELEM.LT.KLIST(LAST))  THEN
X            N=M
X            LAST=LAST-1
X            IF (N.GT.1) GOTO 10
X         ELSEIF (KELEM.GT.KLIST(LAST))  THEN
X            KPOS=LAST
X            N=N-M
X            IF (N.GT.0) GOTO 10
X         ELSE
X            IPOS=LAST
X         ENDIF
X      ENDIF
X      END
/
echo 'x - CFLAGS.h'
sed 's/^X//' > CFLAGS.h << '/'
X*IF DEF,NEVER
X*-----------------------------------------------------------------------
X* +++++++++++++++++++++++++ action flags - as listed
X*  1      make namelist/routine
X*  2      make global namelist
X*  3      print illegal statements
X*  4      print changed statements
X*  5      print filtered statements
X*  6      print all statements
X*  7      write changed statements only on output file
X*  8      write filtered on output file
X*  9      write all on output file
X* 10      take first name only in statement
X* 11      convert hollerith to quotes
X* 12      string replacement requested
X* 13      resequence statement numbers
X* 14      FORMAT to end of routine
X* 15      name replacements requested
X* 16      routine filters given
X* 17      class filters given
X* 18      name filters given
X* 19      string filters given
X* 20      type variables
X* 21      indent
X* 22      USER command given
X* 23      compressed output file requested
X* 24      COMMON block option (signal unused and used C.B.)
X* 25      print namelist / routine
X* 26      print global namelist
X* 27      print COMMON block and variable usage
X* 28      adjust GOTO to the right
X* 29      write tree output file on unit 13
X* +++++++++++++++++++++++++ status flags - as listed
X*  1      no more lines on input
X*  2      no more lines to process
X*  3      illegal stmnt. detected in EXTRAC (unclosed string, or
X*         illegal character '{', '}'  ).
X*  4      end of program due to time limit
X*  5      currently buffered routine without end (split)
X*  6      currently buffered routine continuation (split)
X*  7      current routine filtered
X*  8      last filter passed
X*  9      routine header still to be printed
X* 10      statement still to be printed
X* 11      statement cannot be changed (length overflow,or illegal repl.)
X* 12      c.b. name list overflow in PROCOM, discard current routine
X* 13      true when equiv. groups and commons have been merged (PROCOM)
X* 14      true when current routine is a SUBROUTINE
X*-----------------------------------------------------------------------
X*EI
/
echo 'x - CHRTYP.f'
sed 's/^X//' > CHRTYP.f << '/'
X      SUBROUTINE CHRTYP(ITYPE,STRING,ICC1,ICC2,HOLFLG,KPOS,ILEV)
X*-----------------------------------------------------------------------
X* returns first ch. of specified type, or 0
X* input
X* ITYPE       type
X*            1 = numeric
X*            2 = alpha
X*            3 = alpha-numeric
X*            4 = special
X*            5 = FORTRAN-name
X* string      string to be looked up
X* ICC1        first ch. in string
X* ICC2        last ch. in string
X* HOLFLG      if TRUE, hollerith included in search
X* output
X* KPOS        position of first ch. of specified type, or 0
X* ILEV        relative level, including KPOS
X*
X*-----------------------------------------------------------------------
X      LOGICAL HOLFLG
X      CHARACTER STRING*(*),STEMP*1
X      include 'CONVEX.h'
X      ILEV=0
X      KPOS=0
X      NCNT=0
X      JC=ICC1-1
X   10 JC=JC+1
X      IF (JC.GT.ICC2) GOTO 999
X      STEMP=STRING(JC:JC)
X      IF(STEMP.EQ.'{')  THEN
X*--- start of character string
X         IF (.NOT.HOLFLG) THEN
X            I=INDEX(STRING(JC:ICC2),'}')
X            IF (I.EQ.0) GOTO 999
X            JC=I+JC-1
X         ENDIF
X         GOTO 10
X      ELSEIF(STEMP.EQ.'}')  THEN
X         GOTO 10
X      ELSEIF(STEMP.EQ.'(')  THEN
X         ILEV=ILEV+1
X      ELSEIF(STEMP.EQ.')')  THEN
X         ILEV=ILEV-1
X      ENDIF
X      IF(ITYPE.EQ.1)  THEN
X         IF (NUMCH(STEMP)) KPOS=JC
X      ELSEIF(ITYPE.EQ.2)  THEN
X         IF (ALPHCH(STEMP)) KPOS=JC
X      ELSEIF(ITYPE.EQ.3)  THEN
X         IF (ANUMCH(STEMP)) KPOS=JC
X      ELSEIF(ITYPE.EQ.4)  THEN
X         IF (SPECCH(STEMP)) KPOS=JC
X      ELSEIF(ITYPE.EQ.5)  THEN
X         IF (NCNT.EQ.0)  THEN
X            IF (ALPHCH(STEMP))  THEN
X               KPOS=JC
X               NCNT=NCNT+1
X            ENDIF
X         ELSEIF (ANUMCH(STEMP))  THEN
X            KPOS=JC
X         ENDIF
X      ENDIF
X      IF (KPOS.NE.JC) GOTO 10
X  999 END
/
echo 'x - CKEYCOM.h'
sed 's/^X//' > CKEYCOM.h << '/'
X*IF DEF,NEVER
X*-----------------------------------------------------------------------
X*    NORSET = no. of OR-sets
X*    NGLSET = no. of global commands
X*    NKYNAM = no. of names in SKEYLS
X*    NKYSTR = no. of strings in SKYSTR
X*    LKYSTR = occupation of  SKYSTR
X*    NKYCHR = no. of string refs in KSTREF
X*    NORCOM = no. of commands / OR-set
X*    KORCOM = start-1 of each OR-set in KEYREF
X*    KEYREF
X*            (I,1) = ref. number (=pos.) of key
X*            (I,2) = no. of integers in KEYINT
X*            (I,3) = start-1 of integers in KEYINT
X*            (I,4) = no. of names in SKEYLS
X*            (I,5) = start-1 of names in SKEYLS
X*            (I,6) = no. of string refs in KSTREF
X*            (I,7) = start-1 of string refs in KSTREF
X*    KEYINT = integer list for sub-keys etc.
X*    KNAMRF
X*            (I,1) = ref. to string following name, or zero if none,
X*                   or < 0 if to be ignored (illegal)
X*            (I,2) = ref. to replacement string, or zero
X*    KSTREF
X*            (I,1) = ref. to string (stand alone), or < 0 if illegal
X*            (I,2) = ref. to replacement string for above, or zero
X*    KKYSTA = start of string in SKYSTR
X*    KKYEND = end of string in SKYSTR
X*
X*    SKEYLS = name list for input commands
X*    SKYSTR = contains stand-alone or name-associated strings
X*-----------------------------------------------------------------------
X*EI
/
echo 'x - COMPAC.f'
sed 's/^X//' > COMPAC.f << '/'
X      SUBROUTINE COMPAC(NUMBER)
X*-----------------------------------------------------------------------
X*
X* extracts the FORTRAN field contents from the statement image.
X*
X*--- input
X*    NUMBER          number of the statement to be extracted
X*    SIMA            COMMON/ALCAZA/ (contains one complete routine)
X*    NLTYPE,NFLINE,NLLINE,  COMMON/STATE/
X*
X*--- output
X*    SSTA            COMMON/ALCAZA/  FORTRAN fields 7-72 of SIMA
X*    NCHST           COMMON/STATE/  last non-blank in SSTA
X*                    or =0 if statement consists of comment lines only
X*    NLIMA, NLREF(1..NLIMA),   /STATE/
X*
X*
X*-----------------------------------------------------------------------
X      include 'PARAM.h'
X      include 'ALCAZA.h'
X      include 'CURSTA.h'
X      include 'STATE.h'
X      NCHST=0
X      NLIMA=0
X*--- find last non-blank (only last line)
X      JEND=LASTNB(SIMA(NLLINE(NUMBER)),8,72)
X      DO 10 JLINE=NFLINE(NUMBER),NLLINE(NUMBER)
X         IF (NLTYPE(JLINE).EQ.0) GOTO 10
X         NLIMA=NLIMA+1
X         NLREF(NLIMA)=JLINE
X         IF (JLINE.EQ.NLLINE(NUMBER))  THEN
X            JLAST=JEND
X         ELSE
X            JLAST=72
X         ENDIF
X         L=JLAST-6
X         SSTA(NCHST+1:NCHST+L)=SIMA(JLINE)(7:JLAST)
X         NCHST=NCHST+L
X   10 CONTINUE
X      END
/
echo 'x - CPARAM.h'
sed 's/^X//' > CPARAM.h << '/'
X*IF DEF,NEVER
X*-----------------------------------------------------------------------
X*--- MXNAME = dimension of IWS, COMMON/FLWORK/, and of SNAMES /ALCAZA/
X*    MXSSTM = length of string SSTM, COMMON/ALCAZA/
X*    MXSTAT = max. no. of statement definitions
X*    MCLASS = first dim. of ISTMDS( , ) = no. of control words/statement
X*    MXLENG = max. length of statement field (20*66)
X*    MXLINE = line length of input image
X*    MXSIMA = max. no. of lines in input image (one routine)
X*    MXSIMD = dim. of SIMA (excess for replacement overflows)
X*    MCUNIT = file for command input (data cards)
X*    MPUNIT = file for printed output
X*    MIUNIT = FORTRAN code input unit
X*    MTUNIT = TREE output unit
X*    MOUNIT = FORTRAN code output unit
X*    MXFLAG = no. of status and action flags
X*    MXNMCH = max. no. of characters per name
X*    MXORST = max. no. of OR-sets in control commands
X*    MDIMST = dimension of SSTA, SSTR, SKYSTR
X*    MGLOKY = no. of global command keys
X*    MLOCKY = no. of local (in each OR-set) command keys
X*    MSUBKY = no. of command sub-keys
X*    MXKINT = dim. of KEYINT  /KEYINP/
X*    MXKNAM = max. no. of names or strings on input commands (total)
X*    MXTYPE = max. no. of variable types
X*    MAXNUM = max. no. of statement numbers per routine
X*    MAXGRP = max. no. of c.b. names or equiv. groups (for ACTION(24))
X*    TIMLIM = if less time left, refrain from reading next routine
X*    VERSIO = program version
X*    KALL   = max. no. of different externals / routine (TREE)
X*    KENT   = max. no. of ENTRY statements / routine    (TREE)
X*    NOARG  = max. no. of arguments / call              (TREE)
X*-----------------------------------------------------------------------
X*EI
/
echo 'x - DEFINF.f'
sed 's/^X//' > DEFINF.f << '/'
X      SUBROUTINE DEFINF
X*-----------------------------------------------------------------------
X* Define the table of FORTRAN intrinsic functions, and label the
X* generic ones.
X*-----------------------------------------------------------------------
X      include 'USINFN.h'
X      PARAMETER (NGEN=43)
X      CHARACTER*6 CINF(LIF)
X      CHARACTER*1 CGEN(NGEN)
X      INTEGER IGEN(NGEN)
X      DATA CINF/'INT   ','IFIX  ','IDINT ','IQINT ','REAL  ','FLOAT ',
X     +'SNGL  ','DBLE  ','CMPLX ','ICHAR ','CHAR  ','AINT  ','DINT  ',
X     +'ANINT ','DNINT ','NINT  ','IDNINT','ABS   ','IABS  ','DABS  ',
X     +'CABS  ','MOD   ','AMOD  ','DMOD  ','SIGN  ','ISIGN ','DSIGN ',
X     +'DIM   ','DDIM  ','DPROD ','MAX   ','MAX0  ','AMAX1 ','DMAX1 ',
X     +'AMAX0 ','MAX1  ','MIN   ','MIN0  ','AMIN1 ','DMIN1 ','AMIN0 ',
X     +'MIN1  ','LEN   ','INDEX ','IMAG  ','AIMAG ','CONJG ','SQRT  ',
X     +'DSQRT ','CSQRT ','EXP   ','DEXP  ','CEXP  ','LOG   ','ALOG  ',
X     +'DLOG  ','CLOG  ','LOG10 ','ALOG10','DLOG10','SIN   ','DSIN  ',
X     +'CSIN  ','COS   ','DCOS  ','CCOS  ','TAN   ','DTAN  ','ASIN  ',
X     +'DASIN ','ACOS  ','DACOS ','ATAN  ','DATAN ','ATAN2 ','DATAN2',
X     +'SINH  ','DSINH ','COSH  ','DCOSH ','TANH  ','DTANH ','LGE   ',
X     +'LGT   ','LLE   ','LLT   ','QEXT  ','DCMPLX','QCMPLX','CBRT  ',
X     +'EXP2  ','EXP10 ','LOG2  ','COTAN ','ERF   ','ERFC  ','GAMMA ',
X     +'LGAMMA','IRE   ','AMT   ','NOT   ','IAND  ','IOR   ','IEOR  ',
X     +'ISHFT ','IBSET ','IBCLR ','BTEST ','REAL  '/
X      DATA IGEN /1,5,8,9,12,14,16,18,22,25,28,31,37,45,47,48,51,54,58,
X     &           61,64,67,69,71,73,75,77,79,81,87,88,89,90,91,92,93,
X     &           94,95,96,97,98,99,100/
X      DATA CGEN /'I','R','D','K','R','R','I',6*'$','R','K',14*'$','D',
X     &           'D','K',9*'$','I','$'/
X      DO 10 INF=1,LIF
X        CINFUN(INF) = CINF(INF)
X        INFUNG(INF) = 0
X   10 CONTINUE
X      DO 15 IG=1,NGEN
X        INFUNG(IGEN(IG)) = 1
X        CTYFUN(IGEN(IG)) = CGEN(IG)
X   15 CONTINUE
X      RETURN
X      END
/
echo 'x - EXTRAC.f'
sed 's/^X//' > EXTRAC.f << '/'
X      SUBROUTINE EXTRAC(NUMBER,OPTION)
X*-----------------------------------------------------------------------
X*
X* extracts the FORTRAN field contents from the statement image.
X* holl.  and character strings are included in special characters,
X* '{' and '}'. strings may be either ...H, or be
X* included in single or double quotes.
X*
X*--- input
X*    NUMBER          number of the statement to be extracted
X*    OPTION          (character) 'FULL' or 'PART' to extract
X*                    all, or just start (up to first bracket)
X*    SIMA            COMMON/ALCAZA/ (contains one complete routine)
X*    NLTYPE,ICLASS,NFLINE,NLLINE,  COMMON/STATE/
X*
X*--- output
X*    SSTA            COMMON/ALCAZA/  FORTRAN fields 7-72 of SIMA
X*    NCHST           COMMON/STATE/  last non-blank in SSTA
X*                    or =0 if statement consists of comment lines only
X*    NLIMA, NLREF(1..NLIMA),   /STATE/
X*    STATUS(3)      if illegal (containing '{', '}' )
X*
X*
X*-----------------------------------------------------------------------
X      include 'PARAM.h'
X      include 'ALCAZA.h'
X      include 'FLAGS.h'
X      include 'CURSTA.h'
X      include 'STATE.h'
X      CHARACTER OPTION*4
X      NCHST=0
X      NSTREF=0
X      IF (NUMBER.LE.0.OR.NUMBER.GT.NSTAMM) GOTO 999
X      IF (ICLASS(NUMBER,1).EQ.0) GOTO 999
X      NSTREF=NUMBER
X*--- compact statement into SSTA
X      CALL COMPAC(NUMBER)
X      IF (NCHST.EQ.0) GOTO 999
X*--- insert {} around strings, suppress multiple blanks
X      CALL MARKST(OPTION,IERR)
X      STATUS(3)=IERR.NE.0
X  999 END
/
echo 'x - FLINIT.f'
sed 's/^X//' > FLINIT.f << '/'
X      SUBROUTINE FLINIT
X*-----------------------------------------------------------------------
X*
X*--- initializes FLOP
X*
X*-----------------------------------------------------------------------
X      include 'PARAM.h'
X      include 'CURSTA.h'
X      include 'FLAGS.h'
X      include 'JOBSUM.h'
X      include 'STATE.h'
X      include 'KEYCOM.h'
X      NSTBUF=0
X      IGNAME=0
X      NGNAME=0
X      NKEEPL=0
X      DO 10 I=1,10
X   10 NSTATC(I)=0
X      DO 20 I=1,MXFLAG
X         ACTION(I)=.FALSE.
X         STATUS(I)=.FALSE.
X   20 CONTINUE
X      NDUMMY=0
X      NORSET=0
X      NGLSET=0
X      NKYINT=0
X      NKYNAM=0
X      NKYSTR=0
X      NKYCHR=0
X*--- LKYSTR must start at one to leave room for an extra '#'
X      LKYSTR=1
X      DO 30 I=1,MXORST
X         NORCOM(I)=0
X         KORCOM(I)=0
X   30 CONTINUE
X      DO 40 I=1,7
X         DO 40 J=1,MXKEYS
X            KEYREF(J,I)=0
X   40 CONTINUE
X      DO 50 I=1,2
X         DO 50 J=1,MXKNAM
X            KNAMRF(J,I)=0
X            KSTREF(J,I)=0
X   50 CONTINUE
X      DO 60 I=1,MXKINT
X         KEYINT(I)=0
X   60 CONTINUE
X      DO 70 I=1,2
X         DO 70 J=1,MXSTAT
X   70 NFDCLS(J,I)=0
X      END
/
echo 'x - GETNAM.f'
sed 's/^X//' > GETNAM.f << '/'
X      SUBROUTINE GETNAM(STRING,K1,K2,KFCH,KLCH)
X*-----------------------------------------------------------------------
X*
X*--- finds one name at a time
X*
X*--- input
X*    STRING           input string
X*    K1, K2           first and last ch. in STRING for scan
X*--- output
X*    KFCH             start of name in STRING, or 0 if none
X*    KLCH             end of name in STRING
X*
X*-----------------------------------------------------------------------
X      CHARACTER STRING*(*), STEMP*1, SLAST*1
X      LOGICAL STARTD,SKIP
X      include 'CONVEX.h'
X      SLAST=' '
X      STARTD=.FALSE.
X      SKIP=.FALSE.
X      KNB=0
X      KFCH=0
X      JC=K1-1
X   10 JC=JC+1
X      KLCH=KNB
X      IF (JC.GT.K2) GOTO 999
X      STEMP=STRING(JC:JC)
X*--- skip blanks
X      IF (STEMP.EQ.' ') GOTO 10
X      IF(STEMP.EQ.'{')  THEN
X*--- start of string - quit or skip
X         IF (STARTD) GOTO 999
X         I=INDEX(STRING(JC+1:K2),'}')
X         IF (I.EQ.0) GOTO 999
X         JC=I+JC
X         GOTO 10
X      ENDIF
X      KNB=JC
X      IF(SPECCH(STEMP))  THEN
X         IF (STARTD) GOTO 999
X*--- 'SKIP' helps to ignore .ge. etc
X         SKIP=STEMP.EQ.'.'.AND.(.NOT.SKIP.OR.SLAST.EQ.'.')
X      ELSEIF(ALPHCH(STEMP))  THEN
X         IF (.NOT.(SKIP.OR.NUMCH(SLAST)))  THEN
X*--- preceding if is to catch 1E3 etc
X            IF (.NOT.STARTD) KFCH=JC
X            STARTD=.TRUE.
X         ENDIF
X      ELSE
X*--- numeric
X         SKIP=.FALSE.
X*--- this is necessary for 1.E3 etc.
X      ENDIF
X*--- keep last character
X      SLAST=STEMP
X      GOTO 10
X  999 END
/
echo 'x - GETOPT.f'
sed 's/^X//' > GETOPT.f << '/'
X      SUBROUTINE GETOPT(SLINE,NLEN,SOPT,LOPT,IERR)
XC find if character string SLINE is a recognised operator, and if so
XC return that operator (minus any blanks) in SOPT. The operator does
XC not need to necessarily fill the whole of SLINE.
X      PARAMETER (NOPER=22,LTEMP=100)
X      CHARACTER*(*) SLINE
X      CHARACTER*(LTEMP) STEMP
X      CHARACTER*6 SOPER(NOPER),SOPT
X      INTEGER LOPER(NOPER)
XC all possible operators
X      DATA SOPER /'=     ','(     ',')     ',',     ',':     ',
X     &            '.EQV. ','.NEQV.','.OR.  ','.AND. ','.NOT. ',
X     &            '.GT.  ','.GE.  ','.LT.  ','.LE.  ','.EQ.  ',
X     &            '.NE.  ','//    ','+     ','-     ','**    ',
X     &            '/     ','*     '/
X      DATA LOPER /1,1,1,1,1,5,6,4,5,5,4,4,4,4,4,4,2,1,1,2,1,1/
X      NC = 0
XC loop over characters in the line segment and remove blanks
X      DO 10 I=1,NLEN
X        IF(SLINE(I:I).EQ.' ') GOTO 10
X        NC = NC + 1
X        STEMP(NC:NC) = SLINE(I:I)
X   10 CONTINUE
X      IF(NC.EQ.0.OR.NC.GT.LTEMP) GOTO 900
XC find the operator. Note that ** is found correctly due to its order
XC in the SOPER list. Similarly for //
X      DO 20 I=1,NOPER
X        IF(LOPER(I).GT.NC) GOTO 20
X        IF(STEMP(:LOPER(I)).NE.SOPER(I)(:LOPER(I))) GOTO 20
X        SOPT(:LOPER(I)) = SOPER(I)(:LOPER(I))
X        LOPT = LOPER(I)
X        IERR = 0
X        RETURN
X   20 CONTINUE
X  900 IERR = 1
X      RETURN
X      END
/
echo 'x - INEXTR.f'
sed 's/^X//' > INEXTR.f << '/'
X      SUBROUTINE INEXTR(SKEY,I1,I2,N)
X*-----------------------------------------------------------------------
X*  compacts all occurrences of a given key in the range indicated,
X*  removes the key-words
X*
X*   Input
X*   SKEY         = key to look for
X*   I1           = start of input command range in SIMA
X*   I2           = end         -         -
X*   Output
X*   N            = no. of characters in compacted string
X*                  or -1 if key not found.
X*   SSTA, common /ALCAZA/  contains the string
X*-----------------------------------------------------------------------
X      include 'PARAM.h'
X      include 'ALCAZA.h'
X      include 'STATE.h'
X      CHARACTER*3 SKEY
X      N=-1
X      DO 20 I=I1,I2
X         IF (SKEY.EQ.SIMA(NFLINE(I))(1:3))  THEN
X*--- key found - skip key-word, string, replace ';' by ','
X            IF (N.LT.0) N=0
X            IS=NFLINE(I)
X            IL=NLLINE(I)
X            IP=NLTYPE(IL)
X            SIMA(IL)(IP:IP)=','
X            IND=INDEX(SIMA(IS),',')
X            IF (IND.EQ.0.OR.IND.EQ.NLTYPE(IS))  THEN
X               KADD=1
X            ELSE
X               KADD=0
X            ENDIF
X            DO 10 J=IS+KADD,IL
X               IF (J.EQ.IS)  THEN
X                  IT=IND+1
X               ELSE
X                  IT=1
X               ENDIF
X               L=NLTYPE(J)+1-IT
X               IF (N+L.GT.MDIMST)  THEN
X                  WRITE (MPUNIT,10000) SKEY,MDIMST
X                  N=-1
X                  GOTO 999
X               ENDIF
X               SSTA(N+1:N+L)=SIMA(J)(IT:NLTYPE(J))
X               N=N+L
X   10       CONTINUE
X         ENDIF
X   20 CONTINUE
X10000 FORMAT(/1X,8('*=*='),' WARNING - total length of key ', A,
X     +' more than ',I5,' characters, key ignored')
X  999 END
/
echo 'x - INLINE.f'
sed 's/^X//' > INLINE.f << '/'
X      SUBROUTINE INLINE(IUNIT,STRING,EOFFLG,NTYP)
X*-----------------------------------------------------------------------
X*
X*--- reads one line from input
X*
X*--- input
X*    IUNIT       logical unit number
X*--- output
X*    STRING      line read (up to MXLINE characters)
X*    EOFFLG      TRUE when end of file
X*    NTYP        type if line : 0 comment line
X*                               1 start of statement
X*                               2 contination line
X*
X*-----------------------------------------------------------------------
X      include 'PARAM.h'
X      CHARACTER STRING*(MXLINE),STEMP*1
X      LOGICAL EOFFLG
X      include 'CONVEX.h'
X      EOFFLG=.FALSE.
X      READ (IUNIT,'(A)',END=40) STRING
X      DO 10 I=1,72
X         IF (STRING(I:I).NE.' ') GOTO 20
X   10 CONTINUE
X*--- all blank = comment
X      NTYP=0
X      GOTO 999
X   20 CONTINUE
X*--- check for comment
X      IF(I.LE.6)  THEN
X         DO 30 J=I,5
X            STEMP=STRING(J:J)
X            IF (.NOT.(STEMP.EQ.' '.OR.NUMCH(STEMP))) THEN
X               NTYP=0
X               GOTO 999
X            ENDIF
X   30    CONTINUE
X*--- not a comment line - check for continuation
X         STEMP=STRING(6:6)
X         IF (STEMP.EQ.' '.OR.STEMP.EQ.'0')  THEN
X            NTYP=1
X         ELSE
X            NTYP=2
X         ENDIF
X      ELSE
X         NTYP=1
X      ENDIF
X      GOTO 999
X   40 CONTINUE
X      EOFFLG=.TRUE.
X  999 END
/
echo 'x - KEYCOM.h'
sed 's/^X//' > KEYCOM.h << '/'
X      COMMON/KEYINP/NORSET,NGLSET,NKYINT,NKYNAM,NKYSTR,LKYSTR,NKYCHR,
X     1  NORCOM(MXORST),KORCOM(MXORST),KEYREF(MXKEYS,7),KEYINT(MXKINT),
X     2  KNAMRF(MXKNAM,2),KSTREF(MXKNAM,2),KKYSTA(MXKNAM),KKYEND(MXKNAM)
X      COMMON/SKEYNP/SKYSTR,SKEYLS(MXKNAM)
X      CHARACTER SKYSTR*(MDIMST),SKEYLS*(MXNMCH)
X*IF DEF,NEVER
X*-----------------------------------------------------------------------
X*    NORSET = no. of OR-sets
X*    NGLSET = no. of global commands
X*    NKYNAM = no. of names in SKEYLS
X*    NKYSTR = no. of strings in SKYSTR
X*    LKYSTR = occupation of  SKYSTR
X*    NKYCHR = no. of string refs in KSTREF
X*    NORCOM = no. of commands / OR-set
X*    KORCOM = start-1 of each OR-set in KEYREF
X*    KEYREF
X*            (I,1) = ref. number (=pos.) of key
X*            (I,2) = no. of integers in KEYINT
X*            (I,3) = start-1 of integers in KEYINT
X*            (I,4) = no. of names in SKEYLS
X*            (I,5) = start-1 of names in SKEYLS
X*            (I,6) = no. of string refs in KSTREF
X*            (I,7) = start-1 of string refs in KSTREF
X*    KEYINT = integer list for sub-keys etc.
X*    KNAMRF
X*            (I,1) = ref. to string following name, or zero if none,
X*                   or < 0 if to be ignored (illegal)
X*            (I,2) = ref. to replacement string, or zero
X*    KSTREF
X*            (I,1) = ref. to string (stand alone), or < 0 if illegal
X*            (I,2) = ref. to replacement string for above, or zero
X*    KKYSTA = start of string in SKYSTR
X*    KKYEND = end of string in SKYSTR
X*
X*    SKEYLS = name list for input commands
X*    SKYSTR = contains stand-alone or name-associated strings
X*-----------------------------------------------------------------------
X*EI
/
echo 'x - LMERGE.f'
sed 's/^X//' > LMERGE.f << '/'
X      SUBROUTINE LMERGE(SLIST,NACC,FLACC,IS,N1,N2)
X*-----------------------------------------------------------------------
X*
X*--- merges two successive, alphabetically sorted lists
X*    in SLIST in place, updates NACC
X*
X*--- input
X*    SLIST     list containing all names
X*    NACC      array to be re-arranged with sort
X*    FLACC     if true, NACC is actually updated
X*    IS        start-1 of first list in IS
X*    N1        length of first list
X*    N2        length of second list
X*
X*-----------------------------------------------------------------------
X      include 'PARAM.h'
X      include 'FLWORK.h'
X      CHARACTER *(MXNMCH)  SLIST(*)
X      DIMENSION NACC(*)
X      LOGICAL FLACC
X      KADD=0
X      K2=N1
X      DO 20 I=1,N1
X         II=I
X   10    IF (K2.EQ.N1+N2) GOTO 40
X         IF (SLIST(IS+I).GT.SLIST(IS+K2+1))  THEN
X            K2=K2+1
X            IWS(K2)=I+KADD
X            KADD=KADD+1
X            GOTO 10
X         ELSE
X            IWS(I)=I+KADD
X         ENDIF
X   20 CONTINUE
X      DO 30 I=K2+1,N1+N2
X   30 IWS(I)=I
X      GOTO 60
X   40 CONTINUE
X      DO 50 I=II,N1
X   50 IWS(I)=I+KADD
X   60 CONTINUE
X*
X*--- put in place
X*
X      CALL SHUFFL(SLIST,NACC,FLACC,IS,N1+N2)
X      END
/
echo 'x - NAMOVE.f'
sed 's/^X//' > NAMOVE.f << '/'
X      SUBROUTINE NAMOVE(SLIST,K1,K2,N2)
X*-----------------------------------------------------------------------
X*
X*   moves a set of names from one place in a list to another
X*
X*   Input
X*   SLIST           table
X*   K1              start-1 of target position
X*   K2              start-1 of source position
X*   N2              number of names to move
X*
X*   Output
X*   SLIST is rearranged
X*
X*-----------------------------------------------------------------------
X      include 'PARAM.h'
X      PARAMETER (MBUFF=200)
X      CHARACTER *(MXNMCH) SLIST(*),SBUFF(MBUFF)
X      N=N2
X      KADD=K1
X      K=K2
X      NMOV=ABS(K1-K2)
X   10 CONTINUE
X      NT=MIN(N,MBUFF)
X      DO 20 I=1,NT
X         SBUFF(I)=SLIST(K+I)
X   20 CONTINUE
X      IF(K2.GT.K1)  THEN
X         DO 30 I=K,K-NMOV+1,-1
X            SLIST(NT+I)=SLIST(I)
X   30    CONTINUE
X         DO 40 I=1,NT
X            SLIST(KADD+I)=SBUFF(I)
X   40    CONTINUE
X         IF(NT.LT.N) THEN
X            N=N-NT
X            K=K+NT
X            KADD=KADD+NT
X            GOTO 10
X         ENDIF
X      ELSEIF(K2.LT.K1)  THEN
X         NMOV=NMOV-NT
X         KADD=K1-NT
X         DO 50 I=K2+1,K2+NMOV
X            SLIST(I)=SLIST(NT+I)
X   50    CONTINUE
X         DO 60 I=1,NT
X            SLIST(KADD+I)=SBUFF(I)
X   60    CONTINUE
X         IF(NT.LT.N) THEN
X            N=N-NT
X            NMOV=NMOV+NT
X            GOTO 10
X         ENDIF
X      ENDIF
X      END
/
echo 'x - NAMTAB.f'
sed 's/^X//' > NAMTAB.f << '/'
X      SUBROUTINE NAMTAB(SNAME,SLIST,NLIST,IPOS)
X*-----------------------------------------------------------------------
X*
X*   enters a name in an alphabetic table, or gives position if already in.
X*
X*   input
X*   SNAME                   name to be entered
X*   SLIST                   name list
X*   NUMTAB                  reference list to be updated (integers)
X*   NLIST                   no. of names in SLIST
X*   Output
X*   IPOS                    <0: -pos of name already in table
X*                           =0: NLIST <0
X*                           >0: pos of newly entered name in table
X*
X*+++++++++++ IMPORTANT
X*   In case the name has been entered, the user must increase the list
X*   length himself.
X*-----------------------------------------------------------------------
X      CHARACTER *(*) SNAME,SLIST(*)
X      IF(NLIST.LT.0)  THEN
X         IPOS=0
X      ELSEIF(NLIST.EQ.0)  THEN
X         IPOS=1
X         SLIST(1)=SNAME
X      ELSE
X         CALL NAMSRC(SNAME,SLIST,NLIST,KPOS,LAST)
X         IF (KPOS.EQ.0)  THEN
X*--- name not yet in table
X            IPOS=LAST+1
X            DO 10 I=NLIST,IPOS,-1
X               SLIST(I+1)=SLIST(I)
X   10       CONTINUE
X            SLIST(IPOS)=SNAME
X         ELSE
X            IPOS=-KPOS
X         ENDIF
X      ENDIF
X      END
/
echo 'x - OPRSLT.f'
sed 's/^X//' > OPRSLT.f << '/'
X      SUBROUTINE OPRSLT(STYP1,SOPER,STYP2,IERR,SRSLT)
XC! Get the type of an operator result
XC
XC for a given pair of operands, with a given operator,
XC returns the type of the result, and indicates whether
XC expression was mixed mode by IERR=0 (not mixed),
XC IERR=1 (mixed).
XC
X      CHARACTER*6 SOPER
X      CHARACTER*1 STYP1,STYP2,SRSLT
XC
XC throw out SOME operators
XC
X      IF(SOPER(:1).EQ.'*'.OR.
X     &   SOPER(:1).EQ.'/'.OR.SOPER(:1).EQ.'+'.OR.
X     &   SOPER(:1).EQ.'-') GOTO 5
X        IERR = 0
X        SRSLT=STYP1
X        GOTO 999
X    5 CONTINUE
XC
X      SRSLT = ' '
X      IF(STYP1.EQ.'I') THEN
XC INTEGER 1
X        IF(STYP2.EQ.'I') SRSLT='I'
X        IF(STYP2.EQ.'R') SRSLT='R'
X        IF(STYP2.EQ.'D') SRSLT='D'
X        IF(STYP2.EQ.'K') SRSLT='K'
X      ELSE IF(STYP1.EQ.'R') THEN
XC REAL 1
X        IF(STYP2.EQ.'I') SRSLT='R'
X        IF(STYP2.EQ.'R') SRSLT='R'
X        IF(STYP2.EQ.'D') SRSLT='D'
X        IF(STYP2.EQ.'K') SRSLT='K'
X      ELSE IF(STYP1.EQ.'D') THEN
XC DOUBLE PRECISION
X        IF(STYP2.EQ.'I') SRSLT='D'
X        IF(STYP2.EQ.'R') SRSLT='D'
X        IF(STYP2.EQ.'D') SRSLT='D'
X      ELSE IF(STYP1.EQ.'K') THEN
XC COMPLEX
X        IF(STYP2.EQ.'I') SRSLT='K'
X        IF(STYP2.EQ.'R') SRSLT='K'
X        IF(STYP2.EQ.'K') SRSLT='K'
X      ENDIF
X      IF(SRSLT.EQ.' ') THEN
XC UNRECOGNISED TYPE
X        SRSLT='$'
X        IERR = 0
X        GOTO 999
X      ENDIF
XC CHECK FOR EXPONENTIATION
X      IF(SOPER(:2).EQ.'**') THEN
X        SRSLT = STYP1
X        IERR = 0
X        GOTO 999
X      ENDIF
XC CHECK FOR MIXED MODE
X      IF(STYP1.NE.STYP2) THEN
X        IERR = 1
X        GOTO 999
X      ENDIF
X      IERR = 0
X  999 CONTINUE
X      RETURN
X      END
/
echo 'x - POSCH.f'
sed 's/^X//' > POSCH.f << '/'
X      SUBROUTINE POSCH(SFIND,STRING,ICC1,ICC2,HOLFLG,MLEV,KPOS,ILEV)
X*-----------------------------------------------------------------------
X* positions on a specified character
X* input
X* SFIND     character looked for
X* STRING    string to be looked up
X* ICC1      first ch. in LSTRNG
X* ICC2      last ch.       -
X* HOLFLG    if TRUE, hollerith included
X* MLEV      max. level allowed for character (relative to ICC1...ICC2)
X* output
X* KPOS      position of ICOMP in LSTRNG, or 0
X* ILEV      relative level, including KPOS
X*-----------------------------------------------------------------------
X      LOGICAL HOLFLG
X      CHARACTER STRING*(*),SFIND*1,STEMP*1
X      ILEV=0
X      KPOS=0
X      JC=ICC1-1
X   10 JC=JC+1
X      IF (JC.GT.ICC2) GOTO 999
X      STEMP=STRING(JC:JC)
X      IF(STEMP.EQ.'(')  THEN
X         ILEV=ILEV+1
X      ELSEIF(STEMP.EQ.')')  THEN
X         ILEV=ILEV-1
X      ENDIF
X      IF(STEMP.EQ.SFIND.AND.ILEV.LE.MLEV)  THEN
X         KPOS=JC
X         GOTO 999
X      ENDIF
X      IF(STEMP.EQ.'{')  THEN
X*--- start of character string
X         IF (.NOT.HOLFLG) THEN
X            I=INDEX(STRING(JC:ICC2),'}')
X            IF (I.EQ.0) GOTO 999
X            JC=I+JC-1
X         ENDIF
X      ENDIF
X      GOTO 10
X  999 END
/
echo 'x - PROIND.f'
sed 's/^X//' > PROIND.f << '/'
X      SUBROUTINE PROIND
X*-----------------------------------------------------------------------
X*
X*   Prepares indentation by updating current DO and IF levels
X*
X*-----------------------------------------------------------------------
X      include 'PARAM.h'
X      include 'ALCAZA.h'
X      include 'CLASS.h'
X      include 'CURSTA.h'
X      include 'STATE.h'
X      DIMENSION IDO(100)
X      SAVE IDO
X*--- get external class number
X      ICLEXT=ISTMDS(6,ICURCL(1))
X      IF(ICLEXT.EQ.33)  THEN
X*--- FORMAT, do not indent
X         INDCNT=0
X         GOTO 999
X      ELSE
X         INDCNT=KNTDO+KNTIF
X      ENDIF
X      IF(ICLEXT.EQ.39)  THEN
X*--- IF...THEN
X         KNTIF=KNTIF+1
X      ELSEIF(ICLEXT.EQ.23.OR.ICLEXT.EQ.24)  THEN
X*--- ELSE or ELSEIF
X         INDCNT=INDCNT-1
X      ELSEIF(ICLEXT.EQ.27)  THEN
X*--- ENDIF
X         KNTIF=KNTIF-1
X         INDCNT=INDCNT-1
X      ELSEIF(ICLEXT.EQ.20)  THEN
X*--- DO loop
X         IF (KNTDO.LT.100)  THEN
X            KNTDO=KNTDO+1
X            CALL GETINT(SSTA,1,NCHST,KFCH,KLCH,NN)
X            IDO(KNTDO)=NN
X         ENDIF
X      ELSEIF(KNTDO.GT.0)  THEN
X*--- check for (possibly multiple) end of DO loop
X         K=NEXTIN(SIMA(NFLINE(NSTREF)),1,5)
X         KST=KNTDO
X         DO 10 I=KST,1,-1
X            IF (IDO(I).NE.K) GOTO 20
X            KNTDO=KNTDO-1
X            INDCNT=INDCNT-1
X   10    CONTINUE
X   20    CONTINUE
X      ENDIF
X      INDCNT=MAX(0,INDCNT)
X  999 END
/
echo 'x - READSB.f'
sed 's/^X//' > READSB.f << '/'
X      SUBROUTINE READSB(NCOMM,NST,ICL)
X*-----------------------------------------------------------------------
X*
X*   Purpose:    performs sub-task for READEC by accepting the start of
X*               a new FORTRAN statement.
X*
X*   Input:      NCOMM     number of comment lines preceding the new line
X*
X*   Output:     NST       no. of last FORTRAN statement
X*               ICL       class of last FORTRAN statement
X*
X*   Various variables in common are used and modified.
X*
X*   Author :    HG      date: 7.9.84      last revision: 7.9.84
X*-----------------------------------------------------------------------
X      include 'PARAM.h'
X      include 'CURSTA.h'
X      include 'STATE.h'
X      NST=0
X      IF(NSTAMM.GT.0)  THEN
X*--- close previous if FORTRAN
X         IF (NLTYPE(NFLINE(NSTAMM)).EQ.1)  THEN
X            NLLINE(NSTAMM)=NLINES-NCOMM
X            NFSTAT=NFSTAT+1
X            ICLASS(NSTAMM,1)=999
X            NST=NSTAMM
X            CALL EXTRAC(NSTAMM,'PART')
X            CALL CLASSF
X            ICL=ICURCL(1)
X         ENDIF
X      ENDIF
X      IF(NCOMM.GT.0)  THEN
X*--- make comment line blocks into one statement
X         NSTAMM=NSTAMM+1
X         NFLINE(NSTAMM)=NLINES-NCOMM+1
X         NLLINE(NSTAMM)=NLINES
X         ICLASS(NSTAMM,1)=0
X         NCOMM=0
X      ENDIF
X      END
/
echo 'x - REPSUB.f'
sed 's/^X//' > REPSUB.f << '/'
X      SUBROUTINE REPSUB(KREF1,KREF2,NSPEC,KSP1,KSP2,NCH)
X*-----------------------------------------------------------------------
X*
X*   Sub-task of inserting the replacement string (for REPNAM, REPSTR)
X*
X*--- Input
X*    KREF1         ref. to string to be replaced (cf. KKYSTA, KKYEND)
X*    KREF2         ref. to replacement string
X*    NSPEC         no. of special symbols in STR1
X*    KSP1, KSP2    start and end of special symbol matches in STR1
X*---Input/Output
X*    NCH           occupation of NCH before and after replacement
X*
X*-----------------------------------------------------------------------
X      include 'PARAM.h'
X      include 'ALCAZA.h'
X      include 'KEYCOM.h'
X      include 'FLWORK.h'
X      DIMENSION KSP1(*),KSP2(*)
X      DIMENSION ICT(10),ICT1(10),ICT2(10),IREF1(MXNAME/20,10), IREF2
X     +(MXNAME/20,10)
X      EQUIVALENCE (IREF1(1,1),IWS(1)),(IREF2(1,1),IWS(MXNAME/2+1))
X      CHARACTER STEMP*1
X      LOGICAL SKIPFL
X      include 'CONVEX.h'
X      CALL SPECCT(1,KREF1,NTOT1,ICT1,IREF1,IERR)
X      CALL SPECCT(2,KREF2,NTOT2,ICT2,IREF2,IERR)
X      SKIPFL=.FALSE.
X      DO 10 I=1,10
X         ICT(I)=0
X   10 CONTINUE
X      INSTR=0
X      DO 30 I=KKYSTA(KREF2),KKYEND(KREF2)
X         STEMP=SKYSTR(I:I)
X         IF (SKIPFL) GOTO 20
X         IF (STEMP.EQ.'''') INSTR=1-INSTR
X         IN=INDEX(SPCHAR,STEMP)
X         IF (IN.EQ.0.OR.INSTR.NE.0)  THEN
X*--- normal character
X            NCH=NCH+1
X            IF (NCH.GT.MXLENG) GOTO 999
X            SSTR(NCH:NCH)=STEMP
X         ELSE
X*--- count
X            ICT(IN)=ICT(IN)+1
X*--- get count in [...], or default
X            N=IREF2(ICT(IN),IN)
X            K=IREF1(N,IN)
X            L=KSP2(K)-KSP1(K)+1
X            IF (L.GT.0)  THEN
X               IF (NCH+L.GT.MXLENG)  THEN
X                  NCH=MXLENG+1
X                  GOTO 999
X               ENDIF
X               SSTR(NCH+1:NCH+L)=SSTA(KSP1(K):KSP2(K))
X               NCH=NCH+L
X               SKIPFL=SKYSTR(I+1:I+1).EQ.'['
X            ENDIF
X         ENDIF
X         GOTO 30
X   20    CONTINUE
X         SKIPFL=STEMP.NE.']'
X   30 CONTINUE
X  999 END
/
echo 'x - SHUFFL.f'
sed 's/^X//' > SHUFFL.f << '/'
X      SUBROUTINE SHUFFL(SLIST,NACC,FLACC,IS,NS)
X*-----------------------------------------------------------------------
X*
X*--- puts the names in a list in the order given in an array.
X*    Updates NACC.
X*
X*--- input
X*    SLIST     list containing all names
X*    NACC      array to be re-arranged with sort
X*    FLACC     if true, NACC is actually updated
X*    IS         start-1 of list in SLIST
X*    NS         # of elements
X*    IWS        array containing for element I its target place L,
X*                /FLWORK/
X* ++++++++ warning +++++++++++  IWS is destroyed +++++++++++++++
X*-----------------------------------------------------------------------
X      include 'PARAM.h'
X      include 'FLWORK.h'
X      CHARACTER *(MXNMCH) SLIST(*), SW(2)
X      DIMENSION KEEP(2),NACC(*)
X      LOGICAL STD,FLACC
X      K=1
X      I=1
X   10 STD=.TRUE.
X   20 CONTINUE
X      L=IWS(I)
X      IF(L.EQ.I)  THEN
X         IWS(I)=0
X         I=I+1
X         IF (I.LE.NS) GOTO 10
X      ELSEIF(L.GT.0)  THEN
X         IF (STD)  THEN
X            SW(K)=SLIST(IS+I)
X            IF(FLACC)  KEEP(K)=NACC(IS+I)
X            STD=.FALSE.
X         ENDIF
X         SW(3-K)=SLIST(IS+L)
X         IF(FLACC)  KEEP(3-K)=NACC(IS+L)
X         SLIST(IS+L)=SW(K)
X         IF(FLACC)  NACC(IS+L)=KEEP(K)
X         K=3-K
X         IWS(I)=0
X         I=L
X         GOTO 20
X      ELSE
X*--- look for new non-zero element to start with
X         DO 30 I=1,NS
X            IF (IWS(I).GT.0) GOTO 10
X   30    CONTINUE
X      ENDIF
X      END
/
echo 'x - SKIPLV.f'
sed 's/^X//' > SKIPLV.f << '/'
X      SUBROUTINE SKIPLV(STRING,ICC1,ICC2,HOLFLG,KPOS,ILEV)
X*-----------------------------------------------------------------------
X* scans back to right bracket corresponding to last left one
X* input
X* STRING    string to be looked up
X* ICC1      first ch. in LSTRNG
X* ICC2      last ch.       -
X* HOLFLG    if TRUE, hollerith included
X* output
X* KPOS      position of right bracket or 0
X* ILEV      relative level, including KPOS (i.e. -1, if found)
X*-----------------------------------------------------------------------
X      LOGICAL HOLFLG
X      CHARACTER STRING*(*),STEMP*1
X      ILEV=0
X      KPOS=0
X      JC=ICC1-1
X   10 JC=JC+1
X      IF (JC.GT.ICC2) GOTO 999
X      STEMP=STRING(JC:JC)
X      IF(STEMP.EQ.'{')  THEN
X*--- start of character string
X         IF (.NOT.HOLFLG) THEN
X            I=INDEX(STRING(JC:ICC2),'}')
X            IF (I.EQ.0) GOTO 999
X            JC=I+JC-1
X         ENDIF
X      ELSEIF(STEMP.EQ.'(')  THEN
X         ILEV=ILEV+1
X      ELSEIF(STEMP.EQ.')')  THEN
X         ILEV=ILEV-1
X         IF (ILEV.LT.0) GOTO 20
X      ENDIF
X      GOTO 10
X   20 CONTINUE
X      KPOS=JC
X  999 END
/
echo 'x - SUMMRY.f'
sed 's/^X//' > SUMMRY.f << '/'
X      SUBROUTINE SUMMRY
X*-----------------------------------------------------------------------
X*
X*--- Prints job summary
X*
X*-----------------------------------------------------------------------
X      include 'PARAM.h'
X      include 'ALCAZA.h'
X      include 'JOBSUM.h'
X      include 'STATE.h'
X      include 'FLAGS.h'
X      IF(ACTION(26).AND.NGNAME.GT.0)  THEN
X*--- print list of global names first
XC         WRITE (MPUNIT,10000) NGNAME
X         IF (ACTION(20))  THEN
X*--- print name list with types
XC            CALL PRNAMF(IGNAME+1,IGNAME+NGNAME)
X         ELSE
XC            WRITE (MPUNIT,10010) (SNAMES(IGNAME+J),J=1,NGNAME)
X         ENDIF
X      ENDIF
XC      CALL STSUMM
X      IF(.NOT.STATUS(2))  THEN
XC         WRITE (MPUNIT,10020)
X      ENDIF
X      IF(STATUS(4))  THEN
XC         WRITE (MPUNIT,10030)
X      ENDIF
X      WRITE (MPUNIT,10040)
X      WRITE (MPUNIT,10050) (NSTATC(J),J=1,8)
X10000 FORMAT(//' Global list of',I6,' names'/)
X10010 FORMAT(1X,10A10)
X10020 FORMAT(//1X,10('*=*='),' WARNING - EOF not reached on input')
X10030 FORMAT(//1X,10('*=*='),' WARNING - ending job at time limit')
X10040 FORMAT(//1X,10('****'),' Job Summary ',10('****'))
X10050 FORMAT(' no. of lines read                 =',I10/
X     +' no. of lines out                  =',I10/
X     +' no. of statements                 =',I10/
X     +' no. of filtered stmts.            =',I10/
X     +' no. of changed  stmts.            =',I10/
X     +' no. of stmts. unable to change    =',I10/
X     +' no. of comment lines              =',I10/
X     +' no. of lines printed              =',I10)
X10060 FORMAT(/' time (sec)              =',F10.3/
X     +' time per statement(msec)=',F10.3)
X      END
/
echo 'x - SUPMOR.f'
sed 's/^X//' > SUPMOR.f << '/'
X      SUBROUTINE SUPMOR(SLIST,NACC,FLACC,IS,NS,NOUT)
X*-----------------------------------------------------------------------
X*
X*--- suppresses multiple entries in sorted table, logically ORs NAMTYP
X*
X*--- input
X*    SLIST     list containing all names
X*    NACC      array to be re-arranged, and logically ORed
X*    FLACC     if true, NACC is actually updated
X*    IS      start-1 of table in SNAMES, /ALCAZA/
X*    NS      length of table
X*--- output
X*    NOUT    new table length
X*
X*-----------------------------------------------------------------------
X      include 'PARAM.h'
X      CHARACTER *(MXNMCH) SLIST(*)
X      DIMENSION NACC(*)
X      LOGICAL FLACC
X      NQ=NS
X      IF (NQ.LE.0)  THEN
X         NOUT=0
X      ELSE
X         NOUT=1
X         DO 10 I=2,NQ
X            IF (SLIST(IS+I).NE.SLIST(IS+NOUT))  THEN
X               NOUT=NOUT+1
X               IF (I.NE.NOUT) THEN
X                  SLIST(IS+NOUT)=SLIST(IS+I)
X                  IF(FLACC)  NACC(IS+NOUT)=NACC(IS+I)
X               ENDIF
X            ELSEIF(FLACC)  THEN
X               NACC(IS+NOUT)=IOR(NACC(IS+NOUT),NACC(IS+I))
X            ENDIF
X   10    CONTINUE
X      ENDIF
X      END
/
echo 'x - SUPMUL.f'
sed 's/^X//' > SUPMUL.f << '/'
X      SUBROUTINE SUPMUL(SLIST,NACC,FLACC,IS,NS,NOUT)
X*-----------------------------------------------------------------------
X*
X*--- suppresses multiple entries in sorted table, update NAMTYP
X*
X*--- input
X*    SLIST     list containing all names
X*    NACC      array to be re-arranged with sort
X*    FLACC     if true, NACC is actually updated
X*    IS      start-1 of table in SNAMES, /ALCAZA/
X*    NS      length of table
X*--- output
X*    NOUT    new table length
X*
X*-----------------------------------------------------------------------
X      include 'PARAM.h'
X      CHARACTER *(MXNMCH) SLIST(*)
X      DIMENSION NACC(*)
X      LOGICAL FLACC
X      NQ=NS
X      IF (NQ.LE.0)  THEN
X         NOUT=0
X      ELSE
X         NOUT=1
X         DO 10 I=2,NQ
X            IF (SLIST(IS+I).NE.SLIST(IS+NOUT))  THEN
X               NOUT=NOUT+1
X               IF (I.NE.NOUT) THEN
X                  SLIST(IS+NOUT)=SLIST(IS+I)
X                  IF(FLACC)  NACC(IS+NOUT)=NACC(IS+I)
X               ENDIF
X            ENDIF
X   10    CONTINUE
X      ENDIF
X      END
/
echo 'x - TY2TYP.f'
sed 's/^X//' > TY2TYP.f << '/'
X      SUBROUTINE TY2TYP(ISN,STYP)
XC! Reduces types of operand to smaller set
X      include 'PARAM.h'
X      include 'ALCAZA.h'
X      include 'CLASS.h'
X      include 'STATE.h'
X      include 'USINFN.h'
X      LOGICAL BTEST
XC
XC Here we attempt to evaluate the type of a FLOP statement
XC 'name' using e.g. generic intrinsic function rules etc.
XC
X      CHARACTER*(*) STYP
X      CHARACTER*1 STYPE(7)
XC I=integer R=real D=doubleprecision K=complex L=logical C=complex $=aaargh!
X      DATA STYPE /'I','R','D','K','L','C','$'/
X      STYP = STYPE(7)
X      DO 10 IR=1,NRNAME
X        IF(SNAMES(ISN+ISNAME).NE.SNAMES(IR+IRNAME)) GOTO 10
X        NTYP = NAMTYP(IR+IRNAME)
XC check for generic intrinsic function
X        IF(BTEST(NTYP,16)) THEN
XC marked as a function
X          IFOUN = 0
X          LEN = INDEX(SNAMES(IR+IRNAME),' ')-1
X          DO 20 INFUN=1,LIF
X            IF(CINFUN(INFUN)(:LEN).NE.SNAMES(IR+IRNAME)(:LEN)) GOTO 20
X            IF(INFUNG(INFUN).EQ.0) GOTO 20
XC generic function
X            IFOUN = INFUN
X   20     CONTINUE
X          IF(IFOUN.NE.0) THEN
XC? is this correct ?
X            STYP = CTYFUN(IFOUN)
X            RETURN
X          ENDIF
X        ENDIF
X        IF(BTEST(NTYP,0)) THEN
X          STYP = STYPE(1)
X          RETURN
X        ELSE IF(BTEST(NTYP,1)) THEN
X          STYP = STYPE(2)
X          RETURN
X        ELSE IF(BTEST(NTYP,3)) THEN
X          STYP = STYPE(4)
X          RETURN
X        ELSE IF(BTEST(NTYP,4)) THEN
X          STYP = STYPE(3)
X          RETURN
X        ELSE IF(BTEST(NTYP,2)) THEN
X          STYP = STYPE(5)
X          RETURN
X        ELSE IF(BTEST(NTYP,5)) THEN
X          STYP = STYPE(6)
X          RETURN
X        ENDIF
X        RETURN
X   10 CONTINUE
X      RETURN
X      END
/
echo 'x - floppy.vmscld'
sed 's/^X//' > floppy.vmscld << '/'
X DEFINE VERB FLOPPY
X        IMAGE "CERN$CERNEXE:FLOPPY.EXE"
X        PARAMETER P1,PROMPT="Input FORTRAN file", VALUE(TYPE=$FILE, REQUIRED)
X        QUALIFIER OLD, VALUE(TYPE=$FILE)
X        QUALIFIER CHECKS, VALUE(LIST,TYPE=$NUMBER),DEFAULT
X        QUALIFIER FORTRAN, VALUE(TYPE=$FILE,DEFAULT="FORTRAN.FOR")
X        QUALIFIER OUTPUT, VALUE(TYPE=$FILE), BATCH
X        QUALIFIER LOG, DEFAULT
X        QUALIFIER SPECIAL, VALUE(TYPE=NAMES,DEFAULT="STANDARD"),NONNEGATABLE
X        QUALIFIER IGNORE, VALUE(LIST), NONNEGATABLE
X        QUALIFIER FULL, NONNEGATABLE
X        QUALIFIER TREE, NONNEGATABLE
X        QUALIFIER TIDY, NONNEGATABLE
X        QUALIFIER INDENT, VALUE(TYPE=$NUMBER,DEFAULT="3"), NONNEGATABLE
X        QUALIFIER GROUPF, NONNEGATABLE
X        QUALIFIER FORMAT, VALUE(LIST,TYPE=RANGE,REQUIRED), NONNEGATABLE
X        QUALIFIER STMNTS, VALUE(LIST,TYPE=RANGE,REQUIRED), NONNEGATABLE
X        QUALIFIER GOTOS, NONNEGATABLE
X        DISALLOW  SPECIAL AND CHECKS
X        DISALLOW ((OLD OR OUTPUT OR FULL OR SPECIAL OR IGNORE) AND NEG CHECKS)
X        DISALLOW  TIDY AND NOT (FORTRAN OR INDENT OR GROUPF OR FORMAT OR STMNTS OR GOTOS)
X        DISALLOW  (FORMAT.STEP AND NOT FORMAT.START)
X        DISALLOW  (FORMAT.START AND NOT FORMAT.STEP)
X        DISALLOW  (STMNTS.STEP AND NOT STMNTS.START)
X        DISALLOW  (STMNTS.START AND NOT STMNTS.STEP)
X        DISALLOW  (FORTRAN OR INDENT OR GROUPF OR FORMAT OR STMNTS OR GOTOS) AND NOT TIDY
XDEFINE TYPE NAMES
X        KEYWORD STANDARD, DEFAULT
X        KEYWORD ALEPH
X        KEYWORD GALEPH
X        KEYWORD ONLINE
XDEFINE TYPE RANGE
X        KEYWORD START, VALUE(TYPE=$NUMBER)
X        KEYWORD STEP, VALUE(TYPE=$NUMBER)
/
echo 'Part 10 of Floppy complete.'
exit