      PROGRAM VPLX
      PARAMETER (MSIZED=1000000)
C                                      !  Size of double precision array
      PARAMETER (MAXFMT=20)
      PARAMETER (MAXSUB=500,MAXSBL=2000,MAXSNL=24)
      PARAMETER (MAXSBC=6000)
      PARAMETER (MAXALT=5)
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER U5ALT(MAXALT),U5ASTT(MAXALT)
      COMMON /A5BLCK/U5ALT,U5ASTT
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      CHARACTER*80 CARDIN
      CHARACTER*(MAXSNL) SUBNAM(MAXSUB)
      CHARACTER*12 SUBCSV(MAXSBC)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
      INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL),
     .   U5LCSW
      COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW
C
      CHARACTER*160 FNERRR,FNWARN
      COMMON /IOBLK3/FNERRR,FNWARN
C
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
      CHARACTER*256 CARDWK,CARDSV,CARDIM
      COMMON /CMBLK2/CARDWK,CARDSV,CARDIM
      COMMON /CINBLK/CARDIN,SUBNAM,SUBCSV
      LOGICAL REFRSH
      EXTERNAL REFRSH
C
      LOGICAL DONE,LTEMP
      INTEGER ITYPE(3),IFLAG(3)
      DATA ITYPE/1,0,0/
C
  102 FORMAT(30X,'VPLX  -  Version 1998.09A')
C
  200 FORMAT(' OUT OF ORDER OR INCORRECT FORMAT')
  201 FORMAT(' MISSING NAME')
  202 FORMAT(/,'***** End of CREATE specification/beginning of executio'
     .,'n')
  203 FORMAT(/,'***** End of TRANSFORM specification/beginning of execu'
     .,'tion')
  204 FORMAT(/,'***** End of REWEIGHT specification/beginning of execut'
     .,'ion')
  205 FORMAT(/,'***** End of specification/beginning of execution')
C
      LSTVPL(1:1)=' '
C
C  Initializations related to substitutions
C
      DO 1 I=81,256
      CARDIM(I:I)=' '
    1 CONTINUE
      ITYPE(1)=1
      ITYPE(2)=0
      ITYPE(3)=0
      NSUB=0
      NSUBLM=0
      NSUBCM=0
      ISUBCN=0
      ILNCNT=0
      ICHCNT=0
      ISSLVL=0
      U5LCSW=1
C
C  Initializations related to standard input and output
C
      U5=5
      U6=6
      U5END=0
      U5ECHO=1
      U5ALT(1)=U5
      DO 2 I=2,MAXALT
      U5ALT(I)=0
    2 CONTINUE
C
C  Initializations related to tracking highest use of DX
C
      LASTPD=0
      SIZED=MSIZED
C
C  Initialization of error code
C  IMERR1 - used to hold error or warning code
C  IMERR2 - indicator for position on record
C  IMERR3 - flag for verbose warning messages
C
      IMERR1=0
      IMERR2=0
      IMERR3=0
C
C  Identifier for OS, used in some cases for parsing of file names
C
      NEWFNM=0
C                  ! =1, flag to signal special rules to stop processing
 
C                  ! file names under unix with / following first "."
C     OSCODE=1
C                  ! PC DOS/WIN32 version
      OSCODE=2
C                  ! UNIX
C     OSCODE=3     ! VMS/VAX
C
C  Initialization of error and warning file information
C
      DO 3 I=1,160
      FNERRR(I:I)=' '
      FNWARN(I:I)=' '
    3 CONTINUE
C
C  Default error and warning files for PC DOS version
C
C     FNERRR(1:20)='C:\VPLX\VPLERROR.TXT'
C     FNWARN(1:20)='C:\VPLX\VPLWARNG.TXT'
C
C  Default error and warning file for VAX ISAR cluster at Census Bureau
C
C     FNERRR(1:34)='DIR_DISK2:[R_FAY.VPLX]VPLERROR.TXT'
C     FNWARN(1:34)='DIR_DISK2:[R_FAY.VPLX]VPLWARNG.TXT'
C
C  Default error and warning file for MCVX09 cluster at Census Bureau
C
C     FNERRR(1:25)='STSD_1:[VPLX]VPLERROR.TXT'
C     FNWARN(1:25)='STSD_1:[VPLX]VPLWARNG.TXT'
C
C  Default error and warning file for SUN OS dsmde1 (UNIX) at Census
C  Bureau
C
      FNERRR(1:22)='/opt/vplx/vplerror.txt'
C     FNWARN(1:22)='/opt/vplx/vplwarng.txt'
C
C
      CMPFLG=0
      WRITE(U6,102)
    5 CONTINUE
      LTEMP=REFRSH(IPOS)
   10 CONTINUE
      IF(U5END.EQ.1) THEN
        CALL VPSTOP
      END IF
      CALL RRESET
      NXPTI=1
      NXPTD=1
      CALL KYFND2(IGROUP,IKEY,IPOS)
      IF(IKEY.EQ.-1) THEN
        GO TO 10
      ELSE IF(IGROUP.EQ.0) THEN
        IF(IKEY.EQ.1) THEN
C                                           ! CREATE
          CALL SETUP1
          CALL HADAMG
          CALL SETUP2
          CALL CREAT1
          IF(U5ECHO.EQ.1)WRITE(U6,202)
          CALL CREAT2(DONE)
          IF(.NOT.DONE) THEN
            CALL CREAT3(DONE)
            IF(.NOT.DONE) THEN
              CALL CREAT4
            END IF
          END IF
        ELSE IF(IKEY.EQ.2) THEN
C                                           ! CONTENTS
          CALL CONTNT
        ELSE IF(IKEY.EQ.3) THEN
C                                           ! DISPLAY
          CALL DSETUP(DONE)
          IF(.NOT.DONE) THEN
C                                           ! for old syntax
            CALL DCREAT
          END IF
        ELSE IF(IKEY.EQ.4) THEN
C                                           ! TRANSFORM
          CALL TSET1
          IF(U5ECHO.EQ.1)WRITE(U6,203)
          CALL TCREA1
          CALL TCREA2
        ELSE IF(IKEY.EQ.5.OR.IKEY.EQ.11) THEN
C                                              ! DELETE, FREE
          CALL CRDPRN(3)
          IF(IKEY.EQ.11) THEN
            CALL FNREAD(IPOS,ITYPE,IFLAG,6,IPOSSC)
          ELSE
            CALL FNREAD(IPOS,ITYPE,IFLAG,5,IPOSSC)
          END IF
          IF(IMERR1.GT.0) THEN
            CALL FSTOP
          END IF
          IF(IFLAG(1).EQ.0) THEN
            IF(U5ECHO.GT.0)WRITE(U6,201)
          END IF
          IF(IPOSSC.GT.0) THEN
            U5LCSW=1
          END IF
          GO TO 5
        ELSE IF(IKEY.EQ.6) THEN
C                                           ! REWEIGHT
          CALL SETUP1
          IF(U5ECHO.EQ.1)WRITE(U6,204)
          CALL HADAMG
          CALL RWGHT2
        ELSE IF(IKEY.EQ.7) THEN
C                                           ! IMPORT
          CALL IMPORT
        ELSE IF(IKEY.EQ.8) THEN
C                                           ! EXPORT
          CALL EXPORT
        ELSE IF(IKEY.EQ.9) THEN
C                                           ! REPGEN, CONVERT
          CALL SETUP1
          IF(U5ECHO.EQ.1)WRITE(U6,205)
          CALL HADAMG
          CALL REPGEN
        ELSE IF(IKEY.EQ.10) THEN
C                                           ! JACKKNIFE
          CALL JACKKN
        ELSE IF(IKEY.EQ.12.OR.
C                                           ! MERGE
     .          IKEY.EQ.14) THEN
C                                           ! EXTRACT
          CALL VMERGE
        ELSE IF(IKEY.EQ.13) THEN
C                                           ! RUN
          CALL CRDPRN(3)
          U5LCSW=1
C                                           ! RUN is the only "step"
          GO TO 5
C                                           ! without specified files
        END IF
      ELSE
        WRITE(U6,200)
        CALL CRDPRN(2)
        CALL FESTOP(160330)
      END IF
      IF(U5.GE.13.AND.U5.LE.17) THEN
C
C  If have been reading from a scratch file, the following restores the
C  active input file, if any.  Note that REFRSH is used to read from the
C  scratch file until an end of file is encountered, then one additional
C  call is made to restore the previous input.
C
        IF(U5ESAV.EQ.0) THEN
          L=U5ECHO
          U5ECHO=0
   90     CONTINUE
          IF(U5END.EQ.0) THEN
            LTEMP=REFRSH(IPT)
            GO TO 90
          END IF
          LTEMP=REFRSH(IPT)
          U5ECHO=L
        ELSE
          U5END=1
        END IF
      END IF
      GO TO 10
      END
C
      BLOCK DATA KEYDEF
      PARAMETER (NKEY=200)
      CHARACTER*12 KEYWRD(NKEY)
      COMMON /KEYBLK/KEYWRD
C
C  List of keywords.
C  Note that LOGICAL FUNCTION REFRSH is now written to interpret any
C  keyword beginning with 'COMM' as 'COMMENT'
C
      DATA (KEYWRD(I),I=1,40)/
     . 'SCRATCH1    ','SCRATCH2    ','SCRATCH3    ','SCRATCH4    ',
     . 'SCRATCH5    ','CLASS       ','CATEGORICAL ','CAT         ',
     . 'SELECT      ','MISSING     ','BY          ','REPLICATION ',
     . 'REP         ','UNWEIGHTED  ','INPUT       ','FORMAT      ',
     . 'COMPUTE     ','DROP        ','KEEP        ','LABEL       ',
     . 'LEVEL       ','RENAME      ','REPLICATE   ','WEIGHT      ',
     . 'STRATUM     ','CLUSTER     ','SECOND      ','COEFFICIENT ',
     . 'FPC1        ','FPC2        ','CROSS       ','IDCHANGE    ',
     . 'COPY        ','BLOCK       ','CREATE      ','OPTION      ',
     . 'CONTENT     ','DISPLAY     ','CONTRAST    ','LIST        '/
      DATA (KEYWRD(I),I=41,80)/
     . 'COV         ','COVARIANCE  ','CORR        ','CORRELATION ',
     . 'T           ','TEST        ','TABLE       ','COMMENT     ',
     . 'TRANSFORM   ','OLD         ','MODIFY      ','CONSTANT    ',
     . 'DERIVED     ','REAL        ','COUNT       ','CROSSED     ',
     . 'REMOVE      ','USER1       ','USER2       ','USER3       ',
     . 'USER4       ','USER5       ','USER6       ','USER7       ',
     . 'USER8       ','USER9       ','USER10      ','REFORMAT    ',
     . 'ADD         ','SUBTRACT    ','MULTIPLY    ','DIVIDE      ',
     . 'POWER       ','RECIPROCAL  ','LOG         ','PAIRED      ',
     . 'RMULTIPLY   ','SAVEFULL    ','GLUE        ','RPRINT      '/
      DATA (KEYWRD(I),I=81,120)/
     . 'REPPRINT    ','REPWRITE    ','REPREAD     ','BINARYWRITE ',
     . 'BINARYREAD  ','COLLAPSE    ','STRING      ','LONGSTRING  ',
     . 'INTEGER     ','SLICELENGTH ','SLICE_LENGTH','BOOLEAN     ',
     . 'AND         ','OR          ','NOT         ','DEFAULT     ',
     . 'LINK        ','LINK_MISSING','DELETE      ','ADD_MS      ',
     . 'SUBTRACT_MS ','MULTIPLY_MS ','DIVIDE_MS   ','IF          ',
     . 'ELSE        ','ELSEIF      ','END         ','ENDIF       ',
     . 'REWEIGHT    ','OUTFORMAT   ','OUTPUT      ','MODIFYREPF  ',
     . 'RETAIN      ','IMPORT      ','EXPORT      ','READFULL    ',
     . 'REPGEN      ','HADAMARD    ','CPSCOL      ','SIPPCOL     '/
      DATA (KEYWRD(I),I=121,160)/
     . 'RGENERATE   ','MODEL       ','PINVERT     ','PSOLVE      ',
     . 'PMULTIPLYM  ','PMULTIPLYP  ','PSYMMULTM   ','PSYMMULTP   ',
     . 'PPACK       ','PUNPACK     ','PTRACE      ','PDIAG       ',
     . 'PEIGENVECTOR','PEIGENVALUE ','PSQRT       ','MINVERT     ',
     . 'MSOLVE      ','MMULTIPLY   ','MMULTIPLYM  ','MSYMMULT    ',
     . 'MSYMMULTM   ','MTRACE      ','MDIAG       ','PBMULTIPLYM ',
     . 'PBMULTIPLYP ','PBSYMMULTM  ','PBSYMMULTP  ','PBDIAG      ',
     . 'CPSCHILDCOL ','CPSNICOL    ','GRIDSEARCH  ','RAO_SHAO    ',
     . 'NEWCPSCHCOL ','NPSCHILDCOL ','OLDCPSCHCOL ','PRINT       ',
     . 'ON          ','C           ','JACKKNIFE   ','FREE        '/
      DATA (KEYWRD(I),I=161,200)/
     . 'XMEDIAN     ','SIPPC_ROWCOL','SIPPC_CLMCOL','SIPPC_RAKE  ',
     . 'VPLXAPPEND  ','VPLX_APPEND ','VPLX        ','ZZZZZZZZZZZZ',
     . 'SIPPC_NICOL ','CPS_COMP_COL','CONVERT     ','RUN         ',
     . 'ZZZZZZZZZZZZ','ZZZZZZZZZZZZ','ZZZZZZZZZZZZ','ZZZZZZZZZZZZ',
     . 'ZZZZZZZZZZZZ','ZZZZZZZZZZZZ','ZZZZZZZZZZZZ','ZZZZZZZZZZZZ',
     . 'ZZZZZZZZZZZZ','ZZZZZZZZZZZZ','ZZZZZZZZZZZZ','ZZZZZZZZZZZZ',
     . 'ZZZZZZZZZZZZ','ZZZZZZZZZZZZ','ZZZZZZZZZZZZ','ZZZZZZZZZZZZ',
     . 'ZZZZZZZZZZZZ','ZZZZZZZZZZZZ','ZZZZZZZZZZZZ','ZZZZZZZZZZZZ',
     . 'ZZZZZZZZZZZZ','EXTRACT     ','AS          ','INCORPORATE ',
     . 'MERGE       ','STEP        ','STEPOPTION  ','STEP_OPTION '/
      END
      BLOCK DATA KEYDF2
C
C  Key word groups:
C  0 - Step
C  1 - Subroutine in TRANSFORM, shared with CREATE
C  2 - Other use in TRANSFORM, shared with CREATE
C  3 - Subroutine in TRANSFORM, general
C  4 - Subroutine in TRANSFORM naming file
C  5 - Subroutine in TRANSFORM, specialized to Census Bureau applications
C  6 - Other use in TRANSFORM
C  7 - CREATE only
C  8 - Miscellaneous
C  9 - synonyms
C
      PARAMETER (NKEY0=14,NKEY1=19,NKEY2=16,NKEY3=45,NKEY4=6,NKEY5=12)
      PARAMETER (NKEY6=9,NKEY7=28,NKEY8=12,NKEY9=15)
      PARAMETER (NKEY1B=NKEY0+1,NKEY1E=NKEY0+NKEY1)
      PARAMETER (NKEY2B=NKEY1E+1,NKEY2E=NKEY1E+NKEY2)
      PARAMETER (NKEY3B=NKEY2E+1,NKEY3E=NKEY2E+NKEY3)
      PARAMETER (NKEY4B=NKEY3E+1,NKEY4E=NKEY3E+NKEY4)
      PARAMETER (NKEY5B=NKEY4E+1,NKEY5E=NKEY4E+NKEY5)
      PARAMETER (NKEY6B=NKEY5E+1,NKEY6E=NKEY5E+NKEY6)
      PARAMETER (NKEY7B=NKEY6E+1,NKEY7E=NKEY6E+NKEY7)
      PARAMETER (NKEY8B=NKEY7E+1,NKEY8E=NKEY7E+NKEY8)
      PARAMETER (NKEY9B=NKEY8E+1,NKEY9E=NKEY8E+NKEY9)
      CHARACTER*12 KYWRD2(NKEY9E)
      COMMON /KYBLK2/KYWRD2
      INTEGER KEYGR1(NKEY9),KEYGR2(NKEY9)
      COMMON /KYBLK3/KEYGR1,KEYGR2
C
C  List of keywords.
C  Note that LOGICAL FUNCTION REFRSH is now written to interpret any
C  keyword beginning with 'COMM' as 'COMMENT'
C
C  Group 0: Steps
C
      DATA (KYWRD2(I),I=1,NKEY0)/
     . 'CREATE      ','CONTENT     ','DISPLAY     ','TRANSFORM   ',
     . 'DELETE      ','REWEIGHT    ','IMPORT      ','EXPORT      ',
     . 'REPGEN      ','JACKKNIFE   ','FREE        ','MERGE       ',
     . 'RUN         ','EXTRACT     '/
C
C  Group 1: CREATE and subroutine in TRANSFORM
C
      DATA (KYWRD2(I),I=NKEY1B,NKEY1E)/
     . 'COMPUTE     ','COPY        ','ADD         ','SUBTRACT    ',
     . 'MULTIPLY    ','DIVIDE      ','POWER       ','RECIPROCAL  ',
     . 'LOG         ','PRINT       ','BOOLEAN     ','AND         ',
     . 'OR          ','NOT         ','IF          ','ELSE        ',
     . 'ELSEIF      ','END         ','ENDIF       '/
C
C  Group 2: CREATE and other use in TRANSFORM
C
      DATA (KYWRD2(I),I=NKEY2B,NKEY2E)/
     . 'CLASS       ','CATEGORICAL ','MISSING     ','REAL        ',
     . 'CROSSED     ','FORMAT      ','KEEP        ','LABEL       ',
     . 'LEVEL       ','RENAME      ','OPTION      ','CONSTANT    ',
     . 'OUTFORMAT   ','STEP        ','STEPOPTION  ','MODEL       '/
C
C  Group 3: TRANSFORM subroutines, general
C
      DATA (KYWRD2(I),I=NKEY3B,NKEY3B+39)/
     . 'USER1       ','USER2       ','USER3       ','USER4       ',
     . 'USER5       ','USER6       ','USER7       ','USER8       ',
     . 'USER9       ','USER10      ','RMULTIPLY   ','SAVEFULL    ',
     . 'GLUE        ','COLLAPSE    ','MODIFYREPF  ','PAIRED      ',
     . 'PINVERT     ','PSOLVE      ','PMULTIPLYM  ','PMULTIPLYP  ',
     . 'PSYMMULTM   ','PSYMMULTP   ','PPACK       ','PUNPACK     ',
     . 'PTRACE      ','PDIAG       ','PEIGENVECTOR','PEIGENVALUE ',
     . 'PSQRT       ','MINVERT     ','MSOLVE      ','MMULTIPLY   ',
     . 'MMULTIPLYM  ','MSYMMULT    ','MSYMMULTM   ','MTRACE      ',
     . 'MDIAG       ','PBMULTIPLYM ','PBMULTIPLYP ','PBSYMMULTM  '/
C
      DATA (KYWRD2(I),I=NKEY3B+40,NKEY3E)/
     . 'PBSYMMULTP  ','PBDIAG      ','GRIDSEARCH  ','RAO_SHAO    ',
     . 'XMEDIAN     '/
C
C  Group 4: TRANSFORM subroutines, naming files
C
C
      DATA (KYWRD2(I),I=NKEY4B,NKEY4E)/
     . 'WRITE       ','READ        ','BINARYWRITE ','BINARYREAD  ',
     . 'VPLXAPPEND  ','VPLX        '/
C
C  Group 5: TRANSFORM subroutines, specialized to Census Bureau
C           applications
C
      DATA (KYWRD2(I),I=NKEY5B,NKEY5E)/
     . 'CPSCOL      ','SIPPCOL     ','CPSCHILDCOL ','CPSNICOL    ',
     . 'NEWCPSCHCOL ','NPSCHILDCOL ','OLDCPSCHCOL ','SIPPC_ROWCOL',
     . 'SIPPC_CLMCOL','SIPPC_RAKE  ','SIPPC_NICOL ','CPS_COMP_COL'/
C
C  Group 6: Other TRANSFORM
C
      DATA (KYWRD2(I),I=NKEY6B,NKEY6E)/
     . 'OLD         ','MODIFY      ','DERIVED     ','REMOVE      ',
     . 'COUNT       ','SLICELENGTH ','STRING      ','LONGSTRING  ',
     . 'INTEGER     '/
C
C  Group 7: CREATE only
C
      DATA (KYWRD2(I),I=NKEY7B,NKEY7E)/
     .  'SELECT      ','BY          ','REPLICATION ','UNWEIGHTED  ',
     .  'INPUT       ','DROP        ','REP         ','REPLICATE   ',
     .  'WEIGHT      ','STRATUM     ','CLUSTER     ','SECOND      ',
     .  'COEFFICIENT ','FPC1        ','FPC2        ','CROSS       ',
     .  'IDCHANGE    ','BLOCK       ','LINK        ','LINK_MISSING',
     .  'ADD_MS      ','SUBTRACT_MS ','MULTIPLY_MS ','DIVIDE_MS   ',
     .  'OUTPUT      ','HADAMARD    ','RETAIN      ','RGENERATE   '/
C
C  Group 8  Miscellaneous
C
      DATA (KYWRD2(I),I=NKEY8B,NKEY8E)/
     .  'LIST        ','COVARIANCE  ','CORRELATION ','T           ',
     .  'TEST        ','AS          ','INCORPORATE ','COMMENT     ',
     .  'C           ','ON          ','ECHO        ','TEMPLATE    '/
C
C  Synonyms
C
      DATA (KYWRD2(I),I=NKEY9B,NKEY9E)/
     . 'CAT         ','COV         ','CORR        ','RPRINT      ',
     . 'REPPRINT    ','REPWRITE    ','REPREAD     ','SLICE_LENGTH',
     . 'STEP_OPTION ','REFORMAT    ','VPLX_APPEND ','CONVERT     ',
     . 'F           ','F1          ','F2          '/
 
      DATA (KEYGR1(I),I=1,NKEY9)/  2,  8,  8,  1,  1,  4,  4,  6,
     .   2,  1,  4,  0,  7,  7,   7/
 
      DATA (KEYGR2(I),I=1,NKEY9)/  2,  2,  3, 10, 10,  1,  2,  6,
     .  15,  2,  5,  9, 14, 14, 15/
C
C    . 'DEFAULT     ',
C    . 'READFULL    ',
C    . 'ON          ','C           ',/
      END
C
C  Start of B.FOR - basic utilities, error returns
C
      SUBROUTINE FESTOP(ICODE)
C
      INTEGER ICODE
C
C  End on error during execution of a step, passing an error code
C  to be stored in IMERR1.
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      IMERR1=ICODE
      CALL FSTOP
      STOP
      END
C
      SUBROUTINE FPSTOP(ICODE,IPOS)
C
      INTEGER ICODE,IPOS
C
C  End on error during parsing of a command, passing an error code,
C  and a position for the error, to be stored in IMERR1 and IMERR2,
C  respectively.
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      IMERR1=ICODE
      IMERR2=IPOS
      CALL FSTOP
      STOP
      END
C
      SUBROUTINE FSTOP
C
C  End originally called from most locations.  (As error messages are
C  incorporated, many calls will eventually be to FESTOP or FPSTOP,
C  which then call FSTOP in turn.)
C
C  Prints error codes, if set, and deletes the output file.
C
      PARAMETER (MAXFMT=20)
      LOGICAL FOPEND
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
      CHARACTER*160 FNERRR,FNWARN
      COMMON /IOBLK3/FNERRR,FNWARN
C
      CHARACTER*6 VERROR
      CHARACTER*79 ERRREC
      CHARACTER*1 ALPHA1(26)
      DATA ALPHA1/ 'A','B','C','D','E','F','G','H','I','J','K','L',
     . 'M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/
C
  100 FORMAT(/,' OUT= FILE DELETED',/)
  101 FORMAT(1X)
  102 FORMAT(/,' VPLX ERROR CODE ',A6)
  103 FORMAT('V',A1,I4)
  104 FORMAT('V',A1,'0',I3)
  105 FORMAT('V',A1,'00',I2)
  106 FORMAT('V',A1,'000',I1)
  107 FORMAT(A79)
  108 FORMAT(1X,A79)
C
C  If IMERR1 > 0, print the corresponding error code
C
      IF(IMERR1.GT.0) THEN
        I=IMERR1/10000
        J=MOD(IMERR1,10000)
        IF(J.GE.1000) THEN
          WRITE(VERROR,103)ALPHA1(I),J
        ELSE IF(J.GE.100) THEN
          WRITE(VERROR,104)ALPHA1(I),J
        ELSE IF(J.GE.10) THEN
          WRITE(VERROR,105)ALPHA1(I),J
        ELSE
          WRITE(VERROR,106)ALPHA1(I),J
        END IF
        WRITE(U6,102)VERROR
        IF(FNERRR(1:1).NE.' ') THEN
          FNWRK=FNERRR
          INQUIRE(UNIT=10,OPENED=FOPEND)
          IF(FOPEND) THEN
            CLOSE(UNIT=10)
          END IF
C
C  Check to see if error file exists
C
          CALL FINQEX(FOPEND)
          IF(FOPEND) THEN
C
C  Reset IMERR1=0 so that OPENRF will open the error file.
C
            IMERR1=0
            CALL OPENRF(10)
    3       CONTINUE
            READ(10,107,END=5)ERRREC
            IF(ERRREC(1:6).EQ.VERROR) THEN
              WRITE(U6,101)
    4         CONTINUE
              WRITE(U6,108)ERRREC
              READ(10,107,END=5)ERRREC
              IF(ERRREC(1:1).NE.'V') GO TO 4
            ELSE
              GO TO 3
            END IF
    5       CONTINUE
          END IF
        END IF
      END IF
C
C  If IMERR2 > 0, print an error message with the approximate
C  position of the error.
C
      IF(IMERR2.GT.0) THEN
        CALL CRDPRN(4)
        WRITE(U6,101)
      END IF
      INQUIRE(UNIT=11,OPENED=FOPEND)
      IF(FOPEND) THEN
        CLOSE(UNIT=11,STATUS='DELETE')
        WRITE(U6,100)
      END IF
      CALL VPSTOP
      END
C
      SUBROUTINE RCHECK(IRCODE,IRNOW,IRNEED)
C
      INTEGER IRCODE,IRNOW,IRNEED
C
C  IRCODE - resource code, with possible values given below
C  IRNOW  - current value in use
C  IRNEED - request
C
C  If resources are available, the routine simply returns without
C  changing any values.  If the resource is exceeded, a fatal error
C  message is issued.
C
      INTEGER SIZED,RCEIL(13)
C
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*20 RSOURC (13)
      DATA RSOURC  / 'GENRL INTEGER MATRIX',
     .               'INPUT/NEW VARIABLES ','VARIANCE IDS/BY VARS',
     .               'RECODED VARIABLES   ','RANGES              ',
     .               'SETS OF RANGES      ','LEVELS OF CAT/CLASS ',
     .               'CLASS BLOCKS        ','CLASS POINTER ARRAYS',
     .               'DIMENSN OF CROSSED V','CHARACTER STRINGS   ',
     .               'TRANSFORMATIONS     ','TEMPORARY NAMES     '/
C
  200 FORMAT(1X,I7,' EXCEEDS AVAILABLE RESOURCES FOR ',A20)
C
      IF(IRNOW+IRNEED-1.LE.RCEIL(IRCODE))RETURN
      IRNOW=IRNOW+IRNEED-1
      WRITE(U6,200)IRNOW,RSOURC(IRCODE)
      IMERR1=160200+IRCODE
      CALL FSTOP
      END
C
      SUBROUTINE RINCR(IRCODE,IRNOW,IRNEED)
C
      INTEGER IRCODE,IRNOW,IRNEED
C
C  IRCODE - resource code, with possible values given in the comments
C           to RCHECK, above
C  IRNOW  - current value in use
C  IRNEED - request
C
C  This routine calls RCHECK to see if the resource is available.
C  If so, the subroutine changes IRNOW
C
      CALL RCHECK(IRCODE,IRNOW,IRNEED)
      IRNOW=IRNOW+IRNEED
      RETURN
      END
C
      SUBROUTINE ROOMD(SPACE)
C
C ARGUMENT DECLARATION
C
      INTEGER SPACE
C
C COMMON BLOCK DECLARATIONS
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
  101 FORMAT(/,' DOUBLE PRECISION STORAGE MATRIX OF SIZE',I8,' INSUFFICI
     .ENT, AT LEAST',I8,' NEEDED')
      NXPTD=NXPTD+SPACE
      IF(NXPTD.GT.LASTPD)LASTPD=NXPTD-1
      IF(LASTPD.GT.SIZED) THEN
        WRITE(U6,101)SIZED,LASTPD
        CALL FESTOP(160200)
      END IF
      RETURN
      END
C
      SUBROUTINE ROOMI(SPACE)
C
C ARGUMENT DECLARATION
C
      INTEGER SPACE
C
C COMMON BLOCK DECLARATIONS
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      CALL RINCR(1,NXPTI,SPACE)
      RETURN
      END
C
      SUBROUTINE RRESET
C
C  This subroutine resets all resources to their initial values.
C
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MAXFMT=20)
      PARAMETER (MTRANS=1500)
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      RCEIL(2)=MVAR
      RCEIL(3)=MAXIDS
      RCEIL(4)=MRECOD
      RCEIL(5)=MRANGE
      RCEIL(6)=MRNSET
      RCEIL(7)=MLEVEL
      RCEIL(8)=MCLBLK
      RCEIL(9)=MCLBAR
      RCEIL(10)=MCRSSD
      RCEIL(11)=MAXFMT
      RCEIL(12)=MTRANS
      RCEIL(13)=MVAR
      RETURN
      END
C
      SUBROUTINE VPSTOP
C
C  Normal end, called directly only from main program and by
C  VSTOP after displaying errors.
C
      LOGICAL FOPEND
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
  100 FORMAT('1Use of double precision matrix:',I8,' out of',I8)
C
C  Close scratch files.
C
      DO 10 IUNIT=13,19
      INQUIRE(UNIT=IUNIT,OPENED=FOPEND)
      IF(FOPEND)CLOSE(UNIT=IUNIT,STATUS='DELETE')
   10 CONTINUE
C
C  Printing of use of double precision matrix.
C
      IF(U5ECHO.EQ.1)WRITE(U6,100)LASTPD,SIZED
      STOP
      END
C
C  End of B.FOR
C
C
C  Start of I.FOR - general routines to handle I/O operations
C
      SUBROUTINE FCLALL
C
C  Subroutine to close all open files except standard output, input
C  and alternative input files.
C
      PARAMETER (MAXALT=5)
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER U5ALT(MAXALT),U5ASTT(MAXALT)
      COMMON /A5BLCK/U5ALT,U5ASTT
      LOGICAL FOPEND
C
      DO 15 IUNIT=8,39
      IF(IUNIT.EQ.U5.OR.IUNIT.EQ.U6)GO TO 15
      DO 12 I=1,MAXALT
      IF(IUNIT.GE.13.AND.IUNIT.LE.19)GO TO 15
C
C  U5ALT contains the list of alternative files.  REFRSH resets
C  the corresponding entry to 0 on end of file, so this list is
C  always current.
C
      IF(IUNIT.EQ.U5ALT(I))GO TO 15
   12 CONTINUE
      INQUIRE(UNIT=IUNIT,OPENED=FOPEND)
      IF(FOPEND) THEN
        CLOSE(UNIT=IUNIT)
      END IF
   15 CONTINUE
      RETURN
      END
C
      SUBROUTINE FNFIND(ISTART)
C
      INTEGER ISTART
C
C  ISTART - position in CARD to begin search for a file name.
C
C  This routine looks for a file name of up to 80 characters.
C  It does not attempt to find optional parameters enclosed in
C  parentheses.
C
      PARAMETER (MAXFMT=20)
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
      LOGICAL APOSTR
C
      IPOS=ISTART
      IDOT=0
      CALL NBFIND(CARD(IPOS:256),IPOS,256,IPT)
      IF(IPT.EQ.0) THEN
        CALL FPSTOP(160300,IPOS)
      END IF
      L=0
      APOSTR=.FALSE.
   20 CONTINUE
      IF(CARD(IPT:IPT).EQ.'''') THEN
        IF(L.EQ.0) THEN
C
C  If encounter initial apostrophe, note
C
          APOSTR=.TRUE.
        ELSE IF(APOSTR) THEN
C
C  If encounter apostrophe, after an initial apostrophe, assume end of
C  name.
C
          IPT=IPT+1
          GO TO 25
        ELSE
          CALL FPSTOP(160301,IPT)
        END IF
C
C  Conditions under which file name ends
C  9/21/98 now add condition on '/' as deliminator when NEWFNM=1
C  Considered delimitor under WIN32 and VMS; delimitor under UNIX after
C  first '.' in file name
C
      ELSE IF(.NOT.APOSTR.AND.
     .       (CARD(IPT:IPT).EQ.' '.OR.CARD(IPT:IPT).EQ.','.OR.
     .        CARD(IPT:IPT).EQ.')'.OR.CARD(IPT:IPT).EQ.';'.OR.
     .        (CARD(IPT:IPT).EQ.'/'.AND.NEWFNM.EQ.1.AND.
     .           (OSCODE.NE.2.OR.IDOT.GT.0)))) THEN
C
C  Except when a file name was set within an initial apostrophe,
C  blank, comma, semicolon, and ")" all indicate the end of the name.
C
        GO TO 25
      ELSE
        L=L+1
        IF(L.GT.80) THEN
          CALL FPSTOP(160302,IPT)
        END IF
        FNWRK(L:L)=CARD(IPT:IPT)
        IF(CARD(IPT:IPT).EQ.'.') THEN
C                                       ! Record occurence of '.' in
          IDOT=IPT
C                                       ! file name
        END IF
C
C  Insure that name of file does not start with blank, even if
C  within apostrophes.
C
        IF(L.EQ.1.AND.CARD(IPT:IPT).EQ.' ')L=0
      END IF
      IPT=IPT+1
      IF(IPT.LE.256)GO TO 20
   25 CONTINUE
      IF(L.LT.80) THEN
        DO 30 I=L+1,80
        FNWRK(I:I)=' '
   30   CONTINUE
      END IF
      ISTART=IPT
      RETURN
      END
C
      SUBROUTINE FNLGTH(LEN)
C
      INTEGER LEN
C
C  LEN - returned by subroutine as the last nonblank character
C  in FNWRK(1:80).
C
      PARAMETER (MAXFMT=20)
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
      DO 1 L=80,1,-1
      IF(FNWRK(L:L).NE.' ')GO TO 2
    1 CONTINUE
      L=0
    2 CONTINUE
      LEN=L
      RETURN
      END
C
      SUBROUTINE FNREAD(BASE,ITYPE,IFLAG,IACTN,IPOSSC)
C
      INTEGER BASE,ITYPE(3),IFLAG(3),IACTN
C
C  BASE  - starting position to scan, reset to 1 if FNREAD reads
C          a new card with REFRSH
C  ITYPE  - array with flags indicating possible types of files
C          to expect.  These are passed to FNRD2.
C          ITYPE(1) = 0, when IACTN=1, is reset to 1 for character
C                        input, 2 unformatted input, based on FORTRAN
C                        INQUIRE
C          ITYPE(1) = 1 expect character input
C          ITYPE(2) = 2 expect unformatted input
C          ITYPE(2) = 1 expect character output
C          ITYPE(2) = 2 expect unformatted output
C          ITYPE(3) = 1 expect formatted output (IACTN=7)
C          ITYPE(3) = 2 expect unformatted VPLXIN= input
C          ITYPE(3) =-2, optional unformatted file, but do not default
C                       to last VPLX file in LSTVPL
C          Other values for ITYPE(1, 2, or 3) upon return
C                     2 file is identified as unformatted integer
C                     3 file is identified as unformatted real
C                     4 file is identified as unformatted double
C                       precision
C
C  IFLAG  - initialized to 0, then, for IACTN =1
C          IFLAG(1) = 1 opened input (unit 12)
C          IFLAG(2) = 1 opened output (unit 11)
C          IFLAG(3) = 1 opened input (unit 10) for VPLXIN=10 in
C                       REWEIGHT step (IACNT=1) or output from
C                       CREATE step (IACNT=7)
C
C          For IACTN=2, the appropriate IFLAG will be set to the
C              assigned unit number.
C  IACTN  = 1  primary file specification for step, units 11, 12, 10
C              are eligible for opening
C         = 2  input or output from a subroutine in TRANSFORM, etc.
C              Open and return the unit number in IFLAG.
C         = 3  scratch file - do not open
C         = 4  other file - do not open.
C         = 5  delete
C         = 6  free
C         = 7  primary file specification for CREATE step, units 11,
C              12, 10 are eligible for opening
C
C  IPOSSC -  position of semicolon ending statement
C         = 0 no semicolon encountered.
C
C  Reads filename statements in form IN=fn OUT=fn and opens files,
C  by calling FNRD2 and reading additional lines with REFRSH
C
C  This subroutine repeatedly calls FNRD2 without checking IFPSW.
C  The process ends when REFRSH is false, i.e., either an end-of-file
C  or record with a keyword has been read.
C
C  IMERR1 is set to a value in FNRD2 if a fatal error occurs and if
C  the input file is a scratch file.
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/ CARD
      LOGICAL REFRSH
      EXTERNAL REFRSH
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      IF(BASE.LE.0)BASE=257
      CALL FNRD2(BASE,ITYPE,IFLAG,IACTN,1,IFPSW,IFNAME,IPOSSC)
      IF(IMERR1.GT.0) THEN
        RETURN
      END IF
    1 CONTINUE
      IF(IPOSSC.EQ.0) THEN
        IF(REFRSH(BASE)) THEN
          CALL FNRD2(BASE,ITYPE,IFLAG,IACTN,2,IFPSW,IFNAME,IPOSSC)
          IF(IMERR1.GT.0) THEN
            RETURN
          END IF
          GO TO 1
        ELSE
          CALL FNRD2(BASE,ITYPE,IFLAG,IACTN,3,IFPSW,IFNAME,IPOSSC)
          IF(IMERR1.GT.0) THEN
            RETURN
          END IF
        END IF
      END IF
      RETURN
      END
C
      SUBROUTINE FNRD2(BASE,ITYPE,IFLAG,IACTN,ICSTAT,IFPSW,IFNAME,
     . IPOSSC)
C
      INTEGER BASE,ITYPE(3),IFLAG(3),IACTN,ICSTAT,IFPSW,IFNAME,IPOSSC
C
C  BASE   - starting position to scan.  Not changed by this subroutine.
C  ITYPE  - array with flags indicating possible types of files
C          to expect.
C          ITYPE(1) = 0, when IACTN=1, is reset to 1 for character
C                        input, 2 unformatted input, based on FORTRAN
C                        INQUIRE
C          ITYPE(1) = 1 expect character input
C          ITYPE(2) = 2 expect unformatted input
C          ITYPE(2) = 1 expect character output
C          ITYPE(2) = 2 expect unformatted output
C          ITYPE(3) = 2 expect unformatted VPLXIN= input
C          ITYPE(3) =-2, optional unformatted file, but do not default
C                       to last VPLX file in LSTVPL
C          Other values for ITYPE (1, 2, or 3) upon return:
C                     3 file is identified as unformatted integer
C                     4 file is identified as unformatted real
C                     5 file is identified as unformatted double
C                       precision
C
C  IFLAG  - initialized to 0, then, for IACTN =1
C          IFLAG(1) = 1 opened input (unit 12)
C          IFLAG(2) = 1 opened output (unit 11)
C          IFLAG(3) = 1 opened input (unit 10) for VPLXIN=10 in
C                       REWEIGHT step (IACNT=1) or output from
C                       CREATE step (IACNT=7)
C          Other values for ITYPE (1, 2, or 3)
C                     3 file is identified as unformatted integer
C                     4 file is identified as unformatted real
C                     5 file is identified as unformatted double precision
C
C          For IACTN=2, the appropriate IFLAG will be set to the
C              assigned unit number.
C  IACTN  = 1  primary file specification for step, units 11, 12, 10
C              are eligible for opening
C         = 2  input or output from a subroutine in TRANSFORM, etc.
C              Open and return the unit number in IFLAG.
C         = 3  scratch file - do not open
C         = 4  other file - do not open - e.g. ERRORFILE.
C         = 5  delete
C         = 6  free
C         = 7  primary file specification for CREATE step, units 11,
C              12, 10 are eligible for opening
C
C  ICSTAT - call status -
C         = 1 first call
C         = 2 subsequent call with new information in CARD
C         = 3 close-out call.  Do not examine CARD but conclude
C             processing of a files in progress, if any.
C  IFPSW  -  file name/parameter switch - set by FNRD2
C         = 1 expect a file name
C         = 2 while reading parameters.
C
C  IFNAME -  set to 1 when a file name has been read, 0 otherwise
C
C  IPOSSC - position of ending semicolon in CARD
C         = 0 no ending semicolon encountered.
C
C  Reads filename statements in form IN=fn OUT=fn and opens files.
C
C  This routine is called by FNREAD and directly by REFRSH.  It
C  examines only the current contents of CARD but does not
C  initiate reading of additional records, which is managed by
C  FNREAD or by REFRSH.
C
      PARAMETER (MAXFMT=20)
      PARAMETER (NPRMKY=10)
      PARAMETER (MAXKWL=24)
      CHARACTER*(MAXKWL) KEYWRD
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      CHARACTER*160 FNAM11,FNAM12
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
      CHARACTER*256 CARD
      COMMON /CRDBLK/ CARD
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
      LOGICAL FEXIST,DONE,REFRSH
      EXTERNAL REFRSH
C
C  The following SAVE statement requests that internal variables
C  retain their assigned values over repeated calls of FNRD2
C
      SAVE IEQST,DONE,IFLAGE,FNAM11,FNAM12,IDONE,IFPARM,IFV
C
      CHARACTER*8 PRMKEY(NPRMKY)
      DATA PRMKEY/'UNIT    ','VOL     ','VOLSER  ','RECL    ',
     .            'LRECL   ','TRK     ','MAXREC  ','SECOND  ',
     .            'BLKSIZE ','STATUS  '/
C
  211 FORMAT(5X,'NOT OPEN')
  212 FORMAT(5X,'DOES NOT EXIST')
C
C  Initializations
C
      IF(ICSTAT.EQ.1) THEN
C                                ! For first call to subroutine
        IFLAG(1)=0
        IFLAG(2)=0
        IFLAG(3)=0
        DONE=.FALSE.
        IFV=1
C
C  Set IEQST=1 to indicate initial call to EQSCN2
C
        IEQST=1
C
C  Set IFPSW to initially expect a file name.  IFPSW=2 while
C  reading parameters.
C
        IFPSW=1
C
C  Set IFNAME=0 to indicate that a filename has not yet been read.
C  Set IFPARM=0 to indicate that file parameters have not been read.
C
        IFNAME=0
        IFPARM=0
C
C  Normally, both IDONE and IFLAGE are set on the initial call to
C  EQSCN2.  Set them to their initial values so that this information
C  will be available if ICSTAT=3
C
        IDONE=0
        IFLAGE=0
      END IF
      IPT=BASE
   10 CONTINUE
C
C  Except for ICSTAT=3, scan CARD for new information.
C
      IF(ICSTAT.NE.3) THEN
C
C  Return if BASE does not indicate a starting point
C
        IPOSSC=0
        IF(BASE.LE.0.OR.BASE.GT.256.OR.U5END.EQ.1)GO TO 90
        CALL NBFIND(CARD(IPT:256),IPT,256,IPOS)
        IF(IPOS.EQ.0)GO TO 90
        IPT=IPOS
C
C  For each new file, clear out record for file name and storage of
C  optional file parameters.
C
        IF(IEQST.EQ.1.AND.IFPSW.EQ.1.AND.IFNAME.EQ.0.AND.
     .     IFPARM.EQ.0) THEN
          DO 12 I=1,160
          FNWRK(I:I)=' '
   12     CONTINUE
        END IF
        IF(CARD(IPT:IPT).EQ.'(') THEN
C
C  If at beginning of parameters, set switches and return to 10
C  to begin to read.
C
          IF(IFPSW.EQ.1) THEN
            IFPSW=2
            IFPARM=1
            IPT=IPT+1
            GO TO 10
          ELSE
C
C  Error return
C
            IF(U5.GE.13.AND.U5.LE.17) THEN
              IMERR1=160303
              IMERR2=IPT
              RETURN
            ELSE
              CALL FPSTOP(160303,IPT)
            END IF
          END IF
        ELSE IF(CARD(IPT:IPT).EQ.')') THEN
          IF(IFPSW.EQ.1) THEN
C
C  Error return
C
            IF(U5.GE.13.AND.U5.LE.17) THEN
              IMERR1=160304
              IMERR2=IPT
              RETURN
            ELSE
              CALL FPSTOP(160304,IPT)
            END IF
          ELSE
            IFPSW=1
            IPOS=IPT+1
            CALL NBFND2(IPOS,IPT)
            IF(CARD(IPT:IPT).EQ.';') THEN
              IPOSSC=IPT
              IFPSW=1
            END IF
C
C  Go to 25 to open file.
C
            GO TO 25
          END IF
        ELSE IF(CARD(IPT:IPT).EQ.';'.AND.IFPSW.NE.2) THEN
          IPOSSC=IPT
          IFPSW=1
          GO TO 25
        ELSE IF(CARD(IPT:IPT).EQ.',') THEN
C
C  Skip over commas.
C
          IPT=IPT+1
          GO TO 10
        ELSE IF(IFPSW.EQ.1.AND.IFNAME.EQ.1) THEN
C
C  If filename has been read, go to 25 to open.
C
          GO TO 25
        END IF
C
C  Call EQSCN2 to look for  IN = fname or OUT = fname
C
        CALL EQSCN2(IPT,IPOS,KEYWRD,IFLAGE,IEQST,IDONE)
        IPT=IPOS
        IF(IDONE.EQ.0) THEN
C
C  IDONE=0 indicates EQSCN2 not finished with keyword = syntax
C  RETURN in order to read another record.
C
          IEQST=0
          GO TO 90
        END IF
      END IF
C
C  We arrive here in one of 2 ways:
C     1) EQSCN2 has identified one or more parts of in = fname, etc.
C     2) ICSTAT=3
C
C  If EQSCAN picked up a file name of MAXKWL or fewer characters
C  in KEYWRD, copy it into FNWRK.
C
      IF(IFLAGE.EQ.2..AND.IFPSW.EQ.1.AND.IFNAME.EQ.0) THEN
        IF(IFLAG(1).EQ.0.OR.IACTN.NE.1) THEN
          FNWRK(1:MAXKWL)=KEYWRD
          IFNAME=1
C
C  If IN =, OUT =, VPLXIN = not given, determine whether input or output
C
          IF(IACTN.NE.2.OR.ITYPE(1).GT.0) THEN
            IT=1
          ELSE
            IT=2
          END IF
C
C  Transfer to 10 to look for parameters.
C
          IF(ICSTAT.EQ.3) THEN
            GO TO 25
          ELSE
            GO TO 10
          END IF
        ELSE
          IF(U5.GE.13.AND.U5.LE.17) THEN
            IMERR1=160305
            RETURN
          ELSE
            CALL FESTOP(160305)
          END IF
        END IF
      ELSE IF(ICSTAT.EQ.3) THEN
C
C  Except for the concluding the case just considered for a file name
C  picked up as a keyword by EQSCN2, conclude processing for ICSTAT=3
C
        GO TO 25
      ELSE IF(IFLAGE.EQ.0.AND.IFPSW.EQ.1.AND.IFNAME.EQ.0) THEN
C
C  If EQSCAN did not even partially scan, check for a long file name
C  Note: This will be the case upon encountering any file name with
C  initial or embedded forward / or back slashes.
C
        IF((IFLAG(1).EQ.0.OR.IACTN.NE.1).AND.IPT.NE.0) THEN
          CALL NBFIND(CARD(IPT:256),IPT,256,IPOS)
          IF(IPOS.GT.0) THEN
            IPT=IPOS
            IF(IACTN.NE.2.OR.ITYPE(1).GT.0) THEN
              IT=1
            ELSE
              IT=2
            END IF
            CALL FNFIND(IPT)
            IFNAME=1
C
C  Return to 10 to continue reading.
C
            GO TO 10
          ELSE
            IF(U5.GE.13.AND.U5.LE.17) THEN
              IMERR1=160306
              IMERR2=IPT
              RETURN
            ELSE
              CALL FPSTOP(160306,IPT)
            END IF
          END IF
        END IF
C
C  For KEYWRD = found, determine whether IN=, OUT=, OR VPLXIN=
C
      ELSE IF(IFPSW.EQ.1.AND.IFNAME.EQ.0) THEN
        CALL CMATCH(KEYWRD,1,MAXKWL,'IN',2,IPOS,1)
        IF(IPOS.GT.0) THEN
          IT=1
        ELSE
          CALL CMATCH(KEYWRD,1,MAXKWL,'OUT',3,IPOS,1)
          IF(IPOS.GT.0) THEN
            IF(IACTN.EQ.3) THEN
              IT=1
            ELSE
              IT=2
            END IF
          ELSE
            CALL CMATCH(KEYWRD,1,MAXKWL,'VPLXIN',6,IPOS,1)
            IF(IPOS.GT.0) THEN
              IF(ITYPE(3).EQ.0) THEN
                IT=1
              ELSE
                IT=3
              END IF
            ELSE
              IT=0
              CALL CMATCH(KEYWRD,1,MAXKWL,'VPLXOUT',7,IPOS,1)
              IF(IPOS.GT.0) THEN
                IT=2
              END IF
              CALL CMATCH(KEYWRD,1,MAXKWL,'UNF_INTEGER_IN',14,IPOS,1)
              IF(IPOS.GT.0) THEN
                IT=1
                IFV=3
              END IF
              CALL CMATCH(KEYWRD,1,MAXKWL,'UNF_REAL_IN',11,IPOS,1)
              IF(IPOS.GT.0) THEN
                IT=1
                IFV=4
              END IF
              CALL CMATCH(KEYWRD,1,MAXKWL,'UNF_DOUBLE_IN',13,IPOS,1)
              IF(IPOS.GT.0) THEN
                IT=1
                IFV=5
              END IF
              CALL CMATCH(KEYWRD,1,MAXKWL,'UNF_INTEGER_OUT',15,IPOS,1)
              IF(IPOS.GT.0) THEN
                IT=2
                IFV=3
              END IF
              CALL CMATCH(KEYWRD,1,MAXKWL,'UNF_REAL_OUT',12,IPOS,1)
              IF(IPOS.GT.0) THEN
                IT=2
                IFV=4
              END IF
              CALL CMATCH(KEYWRD,1,MAXKWL,'UNF_DOUBLE_OUT',14,IPOS,1)
              IF(IPOS.GT.0) THEN
                IT=2
                IFV=5
              END IF
C
C  Specification of an unformatted file with CREATE pertains to the unit
C  10 output file, rather than the primary VPLX file output
C
              IF(IACTN.EQ.7.AND.IT.EQ.2) THEN
                IT=3
              END IF
C
              CALL CMATCH(KEYWRD,1,MAXKWL,'FORMATTED_OUT',13,IPOS,1)
              IF(IPOS.GT.0) THEN
                IF(IACTN.EQ.7) THEN
                  IT=3
                ELSE
                  IT=2
                END IF
                IF(IFLAG(IT).EQ.2) THEN
                  IF(U5.GE.13.AND.U5.LE.17) THEN
                    IMERR1=160323
                    RETURN
                  ELSE
                    CALL FESTOP(160323)
                  END IF
                END IF
              END IF
              CALL CMATCH(KEYWRD,1,MAXKWL,'FORMATTED_IN',12,IPOS,1)
              IF(IPOS.GT.0) THEN
                IT=1
                IF(IFLAG(IT).EQ.2) THEN
                  IF(U5.GE.13.AND.U5.LE.17) THEN
                    IMERR1=160323
                    RETURN
                  ELSE
                    CALL FESTOP(160323)
                  END IF
                END IF
              END IF
              IF(IT.EQ.0) THEN
                IF(U5.GE.13.AND.U5.LE.17) THEN
                  IMERR1=160307
                  RETURN
                ELSE
                  CALL FESTOP(160307)
                END IF
              END IF
            END IF
          END IF
        END IF
        CALL FNFIND(IPT)
        IFNAME=1
        GO TO 10
      ELSE
C
C  Interpretation of parameters.
C
        IF(IFLAGE.NE.1) THEN
          IF(U5.GE.13.AND.U5.LE.17) THEN
            IMERR1=160308
            RETURN
          ELSE
            CALL FESTOP(160308)
          END IF
        END IF
        DO 16 L=1,NPRMKY
        CALL CMATCH(KEYWRD,1,MAXKWL,PRMKEY(L),8,IPOS,1)
        IF(IPOS.GT.0)GO TO 17
   16   CONTINUE
C
C  If no match, go to error return
C
        IF(U5.GE.13.AND.U5.LE.17) THEN
          IMERR1=160309
          RETURN
        ELSE
          CALL FESTOP(160309)
        END IF
   17   CONTINUE
        IF(L.EQ.2) THEN
          I=IPT+3
          CALL CMATCH(CARD(IPT:I),IPT,I,'SER',3,IPOS,1)
          IF(IPOS.GT.0) THEN
C
C  VOL=SER construction
C
            IDONE=0
            IFLAGE=2
            IEQST=0
            IPT=IPT+3
            GO TO 10
          END IF
        END IF
        IF(L.LE.3.OR.L.EQ.10) THEN
          IF(L.EQ.1) THEN
            IPOS=80
          ELSE IF(L.EQ.2.OR.L.EQ.3) THEN
            IPOS=88
          ELSE IF(L.EQ.10) THEN
            IPOS=136
          END IF
   20     CONTINUE
          IF(CARD(IPT:IPT).NE.'''') THEN
            IPOS=IPOS+1
            IF((L.EQ.1.AND.IPOS.GT.88).OR.
     .         ((L.EQ.2.OR.L.EQ.3).AND.IPOS.GT.96).OR.
     .         (L.EQ.10.AND.IPOS.GT.144)) THEN
              IF(U5.GE.13.AND.U5.LE.17) THEN
                IMERR1=160310
                IMERR2=IPT
                RETURN
              ELSE
                CALL FPSTOP(160310,IPT)
              END IF
            END IF
            FNWRK(IPOS:IPOS)=CARD(IPT:IPT)
          END IF
          IPT=IPT+1
          IF(CARD(IPT:IPT).NE.' '.AND.CARD(IPT:IPT).NE.','.AND.
     .       CARD(IPT:IPT).NE.')')GO TO 20
        ELSE
          IF(L.EQ.4.OR.L.EQ.5) THEN
            IPOS=113
          ELSE IF(L.EQ.6.OR.L.EQ.7) THEN
            FNWRK(97:104)=PRMKEY(L)
            IPOS=105
          ELSE IF(L.EQ.8) THEN
            IPOS=121
          ELSE
            IPOS=129
          END IF
          CALL IFIND(CARD(IPT:256),IPT,256,I,J)
          IF(I.EQ.0) THEN
            IF(U5.GE.13.AND.U5.LE.17) THEN
              IMERR1=160311
              IMERR2=IPT
              RETURN
            ELSE
              CALL FPSTOP(160311,IPT)
            END IF
          END IF
          IF(J.LT.0.OR.J.GT.99999999) THEN
            IF(U5.GE.13.AND.U5.LE.17) THEN
              IMERR1=160312
              IMERR2=IPT
              RETURN
            ELSE
              CALL FPSTOP(160312,IPT)
            END IF
          END IF
          IPT=I
          WRITE(FNWRK(IPOS:IPOS+7),'(I8)')J
        END IF
        IEQST=1
        GO TO 10
      END IF
   25 CONTINUE
C
C  If there is no name in progress and ICSTAT=3 or a semicolon has
c  been encountered, proceed to final cleanup.
C
      IF((ICSTAT.EQ.3.OR.IPOSSC.GT.0).AND.IFNAME.EQ.0)GO TO 80
C
C  Duplicate input, output, etc.
C
      IF(IFLAG(IT).GT.0) THEN
        IF(IT.EQ.1) THEN
          IF(U5.GE.13.AND.U5.LE.17) THEN
            IMERR1=160313
            RETURN
          ELSE
            IF(U5.GE.13.AND.U5.LE.17) THEN
              IMERR1=160313
              RETURN
            ELSE
              CALL FESTOP(160313)
            END IF
          END IF
        ELSE IF(IT.EQ.2) THEN
          IF(U5.GE.13.AND.U5.LE.17) THEN
            IMERR1=160314
            RETURN
          ELSE
            CALL FESTOP(160314)
          END IF
        ELSE
          IF(U5.GE.13.AND.U5.LE.17) THEN
            IMERR1=160315
            RETURN
          ELSE
            CALL FESTOP(160315)
          END IF
        END IF
      END IF
C
      CALL FNLGTH(L)
      IF(IFV.GE.3) THEN
        IF(ITYPE(IT).NE.1) THEN
          IF(U5.GE.13.AND.U5.LE.17) THEN
            IMERR1=160322
            RETURN
          ELSE
            CALL FESTOP(160322)
          END IF
        ELSE
          ITYPE(IT)=IFV
        END IF
      END IF
      IF(IACTN.EQ.1.OR.IACTN.EQ.7) THEN
C                                        ! primary statement of step
        IFLAG(IT)=1
        IF(IT.EQ.1) THEN
          IU=12
          FNAM12=FNWRK
        ELSE IF(IT.EQ.2) THEN
          IU=11
          FNAM11=FNWRK
        ELSE
          IU=10
        END IF
      ELSE IF(IACTN.EQ.2) THEN
C                                   ! open file e.g., in transform step
C
C  Call IUFIND to obtain a unit number.
C
        CALL IUFIND(IFLAG(IT))
        IU=IFLAG(IT)
        IF(IFV.GE.3) THEN
          ITYPE(IT)=IFV
        END IF
      ELSE
        IFLAG(IT)=1
      END IF
C
      IF(IACTN.LE.2.OR.IACTN.EQ.7) THEN
        IF(IT.EQ.1.OR.(IACTN.LE.2.AND.IT.EQ.3)) THEN
C
C  Check that input file exists.
C
          CALL FINQEX(FEXIST)
          IF(.NOT.FEXIST) THEN
            IF(IT.EQ.1) THEN
              IF((U5.GE.13.AND.U5.LE.17).OR.CMPFLG.EQ.1) THEN
                IMERR1=160316
                RETURN
              ELSE
                CALL FESTOP(160316)
              END IF
            ELSE
              IF((U5.GE.13.AND.U5.LE.17).OR.CMPFLG.EQ.1) THEN
                IMERR1=160317
                RETURN
              ELSE
                CALL FESTOP(160317)
              END IF
            END IF
          END IF
        END IF
        IF(IT.EQ.1) THEN
C
C  For ITYPE(1) = 0, determine whether file is formatted or unformatted.
C
          IF(ITYPE(1).EQ.0) THEN
            CALL FINQFM(KEYWRD(1:12))
            CALL CMATCH(KEYWRD,1,MAXKWL,'FORMATTED',9,IPOS,1)
            IF(IPOS.GT.0) THEN
              ITYPE(1)=1
            ELSE
              ITYPE(1)=2
            END IF
          END IF
        END IF
C
C  Open file.
C
        IF(IT.EQ.1.AND.ITYPE(1).EQ.1) THEN
          CALL OPENRF(IU)
          IF(IMERR1.GT.0)RETURN
        ELSE IF(ITYPE(IT).GE.2.AND.(IT.EQ.1.OR.(IACTN.EQ.1.AND.IT.EQ.3))
     .      )THEN
          CALL OPENRU(IU)
          IF(IMERR1.GT.0)RETURN
          IF(IT.EQ.3) THEN
C
C  VPLXIN = file becomes the future default file for REWEIGHT
C
            LSTVPL=FNWRK
          END IF
        ELSE IF(ITYPE(IT).EQ.1) THEN
          CALL OPENWF(IU)
          IF(IMERR1.GT.0)RETURN
        ELSE
          CALL OPENWU(IU)
          IF(IMERR1.GT.0)RETURN
        END IF
      ELSE IF(IACTN.EQ.5.OR.IACTN.EQ.6) THEN
        CALL FINQEX(FEXIST)
        IF(FEXIST) THEN
C
C  Within this if block, FEXIST will now denote whether the file
C  is open.
C
          CALL FINQOP(FEXIST)
          IF(.NOT.FEXIST) THEN
C
C  If the file is not open, print warning message for FREE, open the
C  file for delete.
C
            IF(IACTN.EQ.6) THEN
              IF(U5ECHO.GT.0)WRITE(U6,211)
            ELSE
              CALL IUFIND(IU)
              CALL OPENG(IU)
            END IF
          ELSE
C
C  Obtain the unit number of an open file
C
            CALL FINQIU(IU)
          END IF
C
C  DELETE
C
          IF(IACTN.EQ.5) THEN
            CLOSE(UNIT=IU,STATUS='DELETE')
          ELSE IF(FEXIST) THEN
C
C  FREE
C
            IF(IU.GE.13.AND.IU.LE.17) THEN
              CLOSE(UNIT=IU,STATUS='DELETE')
            ELSE
              CLOSE(UNIT=IU)
            END IF
          END IF
        ELSE
C
C  Warning message for nonexistent file.
C
          WRITE(U6,212)
        END IF
      END IF
      BASE=IPT
      IF(IACTN.NE.3) THEN
        IEQST=1
C
C  Set IEQST=1 to indicate initial call to EQSCN2
C
        IEQST=1
C
C  Set IFPSW to initially expect a file name.  IFPSW=2 while
C  reading parameters.
C
        IFPSW=1
C
C  Set IFNAME=0 to indicate that a filename has not yet been read.
C  Set IFPARM=0 to indicate that file parameters have not been read.
C
        IFNAME=0
        IFPARM=0
C
C  Normally, both IDONE and IFLAGE are set on the initial call to
C  EQSCN2.  Set them to their initial values so that this information
C  will be available if ICSTAT=3
C
        IDONE=0
        IFLAGE=0
        IFV=1
      END IF
      IF(ICSTAT.NE.3.AND.IPOSSC.EQ.0)GO TO 10
C
C  Final cleanup.  Under IACTN=1, use previous VPLX files,
C  if present, as input files, if VPLX files expected
C
   80 CONTINUE
      IF(IACTN.EQ.1.OR.IACTN.EQ.7) THEN
        IF(.NOT.DONE) THEN
          IF((IFLAG(1).EQ.0.AND.ITYPE(1).EQ.2).OR.
     .       (IFLAG(3).EQ.0.AND.ITYPE(3).EQ.2)) THEN
C
C  If no input has yet been assigned, try the last VPLX file.
C
            IF(LSTVPL(1:1).NE.' ') THEN
              DONE=.TRUE.
              IF(IFLAG(1).EQ.0.AND.ITYPE(1).EQ.2) THEN
                IT=1
              ELSE
                IT=3
              END IF
              FNWRK=LSTVPL
              IFNAME=1
              GO TO 25
            END IF
            IF(IFLAG(3).EQ.0.AND.ITYPE(3).EQ.2) THEN
              IF(U5.GE.13.AND.U5.LE.17) THEN
                IMERR1=160318
                RETURN
              ELSE
                CALL FESTOP(160318)
              END IF
            END IF
          END IF
          IF(IFLAG(1).EQ.0) THEN
            IF(U5.GE.13.AND.U5.LE.17) THEN
              IMERR1=160319
              RETURN
            ELSE
              CALL FESTOP(160319)
            END IF
          END IF
        END IF
        IF(IFLAG(2).EQ.1.AND.ITYPE(2).EQ.2) THEN
          LSTVPL=FNAM11
        ELSE IF(ITYPE(1).EQ.2) THEN
          LSTVPL=FNAM12
        END IF
      ELSE
        IF(ITYPE(1).NE.0.AND.IFLAG(1).EQ.0) THEN
          IF(U5.GE.13.AND.U5.LE.17) THEN
            IMERR1=160320
            RETURN
          ELSE
            CALL FESTOP(160320)
          END IF
        ELSE IF(ITYPE(2).NE.0.AND.IFLAG(2).EQ.0) THEN
          IF(U5.GE.13.AND.U5.LE.17) THEN
            IMERR1=160321
            RETURN
          ELSE
            CALL FESTOP(160321)
          END IF
        END IF
      END IF
      BASE=1
   90 CONTINUE
      RETURN
      END
C
      SUBROUTINE FRSTOP(IUNIT)
C
      INTEGER IUNIT
C
C  Return for error on reading input file, unit IUNIT
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
  100 FORMAT(/,' ERROR ON PRIMARY IN= UNIT FROM STEP')
  101 FORMAT(/,' INPUT ERROR ON UNIT',I3)
C
      IF(IUNIT.EQ.11) THEN
        WRITE(U6,100)
        IF(IMERR1.EQ.0)IMERR1=90101
      ELSE
        WRITE(U6,101)IUNIT
        IF(IMERR1.EQ.0)IMERR1=90102
      END IF
      CALL FSTOP
      END
C
      SUBROUTINE FWSTOP(IUNIT)
C
      INTEGER IUNIT
C
C  Return for error on writing output file, unit IUNIT
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
  100 FORMAT(/,' ERROR ON PRIMARY OUT= UNIT FROM STEP')
  101 FORMAT(/,' OUTPUT ERROR ON UNIT',I3)
C
      CLOSE(UNIT=IUNIT,STATUS='DELETE')
      IF(IUNIT.EQ.11) THEN
        WRITE(U6,100)
        IF(IMERR1.EQ.0)IMERR1=90001
      ELSE
        WRITE(U6,101)IUNIT
        IF(IMERR1.EQ.0)IMERR1=90002
      END IF
      CALL FSTOP
      END
C
      SUBROUTINE INTIN(IUNIT,IX,TSIZE,ENDFLE)
C
      INTEGER IUNIT,TSIZE
      LOGICAL ENDFLE
      INTEGER IX(TSIZE)
C
C  IUNIT  - FORTRAN unit number
C  IX     - integer array to read
C  TSIZE  - size of IX
C  ENDFLE - end of file indicator.
C
C  Reads unformatted integers in blocks of 64 by calling INTIN0
C
      ENDFLE=.FALSE.
      IF(TSIZE.LE.0)RETURN
      DO 10 I=1,TSIZE,64
      IF(I+63.GT.TSIZE) THEN
        J=TSIZE-I+1
      ELSE
        J=64
      END IF
      CALL INTIN0(IUNIT,IX(I),J,ENDFLE)
      IF(ENDFLE) GO TO 20
   10 CONTINUE
   20 CONTINUE
      RETURN
      END
C
      SUBROUTINE INTIN0(IUNIT,IX,TSIZE,ENDFLE)
C
C  IUNIT  - FORTRAN unit number
C  IX     - integer array to read
C  TSIZE  - size of IX
C  ENDFLE - end of file indicator.
C
      INTEGER IUNIT,TSIZE
      LOGICAL ENDFLE
      INTEGER IX(TSIZE)
C
C  Read of integer array matrix
C
      READ(IUNIT,END=10,ERR=20)IX
      RETURN
   10 CONTINUE
      ENDFLE=.TRUE.
      RETURN
   20 CONTINUE
      CALL FRSTOP(IUNIT)
      END
C
      SUBROUTINE INTOUT(IUNIT,IX,TSIZE)
C
      INTEGER IUNIT,TSIZE
      INTEGER IX(TSIZE)
C
C  IUNIT  - FORTRAN unit number
C  IX     - integer array to read
C  TSIZE  - size of IX
C
C  Writes blocks of unformatted integers in blocks of 64 by calling
C  INTOU0
C
      IF(TSIZE.LE.0)RETURN
      DO 10 I=1,TSIZE,64
      IF(I+63.GT.TSIZE) THEN
        J=TSIZE-I+1
      ELSE
        J=64
      END IF
      CALL INTOU0(IUNIT,IX(I),J)
   10 CONTINUE
      RETURN
      END
C
      SUBROUTINE INTOU0(IUNIT,IX,TSIZE)
C
      INTEGER IUNIT,TSIZE
      INTEGER IX(TSIZE)
C
C  IUNIT  - FORTRAN unit number
C  IX     - integer array to read
C  TSIZE  - size of IX
C
      WRITE(IUNIT,ERR=20)IX
      RETURN
   20 CONTINUE
      CALL FWSTOP(IUNIT)
      END
C
      SUBROUTINE IUFIND(IUNIT)
C
      INTEGER IUNIT
C
C  Returns a possible unit number from 20-99 not currently in
C  use.
C
C  Note: changed 9/26/98 to reserve 18+19 as scratch, avoid use
C  of 18+19, upper limit of 99 instead of 39
C
      PARAMETER (MAXALT=5)
      PARAMETER (MSIZED=1000000)
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER U5ALT(MAXALT),U5ASTT(MAXALT)
      COMMON /A5BLCK/U5ALT,U5ASTT
C
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
      CHARACTER*256 CARDWK,CARDSV,CARDIM
      COMMON /CMBLK2/CARDWK,CARDSV,CARDIM
C
      LOGICAL FOPEND
C
  200 FORMAT(' COULD NOT ASSIGN UNIT')
  201 FORMAT(5X,'Assigned to unit',I3)
  202 FORMAT(1X)
      IUNIT=20
   10 CONTINUE
      IF(IUNIT.EQ.U5.OR.IUNIT.EQ.U6)GO TO 15
      DO 12 I=1,MAXALT
      IF(IUNIT.EQ.U5ALT(I))GO TO 15
   12 CONTINUE
      INQUIRE(UNIT=IUNIT,OPENED=FOPEND)
      IF(.NOT.FOPEND) THEN
        IF(CMPFLG.EQ.1) THEN
          CALL STBLNK(CARDWK,1,256)
          WRITE(CARDWK,201)IUNIT
          WRITE(13)CARDWK
          CALL STBLNK(CARDWK,1,256)
          WRITE(13)CARDWK
          NLINE=NLINE+2
          CALL ROOMD(2)
          IF(U5ENOW.GE.1) THEN
            DX(NXPTD-2)=1
            DX(NXPTD-1)=1
          ELSE
            DX(NXPTD-2)=0
            DX(NXPTD-1)=0
          END IF
        ELSE
          IF(U5ECHO.EQ.1) THEN
            WRITE(U6,201)IUNIT
          END IF
        END IF
        RETURN
      END IF
   15 CONTINUE
      IUNIT=IUNIT+1
      IF(IUNIT.EQ.100) THEN
C
C  Error message if no more units.
C
        CALL FESTOP(90200)
      END IF
      GO TO 10
      END
C
      SUBROUTINE SCPOSN(ISUB,NCELL)
C
      INTEGER ISUB,NCELL
C
C  ISUB   - number of subroutine writing file
C  NCELL  - size of stored data
C
C  During TRANSFORM, positions scratch file to data stored for
C  subroutine ISUB and returns NCELL.
C  The scratch file is laid out as a series of records.  A record
C  containing ISUB and NCELL as integers is followed by NCELL
C  double precision values blocked in records of length 32.
C
      PARAMETER (MSIZED=1000000)
      COMMON /DBLOCK/DX
      DOUBLE PRECISION DX(MSIZED)
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      LOGICAL ENDFLE
C
C  First, test if file is in currect position already.
C
      ENDFLE=.FALSE.
      READ(13,END=2)ISUBIN,NCELL
      GO TO 4
    2 CONTINUE
      ENDFLE=.TRUE.
    4 CONTINUE
C
C  If necessary, rewind file to search from the beginning.
C
      IF(ISUBIN.GT.ISUB.OR.ENDFLE) THEN
        REWIND(13)
        READ(13,END=90)ISUBIN,NCELL
      END IF
      IF(ISUBIN.EQ.ISUB)GO TO 80
      NXPTDS=NXPTD
      CALL ROOMD(32)
    5 CONTINUE
      DO 10 I=1,NCELL,32
      IF(I+32.GT.NCELL) THEN
        J=NCELL-I+1
      ELSE
        J=32
      END IF
      CALL UNFIN0(13,DX(NXPTDS),J,ENDFLE)
   10 CONTINUE
      READ(13)ISUBIN,NCELL
      IF(ISUBIN.LT.ISUB) THEN
        GO TO 5
      ELSE IF(ISUBIN.GT.ISUB) THEN
        GO TO 90
      END IF
      NXPTD=NXPTDS
   80 CONTINUE
      RETURN
   90 CONTINUE
      CALL FESTOP(90201)
      END
C
      SUBROUTINE PREAMB
C
C  Subroutine to read a VPLX file as the primary input and to
C  store the metadata in the COMMON arrays.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
C
C  MVAR   represents the maximum number of incoming and created
C         variables, replicate factors and wts
C  MLEVEL is the maximum number of stored labels for levels
C  MCRSSD is the maximum number of pointers for crossed arrays
C  MCLBLK is the maximum number of class blocks
C  MCLBAR is the maximum number of cells of class block arrays
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
C
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      LOGICAL ENDFLE
C
  202 FORMAT(' INCOMING VERSION NUMBER:',I12)
C
      READ(12,ERR=51)IVERSN
      GO TO 52
   51 CONTINUE
      IMERR1=90105
      CALL FRSTOP(12)
   52 CONTINUE
      IF(IVERSN.NE.9004.AND.IVERSN.NE.9203) THEN
        WRITE(U6,202)IVERSN
        CALL FESTOP(90106)
      END IF
      READ(12,ERR=99)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE,
     . VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR
c     write(*,*)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE,
c    . VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR
      CALL RCHECK(2,NVTOT,0)
      NID=NVARID+NBY
      IF(IVERSN.EQ.9004)NIDTOT=NID
      IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN
        IF(NVTOT.NE.NVREG+NCLASS+NVARID+NBY+NWGT-1) THEN
          WRITE(U6,*)VFTYPE,NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT
        END IF
      ELSE
        IF(NVTOT.NE.NVREG+NCLASS+NVARID+NBY+NWGT) THEN
          WRITE(U6,*)VFTYPE,NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT
        END IF
      END IF
C
C  NVTOT   - total number of variables on file
C  NVREG   - number of variables, excluding class, variance id's,
C            BY variables, and weight variable
C  NCLASS  - total number of class variables
C  NVARID  - number of variance id's, excluding BY variables
C  NBY     - number of BY variables
C  NWGT    - 0 or 1 indicating unweighted vs. weighted analysis
C  VFTYPE  - type of input used to create the file
C  VROPTN  - variance option
C  NIDTOT  - length of the ID records on the VPLX file
C  TSIZE   - total size of matrix
C  NCLBLK  - total number of class blocks
C  NCLBAR  - total size of class block information arrays
C
C  Note: NID is not on the file but is computed as NID=NVARID+NBY
C        for convenience of some subroutines
C
C VFTYPE = 3  Weighted obs. with cluster/replicate number
C         4  Unweighted  "
C         5  Replicate weights
C         6  Unweighted initial obs. followed by replicate weights
C         7  Replicate factors multiplying initial weight
C         8  Replicate factors of unweighted initial obs ( = VFTYPE 6)
C        11  Replicate factors multiplying initial weight, including
C            factor for replicate 0, overall estimate
C        12  Unweighted initial obs  "  (= VFTYPE 5)
C        13  Weighted obs. with cluster code
C        14  Unweighted "
C        15  Weighted obs. Stratum no. cluster code
C        16  Unweighted "
C        17  Wtd.          Stratum code, cluster code
C        18  Unwtd      "
C        21  Wtd.      Stratum no. 2nd stage no, cluster code
C        22  Unwtd.     "
C        23  Wtd.      Stratum no. 2nd stage cd, cluster code
C        24  Unwtd.     "
C        25  Wtd.      Stratum code  2nd stage no. cluster code
C        26  Unwtd      "
C        27  Wtd.      Stratum code  2nd stage cd, cluster code
C        28  Unwtd.     "
C        29  Wtd       2nd stage number cluster code
C        30  Unwtd.     "
C        31  Wtd       2nd stage code  cluster code
C        32  Unwtd      "
C        33  Wtd       Replicate number governed by stratum counts
C        34  Unwtd      "
C        35  Wtd       Rep numb govrned by stratum and 2nd stage counts
C        36  Unwtd      "
C        37  Wtd       Rep number governed by 2nd stage counts
C        38  Unwtd      "
C
      CALL RCHECK(8,NCLBLK,0)
      CALL RCHECK(9,NCLBAR,0)
      DO 1 I=1,NCLBLK
      READ(12,ERR=99)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I),
     . BLVSIZ(I),BLNCLS(I),BLCPNT(I)
c     write(*,*)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I),
c    . BLVSIZ(I),BLNCLS(I),BLCPNT(I)
    1 CONTINUE
      IF(NCLBAR.GT.0) THEN
        CALL INTIN(12,CLTYPE,NCLBAR,ENDFLE)
        CALL INTIN(12,CLPNT,NCLBAR,ENDFLE)
      END IF
C
C  BLTYPE  - 1 or 0 indicating row of (weighted) n vs. no row
C  BLXSTR  - pointer to first cell of incoming data in X matrix
C  BLXINC  - length of the X matrix for a single combination
C            of the class variables in the block
C  BLXSIZ  - total size of block data in X matrix (integer multiple
C            of BLXINC)
C  BLVSTR  - pointer to first variable
C  BLVSIZ  - number of variables in block
C  BLNCLS  - number of class variables in block
C  BLCPNT  - pointer for class information
C  CLTYPE  - type of class in array
C  CLPNT   - pointer to class variables
C
      IF(NVTOT.GT.0)CALL INTIN(12,MTYPE,NVTOT,ENDFLE)
C     if(nvtot.gt.0)write(*,*)(mtype(i),i=1,nvtot)
C
C  Variable types are read into MTYPE
C
C  Contents of MTYPE
C     1  =  real variable (total)
C     2  =  real variable with missing checks
C     3  =  categorical variable
C     4  =  class variable, known dimension
C     5  =  by variable, known dimension
C     6  =  by variable, unknown dimension
C     7  =  select transformation (not variable type)
C     8  =  cross variable, real value
C     9  =  cross variable, categorical
C    11  =  derived variable
C    13  =  crossed derived variable, single dimension
C    19  =  crossed derived variable
C
      IF(NVTOT.GT.0)CALL INTIN(12,MSIZE,NVTOT,ENDFLE)
c     if(nvtot.gt.0)write(*,*)(msize(i),i=1,nvtot)
C
C  Sizes are read into MSIZE
C
      IF(NVREG.GT.0)CALL INTIN(12,VMAPL,NVREG,ENDFLE)
c     if(nvtot.gt.0)write(*,*)(vmapl(i),i=1,nvreg)
C
C  VMAPL contains pointers to the first NVREG variables
C
      READ(12,ERR=99)NCRSSD
c     write(*,*)ncrssd
      CALL RCHECK(10,NCRSSD,0)
      IF(NCRSSD.GT.0)CALL INTIN(12,CROSSD,NCRSSD,ENDFLE)
      ILC=1
C
C  Create an array of pointers, CDMPNT, from the variables to
C  the starting entries in CROSSD
C
      DO 3 I=1,NVTOT
      J=MTYPE(I)
      IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN
        CDMPNT(I)=ILC
        ILC=CROSSD(ILC)+ILC+2
      ELSE
        CDMPNT(I)=0
      END IF
    3 CONTINUE
      IF(NCRSSD+1.NE.ILC) THEN
        CALL FESTOP(90107)
      END IF
      ILC=0
C
C  Read variable names and labels, and create an array of pointers,
C  LPOINT, to labels for the levels of the variables
C
      DO 6 I=1,NVTOT
      READ(12,ERR=99)VNAME(I),LABEL(I)
      J=MTYPE(I)
      IF(J.EQ.3.OR.J.EQ.4.OR.J.EQ.5.OR.J.EQ.13) THEN
        LPOINT(I)=ILC+1
        ILC=ILC+MSIZE(I)
      ELSE IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN
        LPOINT(I)=ILC+1
        K=CDMPNT(I)
        L=CROSSD(K)
        DO 4 M=1,L
        K=K+1
        ILC=ILC+CROSSD(K)+1
    4   CONTINUE
      ELSE
        LPOINT(I)=0
      END IF
    6 CONTINUE
C
C  Read in labels for the levels
C
      READ(12,ERR=99)NCRVL
c     write(*,*)ncrvl
      CALL RCHECK(7,NCRVL,0)
      IF(ILC.NE.NCRVL) THEN
        CALL FESTOP(90108)
      END IF
      IF(ILC.GT.0) THEN
        DO 10 I=1,ILC
        READ(12,ERR=99)LEVEL(I)
   10   CONTINUE
      END IF
      READ(12,ERR=99)ILC
C
C  Read in variable names for crossed variables
C
      CALL RCHECK(13,ILC,0)
      SVTEMP=ILC+1
      DO 12 I=1,ILC
      READ(12,ERR=99)VTEMP(I)
   12 CONTINUE
      IF(NBY.GE.1) THEN
        READ(12,ERR=99)NBYGRP
        SDBYID=NXPTD
        K=NBYGRP*NBY
        CALL ROOMD(K)
        K=SDBYID-1
        DO 17 I=1,NBYGRP
        READ(12,ERR=99)(DX(K+J),J=1,NBY)
        K=K+NBY
   17   CONTINUE
      ELSE
        SDBYID=0
        NBYGRP=1
      END IF
      READ(12,ERR=99)NRPTOT
      IF(NRPTOT.GT.0) THEN
        SDCOEF=NXPTD
        CALL ROOMD(NRPTOT)
        CALL UNFIN(12,DX(SDCOEF),NRPTOT,ENDFLE)
      ELSE
        SDCOEF=0
      END IF
      RETURN
   99 CONTINUE
      CALL FRSTOP(12)
      END
C
      SUBROUTINE PREAMO
C
C  Subroutine to write a VPLX file as the primary output, exactly
C  reversing the logic of PREAMB
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
C
C  MVAR   represents the maximum number of incoming and created
C         variables, replicate factors and wts
C  MLEVEL is the maximum number of stored labels for levels
C  MCRSSD is the maximum number of pointers for crossed arrays
C  MCLBLK is the maximum number of class blocks
C  MCLBAR is the maximum number of cells of class block arrays
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
C
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
  200 FORMAT(' ERROR: STORED INTEGER VALUE:',I8,3X,'RECOMPUTED:',I8)
C
      WRITE(11,ERR=99)IVERSN
      WRITE(11,ERR=99)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE,
     . VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR
C
C
      DO 1 I=1,NCLBLK
      WRITE(11,ERR=99)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I),
     . BLVSIZ(I),BLNCLS(I),BLCPNT(I)
    1 CONTINUE
      IF(NCLBAR.GT.0) THEN
        CALL INTOUT(11,CLTYPE,NCLBAR)
        CALL INTOUT(11,CLPNT,NCLBAR)
      END IF
C
      IF(NVTOT.GT.0)CALL INTOUT(11,MTYPE,NVTOT)
C
C
      IF(NVTOT.GT.0)CALL INTOUT(11,MSIZE,NVTOT)
C
C  Sizes are read into MSIZE
C
      IF(NVREG.GT.0)CALL INTOUT(11,VMAPL,NVREG)
C
C
C  Recompute, based on the entries in CROSSD, the expected number
C  for NCRSSD and also compute the number of variable names for
C  levels store in VNTEMP.
C
      ILC1=0
      ILC2=0
      DO 3 I=1,NVTOT
      J=MTYPE(I)
      IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN
        ILC2=CROSSD(ILC1+1)+ILC2
        ILC1=CROSSD(ILC1+1)+ILC1+2
      END IF
    3 CONTINUE
      IF(NCRSSD.NE.ILC1) THEN
        WRITE(U6,200)NCRSSD,ILC1
        CALL FESTOP(90111)
      END IF
      WRITE(11,ERR=99)NCRSSD
      IF(NCRSSD.GT.0)CALL INTOUT(11,CROSSD,NCRSSD)
C
C  Write variable names and labels
C
      ILC3=0
      DO 6 I=1,NVTOT
      WRITE(11,ERR=99)VNAME(I),LABEL(I)
      J=MTYPE(I)
      IF(J.EQ.3.OR.J.EQ.4.OR.J.EQ.5.OR.J.EQ.13) THEN
        ILC3=ILC3+MSIZE(I)
      ELSE IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN
        K=CDMPNT(I)
        L=CROSSD(K)
        DO 4 M=1,L
        K=K+1
        ILC3=ILC3+CROSSD(K)+1
    4   CONTINUE
      END IF
    6 CONTINUE
      IF(ILC3.NE.NCRVL) THEN
        WRITE(U6,200)NCRVL,ILC3
        CALL FESTOP(90112)
      END IF
C
C  Write labels for the levels
C
      WRITE(11,ERR=99)NCRVL
      IF(NCRVL.GT.0) THEN
        DO 10 I=1,NCRVL
        WRITE(11,ERR=99)LEVEL(I)
   10   CONTINUE
      END IF
      WRITE(11,ERR=99)ILC2
C
C  Write variable names for crossed variables
C
      IF(ILC2.GT.0) THEN
        DO 12 I=1,ILC2
        WRITE(11,ERR=99)VTEMP(I)
   12   CONTINUE
      END IF
      IF(NBY.GE.1) THEN
        WRITE(11,ERR=99)NBYGRP
        K=SDBYID-1
        DO 17 I=1,NBYGRP
        WRITE(11,ERR=99)(DX(K+J),J=1,NBY)
        K=K+NBY
   17   CONTINUE
      END IF
      WRITE(11,ERR=99)NRPTOT
      IF(NRPTOT.GT.0) THEN
        CALL UNFOUT(11,DX(SDCOEF),NRPTOT)
      END IF
      RETURN
   99 CONTINUE
      CALL FWSTOP(11)
      END
C
      SUBROUTINE SCOPEN(IUNIT)
C
      INTEGER IUNIT
C
C  IUNIT - unit number, 13-17, to open as scratch file.
C
C  If IUNIT is already open, rewind the file, else open a
C  scratch file.
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      LOGICAL FOPEND
      INQUIRE(UNIT=IUNIT,OPENED=FOPEND)
  100 FORMAT(/,5X,'Unnamed scratch file opened on unit',I3)
      IF(.NOT.FOPEND) THEN
        OPEN(UNIT=IUNIT,FORM='UNFORMATTED',STATUS='SCRATCH',ERR=10)
        IF(U5ECHO.GT.0)WRITE(U6,100)IUNIT
      ELSE
        REWIND(UNIT=IUNIT)
      END IF
      RETURN
   10 CONTINUE
      CALL FESTOP(90209)
      RETURN
      END
C
      SUBROUTINE UNFIN(IUNIT,DX,TSIZE,ENDFLE)
C
      INTEGER IUNIT,TSIZE
      LOGICAL ENDFLE
      DOUBLE PRECISION DX(TSIZE)
C
C  IUNIT  - unit number
C  DX     - matrix to read
C  TSIZE  - size of DX
C  ENDFLE - end of file
C
C  This routine reads double precision numbers in records of size
C  32 by repeated calls to UNFIN0
C
      ENDFLE=.FALSE.
      IF(TSIZE.LE.0)RETURN
      DO 10 I=1,TSIZE,32
      IF(I+31.GT.TSIZE) THEN
        J=TSIZE-I+1
      ELSE
        J=32
      END IF
      CALL UNFIN0(IUNIT,DX(I),J,ENDFLE)
      IF(ENDFLE) GO TO 20
   10 CONTINUE
   20 CONTINUE
      RETURN
      END
C
      SUBROUTINE UNFIN0(IUNIT,DX,TSIZE,ENDFLE)
C
      INTEGER IUNIT,TSIZE
      LOGICAL ENDFLE
      DOUBLE PRECISION DX(TSIZE)
C
C  IUNIT  - unit number
C  DX     - matrix to read
C  TSIZE  - size of DX
C  ENDFLE - end of file
C
      READ(IUNIT,END=10,ERR=20)DX
      RETURN
   10 CONTINUE
      ENDFLE=.TRUE.
      RETURN
   20 CONTINUE
      CALL FRSTOP(IUNIT)
      END
C
      SUBROUTINE UNFOUT(IUNIT,DX,TSIZE)
C
      INTEGER IUNIT,TSIZE
      DOUBLE PRECISION DX(TSIZE)
C
C  IUNIT  - unit number
C  DX     - matrix to write
C  TSIZE  - size of DX
C
C  This routine writes double precision numbers in records of size
C  32 by repeated calls to UNFOU0
C
C
      IF(TSIZE.LE.0)RETURN
      DO 10 I=1,TSIZE,32
      IF(I+31.GT.TSIZE) THEN
        J=TSIZE-I+1
      ELSE
        J=32
      END IF
      CALL UNFOU0(IUNIT,DX(I),J)
   10 CONTINUE
      RETURN
      END
      SUBROUTINE UNFOU0(IUNIT,DX,TSIZE)
C
      INTEGER IUNIT,TSIZE
      DOUBLE PRECISION DX(TSIZE)
C
C  IUNIT  - unit number
C  DX     - matrix to read
C  TSIZE  - size of DX
C
      WRITE(IUNIT,ERR=20)DX
   10 CONTINUE
      RETURN
   20 CONTINUE
      CALL FWSTOP(IUNIT)
      END
C
C
      SUBROUTINE OPENCH
C
C  Checks whether file in FNWRK is already opened.  If the file
C  is open, the run terminates in error.
C
      PARAMETER (MAXFMT=20)
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      LOGICAL FOPEND
C
  100 FORMAT(' ALREADY OPENED ON UNIT',I3)
  101 FORMAT(1X,A80)
C
      CALL FINQOP(FOPEND)
      IF(FOPEND) THEN
        CALL FINQIU(I)
        WRITE(U6,100)I
        WRITE(U6,101)FNWRK(1:80)
        IMERR1=90202
        RETURN
      END IF
      RETURN
      END
C
C  The following routines require changes to run in IBM CMS or MVS
C  environments.
C  There are also some VMS specific features.
C
      SUBROUTINE FINQEX(FEXIST)
C
      LOGICAL FEXIST
C
C  Check whether the file FNWRK already exists.
C
      PARAMETER (MAXFMT=20)
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
      CALL FNLGTH(I)
C
C     CALL IBMFII
C
      INQUIRE(FILE=FNWRK(1:I),EXIST=FEXIST)
      RETURN
      END
C
      SUBROUTINE FINQFM(KEYWRD)
C
      CHARACTER*12 KEYWRD
C
C  Keyword - FORTRAN-supplied UNFORMATTED, FORMATTED, returned by
C  INQUIRE
C
C  Routine to determine the format of a given file in FNWRK.
C
      PARAMETER (MAXFMT=20)
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
      CALL FNLGTH(I)
C
C     CALL IBMFII
C
      INQUIRE(FILE=FNWRK(1:I),FORM=KEYWRD)
      RETURN
      END
C
      SUBROUTINE FINQIU(IUNIT)
C
C  IUNIT - unit number where file is opened.
C
C  Check whether the file named in FNWRK is already open.
C
      INTEGER IUNIT
      PARAMETER (MAXFMT=20)
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
      CALL FNLGTH(I)
C
C     CALL IMBFII
C
      INQUIRE(FILE=FNWRK(1:I),NUMBER=IUNIT)
      RETURN
      END
C
      SUBROUTINE FINQOP(FOPEND)
C
      LOGICAL FOPEND
C
C  FOPEND - logical returned as "true" if the file in FNWRK is already
C  opened, false otherwise.
C
      PARAMETER (MAXFMT=20)
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
      CALL FNLGTH(L)
C
C     CALL IBMFII
C
      INQUIRE(FILE=FNWRK(1:L),OPENED=FOPEND)
      RETURN
      END
C
      SUBROUTINE OPENG(IUNIT)
C
C  IUNIT -  An available unit number.
C  An open subroutine used to open a file in order to delete it.
C
      PARAMETER (MAXFMT=20)
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
      CALL FNLGTH(L)
C
C     CALL IBMFIR
C
      OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),STATUS='UNKNOWN',ERR=10)
      RETURN
   10 CONTINUE
      CALL FESTOP(90204)
      END
C
      SUBROUTINE OPENRF(IUNIT)
C
C  IUNIT - unit number to open.
C  Open file for formatted reading.
C
      PARAMETER (MAXFMT=20)
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
  100 FORMAT(' ATTEMPTED OPEN FOR FORMATTED READING ON UNIT',I3)
      CALL FNLGTH(L)
      CALL OPENCH
      IF(IMERR1.GT.0) THEN
        WRITE(U6,100)IUNIT
        IF(U5.GE.13.AND.U5.LE.17) THEN
          RETURN
        ELSE
          CALL FSTOP
        END IF
      END IF
C
C     CALL IBMFIR
C
      OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),FORM='FORMATTED',STATUS='OLD',
     .       ERR=10)
C
C  VAX-specific form of the OPEN statement to take advantage of the
C  READONLY option.
C
C     OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),FORM='FORMATTED',STATUS='OLD',
C    .  READONLY,ERR=10)
C
C
      RETURN
   10 CONTINUE
      IMERR1=90205
      RETURN
      END
C
      SUBROUTINE OPENRU(IUNIT)
C
      INTEGER IUNIT
c
C  IUNIT - unit number to open.
C  Open file for unformatted reading.
C
      PARAMETER (MAXFMT=20)
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
  100 FORMAT(' ATTEMPTED OPEN FOR UNFORMATTED READING ON UNIT',I3)
      CALL FNLGTH(L)
      CALL OPENCH
      IF(IMERR1.GT.0) THEN
        WRITE(U6,100)IUNIT
        IF(U5.GE.13.AND.U5.LE.17) THEN
          RETURN
        ELSE
          CALL FSTOP
        END IF
      END IF
C
C     CALL IBMFIR
C     OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),FORM='UNFORMATTED',STATUS='OLD',
C    .  RECFM='VBS',ACTION='READ')
C
      OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),FORM='UNFORMATTED',STATUS='OLD',
     .     ERR=10)
C
C  VAX-specific form of the OPEN statement to take advantage of the
C  READONLY option.
C
C     OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),FORM='UNFORMATTED',STATUS='OLD',
C    .  READONLY,ERR=10)
C
      RETURN
   10 CONTINUE
      IMERR1=90206
      END
C
      SUBROUTINE OPENSC(IUNIT)
C
      INTEGER IUNIT
C
C  IUNIT - unit number to open.
C  Open named scratch file.  This routine is used exclusively
C  by REFRSH for SCRATCH1 etc.
C
      PARAMETER (MAXFMT=20)
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
C
      LOGICAL FOPEND
C
      CALL FNLGTH(L)
      INQUIRE(UNIT=IUNIT,OPENED=FOPEND)
      IF(FOPEND) THEN
        CLOSE(UNIT=IUNIT,STATUS='DELETE')
      END IF
      CALL CMATCH(FNWRK(137:139),137,139,'NEW',3,I,1)
      CALL CMATCH(FNWRK(137:143),137,143,'UNKNOWN',7,J,1)
      IF(I.GT.0.OR.(OSCODE.NE.1.AND.J.EQ.0)) THEN
        INQUIRE(FILE=FNWRK(1:L),EXIST=FOPEND)
        IF(FOPEND) THEN
          IMERR1=90210
          RETURN
        END IF
      END IF
      OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),FORM='UNFORMATTED',
     .    STATUS='UNKNOWN',ERR=10)
      RETURN
   10 CONTINUE
      IMERR1=90203
      RETURN
      END
C
      SUBROUTINE OPENWF(IUNIT)
C
      INTEGER IUNIT
c
C  IUNIT - unit number to open.
C  Open file for formatted writing.
C
      PARAMETER (MAXFMT=20)
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
      LOGICAL FEXIST
C
  100 FORMAT(' ATTEMPTED OPEN FOR FORMATTED WRITING ON UNIT',I3)
      CALL FNLGTH(L)
      CALL OPENCH
      IF(IMERR1.GT.0) THEN
        WRITE(U6,100)IUNIT
        IF(U5.GE.13.AND.U5.LE.17) THEN
          RETURN
        ELSE
          CALL FSTOP
        END IF
      END IF
C
C     CALL IBMFIF
C
C  If the file exists, open it and delete it first.  This feature
C  ensures on the VAX system that the output will receive a current
C  date.
C
      CALL FINQEX(FEXIST)
      IF(FEXIST) THEN
        CALL OPENG(IUNIT)
        CLOSE(UNIT=IUNIT,STATUS='DELETE')
      END IF
      OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),FORM='FORMATTED',STATUS='UNKNOWN',
     .     ERR=10)
C
C  VAX-specific form of the OPEN statement with CARRIAGECONTROL option
C  to produce a FORTRAN-readable output file without FORTRAN carriage
C  control.  If RECF has been specified, include this in the open
C  statement.
C
C 100 FORMAT(I8)
C     READ(FNWRK(113:120),100)IRECL
C     IF(IRECL.LE.0) THEN
C       OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),FORM='FORMATTED',
C    .    STATUS='UNKNOWN',CARRIAGECONTROL='LIST',ERR=10)
C     ELSE
C       OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),FORM='FORMATTED',
C    .    STATUS='UNKNOWN',CARRIAGECONTROL='LIST',RECL=IRECL,ERR=10)
C     END IF
C
      RETURN
   10 CONTINUE
      IMERR1=90207
      RETURN
      END
C
      SUBROUTINE OPENWU(IUNIT)
C
      INTEGER IUNIT
C
C  IUNIT - unit number to open.
C  Open file for unformatted writing.
C
      PARAMETER (MAXFMT=20)
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
      LOGICAL FEXIST
C
  100 FORMAT(' ATTEMPTED OPEN FOR UNFORMATTED WRITING ON UNIT',I3)
      CALL FNLGTH(L)
      CALL OPENCH
      IF(IMERR1.GT.0) THEN
        WRITE(U6,100)IUNIT
        IF(U5.GE.13.AND.U5.LE.17) THEN
          RETURN
        ELSE
          CALL FSTOP
        END IF
      END IF
C
C     CALL IBMFIU
C
C  If the file exists, open it and delete it first.
C
      CALL FINQEX(FEXIST)
      IF(FEXIST) THEN
        CALL OPENG(IUNIT)
        CLOSE(UNIT=IUNIT,STATUS='DELETE')
      END IF
      OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),FORM='UNFORMATTED',
     .    STATUS='UNKNOWN',ERR=10)
      RETURN
   10 CONTINUE
      IMERR1=90208
      RETURN
      END
C
C  End of I.FOR
C
C
C  Start of SC.FOR - general parsing routines.
C
      LOGICAL FUNCTION ALPCHK(C)
C
      CHARACTER*1 C
C
C  Returns TRUE if character is alphabetic or underscore
C
      CHARACTER*1 ALPHA1(26),ALPHA2(26)
      DATA ALPHA1/ 'A','B','C','D','E','F','G','H','I','J','K','L',
     . 'M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/
      DATA ALPHA2/ 'a','b','c','d','e','f','g','h','i','j','k','l',
     . 'm','n','o','p','q','r','s','t','u','v','w','x','y','z'/
C
      DO 1 I=1,26
      IF(C.EQ.ALPHA1(I).OR.C.EQ.ALPHA2(I)) THEN
        ALPCHK=.TRUE.
        RETURN
      END IF
    1 CONTINUE
      IF(C.EQ.'_') THEN
        ALPCHK=.TRUE.
      ELSE
        ALPCHK=.FALSE.
      END IF
      RETURN
      END
C
      LOGICAL FUNCTION BCHECK(C,BASE,TOP)
C
      INTEGER BASE,TOP
      CHARACTER*(*) C
C
C  C    - character variable to be checked for blanks
C  BASE - starting position in calling routine of the segment to be
C         checked.
C  TOP  - ending position in calling routine to be checked.
C
C  Returns TRUE if C(BASE:TOP) is all blank.
C
C  Note: call is of the form BCHECK(C(BASE:TOP),BASE,TOP)
C
      LEN=TOP-BASE+1
      DO 1 I=1,LEN
      IF(C(I:I).NE.' ') THEN
        BCHECK=.FALSE.
        RETURN
      END IF
    1 CONTINUE
      BCHECK=.TRUE.
      RETURN
      END
C
      SUBROUTINE CRDPRN(LSKIP)
C
      INTEGER LSKIP
C
C  Subroutine to print one line from the command file, indicating
C  substitutions, if any.
C
C  LSKIP - 0 no line skip, do not print under ECHO LITE unless a
C            substitution is made.  It is used, for example,
C            for normal continuation lines.
C        - 1 skip one line, do not print under ECHO LITE unless
C            substitution - normal printing for lines beginning
C            with a keyword
C        - 2 skip no line, print under all circumstances (e.g.,
C            error messages)
C        - 3 skip one line, print under ECHO LITE or ECHO (e.g.,
C            1st line of step)
C        - 4 on the basis of IMERR2, indicate error position with
C            a $ - used only while displaying information about
C            a fatal error
C
C  The routine recognizes comments following !
C  It prints them, but always blanks them out in CARD before return
C  When substitutions occur, it prints CARDIN first, but only
C  duplicates comments if substitutions occur within the comment
C
      PARAMETER (MAXSUB=500,MAXSBL=2000,MAXSNL=24)
      PARAMETER (MAXSBC=6000)
      INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL),
     .   U5LCSW
      COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      CHARACTER*80 CARDIN
      CHARACTER*8 LFMT
      CHARACTER*(MAXSNL) SUBNAM(MAXSUB)
      CHARACTER*12 SUBCSV(MAXSBC)
      COMMON /CINBLK/CARDIN,SUBNAM,SUBCSV
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
      CHARACTER*256 CARDWK,CARDSV,CARDIM
      COMMON /CMBLK2/CARDWK,CARDSV,CARDIM
C
  100 FORMAT(1X)
  101 FORMAT(1X,A79)
  102 FORMAT(1X,A80)
  103 FORMAT(1X,A76,'(-)')
  104 FORMAT(2X,A78)
  105 FORMAT(2X,A75,'(-)')
  106 FORMAT(2X,A30)
  107 FORMAT('(1X,A',I1,')')
  108 FORMAT('(1X,A',I2,')')
  109 FORMAT(5X,'Approximate position of error marked by ''$'' above')
C
      IAPOST=0
      IEXCLM=0
      CALL LASTCI(ILAST)
      DO 2 I=1,ILAST
C                                           ! Determine IEXCLM,
      IF(IAPOST.EQ.1) THEN
C                                           ! beginning of comment,
        IF(CARDIM(I:I).EQ.'''') THEN
C                                           ! if any, in CARDIM
          IAPOST=0
        END IF
      ELSE IF(IAPOST.EQ.2) THEN
        IF(CARDIM(I:I).EQ.'"') THEN
          IAPOST=0
        END IF
      ELSE IF(CARDIM(I:I).EQ.'''') THEN
        IAPOST=1
      ELSE IF(CARDIM(I:I).EQ.'"') THEN
        IAPOST=2
      ELSE IF(CARDIM(I:I).EQ.'!') THEN
        IF(IEXCLM.EQ.0) THEN
          IEXCLM=I
        END IF
        GO TO 4
      END IF
    2 CONTINUE
    4 CONTINUE
      IEXCL2=0
      IAPOST=0
      DO 6 I=1,80
C                                           ! Determine IEXCL2
      IF(IAPOST.EQ.1) THEN
C                                           ! beginning of comment,
        IF(CARDIN(I:I).EQ.'''') THEN
C                                           ! if any, in CARDIN
          IAPOST=0
        END IF
      ELSE IF(IAPOST.EQ.2) THEN
        IF(CARDIN(I:I).EQ.'"') THEN
          IAPOST=0
        END IF
      ELSE IF(CARDIN(I:I).EQ.'''') THEN
        IAPOST=1
      ELSE IF(CARDIN(I:I).EQ.'"') THEN
        IAPOST=2
      ELSE IF(CARDIN(I:I).EQ.'!') THEN
        IF(IEXCL2.EQ.0) THEN
          IEXCL2=I
        END IF
        GO TO 8
      END IF
    6 CONTINUE
    8 CONTINUE
C
C  Return under ECHO OFF unless LSKIP indicates to print under all
C  circumstances/
C
      IF(U5ECHO.EQ.0.AND.LSKIP.NE.2.AND.
     .  LSKIP.NE.4) THEN
        IF(IEXCLM.GT.0) THEN
C                                             ! If comments, always
          IF(CMPFLG.EQ.0) THEN
C                                             ! blank if CMPFLG = 0
            CALL STBLNK(CARDIM,IEXCLM,256)
          ELSE IF(IEXCL2.GT.0) THEN
C                                             ! If CMPFLG = 1, blank
            IF(CARDIN(IEXCL2:80).EQ.
C                                                    ! if substitution
     .         CARDIM(IEXCLM:IEXCLM+80-IEXCL2).AND.
C                                                    ! but no
     .         CARDIN.NE.CARDIM(1:80)) THEN
C                                                    ! substitution in
              CALL STBLNK(CARDIM,IEXCLM,256)
C                                                    ! comment
            END IF
          END IF
        END IF
        RETURN
      END IF
C
C  IMATCH is used to determine whether to print a card once (=1)
C  or twice (=0): before and after substitutions.  For LSKIP=4 only
C  print the result of substitution.
C
C  CININI (in common array) - 1 usual line
C                             0 part of multi-line substitution
C
      IF(CININI.EQ.1) THEN
        IF(U5.GE.13.AND.U5.LE.17) THEN
          IMATCH=1
        ELSE IF(CARDIN.EQ.CARDIM(1:80)) THEN
          IMATCH=1
        ELSE
          IMATCH=0
        END IF
      ELSE
        IMATCH=0
      END IF
C
C  Determination of whether to skip a line before printing card.
C  CININI=0 if this line is part of a multi-line substitution and
C  not the first line.  Usually, CININI=1.  Skip a line if LSKIP=4.
C
      IF((CININI.EQ.1.AND.(IMATCH.EQ.0.OR.LSKIP.EQ.3.OR.
     .   (LSKIP.EQ.1.AND.U5ECHO.EQ.1))).OR.LSKIP.EQ.4) THEN
        WRITE(U6,100)
      END IF
C
C  Print input card if substitutions occur.
C
      IF(IMATCH.EQ.0.AND.CININI.EQ.1) THEN
C
C  In Microsoft Powerstation implementation, the input line may be an
C  special end-of-file - determine this by call to the standard FORTRAN
C  function ICHAR.  Do not attempt to print the line in this case.
C  This test should not affect other FORTRAN implementations.
C
        ITEST=ICHAR(CARDIN(1:1))
        IF(ITEST.NE.26) THEN
          IF(CARDIN(80:80).EQ.' ') THEN
            WRITE(U6,101)CARDIN(1:79)
          ELSE
            WRITE(U6,102)CARDIN
          END IF
C
C  If the line includes a comment following '!', see if
C  substitutions have modified the comment itself.  If not,
C  blank out the matching section of CARD to avoid a redundant
C  printing of the comment.
C
          IF(IEXCLM.GT.0) THEN
            IF(IEXCL2.GT.0) THEN
              IF(CARDIN(IEXCL2:80).EQ.
     .           CARDIM(IEXCLM:IEXCLM+80-IEXCL2)) THEN
                CALL STBLNK(CARDIM,IEXCLM,256)
              END IF
            END IF
          END IF
        END IF
      END IF
C
C  For LSKIP=4, set up the '$' in the appropriate position in CARDIN.
C  Just in case, adjust IMERR2 to be no more than 1 + the last position
C  on the card.
C
      IF(LSKIP.EQ.4.AND.IMERR2.GT.0) THEN
        CALL STBLNK(CARDIN,1,80)
        CALL LASTCI(ILAST)
        IF(IMERR2.GT.ILAST)IMERR2=ILAST+1
C
C  ILAST is used here and below to indicate the last character to be
C  printed.  Usually, ILAST < 80 and this approach economizes on the
C  size of the print file compared to printing each line to 79.
C
        IF(IMERR2.GT.ILAST)ILAST=IMERR2
        IF(ILAST.LE.80) THEN
          CARDIN(IMERR2:IMERR2)='$'
        ELSE
          IF(IMERR2.LE.76) THEN
            CARDIN(IMERR2:IMERR2)='$'
          ELSE
C
C  Compute K as the relative position in CARDIN when the $ will
C  appear after the first displayed line.
C
            IF(ILAST.LE.154) THEN
              K=IMERR2-76
            ELSE
              IF(IMERR2.LE.151) THEN
                K=IMERR2-76
              ELSE
                IF(ILAST.LE.229) THEN
                  K=IMERR2-151
                ELSE
                  IF(IMERR2.LE.226) THEN
                    K=IMERR2-151
                  ELSE
                    K=IMERR2-226
                  END IF
                END IF
              END IF
            END IF
            CARDIN(K:K)='$'
          END IF
        END IF
      END IF
C
C  Printing of the contents of CARD after substitutions.
C
      IF(IMATCH.EQ.0.OR.U5ECHO.EQ.1.OR.(LSKIP.GE.2.AND.LSKIP.LE.4)) THEN
C
C  Determine ILAST, the last character for display
C
        CALL LASTCI(ILAST)
        IF(LSKIP.EQ.4) THEN
          IF(IMERR2.GT.ILAST)ILAST=IMERR2+1
        END IF
C
        IF(ILAST.EQ.80) THEN
          WRITE(U6,102)CARDIM(1:80)
          IF(LSKIP.EQ.4)WRITE(U6,102)CARDIN(1:80)
        ELSE IF(ILAST.LT.80) THEN
C
C  By far, ILAST < 80 will be the most frequent.  In this case,
C  construct an output format and write only CARDIM(1:ILAST) instead of
C  CARDIM(1:79) in order to reduce the size of the print file.
C  Construct a format in LFMT.
C
          IF(ILAST.LE.9) THEN
            IF(ILAST.EQ.0)ILAST=1
            WRITE(LFMT,107)ILAST
          ELSE
            WRITE(LFMT,108)ILAST
          END IF
          WRITE(U6,FMT=LFMT)CARDIM(1:ILAST)
          IF(LSKIP.EQ.4)WRITE(U6,FMT=LFMT)CARDIN(1:ILAST)
C
C  For printing of lines (after substitution) longer than 80
C
        ELSE
          WRITE(U6,103)CARDIM(1:76)
          IF(LSKIP.EQ.4) THEN
            IF(IMERR2.LE.76) THEN
              WRITE(U6,103)CARDIN(1:76)
C
C  If printing '$' here, skip an extra line to emphasize that it applies
C  to the line above it.
C
              WRITE(U6,100)
            END IF
          END IF
          IF(ILAST.LE.154) THEN
            WRITE(U6,104)CARDIM(77:154)
            IF(LSKIP.EQ.4) THEN
              IF(IMERR2.GE.77.AND.IMERR2.LE.154) THEN
                 WRITE(U6,104)CARDIN(1:78)
              END IF
            END IF
          ELSE
            WRITE(U6,105)CARDIM(77:151)
            IF(LSKIP.EQ.4) THEN
              IF(IMERR2.GE.77.AND.IMERR2.LE.151) THEN
                 WRITE(U6,105)CARDIN(1:75)
C
C  If printing '$' here, skip an extra line to emphasize that it applies
C  to the line above it.
C
                 WRITE(U6,100)
              END IF
            END IF
            IF(ILAST.LE.229) THEN
              WRITE(U6,104)CARDIM(152:229)
              IF(LSKIP.EQ.4) THEN
                IF(IMERR2.GE.152.AND.IMERR2.LE.229) THEN
                   WRITE(U6,104)CARDIN(1:78)
                END IF
              END IF
            ELSE
              WRITE(U6,105)CARDIM(152:226)
              IF(LSKIP.EQ.4) THEN
                IF(IMERR2.GE.152.AND.IMERR2.LE.226) THEN
                   WRITE(U6,105)CARDIN(1:75)
C
C  If printing '$' here, skip an extra line to emphasize that it applies
C  to the line above it.
C
                   WRITE(U6,100)
                END IF
              END IF
              WRITE(U6,106)CARDIM(227:256)
              IF(LSKIP.EQ.4) THEN
                IF(IMERR2.GE.227.AND.IMERR2.LE.256) THEN
                   WRITE(U6,106)CARDIN(1:30)
                END IF
              END IF
            END IF
          END IF
        END IF
C
C  Also skip a line to set off a substitution.
C
        IF(IMATCH.EQ.0.AND.ISUBCN.EQ.0.AND.ICHCNT.EQ.0)WRITE(U6,100)
        IF(LSKIP.EQ.4)WRITE(U6,109)
      END IF
C     IF(IEXCLM.GT.0) THEN                  ! Get to here under CMPFLG=0
C       CALL STBLNK(CARDIM,IEXCLM,256)      ! always blank comments
C     END IF
C     IF(IMERR1.GT.0.OR.IMERR2.GT.0) THEN
C       WRITE(U6,110)CARD(1:75)
C 110   FORMAT(1X,'**',1X,A75)
C     END IF
      RETURN
      END
C
      SUBROUTINE CLSCAN(BASE,IPOSN,IA,MAXIA,NSPTOT,VTMP,MVTMP,RANGET,
     . MAXRNG,RTYPET,RGRPT,NVIN)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER BASE,IPOSN,MAXIA,NSPTOT,MVTMP,MAXRNG,NVIN
      INTEGER IA(3,MAXIA),RTYPET(MAXRNG),RGRPT(MAXRNG)
      DOUBLE PRECISION RANGET(2,MAXRNG)
      CHARACTER*12 VTMP(MVTMP)
C
C  Beginning at CARD(BASE:BASE), CLSCAN will scan CARD for class
C  specifications
C
C  BASE   - starting position, reset to 1 if CLSCAN reads another
C           card
C  IPOSN  - position at end of class processing - returned by CLSCAN
C           set to 0 if at end of all continuation lines
C  IA     - array encoding results of parsing - returned.  A description
C           of the contents of this array is given by comments below.
C  MAXIA  - maximum available rows in IA.  CLSCAN will monitor to
C           avoid overfilling IA
C  NSPTOT - total number of rows of IA filled.  CLSCAN will
C           identify one or more class groupings.  A product of
C           class variables joined by * is considered a single
C           group
C  VTMP   - a work array that CLSCAN uses to hold variable names
C  MVTMP  - the size of VTMP
C  RANGET - an array that CLSCAN uses to hold ranges
C  MAXRNG - the maximum size of RANGET(2,MAXRNG), RTYPET, RGRPT
C  RTYPET - an array that CLSCAN uses to hold variable types
C  RGRPT  - an array that CLSCAN uses to hold range groups
C  NVIN   - the number of currently defined variables
C
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
C
C  MVAR   represents the maximum number of incoming and created
C         variables, replicate factors and weights
C  MLEVEL is the maximum number of stored labels for levels
C  MCRSSD is the maximum number of pointers for crossed arrays
C  MCLBLK is the maximum number of class blocks
C  MCLBAR is the maximum number of cells of class block arrays
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
C
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      LOGICAL REFRSH
      EXTERNAL REFRSH
C
  201 FORMAT(' UNRECOGNIZED VARIABLE NAME: ',A12)
  203 FORMAT(' NOT A CLASS VARIABLE: ',A12)
  204 FORMAT(' OVERFLOW IN CLSCAN ARRAY')
  205 FORMAT(' IMPROPER RANGE: ',A12)
  206 FORMAT(' PRODUCT WITH ITSELF: ',A12)
C
      IPOSN=BASE
C
C  Initial setting for NSPTOT.  During CLSCAN, NSPTOT is generally
C  larger than the actual completed storage but represents the top of
C  the anticipated use of IA.  It is set to the actual number of rows
C  just before returning, after 35 CONTINUE.
C
      NSPTOT=2
      IF(NSPTOT.GT.MAXIA)GO TO 90
C
C  IS     - marks start of current series of class groupings.  A set
C           of classes linked as a product by *'s is called a "group"
C           here.
C  ISTAR  - flag to indicate * just read
C  IV1    - current class variable
C  IVTMP  - current variable # read by VNFIND under consideration
C  NVTMP  - number of variables read by VNFIND
C  ICLM   - the product of the dimensions of the classes, to be
C           stored eventually into IA(3,IS)
C  NIV    - number of class variables in the group, to be stored
C           eventually into IA(2,IS)
C
      IS=1
      IA(1,1)=0
      IA(2,1)=0
      IA(3,1)=0
      ISTAR=0
      IV1=0
      IVTMP=0
      NVTMP=0
      ICLM=1
      NIV=0
C
C  Storage into IA(3,*) (output from CLSCAN)
C
C   IA(1,a) = number of rows in group, not counting row a
C   IA(2,a) = number of class variables referenced
C   IA(3,a) = product of dimensions of specified classes
C   IA(1,a+1) etc.  number of class variable
C   IA(2,a+1) =0, IA(3,a+1) both zero - use all levels of class
C   IA(2,a+1) level of class (possibly including 0)
C   IA(3,a+1) group into which it falls 1, 2, etc.
C
   10 CONTINUE
C
C  If no remaining continuation records, go to end
C
      IF(IPOSN.EQ.0)GO TO 35
C
C  Find next non-blank character.  If another card is read, reset
C  BASE.
C
      CALL NBFND2(IPOSN,IPOS2)
      IF(IPOSN.EQ.1)BASE=1
C
C  If IPOS2=0, no remaining continuation lines.
C
      IF(IPOS2.EQ.0) THEN
        IPOSN=0
        GO TO 35
      END IF
      IPOSN=IPOS2
      IF(CARD(IPOSN:IPOSN).EQ.'*') THEN
C
C  If encounter '*', error unless preceded by a class
C
        IF(IV1.EQ.0) THEN
          CALL FPSTOP(160001,IPOSN)
        END IF
C
C  Set ISTAR=1 and reset IV1 to 0
C
        ISTAR=1
        IPOSN=IPOSN+1
        IV1=0
        GO TO 10
      ELSE IF(CARD(IPOSN:IPOSN).EQ.',') THEN
C
C  Processing of ',' is similar to '*', but ISTAR not set.
C
        IPOSN=IPOSN+1
        IV1=0
        GO TO 10
      ELSE IF(CARD(IPOSN:IPOSN).EQ.'(') THEN
C
C  Processing of a range specification after a class variable.
C
C  If encounter '(' generate an error message unless preceded by a class
C
        IF(IV1.LE.0) THEN
          CALL FPSTOP(160002,IPOSN)
        END IF
C
        IPOSN=IPOSN+1
C
C  The class has already been entered into IA without allowance for
C  the specification to follow in the parenthesis, hence must adjust
C  entries in IA already made. ICLM is divided by MSIZE(IV1) to undo
C  a previous multiplication by MSIZE(IV1)
C
        NSPTOT=NSPTOT-1
        ICLM=ICLM/MSIZE(IV1)
C
C  The call to RNSCAN is used to determine the specified ranges, RNSCAN
C  will look for a ')' to end the specification.
C
        CALL RNSCAN(IPOSN,IPOS2,RANGET,MAXRNG,RTYPET,
     .    RGRPT,NR,3,LEVEL,1)
C
C  Error if RNSCAN did not successfully find ranges.
C
        IF(NR.LE.0) THEN
          IF(IPOSN.GT.1) IMERR2=IPOSN
          CALL FESTOP(160003)
        END IF
C
C  Change BASE if new card read.
C
        IF(IPOSN.EQ.1)BASE=1
        IPOSN=IPOS2
C
C  IG    - index for the number of levels specified
C  IPLUS - + included in range specification
C  IPLSV - retains plus from the previous level
C
C  Interpret ranges from RNSCAN as levels of the class variable
C
        IG=0
        IPLSV=0
        DO 15 IR=1,NR
        IRT=RTYPET(IR)
        IF(IRT.GT.6) THEN
          IPLUS=1
          IRT=IRT-6
        ELSE
          IPLUS=0
        END IF
C
C  Range type
C  1  value1 - value2
C  2  LOW - value
C  3  value - HIGH
C  4  LOW - HIGH
C  5  MISSING
C  6  value - n
C
C  Edit the range.
C
        IF(IRT.EQ.5) THEN
          WRITE(U6,205)VNAME(IV1)
          CALL FESTOP(160004)
        ELSE IF(IRT.EQ.1.OR.IRT.EQ.3.OR.IRT.EQ.6) THEN
          I=RANGET(1,IR)
          IF(I.LT.0..OR.I.GT.MSIZE(IV1))GO TO 98
        END IF
        IF(IRT.EQ.1.OR.IRT.EQ.2) THEN
          I=RANGET(2,IR)
          IF(I.LT.0..OR.I.GT.MSIZE(IV1))GO TO 98
        END IF
C
C  Loop over the possible levels of the class, including 0,
C  to determine what levels fall inside the range.
C
        DO 12 I=0,MSIZE(IV1)
        DI=I
        IF(IRT.EQ.1) THEN
          IF(DI.LT.RANGET(1,IR).OR.DI.GT.RANGET(2,IR))GO TO 12
        ELSE IF(IRT.EQ.2) THEN
          IF(DI.GT.RANGET(2,IR))GO TO 12
        ELSE IF(IRT.EQ.3.OR.IRT.EQ.6) THEN
          IF(DI.LT.RANGET(1,IR))GO TO 12
        END IF
C
C  If a plus was not detected previously, increment the level
C
        IF(IPLSV.EQ.0)IG=IG+1
C
C  Storage of the specification in the following manner.
C
C   IA(1,a+1) etc.  number of class variable
C   IA(2,a+1) level of class (possibly including 0)
C   IA(3,a+1) group into which it falls 1, 2, etc.
C
        IA(1,NSPTOT)=IV1
        IA(2,NSPTOT)=I
        IA(3,NSPTOT)=IG
C
C  Increment NSPTOT and check that have not run out of space
C
        NSPTOT=NSPTOT+1
        IF(NSPTOT.GT.MAXIA)GO TO 90
   12   CONTINUE
C
C  Save whether a plus is given in the range specification to determine
C  incrementing of IG.
C
        IPLSV=IPLUS
   15   CONTINUE
C
C  Accumulate the product of the specified dimensions.
C
        ICLM=ICLM*IG
        GO TO 10
      ELSE
C
C  Processing of a class variable or TOTAL.
C
   20   CONTINUE
C
C  If this class variable is not preceded by * and if NSPTOT > IS+1,
C  then complete the storage of the previous group.
C
C   IA(1,a) = number of rows in group, not counting row a
C   IA(2,a) = number of class variables referenced
C   IA(3,a) = product of dimensions of specified classes
C
        IF(ISTAR.EQ.0.AND.NSPTOT.GT.IS+1) THEN
          IA(1,IS)=NSPTOT-IS-1
          IA(2,IS)=NIV
          IA(3,IS)=ICLM
C
C  Reinitialize for beginning of next group and check availability
C  in IA array.
C
          ICLM=1
          NIV=0
          IS=NSPTOT
          IA(1,IS)=0
          IA(2,IS)=0
          IA(3,IS)=1
          NSPTOT=NSPTOT+1
          IF(NSPTOT.GT.MAXIA)GO TO 90
        END IF
C
C  NVTMP contains the number of variables previously read by VNFIND
C  (initialized to 0 at the top of the subroutine, and IVTMP contains
C  the number that have been processed.  If appropriate, attempt to
C  read variables, including under initial conditions IVTMP=NVTMP=0
C
        IF(IVTMP.GE.NVTMP) THEN
          CALL VNFIND(IPOSN,VTMP,MVTMP,NVTMP,IPOS2,2,VNAME,NVIN)
          IF(IPOSN.EQ.1)BASE=1
          IPOSN=IPOS2
C
C  Check for error return
C
          IF(NVTMP.EQ.-1) THEN
            IF(IPOSN.NE.1)IMERR2=IPOSN
            CALL FESTOP(160007)
C
C  If no variables read at this point, conclude the processing.
C
          ELSE IF(NVTMP.EQ.0) THEN
            GO TO 35
C
C  One or more variables read, reset IVTMP
C
          ELSE
            IVTMP=1
          END IF
        ELSE
C
C  If VNFIND was not just read, increment IVTMP
C
          IVTMP=IVTMP+1
        END IF
C
C  First check for 'TOTAL'
C
        CALL CMATCH(VTMP(IVTMP),1,12,'TOTAL',5,IPOS2,1)
        IF(IPOS2.GT.0) THEN
          IV1=0
C
C  If TOTAL does appear, it cannot be part of a product,
C  e.g., AGE * TOTAL
C
          IF(NSPTOT-IS.NE.1) THEN
            CALL FESTOP(160008)
          END IF
          IF(NSPTOT+2.GT.MAXIA)GO TO 90
          IA(1,IS)=1
          IA(2,IS)=0
          IA(3,IS)=1
          IS=IS+1
          IA(1,IS)=0
          IA(2,IS)=0
          IA(3,IS)=0
          IS=IS+1
          IA(1,IS)=0
          IA(2,IS)=0
          IA(3,IS)=1
          NSPTOT=IS+1
C
C  If more variables remain, recycle to 20.  Note that the storage into
C  IA immediately after 20 will not occur in this case since NSPTOT=IS+1
C
          IF(IVTMP.LT.NVTMP) THEN
            GO TO 20
          ELSE
            GO TO 10
          END IF
        ELSE
C
C  All other cases besides 'TOTAL'
C  First, identify the variable and assure that it is a class variable.
C
          CALL VNMTCH(VTMP(IVTMP),VNAME,NVIN,IV1)
          IF(IV1.GT.0) THEN
            IF(MTYPE(IV1).NE.4) THEN
              WRITE(U6,203)VNAME(IV1)
              CALL FESTOP(160009)
            ELSE
              IF(ISTAR.EQ.1) THEN
                DO 22 I=IS+1,NSPTOT-1
                IF(IV1.EQ.IA(1,I)) THEN
                  WRITE(U6,206)VNAME(IV1)
                  CALL FESTOP(160010)
                END IF
   22           CONTINUE
              END IF
              IA(1,NSPTOT)=IV1
              IA(2,NSPTOT)=0
              IA(3,NSPTOT)=0
C
C  At this point, multiply ICLM by the number of levels of the class
C  variable, even though this may be changed later to reflect a
C  subsequent specification enclosed in parentheses.
C
              ICLM=ICLM*MSIZE(IV1)
C
C  Increment the count of the number of class variables here.
C
              NIV=NIV+1
              ISTAR=0
              NSPTOT=NSPTOT+1
              IF(NSPTOT.GT.MAXIA)GO TO 90
C
C  If more variables remain, recycle to 20.
C
              IF(IVTMP.LT.NVTMP) THEN
                GO TO 20
              ELSE
                GO TO 10
              END IF
            END IF
          ELSE
C
C  Error return for unrecognized variable name.
C
            WRITE(U6,201)VTMP(IVTMP)
            CALL FESTOP(160011)
          END IF
        END IF
      END IF
  35  CONTINUE
C
C  End of CLSCAN processing.  If NSPTOT > IS+1, complete the storage
C  of the last group and set NSPTOT to mark the end.  Otherwise,
C  reduce NSPTOT to mark the end of the last real group processed.
C
      IF(NSPTOT.GT.IS+1) THEN
        IA(1,IS)=NSPTOT-IS-1
        IA(2,IS)=NIV
        IA(3,IS)=ICLM
        NSPTOT=NSPTOT-1
      ELSE
        NSPTOT=NSPTOT-2
      END IF
      RETURN
   90 CONTINUE
      WRITE(U6,204)
      CALL FESTOP(160006)
   98 CONTINUE
      WRITE(U6,205)VNAME(IV1)
      CALL FESTOP(160005)
      END
C
      SUBROUTINE CMATCH(C,BASE,TOP,C1,C1LEN,IPOS,IFLAG)
C
      INTEGER BASE,TOP,C1LEN,IPOS,IFLAG
      CHARACTER*(*) C,C1
C
C  Attempts to match C1 to C up to length of C(BASE:TOP) or first
C  blank in C1, in upper or lower case.
C
C  C     - string to be searched
C  BASE  - starting position in C
C  TOP   - ending position.  Call to CMATCH begins
C          CALL CMATCH(C(BASE:TOP),BASE,TOP,...
C  C1    - reference string to find
C  C1LEN - exact length of C1 to match (i.e. C1(1:C1LEN))
C          C1(1:C1LEN) should not include blanks
C  IPOS  - return first character in C beyond match, if successful
C          return 0 - match not successful.
C  IFLAG=1 match full length C1LEN of C1, and, as long as not
C          beyond TOP, check that next character in C(BASE:TOP)
C          is not alphabetic or numeric
C       =2 do not perform check.  Without the check, CMATCH may
C          return true even if additional letters follow the
C          matched segment in C
C       =3 generally, same as IFLAG=1, but also allow . as part of
C          name
C
      LOGICAL ALPCHK,DGTCHK
      EXTERNAL ALPCHK,DGTCHK
      CHARACTER*1 ALPHA1(26),ALPHA2(26)
      DATA ALPHA1/ 'A','B','C','D','E','F','G','H','I','J','K','L',
     . 'M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/
      DATA ALPHA2/ 'a','b','c','d','e','f','g','h','i','j','k','l',
     . 'm','n','o','p','q','r','s','t','u','v','w','x','y','z'/
C
      IPOS=0
      LEN=TOP-BASE+1
      DO 4 J=1,C1LEN
      IF(C1(J:J).EQ.' ')GO TO 5
      IF(J.GT.LEN)GO TO 6
      IF(C(J:J).EQ.C1(J:J))GO TO 4
      DO 3 K=1,26
C
C  This part of the code makes the match case insensitive.
C
      IF(C1(J:J).EQ.ALPHA1(K).OR.C1(J:J).EQ.ALPHA2(K)) THEN
        IF(C(J:J).EQ.ALPHA1(K).OR.C(J:J).EQ.ALPHA2(K)) THEN
          GO TO 4
        ELSE
          GO TO 6
        END IF
      END IF
    3 CONTINUE
      GO TO 6
    4 CONTINUE
      J=C1LEN+1
    5 CONTINUE
      IF(J.LE.LEN.AND.IFLAG.EQ.1) THEN
        IF(ALPCHK(C(J:J)).OR.DGTCHK(C(J:J)).OR.
     .     (IFLAG.EQ.3.AND.C(J:J).EQ.'.'))GO TO 6
      END IF
      IPOS=J+BASE-1
    6 CONTINUE
      RETURN
      END
C
      SUBROUTINE DASCAN(BASE,IPOS,DA,MAXDA,N)
C
      INTEGER BASE,IPOS,MAXDA,N
      DOUBLE PRECISION DA(MAXDA)
C
C  Searches the contents of the current command line (card) for
C  constants and reads additional lines, if appropriate.
C
C  BASE  - starting position in C (in common block) to search
C  IPOS  - next interpretable position
C          set to 0, if REFRSH returned false, i.e., no more
C          continuation  lines.
C  DA    - array to receive values.
C  MAXDA - maximum available space in DA
C  N     - number of double precision values found and stored into DA
C          return 0 if no values successfully found.
C
C  DASCAN includes the '*' feature to indicate multiple values, e.g.
C          50 * .08.  It treats  ',' and ' ' as spacing.
C
      DOUBLE PRECISION DVALUE,DVAL2
      LOGICAL ICHECK
      EXTERNAL ICHECK
      CHARACTER*256 C
      COMMON /CRDBLK/C
C
      IPOS=BASE
      N=0
C
C  IMULT - integer indicating multiplier in '*' syntax, e.g., 50 * .08
C
      IMULT=0
C
   10 CONTINUE
      CALL NBFND2(IPOS,IPOS2)
      IF(IPOS.EQ.1)BASE=1
      IPOS=IPOS2
C
C  Return if run out of information
C
      IF(IPOS.EQ.0) THEN
        RETURN
      END IF
C
C  Call DFIND to establish whether have encountered a valid number.
C
      CALL DFIND(IPOS,IPOS2,DVALUE,DVAL2,1)
C
C  Treatment of cases where a number has not been read.
C
      IF(IPOS2.LE.0) THEN
C
C  Simply skip ','
C
        IF(C(IPOS:IPOS).EQ.',') THEN
          IPOS=IPOS+1
C
C  If encounter '*'
C
        ELSE IF(C(IPOS:IPOS).EQ.'*') THEN
          IF(N.GE.1.AND.IMULT.EQ.0) THEN
            IF(ICHECK(DA(N),DVALUE)) THEN
              IMULT=DVALUE+.5
              IF(IMULT.GE.1.AND.IMULT.LT.1000000) THEN
                N=N-1
                IPOS=IPOS+1
              ELSE
                CALL FPSTOP(160031,IPOS)
              END IF
            ELSE
              CALL FPSTOP(160031,IPOS)
            END IF
          ELSE IF(IMULT.NE.0) THEN
            CALL FPSTOP(160032,IPOS)
          ELSE IF(N.GE.1) THEN
            CALL FPSTOP(160031,IPOS)
          END IF
        ELSE
C
C  Return if encountered some other character.
C
          RETURN
        END IF
      ELSE
C
C  When a value has been read by DFIND
C
        IF(IMULT.LE.0)IMULT=1
        DO 12 I=1,IMULT
        N=N+1
        IF(N.GE.MAXDA) THEN
          CALL FPSTOP(160030,IPOS)
        END IF
        DA(N)=DVALUE
   12   CONTINUE
        IMULT=0
        IPOS=IPOS2
      END IF
      GO TO 10
      END
C
      SUBROUTINE DFIND(BASE,IPOS,DVALUE,DVAL2,IFLAG)
C
      INTEGER BASE,IPOS,IFLAG
      DOUBLE PRECISION DVALUE,DVAL2
C
C  Reads a double precision number, DVALUE, IPOS=0 no number,
C  IPOS=-1 error on read, IPOS is next position after number
C  If IFLAG=2, DVAL2 is returned falling just below next larger
C  value of DVALUE by adding 1 to least significant digit given
C  e.g., DVALUE at 1.9 returns DVAL2 just below 2.0
C
C  BASE  -  integer, unchanged, giving starting character to
C           search card - CARD(BASE:BASE) assumed nonblank
C  IPOS  -  integer, returned giving
C           0   - no valid number
C          >0   - next character after number
C
C  DVALUE - double precision - returned value if IPOS > 0
C  DVAL2  - double precision - returned number just below DVALUE
C         if IFLAG = 2
C  IFLAG  - integer - passed, unchanged
C         1  computation of DVALUE only
C         2  computation of both DVALUE and DVAL2
C
C  As the routine scans the character string, it builds up in
C  CDVAL2 a number representing the precision in DVALUE.
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/ CARD
      DOUBLE PRECISION DBELOW
      EXTERNAL DBELOW
      CHARACTER*8 WFMT
      CHARACTER*30 CDVAL2
      LOGICAL DGTCHK
      EXTERNAL DGTCHK
      CHARACTER*1 DIGIT(10)
      DATA DIGIT /'0','1','2','3','4','5','6','7','8','9'/
C
      IPOS=0
      DVALUE=0.
      IF(IFLAG.EQ.2)DVAL2=0.
      CALL NBFIND(CARD(BASE:256),BASE,256,IPT)
      IF(IPT.EQ.0) THEN
        IPOS=0
        RETURN
      END IF
      ISTART=IPT
C
C  Starting at ISTART, begin search for a valid number.
C  Set flags during parsing -
C
C  IBLANK - blank encountered
C  IDEC   - position decimal point encountered
C  INEND  - pointer to last digit
C
      IBLANK=0
      IDEC=0
      IDFORM=0
      IEXP=0
      INEND=0
      IPT2=1
C
      IF(DGTCHK(CARD(ISTART:ISTART))) THEN
C
C  If encounter a digit first, start CDVAL2 with a 0.
C
        INEND=ISTART
        CDVAL2(1:1)='0'
      ELSE IF(CARD(ISTART:ISTART).EQ.'.') THEN
        IDEC=ISTART
        CDVAL2(1:1)=CARD(ISTART:ISTART)
      ELSE IF(CARD(ISTART:ISTART).EQ.'+'.OR.
     .    CARD(ISTART:ISTART).EQ.'-') THEN
C
C  In case of '+' or '-' simply begin CDVAL with a blank.
C
        CDVAL2(1:1)=' '
      ELSE
C
C  Return here if CARD(ISTART:ISTART) does not begin a number
C
        RETURN
      END IF
C
   10 CONTINUE
      IPT=IPT+1
C
C  If have scanned to the very end of CARD, conclude processing
C  following 50 CONTINUE
C
      IF(IPT.GT.256) GO TO 50
      IF(IPT-ISTART.GE.30) THEN
        IF(CARD(IPT:IPT).EQ.' ') THEN
          GO TO 50
        ELSE
C
C  Error condition if number seems too long
C
          CALL FPSTOP(160035,IPT)
        END IF
      END IF
C
C  Have encountered a digit.
C
      IF(DGTCHK(CARD(IPT:IPT))) THEN
C
C  If digits have been found previously then:
C     If a "D" or "E" has not been encountered:
C        Intervening blanks -> beginning of new number
C        No intervening blanks -> continuation of this number
C     Else if "D" or "E" encountered -> part of exponent
C  Else - mark beginning of digits.
C
C
        IF(INEND.GT.0) THEN
          IF(IDFORM.EQ.0) THEN
            IF(IBLANK.GT.0) THEN
              GO TO 50
            ELSE
              INEND=IPT
            END IF
          ELSE
            IEXP=IPT
          END IF
        ELSE
          INEND=IPT
        END IF
      ELSE IF(CARD(IPT:IPT).EQ.' ') THEN
C
C  If blank occurs before any digits - not a valid number.
C
        IF(INEND.EQ.0) THEN
          RETURN
        ELSE
C
C  Allow blanks before or after "D" or "E" e.g., .1  D 0
C  If a blank occurs after an exponent, conclude processing.
C
          IF(IDFORM.EQ.0) THEN
            IF(IBLANK.EQ.0) IBLANK=IPT
          ELSE IF(IEXP.GT.0) THEN
            GO TO 50
          END IF
        END IF
      ELSE IF(CARD(IPT:IPT).EQ.'+'.OR.CARD(IPT:IPT).EQ.'-') THEN
C
C  If encounter "+" or "-" after 1st position, conclude processing
C  unless possibly part of exponent.
C
        IF(IDFORM.EQ.0.OR.IEXP.GT.0) GO TO 50
      ELSE IF(CARD(IPT:IPT).EQ.'D'.OR.CARD(IPT:IPT).EQ.'E'.OR.
     .        CARD(IPT:IPT).EQ.'d'.OR.CARD(IPT:IPT).EQ.'e') THEN
C
C  Identification of "D" or "E" as part of scientific notation.
C
        IF(IDFORM.EQ.0) THEN
          IDFORM=IPT
        ELSE
          GO TO 50
        END IF
      ELSE IF(CARD(IPT:IPT).EQ.'.') THEN
C
C  Handling of decimal point.
C
        IF(IDEC.GT.0.OR.IBLANK.GT.0) THEN
          GO TO 50
        ELSE
          IDEC=IPT
        END IF
      ELSE
        GO TO 50
      END IF
C
C  Build up value in CDVAL2
C
      IPT2=IPT2+1
      IF(DGTCHK(CARD(IPT:IPT)).AND.IDFORM.EQ.0) THEN
         CDVAL2(IPT2:IPT2)='0'
      ELSE
        CDVAL2(IPT2:IPT2)=CARD(IPT:IPT)
      END IF
      GO TO 10
C
C  Loop back to 10 to look at next character.
C
C  Transfer to 50 at end of this number.
C
   50 CONTINUE
C
C  If INEND = 0, no digits encountered
C
      IF(INEND.EQ.0)RETURN
C
C  N1 - width of field to read
C
      IF(IDFORM.GT.0) THEN
        N1=IEXP-ISTART+1
      ELSE IF(INEND.GT.IDEC) THEN
        N1=INEND-ISTART+1
      ELSE
        N1=IDEC-ISTART+1
      END IF
C
      IPOS=ISTART+N1
C
C  N2 - number of places after decimal
C
      IF(IDEC.GT.0) THEN
        IF(IDFORM.GT.0) THEN
          N2=IDFORM-IDEC-1
        ELSE IF(INEND.GT.IDEC) THEN
          N2=INEND-IDEC
        ELSE
          N2=0
        END IF
      ELSE
        N2=0
      END IF
C
C  Choose between floating point and scientific notation.
C
      IF(IDFORM.EQ.0) THEN
        WFMT(1:2)='(F'
      ELSE
        WFMT(1:2)='(D'
      END IF
C
      I=3
   52 CONTINUE
C
C  Complete the format (Fn1.n2) or (Dn1.n2)
C
      IF(N1.GT.9) THEN
        J=N1/10
        N1=N1-J*10
        WFMT(I:I)=DIGIT(J+1)
        I=I+1
        GO TO 52
      ELSE
        WFMT(I:I)=DIGIT(N1+1)
        I=I+1
      END IF
      WFMT(I:I)='.'
      I=I+1
   54 CONTINUE
      IF(N2.GT.9) THEN
        J=N2/10
        N2=N2-J*10
        WFMT(I:I)=DIGIT(J+1)
        I=I+1
        GO TO 54
      ELSE
        WFMT(I:I)=DIGIT(N2+1)
        I=I+1
      END IF
      WFMT(I:I)=')'
      READ(CARD(ISTART:256),WFMT,ERR=60)DVALUE
      IF(IFLAG.EQ.2) THEN
        INEND=INEND-ISTART+1
        CDVAL2(INEND:INEND)='1'
        READ(CDVAL2,WFMT,ERR=61)DVAL2
        DVAL2=DVALUE+DVAL2
        DVAL2=DBELOW(DVAL2)
      END IF
      RETURN
C
C  Return for error reading value.
C
   60 CONTINUE
      CALL FPSTOP(160036,ISTART)
C
C  Return for error reading CDVAL2
C
   61 CONTINUE
      CALL FPSTOP(160037,ISTART)
      RETURN
      END
C
      LOGICAL FUNCTION DGTCHK(C)
C
C  Returns TRUE if character is digit
C
      CHARACTER*1 C
      CHARACTER*1 DIGIT(10)
      DATA DIGIT /'0','1','2','3','4','5','6','7','8','9'/
C
      DO 1 I=1,10
      IF(C.EQ.DIGIT(I)) THEN
        DGTCHK=.TRUE.
        RETURN
      END IF
    1 CONTINUE
      DGTCHK=.FALSE.
      RETURN
      END
C
      SUBROUTINE EQSCAN(BASE,IPT,KEYWRD,IFLAG)
C
      INTEGER BASE,IPT,IFLAG
      PARAMETER (MAXKWL=24)
      CHARACTER*(MAXKWL) KEYWRD
C
C  Searches command line(s) for a string of the form KEYWRD =
C  BASE  - starting position to search
C          reset to 1 if REFRSH used to read another line
C          set to 0 if at end of records
C  IPT   - returned ending position on conclusion of search
C          0 if no continuation lines remain
C  KEYWRD - returned keyword found
C  IFLAG=1 successful match, returns KEYWRD and, in IPT,
C          the next non-blank character after =
C       =2 valid KEYWRD only, IPT is next non-blank character
C       =0 invalid KEYWRD, IPT is first non-blank position
C
C  This subroutine will read additional lines from the input
C  file, if necessary, by calling REFRSH and managing the calls
C  to EQSCN2.
C
C  If KEYWRD = has been encountered, but no additional expression
C  follows, EQSCAN terminates with a fatal error
C
      LOGICAL REFRSH
      EXTERNAL REFRSH
C
      CALL EQSCN2(BASE,IPT,KEYWRD,IFLAG,1,IDONE)
   10 CONTINUE
      IF(IDONE.EQ.0) THEN
        IF(REFRSH(BASE)) THEN
          CALL EQSCN2(BASE,IPT,KEYWRD,IFLAG,0,IDONE)
          GO TO 10
        ELSE
          IF(IFLAG.EQ.1) THEN
            CALL FESTOP(160043)
          ELSE
            IPT=0
          END IF
        END IF
      END IF
      RETURN
      END
C
      SUBROUTINE EQSCN2(BASE,IPT,KEYWRD,IFLAG,ICSTAT,IDONE)
C
      INTEGER BASE,IPT,IFLAG,ICSTAT,IDONE
      PARAMETER (MAXKWL=24)
      CHARACTER*(MAXKWL) KEYWRD
C
C  Searches a command line for a string of the form KEYWRD =
C  BASE  - starting position to search, not changed by EQSCN2
C  IPT   - returned ending position on conclusion of search
C          0 reached end of line
C  KEYWRD - returned keyword found
C  IFLAG=1 successful match, returns KEYWRD and, in IPT,
C          the next non-blank character after =
C       =2 valid KEYWRD only, IPT is next non-blank character
C       =0 invalid KEYWRD, IPT is first non-blank position
C  ICSTAT = 1 passed flag indicating first call to routine,
C         = 0 continuation of problem
C         (not changed by EQSCN2)
C  IDONE = 1 now done
C          0 not apparently done, specification may continue on
C            another line
C            (returned)
C
C  This version of the subroutine processes a line at a time, and
C  returns in IDONE an indication of whether the task is complete.
C
C  This subroutine is called by EQSCAN, which uses REFRSH to read
C  multiple lines, if necessary, and by REFRSH through FNRD2, in order
C  to interpret INCLUDE, etc.
C
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/ CARD
      LOGICAL ALPCHK,DGTCHK
      EXTERNAL ALPCHK,DGTCHK
C
      IPT=BASE
C
C  On the initial call, i.e., ICSTAT=1, set IFLAG and IDONE
C
      IF(ICSTAT.EQ.1) THEN
        IFLAG=0
        IDONE=0
      END IF
C
   10 CONTINUE
      CALL NBFIND(CARD(IPT:256),IPT,256,IPOS)
      IPT=IPOS
C
C  If no remaining nonblank charcters, return
C
      IF(IPT.EQ.0) GO TO 99
      IF(CARD(IPT:IPT).EQ.','.AND.IFLAG.EQ.0) THEN
C
C  Ignore ","
C
        IPT=IPT+1
      ELSE IF(IFLAG.EQ.0) THEN
C
C  If a keywork has not yet been established, look here.
C
        IF(.NOT.ALPCHK(CARD(IPT:IPT))) THEN
C
C  No valid keyword established.  Upon return IFLAG=0 and IPT is
C  position of next nonblank character.
C
          IDONE=1
          GO TO 99
        END IF
C
C  Copy into KEYWRD
C
        L=1
        IFLAG=2
   12   CONTINUE
        KEYWRD(L:L)=CARD(IPT:IPT)
        IPT=IPT+1
        IF(IPT.LE.256.AND.L.LT.MAXKWL) THEN
          IF(ALPCHK(CARD(IPT:IPT)).OR.DGTCHK(CARD(IPT:IPT))) THEN
            L=L+1
            GO TO 12
          END IF
        END IF
        IF(L.LT.MAXKWL) THEN
          DO 14 I=L+1,MAXKWL
          KEYWRD(I:I)=' '
   14     CONTINUE
        END IF
        IF(CARD(IPT:IPT).NE.' '.AND.CARD(IPT:IPT).NE.'='.AND.
     .     CARD(IPT:IPT).NE.';') THEN
C
C  If unexpected characters, then end, either leaving IFLAG=2,
C  i.e., valid key word only, or IFLAG=0, i.e., no success.  (In some
C  EQSCN2 may be trying to read a filename longer than 12 characters
C  as if it were a key word.)  Note that file names with imbedded
C  forward, / or back slashes will not be considered key words
C
          IF(CARD(IPT:IPT).NE.',') THEN
            IFLAG=0
            IPT=IPOS
          END IF
          IDONE=1
          GO TO 99
        END IF
      ELSE IF(IFLAG.EQ.2) THEN
C
C  Test whether '=' found when expected (IFLAG=2)
C
        IF(CARD(IPT:IPT).NE.'=') THEN
          IDONE=1
          GO TO 99
        END IF
        IFLAG=1
        IPT=IPT+1
      ELSE
C
C  Arrive here if IPT>0 and IFLAG=1, i.e., successful completion
C
        IDONE=1
        GO TO 99
      END IF
      GO TO 10
   99 CONTINUE
      RETURN
      END
C
      SUBROUTINE IFIND(C,BASE,TOP,IPOS,IVALUE)
C
      INTEGER BASE,TOP,IPOS,IVALUE
      CHARACTER*(*) C
C
C  Finds an unsigned integer
C
C  C    - Character string to search
C  BASE - Starting position in calling routine
C  TOP  - Ending position in calling routine
C  Note:  call is of the form CALL IFIND(C(BASE:TOP),BASE,TOP,...
C  IPOS - 0 returned if unsuccessful
C         >0 next character (with respect to calling program)
C         i.e., C(IPOS,IPOS) is next character
C         Note: may be TOP+1
C  IVALUE - value if IPOS > 0
C         = -1 if IPOS = 0
C
      CHARACTER*1 DIGIT(10)
      DATA DIGIT /'0','1','2','3','4','5','6','7','8','9'/
C
      IPOS=0
      IVALUE=-1
      LEN=TOP-BASE+1
      IPT=0
C
C  Program will loop back to 10 until the first digit is read
C
   10 CONTINUE
      IPT=IPT+1
      IF(IPT.GT.LEN) RETURN
      DO 20 I=1,10
      IF(C(IPT:IPT).EQ.DIGIT(I)) GO TO 30
   20 CONTINUE
      IF(C(IPT:IPT).EQ.' ') THEN
        GO TO 10
      ELSE
        RETURN
      END IF
C
C  Transfer to 30 after first digit read
C  Set IVALUE and IPOS to indicate valid integer
C
   30 CONTINUE
      IVALUE=I-1
      ICOUNT=1
   31 CONTINUE
      IPOS=IPT+BASE
      IF(IPT.LT.LEN) THEN
        DO 33 I=1,10
        IF(C(IPT+1:IPT+1).EQ.DIGIT(I)) THEN
          ICOUNT=ICOUNT+1
          IF(ICOUNT.GT.9) THEN
            CALL FPSTOP(160040,IPOS)
          ELSE
            IVALUE=10*IVALUE+I-1
            IPT=IPT+1
            GO TO 31
          END IF
        END IF
   33   CONTINUE
      END IF
      RETURN
      END
C
      SUBROUTINE KYCHK2(IPT,IGROUP,IKEY,IPNT)
C
      INTEGER IPT,IGROUP,IKEY,IPNT
C
C  IPT    - starting position to begin search, not changed by
C           KYCHK2.  IPT should already point to an alphabetic
C           character.
C  IGROUP - key word group.
C           (may be 0)
C  IKEY   - code for key word
C         = 0 if no match found
C  IPNT   - IPNT first nonblank character after key word
C           = 0 if no match found, or if no nonblank character
C           follows the keyword.
C
C  Returns in IKEY the number of the keyword matching the first columns
C  of CARD, and in IPNT the first nonblank column after the
C  keyword.  A final 's' at the end of the keyword is accepted.
C  If an exact match is not found, a check will be made for an
C  unambiguous shortening.  If no match is found, KYCHK2 simply
C  returns with IPNT=0, unlike KYFND2
C
      PARAMETER (NKEY0=14,NKEY1=19,NKEY2=16,NKEY3=45,NKEY4=6,NKEY5=12)
      PARAMETER (NKEY6=9,NKEY7=28,NKEY8=12,NKEY9=15)
      PARAMETER (NKEY1B=NKEY0+1,NKEY1E=NKEY0+NKEY1)
      PARAMETER (NKEY2B=NKEY1E+1,NKEY2E=NKEY1E+NKEY2)
      PARAMETER (NKEY3B=NKEY2E+1,NKEY3E=NKEY2E+NKEY3)
      PARAMETER (NKEY4B=NKEY3E+1,NKEY4E=NKEY3E+NKEY4)
      PARAMETER (NKEY5B=NKEY4E+1,NKEY5E=NKEY4E+NKEY5)
      PARAMETER (NKEY6B=NKEY5E+1,NKEY6E=NKEY5E+NKEY6)
      PARAMETER (NKEY7B=NKEY6E+1,NKEY7E=NKEY6E+NKEY7)
      PARAMETER (NKEY8B=NKEY7E+1,NKEY8E=NKEY7E+NKEY8)
      PARAMETER (NKEY9B=NKEY8E+1,NKEY9E=NKEY8E+NKEY9)
      CHARACTER*12 KYWRD2(NKEY9E)
      COMMON /KYBLK2/KYWRD2
      INTEGER KEYGR1(NKEY9),KEYGR2(NKEY9)
      COMMON /KYBLK3/KEYGR1,KEYGR2
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      CHARACTER*256 CARD
      COMMON /CRDBLK/ CARD
C
      IGROUP=0
      IKEY=0
C
      IPOS2=IPT
      IPOS12=IPT+11
C
C  First, check for an exact match on a key word, or match
C  with an added 's'
C
      DO 20 I=1,NKEY9E
      CALL CMATCH(CARD(IPOS2:IPOS12),IPOS2,IPOS12,KYWRD2(I),
     . 12,IPOS,1)
      IF(IPOS.GT.0) THEN
        IKEY=I
        CALL NBFIND(CARD(IPOS:256),IPOS,256,IPNT)
        GO TO 80
      ELSE
        CALL CMATCH(CARD(IPOS2:IPOS12),IPOS2,IPOS12,KYWRD2(I),
     .    12,IPOS,2)
        IF(IPOS.GT.0) THEN
          IF((CARD(IPOS:IPOS).EQ.'S'.OR.CARD(IPOS:IPOS).EQ.'s').AND.
     .      CARD(IPOS+1:IPOS+1).EQ.' ') THEN
            IKEY=I
            IPOS=IPOS+1
            CALL NBFIND(CARD(IPOS:256),IPOS,256,IPNT)
            GO TO 80
          END IF
        END IF
      END IF
   20 CONTINUE
C
C  If no exact match, check for a shortening of a key word, which
C  is acceptable only if it is unambiguous.
C
C  First, determine where the abbreviation in CARD(IPOS2:IPOS12) ends
C
      DO 22 I=IPOS2,IPOS12
      IF(CARD(I:I).EQ.' ')GO TO 23
   22 CONTINUE
      GO TO 24
   23 CONTINUE
      IPOS12=I-1
   24 CONTINUE
      ILEN=IPOS12-IPOS2+1
C
C  Now loop over key words, finding how many key words the abbreviation
C  matches.
C
      NMATCH=0
      IF(ILEN.GT.0) THEN
        DO 30 I=1,NKEY9E
        CALL CMATCH(CARD(IPOS2:IPOS12),IPOS2,IPOS12,KYWRD2(I),
     .   ILEN,IPOS,2)
        IF(IPOS.EQ.IPOS12+1) THEN
          NMATCH=NMATCH+1
          IKEY=I
          CALL NBFIND(CARD(IPOS:256),IPOS,256,IPNT)
        END IF
   30   CONTINUE
      END IF
      IF(NMATCH.GE.2) THEN
        IKEY=0
        IPNT=0
      END IF
C
C  Recode IKEY into IGROUP, IKEY
C
   80 CONTINUE
      IF(IKEY.LE.NKEY0) THEN
        IGROUP=0
      ELSE IF(IKEY.LE.NKEY1E) THEN
        IGROUP=1
        IKEY=IKEY-NKEY0
      ELSE IF(IKEY.LE.NKEY2E) THEN
        IGROUP=2
        IKEY=IKEY-NKEY1E
      ELSE IF(IKEY.LE.NKEY3E) THEN
        IGROUP=3
        IKEY=IKEY-NKEY2E
      ELSE IF(IKEY.LE.NKEY4E) THEN
        IGROUP=4
        IKEY=IKEY-NKEY3E
      ELSE IF(IKEY.LE.NKEY5E) THEN
        IGROUP=5
        IKEY=IKEY-NKEY4E
      ELSE IF(IKEY.LE.NKEY6E) THEN
        IGROUP=6
        IKEY=IKEY-NKEY5E
      ELSE IF(IKEY.LE.NKEY7E) THEN
        IGROUP=7
        IKEY=IKEY-NKEY6E
      ELSE IF(IKEY.LE.NKEY8E) THEN
        IGROUP=8
        IKEY=IKEY-NKEY7E
      ELSE
        I=IKEY-NKEY8E
        IGROUP=KEYGR1(I)
        IKEY=KEYGR2(I)
      END IF
      RETURN
      END
C
      SUBROUTINE KYFIND(IKEY,IPNT)
C
      INTEGER IKEY,IPNT
C
C  IKEY - code for key word
C         = -1 if _ not followed by a key word
C  IPNT - IPNT first nonblank character after key word
C
C  Returns in IKEY the number of the keyword matching the first columns
C  of CARD, and in IPNT the first nonblank column after the
C  keyword.  A final 's' at the end of the keyword is accepted.
C  If an exact match is not found, a check will be made for an
C  unambiguous shortening.  A fatal error occurs if no match is found.
C
      PARAMETER (NKEY=200)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      CHARACTER*256 CARD
      COMMON /CRDBLK/ CARD
      CHARACTER*12 KEYWRD(NKEY)
      COMMON /KEYBLK/KEYWRD
C
  100 FORMAT(' _')
  201 FORMAT(' AMBIGUOUS KEY WORD - POSSIBLE:')
  202 FORMAT(5X,A12)
  203 FORMAT(' UNMATCHED KEY WORD')
C
      IKEY=0
C
C  If position 1 contains _, then find beginning of key word
C
      IF(CARD(1:1).EQ.'_') THEN
        IPOS=2
        CALL NBFIND(CARD(IPOS:256),IPOS,256,IPOS2)
        IF(IPOS2.EQ.0) THEN
          IF(U5ECHO.EQ.1)WRITE(U6,100)
          CALL NBFND2(IPOS,IPOS2)
        END IF
        IF(IPOS2.EQ.0) THEN
C
C  Return -1 if key word not found
C
          IKEY=-1
          IPNT=0
          GO TO 90
        ELSE
          IPOS12=IPOS2+11
        END IF
      ELSE
        IPOS2=1
        IPOS12=12
      END IF
C
C  First, check for an exact match on a key word, or match
C  with an added 's'
C
      DO 20 I=1,NKEY
      CALL CMATCH(CARD(IPOS2:IPOS12),IPOS2,IPOS12,KEYWRD(I),
     . 12,IPOS,1)
      IF(IPOS.GT.0) THEN
        IKEY=I
        CALL NBFIND(CARD(IPOS:256),IPOS,256,IPNT)
        GO TO 90
      ELSE
        CALL CMATCH(CARD(IPOS2:IPOS12),IPOS2,IPOS12,KEYWRD(I),
     .    12,IPOS,2)
        IF(IPOS.GT.0) THEN
          IF((CARD(IPOS:IPOS).EQ.'S'.OR.CARD(IPOS:IPOS).EQ.'s').AND.
     .      CARD(IPOS+1:IPOS+1).EQ.' ') THEN
            IKEY=I
            IPOS=IPOS+1
            CALL NBFIND(CARD(IPOS:256),IPOS,256,IPNT)
            GO TO 90
          END IF
        END IF
      END IF
   20 CONTINUE
C
C  If no exact match, check for a shortening of a key word, which
C  is acceptable only if it is unambiguous.
C
C  First, determine where the abbreviation in CARD(IPOS2:IPOS12) ends
C
      DO 22 I=IPOS2,IPOS12
      IF(CARD(I:I).EQ.' ')GO TO 23
   22 CONTINUE
      GO TO 24
   23 CONTINUE
      IPOS12=I-1
   24 CONTINUE
      ILEN=IPOS12-IPOS2+1
C
C  Now loop over key words, finding how many key words the abbreviation
C  matches.
C
 
      NMATCH=0
      IF(ILEN.GT.0) THEN
        DO 30 I=1,NKEY
        CALL CMATCH(CARD(IPOS2:IPOS12),IPOS2,IPOS12,KEYWRD(I),
     .   ILEN,IPOS,2)
        IF(IPOS.EQ.IPOS12+1) THEN
          NMATCH=NMATCH+1
          IF(NMATCH.GE.2) THEN
            IF(NMATCH.EQ.2) THEN
              CALL CRDPRN(2)
              WRITE(U6,201)
              WRITE(U6,202)KEYWRD(IKEY)
            END IF
            WRITE(U6,202)KEYWRD(I)
          END IF
          IKEY=I
          CALL NBFIND(CARD(IPOS:256),IPOS,256,IPNT)
        END IF
   30   CONTINUE
      END IF
      IF(NMATCH.EQ.0) THEN
        CALL CRDPRN(2)
        WRITE(U6,203)
        CALL FPSTOP(160045,IPOS2)
      ELSE IF(NMATCH.GE.2) THEN
        CALL FPSTOP(160045,IPOS2)
      END IF
   90 CONTINUE
      RETURN
      END
C
      SUBROUTINE KYFND2(IGROUP,IKEY,IPNT)
C
      INTEGER IGROUP,IKEY,IPNT
C
C  IGROUP - key word group.
C  IKEY   - code for key word
C           = -1 if _ not followed by a key word
C  IPNT   - IPNT first nonblank character after key word
C
C  Returns in IKEY the number of the keyword matching the first columns
C  of CARD, and in IPNT the first nonblank column after the
C  keyword.  A final 's' at the end of the keyword is accepted.
C  If an exact match is not found, a check will be made for an
C  unambiguous shortening.  A fatal error occurs if no match is found.
C
      PARAMETER (NKEY0=14,NKEY1=19,NKEY2=16,NKEY3=45,NKEY4=6,NKEY5=12)
      PARAMETER (NKEY6=9,NKEY7=28,NKEY8=12,NKEY9=15)
      PARAMETER (NKEY1B=NKEY0+1,NKEY1E=NKEY0+NKEY1)
      PARAMETER (NKEY2B=NKEY1E+1,NKEY2E=NKEY1E+NKEY2)
      PARAMETER (NKEY3B=NKEY2E+1,NKEY3E=NKEY2E+NKEY3)
      PARAMETER (NKEY4B=NKEY3E+1,NKEY4E=NKEY3E+NKEY4)
      PARAMETER (NKEY5B=NKEY4E+1,NKEY5E=NKEY4E+NKEY5)
      PARAMETER (NKEY6B=NKEY5E+1,NKEY6E=NKEY5E+NKEY6)
      PARAMETER (NKEY7B=NKEY6E+1,NKEY7E=NKEY6E+NKEY7)
      PARAMETER (NKEY8B=NKEY7E+1,NKEY8E=NKEY7E+NKEY8)
      PARAMETER (NKEY9B=NKEY8E+1,NKEY9E=NKEY8E+NKEY9)
      CHARACTER*12 KYWRD2(NKEY9E)
      COMMON /KYBLK2/KYWRD2
      INTEGER KEYGR1(NKEY9),KEYGR2(NKEY9)
      COMMON /KYBLK3/KEYGR1,KEYGR2
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      CHARACTER*256 CARD
      COMMON /CRDBLK/ CARD
C
  100 FORMAT(' _')
  201 FORMAT(' AMBIGUOUS KEY WORD - POSSIBLE:')
  202 FORMAT(5X,A12)
  203 FORMAT(' UNMATCHED KEY WORD')
C
      IGROUP=0
      IKEY=0
C
C  If position 1 contains _, then find beginning of key word
C
      IF(CARD(1:1).EQ.'_') THEN
        IPOS=2
        CALL NBFIND(CARD(IPOS:256),IPOS,256,IPOS2)
        IF(IPOS2.EQ.0) THEN
          IF(U5ECHO.EQ.1)WRITE(U6,100)
          CALL NBFND2(IPOS,IPOS2)
        END IF
        IF(IPOS2.EQ.0) THEN
C
C  Return -1 if key word not found
C
          IKEY=-1
          IPNT=0
          GO TO 90
        ELSE
          IPOS12=IPOS2+11
        END IF
      ELSE
        IPOS2=1
        IPOS12=12
      END IF
C
C  First, check for an exact match on a key word, or match
C  with an added 's'
C
      DO 20 I=1,NKEY9E
      CALL CMATCH(CARD(IPOS2:IPOS12),IPOS2,IPOS12,KYWRD2(I),
     . 12,IPOS,1)
      IF(IPOS.GT.0) THEN
        IKEY=I
        CALL NBFIND(CARD(IPOS:256),IPOS,256,IPNT)
        GO TO 80
      ELSE
        CALL CMATCH(CARD(IPOS2:IPOS12),IPOS2,IPOS12,KYWRD2(I),
     .    12,IPOS,2)
        IF(IPOS.GT.0) THEN
          IF((CARD(IPOS:IPOS).EQ.'S'.OR.CARD(IPOS:IPOS).EQ.'s').AND.
     .      CARD(IPOS+1:IPOS+1).EQ.' ') THEN
            IKEY=I
            IPOS=IPOS+1
            CALL NBFIND(CARD(IPOS:256),IPOS,256,IPNT)
            GO TO 80
          END IF
        END IF
      END IF
   20 CONTINUE
C
C  If no exact match, check for a shortening of a key word, which
C  is acceptable only if it is unambiguous.
C
C  First, determine where the abbreviation in CARD(IPOS2:IPOS12) ends
C
      DO 22 I=IPOS2,IPOS12
      IF(CARD(I:I).EQ.' ')GO TO 23
   22 CONTINUE
      GO TO 24
   23 CONTINUE
      IPOS12=I-1
   24 CONTINUE
      ILEN=IPOS12-IPOS2+1
C
C  Now loop over key words, finding how many key words the abbreviation
C  matches.
C
      NMATCH=0
      IF(ILEN.GT.0) THEN
        DO 30 I=1,NKEY9E
        CALL CMATCH(CARD(IPOS2:IPOS12),IPOS2,IPOS12,KYWRD2(I),
     .   ILEN,IPOS,2)
        IF(IPOS.EQ.IPOS12+1) THEN
          NMATCH=NMATCH+1
          IF(NMATCH.GE.2) THEN
            IF(NMATCH.EQ.2) THEN
              CALL CRDPRN(2)
              WRITE(U6,201)
              WRITE(U6,202)KYWRD2(IKEY)
            END IF
            WRITE(U6,202)KYWRD2(I)
          END IF
          IKEY=I
          CALL NBFIND(CARD(IPOS:256),IPOS,256,IPNT)
        END IF
   30   CONTINUE
      END IF
      IF(NMATCH.EQ.0) THEN
        CALL CRDPRN(2)
        WRITE(U6,203)
        CALL FPSTOP(160045,IPOS2)
      ELSE IF(NMATCH.GE.2) THEN
        CALL FPSTOP(160045,IPOS2)
      END IF
C
C  Recode IKEY into IGROUP, IKEY
C
   80 CONTINUE
      IF(IKEY.LE.NKEY0) THEN
        IGROUP=0
      ELSE IF(IKEY.LE.NKEY1E) THEN
        IGROUP=1
        IKEY=IKEY-NKEY0
      ELSE IF(IKEY.LE.NKEY2E) THEN
        IGROUP=2
        IKEY=IKEY-NKEY1E
      ELSE IF(IKEY.LE.NKEY3E) THEN
        IGROUP=3
        IKEY=IKEY-NKEY2E
      ELSE IF(IKEY.LE.NKEY4E) THEN
        IGROUP=4
        IKEY=IKEY-NKEY3E
      ELSE IF(IKEY.LE.NKEY5E) THEN
        IGROUP=5
        IKEY=IKEY-NKEY4E
      ELSE IF(IKEY.LE.NKEY6E) THEN
        IGROUP=6
        IKEY=IKEY-NKEY5E
      ELSE IF(IKEY.LE.NKEY7E) THEN
        IGROUP=7
        IKEY=IKEY-NKEY6E
      ELSE IF(IKEY.LE.NKEY8E) THEN
        IGROUP=8
        IKEY=IKEY-NKEY7E
      ELSE
        I=IKEY-NKEY8E
        IGROUP=KEYGR1(I)
        IKEY=KEYGR2(I)
      END IF
   90 CONTINUE
      RETURN
      END
C
      SUBROUTINE LASTCI(ILAST)
C
      INTEGER ILAST
C
C  ILAST - the last nonblank character in CARDIM.
C
      CHARACTER*256 CARDWK,CARDSV,CARDIM
      COMMON /CMBLK2/CARDWK,CARDSV,CARDIM
      DO 1 I=256,1,-1
      IF(CARDIM(I:I).NE.' ')GO TO 2
    1 CONTINUE
      ILAST=0
      GO TO 3
    2 CONTINUE
      ILAST=I
    3 CONTINUE
      RETURN
      END
C
      SUBROUTINE LASTCR(ILAST)
C
      INTEGER ILAST
C
C  ILAST - the last nonblank character in CARD.
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
      DO 1 I=256,1,-1
      IF(CARD(I:I).NE.' ')GO TO 2
    1 CONTINUE
      ILAST=0
      GO TO 3
    2 CONTINUE
      ILAST=I
    3 CONTINUE
      RETURN
      END
C
      SUBROUTINE LEVELD(LABEL,NLABEL)
C
      INTEGER NLABEL
      CHARACTER*24 LABEL(NLABEL)
C
C  LABEL  - array  labels
C  NLABEL - number of labels
C
C  Reviews the labels in LABEL and inserts a default label where blank.
C
  201 FORMAT('Level',I2)
  202 FORMAT('Level',I3)
  203 FORMAT('Level',I5)
  204 FORMAT('Level',I8)
C
      DO 10 L=1,NLABEL
      DO 2 I=1,24
      IF(LABEL(L)(I:I).NE.' ')GO TO 10
    2 CONTINUE
      IF(NLABEL.LE.9) THEN
        WRITE(LABEL(L),201)L
      ELSE IF(NLABEL.LE.99) THEN
        WRITE(LABEL(L),202)L
      ELSE IF(NLABEL.LE.9999) THEN
        WRITE(LABEL(L),203)L
      ELSE
        WRITE(LABEL(L),204)L
      END IF
   10 CONTINUE
      RETURN
      END
C
      SUBROUTINE LEVELR(BASE,IPOS,N,LABEL,MLABEL)
C
      INTEGER BASE,IPOS,N,MLABEL
      CHARACTER*24 LABEL(MLABEL)
C
C  BASE   - starting position in CARD to scan
C  IPOS   - next position beyond labels
C           0 - end of continuation lines
C  N      - number of labels returned
C  LABEL  - array into which to store labels
C  MLABEL - maximum number of labels to accept
C
C  Returns N as number of entries in LABEL returned, up to MLABEL
C  Continues scanning even after LABEL is full.
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/ CARD
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      LOGICAL REFRSH
      EXTERNAL REFRSH
C
C 100 FORMAT(' UNBALANCED APOSTROPHIES ON LINE')
C
C 101 FORMAT(' MORE LABELS THAN EXPECTED')
C
C  ISWTCH - toggle to indicate whether information is enclosed in
C           apostrophes.
C
      ISWTCH=0
      N=0
    5 CONTINUE
      I=BASE-1
   10 CONTINUE
      I=I+1
C
C  If at end of command line
C
      IF(I.GT.256) THEN
        IF(ISWTCH.EQ.1) THEN
          CALL FESTOP(160050)
        ELSE IF(.NOT.REFRSH(BASE)) THEN
          IPOS=0
          IF(N.GT.MLABEL)N=MLABEL
          RETURN
        ELSE
          GO TO 5
        END IF
      END IF
C
C  If not now within the range of apostropes.
C
      IF(ISWTCH.EQ.0) THEN
        IF(CARD(I:I).EQ.'''') THEN
          ISWTCH=1
          L=0
          N=N+1
C
C  Only blanks and commas expected between labels, otherwise
C  return
C
        ELSE IF(CARD(I:I).NE.' '.AND.CARD(I:I).NE.',') THEN
          IPOS=I
          IF(N.GT.MLABEL)N=MLABEL
          RETURN
        END IF
      ELSE
C
C  If within range of apostrophe, first check for second apostrophe
C
        IF(CARD(I:I).EQ.'''') THEN
          IF(I.LT.256) THEN
C
C  Check whether adjacent apostrophes should be translated into a
C  single apostrophe within the label.
C
            IF(CARD(I+1:I+1).EQ.'''') THEN
              L=L+1
              IF(L.LE.24.AND.N.LE.MLABEL)LABEL(N)(L:L)=CARD(I:I)
              I=I+1
              GO TO 10
            END IF
          END IF
C
C  At end of current label.
C
          ISWTCH=0
          IF(L.LT.24.AND.N.LE.MLABEL) THEN
            DO 24 J=L+1,24
            LABEL(N)(J:J)=' '
   24       CONTINUE
          END IF
        ELSE
C
C  Storage of character into label.
C
          L=L+1
          IF(L.LE.24.AND.N.LE.MLABEL)LABEL(N)(L:L)=CARD(I:I)
        END IF
      END IF
      GO TO 10
      END
C
      SUBROUTINE NBFIND(C,BASE,TOP,IPOS)
C
      INTEGER BASE,TOP,IPOS
      CHARACTER*(*) C
C
C  C    - string to search
C  BASE - starting position in C to search
C  TOP  - ending position to search
C         Note: call is of form NBFIND(C(BASE:TOP),BASE,TOP,...
C  IPOS - next nonblank character (as numbered in calling program)
C         0 all blanks.
C
      IPOS=0
      IPT=0
      LEN=TOP-BASE+1
   10 CONTINUE
      IPT=IPT+1
      IF(IPT.GT.LEN) RETURN
      IF(C(IPT:IPT).EQ.' ') GO TO 10
      IPOS=IPT+BASE-1
      RETURN
      END
C
      SUBROUTINE NBFND2(BASE,IPOS)
C
C  BASE - starting position in CARD to search.
C         It will be reset to 1 if additional lines have been read.
C  IPOS - next nonblank character (as numbered in calling program)
C         0 no more continuation lines
C
C  Finds next nonblank character, IPOS is nonblank position
C  0 otherwise
C  NBFND2 is specific to the search of command lines, and will
C  initiate the reading of additional lines through REFRSH
C
      INTEGER BASE,IPOS
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/ CARD
      LOGICAL REFRSH
      EXTERNAL REFRSH
C
      IPOS=0
      IF(BASE.GT.256.OR.BASE.EQ.0) THEN
        IF(.NOT.REFRSH(BASE))GO TO 30
      END IF
   10 CONTINUE
      DO 20 IPT=BASE,256
      IF(CARD(IPT:IPT).NE.' ') THEN
        IPOS=IPT
        GO TO 30
      END IF
   20 CONTINUE
      IF(REFRSH(BASE))GO TO 10
   30 CONTINUE
      RETURN
      END
C
      SUBROUTINE OPTNTR(NOPTN,INDX,IVALUE,OPTNW,BASE,IPOS,IOPTN)
C
      INTEGER NOPTN,BASE,IPOS,IOPTN(*)
      INTEGER INDX(NOPTN)
      INTEGER IVALUE(NOPTN)
      CHARACTER*12 OPTNW(NOPTN)
      PARAMETER (MAXKWL=24)
      CHARACTER*(MAXKWL) KEYWRD
      CHARACTER*12 VNKEYW(1)
C
C  Subroutine to read options of the form
C     OPTION1 , OPTION2 = VALUE2
C  where VALUE2 is an integer, etc.
C
C  NOPTN  - number of posible options to search
C  INDX   - pointer mapping options in OPTNW to places in IVALUE
C           to receive the result
C  IVALUE - value if key word appears by itself without =
C  OPTNW  - option key words to look for
C  BASE   - location in CARD to begin search
C           reset to 1 if new card read
C  IPOS   - ending position, 0 if no more continuation lines.
C  IOPTN  -
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/ CARD
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      LOGICAL REFRSH
      EXTERNAL REFRSH
C
  100 FORMAT(/,5X,'UNMATCHED OPTION: ',A12)
C
      IPT=BASE
    1 CONTINUE
C
C  Call EQSCAN to find out how much of keyword = value
C  appears
C
      CALL EQSCAN(IPT,IPOS,KEYWRD,IFLAG)
C
C  If new line has been read, reset BASE
C
      IF(IPT.EQ.1)BASE=1
C
C  EQSCAN returns 1 for keyword =
C                 2 for keyword followed by a character other than =
C
      IF(IFLAG.EQ.1.OR.IFLAG.EQ.2) THEN
        VNKEYW(1)=KEYWRD(1:12)
        DO 3 J=1,NOPTN
        CALL VNMTCH(OPTNW(J),VNKEYW,1,IPOS2)
        IF(IPOS2.GT.0) THEN
C
C  If keyword matches, initialize from IVALUE
C
          IOPTN(INDX(J))=IVALUE(J)
          IF(IFLAG.EQ.1) THEN
            CALL IFIND(CARD(IPOS:256),IPOS,256,IPT,IVAL)
            IF(IPT.GT.0) THEN
              IOPTN(INDX(J))=IVAL
              IPOS=IPT
            ELSE
              IF(U5.GE.13.AND.U5.LE.17) THEN
                IMERR1=160055
                RETURN
              ELSE
                CALL FPSTOP(160055,IPOS)
              END IF
            END IF
          ELSE
            IPT=IPOS
          END IF
          GO TO 5
        END IF
    3   CONTINUE
C
C  If no match, print message and treat as nonfatal error.
C
        WRITE(U6,100)VNKEYW(1)
        IF(IFLAG.EQ.1) THEN
          CALL IFIND(CARD(IPOS:256),IPOS,256,IPT,IVAL)
          IF(IPT.GT.0) THEN
            IPOS=IPT
          ELSE
            IF(U5.GE.13.AND.U5.LE.17) THEN
              IMERR1=160055
              RETURN
            ELSE
              CALL FPSTOP(160055,IPOS)
            END IF
          END IF
        ELSE
          IPT=IPOS
        END IF
    5   CONTINUE
        IF(IPT.GT.256) THEN
          IF(.NOT.REFRSH(BASE)) RETURN
          IPT=1
        END IF
        IF(IPT.GT.0)GO TO 1
      END IF
      RETURN
      END
C
      LOGICAL FUNCTION REFRSH(BASE)
C
      INTEGER BASE
C
C  BASE - reset to 1
C
C  Refreshes CARD by reading the next record.
C  U5END is set to 1 on end of primary file.
C
C  Returns TRUE unless end of file or first character is
C  alphanumeric or _, that is, TRUE indicates that the new record
C  is a continuation line.
C
C  REFRSH returns FALSE on end of file on the original U5 (while
C  implementing any INCLUDEs) or when the line appears
C  to begin a command line.
C
C  Entirely blank records are simply printed and the next record is
C  read.  Consequently, the routine returns with either a nonblank
C  record or U5END = 1.
C
C  Several accommodations have been made to the new syntax, where
C  CMPFLG = 1 or U5 may be a scratch file on units 13-17
C
C  REFRSH handles:
C    COMMENT and C
C    ECHO
C    ERRORFILE
C    INCLUDE
C    IGNORE and IGNORE OFF
C    LONGCOMMENT and LONGCOMMENT OFF
C    MACROWRITE and MACROEND
C    SCRATCH1 - SCRATCH7, SCRATCHSTEM
C    SET
C    MACROIMPLEMENT and MACROIMPLEMENTEND
C  and subsequent command lines associated with processing these
C  features.  The calling routine does not have to be concerned
C  with them.
C
C  12/97  REFRSH also implements the /* comment */ syntax, keeping
C  track of the number of /*'s encountered.
C
C  CARDIN - holds the command line as read.
C  CARDIM - (intermediate) holds the line with all the resulting
C           substitutions implemented, including /* comments */
C           and ! comments.  CRDPRN prints CARDIN and CARDIM (if
C           different).
C  CARD   - the command line to be interpreted, with comments removed
C
C  At the end of an INCLUDEd file, REFRSH also switches the input file
C  in the stack to the calling INCLUDEd file or primary input file.
C  Consequently, RETURN occurs to the calling routine when the next
C  record to be processed normally has been read, or on end of file
C  for the input stream.
C
      PARAMETER (MAXSUB=500,MAXSBL=2000,MAXSNL=24)
      PARAMETER (MAXSBC=6000)
      PARAMETER (MAXFMT=20)
      PARAMETER (MAXALT=5)
      PARAMETER (MSIZED=1000000)
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL),
     .   U5LCSW
      COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER U5ALT(MAXALT),U5ASTT(MAXALT)
      CHARACTER *80 U5LINE(MAXALT)
      COMMON /A5BLCK/U5ALT,U5ASTT
      COMMON /U5LBLK/U5LINE
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
      CHARACTER*80 CARDIN
      CHARACTER*(MAXSNL) SUBNAM(MAXSUB)
      CHARACTER*12 SUBCSV(MAXSBC)
      COMMON /CINBLK/CARDIN,SUBNAM,SUBCSV
      LOGICAL ALPCHK,DGTCHK
      EXTERNAL ALPCHK,DGTCHK
      LOGICAL MACROI,FOPEND
      INTEGER IFLAGI(3),ITYPEI(3)
C
      CHARACTER*160 FNERRR,FNWARN
      COMMON /IOBLK3/FNERRR,FNWARN
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
      CHARACTER*256 CARDWK,CARDSV,CARDIM
      COMMON /CMBLK2/CARDWK,CARDSV,CARDIM
C
      CHARACTER*1 C,A(31)
      CHARACTER*6 LFMT
      CHARACTER*176 OVERFL
C
C  The data statement contains all of the ASCII characters that VPLX
C  will recognize, in addition to letters and digits.  This form is
C  used with Microsoft PowerStation for the PC, and VAX, among others.
C
C     DATA A/'$','?','!','"','#','%','&','(',')','*',
C    .       '+',',','-','.','/',':',';','<','=','>',
C    .       '?','@','[','\',']','^','{','}','|','~','`'/
C
C  Special form for SUN OS and UNIX generally to handle \.
C  A single \ is interpreted as an escape character, so \\ is
C  required in the DATA statement.
C
      DATA A/'$','?','!','"','#','%','&','(',')','*',
     .       '+',',','-','.','/',':',';','<','=','>',
     .       '?','@','[','\\',']','^','{','}','|','~','`'/
C
C
  100 FORMAT(A80,A176)
  101 FORMAT(1X,A79)
  102 FORMAT(1X,A80)
  103 FORMAT(1X)
  107 FORMAT('(A',I1,')')
  108 FORMAT('(A',I2,')')
  109 FORMAT(I1,'.tmp')
  200 FORMAT(5X,'WARNING - UNEXPECTED CHARACTER(S) CONVERTED TO BLANK IN
     . THE NEXT RECORD')
  202 FORMAT(' TOO MANY LEVELS, MAXIMUM=',I2)
  203 FORMAT(' UNSUCCESSFUL SUBSTITUTION')
  204 FORMAT(' WARNING: UNBALANCED OFF')
  205 FORMAT(' SET ERROR')
  206 FORMAT(' RESOURCE CONSTRAINT')
  207 FORMAT(' INCLUDE FAILED')
C
      ISTAT=0
      REFRSH=.FALSE.
      BASE=1
      ISBFLG=0
C
C  MACROIMPLEMENT 3/97
C  Always set MACROI to FALSE when REFRSH is called.
C
      MACROI=.FALSE.
C
C  Just in case, RETURN if already at end-of-file
C
      IF(U5END.EQ.1)THEN
        IF(U5.GE.13.AND.U5.LE.17) THEN
          GO TO 90
        ELSE
          IF(MACROI) THEN
            CLOSE(UNIT=MACROF)
          END IF
          RETURN
        END IF
      END IF
C
C  ISTAT = 0  normal reading of input stream
C          1  LONGCOMMENT
C          2  IGNORE
C          3  COMMENT
C          4  SET
C          5  INCLUDE
C          6  SCRATCH, SCRATCHSTEM
C          7  MACROWRITE statement
C          8  ON statement
C          9  ERRORFILE
C         10  MACROIMPLEMENT statement
C
C  LEVEL keeps track of the nesting of IGNORE, and LONGCOMMENT
C
C  ISSLVL keeps track of the net balance between /* and */
C
C  U5LCSW is initialized to 1 in the main program to VPLX.
C  REFRSH sets it to 2 on reading any line that may contain file names,
C  such as the beginning of a step.  When U5LCSW=2, it will be set
C  to 3 here when all associated records with the filename(s) have been
C  read.  It is set =4 when the end of file is reached while reading
C  a file name.
C  When REFRSH is called with U5LCSW=3, it is reset to 1.
C
C
C  The logic for SET and substitutions is complex.  The following
C  descriptions are repeated later in the subroutine:
C
C  Variables and arrays used by SET and substitutions:
C
C  NSUB   - the number of assigned substitution strings
C  NSUBLM - the number of assigned lines
C  NSUBCM - the number of assigned elements of the character array
C  ISUBCN - ISUB for a substitution string with continuation lines,
C           while in use.
C  ICHCNT - holds current position in line in case of substitution
C           of multi-line strings.
C  CININI - 1 - a line has just been read from the input file
C           0 - this is a continuation line.
C  NSUBLN - number of lines for the substitution string.
C  IPTSBL - pointer from ISUB to the first line of substitution.
C  NSBCHR - number of characters in the substitution line
C  IPTSBC - pointer from ILINE to the first element of character
C           array for the line.
C  U5LCSW - switch to control flow when step or subroutine referencing
C           file names encountered.
C
C  The main routine begins a VPLX run with the following
C  initializations related to substitutions connected with SET:
C
C     NSUB=0
C     NSUBLM=0
C     NSUBCM=0
C     ISUBCN=0
C     ILNCNT=0
C     ICHCNT=0
C     U5LCSW=1
C     ISTAT=0
C     LEVEL=0
C
    1 CONTINUE
C
C  First, fill the end of CARDIM with blanks, if substitutions are
C  possible.
C
      IF(NSUB.GT.0) THEN
        CALL STBLNK(CARDIM,81,256)
      END IF
C
C  Next, determine if should read from input file or from the
C  continuation of a multi-line substitution.
C
C  If U5LCSW is 3, may now reset U5LCSW to 1 and begin to process
C  string held in CARD since previous call.
C
      IF(U5LCSW.EQ.3) THEN
        U5LCSW=1
C
C  If U5LCSW is 4, INCLUDED file ended with a statement including a
C  file name (although not an INCLUDE statement).  Control has been
C  returned to the calling program already to conclude processing of
C  filename.  At this point, must transfer to 90 to handle end of
C  the INCLUDEd file.
C
      ELSE IF(U5LCSW.EQ.4) THEN
C                                             ! Open new file (delayed
        U5LCSW=1
C                                             ! until file name
        GO TO 90
C                                             ! processing completed
      ELSE IF(ISUBCN.GT.0) THEN
C
C  Copy continuation lines of multi-line substitution here.
C  Multiline substitutions occur when a SET statement equates
C  a name to two or more lines.
C
C  CININI is passed to CRDPRN to identify substitution continuation
C         lines.  The variable is usually 1 but is zero for substitution
C         lines.
C  ILNCNT is the count of continuation lines processed.
C  ICHCNT saves the position of the next character from the initial
C       input line to be interpreted after the completion of a
C       multiline substitution.
C
        CININI=0
        IF(ILNCNT.LT.NSUBLN(ISUBCN)) THEN
C
C  Continuation line copied into CARDIM here.
C
          ILINE=IPTSBL(ISUBCN)+ILNCNT
          JJ=IPTSBC(ILINE)
          DO 4 J=1,NSBCHR(ILINE),12
          CARDIM(J:J+11)=SUBCSV(JJ)
          JJ=JJ+1
    4     CONTINUE
          IF(NSBCHR(ILINE).LT.80) THEN
            DO 5 J=NSBCHR(ILINE)+1,80
            CARDIM(J:J)=' '
    5       CONTINUE
          END IF
C
C  Increment ILNCNT here, to reflect number of line just added.
C
          ILNCNT=ILNCNT+1
        ELSE
C
C  If, after multi-line substitution, copy the remaining contents
C  of CARDIN, if present.  Set ILNCNT=0 and ISUBCN=0 to prevent
C  coming through this loop again, unless another multi-line
C  substitution is initiated.
C
          ISUBCN=0
          ILNCNT=0
          DO 6 J=1,ICHCNT-1
          CARDIM(J:J)=' '
    6     CONTINUE
          CARDIM(ICHCNT:80)=CARDIN(ICHCNT:80)
        END IF
      ELSE
C
C  Reading of record from input file.  This is the normal circumstance.
C
        CININI=1
        IF(U5.GE.13.AND.U5.LE.17) THEN
          READ(U5,END=90)CARDIM
          LNCNTR=LNCNTR+1
        ELSE
          READ(U5,100,END=90)CARDIN,OVERFL
          CALL NBFIND(OVERFL,1,20,IPOS)
          IF(IPOS.GT.0) THEN
            IF(CMPFLG.EQ.1) THEN
              IMERR1=160117
              RETURN
            ELSE
              CALL FESTOP(160117)
            END IF
          END IF
          CARDIM(1:80)=CARDIN
        END IF
      END IF
C
C  If currently in process of reading lines that may contain file
C  names, (when U5LCSW=2), stop reading lines and hold them in CARD,
C  if encounter nonblank position 1.  (Except for MACROI.)
C  Note that, in a sense, the RETURN occurs prematurely, for
C  example, no substitutions will have been made yet for substitution
C  strings in CARD.  After the calling routine completes the process of
C  opening files, the calling routine must call REFRSH again to
C  complete the processing of CARD.
C
C  This complex logic arises to ensure that all file processing is
C  completed before attempting to process CARDIM, which itself may
C  contain file references, e.g., when it has INCLUDE.
C
      IF(U5LCSW.EQ.2) THEN
        IF(CARDIM(1:1).NE.' ') THEN
          IF(ISUBCN.GT.0) THEN
C
C  If continuation line of substitution continues beyond file name,
C  the logic is in trouble - generate error.
C
            WRITE(U6,207)
            IF(CMPFLG.EQ.1) THEN
              IMERR1=160100
              RETURN
            ELSE
              CALL FESTOP(160100)
            END IF
          ELSE
C
C  Return here if at end of file specification but next line continues
C  a command.  Calling routine should complete all decisions based on
C  the file name before calling REFRSH again.
C
            U5LCSW=3
            RETURN
          END IF
        END IF
      END IF
    7 CONTINUE
C
C  For INCLUDE, MACROWRITE, and MACROIMPLEMENT, check if file name
C  appears to have been read.  All three skip to 37 to avoid
C  implementing substitutions on next card:
C  INCLUDE - the INCLUDED file may contain SET statements with
C            consequences for CARD
C  MACROWRITE - the contents of CARD should be written without
C            implementing substitutions.
C  MACROIMPLEMENT - should go to special MACROIMPLEMENT processing
C
      IF(ISTAT.EQ.5.OR.ISTAT.EQ.7.OR.ISTAT.EQ.10) THEN
        IF(ICLEND.EQ.1) THEN
          GO TO 37
        ELSE IF(CARDIM(1:1).NE.' '.OR.IFLAGI(1).GT.0) THEN
          ICLEND=1
          GO TO 37
C
C  If have read a complete file name (IFNAME=1), but have not yet
C  begun to read file parameters initiated by '(', then stop scanning
C  if next nonblank character is not '('
C
        ELSE IF(IFNAME.EQ.1.AND.IFPSW.EQ.1) THEN
          CALL NBFIND(CARDIM(1:256),1,256,IPOS)
          IF(IPOS.GT.0) THEN
            IF(CARDIM(IPOS:IPOS).NE.'(') THEN
              ICLEND=1
              GO TO 37
            END IF
          END IF
        END IF
      END IF
      ICLEND=0
      IFLAG=0
      IAPOST=0
C
C  Find last nonblank character in CARDIM.  ILAST will be used
C  repeatedly to avoid repeated unnecessary scans through 240
c  characters in CARDIM.
C
      CALL LASTCI(ILAST)
C
C  Loop to fill in substitution strings if ISUBCN = 0, that is,
C  if not already inside a multi-line substitution.
C
      IONFLG=0
      IF(ISUBCN.EQ.0) THEN
        J=1
        ICHCNT=1
    8   CONTINUE
        IF(CARDIM(J:J).EQ.'&') THEN
          JJ=J+1
          IF(ALPCHK(CARDIM(JJ:JJ))) THEN
            JJ=JJ+1
   10       CONTINUE
            IF(ALPCHK(CARDIM(JJ:JJ)).OR.DGTCHK(CARDIM(JJ:JJ)).OR.
     .         CARDIM(JJ:JJ).EQ.'.') THEN
              IF(JJ.LE.J+MAXSNL) THEN
                JJ=JJ+1
                GO TO 10
              END IF
            ELSE IF(CARDIM(JJ:JJ).EQ.'&') THEN
C
C  Arrive here if CARDIM(J:JJ) contains &stringname&
C  Check to see if name has already appeared.
C
              IF(NSUB.GT.0) THEN
                ILEN=JJ-J-1
                DO 22 I=1,NSUB
                CALL CMATCH(SUBNAM(I),1,MAXSNL,CARDIM(J+1:JJ-1),ILEN,
     .                      IPOS2,1)
                IF(IPOS2.GT.0) THEN
C
C  Successful match
C
                  ILINE=IPTSBL(I)
                  N=NSBCHR(ILINE)
                  II=IPTSBC(ILINE)
                  ICHCNT=ICHCNT+ILEN+1
C
C  First, shift the contents of CARDIM to make room for substitution.
C
                  IDIF=N-ILEN-2
                  IF(IDIF.GT.0.AND.JJ.LT.ILAST) THEN
                    IF(ILAST+IDIF.GT.240) THEN
                      CALL CRDPRN(2)
                      WRITE(U6,203)
                      IF(CMPFLG.EQ.1) THEN
                        IMERR1=160101
                        RETURN
                      ELSE
                        CALL FESTOP(160101)
                      END IF
                    END IF
                    DO 12 K=ILAST,JJ+1,-1
                    CARDIM(K+IDIF:K+IDIF)=CARDIM(K:K)
   12               CONTINUE
                  ELSE IF(IDIF.LT.0) THEN
                    IF(JJ.LT.ILAST) THEN
                      DO 14 K=JJ+1,ILAST
                      CARDIM(K+IDIF:K+IDIF)=CARDIM(K:K)
   14                 CONTINUE
                    END IF
C
C  In this case, we must fill vacated space with blanks.
C
                    DO 15 K=-1,IDIF,-1
                    CARDIM(ILAST+1+K:ILAST+1+K)=' '
   15               CONTINUE
                  END IF
C
C  Update both ILAST and JJ to reflect length of substituted string.
C
                  ILAST=ILAST+IDIF
                  JJ=JJ+IDIF
C
C  Special check during MACROIMPLEMENT - is ON substituted
C  at the beginning of a line?
C
                  IF(MACROI) THEN
                    IF(N.EQ.2.AND.J.EQ.1) THEN
                      CALL CMATCH(SUBCSV(II),1,2,'ON',2,IONFLG,2)
                    END IF
                  END IF
C
C  Make the substitution here.
C
                  NFULL=N/12
                  IF(NFULL.GT.0) THEN
                    DO 16 K=1,NFULL
                    CARDIM(J:J+11)=SUBCSV(II)
                    J=J+12
                    II=II+1
   16               CONTINUE
                    N=N-NFULL*12
                  END IF
C
C  For residual, if any.
C
                  IF(N.GT.0) THEN
                    CARDIM(J:JJ)=SUBCSV(II)(1:N)
                  END IF
C
C  If substitution is single line, continue looping, else
C  store appropriate information for first line of multi-line
C  string.
C
                  IF(NSUBLN(I).EQ.1) THEN
                    J=JJ
                    GO TO 24
                  ELSE
                    ISUBCN=I
                    ILNCNT=1
C
C  At this point, store information on whether residual remains in
C  CARDIN, or whether multi-line substitution begins at end of line.
C
                    IF(JJ.GE.ILAST) THEN
                      ICHCNT=0
                    ELSE
                      ICHCNT=ICHCNT+1
                      DO 18 J=JJ+1,ILAST
                      CARDIM(J:J)=' '
   18                 CONTINUE
                    END IF
C
C  Since have now set ISUBCN > 0, skip to 33 avoids instructions
C  appropriate only for single lines.
C
                    GO TO 33
                  END IF
                END IF
   22           CONTINUE
              END IF
C
C  Arrive here if no stored substitutions, or if no match.  Except
C  under LONGCOMMENT, IGNORE, or COMMENT, this is a fatal error.
C
              IF(ISTAT.EQ.0.OR.ISTAT.GT.3) THEN
                IF(CARDIM(1:1).NE.' ') THEN
C
C  This code checks whether the current line is a COMMENT line.
C
                  K=1
                  IF(CARDIM(1:1).EQ.'_') THEN
                    CALL NBFIND(CARDIM(2:256),2,256,K)
                  END IF
                  CALL CMATCH(CARDIM(K:256),K,256,'COMM',4,KK,2)
                  IF(KK.EQ.0) THEN
                    CALL CMATCH(CARDIM(K:256),K,256,'C',1,KK,1)
                  END IF
                  IF(KK.GT.0) GO TO 24
                END IF
C
C  Error call for unsuccessful substitution.
C
                CALL CRDPRN(2)
                WRITE(U6,203)
                IF(CMPFLG.EQ.1) THEN
                  IF(NSUB.EQ.0) THEN
                    IMERR1=160103
                  ELSE
                    IMERR1=160102
                  END IF
                  IMERR2=J
                  RETURN
                ELSE
                  IF(NSUB.EQ.0) THEN
                    CALL FPSTOP(160103,J)
                  ELSE
                    CALL FPSTOP(160102,J)
                  END IF
                END IF
              END IF
   24         CONTINUE
            END IF
C
C  Convert && into & without making substitutions
C
          ELSE IF(CARDIM(JJ:JJ).EQ.'&') THEN
            DO 26 K=JJ,ILAST
            CARDIM(K:K)=CARDIM(K+1:K+1)
   26       CONTINUE
            ILAST=ILAST-1
            ICHCNT=ICHCNT+1
          END IF
        END IF
        J=J+1
        ICHCNT=ICHCNT+1
        IF(J.LT.ILAST)GO TO 8
C
C  If all substitutions successful to here, there is no residual in
C  CARDIN.
C
C  NLINE  - keeps track of records written to unit 13 from REFRSH, for
C           use with CMPFLG=1 (new syntax).
C  LNCNTR - relative counter of input lines from units 13-17.
C           It is often set to 0 or to a specific value in
C           another routine.
C
        ICHCNT=0
        IF(CMPFLG.EQ.1) THEN
          IF(CARDIN.NE.CARDIM(1:80).AND.ISTAT.NE.1.AND.ISTAT.NE.2) THEN
            CALL STBLNK(CARDWK,1,256)
            CALL ROOMD(2)
            IF(U5ENOW.GE.1) THEN
C                                      ! Here and elsewhere, when
              DX(NXPTD-2)=1
C                                      ! CMPFLG==1, store in DX(NXPTD-1)
              DX(NXPTD-1)=1
C                                      ! the effective value of u5echo
            ELSE
C                                      ! for later printing.
              DX(NXPTD-2)=0
C                                      ! For substituted line, print
              DX(NXPTD-1)=0
C                                      ! under ECHO and ECHO LITE
            END IF
            WRITE(13)CARDWK
            CARDWK(1:80)=CARDIN
            WRITE(13)CARDWK
            NLINE=NLINE+2
            ISBFLG=1
C                                      ! Flag to mark substitutions
          END IF
        END IF
      END IF
C
C  Beginning of multi-line substitutions have skipped to here.
C
   33 CONTINUE
C
C  If all lines have been substituted, and if there is no residual in
C  CARDIN, set ISUBCN=0 here, to read a new record into CARDIN at 1.
C
      IF(ISUBCN.GT.0) THEN
        IF(ILNCNT.EQ.NSUBLN(ISUBCN)) THEN
          IF(ICHCNT.EQ.0)ISUBCN=0
        END IF
      END IF
C
C  The loop to 40 is to check for non-ASCII characters
C  Change non-ASCII characters to blank, unless within apostrophies
C
   37 CONTINUE
      IAPOST=0
      IAPOS2=0
      IEXCLF=0
C                                           ! Beginning of ! comment
      IEXCL2=0
      I=1
      II=1
   38 CONTINUE
      C=CARDIM(I:I)
      IF(C.EQ.' ')GO TO 40
      IF(IAPOS2.EQ.1) THEN
        IF(C.EQ.'''') THEN
          IAPOS2=0
          GO TO 40
        END IF
      ELSE IF(IAPOS2.EQ.2) THEN
        IF(C.EQ.'"') THEN
          IAPOS2=0
          GO TO 40
        END IF
      ELSE IF(C.EQ.'''') THEN
        IF(IEXCL2.EQ.0) THEN
          IAPOS2=1
        END IF
        GO TO 40
      ELSE IF(C.EQ.'"'.AND.IEXCL2.EQ.0) THEN
        IAPOS2=2
        GO TO 40
      ELSE IF(C.EQ.'!') THEN
        IF(IEXCL2.EQ.0.AND.IAPOS2.EQ.0)IEXCL2=I
        GO TO 40
      END IF
      IF(IAPOS2.GT.0)GO TO 40
      IF(ALPCHK(C))GO TO 40
      IF(DGTCHK(C))GO TO 40
      DO 39 J=1,31
      IF(A(J).EQ.C)GO TO 40
   39 CONTINUE
C
C  Special check for Fortran PowerStation 1.0 - skip warning message
C  on end of file.
C
      IFLAG=1
      IF(I.EQ.1) THEN
        IF(ICHAR(C).EQ.26) THEN
          IFLAG=0
        END IF
      END IF
      CARDIM(I:I)=' '
      CARD(II:II)=' '
      C=' '
   40 CONTINUE
      IF(ISTAT.EQ.1.OR.ISTAT.EQ.2) THEN
C                                                ! LONGCOMMENT, IGNORE
        IF(IEXCL2.GT.0) THEN
          CARD(II:II)=' '
        ELSE
          CARD(II:II)=CARDIM(I:I)
        END IF
      ELSE
        IF(C.EQ.'/'.AND.I.LE.255) THEN
          IF(CARDIM(I+1:I+1).EQ.'*') THEN
C                                                ! check for /*
            IF(I.LE.253.AND.IEXCL2.EQ.0.AND.
C                                                ! check for /*/*
     .         IAPOS2.GT.0) THEN
              IF(CARDIM(I+2:I+3).EQ.'/*') THEN
                CARD(II:II+1)='/*'
                I=I+4
                II=II+2
                IF(I.LE.256) THEN
                  GO TO 38
                ELSE
                  GO TO 41
                END IF
              END IF
            END IF
            IF(ISTAT.NE.5) THEN
              ISSLVL=ISSLVL+1
            END IF
            CARD(II:II+1)='  '
            I=I+2
            II=II+2
            IF(I.LE.256) THEN
              GO TO 38
            ELSE
              GO TO 41
            END IF
          END IF
        ELSE IF(C.EQ.'*'.AND.I.LE.255) THEN
          IF(CARDIM(I+1:I+1).EQ.'/') THEN
C                                                ! check for */
            IF(I.LE.253.AND.IEXCL2.EQ.0.AND.
C                                                ! check for */*/
     .         IAPOS2.GT.0) THEN
              IF(CARDIM(I+2:I+3).EQ.'*/') THEN
                CARD(II:II+1)='*/'
                I=I+4
                II=II+2
                IF(I.LE.256) THEN
                  GO TO 38
                ELSE
                  GO TO 41
                END IF
              END IF
            END IF
            IF(ISSLVL.GT.0.AND.ISTAT.NE.5)ISSLVL=ISSLVL-1
            CARD(II:II+1)='  '
            I=I+2
            II=II+2
            IF(I.LE.256) THEN
              GO TO 38
            ELSE
              GO TO 41
            END IF
          END IF
        END IF
        IF(ISSLVL.GT.0.OR.IEXCLF.GT.0) THEN
          CARD(II:II)=' '
        ELSE
          CARD(II:II)=C
          IF(IAPOST.EQ.1.AND.C.EQ.'''') THEN
            IAPOST=0
          ELSE IF(IAPOST.EQ.2.AND.C.EQ.'"') THEN
            IAPOST=0
          ELSE IF(C.EQ.'''') THEN
            IAPOST=1
          ELSE IF(C.EQ.'"') THEN
            IAPOST=2
          ELSE IF(C.EQ.'!'.AND.IAPOST.EQ.0) THEN
            IEXCLF=II
            CARD(II:II)=' '
          END IF
        END IF
      END IF
      I=I+1
      II=II+1
      IF(I.LE.256) GO TO 38
   41 CONTINUE
      IF(II.LT.256) THEN
        II=II+1
        CALL STBLNK(CARD,II,256)
      END IF
      CALL LASTCR(ILAST)
      IF(ISTAT.EQ.1.OR.ISTAT.EQ.2) THEN
        IEXCLF=IEXCL2
      END IF
C
C  Warning message for non-ASCII characters.
C
      IF(IFLAG.EQ.1) THEN
        IF(CMPFLG.EQ.1) THEN
          CALL STBLNK(CARDWK,1,256)
          WRITE(CARDWK,200)
          WRITE(13)CARDWK
          NLINE=NLINE+1
          CALL ROOMD(1)
C                                 ! Print warning for non-ASCII
          DX(NXPTD-1)=U5ENOW
C                                 ! characters under ECHO
        ELSE
          WRITE(U6,200)
        END IF
      END IF
C
C  If the previous line was ON, reset ISTAT to 0.
C
      IF(ISTAT.EQ.8)ISTAT=0
C
C  Scan the image for ECHO, LONGCOMMENT, IGNORE, COMMENT, SET,
C  MACROWRITE, INCLUDE, ERRORFILE, MACROIMPLEMENT, and MACROIMPLEMENTEND
C
      IM=0
C
C  IM records a match for this line on:
C     1 = INCLUDE
C     2 = LONGCOMMENT (except within range of IGNORE)
C     3 = IGNORE (except within range of LONGCOMMENT)
C     4 = ECHO (except within range of IGNORE or LONGCOMMENT)
C     5 = SET (except within range of IGNORE or LONGCOMMENT)
C     6 = SCRATCH (except within range of IGNORE or LONGCOMMENT)
C     7 = MACROWRITE (except within range of IGNORE or LONGCOMMENT)
C     9 = ERRORFILE (except within the range of IGNORE or LONGCOMMENT)
C    10 = MACROIMPLEMENT
C    11 = MACROIMPLEMENTEND
C
C  A letter OR '_' in column 1 ends the range of COMMENT, SET,
C  INCLUDE, SCRATCH, or MACROWRITE.  ICLEND=1 if apparently at
C  end of the file name associated with INCLUDE or MACROWRITE.
C
      CALL NBFIND(CARDIM,1,256,IEXCLM)
C                                                  ! Determine if comment
      IF(IEXCLM.NE.IEXCLF) THEN
C                                                  ! line
        IEXCLM=0
      END IF
C
C  ISTAT = 0  normal reading of input stream
C          1  LONGCOMMENT
C          2  IGNORE
C          3  COMMENT
C          4  SET
C          5  INCLUDE
C          6  SCRATCH
C          7  MACROWRITE statement
C          8  ON statement
C          9  ERRORFILE
C         10  MACROIMPLEMENT statement
C
      IF(ALPCHK(CARD(1:1)).OR.ICLEND.EQ.1.OR.IEXCLM.NE.0) THEN
C
C  Just in case, however, save ISTAT in case it should be restored
C  after processing INCLUDE.
C
        IF(ICLEND.EQ.0)ISTTSV=ISTAT
        IF((ISTAT.EQ.3.AND.IEXCLM.EQ.0).OR.
C                                                          ! COMMENT
     .      ISTAT.EQ.4)ISTAT=0
C                                                          ! SET
C
C  Conclude processing of active INCLUDE statement.  Save the current
C  contents of CARDIN, which will be restored only after the INCLUDEd
C  file has been read.
C
        IF(ISTAT.EQ.5) THEN
C                                                        ! INCLUDE
          J=1
          IF(IPOSSC.EQ.0) THEN
C                                                        ! IPOSSC > 0
            CALL FNRD2(J,ITYPEI,IFLAGI,2,3,IFPSW,
C                                                        ! if ';' read
     .                 IFNAME,IPOSSC)
          END IF
          IF(IMERR1.GT.0) THEN
            IF(IMERR1.EQ.160316) THEN
              IMERR1=160104
            END IF
            RETURN
          ELSE IF(IFLAGI(1).EQ.0) THEN
            WRITE(U6,207)
            IF(CMPFLG.EQ.1) THEN
              IMERR1=160104
              RETURN
            ELSE
              CALL FESTOP(160104)
            END IF
          END IF
          IF(U5ALT(MAXALT).NE.0) THEN
            IF(U5ALT(MAXALT).NE.U5) THEN
              WRITE(U6,202)MAXALT
              IF(CMPFLG.EQ.1) THEN
                IMERR1=160105
                RETURN
              ELSE
                CALL FESTOP(160105)
              END IF
            END IF
          END IF
          DO 511 I=MAXALT,1,-1
          IF(U5ALT(I).NE.0) THEN
            U5ASTT(I)=1
            U5LINE(I)=CARDIN
            IF(I.LT.MAXALT) THEN
              U5ALT(I+1)=IFLAGI(1)
            END IF
            GO TO 512
          END IF
  511     CONTINUE
  512     CONTINUE
          U5=IFLAGI(1)
C
C  At this point, ISTAT is restored to its previous value before
C  encountering the INCLUDE statement.  If the previous status was
C  SCRATCH, MACROWRITE, ERRORFILE, or MACROIMPLEMENT, set to normal
C  reading instead.
C
          ISTAT=ISTTSV
          IF(ISTAT.EQ.6.OR.ISTAT.EQ.7.OR.ISTAT.EQ.9.OR.
     .       ISTAT.EQ.10)ISTAT=0
C
C  Transfer to 1 to begin reading from the new file.
C
          GO TO 1
C
C  Conclude processing of active SCRATCH statement.
C
        ELSE IF(ISTAT.EQ.6.AND..NOT.MACROI) THEN
          J=1
          IF(ISCRND.EQ.0) THEN
            CALL FNRD2(J,ITYPEI,IFLAGI,3,3,IFPSW,IFNAME,IPOSSC)
          END IF
          IF(IMERR1.GT.0) THEN
            CALL FSTOP
          ELSE IF(IFLAGI(1).EQ.0) THEN
            CALL FESTOP(160106)
          ELSE IF(IU.GT.0) THEN
            CALL OPENSC(IU)
          ELSE
            CALL FNLGTH(J)
            IF(J.GT.75) THEN
              CALL FESTOP(160324)
            END IF
            DO 514 I=1,7
            IU=12+I
            INQUIRE(UNIT=IU,OPENED=FOPEND)
            IF(.NOT.FOPEND) THEN
              WRITE(FNWRK(J+1:J+5),109)I
              CALL OPENSC(IU)
              IF(IMERR1.GT.0) THEN
                WRITE(U6,102)FNWRK(1:80)
                CALL FSTOP
              END IF
            END IF
  514       CONTINUE
          END IF
          ISTAT=0
C
C  Conclude processing of MACROWRITE statement.
C
        ELSE IF(ISTAT.EQ.7) THEN
          J=1
          IF(IPOSSC.EQ.0) THEN
            CALL FNRD2(J,ITYPEI,IFLAGI,2,3,IFPSW,IFNAME,IPOSSC)
          END IF
          IF(IMERR1.GT.0) THEN
            IF(CMPFLG.EQ.1) THEN
              RETURN
            ELSE
              CALL FSTOP
            END IF
          ELSE IF(IFLAGI(2).EQ.0) THEN
            IF(CMPFLG.EQ.1) THEN
              IMERR1=160107
              RETURN
            ELSE
              CALL FESTOP(160107)
            END IF
          ELSE
            IU=IFLAGI(2)
          END IF
C
C  Begin to write records to the macro file.
C
   44     CONTINUE
          IF(CMPFLG.EQ.1) THEN
            CALL STBLNK(CARDWK,1,256)
            CARDWK(1:80)=CARDIN
            WRITE(13)CARDWK
C                                          ! Under CMPFLG, print under
            NLINE=NLINE+1
C                                          ! ECHO only
            CALL ROOMD(1)
            DX(NXPTD-1)=U5ENOW
          ELSE IF(U5ECHO.EQ.1) THEN
            IF(CARDIN(80:80).EQ.' ') THEN
              WRITE(U6,101)CARDIN(1:79)
            ELSE
              WRITE(U6,102)CARDIN
            END IF
          END IF
C
C  Test for MACROEND at end of macro file
C
          CALL CMATCH(CARDIN(1:9),1,9,'MACROEND',8,I,1)
          IF(I.GT.0) GO TO 46
          WRITE(IU,100)CARDIN
          READ(U5,100,END=46)CARDIN,OVERFL
          CALL NBFIND(OVERFL,1,20,IPOS)
          IF(IPOS.GT.0) THEN
            CALL FESTOP(160117)
          END IF
          CARD(1:80)=CARDIN
          GO TO 44
C
C  Continue to read records and write to macro file
C
   46     CONTINUE
          CLOSE(IU)
          ISTAT=0
C
C  Transfer to 1 to continue reading from file.
C
          GO TO 1
C
C  Conclude processing of active ERRORFILE statement.
C
        ELSE IF(ISTAT.EQ.9) THEN
          J=1
          IF(ISCRND.EQ.0) THEN
            CALL FNRD2(J,ITYPEI,IFLAGI,4,3,IFPSW,IFNAME,IPOSSC)
          END IF
          IF(IMERR1.GT.0) THEN
            CALL FSTOP
          END IF
          FNERRR=FNWRK
          ISTAT=0
C
C  Conclude processing of MACROIMPLEMENT
C
        ELSE IF(ISTAT.EQ.10) THEN
          J=1
          IF(IPOSSC.EQ.0) THEN
            CALL FNRD2(J,ITYPEI,IFLAGI,2,3,IFPSW,IFNAME,IPOSSC)
          END IF
          IF(IMERR1.GT.0) THEN
            CALL FSTOP
          ELSE IF(IFLAGI(2).EQ.0) THEN
            CALL FESTOP(160113)
          ELSE
            MACROF=IFLAGI(2)
            MACROI=.TRUE.
            ISTAT=0
            GO TO 7
          END IF
C
        END IF
C
C  Processing of command lines beginning with letter or underscore.
C  Check for INCLUDE, SCRATCH, MACROWRITE and ERRORFILE encountered
C  during normal reading (not inside the scope of IGNORE, LONGCOMMENT,
C  etc.
C
        J=1
        IF(CARD(1:1).EQ.'_') THEN
          CALL NBFIND(CARD(2:256),2,256,J)
        ELSE IF(IEXCLM.GT.0) THEN
          J=0
        END IF
        I=0
        IF(J.GT.0) THEN
          IF(ISTAT.EQ.0) THEN
            CALL CMATCH(CARD(J:256),J,256,'INCLUDE',7,I,1)
            IF(I.GT.0) THEN
              IM=1
            ELSE
              CALL CMATCH(CARD(J:256),J,256,'MACROWRITE',10,I,1)
              IF(I.GT.0) THEN
                IM=7
              ELSE IF(CMPFLG.NE.1) THEN
                CALL CMATCH(CARD(J:256),J,256,'SCRATCH',7,I,2)
                IF(I.GT.0.AND..NOT.MACROI) THEN
                  CALL IFIND(CARD(I:256),I,256,IPOS,IU)
                  IF(IU.GE.1.AND.IU.LE.7) THEN
                    IU=12+IU
                    I=IPOS
                    IM=6
                  ELSE
                    CALL CMATCH(CARD(I:256),I,256,'STEM',4,IPOS,1)
                    IF(IPOS.GT.0) THEN
                      IU=-1
                      I=IPOS
                      IM=6
                    END IF
                  END IF
                ELSE
                  CALL CMATCH(CARD(J:256),J,256,'ERRORFILE',9,I,1)
                  IF(I.GT.0.AND..NOT.MACROI.AND.CMPFLG.NE.1) THEN
                    IM=9
                  ELSE
                    CALL CMATCH(CARD(J:256),J,256,
     .                         'MACROIMPLEMENT',14,I,1)
                    IF(I.GT.0) THEN
                      IF(MACROI) THEN
                        CALL FESTOP(160114)
                      ELSE
                        IM=10
                      END IF
                    ELSE
                      CALL CMATCH(CARD(J:256),J,256,
     .                         'MACROIMPLEMENTEND',17,I,1)
                      IF(I.GT.0) THEN
                        IM=11
                      END IF
                    END IF
                  END IF
                END IF
              END IF
            END IF
          END IF
          IF(I.EQ.0.AND.ISTAT.NE.2) THEN
            CALL CMATCH(CARD(J:256),J,256,'LONGCOMMENT',11,I,1)
            IF(I.GT.0)IM=2
          END IF
          IF(I.EQ.0.AND.ISTAT.NE.1) THEN
            CALL CMATCH(CARD(J:256),J,256,'IGNORE',6,I,1)
            IF(I.GT.0)IM=3
          END IF
          IF(I.EQ.0.AND.ISTAT.NE.1) THEN
            CALL CMATCH(CARD(J:256),J,256,'OFF',3,I,1)
            IF(I.GT.0)IM=3
          END IF
          IF(I.EQ.0.AND.ISTAT.EQ.0.AND..NOT.MACROI) THEN
            CALL CMATCH(CARD(J:256),J,256,'ECHO',4,I,1)
            IF(I.GT.0)IM=4
          END IF
          IF(I.EQ.0.AND.ISTAT.EQ.0) THEN
            CALL CMATCH(CARD(J:256),J,256,'SET',3,I,1)
            IF(I.GT.0)IM=5
          END IF
          IF(I.EQ.0.AND.ISTAT.EQ.0.AND.CMPFLG.EQ.0.AND..NOT.MACROI) THEN
C
C  For regular key words, call KYFND2 to identify.
C
            CALL KYFND2(IGROUP,IKEY,I)
C
C  The following checks for the first line of any step name or
C  subroutine that will read file names. U5LCSW is set to 2 to
C  identify that reading of a file name is in progress.
C
C  Special Note:  This IF statement must be amended in adding
C  steps or TRANSFORM subroutines that employ file names.
C
            IF(IKEY.GT.0) THEN
              IF(IGROUP.EQ.0.OR.IGROUP.EQ.4.OR.
     .           (IGROUP.EQ.7.AND.
     .            (IKEY.EQ.19.OR.IKEY.EQ.20)).OR.
C                                                   ! LINK, LINK_MISSING
     .           (IGROUP.EQ.8.AND.IKEY.EQ.7)) THEN
C                                                   ! INCORPORATE
                U5LCSW=2
              END IF
            END IF
            I=0
          END IF
C
C  Instead of setting IM, change status immediately for COMMENT and ON
C  C or any string beginning with COMM is treated as COMMENT.
C
          IF(I.EQ.0.AND.ISTAT.EQ.0.AND..NOT.MACROI) THEN
            CALL CMATCH(CARD(J:256),J,256,'COMM',4,I,2)
            IF(I.EQ.0) THEN
              CALL CMATCH(CARD(J:256),J,256,'C',1,I,1)
            END IF
            IF(I.GT.0.AND.CMPFLG.EQ.0) THEN
              ISTAT=3
              IF(U5ECHO.EQ.1)WRITE(U6,103)
              I=0
            ELSE
              CALL CMATCH(CARD(J:256),J,256,'ON',2,I,1)
              IF(I.GT.0) THEN
                ISTAT=8
                I=0
                IF(CMPFLG.EQ.1) THEN
                  CALL STBLNK(CARDWK,1,256)
                  WRITE(13)CARDWK
                  NLINE=NLINE+1
                  CALL ROOMD(1)
C                                         ! Under CMPFLG==, print ON only
                  DX(NXPTD-1)=U5ENOW
C                                         ! UNDER ECHO ?
                ELSE
                  IF(U5ECHO.EQ.1)WRITE(U6,103)
                END IF
              END IF
            END IF
          END IF
        END IF
C
C  Except for COMMENT, now handle the consequences of INCLUDE,
C  LONGCOMMENT, IGNORE, SET, ECHO, MACROIMPLEMENT and
C  MACROIMPLEMENTEND here.
C
        IF(I.GT.0) THEN
C
C  Print according to U5ECHO, but always print ECHO itself.
C
          IF(CMPFLG.EQ.1) THEN
            IF(CARDIN.NE.CARD(1:80).AND.(ISTAT.EQ.1.OR.ISTAT.EQ.2)) THEN
              CARDWK(1:80)=CARDIN
              WRITE(13)CARDWK
              NLINE=NLINE+1
              CALL ROOMD(1)
              IF(U5ENOW.GE.1.OR.IM.EQ.4) THEN
                DX(NXPTD-1)=1
              ELSE
                DX(NXPTD-1)=0
              END IF
            END IF
C           CALL STBLNK(CARDWK,1,256)
C           WRITE(13)CARDWK
            WRITE(13)CARD
C           NLINE=NLINE+2
            NLINE=NLINE+1
            CALL ROOMD(1)
            IF(U5ENOW.GE.1.OR.IM.EQ.4) THEN
              DX(NXPTD-1)=1
            ELSE
              DX(NXPTD-1)=0
            END IF
          ELSE IF(CMPFLG.NE.1) THEN
            IF(U5ECHO.GT.0.OR.(IM.EQ.4.AND..NOT.MACROI)) THEN
              WRITE(U6,103)
              CALL CRDPRN(2)
C                                              ! Note that ! comments
            END IF
C                                              ! removed from CARD here
          END IF
C
C  INCLUDE
C
          IF(IM.EQ.1) THEN
C
C  Nesting on INCLUDE can go MAXALT+1 deep, i.e., each element of U5ALT
C  can be different, as well as U5, for a total of MAXALT+1 open units.
C
            ITYPEI(1)=1
            ITYPEI(2)=0
            ITYPEI(3)=0
            IPT=I+1
            CALL FNRD2(IPT,ITYPEI,IFLAGI,2,1,IFPSW,IFNAME,IPOSSC)
            IF(IMERR1.GT.0) THEN
              IF(CMPFLG.EQ.1) THEN
                RETURN
              ELSE
                CALL FSTOP
              END IF
            END IF
            ISTAT=5
            IACTN=2
            IF(IPOSSC.NE.0)ICLEND=1
            GO TO 1
C
C  SCRATCH
C
          ELSE IF(IM.EQ.6) THEN
            ITYPEI(1)=1
            ITYPEI(2)=0
            ITYPEI(3)=0
            CALL FNRD2(I,ITYPEI,IFLAGI,3,1,IFPSW,IFNAME,IPOSSC)
            IF(IMERR1.GT.0) THEN
              CALL FSTOP
            END IF
            ISTAT=6
            IACTN=3
            IF(IPOSSC.NE.0)THEN
              ICLEND=1
              ISCRND=1
            ELSE
              ISCRND=0
            END IF
            GO TO 1
C
C  MACROWRITE
C
          ELSE IF(IM.EQ.7) THEN
            ITYPEI(1)=0
            ITYPEI(2)=1
            ITYPEI(3)=0
            IPT=I+1
            CALL FNRD2(IPT,ITYPEI,IFLAGI,2,1,IFPSW,IFNAME,IPOSSC)
            IF(IMERR1.GT.0) THEN
              IF(CMPFLG.EQ.1) THEN
                RETURN
              ELSE
                CALL FSTOP
              END IF
            END IF
            ISTAT=7
            IACTN=2
            IF(IPOSSC.NE.0)ICLEND=1
            GO TO 1
C
C  ERRORFILE
C
          ELSE IF(IM.EQ.9) THEN
            ITYPEI(1)=1
            ITYPEI(2)=0
            ITYPEI(3)=0
            IPT=I+1
            CALL FNRD2(IPT,ITYPEI,IFLAGI,4,1,IFPSW,IFNAME,IPOSSC)
            IF(IMERR1.GT.0) THEN
              CALL FSTOP
            END IF
            ISTAT=9
            IACTN=1
            IF(IPOSSC.NE.0)THEN
              ICLEND=1
              ISCRND=1
            ELSE
              ISCRND=0
            END IF
            GO TO 1
C
C  MACROIMPLEMENT
C
          ELSE IF(IM.EQ.10) THEN
            ITYPEI(1)=0
            ITYPEI(2)=1
            ITYPEI(3)=0
            IPT=I+1
            CALL FNRD2(IPT,ITYPEI,IFLAGI,2,1,IFPSW,IFNAME,IPOSSC)
            IF(IMERR1.GT.0) THEN
              CALL FSTOP
            END IF
            ISTAT=10
            IACTN=2
            IF(IPOSSC.NE.0)ICLEND=1
            GO TO 1
C
C  MACROIMPLEMENTEND
C
          ELSE IF(IM.EQ.11) THEN
            ISTAT=0
            MACROI=.FALSE.
            CLOSE(UNIT=MACROF)
            GO TO 1
          ELSE IF(IM.NE.5) THEN
C
C  LONGCOMMENT, IGNORE, ECHO
C  First, assume "ON", then check for "OFF" or "LITE"
C  Note that only this line is checked - continuation lines
C  are not anticipated i.e.,
C    ECHO
C       off
C  will not be interpreted as
C    ECHO  off
C
C  LEVEL keeps tract of the depth of IGNORE or LONGCOMMENT statements.
C
            IF(IM.EQ.2) THEN
              ISTAT=1
              LEVEL=LEVEL+1
            ELSE IF(IM.EQ.3) THEN
              ISTAT=2
              LEVEL=LEVEL+1
            ELSE IF(CMPFLG.NE.1) THEN
              U5ECHO=1
            ELSE
              U5ENOW=1
            END IF
C
C  Check here for IGNORE OFF, LONGCOMMENT OFF, ECHO OFF
C
            CALL NBFIND(CARD(I:256),I,256,J)
            IF(J.GT.0) THEN
              CALL CMATCH(CARD(J:256),J,256,'OFF',3,I,1)
              IF(I.GT.0) THEN
                IF(IM.EQ.4) THEN
                  IF(CMPFLG.NE.1) THEN
                    U5ECHO=0
                  ELSE
                    U5ENOW=0
                  END IF
                ELSE
                  LEVEL=LEVEL-2
                  IF(LEVEL.LE.0) THEN
                    IF(LEVEL.EQ.-1) THEN
                      IF(CMPFLG.EQ.1) THEN
                        CALL STBLNK(CARDWK,1,256)
                        WRITE(CARDWK,204)
                        WRITE(13)CARDWK
C                                            ! For CMPFLG==1, always
                        NLINE=NLINE+1
C                                            ! print warning
                        CALL ROOMD(1)
                        DX(NXPTD-1)=1
                      ELSE
                        WRITE(U6,204)
                      END IF
                      LEVEL=0
                    END IF
                    ISTAT=0
                  END IF
                END IF
C
C  Check for ECHO LITE
C
              ELSE IF(IM.EQ.4) THEN
                CALL CMATCH(CARD(J:256),J,256,'LITE',4,I,1)
                IF(I.GT.0) THEN
                  IF(CMPFLG.EQ.1) THEN
                    U5ENOW=2
                  ELSE
                    U5ECHO=2
                  END IF
                END IF
              END IF
            END IF
C
C  If LONGCOMMENT, IGNORE, or ECHO, read next record
C
            GO TO 1
          ELSE
C
C  Initialize SET, J records where to begin processing
C
            ISTAT=4
            ISUB=0
            CALL NBFIND(CARD(I:256),I,256,J)
          END IF
        END IF
      ELSE IF(ISTAT.EQ.4) THEN
C
C  Continuation line of SET, J records where to begin processing
C
        CALL NBFIND(CARD(1:256),1,256,J)
        IF(CMPFLG.EQ.1) THEN
          WRITE(13)CARD
          NLINE=NLINE+1
          CALL ROOMD(1)
          DX(NXPTD-1)=U5ENOW
        ELSE
          CALL CRDPRN(0)
        END IF
      ELSE IF(ISTAT.EQ.5.OR.ISTAT.EQ.6.OR.ISTAT.EQ.7.OR.ISTAT.EQ.10)THEN
C
C  Continue to read file name for INCLUDE, SCRATCH, MACROWRITE,
C  MACROIMPLEMENT.
C
        J=1
        CALL FNRD2(J,ITYPEI,IFLAGI,IACTN,2,IFPSW,IFNAME,IPOSSC)
        IF(IMERR1.GT.0) THEN
          IF(CMPFLG.EQ.1) THEN
            RETURN
          ELSE
            CALL FSTOP
          END IF
        END IF
        IF(CMPFLG.EQ.1) THEN
          WRITE(13)CARD
          NLINE=NLINE+1
          CALL ROOMD(1)
          DX(NXPTD-1)=U5ENOW
        ELSE
          CALL CRDPRN(0)
        END IF
        IF(IPOSSC.NE.0)ICLEND=1
C
C  Transfer to 1 to read next line.
C
        GO TO 1
      END IF
C
C  Processing of SET here, for both initial and continuation lines.
C
C  Variables and arrays used by SET and substitutions:
C
C  NSUB   - the number of assigned substitution strings
C  NSUBLM - the number of assigned lines
C  NSUBCM - the number of assigned elements of the character array
C  ISUBCN - ISUB for a substitution string with continuation lines,
C           while in use.
C  ICHCNT - holds current position in line in case of substitution
C           of multi-line strings.
C  CININI - 1 - a line has just been read from the input file
C           0 - this is a continuation line.
C  NSUBLN - number of lines for the substitution string.
C  IPTSBL - pointer from ISUB to the first line of substitution.
C  NSBCHR - number of characters in the substitution line
C  IPTSBC - pointer from ILINE to the first element of character
C           array for the line.
C  U5LCSW - switch to control flow when step or subroutine referencing
C           file names encountered.
C
      IF(ISTAT.EQ.4) THEN
        IAPOST=0
C       IF(IEXCLF.GT.1) THEN                      ! Adjust ILAST to
C         DO 50 ILAST=IEXCLF-1,1,-1               ! last character
C         IF(CARD(ILAST:ILAST).NE.' ') GO TO 501  ! before comments
C  50     CONTINUE
C         ILAST=1
C       END IF
C 501   CONTINUE
        IF(ILAST.GT.1.AND.CARD(ILAST:ILAST).EQ.';') THEN
          ISCEND=1
C                                                 ! ISCEND - flag
          K=ILAST-1
C                                                 ! indicating ending
          DO 502 ILAST=K,1,-1
C                                                 ! ';'
          IF(CARD(ILAST:ILAST).NE.' ') GO TO 503
  502     CONTINUE
          ILAST=1
  503     CONTINUE
        ELSE
          ISCEND=0
        END IF
   51   CONTINUE
        IF(J.EQ.0) GO TO 1
C
C  If name of string has not yet been established, the name should
C  begin at J.
C
        IF(ISUB.EQ.0) THEN
          IF(.NOT.ALPCHK(CARD(J:J))) THEN
            WRITE(U6,205)
            IF(CMPFLG.EQ.1) THEN
              IMERR1=160111
              RETURN
            ELSE
              CALL FPSTOP(160111,J)
            END IF
          END IF
          JJ=J+1
   52     CONTINUE
          IF(ALPCHK(CARD(JJ:JJ)).OR.DGTCHK(CARD(JJ:JJ)).OR.
     .       CARD(JJ:JJ).EQ.'.') THEN
            JJ=JJ+1
            IF(JJ.LE.J+MAXSNL)GO TO 52
            WRITE(U6,205)
            IF(CMPFLG.EQ.1) THEN
              IMERR1=160112
              RETURN
            ELSE
              CALL FPSTOP(160112,JJ)
            END IF
          END IF
          LEN=JJ-J
          JJ=JJ-1
C
C  At this point, the name is in the range J:JJ
C
C  Check if name already in use
C
          IF(NSUB.GT.0) THEN
            DO 54 I=1,NSUB
            CALL CMATCH(SUBNAM(I),1,MAXSNL,CARD(J:JJ),LEN,IPOS2,1)
            IF(IPOS2.GT.0) THEN
              ISUB=I
              ISUBLN=IPTSBL(I)
              NSBCHR(ISUBLN)=0
C
C  If ISUBLN = NSUBLM, may reuse space, otherwise, ISUBLN and IPTSBL
C  will be reassigned below.
C
              IF(ISUBLN.EQ.NSUBLM) THEN
                NSUBCM=IPTSBC(ISUBLN)
              ELSE
                ISUBLN=0
              END IF
              GO TO 55
            END IF
   54       CONTINUE
   55       CONTINUE
          END IF
C
C  Assign ISUB here if not matched.
C
          IF(ISUB.EQ.0) THEN
            NSUB=NSUB+1
            ISUB=NSUB
            IF(NSUB.GT.MAXSUB) THEN
              WRITE(U6,206)
              IF(CMPFLG.EQ.1) THEN
                IMERR1=160108
                RETURN
              ELSE
                CALL FESTOP(160108)
              END IF
            END IF
            ISUBLN=0
            SUBNAM(ISUB)=CARD(J:JJ)
            IF(LEN.LT.MAXSNL) THEN
              DO 56 L=LEN+1,MAXSNL
              SUBNAM(ISUB)(L:L)=' '
   56         CONTINUE
            END IF
          END IF
C
C  Except in case of match to previous ISUBLN=NSUBLM, assign ISUBLN to
C  new space here.
C
          IF(ISUBLN.EQ.0) THEN
            NSUBLM=NSUBLM+1
            IF(NSUBLM.GT.MAXSBL) THEN
              WRITE(U6,206)
              IF(CMPFLG.EQ.1) THEN
                IMERR1=160109
                RETURN
              ELSE
                CALL FESTOP(160109)
              END IF
            END IF
            NSUBCM=NSUBCM+1
            IF(NSUBCM.GT.MAXSBC) THEN
              WRITE(U6,206)
              IF(CMPFLG.EQ.1) THEN
                IMERR1=160110
                RETURN
              ELSE
                CALL FESTOP(160110)
              END IF
            END IF
            ISUBLN=NSUBLM
            IPTSBL(ISUB)=ISUBLN
            NSBCHR(ISUBLN)=0
            IPTSBC(ISUBLN)=NSUBCM
          END IF
          JJ=JJ+1
C
C  Set IEQUAL=0 to indicate that we have not yet matched "="
C
          IEQUAL=0
          NSUBLN(ISUB)=1
          CALL NBFIND(CARD(JJ:256),JJ,256,J)
          IF(J.GT.0)GO TO 51
          GO TO 1
        ELSE IF(IEQUAL.EQ.0) THEN
C
C  Check for "=" - if do not match, assume are at beginning of string
C
          IEQUAL=1
          LFIRST=1
          IF(CARD(J:J).EQ.'=') THEN
            JJ=J+1
            CALL NBFIND(CARD(JJ:256),JJ,256,J)
            IF(J.EQ.0)GO TO 1
          END IF
          GO TO 51
        ELSE
C
C  If not at first line of substitution, record new line.
C
          IF(LFIRST.EQ.0) THEN
            NSUBLN(ISUB)=NSUBLN(ISUB)+1
            NSUBLM=NSUBLM+1
            IF(NSUBLM.GT.MAXSBL) THEN
              WRITE(U6,206)
              IF(CMPFLG.EQ.1) THEN
                IMERR1=160109
                RETURN
              ELSE
                CALL FESTOP(160109)
              END IF
            END IF
            NSUBCM=NSUBCM+1
            IF(NSUBCM.GT.MAXSBC) THEN
              WRITE(U6,206)
              IF(CMPFLG.EQ.1) THEN
                IMERR1=160110
                RETURN
              ELSE
                CALL FESTOP(160110)
              END IF
            END IF
            ISUBLN=NSUBLM
            NSBCHR(ISUBLN)=0
            IPTSBC(ISUBLN)=NSUBCM
C
C  Unless explicit positioning indicated by "'", insert a blank as
C  first character of continuation line.
C
            IF(CARD(J:J).EQ.'''') THEN
              L=0
              J=J+1
              NCHAR=0
              IAPOST=1
            ELSE IF(CARD(J:J).EQ.'"') THEN
              L=0
              J=J+1
              NCHAR=0
              IAPOST=2
            ELSE
              SUBCSV(NSUBCM)(1:1)=' '
              L=1
              NCHAR=1
            END IF
          ELSE
C
C  On first line of substitution, begin at character 1, unless directed
C  by "'"
C
            L=0
            NCHAR=0
            IF(CARD(J:J).EQ.'''') THEN
              J=J+1
              IAPOST=1
            ELSE IF(CARD(J:J).EQ.'"') THEN
              J=J+1
              IAPOST=2
            END IF
            LFIRST=0
          END IF
C
C  Loop to 57 stores the string, a character at a time.
C  Convert && to &.
C
   57     CONTINUE
          IF(J.GT.ILAST.OR.
     .       J.EQ.ILAST.AND.(CARD(J:J).EQ.''''.OR.CARD(J:J).EQ.'"'))THEN
            IF(L.LT.12) THEN
              DO 58 JJ=L+1,12
              SUBCSV(NSUBCM)(JJ:JJ)=' '
   58         CONTINUE
            END IF
            NSBCHR(ISUBLN)=NCHAR
            IF(ISCEND.EQ.1) THEN
              ISTAT=0
            END IF
            GO TO 1
          END IF
          IF(CARD(J:J).EQ.'&'.AND.CARD(J+1:J+1).EQ.'&') THEN
            J=J+1
          ELSE IF(CARD(J:J).EQ.'''') THEN
            IF(IAPOST.EQ.1) THEN
              IF(CARD(J+1:J+1).EQ.'''') THEN
                J=J+1
              ELSE
                IAPOST=0
                J=J+1
                GO TO 57
              END IF
            ELSE IF(IAPOST.EQ.0) THEN
              IAPOST=1
              J=J+1
              GO TO 57
            END IF
          ELSE IF(CARD(J:J).EQ.'"') THEN
            IF(IAPOST.EQ.2) THEN
              IF(CARD(J+1:J+1).EQ.'"') THEN
                J=J+1
              ELSE
                IAPOST=0
                J=J+1
                GO TO 57
              END IF
            ELSE IF(IAPOST.EQ.0) THEN
              IAPOST=2
              J=J+1
              GO TO 57
            END IF
          END IF
          L=L+1
          NCHAR=NCHAR+1
          IF(L.EQ.13) THEN
            NSUBCM=NSUBCM+1
            IF(NSUBCM.GT.MAXSBC) THEN
              WRITE(U6,206)
              IF(CMPFLG.EQ.1) THEN
                IMERR1=160110
                RETURN
              ELSE
                CALL FESTOP(160110)
              END IF
            END IF
            L=1
          END IF
          SUBCSV(NSUBCM)(L:L)=CARD(J:J)
          J=J+1
          GO TO 57
        END IF
C
C  Under SET, always read the next record to determine continuation, if
C  any.
C
        GO TO 1
      END IF
C
C  End of SET processing.
C
C  Print the contents here if continuation card or if LONGCOMMENT
C
      IF(ISTAT.NE.2) THEN
        IF(ISTAT.NE.0.OR..NOT.ALPCHK(CARD(1:1)).OR.MACROI) THEN
          IF(CMPFLG.EQ.1.AND.ISTAT.NE.0) THEN
            WRITE(13)CARDIM
            NLINE=NLINE+1
            CALL ROOMD(1)
            DX(NXPTD-1)=U5ENOW
          ELSE
            CALL CRDPRN(0)
          END IF
        END IF
        IF(MACROI) THEN
          IF(IONFLG.GT.0) THEN
            GO TO 1
          ELSE
            CALL LASTCR(ILAST)
            IF(ILAST.GT.80) THEN
              CALL FESTOP(160115)
            ELSE
              IF(ILAST.LE.9) THEN
                IF(ILAST.EQ.0)ILAST=1
                WRITE(LFMT,107)ILAST
              ELSE
                WRITE(LFMT,108)ILAST
              END IF
              IF(ILAST.GE.1) THEN
                WRITE(MACROF,FMT=LFMT,ERR=62)CARD(1:ILAST)
              ELSE
                WRITE(MACROF,FMT=LFMT,ERR=62)
              END IF
              GO TO 1
   62         CONTINUE
              CALL FESTOP(160116)
            END IF
          END IF
        END IF
C
C  Eliminate entirely blank cards unless CMPFLG=1
C  If ISTAT ne 0, then keep reading more records under COMMENT, ON,
C  LONGCOMMENT or IGNORE.
C
        CALL NBFIND(CARD(1:256),1,256,J)
        IF((J.EQ.0.AND.CMPFLG.EQ.0).OR.ISTAT.NE.0)GO TO 1
        IF(ALPCHK(CARD(1:1))) THEN
          IF(CMPFLG.EQ.1.AND.ISBFLG.EQ.1) THEN
C                                              ! If two lines have
            NLINE=NLINE-2
C                                              ! been written to 13
          END IF
C                                              ! for substitution,
        ELSE
C                                              ! adjust nline
          REFRSH=.TRUE.
        END IF
      ELSE
        GO TO 1
      END IF
      RETURN
C
C  Handling of end of input file - check to return to previous file
C  in stack.
C
   90 CONTINUE
C
C  If the file ended with an INCLUDE statement, process immediately.
C
      IF(ISTAT.EQ.5) THEN
        J=1
        CALL FNRD2(J,ITYPEI,IFLAGI,2,3,IFPSW,IFNAME,IPOSSC)
        IF(IMERR1.GT.0) THEN
          IF(CMPFLG.EQ.1) THEN
            RETURN
          ELSE
            CALL FSTOP
          END IF
        ELSE IF(IFLAGI(1).EQ.0) THEN
          WRITE(U6,207)
          IF(CMPFLG.EQ.1) THEN
            IMERR1=160104
            RETURN
          ELSE
            CALL FESTOP(160104)
          END IF
        END IF
        IF(U5ALT(MAXALT).NE.0) THEN
          IF(U5ALT(MAXALT).NE.U5) THEN
            WRITE(U6,202)MAXALT
            IF(CMPFLG.EQ.1) THEN
              IMERR1=160105
              RETURN
            ELSE
              CALL FESTOP(160105)
            END IF
          END IF
        END IF
C
C  Find current included file and set U5ALT to 0
C
        DO 91 I=MAXALT,1,-1
        IF(U5ALT(I).NE.0) THEN
          U5ASTT(I)=0
          IF(I.LT.MAXALT) THEN
            U5ALT(I+1)=IFLAGI(1)
          END IF
          GO TO 92
        END IF
   91   CONTINUE
   92   CONTINUE
        U5=IFLAGI(1)
        ISTAT=ISTTSV
        IF(ISTAT.EQ.6)ISTAT=0
C
C  Transfer to 1 to begin reading from this new file.
C
        GO TO 1
      END IF
C
C  Except for INCLUDE, handled above, if the file ended
C  while processing a file name (U5LCSW=2), return to
C  calling program with U5LCSW=4
C
      IF(U5LCSW.EQ.2) THEN
        IF(ISUBCN.GT.0) THEN
C
C  If continuation line of substitution continues beyond file name,
C  the logic is in trouble - generate error.
C
          WRITE(U6,207)
          IF(CMPFLG.EQ.1) THEN
            IMERR1=160100
            RETURN
          ELSE
            CALL FESTOP(160100)
          END IF
        ELSE
C
C  Return here if at end of file specification but next line continues
C  a command.  Calling routine should complete all decisions based on
C  the file name before calling REFRSH again.
C
          U5LCSW=4
          RETURN
        END IF
      END IF
C
C  If reading from a scratch file, set U5END to 1 on encountering
C  an end-of-file.  The calling program must call REFRSH again to begin
C  processing the incoming files.
C
      IF(U5.GE.13.AND.U5.LE.17) THEN
        IF(U5END.EQ.0) THEN
          U5END=1
          RETURN
        ELSE
          U5END=U5ESAV
          IF(U5END.EQ.1) THEN
            U5=U5ALT(1)
            RETURN
          END IF
        END IF
      END IF
C
C  In all other cases, close the file unless this is the primary input
C  file.  Restore the contents of CARDIN.
C
      IF(U5.NE.U5ALT(1)) THEN
        IF(U5.GE.13.AND.U5.LE.17) THEN
          REWIND(UNIT=U5)
        ELSE
          CLOSE(UNIT=U5)
        END IF
        IF(U5ALT(MAXALT).NE.0.AND.U5.NE.U5ALT(MAXALT)) THEN
          U5=U5ALT(MAXALT)
          IF(U5ASTT(MAXALT).EQ.1)CARDIN=U5LINE(MAXALT)
          J=U5ASTT(MAXALT)
        ELSE
          DO 93 I=MAXALT,2,-1
          IF(U5ALT(I).NE.0) THEN
            U5ALT(I)=0
            U5=U5ALT(I-1)
            IF(U5ASTT(I-1).EQ.1)CARDIN=U5LINE(I-1)
            J=U5ASTT(I-1)
            GO TO 94
          END IF
   93     CONTINUE
   94     CONTINUE
        END IF
C
C  On end of file, turn off IGNORE or LONGCOMMENT, set ISSLVL=0
C
        IF(ISTAT.EQ.1.OR.ISTAT.EQ.2)ISTAT=0
        LEVEL=0
        ISSLVL=0
C
C  Check to see if the restored file itself is at end of file.
C  If so, loop back to 90 to handle in the same way.
C
        IF(J.EQ.0) THEN
          GO TO 90
        ELSE
          CININI=1
          CARDIM(1:80)=CARDIN
          IF(NSUB.GT.0) THEN
            CALL STBLNK(CARD,81,256)
          END IF
          GO TO 7
        END IF
      END IF
C
C  Arrive here on end of primary file.
C
      U5END=1
      RETURN
      END
C
      SUBROUTINE RENAMV(BASE,VNAME,NVIN,VTEMP,VTMPSZ,VTEMP2,
     .  VNKEEP,NKEEP,MTYPE,LPOINT,CDMPNT,CROSSD,LABEL,LEVEL,IPOS)
C
      INTEGER BASE,NVIN,VTMPSZ,NKEEP,IPOS
      INTEGER MTYPE(NVIN),LPOINT(NVIN),CDMPNT(NVIN),CROSSD(*)
      CHARACTER*12 VNAME(NVIN),VTEMP(VTMPSZ),VTEMP2(*),VNKEEP(*)
      CHARACTER*24 LABEL(NVIN),LEVEL(*)
C
C  Renames variables in VNAME, and also changes references to the old
C  name for crossed variables.
C
C  BASE           - pointer to the first non-blank character in CARD,
C                   set to 1 if another card is read
C  VNAME(NVIN)    - primary array of current names
C  NVIN           - number of current variables
C  VTEMP          - work array
C  VTMPSZ         - size of VTEMP
C  VTEMP2(*)      - an array of names associated with crossed variables
C  VNKEEP         - an array holding the list of KEEP variables
C  NKEEP          - the current entries in VNKEEP
C  MTYPE(NVIN)    - variable types
C  LPOINT(NVIN)   - pointer to LEVELS
C  CDMPNT(NVIN)   - pointer to information on crossed variables
C  CROSSD(*)      - information on crossed variables
C  LABEL          - labels for the variables
C  LEVEL          - labels for levels of categorical and crossed
C                   variables
C  IPOS           - ending position (added 1/4/98)
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      INTEGER J,JJ,K,L,L1,MATCH,N,N1,N2
C
  201 FORMAT(' DUPLICATION OF EXISTING VARIABLE NAME - ',A12)
  205 FORMAT(' WARNING - UNRECOGNIZED VARIABLE NAME ',A12)
C
      CALL VNFIND(BASE,VTEMP,VTMPSZ,N,IPOS,2,VNAME,NVIN)
      IF(N.LE.2) THEN
        CALL FESTOP(160060)
      END IF
      N1=1
   10 CONTINUE
      N2=N-N1+1
C
C  Find the first occurence of AS or INTO
C
      CALL VNMTCH('AS          ',VTEMP(N1),N2,L)
      CALL VNMTCH('INTO        ',VTEMP(N1),N2,L2)
      IF(L2.GT.0.AND.(L.EQ.0.OR.L2.LT.L)) THEN
        L=L2
      END IF
      IF(L.EQ.0) THEN
        CALL FESTOP(160061)
      ELSE IF(2*L+N1.GT.N+2) THEN
        CALL FESTOP(160062)
      END IF
      L=L+N1-2
      L1=L+2
      DO 20 I=N1,L
      MATCH=0
      CALL VNMTCH(VTEMP(L1),VNAME,NVIN,K)
      IF(K.GT.0) THEN
        WRITE(U6,201)VTEMP(L1)
        CALL FESTOP(160063)
      END IF
      CALL VNMTCH(VTEMP(I),VNAME,NVIN,K)
      IF(K.GT.0) THEN
        VNAME(K)=VTEMP(L1)
        MATCH=1
C
C  If the label for the old variable was the same as the variable
C  name, then relabel the variable with the new name.
C
        IF(LABEL(K)(1:12).EQ.VTEMP(I).AND.
     .     LABEL(K)(13:24).EQ.'            ') THEN
          LABEL(K)(1:12)=VTEMP(L1)
        END IF
      END IF
C
C  If the old name appeared in a KEEP list, then revise the list.
C
      IF(NKEEP.GT.0) THEN
        CALL VNMTCH(VTEMP(I),VNKEEP,NKEEP,K)
        IF(K.GT.0) THEN
          VNKEEP(K)=VTEMP(L1)
        END IF
      END IF
C
C  If the old name was included as a label for any crossed variable,
C  revise the label here too.
C
      DO 15 JJ=1,NVIN
      IF(MTYPE(JJ).EQ.8.OR.MTYPE(JJ).EQ.9) THEN
        L=LPOINT(JJ)
        K=CDMPNT(JJ)
        N3=CROSSD(K)
        NM=CROSSD(K+N3+1)
        DO 6 J=1,N3
        CALL VNMTCH(VTEMP2(NM),VTEMP(I),1,LL)
        IF(LL.EQ.1) THEN
          IF(LEVEL(L)(1:12).EQ.VTEMP2(NM).AND.
     .       LEVEL(L)(13:24).EQ.'            ') THEN
            LEVEL(L)(1:12)=VTEMP(L1)
          END IF
          VTEMP2(NM)=VTEMP(L1)
          MATCH=1
        END IF
        NM=NM+1
        L=L+1+CROSSD(K+J)
    6   CONTINUE
      END IF
   15 CONTINUE
C
C  Nonfatal error message if old name is not in use.
C
      IF(MATCH.EQ.0.AND.U5ECHO.GT.0)WRITE(U6,205)VTEMP(I)
      L1=L1+1
  20  CONTINUE
      N1=L1
      IF(N1.LE.N)GO TO 10
      RETURN
      END
C
      SUBROUTINE RLABEL(BASE,VNAME,NVIN,VTEMP,VTMPSZ,VTEMP2,MTYPE,
     .  LPOINT,CDMPNT,CROSSD,LABEL,LEVEL,NLEVEL,MLEVEL,IPOS)
C
      INTEGER BASE,NVIN,VTMPSZ,NLEVEL,MLEVEL,IPOS
      INTEGER MTYPE(NVIN),LPOINT(NVIN),CDMPNT(NVIN),CROSSD(*)
      CHARACTER*12 VNAME(NVIN),VTEMP(VTMPSZ),VTEMP2(*)
      CHARACTER*24 LABEL(NVIN),LEVEL(MLEVEL)
C
C  Reads variable labels after LABEL statement.
C
C  BASE           - pointer to the first non-blank character in CARD,
C                   set to 1 if another record is read
C  VNAME(NVIN)    - primary array of current names
C  NVIN           - number of current variables
C  VTEMP          - work array
C  VTMPSZ         - size of VTEMP
C  VTEMP2(*)      - an array of names associated with crossed variables
C  MTYPE(NVIN)    - variable types
C  LPOINT(NVIN)   - pointer to LEVELS
C  CDMPNT(NVIN)   - pointer to information on crossed variables
C  CROSSD(*)      - information on crossed variables
C  LABEL          - labels for the variables
C  LEVEL          - labels for levels of categorical and crossed
C                   variables.  Unused space in this array is used
C                   as scratch space in this routine.
C  NLEVEL         - the number of current entries in LEVEL
C  MLEVEL         - the maximum allowed entries in LEVEL
C  IPOS           - ending position (may be =0) (added 1/4/98)
C
 
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      CHARACTER*256 CARD
      COMMON /CRDBLK/ CARD
      LOGICAL ALPCHK
      EXTERNAL ALPCHK
C
      INTEGER I,IPT,N,NL,N1LEV
C
  205 FORMAT(' WARNING - UNRECOGNIZED VARIABLE NAME ',A12)
  210 FORMAT(1X,I7,' EXCEEDS AVAILABLE RESOURCES FOR LEVELS OF CAT/CLASS
     .')
C
      IPT=BASE
    1 CONTINUE
C
C  Determine variables to label.  On return from VNFIND, N will provide
C  the number of variables
C
      CALL VNFIND(IPT,VTEMP,VTMPSZ,N,IPOS,2,VNAME,NVIN)
      IF(IPT.EQ.1)BASE=1
      IF(N.LE.0.OR.IPOS.EQ.0)RETURN
      IPT=IPOS
      N1LEV=NLEVEL+1
      IF(NLEVEL+N.GT.MLEVEL) THEN
        NLEVEL=NLEVEL+N
        WRITE(U6,210)NLEVEL
        CALL FESTOP(160065)
      END IF
C
C  LEVELR uses N as the maximum number to accept and returns NL, the
C  number actually read.
C
      CALL LEVELR(IPT,IPOS,NL,LEVEL(N1LEV),N)
      IF(IPT.EQ.1)BASE=1
      IF(NL.GT.N)NL=N
      DO 20 I=1,NL
      MATCH=0
      CALL VNMTCH(VTEMP(I),VNAME,NVIN,K)
      IF(K.GT.0) THEN
        LABEL(K)=LEVEL(N1LEV)
        MATCH=1
      END IF
C
C  If have stored this label for the variable, update the labels
C  in any crossed variables.
C
      DO 15 JJ=1,NVIN
      IF(MTYPE(JJ).EQ.8.OR.MTYPE(JJ).EQ.9.OR.
     .   MTYPE(JJ).EQ.19) THEN
        L=LPOINT(JJ)
        K=CDMPNT(JJ)
        N=CROSSD(K)
        NM=CROSSD(K+N+1)
        DO 6 J=1,N
        CALL VNMTCH(VTEMP2(NM),VTEMP(I),1,LL)
        IF(LL.EQ.1) THEN
          LEVEL(L)=LEVEL(N1LEV)
          MATCH=1
        END IF
        NM=NM+1
        L=L+1+CROSSD(K+J)
    6   CONTINUE
      END IF
   15 CONTINUE
      IF(MATCH.EQ.0) THEN
        WRITE(U6,205)VTEMP(I)
      END IF
      N1LEV=N1LEV+1
   20 CONTINUE
      IF(U5END.EQ.1.OR.(BASE.EQ.1.AND.ALPCHK(CARD(1:1)))) THEN
        RETURN
      ELSE
        IPT=IPOS
        GO TO 1
      END IF
      END
C
      SUBROUTINE RLEVEL(BASE,VNAME,NVIN,VTEMP,VTMPSZ,MSIZE,
     .  LPOINT,LEVEL,NLEVEL,MLEVEL,IPOS)
C
      INTEGER BASE,NVIN,VTMPSZ,NLEVEL,MLEVEL,IPOS
      INTEGER LPOINT(NVIN),MSIZE(NVIN)
      CHARACTER*12 VNAME(NVIN),VTEMP(VTMPSZ)
      CHARACTER*24 LEVEL(MLEVEL)
C
C  Reads labels for levels after LEVEL statement.
C
C  BASE           - pointer to the first non-blank character in CARD,
C                   set to 1 if another record is read
C  VNAME(NVIN)    - primary array of current names
C  NVIN           - number of current variables
C  VTEMP          - work array
C  VTMPSZ         - size of VTEMP
C  MSIZE          - size of the variables, used to determine the
C                   expected number of level labels
C  LPOINT         - pointer to LEVELS
C  LEVEL          - labels for levels of categorical and crossed
C                   variables.
C  NLEVEL         - the number of current entries in LEVEL
C  MLEVEL         - the maximum allowed entries in LEVEL
C  IPOS           - final position (added 1/4/98)
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      CHARACTER*256 CARD
      COMMON /CRDBLK/ CARD
      LOGICAL ALPCHK
      EXTERNAL ALPCHK
C
      INTEGER I,IPT,N,NL,N1LEV
C
 
  205 FORMAT(' WARNING - UNRECOGNIZED VARIABLE NAME ',A12)
  210 FORMAT(1X,I7,' EXCEEDS AVAILABLE RESOURCES FOR LEVELS OF CAT/CLASS
     .')
C
      IPT=BASE
    1 CONTINUE
C
C  First, read the name(s) of the variable(s).
C
      CALL VNFIND(IPT,VTEMP,VTMPSZ,N,IPOS,2,VNAME,NVIN)
      IF(IPT.EQ.1)BASE=1
C
C  Return if no variable names or if no labels follow.
C
      IF(N.LE.0.OR.IPOS.EQ.0.OR.U5END.EQ.1)RETURN
      IPT=IPOS
      N1LEV=NLEVEL+1
      IF(N1LEV.GT.MLEVEL) THEN
        NLEVEL=N1LEV
        WRITE(U6,210)NLEVEL
        CALL FESTOP(160070)
      END IF
      N2LEV=MLEVEL-NLEVEL
      CALL LEVELR(IPT,IPOS,NL,LEVEL(N1LEV),N2LEV)
      IF(IPT.EQ.1)BASE=1
C
C  Set LPOINT to point from the variables to the beginning of the
C  levels.  Determine the maximum number of levels expected
C  according to MSIZE
C
      LMAX=1
      DO 20 I=1,N
      CALL VNMTCH(VTEMP(I),VNAME,NVIN,K)
      IF(K.EQ.0) THEN
        WRITE(U6,205)VTEMP(I)
      ELSE
        LPOINT(K)=N1LEV
        IF(MSIZE(K).GT.LMAX)LMAX=MSIZE(K)
      END IF
   20 CONTINUE
C
C  If one or more variables have a size larger than the number of
C  levels provided, fill the remaining labels with blanks.
C
      IF(LMAX.GT.NL) THEN
        DO 25 I=NL+1,LMAX
        LEVEL(NLEVEL+I)='                       '
   25   CONTINUE
      END IF
      NLEVEL=NLEVEL+LMAX
      IF(U5END.EQ.1.OR.(IPT.EQ.1.AND.ALPCHK(CARD(1:1))))RETURN
      IPT=IPOS
      GO TO 1
      END
C
      SUBROUTINE RNSCAN(BASE,IPOS,RANGET,MAXRNG,RTYPET,RGRPT,N,IFLAG,
     . TEMPLB,MAXTLB)
C
      INTEGER BASE,IPOS,MAXRNG,N,IFLAG,MAXTLB
      INTEGER RTYPET(MAXRNG),RGRPT(MAXRNG)
      DOUBLE PRECISION RANGET(2,MAXRNG)
      CHARACTER*24 TEMPLB(MAXTLB)
C
C  Subroutine to scan for ranges.  Used with IF, CLASS, CAT, etc.
C  Also used by CLSCAN to determine levels of class variables.
C
C  BASE    - starting position to scan, reset to 1 if new card read
C  IPOS    - ending position returned by RNSCAN
C  RANGET  - matrix into which RNSCAN stores the lower and upper
C            limits of each range
C  MAXRNG  - the maximum space in RANGET, RTYPET, and RGRPT,
C            determined by the calling program
C  RTYPET  - integer codes to indicate the type of range (documented
C            below
C  RGRPT   - an array that marks level membership
C  IFLAG   - from calling routine - RNSCAN
C  TEMPLB  - an array into which RNSCAN should store labels based on
C            the ranges themselves.  This feature, used with CLASS,
C            CAT, etc., provides provisional labels in case they are
C            not otherwise given.
C  MAXTLB  - the size of TEMPLB.
C
C  The routine reads successive cards, if necessary,
C  resetting BASE=1 if it does so.
C
C  If IFLAG=1 or 2 "," delimits ranges, "/" delimits levels
C                       e.g., CLASS, CAT
C     IFLAG=3      " " delimits ranges "," delimits levels
C                       e.g., as used by CLSCAN to determine
C                       levels of a class variable.
C
C  If IFLAG=1 store ranges as default labels into TEMPLB
C
      CHARACTER*256 C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      COMMON /CRDBLK/C
      DOUBLE PRECISION DLOW,DLOW1,DHIGH,DHIGH1
      DOUBLE PRECISION DBELOW,DABOVE
      LOGICAL REFRSH
      EXTERNAL REFRSH,DBELOW,DABOVE
      INTEGER LEVEL
C
      IPOS=0
      N=0
      IPT=BASE
C
C  LEVEL - for IFLAG = 1 or 2, level as marked off by "/"
C  NEWLVL - keeps tract of increments in LEVEL
C
      LEVEL=1
      NEWLVL=1
C
C  The next three indices have to do with copying ranges into levels
C  for use as labels.
C    ILSTRT - position in CARD of beginning of range, or next part of
C             range to copy
C    ILEND  - last nonblank position in CARD with part of range (not
C             initialized here but set when beginning of range is
C             detected.
C    LSTART - character position in TEMPLB to beginning copying range
C    LEND   - last character position in TEMPLB to receive range
C
      ILSTRT=1
      LSTART=0
      LEND=0
C
C  For IFLAG=1 or 2, use two flags to decide whether blank should be
C  allowed as a delimitor between numbers.
C    INGEVR - negative number ever read
C    IBLEVR - blank ever used as delimitor
C
      INGEVR=0
      IBLEVR=0
C
C  Control returns to 8 to begin processing a new range
C
C     NSWTCH - switch to record processing of 2-component range.
C              1 - 1st number or MISSING, LOW, RES, read
C              2 - at minus sign
C              3 - 2nd number or HIGH, N read
C     ILOW   - indicates "LOW" read as part of range
C     IHIGH  - indicates "HIGH" read
C     IRES   - indicates "RES" read
C     INFLAG - indicates "N" read
C     IMSSNG - indicates "MISSING" read
C     IPLUS  - indicates "+" read
C
    8 CONTINUE
      NSWTCH=0
      ILOW=0
      IHIGH=0
      IRES=0
      INFLAG=0
      IMSSNG=0
      IPLUS=0
C
C  Control returns to 10 to continue processing a given range
C
   10 CONTINUE
      IF(IPT.GT.256) THEN
C
C  If at end of card, copy segment of range into TEMPLB, if appropriate
C
        IF(IFLAG.EQ.1.AND.LSTART.GT.0.AND.LEND.GT.0.AND.
     .     ILSTRT.LE.24.AND.LEVEL.LE.MAXTLB) THEN
          ILEND=ILSTRT+LEND-LSTART
          IF(ILEND.GT.24)ILEND=24
          LEND=LSTART+ILEND-ILSTRT
          TEMPLB(LEVEL)(ILSTRT:ILEND)=C(LSTART:LEND)
C
C  If space is available, add a single blank to mark end of line.
C
          IF(ILEND.LT.24)TEMPLB(LEVEL)(ILEND+1:ILEND+1)=' '
          LSTART=0
          LEND=0
          ILSTRT=ILEND+2
        END IF
        IF(.NOT.REFRSH(BASE)) THEN
          CALL FESTOP(160075)
        END IF
        IPT=1
C
C  Return to 10 to continue processing additional parts of this range.
C
        GO TO 10
      END IF
C
      CALL NBFIND(C(IPT:256),IPT,256,IPOS2)
      IPT=IPOS2
      IF(LSTART.EQ.0)LSTART=IPT
      IF(IPOS2.EQ.0) THEN
C
C  If remaining characters are blank, set IPT=257.  On return to 10
C  next record will be read.
C
        IPT=257
      ELSE IF(((IFLAG.EQ.1.OR.IFLAG.EQ.2).AND.C(IPT:IPT).EQ.'/').OR.
     .        (IFLAG.EQ.3.AND.C(IPT:IPT).EQ.',')) THEN
C
C  Increment level, first into NEWLVL, on encountering delimitor
C
        NEWLVL=NEWLVL+1
        IPT=IPT+1
C
C  Transfer to 20 to conclude processing of range
C
        GO TO 20
      ELSE IF(C(IPT:IPT).EQ.',') THEN
C
C  After "," transfer to 20 to conclude processing of range
C
        LEND=IPT
        IPT=IPT+1
        GO TO 20
      ELSE IF(IFLAG.EQ.3.AND.C(IPT:IPT).EQ.'+') THEN
C
C  Record when encounter + and conclude processing of range
C
        LEND=IPT
        IPT=IPT+1
        IPLUS=1
        GO TO 20
      ELSE IF(C(IPT:IPT).EQ.'-') THEN
C
C  For minus, must differentiate whether dash separating 2 end points
C  of range or a minus sign connected with a number
C
        IF(NSWTCH.EQ.1) THEN
C
C  If NSWTCH = 1, previously have read first part of range, so
C  set to indicate dash separating parts.
C
          NSWTCH=2
          IPT=IPT+1
        ELSE
C
C  For NSWTCH=0 or =2, assume part of number.  Call DFIND to read.
C
          IF(NSWTCH.EQ.0) THEN
            CALL DFIND(IPT,IPOS2,DLOW,DLOW1,2)
          ELSE
            CALL DFIND(IPT,IPOS2,DHIGH,DHIGH1,1)
          END IF
          IF(IPOS2.GT.0) THEN
C
C  If encountered negative number, set INGEVR and check status of
C  IBLEVR.
C
            INGEVR=1
            IF(IBLEVR.EQ.1) THEN
              CALL FPSTOP(160081,IPT)
            END IF
            NSWTCH=NSWTCH+1
            IPT=IPOS2
          ELSE
C
C  If a number could not be read at this point, an error has occurred.
C
            CALL FPSTOP(160076,IPT)
          END IF
        END IF
        LEND=IPT-1
      ELSE IF(C(IPT:IPT).EQ.')'.OR.C(IPT:IPT).EQ.'}') THEN
C
C  If have read ending ")", must still process this range.
C
        IPOS=IPT+1
        NEWLVL=NEWLVL+1
        GO TO 20
      ELSE IF(NSWTCH.EQ.0) THEN
C
C  Options if the 1st element of the range has not been read.
C
        CALL DFIND(IPT,IPOS2,DLOW,DLOW1,1)
        IF(IPOS2.GT.0) THEN
C
C  If DFIND successfully read a number, set NSWTCH=1
C
          NSWTCH=1
          IPT=IPOS2
        ELSE
          CALL CMATCH(C(IPT:256),IPT,256,'LOW',3,IPOS2,1)
          IF(IPOS2.GT.0) THEN
            ILOW=1
          ELSE
            CALL CMATCH(C(IPT:256),IPT,256,'RES',3,IPOS2,1)
            IF(IPOS2.EQ.0) THEN
              CALL CMATCH(C(IPT:256),IPT,256,'MISSING',7,IPOS2,1)
              IF(IPOS2.EQ.0) THEN
C
C  Within this IF block, identifying error and ending
C
                CALL CMATCH(C(IPT:256),IPT,256,'HIGH',4,IPOS2,1)
                IF(IPOS2.GT.0) THEN
                  CALL FPSTOP(160078,IPT)
                END IF
                CALL CMATCH(C(IPT:256),IPT,256,'N',1,IPOS2,1)
                IF(IPOS2.GT.0) THEN
                  CALL FPSTOP(160078,IPT)
                END IF
                CALL FPSTOP(160077,IPT)
C
C  End of processing of errors
C
              END IF
              IMSSNG=1
            ELSE
              IRES=1
            END IF
          END IF
          IPT=IPOS2
C
C  NSWTCH=1 if MISSING, LOW, or RES read
C
          NSWTCH=1
        END IF
        LEND=IPT-1
      ELSE IF(NSWTCH.EQ.2) THEN
        CALL DFIND(IPT,IPOS2,DHIGH,DHIGH1,2)
        IF(IPOS2.GT.0) THEN
C
C  If DFIND successfully read a number, set NSWTCH=3
C
          NSWTCH=3
          IPT=IPOS2
        ELSE
          CALL CMATCH(C(IPT:256),IPT,256,'HIGH',4,IPOS2,1)
          IF(IPOS2.GT.0) THEN
            IHIGH=1
          ELSE
            CALL CMATCH(C(IPT:256),IPT,256,'N',1,IPOS2,1)
            IF(IPOS2.EQ.0) THEN
C
C  Within this IF block, identifying error and ending
C
              CALL CMATCH(C(IPT:256),IPT,256,'LOW',3,IPOS2,1)
              IF(IPOS2.GT.0) THEN
                CALL FPSTOP(160080,IPT)
              END IF
              CALL CMATCH(C(IPT:256),IPT,256,'RES',3,IPOS2,1)
              IF(IPOS2.GT.0) THEN
                CALL FPSTOP(160080,IPT)
              END IF
              CALL CMATCH(C(IPT:256),IPT,256,'MISSING',7,IPOS2,1)
              IF(IPOS2.GT.0) THEN
                CALL FPSTOP(160080,IPT)
              END IF
              CALL FPSTOP(160079,IPT)
            END IF
C
C  End of processing of errors
C
            INFLAG=1
          END IF
          IPT=IPOS2
          NSWTCH=3
        END IF
        LEND=IPT-1
      ELSE IF(INGEVR.EQ.0.AND.(NSWTCH.EQ.1.OR.NSWTCH.EQ.3)) THEN
C
C  Tolerance for blank as a delimitor requires no previous appearance
C  of negative numbers
C
        IBLEVR=1
        GO TO 20
      ELSE
C
C  Error condition
C
        CALL DFIND(IPT,IPOS2,DHIGH,DHIGH1,2)
        IF(IPOS2.GT.0) THEN
          CALL FPSTOP(160082,IPT)
        ELSE
          CALL FPSTOP(160083,IPT)
        END IF
      END IF
C
C  Return to 10 to continue processing range
C
      GO TO 10
C
C  Processing of completed range
C
   20 CONTINUE
      N=N+1
      IF(N.GT.MAXRNG) THEN
        CALL FESTOP(160084)
      END IF
      IF(IFLAG.EQ.1.AND.LEVEL.LE.MAXTLB) THEN
C
C  For IFLAG=1, copy remaining segment of the range into the label
C
        IF(LSTART.GT.0.AND.LEND.GT.0.AND.ILSTRT.LE.24) THEN
          ILEND=ILSTRT+LEND-LSTART
          IF(ILEND.GT.24)ILEND=24
          LEND=LSTART+ILEND-ILSTRT
          TEMPLB(LEVEL)(ILSTRT:ILEND)=C(LSTART:LEND)
          ILSTRT=ILEND+1
        END IF
C
C  If have encountered a new level, fill remaining space with blanks.
C
        IF(NEWLVL.NE.LEVEL) THEN
          CALL STBLNK(TEMPLB(LEVEL),ILSTRT,24)
C         IF(ILSTRT.LE.24) THEN
C           DO 22 I=ILSTRT,24
C           TEMPLB(LEVEL)(I:I)=' '
C  22       CONTINUE
C         END IF
          ILSTRT=1
        END IF
        LSTART=0
        LEND=0
      END IF
      RGRPT(N)=LEVEL
      NSAVE=N
C
C  Range type
C  1  value1 - value2
C  2  LOW - value
C  3  value - HIGH
C  4  LOW - HIGH
C  5  MISSING
C  6  value - n
C
      IF(IRES.EQ.1.OR.(ILOW.EQ.1.AND.IHIGH.EQ.1)) THEN
        RTYPET(N)=4
      ELSE IF(IMSSNG.EQ.1) THEN
        RTYPET(N)=5
      ELSE IF(NSWTCH.EQ.3) THEN
C
C  For ranges with 2 components.
C
        IF(ILOW.EQ.1) THEN
          RTYPET(N)=2
        ELSE
          RTYPET(N)=1
          IF(DLOW.LT.0.)DLOW=DLOW1
          IF(DLOW.LT.0.) THEN
            DLOW=DABOVE(DLOW)
          ELSE
            DLOW=DBELOW(DLOW)
          END IF
          RANGET(1,N)=DLOW
        END IF
        IF(IHIGH.EQ.1) THEN
          RTYPET(N)=3
        ELSE IF(INFLAG.EQ.1) THEN
          RTYPET(N)=6
        ELSE
          IF(DHIGH.LT.0.)DHIGH1=DHIGH
          IF(DHIGH.GE.0.) THEN
            DHIGH1=DBELOW(DHIGH1)
          ELSE
            DHIGH1=DABOVE(DHIGH1)
          END IF
          RANGET(2,N)=DHIGH1
        END IF
      ELSE IF(NSWTCH.EQ.1.OR.NSWTCH.EQ.2) THEN
C
C  For ranges with a single component.
C
        IF(ILOW.GT.0) THEN
          CALL FESTOP(160085)
        END IF
        RANGET(1,N)=DLOW-1.0D-12
        RANGET(2,N)=DLOW+1.0D-12
        RTYPET(N)=1
      ELSE
C
C  If NSWTCH=0, do not store.
C
        N=N-1
      END IF
C
C  For IFLAG=3, Add 6 to the code unless NSWTCH=0 if range is followed
C  by a plus.
C
      IF(N.EQ.NSAVE.AND.IFLAG.EQ.3.AND.IPLUS.EQ.1)RTYPET(N)=RTYPET(N)+6
      IF(C(IPT:IPT).EQ.')'.OR.C(IPT:IPT).EQ.'}')RETURN
      LEVEL=NEWLVL
      GO TO 8
      END
C
      SUBROUTINE STBLNK(C,ISTART,IEND)
      INTEGER ISTART,IEND
      CHARACTER *(*) C
      IF(ISTART.LE.IEND) THEN
        DO 1 I=ISTART,IEND
        C(I:I)=' '
    1   CONTINUE
      END IF
      RETURN
      END
C
      SUBROUTINE VNFIND(BASE,VNAMET,MAXVN,N,IPOS,IFLAG,VNAME,NVIN)
C
      INTEGER BASE,MAXVN,N,IPOS,IFLAG,NVIN
      INTEGER VNLEN,MVIN
      PARAMETER (VNLEN=12)
      PARAMETER (MVIN=500)
      CHARACTER *12 VNAMET(MAXVN),VNAME(MVIN)
C
C  BASE   - starting position in C (CARD) to search, reset to 1 if
C           additional lines read.
C  VNAMET - character array to receive resulting names
C  MAXVN  - size of VNAMET
C  N      - resulting number of names found
C  IPOS   - ending position
C  IFLAG  - governs conventions.
C           1 - read variable names, but do not allow "--" convention
C               (e.g. with INPUT statement).  If "--" encountered,
C               attempt to interpret it as single "-"
C           2 - implement the "--" convention for variable names.
C           3 - return only the first variable name found
C  VNAME  - existing variable names (used for "--")
C  NVIN   - number of existing variables (may be 0)
C
      CHARACTER*256 C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      COMMON /CRDBLK/C
      LOGICAL ALPCHK,DGTCHK,REFRSH
      EXTERNAL ALPCHK,DGTCHK,REFRSH
      CHARACTER*1 DIGIT(10)
      DATA DIGIT /'0','1','2','3','4','5','6','7','8','9'/
C
  104 FORMAT(' INVALID RANGE: VARIABLE NAME: ',A12,' NOT PREVIOUSLY DEF'
     .,'INED')
  105 FORMAT(' NAME EXCEEDS 12 CHARACTERS: ',A13)
  106 FORMAT(5X,'Note: The leading ''0'' in ',A12,' may cause a difficu'
     .,'lty',/,11x,'in expanding the range')
C
      IPOS=BASE
      N=0
    8 CONTINUE
C
C  NSWTCH - keeps tract of status
C         = 0  no names read
C         = 1  one name read, could be beginning of range of names.
C         = 2  both beginning and ending names of range now read.
C  NMINUS - count of current minus signs - destinguish "-" from "--"
C  ISTART - character position of start of current name
C
      NSWTCH=0
      NMINUS=0
    9 CONTINUE
      ISTART=0
      GO TO 11
C
C  Transfers to 10 increment IPOS, looking at next character.
C
   10 CONTINUE
      IPOS=IPOS+1
C
C  Transfers to 11 review same character.
C
   11 CONTINUE
C
C  Decision on reading more names.
C
      IF(ISTART.EQ.0.AND.IPOS.GT.256) THEN
        IPOS=0
        IF(.NOT.REFRSH(BASE))RETURN
        IPOS=1
C
C  Transfer to 11 to begin scanning new record.
C
        GO TO 11
      END IF
C
C  If name currently under way is too long, stop
C
      IF(ISTART.GT.0) THEN
        IF(IPOS.GT.256)GO TO 20
        IF(IPOS-ISTART.GE.VNLEN) THEN
          IF(ALPCHK(C(IPOS:IPOS)).OR.DGTCHK(C(IPOS:IPOS))) THEN
            WRITE(U6,105)C(ISTART:IPOS)
            CALL FPSTOP(160140,IPOS)
          END IF
C
C  Transfer to 20 to conclude processing name
C
          GO TO 20
        END IF
      END IF
      IF(ALPCHK(C(IPOS:IPOS))) THEN
        IF(ISTART.EQ.0)ISTART=IPOS
C
C  Return to 10 will increment IPOS
C
        GO TO 10
      END IF
      IF(ISTART.EQ.0) THEN
        IF(C(IPOS:IPOS).EQ.' '.OR.C(IPOS:IPOS).EQ.',') THEN
          GO TO 10
        ELSE IF(C(IPOS:IPOS).EQ.'-') THEN
C
C  Encountering a minus here is an error.
C
          CALL FPSTOP(160141,IPOS)
        ELSE
C
C  Return if not in process of reading name.
C
          RETURN
        END IF
      ELSE IF(DGTCHK(C(IPOS:IPOS))) THEN
C
C  Check for digit as part of name.  Transfer to 10 continues reading.
C
        GO TO 10
      END IF
   20 CONTINUE
      NSWTCH=NSWTCH+1
      N=N+1
      IF(N.GT.MAXVN) THEN
C
C  For too many names.
C
        CALL FESTOP(160142)
      END IF
C
C  Copy current name into VNAMET
C
      J=1
      DO 22 I=ISTART,IPOS-1
      VNAMET(N)(J:J)=C(I:I)
      J=J+1
   22 CONTINUE
      CALL STBLNK(VNAMET(N),J,VNLEN)
C     IF(J.LE.VNLEN) THEN
C       DO 24 I=J,VNLEN
C       VNAMET(N)(I:I)=' '
C  24   CONTINUE
C     END IF
C
C  If IFLAG=3, interested only in a single name.
C
      IF(IFLAG.EQ.3) RETURN
C
C  If NSWTCH=1, look for "-" or "--"
C
      IF(NSWTCH.EQ.1) THEN
   26   CONTINUE
        IF(IPOS.GT.256) GO TO 30
        DO 28 IPOS=IPOS,256
        IF(C(IPOS:IPOS).EQ.' '.OR.C(IPOS:IPOS).EQ.',') THEN
          GO TO 28
        ELSE IF(C(IPOS:IPOS).EQ.'-') THEN
          NMINUS=NMINUS+1
        ELSE IF(NMINUS.GE.1) THEN
C
C  If have read one or more minuses, transfer to 9 to begin searching
C  for second name to end the range.
C
          GO TO 9
        ELSE
C
C  Otherwise, transfer to 8 resets NSWTCH.
C
          GO TO 8
        END IF
   28   CONTINUE
   30   CONTINUE
        IPOS=0
        IF(.NOT.REFRSH(BASE))RETURN
        IPOS=1
        GO TO 26
      ELSE
        IF(IFLAG.EQ.2.AND.NMINUS.GE.2) THEN
C
C  Implementation of "--" syntax, to define a group of variables
C  based on their previous order of appearance.
C
C  N1 points to name before "--"
C
          N1=N-1
          DO 31 I=1,NVIN
          CALL CMATCH(VNAMET(N1),1,12,VNAME(I),12,IPOS2,1)
          IF(IPOS2.GT.0) THEN
            IEND1=I
            GO TO 32
          END IF
   31     CONTINUE
          WRITE(U6,104)VNAMET(N1)
          CALL FESTOP(160143)
   32     CONTINUE
          DO 33 I=1,NVIN
          CALL CMATCH(VNAMET(N),1,12,VNAME(I),12,IPOS2,1)
          IF(IPOS2.GT.0) THEN
            IEND2=I
            GO TO 34
          END IF
   33     CONTINUE
          WRITE(U6,104)VNAMET(N)
          CALL FESTOP(160143)
   34     CONTINUE
          IF(IEND2-IEND1+N-1.GT.MAXVN) THEN
            CALL FESTOP(160142)
          END IF
          N=N-2
          DO 38 I=IEND1,IEND2
          N=N+1
          VNAMET(N)=VNAME(I)
   38     CONTINUE
        ELSE IF(NMINUS.GE.1) THEN
C
C  For interpretation of "-" ranges.
C
C  Find last characters, IEND1 and IEND2, in VNAMET(N1) and VNAMET(N)
C  that are not digits.
C
          IEND1=0
          IEND2=0
          N1=N-1
          DO 42 I=VNLEN,1,-1
          IF(VNAMET(N1)(I:I).NE.' '.AND..NOT.DGTCHK(VNAMET(N1)(I:I)))
     .        THEN
            IF(IEND1.EQ.0)IEND1=I
          END IF
          IF(VNAMET(N)(I:I).NE.' '.AND..NOT.DGTCHK(VNAMET(N)(I:I))) THEN
            IF(IEND2.EQ.0)IEND2=I
          END IF
   42     CONTINUE
C
          IF(IEND1.EQ.0.OR.IEND1.EQ.VNLEN.OR.IEND1.NE.IEND2) THEN
            IF(IFLAG.EQ.2.AND.NMINUS.GT.1) THEN
              CALL FESTOP(160144)
            ELSE
              CALL FESTOP(160145)
            END IF
          END IF
C
C  Check that names begin with same stem.
C
          CALL CMATCH(VNAMET(N1),1,IEND1,VNAMET(N),IEND1,IPOS2,2)
          IF(IPOS2.EQ.0) THEN
            CALL FESTOP(160145)
          END IF
C
C  Translate ending digits into numbers.
C
          IEND1=IEND1+1
          CALL IFIND(VNAMET(N1)(IEND1:VNLEN),IEND1,VNLEN,IPOS2,IVAL1)
          IF(IPOS2.EQ.0) THEN
C
C  Just in case, error message for inability to extract IVAL1.  This
C  should not occur, however, since should be looking only at digits,
C  unless there are no concluding digits.
C
            CALL FESTOP(160146)
          ELSE IF(VNAMET(N1)(IEND1:IEND1).EQ.'0'.AND.IVAL1.NE.0) THEN
            WRITE(U6,106)VNAMET(N1)
          END IF
          CALL IFIND(VNAMET(N)(IEND1:VNLEN),IEND1,VNLEN,IPOS2,IVAL2)
          IF(IPOS2.EQ.0) THEN
C
C  Just in case, error message for inability to extract IVAL2.  This
C  should not occur, however, since should be looking only at digits,
C  unless there are no concluding digits.
C
            CALL FESTOP(160146)
          END IF
          IF(IVAL1.GT.IVAL2) THEN
C
C  Error message for IVAL1 > IVAL2.
C
            CALL FESTOP(160147)
          ELSE IF(VNAMET(N)(IEND1:IEND1).EQ.'0') THEN
            WRITE(U6,106)VNAMET(N)
          END IF
          IF(IVAL2-IVAL1+N-1.GT.MAXVN) THEN
            CALL FESTOP(160142)
          END IF
          N=N-1
C
C  Fill in all the implied values.
C
          DO 48 I=IVAL1+1,IVAL2
          N=N+1
          VNAMET(N)(1:IEND2)=VNAMET(N1)(1:IEND2)
          I10=1
   44     CONTINUE
          IF(I10*10.LE.I) THEN
            I10=I10*10
            GO TO 44
          END IF
          K=I
          J=IEND1
   46     CONTINUE
          L=K/I10
          K=K-I10*L
          I10=I10/10
          VNAMET(N)(J:J)=DIGIT(L+1)
          J=J+1
          IF(I10.GT.0)GO TO 46
          CALL STBLNK(VNAMET(N),J,VNLEN)
C         IF(J.LE.VNLEN) THEN
C           DO 47 L=J,VNLEN
C           VNAMET(N)(L:L)=' '
C  47       CONTINUE
C         END IF
   48     CONTINUE
        END IF
      END IF
      GO TO 8
      END
C
      SUBROUTINE VNMTCH(VNAMET,VA,NVA,NUM)
C
      INTEGER NVA,NUM
      CHARACTER*12 VA(*)
      CHARACTER*(*) VNAMET
C
C  VNAMET - variable name to look for
C  VA     - array of variable names to search
C  NVA    - number of names in VA
C  NUM    - number of name in VA that is matched - 0 otherwise
C
C  This routine searches for the variable name VNAMET in the array
C  VA(NVA)
C
      DO 1 I=1,NVA
      CALL CMATCH(VNAMET,1,12,VA(I),12,IPOS,1)
      IF(IPOS.GT.0) THEN
        NUM=I
        RETURN
      END IF
    1 CONTINUE
      NUM=0
      RETURN
      END
C
      SUBROUTINE VTSCAN(BASE,VNAME,MTYPE,MSIZE,CDMPNT,CROSSD,NVIN,
     . VTEMP,VTMPSZ,VLIST,TTYPE,LEN,MXVLST,IV,LTOT,IPOSN,IERR)
C
      INTEGER BASE,MTYPE(*),MSIZE(*),CDMPNT(*),CROSSD(*),NVIN
      INTEGER VTMPSZ,MXVLST,IV,LTOT,IPOSN,IERR
      INTEGER VLIST(MXVLST),TTYPE(MXVLST),LEN(MXVLST)
      CHARACTER*12 VNAME(*),VTEMP(VTMPSZ)
C
C  BASE   -  starting position, reset to 1 if another record read
C  VNAME  -  variable names
C  MTYPE  -  variable types
C  MSIZE  -  variable sizes
C  CDMPNT -  pointer to CROSSD
C  CROSSD -  dimensions of crossed variables
C  NVIN   -  number of variables
C  VTEMP  -  work array of variable names
C  VTMPSZ -  size of VTEMP
C  VLIST  -  array of variables
C  TTYPE  -  array of transformation types, see below
C  LEN    -  lengths of transformed variables (ignoring
C            cross-classifications by CLASS variables)
C  MXVLST -  maximum length of VLIST, TTYPE, and LEN
C  IV     -  number of variables/transformed variables
C  LTOT   -  total length specified
C  IPOSN  -  position of next nonblank character, 0 if
C            end of file or next command line
C  IERR   -  0 no error detected
C            1 unrecognized variable
C            2 probable error in returned position or other
C              problem of interpretation
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
      LOGICAL REFRSH
      EXTERNAL REFRSH
C
      CHARACTER*11 CTYPE(6)
      DATA CTYPE / 'PERCENT1   ','TOTAL1     ','PERCENT2   ',
     .             'PROPORTION ','PROPORTION1','N          '/
C
  200 FORMAT(' ERROR IN SPECIFICATION')
  201 FORMAT(' UNRECOGNIZED VARIABLE NAME: ',A12)
  202 FORMAT(/,1X,A12,' MAY NOT BE USED WITH ',A11)
  203 FORMAT(/,' WORK SPACE OF',I8,' EXCEEDED')
C
      IERR=0
C
C  IV    - cumulative index of number of variables found by VTSCAN.
C  ITYPE - holds current function status
C
      IV=0
      ITYPE=0
      LTOT=0
      CALL VNFIND(BASE,VTEMP,VTMPSZ,N,IPOSN,2,VNAME,NVIN)
      IF(N.EQ.0) GO TO 50
   11 CONTINUE
      DO 16 IV0=1,N
C
C  Function type
C
C  0  -  Default
C  1  -  Percent or Mean
C  2  -  Total
C  3  -  Percent1
C  4  -  Total1
C  5  -  Percent2
C  6  -  Proportion
C  7  -  Proportion1
C  8  -  N of a variable
C  9  -  N of a block
C 10  -  Value of a variable, i.e., without indicators
C
C  The last "variable" read by VNFIND may be a function -
C  check this first for IV0 = N
C
      IF(ITYPE.EQ.0.AND.IV0.EQ.N.AND.IPOSN.GT.0) THEN
        CALL CMATCH(VTEMP(IV0),1,12,'MEAN',4,IPOS,1)
        IF(IPOS.GT.0) THEN
          ITYPE=1
        END IF
        CALL CMATCH(VTEMP(IV0),1,12,'MEANS',5,IPOS,1)
        IF(IPOS.GT.0) THEN
          ITYPE=1
        END IF
        CALL CMATCH(VTEMP(IV0),1,12,'PERCENT',7,IPOS,1)
        IF(IPOS.GT.0) THEN
          ITYPE=1
        END IF
        CALL CMATCH(VTEMP(IV0),1,12,'PERCENTS',8,IPOS,1)
        IF(IPOS.GT.0) THEN
          ITYPE=1
        END IF
        CALL CMATCH(VTEMP(IV0),1,12,'TOTAL',5,IPOS,1)
        IF(IPOS.GT.0) THEN
          ITYPE=2
        END IF
        CALL CMATCH(VTEMP(IV0),1,12,'TOTALS',6,IPOS,1)
        IF(IPOS.GT.0) THEN
          ITYPE=2
        END IF
        CALL CMATCH(VTEMP(IV0),1,12,'PERCENT1',8,IPOS,1)
        IF(IPOS.GT.0) THEN
          ITYPE=3
        END IF
        CALL CMATCH(VTEMP(IV0),1,12,'TOTAL1',6,IPOS,1)
        IF(IPOS.GT.0) THEN
          ITYPE=4
        END IF
        CALL CMATCH(VTEMP(IV0),1,12,'PERCENT2',8,IPOS,1)
        IF(IPOS.GT.0) THEN
          ITYPE=5
        END IF
        CALL CMATCH(VTEMP(IV0),1,12,'PROPORTION',10,IPOS,1)
        IF(IPOS.GT.0) THEN
          ITYPE=6
        END IF
        CALL CMATCH(VTEMP(IV0),1,12,'PROPORTIONS',11,IPOS,1)
        IF(IPOS.GT.0) THEN
          ITYPE=6
        END IF
        CALL CMATCH(VTEMP(IV0),1,12,'PROPORTION1',11,IPOS,1)
        IF(IPOS.GT.0) THEN
          ITYPE=7
        END IF
        CALL CMATCH(VTEMP(IV0),1,12,'N',1,IPOS,1)
        IF(IPOS.GT.0) THEN
          ITYPE=8
        END IF
        CALL CMATCH(VTEMP(IV0),1,12,'VALUE',5,IPOS,1)
        IF(IPOS.GT.0) THEN
          ITYPE=10
        END IF
        CALL CMATCH(VTEMP(IV0),1,12,'VALUES',6,IPOS,1)
        IF(IPOS.GT.0) THEN
          ITYPE=10
        END IF
   12   CONTINUE
C
C  When one of the recognized functions is not followed by "(", r
C  reinterpret the function name as a possible variable name.
C
        IF(ITYPE.NE.0) THEN
          CALL NBFND2(IPOSN,IPOS2)
          IF(IPOSN.EQ.1)BASE=1
          IF(IPOS2.EQ.0) THEN
            IPOSN=0
          ELSE
            IF(CARD(IPOS2:IPOS2).EQ.'(') THEN
              IPOSN=IPOS2
C
C  If a function has been confirmed, skip to the end of the loop
C
              GO TO 16
            ELSE
              ITYPE=0
            END IF
          END IF
        END IF
      END IF
C
C  IV1 - index of variable in list of defined variables
C
      IF(NVIN.GT.0) THEN
        CALL VNMTCH(VTEMP(IV0),VNAME,NVIN,IV1)
      ELSE
        IV1=0
      END IF
C
C  IVS - saves current value of IV
C
      IVS=IV
      IF(IV.GE.MXVLST) THEN
        WRITE(U6,203)MXVLST
        CALL FESTOP(160170)
      END IF
C
      IF(IV1.GT.0) THEN
        IV=IV+1
        VLIST(IV)=IV1
        TTYPE(IV)=ITYPE
C
C  Translate VALUE into TOTAL for MTYPE < 10
C
        IF(ITYPE.EQ.10) THEN
          IF(MTYPE(IV1).LT.10) THEN
            TTYPE(IV)=2
          END IF
C
C  Translate TOTAL into VALUE for MTYPE > 10
C
        ELSE IF(ITYPE.EQ.2) THEN
          IF(MTYPE(IV1).GT.10) THEN
            TTYPE(IV)=10
          END IF
        END IF
C
C  Calculation of the length of the transformed variable
C
        IF(ITYPE.EQ.0) THEN
C
C  Length of default is MSIZE
C
          LEN(IV)=MSIZE(IV1)
        ELSE IF(TTYPE(IV).EQ.1.OR.TTYPE(IV).EQ.2.OR.
     .      TTYPE(IV).EQ.10) THEN
C
C  For PERCENT, MEAN, TOTAL, VALUE, adjust MSIZE for real with
C  missing and crossed real variables
C
          IF(MTYPE(IV1).EQ.2.OR.MTYPE(IV1).EQ.8) THEN
            LEN(IV)=MSIZE(IV1)/2
          ELSE
            LEN(IV)=MSIZE(IV1)
          END IF
        ELSE IF(ITYPE.EQ.3.OR.ITYPE.EQ.4.OR.ITYPE.EQ.7) THEN
C
C  PERCENT1, MEAN1, PROPORTION1
C
          IF(MTYPE(IV1).EQ.3) THEN
            IF(MSIZE(IV1).GT.1) THEN
              LEN(IV)=MSIZE(IV1)-1
            ELSE
C
C  If MSIZE=1, redefine transformation.
C
              LEN(IV)=1
              IF(ITYPE.EQ.3.OR.ITYPE.EQ.4) THEN
                TTYPE(IV)=ITYPE-2
              ELSE
                TTYPE(IV)=ITYPE-1
              END IF
            END IF
          ELSE IF(MTYPE(IV1).EQ.9) THEN
            K=CROSSD(CDMPNT(IV1)+1)
            IF(K.EQ.1) THEN
              LEN(IV)=MSIZE(IV1)
              IF(ITYPE.EQ.3.OR.ITYPE.EQ.4) THEN
                TTYPE(IV)=ITYPE-2
              ELSE
                TTYPE(IV)=ITYPE-1
              END IF
            ELSE
              LEN(IV)=((K-1)*MSIZE(IV1))/K
            END IF
          ELSE
C
C  PERCENT1, MEAN1, PROPORTION1 may only be used with CAT, or
C  CROSSED CAT
C
            IV=IV-1
            WRITE(U6,202)VNAME(IV1),CTYPE(ITYPE-2)
          END IF
        ELSE IF(ITYPE.EQ.5) THEN
C
C  PERCENT2
C
          IF(MTYPE(IV1).EQ.9) THEN
            LEN(IV)=MSIZE(IV1)
          ELSE
C
C  PERCENT2 may only be used with CROSSED CAT
C
            IV=IV-1
            WRITE(U6,202)VNAME(IV1),CTYPE(3)
          END IF
        ELSE IF(ITYPE.EQ.6) THEN
C
C  PROPORTION
C
          IF(MTYPE(IV1).EQ.3.OR.MTYPE(IV1).EQ.9) THEN
            LEN(IV)=MSIZE(IV1)
          ELSE
            IV=IV-1
            WRITE(U6,202)VNAME(IV1),CTYPE(4)
          END IF
        ELSE IF(ITYPE.EQ.8) THEN
C
C  N
c
          IF(MTYPE(IV1).EQ.2.OR.MTYPE(IV1).EQ.8) THEN
            LEN(IV)=MSIZE(IV1)/2
          ELSE IF(MTYPE(IV1).EQ.9) THEN
            K=CROSSD(CDMPNT(IV1)+1)
            LEN(IV)=MSIZE(IV1)/K
          ELSE IF(MTYPE(IV1).LT.10) THEN
            LEN(IV)=1
          ELSE
C
C  N may not be used with any form of DERIVED variables
C
            IV=IV-1
            WRITE(U6,202)VNAME(IV1),CTYPE(6)
          END IF
        END IF
C
C  Check here if a variable has been eliminated
C
        IF(IV.GT.IVS) THEN
          LTOT=LTOT+LEN(IV)
        ELSE
          IERR=1
        END IF
      ELSE
C
C  If have not matched to a defined variable
C
        WRITE(U6,201)VTEMP(IV0)
        IERR=1
      END IF
   16 CONTINUE
C
C  Arrive here after processing the list of variables returned by
C  VNFIND
C
   17 CONTINUE
      IF(IPOSN.GT.0) THEN
C
C  Examine next characters, if any
C
        CALL NBFND2(IPOSN,IPOS2)
        IF(IPOSN.EQ.1)BASE=1
        IF(IPOS2.GT.0) THEN
          IF(CARD(IPOS2:IPOS2).EQ.')') THEN
C
C  Interpret ")" as end of function range
C
            ITYPE=0
          ELSE IF(CARD(IPOS2:IPOS2).NE.'(') THEN
C
C  If not "(" or ")" transfer to 18 in preparation for return
C
            IPOSN=IPOS2
            GO TO 18
          END IF
          IPOSN=IPOS2+1
          IF(IPOSN.GT.256) THEN
            IF(.NOT.REFRSH(BASE)) THEN
              IPOSN=0
              GO TO 18
            ELSE
              IPOSN=1
            END IF
          END IF
          IPT=IPOSN
C
C  Call VNFIND to determine if scan should continue.
C
          CALL VNFIND(IPT,VTEMP,VTMPSZ,N,IPOS2,2,VNAME,NVIN)
          IPOSN=IPOS2
          IF(IPT.EQ.1)BASE=1
          IF(N.GT.0) THEN
C
C  Transfer to 11 if VNFIND has found variables.
C
            GO TO 11
          ELSE IF(ITYPE.EQ.8.AND.IPOSN.GT.0) THEN
C
C  Check here for N of a block - N(1) etc.
C
            CALL IFIND(CARD(IPT:256),IPT,256,IPOSN,IVALUE)
            IF(IPOSN.GT.0) THEN
              IV=IV+1
              LTOT=LTOT+1
              VLIST(IV)=IVALUE
              TTYPE(IV)=9
              LEN(IV)=1
              GO TO 17
            END IF
          END IF
        END IF
      END IF
   18 CONTINUE
      IF(IPOSN.LE.0) GO TO 50
   20 CONTINUE
      CALL NBFND2(IPOSN,IPOS2)
      IF(IPOSN.EQ.1)BASE=1
      IPOSN=IPOS2
   50 CONTINUE
C
C  Check that all function calls closed off
C
      IF(ITYPE.NE.0)IERR=2
      RETURN
      END
C
      DOUBLE PRECISION FUNCTION DABOVE(DVALUE)
C
      DOUBLE PRECISION DVALUE
C
C  This routine finds the next double precision value above
C  DVALUE, but uses the SAS convention of 1.0D-12 for integers,
C  that is, double precision values within 1.0D-12 of an integer
C
      DOUBLE PRECISION DTEMP,DTEMP1,DTEMP2,DINC
      LOGICAL ICHECK
      EXTERNAL ICHECK
      DTEMP=DVALUE
      IF(ICHECK(DTEMP,DTEMP1)) THEN
        DTEMP1=DTEMP1+1.0D-12
        IF(DTEMP.LT.DTEMP1)GO TO 20
      END IF
      DINC=1.
      DO 10 I=1,200
      DINC=DINC/2.0D0
      DTEMP2=DTEMP+DINC
      IF(DTEMP2.LE.DTEMP)GO TO 20
      DTEMP1=DTEMP2
   10 CONTINUE
   20 DABOVE=DTEMP1
      RETURN
      END
C
      DOUBLE PRECISION FUNCTION DBELOW(DVALUE)
C
      DOUBLE PRECISION DVALUE
C
C  This routine finds the next double precision value below
C  DVALUE, but uses the SAS convention of 1.0D-12 for integers,
C  that is, double precision values within 1.0D-12 of an integer
C
      DOUBLE PRECISION DTEMP,DTEMP1,DTEMP2,DINC
      LOGICAL ICHECK
      EXTERNAL ICHECK
      DTEMP=DVALUE
      IF(ICHECK(DTEMP,DTEMP1)) THEN
        DTEMP1=DTEMP1-1.0D-12
        IF(DTEMP.GT.DTEMP1)GO TO 20
      END IF
      DINC=1.
      DO 10 I=1,200
      DINC=DINC/2.0D0
      DTEMP2=DTEMP-DINC
      IF(DTEMP2.GE.DTEMP)GO TO 20
      DTEMP1=DTEMP2
   10 CONTINUE
   20 DBELOW=DTEMP1
      RETURN
      END
C
      LOGICAL FUNCTION ICHECK(DVALUE,DVALU2)
C
      DOUBLE PRECISION DVALUE,DVALU2
C
C  This routine implements the SAS convention for declaring
C  a double precision value within 1.0D-12 of an integer to
C  be that integer.
C
      IF(DVALUE.LT.0.) THEN
        DVALU2=DVALUE-1.0D-12
      ELSE
        DVALU2=DVALUE+1.0D-12
      END IF
      DVALU2=DINT(DVALU2)
      IF(DABS(DVALUE-DVALU2).LE.1.0D-12) THEN
        ICHECK=.TRUE.
      ELSE
        ICHECK=.FALSE.
      END IF
      RETURN
      END
C
C  End of SC.FOR
C
      SUBROUTINE SETUP1
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MIFLVL=7,IXFLLD=13-MIFLVL)
      PARAMETER (MAXFMT=20)
      PARAMETER (NOPTN1=3)
C
C  MVAR   represents the maximum number of incoming and created
C         variables, replicate factors and wts
C  MAXIDS is the maximum number of class variables
C  MRECOD is the maximum of variables transformed by CLASS, CAT
C         MISSING, SELECT, BY etc.
C  MRANGE is the maximum number of ranges
C  MRNSET is the maximum number of sets of ranges
C  MLEVEL is the maximum number of stored labels for levels
C  MCLBLK is the maximum number of class blocks
C  MCLBAR is the maximum number of cells of class block arrays
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
      INTEGER VTMPSZ
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
      PARAMETER (MAXSUB=500,MAXSBL=2000,MAXSNL=24)
      PARAMETER (MAXSBC=6000)
      PARAMETER (MAXALT=5)
      INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL),
     .   U5LCSW
      COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW
      INTEGER BASE
      LOGICAL REFRSH,ALPCHK,DGTCHK
      EXTERNAL REFRSH,ALPCHK,DGTCHK
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
C
C       NVTOT   (NTOTV)
C       NVREG   (IOUTC1)
C       NVARID  (NID1)
C
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1,
     . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX
C
      DOUBLE PRECISION RANGE(2,MRANGE)
      INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET),
     . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD),
     . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI)
C
      COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP,
     . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO,
     . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS,
     . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT,
     . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS,
     . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO,
     . NLEVEL,NRNSET,NRANGE,NHADAM,ISTEPC,IFLVL,IF1LST,IFLAST,NEWSYN,
     . IXFILL,SDSTCK,MSDPTH
      INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS,
     . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN,
     . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IFLAST(MIFLVL),
     . IXFILL(IXFLLD),SDSTCK,MSDPTH
C
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
C
C  Usage in this subroutine (CREATE):
C
C  BLVSTR  -  Pointer for block to VNKEEP, 0 if no definition
C             of block contents by a KEEP statement
C  BLVSIZ  -  number of variables for block in VNKEEP
C  BLNCLS  -  number of classes in block
C  BLCPNT  -  pointer for classes to CLTYPE
C  CLTYPE  -  used as pointers to class variables
C
      INTEGER ITYPEF(3),IFILEF(3)
      LOGICAL LTEMP
      INTEGER INDX1(NOPTN1)
      INTEGER IVAL1(NOPTN1)
      CHARACTER*12 OPTNW1(NOPTN1)
      DATA OPTNW1 /    'NPRINT      ','OBS         ','NOBS        '/
      DATA INDX1/1,2,2/
      DATA IVAL1/0,0,0/
C
  200 FORMAT(' ERROR IN SPECIFICATION')
  203 FORMAT(' THE FORMAT MUST BEGIN WITH ''(''')
  205 FORMAT(' UNRECOGNIZED VARIABLE NAME ',A12)
  210 FORMAT(' BY missing or unbalanced numbers of variables')
  211 FORMAT(' THIS VARIABLE IS NOT OF TYPE CLASS OR CATEGORICAL - ',A12
     .)
  212 FORMAT(' VARIABLE OF INAPPROPRIATE TYPE - ',A12)
  213 FORMAT(' A OR I EDIT DESCRIPTORS NOT ALLOWED IN THE FORMAT')
  215 FORMAT(' Variable already exists - ',A12)
  216 FORMAT(' COPY into a CLASS variable is not allowed')
  218 FORMAT(' BY variable of improper type')
  220 FORMAT(5X,'WARNING: COUNT OF CAT, CLASS, ETC. OPERATIONS TO CAT OR
     . CROSSED VAR:',I4)
  222 FORMAT(5X,'FOR REAL, REAL WITH MISSING, OR CROSSED REAL ONLY')
  223 FORMAT(' FORMAT ALREADY SPECIFIED')
  224 FORMAT(' MISSING FORMAT')
  225 FORMAT(' DUPLICATE INPUT')
  226 FORMAT(' *** KEY IGNORED - NO PREVIOUS VARIABLES')
  227 FORMAT(' KEY VARIABLE NOT ON INPUT LIST')
  228 FORMAT(' KEY VARIABLE NOT MATCHED TO PREVIOUS')
  229 FORMAT(' DUPLICATION: ',A12)
  230 FORMAT(' MISSING INPUT')
  232 FORMAT(/,1X,I7,' variables are specified')
  233 FORMAT(5X,'Not permitted within IF block')
  234 FORMAT(5X,'Unbalanced IFs')
  238 FORMAT(' ONLY FOR REWEIGHT')
  239 FORMAT(' DUPLICATE OUTPUT statement')
  240 FORMAT(' MISSING OUTPUT statement')
  241 FORMAT(5X,'Ignored for this step')
  242 FORMAT(' WARNING:  Not generated here, but may have been generated
     . earlier')
  247 FORMAT(' NO LINK TO BY VARIABLES')
  250 FORMAT(5X,'*** PRINT request',I5)
  251 FORMAT(' CONFLICT BETWEEN OLD AND NEW SYNTAX')
  252 FORMAT(' REDUNDANT CLASS SPECIFICATION')
  253 FORMAT(' NOT A CLASS VARIABLE: ',A12)
C
      RCEIL(1)=MSIZEI
      MSDPTH=0
      SDSTCK=0
      IFLVL=0
      IVZERO=0
      IFLOW=0
      IFHIGH=0
      IFOUTL=0
      IFOUTH=0
      IRCINP=0
      IRCTIN=40
      IUINPT=12
      NVIN=0
      NRECOD=0
      NRANGE=0
      NRNSET=0
      NLEVEL=0
      NHADAM=0
      NKEEP=0
      VKEEPF=0
      IREPF=0
      IREPW=0
      IREPNO=0
      IWGT=0
      ISTRCD=0
      ISTRNO=0
      ISNDCD=0
      ISNDNO=0
      ICLUSC=0
      ICLUSN=0
      ICLCNT=0
      SISTRS=0
      SISNDS=0
      NISTRS=0
      NISNDS=0
      NDCOEF=0
      SDFPC1=0
      NDFPC1=0
      SDFPC2=0
      NDFPC2=0
      NREPW=0
      NOWGTF=0
      ICWARN=0
      IPREQ=0
      NEWSYN=0
      IOUTFV=0
      DO 3 I=1,MVAR
      MTYPE(I)=1
      MTSTRT(I)=1
      MSIZE(I)=1
      MXSIZE(I)=1
      CDMPNT(I)=0
      LPOINT(I)=0
    3 CONTINUE
C
C  Contents of MTYPE, codes for transformations
C     1  =  real variable
C     2  =  real variable with missing checks
C     3  =  categorical variable
C     4  =  class variable, known dimension
C     5  =  by variable, known dimension
C     6  =  by variable, unknown dimension
C     7  =  select transformation (not variable type)
C     8  =  cross variable, real value
C     9  =  cross variable, categorical
C    10  =  copy (not variable type)
C    21  =  boolean                 "
C    22  =  boolean - no range      "
C    23  =  and (logical and)       "
C    24  =  or                      "
C    25  =  not                     "
C    26  =  add_ms                  "
C    27  =  subtract_ms             "
C    28  =  multiply_ms             "
C    29  =  divide_ms               "
C    30  =  add                     "
C    31  =  subtract                "
C    32  =  multiply                "
C    33  =  divide                  "
C    34  =  constants               "
C    35  =  if (else if)            "
C    36  =  go to                   "
C    40  =  initial read
C    41  =  input (link)
C    42  =  input with missing (link_missing)
C               v1        v2        v3        rstpnt
C             iuinpt    status   # input      # keys
C             1st v    start x   start fmt    # fmt
C             # print   #obs     file type
C             key x    match v   last key     var # of match v
C    43  =  add loop to replicate weights/factors
C               v1        v2        v3        rstpnt
C             1st rf/rw  # rf/rw   var
C    44  =  subtract loop to replicate weights/factors
C    45  =  multiply loop            "
C    46  =  divide   loop            "
C    47  =  output
C               v1        v2        v3        rstpnt
C            #output  point IX start fmt    # fmt
C
C  50-60 are during REWEIGHT only
C
C    50  =  add, 0 replicate,      using vplxin data
C               v1        v2        v3        rstpnt
C             1st op   target   vplxin v     #classes
C          for each class:
C               v1        v2        v3        rstpnt
C            class/cat           0 offset    increment
C
C    51  =  subtract, 0 replicate   using vplxin data
C    52  =  multiply, 0 replicate       "
C    53  =  divide, 0 replicate         "
C    54  =  add loop to replicate weights/factors, using vplxin
C               v1        v2        v3        rstpnt
C             1st rf/rw  # rf/rw  vplxin var  #classes
C          for each class:
C               v1        v2        v3        rstpnt
C            class/cat           0 offset    increment
C
C    55  =  subtract loop to replicate weights/factors, using vplxin
C    56  =  multiply loop            "                       "
C    57  =  divide   loop            "                       "
C
C    58  =  define repf based on var ids
C               v1        v2        v3       rstpnt
C            1st rf/rw  # rf/rw     wt      #var ids
C          for each id:
C               v1        v2        v3       rstpnt
C            variance id
C          for repw, v3 will give id of weight
C    60  =  check BY variables
C               v1        v2        v3       rstpnt
C                                           #BY vars
C          for each BY var:
C               v1        v2        v3       rstpnt
C              BY id                       loc in vid
C
C    61  =  define repf based on rows of Hadamard matrix and
C           coefficients
C               v1        v2        v3       rstpnt
C            1st rf/rw  # rf/rw     wt       #sets
C          for each set:
C               v1        v2        v3       rstpnt
C              row     coefficient
C          for repw, v3 will give id of weight
C
C    62  =  idchange to return 1 if change in variables
C               v1        v2        v3        rstpnt
C               0     idchange       0         # keys
C           for each key:
C                     match v    pointer to   var # of match v
C                                 last value
C
C    63 =   print
C               v1        v2        v3        rstpnt
C             # print   #obs     # list       # pointer to IX
C
C   100 =   store
C   101 =   load variable
C   102 =   add variable
C   103 =   subtract variable
C   104 =   multiply variable
C   105 =   divide variable
C   106 =   power variable
C   111 =   load constant
C   112 =   add constant
C   113 =   subtract constant
C   114 =   multiply constant
C   115 =   divide constant
C   116 =   power constant
C   122 =   add stack
C   123 =   subtract stack
C   124 =   multiply stack
C   125 =   divide stack
C   126 =   power stack
C
      CALL KYFIND(IKEY,IPT)
C
C  REWEIGHT, ISTEPC=2
C
      ITYPEF(1)=1
      IF(IKEY.EQ.109) THEN
        ISTEPC=2
        ITYPEF(2)=1
        ITYPEF(3)=2
        J=1
C
C  REPGEN, ISTEPC=3
C
      ELSE IF(IKEY.EQ.117.OR.IKEY.EQ.171) THEN
        ISTEPC=3
        ITYPEF(2)=1
        ITYPEF(3)=0
        J=1
C
C  CREATE, istepc=1
C
      ELSE
        ISTEPC=1
        ITYPEF(2)=2
        ITYPEF(3)=1
        J=7
      END IF
      CALL CRDPRN(3)
      CALL FNREAD(IPT,ITYPEF,IFILEF,J,IPOSSC)
      IF(IMERR1.GT.0) THEN
        CALL FSTOP
      END IF
C
      IF(IFILEF(1).EQ.0.OR.IFILEF(2).EQ.0.OR.
     .   (ISTEPC.EQ.2.AND.IFILEF(3).EQ.0))GO TO 95
      IF(ISTEPC.EQ.1) THEN
        IF(IFILEF(3).NE.0) THEN
          IOUTFV=ITYPEF(3)
        END IF
      ELSE
        IOUTFV=ITYPEF(2)
      END IF
      IF(ISTEPC.EQ.2) THEN
        CALL PREAMC
        IV=RCEIL(2)
C
C  Store the number of the block for each variable in MXSIZE
C
        DO 27 ICLBLK=1,NCLBLK
        IF(BLVSIZ(ICLBLK).GT.0) THEN
          DO 26 I=1,BLVSIZ(ICLBLK)
          IV=IV+1
          MXSIZE(IV)=ICLBLK
   26     CONTINUE
        END IF
   27   CONTINUE
        IRCOUT=0
        IBYCHK=0
        VTMPSZ=MVAR-SVTEMP+1
      ELSE
        NCLASS=0
        NRPTOT=0
        NCLBLK=1
        NCLBAR=0
        BLCPNT(1)=0
        BLNCLS(1)=0
        BLVSTR(1)=0
        BLVSIZ(1)=0
        SVTEMP=1
        VTMPSZ=MVAR
        SDCOEF=0
        NBY=0
        VROPTN=0
        NVREG=0
      END IF
      NCRSSD=0
      IF(IPOSSC.GT.0) THEN
        TSWTCH=2
        CALL STBLNK(CARD,1,IPOSSC)
        IPOSSC=IPOSSC+1
        U5LCSW=1
C                                  ! Reset U5LCSW used by REFRSH
        CALL CMPAR1(IX,IPOSSC)
        CALL NSETP1(IX(NLINE+NLINE2+1),IX,IX(NLINE+1),ITYPEF,IFILEF)
        RETURN
      END IF
    1 CONTINUE
      LTEMP=REFRSH(IPT)
    2 CONTINUE
      IF(U5END.GT.0) THEN
        IF(U5.GE.13.AND.U5.LE.17) THEN
          GO TO 1
        ELSE
          IKEY=0
          GO TO 90
        END IF
      END IF
      IBFLAG=0
      CALL KYFIND(IKEY,IPT)
      IF(IKEY.EQ.9.OR.IKEY.EQ.19) THEN
        IF(NEWSYN.EQ.1) THEN
          GO TO 98
        ELSE IF(NEWSYN.EQ.0) THEN
          NEWSYN=2
        END IF
      END IF
   65 CONTINUE
      IF(IKEY.GT.34) THEN
        IF(IKEY.NE.36.AND.IKEY.NE.52.AND.(IKEY.LT.69.OR.IKEY.GT.72)
     .     .AND.(IKEY.LT.92.OR.IKEY.GT.98).AND.IKEY.NE.118.AND.
     .          IKEY.NE.121.AND.IKEY.NE.156.AND.
     .     (IKEY.LT.100.OR.IKEY.GT.111.OR.IKEY.EQ.109))GO TO 90
      END IF
      IF(IBFLAG.EQ.0.AND.IKEY.NE.17)CALL CRDPRN(1)
      IF(IKEY.EQ.-1) THEN
        GO TO 2
C
C  For commands where further specification is expected, check that
C  additional information begins on this line or continuation.  IPT
C  will contain position of nonblank character.
C
      ELSE IF(IKEY.LE.13.OR.(IKEY.GE.15.AND.IKEY.LE.33.AND.IKEY.NE.17)
     .        .OR.IKEY.GE.110) THEN
        IF(IPT.LE.0) THEN
          IPT=20
          CALL NBFND2(IPT,IPOS)
          IF(IPOS.LE.0)GO TO 95
          IPT=IPOS
        END IF
      END IF
C
C  FORMAT, OUTFORMAT
C
      IF(IKEY.EQ.16.OR.IKEY.EQ.110) THEN
        IF(IKEY.EQ.110.AND.ISTEPC.EQ.1.AND.IOUTFV.EQ.0)GO TO 97
        CALL NBFND2(IPT,IPOS)
        IF(IPOS.EQ.0)GO TO 95
        IF(CARD(IPOS:IPOS).NE.'(') THEN
          WRITE(U6,203)
          GO TO 99
        END IF
        L=1
        IF(IKEY.EQ.16) THEN
          IF(IFLOW.GT.0) THEN
            WRITE(U6,223)
            GO TO 99
          END IF
          IF(IFOUTH.GT.IFHIGH)IFHIGH=IFOUTH
          CALL RINCR(11,IFHIGH,1)
          IFLOW=IFHIGH
          K=IFHIGH
        ELSE
          IF(IFOUTL.GT.0) THEN
            WRITE(U6,223)
            GO TO 99
          END IF
          IFOUTH=IFHIGH
          CALL RINCR(11,IFOUTH,1)
          IFOUTL=IFOUTH
          K=IFOUTH
        END IF
    5   CONTINUE
        DO 6 I=IPOS,256
        IF(CARD(I:I).EQ.'x') THEN
          CARD(I:I)='X'
        ELSE IF(CARD(I:I).EQ.'f') THEN
          CARD(I:I)='F'
        ELSE IF(CARD(I:I).EQ.'d') THEN
          CARD(I:I)='D'
        ELSE IF(CARD(I:I).EQ.'e') THEN
          CARD(I:I)='E'
        ELSE IF(CARD(I:I).EQ.'A'.OR.CARD(I:I).EQ.'a'.OR.
     .          CARD(I:I).EQ.'I'.OR.CARD(I:I).EQ.'i') THEN
          WRITE(U6,213)
          GO TO 99
        ELSE IF(CARD(I:I).EQ.' ') THEN
          GO TO 6
        END IF
        IF(L.GT.128) THEN
          L=1
          IF(IKEY.EQ.16) THEN
            CALL RINCR(11,IFHIGH,1)
          ELSE
            CALL RINCR(11,IFOUTH,1)
          END IF
          K=K+1
        END IF
        INFRMT(K)(L:L)=CARD(I:I)
        L=L+1
    6   CONTINUE
        IF(.NOT.REFRSH(BASE)) GO TO 2
        IPOS=1
        GO TO 5
C
C  Except for CREATE, skip SELECT, DROP, KEEP, and BLOCK
C
      ELSE IF(ISTEPC.NE.1.AND.(IKEY.EQ.9.OR.IKEY.EQ.18.OR.
     .       IKEY.EQ.19.OR.IKEY.EQ.34)) THEN
   62   CONTINUE
        IF(REFRSH(IPT)) GO TO 62
        IF(U5ECHO.EQ.1)WRITE(U6,241)
        GO TO 2
C
C  CLASS, CATEGORICAL, CAT, SELECT, MISSING, COPY, BOOLEAN, NOT,
C  IF, ELSE, ELSE IF, END, ENDIF
C
      ELSE IF((IKEY.GE.6.AND.IKEY.LE.10).OR.IKEY.EQ.33.OR.
     .    IKEY.EQ.92.OR.IKEY.EQ.95.OR.
     .    (IKEY.GE.104.AND.IKEY.LE.108)) THEN
        CALL SET1B(IKEY,IPT,VTMPSZ,ICWRNT,IPOS)
C
C  INPUT
C
      ELSE IF(IKEY.EQ.15) THEN
        IF(IRCINP.GT.0) THEN
          WRITE(U6,225)
          GO TO 99
        END IF
        IF(IFLVL.GT.0) THEN
          IVZERO=1
        END IF
        IRCINP=NRECOD+1
        CALL RINCR(4,NRECOD,3)
        RCTYPE(IRCINP)=IRCTIN
        V1(IRCINP)=IUINPT
        V2(IRCINP)=0
        RSTPNT(IRCINP)=0
        K=NVIN+1
        RCTYPE(IRCINP+1)=0
        V2(IRCINP+1)=NXPTD
        V1(NRECOD)=0
        V2(NRECOD)=0
        V3(NRECOD)=ITYPEF(1)
        RSTPNT(NRECOD)=0
        RCTYPE(NRECOD)=0
        J=RCEIL(2)-NVIN
        CALL VNFIND(IPT,VNAME(K),J,NVINPT,IPOS,1,VNAME,MVAR)
        IF(NVINPT.EQ.0)GO TO 95
        CALL RFADD(VNAME(K),NVINPT,J,1,IX,1)
        IF(U5ECHO.EQ.1)WRITE(U6,232)NVINPT
        V3(IRCINP)=NVINPT
        V1(IRCINP+1)=NXPTI
        CALL ROOMI(NVINPT)
        J=V1(IRCINP+1)
        DO 21 I=1,NVINPT
        IX(J)=K+I-1
        J=J+1
   21   CONTINUE
C
C  Set values for LINK_MISSING
C
        IF(IRCTIN.EQ.42) THEN
          DO 22 I=1,NVINPT
          MSIZE(K)=2
          MXSIZE(K)=2
          MTYPE(K)=2
          MTSTRT(K)=2
          K=K+1
   22     CONTINUE
        END IF
C
C  Look for keyed link or options
C
   23   CONTINUE
        IF(IPOS.GT.0) THEN
          IF(CARD(IPOS:IPOS).EQ.'/') THEN
            IPOS=IPOS+1
            CALL NBFND2(IPOS,IPOS2)
            IF(IPOS.EQ.1)IPT=1
            IF(IPOS2.GT.0) THEN
              IPOS=IPOS2
              CALL CMATCH(CARD(IPOS:256),IPOS,256,'KEY',3,IPOS2,1)
              IF(IPOS2.GT.0) THEN
                IPOS=IPOS2
                CALL NBFND2(IPOS,IPOS2)
                IF(IPOS.EQ.1)IPT=1
                IPOS=IPOS2
                J=RCEIL(2)-NVIN-NVINPT
                K=NVIN+NVINPT+1
                CALL VNFIND(IPOS,VNAME(K),J,L,IPOS2,1,VNAME,MVAR)
                IF(IPOS.EQ.1)IPT=1
                IPOS=IPOS2
                IF(L.GE.1) THEN
                  IF(NVIN.EQ.0) THEN
                    IF(U5ECHO.GT.0)WRITE(U6,226)
                  ELSE
C
C  Check that the keyed variable was included on the input list.
C
 
                    RSTPNT(IRCINP)=L
                    DO 71 I=1,L
                    CALL VNMTCH(VNAME(K+I-1),VNAME(NVIN+1),NVINPT,J)
                    IF(J.EQ.0) THEN
                      WRITE(U6,227)
                      GO TO 99
                    END IF
                    CALL RINCR(4,NRECOD,1)
                    RCTYPE(NRECOD)=0
                    V1(NRECOD)=NXPTD+J-1
C
C  Set the type of the keyed variable to 49.
C
                    MTYPE(NVIN+J)=49
                    V3(NRECOD)=NXPTD+NVINPT+I-1
C
C  Find the previous definition of the keyed variable and stop if not
C  previously defined.
C
                    CALL VNMTCH(VNAME(K+I-1),VNAME,NVIN,V2(NRECOD))
                    RSTPNT(NRECOD)=V2(NRECOD)
                    IF(V2(NRECOD).EQ.0) THEN
                      WRITE(U6,228)
                      GO TO 99
                    END IF
   71               CONTINUE
                  END IF
                  GO TO 23
                END IF
              ELSE
                CALL CMATCH(CARD(IPOS:256),IPOS,256,'OPTION',6,
     .             IPOS2,1)
                IF(IPOS2.EQ.0) THEN
                  CALL CMATCH(CARD(IPOS:256),IPOS,256,'OPTIONS',7,
     .               IPOS2,1)
                END IF
                IF(IPOS2.GT.0) THEN
                  IPOS=IPOS2
                  CALL NBFND2(IPOS,IPOS2)
                  IF(IPOS.EQ.1)IPT=1
                  IPOS=IPOS2
                  IX(NXPTI)=0
                  IX(NXPTI+1)=0
                  CALL OPTNTR(NOPTN1,INDX1,IVAL1,OPTNW1,IPOS,IPOS2,
     .                      IX(NXPTI))
                  V1(IRCINP+2)=IX(NXPTI)
                  V2(IRCINP+2)=IX(NXPTI+1)
                  IF(IPOS.EQ.1)IPT=1
                  IPOS=IPOS2
                  GO TO 23
                END IF
              END IF
              GO TO 95
            END IF
          END IF
        END IF
        L=NVINPT+RSTPNT(IRCINP)
        CALL ROOMD(L)
C
C  Check that variables have not previously appeared
C
        DO 72 I=1,NVINPT
        IF(MTYPE(NVIN+1).NE.49.AND.NVIN.GT.0) THEN
          CALL VNMTCH(VNAME(NVIN+1),VNAME,NVIN,J)
          IF(J.NE.0) THEN
            WRITE(U6,229)VNAME(NVIN+1)
            GO TO 99
          END IF
        END IF
        CALL RINCR(2,NVIN,1)
        LABEL(NVIN)(1:12)=VNAME(NVIN)
        LABEL(NVIN)(13:24)='            '
        CALL RFCHCK(1)
   72   CONTINUE
C
C  PRINT
C
C    63 =   print
C               v1        v2        v3        rstpnt
C             # print   #obs     # list       # pointer to IX
C             # req
C
      ELSE IF(IKEY.EQ.156) THEN
        IPREQ=IPREQ+1
        CALL RINCR(4,NRECOD,2)
        RCTYPE(NRECOD-1)=63
        V1(NRECOD-1)=0
        V2(NRECOD-1)=0
        RSTPNT(NRECOD-1)=NXPTI
        V1(NRECOD)=IPREQ
        RCTYPE(NRECOD)=0
        V2(NRECOD)=0
        V3(NRECOD)=0
        RSTPNT(NRECOD)=0
        K=NVIN+1
        J=RCEIL(2)-NVIN
        CALL VNFIND(IPT,VNAME(K),J,N,IPOS,1,VNAME,MVAR)
        IF(N.EQ.0)GO TO 95
        V3(NRECOD-1)=N
        CALL ROOMI(N)
C
C  Look for options
C
   73   CONTINUE
        IF(IPOS.GT.0) THEN
          IF(CARD(IPOS:IPOS).EQ.'/') THEN
            IPOS=IPOS+1
            CALL NBFND2(IPOS,IPOS2)
            IF(IPOS.EQ.1)IPT=1
            IF(IPOS2.GT.0) THEN
              IPOS=IPOS2
              CALL CMATCH(CARD(IPOS:256),IPOS,256,'OPTION',6,
     .            IPOS2,1)
              IF(IPOS2.EQ.0) THEN
                CALL CMATCH(CARD(IPOS:256),IPOS,256,'OPTIONS',7,
     .             IPOS2,1)
              END IF
              IF(IPOS2.GT.0) THEN
                IPOS=IPOS2
                CALL NBFND2(IPOS,IPOS2)
                IF(IPOS.EQ.1)IPT=1
                IPOS=IPOS2
                IX(NXPTI)=0
                IX(NXPTI+1)=0
                CALL OPTNTR(1,INDX1,IVAL1,OPTNW1,IPOS,IPOS2,
     .                      IX(NXPTI))
                V1(NRECOD-1)=IX(NXPTI)
                IF(IPOS.EQ.1)IPT=1
                IPOS=IPOS2
                GO TO 73
              END IF
              GO TO 95
            END IF
          END IF
        END IF
C
C  Build up list of variables in IX
C
        K=RSTPNT(NRECOD-1)
        DO 74 I=1,N
        CALL VNMTCH(VNAME(NVIN+I),VNAME,NVIN,J)
        IF(J.EQ.0) THEN
          WRITE(U6,205)VNAME(NVIN+I)
          GO TO 99
        END IF
        IX(K)=J
        K=K+1
   74   CONTINUE
        IF(U5ECHO.EQ.1)WRITE(U6,250)IPREQ
C
C  CROSS, ADD, SUBTRACT, MULTIPLY, DIVIDE, AND, OR
C  ADD_MS, SUBTRACT_MS, MULTIPLY_MS, DIVIDE_MS, RGENERATE,
C  IDCHANGE
C
      ELSE IF(IKEY.EQ.31.OR.(IKEY.GE.69.AND.IKEY.LE.72).OR.
     .    (IKEY.GE.100.AND.IKEY.LE.103).OR.IKEY.EQ.32.OR.
     .    IKEY.EQ.93.OR.IKEY.EQ.94.OR.IKEY.EQ.96) THEN
        CALL SET1C(IKEY,IPT,VTMPSZ,IBYCHK)
C
C  CONSTANT(S)
C
      ELSE IF(IKEY.EQ.52) THEN
        IBEYND=0
   53   CONTINUE
        L=SIZED-NXPTD+1
        CALL DASCAN(IPT,IPOS,DX(NXPTD),L,N)
        IF(IPT.EQ.1)IBEYND=1
        IF(N.GT.0.AND.IPOS.GT.0) THEN
          IPT=IPOS
          CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,K,IPOS,2,VNAME,NVIN)
          CALL RFADD(VTEMP(SVTEMP),K,VTMPSZ,2,IX,1)
          IF(K.NE.N+1)GO TO 95
          IF(IPT.EQ.1)IBEYND=1
          IPT=IPOS
          CALL VNMTCH('INTO ',VTEMP(SVTEMP),1,IINTO)
          IF(IINTO.EQ.0)GO TO 95
          DO 54 I=1,N
          IF(NVIN.GT.0) THEN
            CALL VNMTCH(VTEMP(I+SVTEMP),VNAME,NVIN,IV2)
          ELSE
            IV2=0
          END IF
          IF(IV2.EQ.0) THEN
            CALL RINCR(2,NVIN,1)
            IV2=NVIN
            VNAME(NVIN)=VTEMP(I+SVTEMP)
            LABEL(NVIN)(1:12)=VNAME(NVIN)
            LABEL(NVIN)(13:24)='            '
            CALL RFCHCK(1)
            IF(IFLVL.GT.0)IVZERO=1
          ELSE
            IF(IFLVL.GT.0.AND.MTYPE(IV2).NE.1.AND.MTYPE(IV2).LT.50)
     .        GO TO 96
          END IF
          IF(MTYPE(IV2).LT.50)MTYPE(IV2)=1
          MSIZE(IV2)=1
          LPOINT(IV2)=0
          CDMPNT(IV2)=0
          CALL RINCR(4,NRECOD,1)
          RSTPNT(NRECOD)=0
          RCTYPE(NRECOD)=34
          V1(NRECOD)=NXPTD+I-1
          V2(NRECOD)=IV2
          V3(NRECOD)=0
   54     CONTINUE
          CALL ROOMD(N)
          IF(IPT.NE.0)GO TO 53
        ELSE IF(N.GT.0.OR.IPOS.GT.0) THEN
          GO TO 95
        END IF
        IF(IBEYND.EQ.1) THEN
          IPT=1
        ELSE
          IPT=2
        END IF
C
C  SCRATCH1, SCRATCH2, SCRATCH3, SCRATCH4, SCRATCH5, BY,
C  REPLICATION (REP), UNWEIGHTED, DROP, KEEP, LABEL, LEVEL,
C  RENAME, REPLICATE, WEIGHT, STRATUM, CLUSTER, SECOND,
C  COEFFICIENT, FPC1, FPC2, HADAMARD
C
      ELSE IF(IKEY.LE.5.OR.(IKEY.GE.11.AND.IKEY.LE.14).OR.
     .   (IKEY.GE.18.AND.IKEY.LE.30).OR.IKEY.EQ.118) THEN
        CALL SET1A(IKEY,IPT,VTMPSZ,IPOS)
C
C  OUTPUT
C
      ELSE IF(IKEY.EQ.111.AND.(ISTEPC.NE.1.OR.IOUTFV.GT.0)) THEN
C       IF(NKEEP.GT.0) THEN
C         WRITE(U6,239)
C         GO TO 99
C       END IF
        J=MVAR-NKEEP
        CALL VNFIND(IPT,VNKEEP(NKEEP+1),J,N,IPOS,2,VNAME,NVIN)
        IF(N.LE.0)GO TO 95
        J=MVAR-NKEEP-N
        CALL RFADD(VNKEEP(NKEEP+1),N,J,2,IX,1)
        CALL RINCR(4,NRECOD,1)
        V1(NRECOD)=N
        V2(NRECOD)=NXPTI
        CALL ROOMI(1)
        IF(ISTEPC.EQ.1) THEN
          IX(NXPTI-1)=10
        ELSE
          IX(NXPTI-1)=11
        END IF
        CALL ROOMI(1)
        IX(NXPTI-1)=IOUTFV
        DO 61 I=1,N
        CALL ROOMI(1)
        CALL VNMTCH(VNKEEP(NKEEP+I),VNAME,NVIN,IX(NXPTI-1))
        IF(IX(NXPTI-1).EQ.0) THEN
          WRITE(U6,205)VNKEEP(NKEEP+I)
          GO TO 95
        END IF
   61   CONTINUE
        IRCOUT=NRECOD
        RCTYPE(NRECOD)=47
C
C  RGENERATE
C
      ELSE IF(IKEY.EQ.121) THEN
        CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,K,IPOS,2,VNAME,NVIN)
        J=NRECOD
        IF(K.GT.0) THEN
          CALL RFADD(VTEMP(SVTEMP),K,VTMPSZ,2,IX,1)
        END IF
        IF(J.EQ.NRECOD) THEN
          IF(U5ECHO.EQ.1)WRITE(U6,242)
        END IF
C
C  LINK, LINK_MISSING
C
      ELSE IF(IKEY.EQ.97.OR.IKEY.EQ.98) THEN
        GO TO 90
C
C  COMPUTE
C
      ELSE IF(IKEY.EQ.17) THEN
        TSWTCH=2
        CALL CMPAR1(IX,IPT)
        GO TO 1
C
C  BLOCK
C
      ELSE IF(IKEY.EQ.34) THEN
        CALL RINCR(8,NCLBLK,1)
        BLCPNT(NCLBLK)=0
        BLNCLS(NCLBLK)=0
        BLVSTR(NCLBLK)=0
        BLVSIZ(NCLBLK)=0
C
C  Determine if any remaining information on the record suggests
C  the old or new syntax.
 
        IF(IPT.EQ.0) THEN
          CALL NBFND2(IPT,IPOS)
        ELSE
          IPOS=IPT
        END IF
        IF(IPOS.EQ.0) THEN
          IBTYPE=1
        ELSE
          IF(DGTCHK(CARD(IPOS:IPOS))) THEN
            IBTYPE=1
          ELSE
            IBTYPE=2
          END IF
        END IF
        IF(IBTYPE.EQ.2) THEN
          IF(NEWSYN.EQ.2) THEN
            GO TO 98
          ELSE IF(NEWSYN.EQ.0) THEN
            NEWSYN=1
C
C  If the preceding blocks were processed under the old syntax originally,
C  correct them.
C
            NCLBAR=0
            IF(NCLBLK.GE.2) THEN
              DO 63 ICLBLK=1,NCLBLK-1
              BLCPNT(ICLBLK)=0
              BLNCLS(ICLBLK)=0
              BLVSTR(ICLBLK)=0
              BLVSIZ(ICLBLK)=0
   63         CONTINUE
            END IF
          END IF
          IBFLAG=1
          IPT=IPOS
          ICSPEC=0
        END IF
      END IF
   64 CONTINUE
      IF(IBFLAG.EQ.1.AND.IPOS.GT.0) THEN
        IF(CARD(IPOS:IPOS).EQ.'/') THEN
          IPOS=IPOS+1
          CALL NBFND2(IPOS,IPOS2)
          IF(IPOS2.GT.0) THEN
            IPOS=IPOS2
            GO TO 64
          END IF
        ELSE
          CALL CMATCH(CARD(IPOS:256),IPOS,256,'CLASS',5,IPOS2,1)
          IF(IPOS2.GT.0) THEN
            IF(ICSPEC.EQ.1) THEN
              WRITE(U6,252)
              GO TO 99
            ELSE
              ICSPEC=1
            END IF
            IPOS=IPOS2
   66       CONTINUE
            IPT=IPOS
            CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,K,IPOS,2,VNAME,NVIN)
            IF(K.GT.0) THEN
              DO 67 I=1,K
              CALL VNMTCH(VTEMP(I+SVTEMP-1),VNAME,NVIN,J)
              IF(J.EQ.0) THEN
                WRITE(U6,205)VTEMP(I+SVTEMP-1)
                GO TO 99
              ELSE
                IF(MTYPE(J).NE.4) THEN
                  WRITE(U6,253)VTEMP(I+SVTEMP-1)
                  GO TO 99
                END IF
              END IF
              BLNCLS(NCLBLK)=BLNCLS(NCLBLK)+1
              CALL RINCR(9,NCLBAR,1)
              IF(BLCPNT(NCLBLK).EQ.0)BLCPNT(NCLBLK)=NCLBAR
              CLTYPE(NCLBAR)=J
   67         CONTINUE
            END IF
            IF(IPOS.GT.0) THEN
              IF(CARD(IPOS:IPOS).EQ.'*') THEN
                IPOS=IPOS+1
                GO TO 66
              END IF
            END IF
            GO TO 64
          ELSE
            CALL CMATCH(CARD(IPOS:256),IPOS,256,'SELECT',6,IPOS2,1)
            IF(IPOS2.GT.0) THEN
              IKEY=9
              IPT=IPOS2
            ELSE
              CALL CMATCH(CARD(IPOS:256),IPOS,256,'KEEP',4,IPOS2,1)
              IF(IPOS2.GT.0) THEN
                IKEY=19
                IPT=IPOS2
              ELSE
                IKEY=19
                IPT=IPOS
              END IF
            END IF
          END IF
          GO TO 65
        END IF
      END IF
      IF(IPT.EQ.1) THEN
        GO TO 2
      ELSE
        GO TO 1
      END IF
C
C
   90 CONTINUE
      IF((IFLOW.EQ.0.AND.ITYPEF(1).EQ.1).OR.IRCINP.EQ.0) THEN
        IF(IFLOW.EQ.0)WRITE(U6,224)
        IF(IRCINP.EQ.0)WRITE(U6,230)
        GO TO 99
      END IF
      V3(IRCINP+1)=IFLOW
      RSTPNT(IRCINP+1)=IFHIGH-IFLOW+1
      IF(IKEY.EQ.97.OR.IKEY.EQ.98) THEN
        IFLOW=0
        IRCINP=0
        ITYPEF(1)=1
        ITYPEF(2)=0
        ITYPEF(3)=0
        CALL FNREAD(IPT,ITYPEF,IFILEF,2,IPOSSC)
        IF(IMERR1.GT.0) THEN
          CALL FSTOP
        END IF
        IUINPT=IFILEF(1)
        IF(IKEY.EQ.97) THEN
          IRCTIN=41
        ELSE
          IRCTIN=42
        END IF
        GO TO 1
      END IF
      IF(ISTEPC.NE.1.OR.IOUTFV.GT.0) THEN
        IF(IRCOUT.LE.0) THEN
          WRITE(U6,240)
          GO TO 99
        ELSE IF(IOUTFV.LE.1.AND.IFOUTL.EQ.0) THEN
          WRITE(U6,224)
          GO TO 99
        END IF
        V3(IRCOUT)=IFOUTL
        RSTPNT(IRCOUT)=IFOUTH-IFOUTL+1
        IF(ISTEPC.NE.1.AND.NBY.GT.0.AND.IBYCHK.EQ.0) THEN
          WRITE(U6,247)
          GO TO 99
        END IF
      END IF
      IF(ICWARN.GT.0.AND.U5ECHO.GT.0)WRITE(U6,220)ICWARN
      IF(IFLVL.NE.0) THEN
        WRITE(U6,234)
        GO TO 99
      END IF
      IF(NHADAM.GT.0) THEN
        J=RCEIL(2)-NVIN
        IF(NRECOD.GT.0) THEN
          DO 91 I=1,NRECOD
          IF(RCTYPE(I).EQ.61) GO TO 94
   91     CONTINUE
        END IF
        IF(IREPF.EQ.1) THEN
          VNAME(NVIN+1)='REPF        '
        ELSE
          VNAME(NVIN+1)='REPW        '
        END IF
        NVINPT=1
        CALL RFADD(VNAME(NVIN+1),NVINPT,J,2,IX,1)
      END IF
   94 CONTINUE
      RETURN
   95 CONTINUE
      WRITE(U6,200)
      GO TO 99
   96 CONTINUE
      WRITE(U6,233)
      GO TO 99
   97 CONTINUE
      WRITE(U6,238)
      GO TO 99
   98 CONTINUE
      WRITE(U6,251)
   99 CONTINUE
      CALL FSTOP
      END
      SUBROUTINE SET1A(IKEY,IPT,VTMPSZ,IPOS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MIFLVL=7,IXFLLD=15-MIFLVL)
      PARAMETER (MAXFMT=20)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
      INTEGER VTMPSZ
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
      LOGICAL REFRSH,ALPCHK,DGTCHK
      EXTERNAL REFRSH,ALPCHK,DGTCHK
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
C
C       NVTOT   (NTOTV)
C       NVREG   (IOUTC1)
C       NVARID  (NID1)
C
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1,
     . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX
C
      DOUBLE PRECISION RANGE(2,MRANGE)
      INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET),
     . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD),
     . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI)
C
      COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP,
     . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO,
     . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS,
     . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT,
     . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS,
     . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO,
     . NLEVEL,NRNSET,NRANGE,NHADAM,ISTEPC,IFLVL,IF1LST,IFLAST,NEWSYN,
     . IXFILL
      INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS,
     . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN,
     . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IFLAST(MIFLVL),
     . IXFILL(IXFLLD)
C
  200 FORMAT(' ERROR IN SPECIFICATION')
  205 FORMAT(' UNRECOGNIZED VARIABLE NAME ',A12)
  206 FORMAT(' Only one BY statement allowed')
  207 FORMAT(' REPLICATION METHOD NOT RECOGNIZED')
  208 FORMAT(' CONFLICT WITH PREVIOUS SPECIFICATION')
  209 FORMAT(' VARIABLE REQUIRED TO BE OF TYPE REAL - ',A12)
  214 FORMAT(' DROP may not be used with KEEP')
  242 FORMAT(' INCONSISTENT WITH VPLX FILE')
C
C  BY
C
      IF(IKEY.EQ.11) THEN
        IF(NBY.GT.0.AND.ISTEPC.EQ.1) THEN
          WRITE(U6,206)
          GO TO 99
        END IF
        CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,I,IPOS,2,VNAME,NVIN)
        IF(I.LE.0)GO TO 95
        IF(ISTEPC.EQ.2) THEN
          IF(I.NE.NBY) THEN
            WRITE(U6,242)
            GO TO 99
          END IF
          J=RCEIL(2)+NVREG+NCLASS+NVARID
          IF(VFTYPE.GE.5.AND.VFTYPE.LE.12)J=J-1
        ELSE
          NBY=I
          CALL RCHECK(3,0,NBY)
        END IF
        DO 26 I=1,NBY
        CALL VNMTCH(VTEMP(I+SVTEMP-1),VNAME,NVIN,BYLIST(I))
        IF(BYLIST(I).EQ.0) THEN
          WRITE(U6,205)VTEMP(I+SVTEMP-1)
          GO TO 99
        END IF
        IF(ISTEPC.EQ.2) THEN
          J=J+1
          CALL VNMTCH(VTEMP(I+SVTEMP-1),VNAME(J),1,K)
          IF(K.NE.1) THEN
            WRITE(U6,242)
            GO TO 99
          END IF
        END IF
   26   CONTINUE
C
C  REPLICATION [REP] METHOD,
C  REPLICATE [REP] NUMBER, FACTORS, WEIGHTS, COUNT
C  HADAMARD
C
      ELSE IF(IKEY.EQ.12.OR.IKEY.EQ.13.OR.IKEY.EQ.23.OR.IKEY.EQ.118)
     .    THEN
        CALL NBFIND(CARD(IPT:256),IPT,256,IPOS2)
        IF(IPOS2.EQ.0)GO TO 95
        IF(IKEY.EQ.118) THEN
          IF(NHADAM.GT.0)GO TO 96
          CALL IFIND(CARD(IPOS2:256),IPOS2,256,IPT,NHADAM)
          IF(IPT.LE.0)GO TO 95
          GO TO 1
        END IF
        IPT=IPOS2
        IFLAG=0
        CALL CMATCH(CARD(IPT:256),IPT,256,'NUMBER',6,IPOS2,1)
        IF(IPOS2.GT.0) THEN
          IF(IREPNO.GT.0.OR.IREPF.GT.0.OR.IREPW.GT.0.OR.
     .       ISTRCD.GT.0.OR.ISTRNO.GT.0.OR.ISNDCD.GT.0.OR.
     .       ISNDNO.GT.0.OR.ICLUSC.GT.0.OR.ICLUSN.GT.0) THEN
            GO TO 96
          END IF
          IFLAG=1
          IREPNO=1
          IPT=IPOS2
        END IF
        CALL CMATCH(CARD(IPT:256),IPT,256,'COUNT',5,IPOS2,1)
        IF(IPOS2.GT.0) THEN
          IF(ICLCNT.GT.0) THEN
            GO TO 96
          END IF
          CALL IFIND(CARD(IPOS2:256),IPOS2,256,IPT,ICLCNT)
          IF(IPT.LE.0)GO TO 95
          GO TO 1
        END IF
        CALL CMATCH(CARD(IPT:256),IPT,256,'FACTORS',7,IPOS2,1)
        IF(IPOS2.GT.0) THEN
          IF(IREPNO.GT.0.OR.IREPF.GT.0.OR.IREPW.GT.0.OR.
     .       ISTRCD.GT.0.OR.ISTRNO.GT.0.OR.ISNDCD.GT.0.OR.
     .       ISNDNO.GT.0.OR.ICLUSC.GT.0.OR.ICLUSN.GT.0) THEN
            GO TO 96
          END IF
          IFLAG=1
          IREPF=1
          IPT=IPOS2
        END IF
        CALL CMATCH(CARD(IPT:256),IPT,256,'WEIGHTS',7,IPOS2,1)
        IF(IPOS2.GT.0) THEN
          IF(IREPNO.GT.0.OR.IREPF.GT.0.OR.IREPW.GT.0.OR.
     .       ISTRCD.GT.0.OR.ISTRNO.GT.0.OR.ISNDCD.GT.0.OR.
     .       ISNDNO.GT.0.OR.ICLUSC.GT.0.OR.ICLUSN.GT.0) THEN
            GO TO 96
          END IF
          IFLAG=1
          IREPW=1
          IPT=IPOS2
        END IF
        IF(IFLAG.EQ.1) THEN
          CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,NREPW,IPOS,2,VNAME,
     .      NVIN)
          IF(NREPW.LE.0)GO TO 95
          IF(IREPNO.EQ.1.AND.NREPW.GT.1)GO TO 95
          DO 28 I=1,NREPW
          CALL VNMTCH(VTEMP(I+SVTEMP-1),VNAME,MVAR,IV1)
          IF(IV1.LE.0) THEN
            WRITE(U6,205)VTEMP(I+SVTEMP-1)
            GO TO 99
          END IF
          IF(IREPNO.EQ.1) THEN
            IREPNO=IV1
            NREPW=0
            GO TO 2
          END IF
          IF(MTYPE(IV1).NE.1.OR.MXSIZE(IV1).NE.1) THEN
            WRITE(U6,209)VTEMP(I+SVTEMP-1)
            GO TO 99
          END IF
          MTYPE(IV1)=50+I
   28     CONTINUE
          GO TO 2
        END IF
        CALL CMATCH(CARD(IPT:256),IPT,256,'METHOD',6,IPOS2,1)
        IF(IPOS2.GT.0) THEN
          CALL NBFIND(CARD(IPOS2:256),IPOS2,256,IPT)
          IF(IPT.EQ.0) GO TO 95
        END IF
        ISMPL=0
        CALL CMATCH(CARD(IPT:256),IPT,256,'SIMPLE',6,IPOS2,1)
        IF(IPOS2.GT.0) THEN
          CALL NBFIND(CARD(IPOS2:256),IPOS2,256,IPT)
          IF(IPT.EQ.0) GO TO 95
          ISMPL=1
        END IF
        CALL CMATCH(CARD(IPT:256),IPT,256,'STRAT',5,IPOS2,2)
        IF(IPOS2.GT.0) THEN
          VROPTN=4
          GO TO 1
        END IF
        CALL CMATCH(CARD(IPT:256),IPT,256,'JACK',4,IPOS2,2)
        IF(IPOS2.GT.0) THEN
          VROPTN=1
          GO TO  1
        END IF
        CALL CMATCH(CARD(IPT:256),IPT,256,'RE',2,IPOS2,2)
        IF(IPOS2.GT.0) THEN
          VROPTN=3
          GO TO 1
        END IF
        CALL CMATCH(CARD(IPT:256),IPT,256,'GEN',3,IPOS2,2)
        IF(IPOS2.GT.0) THEN
          VROPTN=5
          GO TO 1
        END IF
        CALL CMATCH(CARD(IPT:256),IPT,256,'HALF',4,IPOS2,2)
        IF(IPOS2.GT.0) THEN
          VROPTN=2
          GO TO 1
        END IF
        CALL CMATCH(CARD(IPT:256),IPT,256,'RAND',4,IPOS2,2)
        IF(IPOS2.GT.0) THEN
          VROPTN=7
          GO TO 1
        END IF
        WRITE(U6,207)
        GO TO 99
C
C  UNWEIGHTED
C
      ELSE IF(IKEY.EQ.14) THEN
        IF(IWGT.NE.0) THEN
          GO TO 96
        END IF
        NOWGTF=1
C
C  DROP, KEEP
C
      ELSE IF(IKEY.EQ.18.OR.IKEY.EQ.19) THEN
        IF(VKEEPF.NE.0) THEN
          IF((IKEY.EQ.18.AND.VKEEPF.EQ.1).OR.
     .       (IKEY.EQ.19.AND.VKEEPF.EQ.2)) THEN
            WRITE(U6,214)
            GO TO 99
          END IF
        ELSE IF(IKEY.EQ.18) THEN
          VKEEPF=2
        ELSE
          VKEEPF=1
        END IF
        J=MVAR-NKEEP
        CALL VNFIND(IPT,VNKEEP(NKEEP+1),J,N,IPOS,2,VNAME,NVIN)
        IF(N.LE.0) GO TO 95
        IF(IKEY.EQ.19) THEN
          IF(BLVSTR(NCLBLK).EQ.0)BLVSTR(NCLBLK)=NKEEP+1
          BLVSIZ(NCLBLK)=BLVSIZ(NCLBLK)+N
        END IF
        NKEEP=NKEEP+N
C
C  LABEL, LABELS
C
      ELSE IF(IKEY.EQ.20) THEN
        CALL RLABEL(IPT,VNAME,NVIN,VTEMP(SVTEMP),VTMPSZ,VTEMP,
     .    MTYPE,LPOINT,CDMPNT,CROSSD,LABEL,LEVEL,NLEVEL,MLEVEL,IPOS)
C
C  LEVEL, LEVELS
C
      ELSE IF(IKEY.EQ.21) THEN
        CALL RLEVEL(IPT,VNAME,NVIN,VTEMP(SVTEMP),VTMPSZ,LPOINT,MSIZE,
     .    LEVEL,NLEVEL,MLEVEL,IPOS)
C
C  RENAME
C
      ELSE IF(IKEY.EQ.22) THEN
        CALL RENAMV(IPT,VNAME,NVIN,VTEMP(SVTEMP),VTMPSZ,VTEMP,
     .    VNKEEP,NKEEP,MTYPE,LPOINT,CDMPNT,CROSSD,LABEL,LEVEL,IPOS)
C
C  WEIGHT
C
      ELSE IF(IKEY.EQ.24) THEN
        IF(IWGT.NE.0.OR.NOWGTF.GT.0) THEN
          GO TO 96
        END IF
        CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,N,IPOS,2,VNAME,NVIN)
        IF(N.NE.1) GO TO 95
        CALL VNMTCH(VTEMP(SVTEMP),VNAME,NVIN,N)
        IF(N.LE.0) THEN
          WRITE(U6,205)VTEMP(SVTEMP)
          GO TO 99
        END IF
        IWGT=N
        GO TO 2
C
C  STRATUM SIZE, STRATUM SIZES, STRATUM CODE, STRATUM NUMBER
C  SECOND STAGE SIZE, SECOND STAGE SIZES, SECOND STAGE CODE,
C  SECOND STAGE NUMBER
C  SECOND-STAGE SIZE, SECOND-STAGE SIZES, SECOND-STAGE CODE,
C  SECOND-STAGE NUMBER
C  CLUSTER CODE, CLUSTER NUMBER, CLUSTER COUNT
C
      ELSE IF(IKEY.GE.25.AND.IKEY.LE.27) THEN
        IF(IKEY.EQ.27.AND.CARD(IPT:IPT).EQ.'-')IPT=IPT+1
        CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,N,IPOS,2,VNAME,NVIN)
        IF(N.EQ.0)GO TO 95
        IF((IKEY.EQ.25.AND.N.EQ.1).OR.
     .     (IKEY.EQ.27.AND.N.EQ.2)) THEN
          CALL CMATCH(VTEMP(N+SVTEMP-1),1,12,'SIZE',4,IPOS2,2)
          IF(IPOS2.GT.0) THEN
            L=SIZED-NXPTD+1
            CALL DASCAN(IPOS,IPOS2,DX(NXPTD),L,N)
            IF(N.LE.0) GO TO 95
            IF(IKEY.EQ.25) THEN
              IF(SISTRS.GT.0) THEN
                GO TO 96
              ELSE
                SISTRS=NXPTI
                NISTRS=N
              END IF
            ELSE
              IF(SISNDS.GT.0) THEN
                GO TO 96
              ELSE
                SISNDS=NXPTI
                NISNDS=N
              END IF
            END IF
            J=NXPTI
            K=NXPTD
            CALL ROOMI(N)
            DO 30 I=1,N
            IF(DX(K).LE.0) GO TO 95
            IX(J)=DX(K)+.05
            J=J+1
            K=K+1
   30       CONTINUE
            GO TO 2
          END IF
        END IF
        CALL CMATCH(VTEMP(N+SVTEMP-1),1,12,'COUNT',5,IPOS2,2)
        IF(IPOS2.GT.0) THEN
          IF(ICLCNT.GT.0.OR.IKEY.NE.26) THEN
            GO TO 96
          END IF
          CALL IFIND(CARD(IPOS:256),IPOS,256,IPT,ICLCNT)
          IF(IPT.LE.0)GO TO 95
          GO TO 1
        END IF
        CALL VNMTCH(VTEMP(N+SVTEMP-1),VNAME,NVIN,L)
        IF(L.LE.0) THEN
          WRITE(U6,205)VTEMP(N+SVTEMP-1)
          GO TO 99
        END IF
        IF(N.GT.1) THEN
          N=N-1
          CALL CMATCH(VTEMP(N+SVTEMP-1),1,12,'NUMBER',6,IPOS2,1)
          IF(IPOS2.GT.0) THEN
            IF(IKEY.EQ.25) THEN
              IF(ISTRNO.EQ.0.AND.ISTRCD.EQ.0.OR.IREPNO.GT.0) THEN
                ISTRNO=L
                GO TO 2
              END IF
            ELSE IF(IKEY.EQ.26) THEN
              IF(ICLUSN.EQ.0.AND.ICLUSC.EQ.0.OR.IREPNO.GT.0) THEN
                ICLUSN=L
                GO TO 2
              END IF
            ELSE
              IF(ISNDNO.EQ.0.AND.ISNDCD.EQ.0.OR.IREPNO.GT.0) THEN
                ISNDNO=L
                GO TO 2
              END IF
            END IF
            GO TO 96
          END IF
        END IF
        IF(IKEY.EQ.25) THEN
          IF(ISTRCD.EQ.0.AND.ISTRCD.EQ.0.OR.IREPNO.GT.0) THEN
            ISTRCD=L
            GO TO 2
          END IF
        ELSE IF(IKEY.EQ.26) THEN
          IF(ICLUSC.EQ.0.AND.ICLUSN.EQ.0.OR.IREPNO.GT.0) THEN
            ICLUSC=L
            GO TO 2
          END IF
        ELSE
          IF(ISNDCD.EQ.0.AND.ISNDNO.EQ.0.OR.IREPNO.GT.0) THEN
            ISNDCD=L
            GO TO 2
          END IF
        END IF
        GO TO 96
C
C  COEFFICIENTS, FPC1, FPC2
C
      ELSE IF(IKEY.GE.28.AND.IKEY.LE.30) THEN
        L=SIZED-NXPTD+1
        CALL DASCAN(IPT,IPOS2,DX(NXPTD),L,N)
        IF(N.LE.0) GO TO 95
        IF(IKEY.EQ.28) THEN
          IF(ISTEPC.EQ.2) THEN
            IF(N.NE.NRPTOT) GO TO 96
            DO 41 I=1,N
            IF(DABS(DX(NXPTD+I-1)-DX(SDCOEF+I-1)).GT..1D-06)GO TO 96
   41       CONTINUE
          ELSE IF(SDCOEF.GT.0.OR.SDFPC1.GT.0.OR.SDFPC2.GT.0) THEN
            GO TO 96
          ELSE
            SDCOEF=NXPTD
            NDCOEF=N
          END IF
        ELSE
          DO 42 I=1,N
          DX(NXPTD+I-1)=1.D0-DX(NXPTD+I-1)
   42     CONTINUE
          IF(IKEY.EQ.29) THEN
            IF(SDFPC1.GT.0.OR.(SDCOEF.GT.0.AND.ISTEPC.EQ.1)) THEN
              GO TO 96
            ELSE
              SDFPC1=NXPTD
              NDFPC1=N
            END IF
          ELSE
            IF(SDFPC2.GT.0.OR.(SDCOEF.GT.0.AND.ISTEPC.EQ.1)) THEN
              GO TO 96
            ELSE
              SDFPC2=NXPTD
              NDFPC2=N
            END IF
          END IF
        END IF
        IF(ISTEPC.EQ.1.OR.IKEY.NE.28) THEN
          CALL ROOMD(N)
        END IF
      END IF
      GO TO 3
    1 CONTINUE
      IPT=2
      GO TO 3
    2 CONTINUE
      IPT=1
    3 CONTINUE
      RETURN
   95 CONTINUE
      WRITE(U6,200)
      GO TO 99
   96 CONTINUE
      WRITE(U6,208)
   99 CONTINUE
      CALL FSTOP
      END
      SUBROUTINE SET1B(IKEY,IPT,VTMPSZ,ICWRNT,IPOS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MIFLVL=7,IXFLLD=15-MIFLVL)
      PARAMETER (MAXFMT=20)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
      INTEGER VTMPSZ
      LOGICAL RANGEP
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
      LOGICAL REFRSH,ALPCHK,DGTCHK
      EXTERNAL REFRSH,ALPCHK,DGTCHK
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1,
     . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX
C
      DOUBLE PRECISION RANGE(2,MRANGE)
      INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET),
     . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD),
     . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI)
C
      COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP,
     . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO,
     . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS,
     . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT,
     . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS,
     . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO,
     . NLEVEL,NRNSET,NRANGE,NHADAM,ISTEPC,IFLVL,IF1LST,IFLAST,NEWSYN,
     . IXFILL
      INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS,
     . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN,
     . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IFLAST(MIFLVL),
     . IXFILL(IXFLLD)
C
  200 FORMAT(' ERROR IN SPECIFICATION')
  205 FORMAT(' UNRECOGNIZED VARIABLE NAME ',A12)
  212 FORMAT(' VARIABLE OF INAPPROPRIATE TYPE - ',A12)
  215 FORMAT(' Variable already exists - ',A12)
  216 FORMAT(' COPY into a CLASS variable is not allowed')
  220 FORMAT(5X,'WARNING: COUNT OF CAT, CLASS, ETC. OPERATIONS TO CAT OR
     . CROSSED VAR:',I4)
  221 FORMAT(5X,'WARNING: OPERATIONS TO CAT OR CROSSED VAR')
  222 FORMAT(5X,'FOR REAL, REAL WITH MISSING, OR CROSSED REAL ONLY')
  233 FORMAT(' NOT PERMITTED WITHIN IF BLOCK')
  234 FORMAT(' UNBALANCED IFS')
  235 FORMAT(' EXCEEDS MAXIMUM IF LEVELS')
  236 FORMAT(5X,'(If level:',i2,')')
  237 FORMAT(' NOT ALLOWED ON REPLICATE WEIGHT/FACTOR')
  251 FORMAT(' CONFLICT BETWEEN OLD AND NEW SYNTAX')
C
C  Contents of MTYPE, codes for transformations
C     1  =  real variable
C     2  =  real variable with missing checks
C     3  =  categorical variable
C     4  =  class variable, known dimension
C     5  =  by variable, known dimension
C     6  =  by variable, unknown dimension
C     7  =  select transformation (not variable type)
C     8  =  cross variable, real value
C     9  =  cross variable, categorical
C    10  =  copy (not variable type)
C    21  =  boolean                 "
C    22  =  boolean - no range      "
C    23  =  and (logical and)       "
C    24  =  or                      "
C    25  =  not                     "
C    26  =  add_ms                  "
C    27  =  subtract_ms             "
C    28  =  multiply_ms             "
C    29  =  divide_ms               "
C    30  =  add                     "
C    31  =  subtract                "
C    32  =  multiply                "
C    33  =  divide                  "
C    34  =  constants               "
C    35  =  if (else if)            "
C    36  =  go to                   "
C    40  =  initial read
C    41  =  input (link)
C    42  =  input with missing (link_missing)
C               v1        v2        v3        rstpnt
C             iuinpt    status   # input      # keys
C             1st v    start x   start fmt    # fmt
C             # print   #obs
C             key x    match v   last key     var # of match v
C    43  =  add loop to replicate weights/factors
C               v1        v2        v3        rstpnt
C             1st rf/rw  # rf/rw   var
C    44  =  subtract loop to replicate weights/factors
C    45  =  multiply loop            "
C    46  =  divide   loop            "
C    47  =  output
C
C  50-60 are during REWEIGHT only
C
C    50  =  add, 0 replicate,      using vplxin data
C               v1        v2        v3        rstpnt
C             1st op   target   vplxin v     #classes
C          for each class:
C               v1        v2        v3        rstpnt
C            class/cat           0 offset    increment
C
C    51  =  subtract, 0 replicate   using vplxin data
C    52  =  multiply, 0 replicate       "
C    53  =  divide, 0 replicate         "
C    54  =  add loop to replicate weights/factors, using vplxin
C               v1        v2        v3        rstpnt
C             1st rf/rw  # rf/rw  vplxin var  #classes
C          for each class:
C               v1        v2        v3        rstpnt
C            class/cat           0 offset    increment
C
C    55  =  subtract loop to replicate weights/factors, using vplxin
C    56  =  multiply loop            "                       "
C    57  =  divide   loop            "                       "
C
C    58  =  define repf based on var ids
C               v1        v2        v3       rstpnt
C            1st rf/rw  # rf/rw     wt      #var ids
C          for each id:
C               v1        v2        v3       rstpnt
C            variance id
C          for repw, v3 will give id of weight
C    60  =  check BY variables
C               v1        v2        v3       rstpnt
C                                           #BY vars
C          for each BY var:
C               v1        v2        v3       rstpnt
C              BY id                       loc in vid
C
C    61  =  define repf based on rows of Hadamard matrix and
C           coefficients
C               v1        v2        v3       rstpnt
C            1st rf/rw  # rf/rw     wt       #sets
C          for each set:
C               v1        v2        v3       rstpnt
C              row     coefficient
C          for repw, v3 will give id of weight
C
      IBEYND=0
      ICWRNT=0
      IRC=0
      CALL NBFND2(IPT,IPT2)
C
C  Check whether ELSE or ELSE IF
C
      IF(IKEY.EQ.105) THEN
        IF(IPT2.GT.0) THEN
          CALL CMATCH(CARD(IPT2:256),IPT2,256,'IF',2,IPOS2,1)
          IF(IPOS2.EQ.0)GO TO 95
          IPOS=IPT2+2
          CALL NBFND2(IPOS,IPT2)
          IF(IPOS.EQ.1)IBEYND=1
          IF(IPT2.LE.0)GO TO 95
        ELSE
C
C  Handling of ELSE
C
          IF(IFLVL.EQ.0)GO TO 97
          IF(IFLAST(IFLVL).LT.0)GO TO 97
          CALL RINCR(4,NRECOD,1)
          RCTYPE(NRECOD)=36
          V3(NRECOD)=IFLAST(IFLVL)
          IFLAST(IFLVL)=-NRECOD
          IF(IFLVL.GT.1.AND.U5ECHO.EQ.1)WRITE(U6,236)IFLVL
          RETURN
        END IF
      ELSE IF(IKEY.EQ.107.OR.IKEY.EQ.108) THEN
C
C  END, ENDIF
C
        IF(IFLVL.EQ.0)GO TO 97
        IF(IFLVL.GT.1.AND.U5ECHO.EQ.1)WRITE(U6,236)IFLVL
        IRC=NRECOD+1
    4   CONTINUE
        J=IFLAST(IFLVL)
        IF(J.GT.0) THEN
          IFLAST(IFLVL)=V3(J)
          V3(J)=IRC
          IF(IFLAST(IFLVL).GT.0) THEN
            V3(J-1)=NRECOD+1
            IRC=J
            GO TO 4
          END IF
        ELSE
          J=-J
          IFLAST(IFLVL)=V3(J)
          V3(J)=IRC
          IRC=J+1
          GO TO 4
        END IF
        IFLVL=IFLVL-1
        RETURN
      ELSE
        IF(IPT2.LE.0)GO TO 95
      END IF
C
C  Preliminary setup for IF and ELSE IF, get beyond first "("
C
      IF(IKEY.GE.104.AND.IKEY.LE.106) THEN
        IF(CARD(IPT2:IPT2).EQ.'(') THEN
          IPOS=IPT2+1
          CALL NBFND2(IPOS,IPT2)
          IF(IPOS.EQ.1)IBEYND=1
          IF(IPT2.LE.0)GO TO 95
        END IF
        IF(IKEY.EQ.104) THEN
          IFLVL=IFLVL+1
          IF(IFLVL.GT.MIFLVL) THEN
            WRITE(U6,235)
            GO TO 99
          END IF
          IFLAST(IFLVL)=NRECOD+1
          IF(IFLVL.EQ.1)IF1LST=NRECOD+1
          V3(NRECOD+1)=0
        ELSE
          IF(IFLVL.EQ.0)GO TO 97
          IF(IFLAST(IFLVL).LE.0)GO TO 97
          CALL RINCR(4,NRECOD,1)
          RCTYPE(NRECOD)=36
          V3(NRECOD+1)=IFLAST(IFLVL)
          IFLAST(IFLVL)=NRECOD+1
        END IF
      END IF
      IF(IKEY.EQ.10) THEN
        IRC=2
      ELSE IF(IKEY.EQ.9) THEN
        IRC=7
      ELSE IF(IKEY.GE.104.AND.IKEY.LE.106) THEN
        IRC=35
      END IF
      CALL VNFIND(IPT2,VTEMP(SVTEMP),VTMPSZ,N,IPOS,2,VNAME,NVIN)
      IF(IPT2.EQ.1)IPT=1
      IF(N.LE.0)GO TO 95
      IF(IRC.EQ.35) THEN
        IF(IPOS.GT.0) THEN
          IF(CARD(IPOS:IPOS).EQ.')') THEN
            IPOS2=IPOS+1
            CALL NBFND2(IPOS2,IPOS)
            IF(IPOS2.EQ.1)IBEYND=1
            IF(IPOS.GT.0) THEN
              CALL CMATCH(CARD(IPOS:256),IPOS,256,'THEN',4,IPOS2,1)
              IF(IPOS2.GT.0) THEN
                CALL NBFND2(IPOS2,IPOS)
                IF(IPOS2.NE.1)GO TO 95
                IPOS=0
              ELSE
                GO TO 95
              END IF
            END IF
          END IF
        END IF
      END IF
C
C  If IPOS=0, check for COPY or CLASS  catvar INTO classvar syntax
C
      IF(IPOS.EQ.0) THEN
        RANGEP=.FALSE.
        IF(IKEY.GE.6.AND.IKEY.LE.9.AND.IFLVL.GT.0)GO TO 96
        IF((IKEY.EQ.6).OR.IKEY.EQ.33) THEN
          CALL VNMTCH('INTO ',VTEMP(SVTEMP),N,IINTO)
          IF(IINTO.GT.0) THEN
            N1=1
    7       CONTINUE
            IF(IINTO.EQ.0.OR.2*IINTO+N1.GT.N+2)GO TO 95
            L=IINTO+N1-2
            L1=L+2
            DO 9 I=N1,L
            CALL VNMTCH(VTEMP(I+SVTEMP-1),VNAME,NVIN,IV1)
            IF(IV1.LE.0) THEN
              WRITE(U6,205)VTEMP(I+SVTEMP-1)
              GO TO 99
            END IF
            IF(MTYPE(IV1).NE.3.AND.IKEY.EQ.6) THEN
              WRITE(U6,212)VTEMP(I+SVTEMP-1)
              GO TO 99
            END IF
            CALL VNMTCH(VTEMP(L1+SVTEMP-1),VNAME,NVIN,IV2)
            IF(IV2.NE.0.AND.IKEY.EQ.6) THEN
              WRITE(U6,215)VTEMP(L1+SVTEMP-1)
              GO TO 99
            END IF
            IF(IV2.EQ.0) THEN
              CALL RINCR(2,NVIN,1)
              IV2=NVIN
              VNAME(NVIN)=VTEMP(L1+SVTEMP-1)
              CALL RFCHCK(1)
              MXSIZE(IV2)=MSIZE(IV1)
              IF(IKEY.EQ.6) THEN
                IF(MTYPE(IV2).GE.50)GO TO 98
                MTYPE(IV2)=4
                IF(ISTEPC.EQ.1.AND.NEWSYN.NE.1) THEN
                  BLNCLS(NCLBLK)=BLNCLS(NCLBLK)+1
                  CALL RINCR(9,NCLBAR,1)
                  IF(BLCPNT(NCLBLK).EQ.0)BLCPNT(NCLBLK)=NCLBAR
                  CLTYPE(NCLBAR)=IV2
                END IF
              ELSE
                IF(IFLVL.GT.0) THEN
                  IF(MTYPE(IV1).EQ.2) THEN
                    MTSTRT(IV2)=2
                  ELSE IF(MTYPE(IV1).NE.1.AND.MTYPE(IV1).LT.50) THEN
                    GO TO 96
                  END IF
                  IVZERO=1
                END IF
                IF(MTYPE(IV2).LT.50) THEN
                  IF(MTYPE(IV1).LT.50)MTYPE(IV2)=MTYPE(IV1)
                ELSE
                  IF(MTYPE(IV1).NE.1.AND.MTYPE(IV1).LT.50)GO TO 98
                END IF
              END IF
            ELSE
              IF(MTYPE(IV2).EQ.4) THEN
                WRITE(U6,216)
                GO TO 99
              END IF
              IF(MTYPE(IV2).GE.50) THEN
                IF(MTYPE(IV1).NE.1.AND.MTYPE(IV1).LT.50)GO TO 98
              ELSE IF(MTYPE(IV1).GE.50) THEN
                IF(IFLVL.GT.0) THEN
                  IF(MTYPE(IV2).NE.1)GO TO 96
                ELSE
                  MTYPE(IV2)=1
                END IF
              ELSE
                IF(MXSIZE(IV2).LT.MSIZE(IV1))MXSIZE(IV2)=MSIZE(IV1)
                IF(IFLVL.GT.0) THEN
                  IF(MTYPE(IV2).NE.MTYPE(IV1))GO TO 96
                  IF(MSIZE(IV2).NE.MSIZE(IV1))GO TO 96
                ELSE
                  MTYPE(IV2)=MTYPE(IV1)
                END IF
              END IF
            END IF
            MSIZE(IV2)=MSIZE(IV1)
            IF(LABEL(IV1)(1:12).EQ.VNAME(IV1).AND.
     .         LABEL(IV1)(13:24).EQ.'            ') THEN
              LABEL(IV2)(1:12)=VNAME(IV2)
              LABEL(IV2)(13:24)='            '
            ELSE
              LABEL(IV2)=LABEL(IV1)
            END IF
            LPOINT(IV2)=LPOINT(IV1)
            CDMPNT(IV2)=CDMPNT(IV1)
            CALL RINCR(4,NRECOD,1)
            RSTPNT(NRECOD)=0
            RCTYPE(NRECOD)=10
            V1(NRECOD)=IV1
            V2(NRECOD)=IV2
            V3(NRECOD)=IV1
            L1=L1+1
    9       CONTINUE
            N1=L1
            IF(N1.LE.N) THEN
              N2=N-N1+1
              CALL VNMTCH('INTO ',VTEMP(N1+SVTEMP-1),N2,IINTO)
              GO TO 7
            ELSE
              GO TO 2
            END IF
          ELSE
            IF(IKEY.EQ.33)GO TO 95
            DO 10 I=1,N
            CALL VNMTCH(VTEMP(I+SVTEMP-1),VNAME,NVIN,J)
            IF(J.EQ.0) THEN
              WRITE(U6,205)VTEMP(I+SVTEMP-1)
              GO TO 99
            END IF
            IF(MTYPE(J).NE.4) THEN
              WRITE(U6,212)VTEMP(I+SVTEMP-1)
              GO TO 99
            END IF
            IF(ISTEPC.EQ.1) THEN
              IF(NEWSYN.EQ.1) THEN
                WRITE(U6,251)
                GO TO 99
              ELSE
                NEWSYN=2
              END IF
              BLNCLS(NCLBLK)=BLNCLS(NCLBLK)+1
              CALL RINCR(9,NCLBAR,1)
              IF(BLCPNT(NCLBLK).EQ.0)BLCPNT(NCLBLK)=NCLBAR
              CLTYPE(NCLBAR)=J
            END IF
   10       CONTINUE
            GO TO 2
          END IF
        ELSE IF(IKEY.EQ.92) THEN
          IRC=22
        ELSE IF(IKEY.EQ.95) THEN
          IRC=25
        ELSE IF(IRC.EQ.0) THEN
          GO TO 95
        END IF
        IBEYND=1
      ELSE
C
C  Remaining cases all should have range specification
C
        RANGEP=.TRUE.
        IF(IPT.EQ.1)IBEYND=1
        CALL NBFND2(IPOS,IPOS2)
        IF(IPOS.EQ.1)IBEYND=1
        IF(IPOS2.EQ.0)GO TO 95
        IF(CARD(IPOS2:IPOS2).NE.'(') GO TO 95
        IPOS=IPOS2+1
        IF(IPOS.GE.241) THEN
          IF(.NOT.REFRSH(IPOS)) GO TO 95
          IBEYND=1
        END IF
        CALL RCHECK(5,NRANGE,1)
        NRANG1=NRANGE+1
        CALL RINCR(6,NRNSET,1)
        N1MAX=MRANGE-NRANGE
        RNGPNT(NRNSET)=NRANG1
        CALL RCHECK(7,NLEVEL,1)
        N1LEV=NLEVEL+1
        NL1MAX=MLEVEL-NLEVEL
        CALL RNSCAN(IPOS,IPOS2,RANGE(1,NRANG1),N1MAX,RTYPE(NRANG1),
     .    RGROUP(NRANG1),NR,1,LEVEL(N1LEV),NL1MAX)
        IF(IPOS.EQ.1)IBEYND=1
        IF(IPOS2.GT.0) THEN
          CALL NBFND2(IPOS2,IPOS)
          IF(IPOS2.EQ.1)IBEYND=1
          IF(IPOS.GT.0) THEN
            IF(CARD(IPOS:IPOS).EQ.')')IPOS=IPOS+1
            IPOS2=IPOS
            CALL NBFND2(IPOS2,IPOS)
            IF(IPOS2.EQ.1)IBEYND=1
            IF(IKEY.GE.104.AND.IKEY.LE.106) THEN
              IF(IPOS.GT.0) THEN
                CALL CMATCH(CARD(IPOS:256),IPOS,256,'THEN',4,IPOS2,1)
                IF(IPOS2.EQ.0)GO TO 95
                IPOS=IPOS2
              END IF
            ELSE
              IF(NR.LE.0)GO TO 95
            END IF
          END IF
        END IF
        NRNG(NRNSET)=NR
        CALL RINCR(5,NRANGE,NR)
        IF(IKEY.LT.9) THEN
          CALL RINCR(7,NLEVEL,RGROUP(NRANGE))
          CALL LEVELR(IPOS2,IPOS,NL,LEVEL(N1LEV),RGROUP(NRANGE))
          IF(IPOS2.EQ.1)IBEYND=1
          IPOS2=IPOS
        END IF
        IF(IKEY.EQ.6.AND.IKEY.LE.9.AND.IFLVL.GT.0)GO TO 96
        IF(IKEY.EQ.7.OR.IKEY.EQ.8) THEN
          IRC=3
        ELSE IF(IKEY.EQ.6) THEN
          IRC=4
        ELSE IF(IKEY.EQ.92) THEN
          IRC=21
        ELSE IF(IRC.EQ.0) THEN
          GO TO 95
        END IF
      END IF
      CALL VNMTCH('FOR ',VTEMP(SVTEMP),N,IFOR)
      IF(IFOR.EQ.0) THEN
        CALL VNMTCH('IF ',VTEMP(SVTEMP),N,IFOR)
      END IF
      CALL VNMTCH('INTO ',VTEMP(SVTEMP),N,IINTO)
      IF(IFOR.GT.0) THEN
        IF(IKEY.NE.9.AND.IKEY.NE.10)GO TO 95
      ELSE
        IF(.NOT.RANGEP.AND.IRC.EQ.2)GO TO 95
      END IF
      IS1=1
      IF(IINTO.GT.0) THEN
        N1=IINTO-1
        I2=IINTO+1
        IF(IFOR.GT.0) THEN
          IF(IFOR.EQ.N-1) THEN
            IF(N1+IINTO+2.NE.N)GO TO 95
          ELSE
            IF(N1+IINTO+1.NE.IFOR)GO TO 95
            IF(IFOR+N1.NE.N)GO TO 95
          END IF
        ELSE
          IF(N1+IINTO.NE.N)GO TO 95
        END IF
      ELSE IF(IFOR.EQ.1.AND.IKEY.EQ.9) THEN
        IS1=2
        N1=N
        I2=2
      ELSE IF(IFOR.GT.0) THEN
        N1=IFOR-1
        I2=1
        IF(IFOR.NE.N-1) THEN
          IF(IFOR+N1.NE.N)GO TO 95
        END IF
      ELSE
        N1=N
        I2=1
      END IF
      IFOR=IFOR+1
C     IF(RANGEP) THEN
C       DO 14 I=NRANG1,NRANGE
C       IF(RTYPE(I).EQ.5) THEN
C         IF(IKEY.NE.6)GO TO 95
C       END IF
C  14   CONTINUE
C     END IF
      IF(IRC.EQ.35) THEN
        IF(IS1.NE.N1)GO TO 95
        IF(IFLVL.GT.1.AND.U5ECHO.EQ.1)WRITE(U6,236)IFLVL
      END IF
      DO 18 I=IS1,N1
      CALL VNMTCH(VTEMP(I+SVTEMP-1),VNAME,NVIN,IV1)
      CALL VNMTCH(VTEMP(I2+SVTEMP-1),VNAME,NVIN,IV2)
      CALL VNMTCH(VTEMP(IFOR+SVTEMP-1),VNAME,NVIN,IV3)
      IF(IV1.EQ.0) THEN
        WRITE(U6,205)VTEMP(I+SVTEMP-1)
        GO TO 99
      END IF
      IF(IV3.EQ.0) THEN
        WRITE(U6,205)VTEMP(IFOR+SVTEMP-1)
        GO TO 99
      END IF
      IF(IFOR.LT.N)IFOR=IFOR+1
      IF(IV2.EQ.0) THEN
        CALL RINCR(2,NVIN,1)
        VNAME(NVIN)=VTEMP(I2+SVTEMP-1)
        LABEL(NVIN)(1:12)=VNAME(NVIN)
        LABEL(NVIN)(13:24)='            '
        IV2=NVIN
        CALL RFCHCK(1)
        IF(MTYPE(IV2).GE.50)GO TO 98
        IF(IFLVL.GT.0) THEN
          IF(IKEY.EQ.10) THEN
            MTSTRT(NVIN)=2
            MTYPE(NVIN)=2
          ELSE
            GO TO 96
          END IF
        END IF
      END IF
      MTSAVE=MTYPE(IV2)
      IF(IKEY.LE.10.OR.IRC.EQ.35) THEN
        MT1=MTYPE(IV1)
        IF(MT1.GE.50)MT1=1
        IF(MT1.EQ.3.OR.MT1.EQ.4.OR.MT1.EQ.8.OR.MT1.EQ.9) THEN
          ICWARN=ICWARN+1
          ICWRNT=ICWRNT+1
        END IF
      END IF
      CALL RINCR(4,NRECOD,1)
      IF(RANGEP) THEN
        RSTPNT(NRECOD)=NRNSET
      ELSE
        RSTPNT(NRECOD)=0
      END IF
      RCTYPE(NRECOD)=IRC
      V1(NRECOD)=IV1
      V2(NRECOD)=IV2
      IF(IRC.EQ.7) THEN
        V3(NRECOD)=NCLBLK
      ELSE IF(IRC.NE.35) THEN
        V3(NRECOD)=IV3
      END IF
      IF(IKEY.LT.9) THEN
        MSIZE(IV2)=RGROUP(NRANGE)
        LPOINT(IV2)=N1LEV
        MTYPE(IV2)=IRC
      ELSE IF(IKEY.EQ.10) THEN
        IF(MTYPE(IV1).EQ.1) THEN
          MSIZE(IV2)=2
          MTYPE(IV2)=2
        ELSE
          MSIZE(IV2)=MSIZE(IV1)
          MTYPE(IV2)=MTYPE(IV1)
        END IF
      ELSE IF(IKEY.EQ.92.OR.IKEY.EQ.95) THEN
        IF(MTYPE(IV1).NE.1.AND.MTYPE(IV1).NE.2.AND.MTYPE(IV1).NE.8
     .    .AND.MTYPE(IV1).LT.50) THEN
          WRITE(U6,222)
          GO TO 99
        END IF
        MSIZE(IV2)=1
        MTYPE(IV2)=1
      END IF
      IF(IRC.NE.35) THEN
        IF(IFLVL.GT.0.AND.MTSAVE.NE.MTYPE(IV2))GO TO 96
      END IF
      IF(MXSIZE(IV2).LT.MSIZE(IV2))MXSIZE(IV2)=MSIZE(IV2)
      IF(IKEY.EQ.6.AND.ISTEPC.EQ.1.AND.NEWSYN.NE.1) THEN
        BLNCLS(NCLBLK)=BLNCLS(NCLBLK)+1
        CALL RINCR(9,NCLBAR,1)
        IF(BLCPNT(NCLBLK).EQ.0)BLCPNT(NCLBLK)=NCLBAR
        CLTYPE(NCLBAR)=IV2
      END IF
      I2=I2+1
   18 CONTINUE
      IF(ICWRNT.GT.0.AND.U5ECHO.EQ.1)WRITE(U6,221)
      IF(U5END.EQ.1.OR.(ALPCHK(CARD(1:1)).AND.IBEYND.EQ.1))GO TO 2
      IPT=2
      GO TO 3
    2 CONTINUE
      IPT=1
    3 CONTINUE
      RETURN
   95 CONTINUE
      WRITE(U6,200)
      GO TO 99
   96 CONTINUE
      WRITE(U6,233)
      GO TO 99
   97 CONTINUE
      WRITE(U6,234)
      GO TO 99
   98 CONTINUE
      WRITE(U6,237)
   99 CONTINUE
      CALL FSTOP
      END
C
      SUBROUTINE SET1C(IKEY,IPT,VTMPSZ,IBYCHK)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MIFLVL=7,IXFLLD=15-MIFLVL)
      PARAMETER (MAXFMT=20)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
      INTEGER VTMPSZ
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
      LOGICAL REFRSH,ALPCHK,DGTCHK
      EXTERNAL REFRSH,ALPCHK,DGTCHK
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1,
     . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX
C
      DOUBLE PRECISION RANGE(2,MRANGE)
      INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET),
     . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD),
     . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI)
C
      COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP,
     . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO,
     . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS,
     . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT,
     . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS,
     . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO,
     . NLEVEL,NRNSET,NRANGE,NHADAM,ISTEPC,IFLVL,IF1LST,IFLAST,NEWSYN,
     . IXFILL
      INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS,
     . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN,
     . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IFLAST(MIFLVL),
     . IXFILL(IXFLLD)
C
      INTEGER SVTMP2
C
  200 FORMAT(' ERROR IN SPECIFICATION')
  205 FORMAT(' UNRECOGNIZED VARIABLE NAME ',A12)
  210 FORMAT(' BY missing or unbalanced numbers of variables')
  211 FORMAT(' THIS VARIABLE IS NOT OF TYPE CLASS OR CATEGORICAL - ',A12
     .)
  212 FORMAT(' VARIABLE OF INAPPROPRIATE TYPE - ',A12)
  222 FORMAT(5X,'FOR REAL, REAL WITH MISSING, OR CROSSED REAL ONLY')
  233 FORMAT(5X,'Not permitted within if block')
  237 FORMAT(' NOT ALLOWED ON REPLICATE WEIGHT/FACTOR')
  243 FORMAT(' VPLXIN VAR. MUST BE REAL OR DERIVED')
  244 FORMAT(' UNMATCHED CLASS: ',A12)
  245 FORMAT(' MUST BE CAT OR CLASS: ',A12)
  246 FORMAT(' SIZE MISMATCH: ',A12)
  248 FORMAT(' UNMATCHED BY VAR: ',A12)
  249 FORMAT(5X,'Link to BY variables here')
  250 FORMAT(/,5X,'WARNING: Link to BY variables moved to start of level
     . 1 IF BLOCK')
C
C  Contents of MTYPE, codes for transformations
C     1  =  real variable
C     2  =  real variable with missing checks
C     3  =  categorical variable
C     4  =  class variable, known dimension
C     5  =  by variable, known dimension
C     6  =  by variable, unknown dimension
C     7  =  select transformation (not variable type)
C     8  =  cross variable, real value
C     9  =  cross variable, categorical
C    10  =  copy (not variable type)
C    21  =  boolean                 "
C    22  =  boolean - no range      "
C    23  =  and (logical and)       "
C    24  =  or                      "
C    25  =  not                     "
C    26  =  add_ms                  "
C    27  =  subtract_ms             "
C    28  =  multiply_ms             "
C    29  =  divide_ms               "
C    30  =  add                     "
C    31  =  subtract                "
C    32  =  multiply                "
C    33  =  divide                  "
C    34  =  constants               "
C    35  =  if (else if)            "
C    36  =  go to                   "
C    40  =  initial read
C    41  =  input (link)
C    42  =  input with missing (link_missing)
C               v1        v2        v3        rstpnt
C             iuinpt    status   # input      # keys
C             1st v    start x   start fmt    # fmt
C             # print   #obs
C             key x    match v   last key     var # of match v
C    43  =  add loop to replicate weights/factors
C               v1        v2        v3        rstpnt
C             1st rf/rw  # rf/rw   var
C    44  =  subtract loop to replicate weights/factors
C    45  =  multiply loop            "
C    46  =  divide   loop            "
C    47  =  output
C
C  50-60 are during REWEIGHT only
C
C    50  =  add, 0 replicate,      using vplxin data
C               v1        v2        v3        rstpnt
C             1st op   target   vplxin v     #classes
C          for each class:
C               v1        v2        v3        rstpnt
C            class/cat           0 offset    increment
C
C    51  =  subtract, 0 replicate   using vplxin data
C    52  =  multiply, 0 replicate       "
C    53  =  divide, 0 replicate         "
C    54  =  add loop to replicate weights/factors, using vplxin
C               v1        v2        v3        rstpnt
C             1st rf/rw  # rf/rw  vplxin var  #classes
C          for each class:
C               v1        v2        v3        rstpnt
C            class/cat           0 offset    increment
C
C    55  =  subtract loop to replicate weights/factors, using vplxin
C    56  =  multiply loop            "                       "
C    57  =  divide   loop            "                       "
C
C    58  =  define repf based on var ids
C               v1        v2        v3       rstpnt
C            1st rf/rw  # rf/rw     wt      #var ids
C          for each id:
C               v1        v2        v3       rstpnt
C            variance id
C          for repw, v3 will give id of weight
C    60  =  check BY variables
C               v1        v2        v3       rstpnt
C                                           #BY vars
C          for each BY var:
C               v1        v2        v3       rstpnt
C              BY id                       loc in vid
C
C    61  =  define repf based on rows of Hadamard matrix and
C           coefficients
C               v1        v2        v3       rstpnt
C            1st rf/rw  # rf/rw     wt       #sets
C          for each set:
C               v1        v2        v3       rstpnt
C              row     coefficient
C          for repw, v3 will give id of weight
C
C
C    62  =  idchange to return 1 if change in variables
C               v1        v2        v3        rstpnt
C               0     idchange       0         # keys
C           for each key:
C               0     match v    pointer to   var # of match v
C                                 last value
C
      IRC=0
      CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,N,IPOS,2,VNAME,NVIN)
      IF(N.LE.0)GO TO 95
      CALL RFADD(VTEMP(SVTEMP),N,VTMPSZ,2,IX,1)
C
C  DEFAULT ADD, SUBTRACT, ...
C
      IF(IKEY.EQ.96) THEN
        IF(N.LE.1)GO TO 95
        CALL VNMTCH('ADD ',VTEMP(SVTEMP),1,IBY)
        IF(IBY.NE.0) THEN
          IRC=30
        ELSE
          CALL VNMTCH('SUBTRACT ',VTEMP(SVTEMP),1,IBY)
          IF(IBY.NE.0) THEN
            IRC=31
          ELSE
            CALL VNMTCH('MULTIPLY ',VTEMP(SVTEMP),1,IBY)
            IF(IBY.NE.0) THEN
              IRC=32
            ELSE
              CALL VNMTCH('DIVIDE ',VTEMP(SVTEMP),1,IBY)
              IF(IBY.NE.0) THEN
                IRC=33
              ELSE
                GO TO 95
              END IF
            END IF
          END IF
        END IF
        N=N-1
        K=SVTEMP
      ELSE
        K=SVTEMP-1
C
C  IKEY=100-103 => IRC=26-29  ADD_MS, ...
C
        IF(IKEY.GE.100.AND.IKEY.LE.103) THEN
          IRC=IKEY-74
C
C  IKEY=69-72 => IRC=30-33  ADD, SUBTRACT, ...
C
        ELSE IF(IKEY.GE.69.AND.IKEY.LE.72) THEN
          IRC=IKEY-39
C
C  IKEY=93,94 => IRC=23,24  AND, OR
C
        ELSE IF(IKEY.EQ.93) THEN
          IRC=23
        ELSE IF(IKEY.EQ.94) THEN
          IRC=24
C
C  IKEY=32 => IRC=62  IDCHANGE
C
        ELSE IF(IKEY.EQ.32) THEN
          IRC=62
        END IF
      END IF
C
C  Copy variable list to top of VTEMP array
C
      SVTMP2=MVAR-N+1
      DO 32 I=1,N
      VTEMP(SVTMP2+I-1)=VTEMP(K+I)
   32 CONTINUE
      CALL VNMTCH('BY ',VTEMP(SVTMP2),N,IBY)
      IF(IBY.EQ.0) THEN
        IF(IRC.EQ.26.OR.IRC.EQ.30) THEN
          CALL VNMTCH('PLUS ',VTEMP(SVTMP2),N,IBY)
        ELSE IF(IRC.EQ.27.OR.IRC.EQ.31) THEN
          CALL VNMTCH('MINUS ',VTEMP(SVTMP2),N,IBY)
        ELSE IF(IKEY.EQ.93.OR.IKEY.EQ.94) THEN
          CALL VNMTCH('WITH ',VTEMP(SVTMP2),N,IBY)
        END IF
      END IF
      CALL VNMTCH('INTO ',VTEMP(SVTMP2),N,IINTO)
      IF(IRC.EQ.62) THEN
        IF(IINTO.NE.N-1.OR.IBY.GT.0)GO TO 95
      END IF
      N1=IBY-1
      NOUT=N1
      IF(IINTO.GT.0) THEN
        IF(IBY.EQ.0) THEN
          IF(IINTO.EQ.N-1.AND.(IRC.EQ.26.OR.IRC.EQ.28.OR.
     .       IKEY.EQ.93.OR.IKEY.EQ.94.OR.IRC.EQ.62.OR.
     .       IRC.EQ.30.OR.IRC.EQ.32)) THEN
            I2=N
            IF(IRC.EQ.62) THEN
              NOUT=1
            ELSE
              NOUT=IINTO-2
            END IF
            IBY=1
            I1INC=1
            I3INC=1
          ELSE
            WRITE(U6,210)
            GO TO 99
          END IF
        ELSE
          IF((IINTO-IBY.EQ.2.AND.N1.NE.N-IINTO).OR.
     .       (N1.EQ.1.AND.IINTO-IBY-1.NE.N-IINTO).OR.
     .       (N1.NE.1.AND.IINTO-IBY.NE.2.AND.
     .       (N1.NE.IINTO-IBY-1.OR.N1.NE.N-IINTO))) THEN
            WRITE(U6,210)
            GO TO 99
          END IF
          IF(N1.EQ.1) THEN
            I1INC=0
            NOUT=N-IINTO
          ELSE
            I1INC=1
          END IF
          IF(IINTO-IBY.EQ.2) THEN
            I3INC=0
          ELSE
            I3INC=1
          END IF
          I2=IINTO+1
        END IF
      ELSE
        IF(IBY.EQ.0.OR.(IBY.NE.N-1.AND.2*IBY.NE.N+1)) THEN
          WRITE(U6,210)
          GO TO 99
        END IF
        I1INC=1
        IF(IBY.EQ.N-1) THEN
          I3INC=0
        ELSE
          I3INC=1
        END IF
        I2=1
      END IF
      IBY=IBY+1
      I1=1
      IF(IFLVL.GT.0.AND.IKEY.EQ.31)GO TO 96
C
C  NRECDL keeps track of NRECOD with RCTYPE=54-57 so that can
C  build up a loop with the multiplication, etc., of multiple
C  replicate factors or weights.
C
      NRECDL=0
C
C  IV3 is variable following BY, PLUS, etc.
C
      DO 52 I=1,NOUT
      IF((I.EQ.1.OR.I3INC.EQ.1).AND.IRC.NE.62) THEN
        CALL VNMTCH(VTEMP(IBY+SVTMP2-1),VNAME,NVIN,IV3)
        IF(IV3.EQ.0) THEN
C
C  During REWEIGHT, check for variable from VPLX file.
C
          IF(ISTEPC.EQ.2.AND.IRC.GE.30.AND.IRC.LE.33) THEN
            K=RCEIL(2)+1
            CALL VNMTCH(VTEMP(IBY+SVTMP2-1),VNAME(K),NVREG,IV3)
            IF(IV3.GT.0) THEN
              IV3=IV3+RCEIL(2)
              IF(MTYPE(IV3).NE.1.AND.MTYPE(IV3).NE.11) THEN
                WRITE(U6,243)
                GO TO 99
              END IF
C
C  If NBY>0, check if need a RCTYPE=60 statement to check BY variables.
C
              IF(IBYCHK.EQ.0.AND.NBY.GT.0) THEN
                K=NBY+1
                CALL RINCR(4,NRECOD,K)
                J=NRECOD-K
C
C  If within an IF block, need to find top in order to place BY check
C  there.  Move intervening statements down.
C
                IF(IFLVL.GT.0) THEN
                  DO 44 KK=J,IF1LST,-1
                  V1(KK+K)=V1(KK)
                  V2(KK+K)=V2(KK)
                  IF(RCTYPE(KK).EQ.35.OR.RCTYPE(KK).EQ.36) THEN
                    IF(V3(KK).GT.0) THEN
                      V3(KK+K)=V3(KK)+K
                    ELSE IF(V3(KK).LT.0) THEN
                      V3(KK+K)=V3(KK)-K
                    ELSE
                      V3(KK+K)=0
                    END IF
                  ELSE
                    V3(KK+K)=V3(KK)
                  END IF
                  RSTPNT(KK+K)=RSTPNT(KK)
                  RCTYPE(KK+K)=RCTYPE(KK)
   44             CONTINUE
                  J=IF1LST
                  IF1LST=IF1LST+K
                  IF(U5ECHO.GT.0)WRITE(U6,250)
                  DO 45 KK=1,IFLVL
                  IF(IFLAST(KK).LT.0) THEN
                    IFLAST(KK)=IFLAST(KK)-K
                  ELSE IF(IFLAST(KK).GT.0) THEN
                    IFLAST(KK)=IFLAST(KK)+K
                  END IF
   45             CONTINUE
                ELSE
                  IF(U5ECHO.EQ.1)WRITE(U6,249)
                  J=J+1
                END IF
C
C  Placement of BY check
C
                RCTYPE(J)=60
                V1(J)=0
                V2(J)=0
                V3(J)=0
                RSTPNT(J)=NBY
                KK=RCEIL(2)+NVREG+NCLASS+NVARID
                IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN
                  KK=KK-1
                END IF
                DO 46 K=1,NBY
                KK=KK+1
                CALL VNMTCH(VNAME(KK),VNAME,NVIN,BYLIST(K))
                J=J+1
                RCTYPE(J)=0
                V1(J)=BYLIST(K)
                V2(J)=0
                V3(J)=0
                RSTPNT(J)=K+NVARID
                IF(BYLIST(K).EQ.0) THEN
                  WRITE(U6,248)VNAME(KK)
                  GO TO 99
                END IF
   46           CONTINUE
                IBYCHK=1
              END IF
            END IF
          END IF
          IF(IV3.EQ.0) THEN
            WRITE(U6,205)VTEMP(IBY+SVTMP2-1)
            GO TO 99
          END IF
        END IF
C
C  If CROSS, IV3 must be CLASS or CAT
C
        IF(IKEY.EQ.31) THEN
          IF(MTYPE(IV3).NE.3.AND.MTYPE(IV3).NE.4) THEN
            WRITE(U6,211)VTEMP(IBY+SVTMP2-1)
            GO TO 99
          END IF
        END IF
      END IF
C
C  Insure that IV1 exists.
C
      IF(I.EQ.1.OR.I1INC.EQ.1) THEN
        CALL VNMTCH(VTEMP(I1+SVTMP2-1),VNAME,NVIN,IV1)
        IF(IV1.EQ.0) THEN
          WRITE(U6,205)VTEMP(I1+SVTMP2-1)
          GO TO 99
        END IF
      END IF
C
C  IV2 is target.
C
      CALL VNMTCH(VTEMP(I2+SVTMP2-1),VNAME,NVIN,IV2)
      IV2NEW=0
      IF(IV2.EQ.0) THEN
        CALL RINCR(2,NVIN,1)
        VNAME(NVIN)=VTEMP(I2+SVTMP2-1)
        LABEL(NVIN)(1:12)=VNAME(NVIN)
        LABEL(NVIN)(13:24)='            '
        IV2=NVIN
        CALL RFCHCK(1)
        IF(IFLVL.GT.0)IVZERO=1
        NRECDL=0
        IV2NEW=1
      ELSE IF(MTYPE(IV2).GE.50) THEN
        IF(IV3.GT.NVIN) THEN
C
C  MULTIPLYING, etc. weight or replicate weight by factor from vplx
C  file.
C
C  Make sure variables match.  Thus,
C    multiply repw1 by factor into repw2
C  is not allowed.
C
          IF(IV1.NE.IV2) THEN
            WRITE(U6,237)
            GO TO 99
          END IF
C
C  If NRECDL > 0, see if can add this case to the loop.  If so,
C  complete with this case and transfer to 515 to increment IV1,
C  etc.
C
          IF(NRECDL.GT.0) THEN
            IF(MTYPE(V1(NRECDL))+V2(NRECDL).EQ.MTYPE(IV1)) THEN
              V2(NRECDL)=V2(NRECDL)+1
              GO TO 515
            END IF
          END IF
C
C  If NRECDL=0 to here, set it to NRECOD here to start potential loop
C
          CALL RINCR(4,NRECOD,1)
          NRECDL=NRECOD
          V1(NRECOD)=IV1
          V2(NRECOD)=1
          V3(NRECOD)=IV3
        ELSE IF(I.GT.1.AND.IRC.GE.30.AND.IRC.LE.33.AND.IV1.EQ.IV2)
     .      THEN
C
C  MULTIPLYING, etc. a weight or replicate weight by a regular variable
C  Check to see if should set up loop, IRC=43,...46 in place of
C  IRC=30,33.  If so, skip to 515 to avoid incrementing NRECOD.
C
          NRECDL=0
          IF(V3(NRECOD).EQ.IV3) THEN
            IF(RCTYPE(NRECOD).GE.30.AND.RCTYPE(NRECOD).LE.33) THEN
              IF(V1(NRECOD).EQ.V2(NRECOD).AND.
     .           MTYPE(V1(NRECOD))+1.EQ.MTYPE(IV1)) THEN
                RCTYPE(NRECOD)=RCTYPE(NRECOD)+13
                V2(NRECOD)=2
                GO TO 515
              END IF
            ELSE IF(RCTYPE(NRECOD).GE.43.AND.RCTYPE(NRECOD).LE.46) THEN
              IF(MTYPE(V1(NRECOD))+V2(NRECOD).EQ.MTYPE(IV1)) THEN
                V2(NRECOD)=V2(NRECOD)+1
                GO TO 515
              END IF
            END IF
          END IF
        ELSE
          NRECDL=0
        END IF
      END IF
C
C  IDCHANGE
C
      IF(IRC.EQ.62) THEN
        MTYPE(IV2)=1
        MSIZE(IV2)=1
        K=N-1
        CALL RINCR(4,NRECOD,K)
        K=K-1
        RCTYPE(NRECOD-K)=62
        V1(NRECOD-K)=0
        V2(NRECOD-K)=IV2
        V3(NRECOD-K)=0
        RSTPNT(NRECOD-K)=K
        NXPTDS=NXPTD
        CALL ROOMD(K)
        DO 47 KK=1,K
        CALL VNMTCH(VTEMP(KK+SVTMP2-1),VNAME,NVIN,IV1)
        IF(IV1.EQ.0) THEN
          WRITE(U6,205)VTEMP(KK+SVTMP2-1)
          GO TO 99
        END IF
        IF(MTYPE(IV1).NE.1)GO TO 95
        DX(NXPTDS)=-98765.432109D0
        RCTYPE(NRECOD-K+KK)=0
        V1(NRECOD-K+KK)=0
        V2(NRECOD-K+KK)=IV1
        V3(NRECOD-K+KK)=NXPTDS
        RSTPNT(NRECOD-K+KK)=IV1
        NXPTDS=NXPTDS+1
   47   CONTINUE
        GO TO 53
      END IF
      IF(NRECDL.EQ.0) THEN
        CALL RINCR(4,NRECOD,1)
      END IF
      IF(IKEY.EQ.31) THEN
        LPIV1=LPOINT(IV1)
        LPOINT(IV2)=NLEVEL+1
        IF(MTYPE(IV1).EQ.1.OR.MTYPE(IV1).EQ.2.OR.MTYPE(IV1).EQ.8.OR.
     .     MTYPE(IV1).GE.50) THEN
          IRC=8
        ELSE IF(MTYPE(IV1).EQ.3.OR.MTYPE(IV1).EQ.4.OR.
     .      MTYPE(IV1).EQ.9) THEN
          IRC=9
        ELSE
          WRITE(U6,212)VTEMP(IV1+SVTMP2-1)
          GO TO 99
        END IF
        ICDIV1=CDMPNT(IV1)
        CDMPNT(IV2)=NCRSSD+1
        IF(MTYPE(IV1).EQ.8.OR.MTYPE(IV1).EQ.9) THEN
          CALL RINCR(10,NCRSSD,1)
          CROSSD(NCRSSD)=CROSSD(ICDIV1)+1
          L=0
          K=ICDIV1+CROSSD(ICDIV1)+1
          K=CROSSD(K)
          DO 48 J=1,CROSSD(ICDIV1)
          CALL RINCR(10,NCRSSD,1)
          CROSSD(NCRSSD)=CROSSD(ICDIV1+J)
          L=L+CROSSD(NCRSSD)+1
          VTEMP(SVTEMP+J-1)=VTEMP(K)
          K=K+1
   48     CONTINUE
          KS=SVTEMP+CROSSD(ICDIV1)
          CALL RINCR(10,NCRSSD,1)
          K=LPIV1
          DO 49 J=1,L
          CALL RINCR(7,NLEVEL,1)
          LEVEL(NLEVEL)=LEVEL(K)
          K=K+1
   49     CONTINUE
        ELSE
          CROSSD(NCRSSD+1)=2
          CALL RINCR(7,NLEVEL,1)
          LEVEL(NLEVEL)=LABEL(IV1)
          IF(MTYPE(IV1).EQ.1.OR.MTYPE(IV1).EQ.2) THEN
            CROSSD(NCRSSD+2)=0
          ELSE
            CROSSD(NCRSSD+2)=MSIZE(IV1)
            K=LPIV1
            DO 50 J=1,MSIZE(IV1)
            CALL RINCR(7,NLEVEL,1)
            LEVEL(NLEVEL)=LEVEL(K)
            K=K+1
   50       CONTINUE
          END IF
          CALL RINCR(10,NCRSSD,3)
          VTEMP(SVTEMP)=VNAME(IV1)
          KS=SVTEMP+1
        END IF
        CROSSD(NCRSSD)=MSIZE(IV3)
        CALL RINCR(10,NCRSSD,1)
        CROSSD(NCRSSD)=SVTEMP
        VTEMP(KS)=VNAME(IV3)
        SVTEMP=KS+1
        CALL RCHECK(13,KS,1)
        CALL RINCR(7,NLEVEL,1)
        LEVEL(NLEVEL)=LABEL(IV3)
        K=LPOINT(IV3)
        DO 51 J=1,MSIZE(IV3)
        CALL RINCR(7,NLEVEL,1)
        LEVEL(NLEVEL)=LEVEL(K)
        K=K+1
   51   CONTINUE
        IF(IRC.EQ.9.OR.MTYPE(IV1).EQ.8.OR.MTYPE(IV1).EQ.2) THEN
          MSIZE(IV2)=MSIZE(IV1)*MSIZE(IV3)
        ELSE
          MSIZE(IV2)=2*MSIZE(IV3)
        END IF
        IF(MTYPE(IV1).EQ.3.OR.MTYPE(IV1).EQ.9) THEN
          MTYPE(IV2)=9
        ELSE
          MTYPE(IV2)=8
        END IF
      ELSE
        IF((MTYPE(IV1).NE.1.AND.MTYPE(IV1).NE.2.AND.MTYPE(IV1).NE.8
     .     .AND.MTYPE(IV1).LT.50).OR.
     .     (MTYPE(IV3).NE.1.AND.MTYPE(IV3).NE.2.AND.MTYPE(IV3).NE.8
     .     .AND.MTYPE(IV3).LT.50.AND.IV3.LE.NVIN)) THEN
          WRITE(U6,222)
          GO TO 99
        END IF
        IF(NRECDL.EQ.0) THEN
          MTSAVE=MTYPE(IV2)
          IF((IRC.NE.29.AND.(MTYPE(IV1).EQ.1.OR.MTYPE(IV1).GE.50).AND.
     .     (IV3.GT.NVIN.OR.MTYPE(IV3).EQ.1.OR.MTYPE(IV3).GE.50)).OR.
     .        IKEY.EQ.93.OR.IKEY.EQ.94.OR.(IRC.GE.30.AND.IRC.LE.33))
     .         THEN
            MSIZE(IV2)=1
            IF(MTYPE(IV2).LT.50)MTYPE(IV2)=1
          ELSE IF(MTYPE(IV1).EQ.8) THEN
            IF(MTYPE(IV2).GE.50)GO TO 98
            MTYPE(IV2)=8
            MSIZE(IV2)=MSIZE(IV1)
            CDMPNT(IV2)=CDMPNT(IV1)
            LPOINT(IV2)=LPOINT(IV1)
          ELSE
            IF(MTYPE(IV2).GE.50)GO TO 98
            MSIZE(IV2)=2
            MTYPE(IV2)=2
          END IF
          IF(IFLVL.GT.0.AND.MTSAVE.NE.MTYPE(IV2).AND.MTSAVE.LT.50.
     .       .AND.MTYPE(IV2).LT.50) THEN
            IF(IV2NEW.EQ.1) THEN
              IF(MTYPE(IV2).EQ.2) THEN
                MTSTRT(IV2)=2
              ELSE
                GO TO 96
              END IF
            END IF
          END IF
        END IF
      END IF
      IF(MXSIZE(IV2).LT.MSIZE(IV2))MXSIZE(IV2)=MSIZE(IV2)
      IF(NRECDL.EQ.0) THEN
        V1(NRECOD)=IV1
        V2(NRECOD)=IV2
        V3(NRECOD)=IV3
      END IF
      IF(IV3.LE.NVIN) THEN
        RCTYPE(NRECOD)=IRC
        RSTPNT(NRECOD)=0
      ELSE
        K=MXSIZE(IV3)
        IF(NRECDL.EQ.0) THEN
          RCTYPE(NRECOD)=IRC+20
        ELSE
          RCTYPE(NRECOD)=IRC+24
        END IF
        RSTPNT(NRECOD)=BLNCLS(K)
        IF(BLNCLS(K).GT.0) THEN
          INCX=BLXINC(K)
          ICLBAR=BLCPNT(K)
          DO 513 J=1,BLNCLS(K)
          CALL RINCR(4,NRECOD,1)
          RCTYPE(NRECOD)=0
          V2(NRECOD)=0
          IC=CLPNT(ICLBAR)+RCEIL(2)
          CALL VNMTCH(VNAME(IC),VNAME,NVIN,JJ)
          IF(JJ.EQ.0) THEN
            WRITE(U6,244)VNAME(IC)
            GO TO 99
          ELSE IF(MTYPE(JJ).NE.3.AND.MTYPE(JJ).NE.4) THEN
            WRITE(U6,245)VNAME(JJ)
            GO TO 99
          ELSE IF(MSIZE(JJ).NE.MSIZE(IC)) THEN
            WRITE(U6,246)VNAME(JJ)
            GO TO 99
          END IF
          V1(NRECOD)=JJ
          RSTPNT(NRECOD)=INCX
          IF(CLTYPE(ICLBAR).EQ.1) THEN
            V3(NRECOD)=0
            INCX=INCX*MSIZE(JJ)
          ELSE
            V3(NRECOD)=1
            INCX=INCX*(MSIZE(JJ)+1)
          END IF
          ICLBAR=ICLBAR+1
  513     CONTINUE
        END IF
      END IF
  515 CONTINUE
      IF(I2.EQ.N) THEN
        IF(I.EQ.1) THEN
          I1=I2
        END IF
      ELSE
        I2=I2+1
        I1=I1+I1INC
      END IF
      IBY=IBY+I3INC
   52 CONTINUE
   53 CONTINUE
      VTMPSZ=MVAR+1-SVTEMP
      RETURN
   95 CONTINUE
      WRITE(U6,200)
      GO TO 99
   96 CONTINUE
      WRITE(U6,233)
      GO TO 99
   98 CONTINUE
      WRITE(U6,237)
   99 CONTINUE
      CALL FSTOP
      END
C
      SUBROUTINE RFADD(VARRAY,NVA,MAXVA,INPTFL,IXM,ISTATE)
      PARAMETER (IXDIM=13)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER NVA,MAXVA,INPTFL,IXM(IXDIM,ISTATE)
      CHARACTER*12 VARRAY(MAXVA)
C
C  VARRAY - list of variable names.
C  NVA    - length of list, updated by routine
C  MAXVA  - maximum allowed length of list
C  INPTFL - 1 if list from INPUT statement,
C           2 other applications.
C
C  RFADD inspects the list in VARRAY for REPW, REPF, REPW# and REPF#
C  REPW and REPF are expanded, if possible.
C  Instructions are issued in RCTYPE etc. to generate the REPW, etc.,
C  if necessary and revises NRECOD in this case.
C
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MIFLVL=7,IXFLLD=15-MIFLVL)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1,
     . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX
C
      DOUBLE PRECISION RANGE(2,MRANGE)
      INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET),
     . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD),
     . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI)
C
      COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP,
     . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO,
     . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS,
     . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT,
     . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS,
     . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO,
     . NLEVEL,NRNSET,NRANGE,NHADAM,ISTEPC,IFLVL,IF1LST,IFLAST,NEWSYN,
     . IXFILL
      INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS,
     . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN,
     . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IFLAST(MIFLVL),
     . IXFILL(IXFLLD)
C
  101 FORMAT('REPF',I1,7X)
  102 FORMAT('REPF',I2,6X)
  103 FORMAT('REPF',I3,5X)
  104 FORMAT('REPF',I4,4X)
  105 FORMAT('REPF',I5,3X)
  201 FORMAT(/,5X,'Implicit: ',A12,'- ',A12,/)
  202 FORMAT(' UNMATCHED ID: ',A12)
  203 FORMAT(' CANNOT EXPAND REPF/W')
  204 FORMAT(/,5X,'WARNING: GENERATION MOVED TO START OF LEVEL 1 IF BLOC
     .K')
  205 FORMAT(/,5X,'WARNING: NO WEIGHT VAR')
C
      IV=1
      NRECSV=NRECOD
    1 CONTINUE
C
C  Check for a name beginning REPF or REPW, else loop to the
C  next variable name in the list.
C
      IVALUE=0
      CALL CMATCH(VARRAY(IV),1,12,'REPF',4,IPOS,2)
      IF(IPOS.GT.0) THEN
        IRT=1
      ELSE
        CALL CMATCH(VARRAY(IV),1,12,'REPW',4,IPOS,2)
        IF(IPOS.GT.0) THEN
          IRT=2
        ELSE
          GO TO 50
C                                ! Transfer to 50 increments IV and
        END IF
C                                ! loops back to 1 if not done.
      END IF
C
C  IRT  = 1  REPF
C       = 2  REPW
C       = 3  REPF* where * is a number
C       = 4  REPW* where * is a number
C
      IF(VARRAY(IV)(5:5).NE.' ') THEN
        IRT=IRT+2
        CALL IFIND(VARRAY(IV)(5:12),5,12,IPOS,IVALUE)
        IF(IPOS.EQ.0) GO TO 50
        IF(IPOS.LE.12) THEN
          IF(VARRAY(IV)(IPOS:IPOS).NE.' ')GO TO 50
        END IF
      END IF
C
C  Check for inconsistency with earlier specifications.
C
      IF((IRT.EQ.1.OR.IRT.EQ.3).AND.IREPW.EQ.1.OR.
     .  ((IRT.EQ.2.OR.IRT.EQ.4).AND.IREPF.EQ.1)) THEN
        IF(U5.GE.13.AND.U5.LE.17) THEN
          IMERR1=30302
          RETURN
        ELSE
          CALL FESTOP(30302)
        END IF
      END IF
C
C  We need to determine two numbers:
C    1) the number of variables, NRPINC, to insert into the
C       variable list, generated on the basis of REPF or REPW
C    2) the number of variables, NRPADD, that are generated by
C       a HADAMARD statement, or through the replicate
C       generation feature of REWEIGHT for the jackknife.
C
C  For REPF or REPW, determine the number of replicates, NRPINC,
C  to include and adjust the list of variables accordingly.
C  In the CREATE step, add the replicates only if a COEFFICIENTS
C  statement indicates how many, or on the basis of HADAMARD
C
C  Change 8/20/97 for REPGEN, CONVERT - NDCOEF consulted for
C  NRPINC instead of NDCOEF
C
      NRPINC=0
      IF(IRT.LE.2) THEN
        IF(ISTEPC.EQ.2) THEN
          NRPINC=NRPTOT
C                                            ! REWEIGHT
        ELSE
          NRPINC=NDCOEF
C                                            ! CREATE, REPGEN
C
C  Change 8/20/97 in effect of NHADAM - now limited to CREATE, REPGEN
C
C         IF(NHADAM.GT.NRPINC) THEN
C           NRPINC=NHADAM
C         END IF
C
          IF(NRPINC.EQ.0) THEN
            NRPINC=NHADAM
          END IF
        END IF
C
C  Not knowing how many variables to insert is a fatal flaw.
C
        IF(NRPINC.EQ.0) THEN
          IF(U5.GE.13.AND.U5.LE.17) THEN
            IMERR1=30300
            RETURN
          ELSE
            CALL FESTOP(30300)
          END IF
        END IF
        IF(NVA+NRPINC-1.GT.MAXVA) THEN
C                                            !  Resource check
          IF(U5.GE.13.AND.U5.LE.17) THEN
            IMERR1=30301
            RETURN
          ELSE
            CALL FESTOP(30301)
          END IF
C
C  For now, move other variables in VARRAY down to make space for
C  the inserted variables.
C
        ELSE IF(IV.LT.NVA) THEN
          J=NVA
          JJ=J+NRPINC-1
          DO 3 IV2=IV+1,NVA
          VARRAY(JJ)=VARRAY(J)
          JJ=JJ-1
          J=J-1
    3     CONTINUE
        END IF
      END IF
C
C  Now determine if new variables will be generated at this point
C
C  Generate REPF/W based on Hadamard matrix if not previously
C  done, if reference is to repf, repw, or a repf* or repw* where
C  * is a number less than or equal to the size of the Hadamard
C  matrix.
C
      NRPADD=0
      IHG=0
      IF(NHADAM.GT.0) THEN
C
C  Earlier version of 8/20/97  This code checks whether
C  a previous instruction has generated the hadamard matrix.
C
C       IF(IVALUE.LE.NHADAM) THEN
C         IHG=1
C         IF(NRECOD.GT.0) THEN
C           DO 4 I=1,NRECOD
C           IF(RCTYPE(I).EQ.61)IHG=0
C   4       CONTINUE
C         END IF
C       END IF
C
C  In the revised version, generate matrix only if no values have
C  been provided in the range for repw, repf
C
        IF(IVALUE.LE.NHADAM) THEN
          IHG=1
          IF(NVIN.GT.0) THEN
            DO 4 I=1,NVIN
            IF(MTYPE(I).GE.51.AND.MTYPE(I).LE.50+NHADAM)IHG=0
    4       CONTINUE
          END IF
        END IF
C
        IF(IHG.EQ.1) THEN
          NRPADD=NHADAM
          CALL RINCR(2,NVIN,1)
          NVIN1=NVIN
C                                               ! Save start of added
          NVIN=NVIN-1
C                                               ! variables
          CALL RINCR(4,NRECOD,1)
          RCTYPE(NRECOD)=61
          V3(NRECOD)=0
          IF(IRT.EQ.2.OR.IRT.EQ.4) THEN
C                                               ! For replicate weights,
            IF(IWGT.NE.0) THEN
C                                               ! use declared weight
              V3(NRECOD)=IWGT
C                                               ! variable or WEIGHT
            ELSE IF(NOWGTF.EQ.0) THEN
              CALL VNMTCH('WEIGHT ',VNAME,NVIN,V3(NRECOD))
              IF(V3(NRECOD).EQ.0) THEN
                IF(U5ECHO.GT.0)WRITE(U6,205)
              END IF
            END IF
          END IF
          V1(NRECOD)=NVIN+1
          V2(NRECOD)=NHADAM
          NRECS1=NRECOD
          RSTPNT(NRECOD)=0
C
C  Search for pairs of variables ROW# COEF#
C
          DO 5 I=1,NVIN
          CALL CMATCH(VNAME(I),1,12,'ROW',3,IPOS,2)
          IF(IPOS.GT.0) THEN
            IF(VNAME(I)(4:4).NE.' ') THEN
              CALL IFIND(VNAME(I)(4:12),4,12,IPOS,IVALUE)
              IF(IPOS.EQ.0) GO TO 5
              IF(IPOS.LE.12) THEN
                IF(VNAME(I)(IPOS:IPOS).NE.' ')GO TO 5
              END IF
              CALL RINCR(4,NRECOD,1)
              V1(NRECOD)=I
              V3(NRECOD)=0
              RCTYPE(NRECOD)=0
              RSTPNT(NRECOD)=0
              IF(IVALUE.LE.9) THEN
                WRITE(VNAME(NVIN1),101)IVALUE
              ELSE IF(IVALUE.LE.99) THEN
                WRITE(VNAME(NVIN1),102)IVALUE
              ELSE IF(IVALUE.LE.999) THEN
                WRITE(VNAME(NVIN1),103)IVALUE
              ELSE IF(IVALUE.LE.9999) THEN
                WRITE(VNAME(NVIN1),104)IVALUE
              ELSE IF(IVALUE.LE.99999) THEN
                WRITE(VNAME(NVIN1),105)IVALUE
              ELSE
                IF(U5.GE.13.AND.U5.LE.17) THEN
                  IMERR1=30303
                  RETURN
                ELSE
                  CALL FESTOP(30303)
                END IF
              END IF
              VNAME(NVIN1)(1:4)='COEF'
              CALL VNMTCH(VNAME(NVIN1),VNAME,NVIN,V2(NRECOD))
            END IF
          END IF
    5     CONTINUE
          IF(NRECOD.EQ.NRECS1) THEN
            IF(U5.GE.13.AND.U5.LE.17) THEN
              IMERR1=30304
              RETURN
            ELSE
              CALL FESTOP(30304)
            END IF
          ELSE
            RSTPNT(NRECS1)=NRECOD-NRECS1
C                                               ! Number of pairs
          END IF
        END IF
C
C  For REWEIGHT, set up pointers to create replicate factors for
C  jackknife methods.
C
      ELSE IF(ISTEPC.EQ.2) THEN
        IF(IREPW.EQ.0.AND.IREPF.EQ.0.AND.
     .     (VFTYPE.LT.5.OR.VFTYPE.GT.12)) THEN
          NRPADD=NRPTOT
          CALL RINCR(4,NRECOD,1)
          RCTYPE(NRECOD)=58
          V3(NRECOD)=0
          IF(IRT.EQ.2.OR.IRT.EQ.4) THEN
C                                                ! If appropriate,
            IF(MOD(VFTYPE,2).EQ.1) THEN
C                                                ! search for matching
              K=RCEIL(2)+NVREG+NCLASS+NID+1
C                                                ! weight variable
              IF(VFTYPE.GE.5.AND.VFTYPE.LE.12)K=K-1
              CALL VNMTCH(VNAME(K),VNAME,NVIN,V3(NRECOD))
              IF(V3(NRECOD).EQ.0) THEN
                WRITE(U6,202)VNAME(K)
                IF(U5.GE.13.AND.U5.LE.17) THEN
C                                                ! Error return if
                  IMERR1=30305
C                                                ! weight not matched
                  RETURN
                ELSE
                  CALL FESTOP(30305)
                END IF
              END IF
            END IF
          END IF
          V1(NRECOD)=NVIN+1
          V2(NRECOD)=NRPADD
          RSTPNT(NRECOD)=NVARID
          DO 10 I=1,NVARID
          CALL RINCR(4,NRECOD,1)
          RCTYPE(NRECOD)=0
          V2(NRECOD)=0
          V3(NRECOD)=0
          RSTPNT(NRECOD)=0
          K=RCEIL(2)+NVREG+NCLASS+I
          CALL VNMTCH(VNAME(K),VNAME,NVIN,V1(NRECOD))
          IF(V1(NRECOD).EQ.0) THEN
            WRITE(U6,202)VNAME(K)
            IF(U5.GE.13.AND.U5.LE.17) THEN
C                                                ! Error return if
              IMERR1=30306
C                                                ! variance identifier
              RETURN
C                                                ! not matched
            ELSE
              CALL FESTOP(30306)
              END IF
           CALL FSTOP
          END IF
   10     CONTINUE
        END IF
      END IF
C
C  Now, insert the implied number of replicate factors or weights
C  into the variable list.
C
      IF(NRPINC.GT.NRPADD) THEN
        NRPMAX=NRPINC
      ELSE
        NRPMAX=NRPADD
      END IF
      IF(NRPMAX.GT.0) THEN
        J=IV
        DO 20 I=1,NRPMAX
C
C  Except for INPUT, we add the first NRPADD variables to the overall
C  list of variables
C
        IF(I.LE.NRPADD.AND.INPTFL.EQ.2) THEN
          CALL RINCR(2,NVIN,1)
          MTYPE(NVIN)=50+I
          IF(I.LE.9) THEN
            WRITE(VNAME(NVIN),101)I
          ELSE IF(I.LE.99) THEN
            WRITE(VNAME(NVIN),102)I
          ELSE IF(I.LE.999) THEN
            WRITE(VNAME(NVIN),103)I
          ELSE IF(I.LE.9999) THEN
            WRITE(VNAME(NVIN),104)I
          ELSE IF(I.LE.99999) THEN
            WRITE(VNAME(NVIN),105)I
          ELSE
            CALL FSTOP
          END IF
          IF(IRT.EQ.2.OR.IRT.EQ.4) THEN
            VNAME(NVIN)(4:4)='W'
          END IF
          LABEL(NVIN)(1:12)=VNAME(NVIN)
          LABEL(NVIN)(13:24)='            '
        END IF
C
C  We now include the first NRPINC variables on the list.
C
        IF(I.LE.NRPINC.AND.IRT.LE.2) THEN
          IF(I.LE.9) THEN
            WRITE(VARRAY(J),101)I
          ELSE IF(I.LE.99) THEN
            WRITE(VARRAY(J),102)I
          ELSE IF(I.LE.999) THEN
            WRITE(VARRAY(J),103)I
          ELSE IF(I.LE.9999) THEN
            WRITE(VARRAY(J),104)I
          ELSE IF(I.LE.99999) THEN
            WRITE(VARRAY(J),105)I
          ELSE
            CALL FSTOP
          END IF
          IF(IRT.EQ.2) THEN
            VARRAY(J)(4:4)='W'
          END IF
        END IF
        J=J+1
   20   CONTINUE
C
C  Reposition added instructions if within an IF block, except for INPUT
C
        IF(NRPADD.GT.0) THEN
          IF(U5.LT.13.OR.U5.GT.17) THEN
            IF(U5ECHO.EQ.1)WRITE(U6,201)VNAME(NVIN-NRPADD+1),VNAME(NVIN)
            IF(IFLVL.GT.0.AND.INPTFL.EQ.2) THEN
              IF(U5ECHO.GT.0)WRITE(U6,204)
              J=NRECOD-NRECSV
              CALL RINCR(4,NRECOD,J)
C                                                ! Confirm temporary
              NRECOD=NRECOD-J
C                                                ! space
              DO 22 I=1,J
              RCTYPE(NRECOD+I)=RCTYPE(NRECSV+I)
C                                                ! Move the new commands
              V1(NRECOD+I)=V1(NRECSV+I)
C                                                ! into the temporary
              V2(NRECOD+I)=V2(NRECSV+I)
C                                                ! space
              V3(NRECOD+I)=V3(NRECSV+I)
              RSTPNT(NRECOD+I)=RSTPNT(NRECSV+I)
   22         CONTINUE
              DO 24 I=NRECSV,IF1LST,-1
C                                                ! Shift other
              RCTYPE(I+J)=RCTYPE(I)
C                                                ! commands up
              V1(I+J)=V1(I)
              V2(I+J)=V2(I)
              IF(RCTYPE(I).EQ.35.OR.RCTYPE(I).EQ.36) THEN
                IF(V3(I).GT.0) THEN
                  V3(I+J)=V3(I)+J
C                                                ! Adjust pointers for
                ELSE IF(V3(I).LT.0) THEN
C                                                ! if statements
                  V3(I+J)=V3(I)-J
                ELSE
                  V3(I+J)=0
                END IF
              ELSE
                V3(I+J)=V3(I)
              END IF
              RSTPNT(I+J)=RSTPNT(I)
   24         CONTINUE
              DO 26 I=1,J
              RCTYPE(IF1LST+I-1)=RCTYPE(NRECOD+I)
              V1(IF1LST+I-1)=V1(NRECOD+I)
C                                                ! Move new instructions
              V2(IF1LST+I-1)=V2(NRECOD+I)
C                                                ! into place
              V3(IF1LST+I-1)=V3(NRECOD+I)
              RSTPNT(IF1LST+I-1)=RSTPNT(NRECOD+I)
   26         CONTINUE
              DO 28 I=1,IFLVL
              IF(IFLAST(I).LT.0) THEN
                IFLAST(I)=IFLAST(I)-J
C                                                ! Adjust IFLAST array
              ELSE IF(IFLAST(I).GT.0) THEN
                IFLAST(I)=IFLAST(I)+J
              END IF
   28         CONTINUE
            END IF
          ELSE IF(ISTATE.GT.0) THEN
            IF(IXM(6,ISTATE).GT.0.AND.INPTFL.EQ.2) THEN
              J=NRECOD-NRECSV
              CALL RINCR(4,NRECOD,J)
C                                                ! Confirm temporary
              NRECOD=NRECOD-J
C                                                ! space
              DO 32 I=1,J
              RCTYPE(NRECOD+I)=RCTYPE(NRECSV+I)
C                                                ! Move the new commands
              V1(NRECOD+I)=V1(NRECSV+I)
C                                                ! into the temporary
              V2(NRECOD+I)=V2(NRECSV+I)
C                                                ! space
              V3(NRECOD+I)=V3(NRECSV+I)
              RSTPNT(NRECOD+I)=RSTPNT(NRECSV+I)
   32         CONTINUE
              DO 33 I=ISTATE,1,-1
              IF(IXM(6,I).EQ.0) THEN
C                                                ! Find preceding
                GO TO 34
C                                                ! statement at IF
              END IF
C                                                ! level 0
   33         CONTINUE
              I=1
C                                                ! (Not expected)
   34         CONTINUE
              IF1LST=I
              IF1LSN=IXM(10,IF1LST)
C                                                ! Start of matching
C                                                ! recode
              DO 36 I=NRECSV,IF1LSN,-1
C                                                ! Shift other
              RCTYPE(I+J)=RCTYPE(I)
C                                                ! commands up
              V1(I+J)=V1(I)
              V2(I+J)=V2(I)
              IF(RCTYPE(I).EQ.36.OR.RCTYPE(I).EQ.109) THEN
                IF(V3(I).GT.0) THEN
                  V3(I+J)=V3(I)+J
C                                                ! Adjust pointers for
                ELSE
C                                                ! if statements
                  V3(I+J)=0
                END IF
              ELSE
                V3(I+J)=V3(I)
              END IF
              RSTPNT(I+J)=RSTPNT(I)
   36         CONTINUE
              DO 38 I=1,J
              RCTYPE(IF1LSN+I-1)=RCTYPE(NRECOD+I)
              V1(IF1LSN+I-1)=V1(NRECOD+I)
C                                                ! Move new instructions
              V2(IF1LSN+I-1)=V2(NRECOD+I)
C                                                ! into place
              V3(IF1LSN+I-1)=V3(NRECOD+I)
              RSTPNT(IF1LSN+I-1)=RSTPNT(NRECOD+I)
   38         CONTINUE
              DO 39 I=IF1LST,ISTATE
              IF(IXM(5,I).GE.5.AND.IXM(5,I).LE.7) THEN
                IF(IXM(10,I).GT.0) THEN
                  IXM(10,I)=IXM(10,I)+J
                END IF
                IF(IXM(11,I).GT.0) THEN
                  IXM(11,I)=IXM(11,I)+J
                END IF
              END IF
   39         CONTINUE
            END IF
          END IF
        END IF
C
        IF(NRPINC.GT.0) THEN
          IV=IV+NRPINC-1
          NVA=NVA+NRPINC-1
        END IF
      END IF
      IF(IRT.EQ.1.OR.IRT.EQ.3) THEN
        IREPF=1
      ELSE IF(IRT.EQ.2.OR.IRT.EQ.4) THEN
        IREPW=1
      END IF
   50 CONTINUE
      IV=IV+1
      IF(IV.LE.NVA) GO TO 1
   90 CONTINUE
      RETURN
      END
C
      SUBROUTINE RFCHCK(IFLAG)
C
C  Subroutine checks whether VNAME(NVIN) is a replicate factor or
C  weight and resets MTYPE accordingly.
C
C  If IFLAG=1, it performs checks for redundant specifications.
C     IFLAG=2, set MTYPE(NVIN) only
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MAXIDS=10)
      PARAMETER (MIFLVL=7,IXFLLD=15-MIFLVL)
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP,
     . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO,
     . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS,
     . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT,
     . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS,
     . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO,
     . NLEVEL,NRNSET,NRANGE,NHADAM,ISTEPC,IFLVL,IF1LST,IFLAST,NEWSYN,
     . IXFILL
      INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS,
     . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN,
     . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IFLAST(MIFLVL),
     . IXFILL(IXFLLD)
C
C
C  RFCHCK determines if any new variable is a replicate factor or
C  weight.
C  It sets MTYPE and checks for previous duplication
C
      CALL CMATCH(VNAME(NVIN),1,12,'REPF',4,IPOS,2)
      IF(IPOS.GT.0) THEN
        IRT=1
      ELSE
        CALL CMATCH(VNAME(NVIN),1,12,'REPW',4,IPOS,2)
        IF(IPOS.GT.0) THEN
          IRT=2
        ELSE
          GO TO 90
        END IF
      END IF
C
C  IRT = 1  REPF*
C      = 2  REPW*
C
      CALL IFIND(VNAME(NVIN)(5:12),5,12,IPOS,IVALUE)
      IF(IPOS.EQ.0) GO TO 90
      IF(IPOS.LE.12) THEN
        IF(VNAME(NVIN)(IPOS:IPOS).NE.' ')GO TO 90
      END IF
      IF((IRT.EQ.1.AND.IREPW.GT.0).OR.
     .   (IRT.EQ.2.AND.IREPF.GT.0)) THEN
        IF(U5.GE.13.AND.U5.LE.17) THEN
          IMERR1=30310
          RETURN
        ELSE
          CALL FESTOP(30310)
        END IF
      ELSE IF(IRT.EQ.1) THEN
C                                              ! REPF*
        IF(IVALUE.EQ.0) THEN
C                                              ! REPF0 - set IREPF
          IREPF=2
        ELSE IF(IREPF.EQ.0) THEN
          IREPF=1
        END IF
        MTYPE(NVIN)=50+IVALUE
      ELSE
        IF(IVALUE.EQ.0) THEN
C                                              ! REPW0 - accept as
          IF(IWGT.GT.0.AND.IFLAG.EQ.1) THEN
C                                              ! weight only if no
            IF(U5.GE.13.AND.U5.LE.17) THEN
C                                              ! conflict
              IMERR1=30311
              RETURN
            ELSE
              CALL FESTOP(30311)
            END IF
          ELSE IF(IFLAG.EQ.1) THEN
            IWGT=NVIN
          END IF
C                                              ! Do not change type of
C         MTYPE(NVIN)=50                       ! REPW0
        ELSE
          MTYPE(NVIN)=50+IVALUE
          IREPW=1
        END IF
      END IF
      IF(NVIN.GT.1.AND.IFLAG.EQ.1) THEN
        DO 1 I=1,NVIN-1
        IF(MTYPE(I).EQ.50+IVALUE) THEN
          IF(U5.GE.13.AND.U5.LE.17) THEN
            IMERR1=30312
            RETURN
          ELSE
            CALL FESTOP(30312)
          END IF
        END IF
    1   CONTINUE
      END IF
   90 CONTINUE
      RETURN
      END
C
      SUBROUTINE PREAMC
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      LOGICAL ENDFLE
C
  200 FORMAT(' ERROR IN SPECIFICATION')
  201 FORMAT(' ERROR ON INCOMING FILE')
  298 FORMAT(' LOGICAL ERROR')
      READ(10)IVERSN
      IF(IVERSN.NE.9004.AND.IVERSN.NE.9203)STOP
      READ(10)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE,
     . VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR
      CALL RCHECK(2,NVTOT,0)
      NID=NVARID+NBY
      IF(IVERSN.EQ.9004)NIDTOT=NID
C
C  NVTOT   - total number of variables on file
C  NVREG  - number of variables, excluding class, variance id's,
C            BY variables, and weight variable
C  NCLASS  - total number of class variables
C  NVARID   - number of variance id's, excluding BY variables
C  NBY     - number of BY variables
C  NWGT    - 0 or 1 indicating unweighted vs. weighted analysis
C  TYPE    - type of input used to create the file
C  VROPTN  - variance option
C  TSIZE   - total size of matrix
C  NCLBLK  - total number of class blocks
C  NCLBAR  - total size of class block information arrays
C
C  TYPE = 3  Weighted obs. with cluster/replicate number
C         4  Unweighted  "
C         5  Replicate weights
C         6  Unweighted initial obs. followed by replicate weights
C         7  Replicate factors multiplying initial weight
C         8  Replicate factors of unweighted initial obs ( = TYPE 6)
C        11  Replicate factors multiplying initial weight, including
C            factor for replicate 0, overall estimate
C        12  Unweighted initial obs  "  (= TYPE 5)
C        13  Weighted obs. with cluster code
C        14  Unweighted "
C        15  Weighted obs. Stratum no. cluster code
C        16  Unweighted "
C        17  Wtd.          Stratum code, cluster code
C        18  Unwtd      "
C        21  Wtd.      Stratum no. 2nd stage no, cluster code
C        22  Unwtd.     "
C        23  Wtd.      Stratum no. 2nd stage cd, cluster code
C        24  Unwtd.     "
C        25  Wtd.      Stratum code  2nd stage no. cluster code
C        26  Unwtd      "
C        27  Wtd.      Stratum code  2nd stage cd, cluster code
C        28  Unwtd.     "
C        29  Wtd       2nd stage number cluster code
C        30  Unwtd.     "
C        31  Wtd       2nd stage code  cluster code
C        32  Unwtd      "
C        33  Wtd       Replicate number governed by stratum counts
C        34  Unwtd      "
C        35  Wtd       Rep numb govrned by stratum and 2nd stage counts
C        36  Unwtd      "
C        37  Wtd       Rep number governed by 2nd stage counts
C        38  Unwtd      "
C
      CALL RCHECK(8,NCLBLK,0)
      CALL RCHECK(9,NCLBAR,0)
      DO 1 I=1,NCLBLK
      READ(10)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I),
     . BLVSIZ(I),BLNCLS(I),BLCPNT(I)
    1 CONTINUE
      IF(NCLBAR.GT.0) THEN
        CALL INTIN(10,CLTYPE,NCLBAR,ENDFLE)
        CALL INTIN(10,CLPNT,NCLBAR,ENDFLE)
      END IF
C
C  BLTYPE  - 1 or 0 indicating row of (weighted) n vs. no row
C  BLXSTR  - pointer to first cell of incoming data in X matrix
C  BLXINC  - length of the X matrix for a single combination
C            of the class variables in the block
C  BLXSIZ  - total size of block data in X matrix (integer multiple
C            of BLXINC)
C  BLVSTR  - pointer to first variable
C  BLVSIZ  - number of variables in block
C  BLNCLS  - number of class variables in block
C  BLCPNT  - pointer for class information
C  CLTYPE  - type of class in array
C  CLPNT   - pointer to class variables
C
      RCEIL(2)=MVAR-NVTOT
      I=RCEIL(2)+1
      IF(NVTOT.GT.0) THEN
        CALL INTIN(10,MTYPE(I),NVTOT,ENDFLE)
C
C  Variable types are read into MTYPE
C
C  Contents of MTYPE
C     1  =  real variable (total)
C     2  =  real variable with missing checks
C     3  =  categorical variable
C     4  =  class variable, known dimension
C     5  =  by variable, known dimension
C     6  =  by variable, unknown dimension
C     7  =  select transformation (not variable type)
C     8  =  cross variable, real value
C     9  =  cross variable, categorical
C    11  =  derived variable
C    13  =  crossed derived variable, single dimension
C    19  =  crossed derived variable
C
        CALL INTIN(10,MSIZE(I),NVTOT,ENDFLE)
      END IF
C
C  Sizes are read into MSIZE
C
      IF(NVREG.GT.0) THEN
        CALL INTIN(10,VMAPL(I),NVREG,ENDFLE)
      END IF
C
C  VMAPL contains pointers to the first NVREG variables
C
      READ(10)NCRSSD
      CALL RCHECK(10,NCRSSD,0)
      RCEIL(10)=RCEIL(10)-NCRSSD
      ILC=RCEIL(10)+1
      IF(NCRSSD.GT.0)CALL INTIN(10,CROSSD(ILC),NCRSSD,ENDFLE)
C
C  Create an array of pointers, CDMPNT, from the variables to
C  the starting entries in CROSSD
C
      DO 3 I=RCEIL(2)+1,MVAR
      J=MTYPE(I)
      IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN
        CDMPNT(I)=ILC
        ILC=CROSSD(ILC)+ILC+2
      ELSE
        CDMPNT(I)=0
      END IF
    3 CONTINUE
      IF(MCRSSD+1.NE.ILC) THEN
        WRITE(U6,201)
        GO TO 99
      END IF
      ILC=0
C
C  Read variable names and labels, and create an array of pointers,
C  LPOINT, to labels for the levels of the variables
C
      DO 6 I=RCEIL(2)+1,MVAR
      READ(10)VNAME(I),LABEL(I)
      J=MTYPE(I)
      IF(J.EQ.3.OR.J.EQ.4.OR.J.EQ.5.OR.J.EQ.13) THEN
        LPOINT(I)=ILC+1
        ILC=ILC+MSIZE(I)
      ELSE IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN
        LPOINT(I)=ILC+1
        K=CDMPNT(I)
        L=CROSSD(K)
        DO 4 M=1,L
        K=K+1
        ILC=ILC+CROSSD(K)+1
    4   CONTINUE
      ELSE
        LPOINT(I)=0
      END IF
    6 CONTINUE
C
C  Read in labels for the levels
C
      READ(10)NCRVL
      CALL RCHECK(7,NCRVL,0)
      IF(ILC.NE.NCRVL) THEN
        WRITE(U6,201)
        GO TO 99
      END IF
      RCEIL(7)=RCEIL(7)-ILC
      IF(ILC.GT.0) THEN
        DO 8 I=RCEIL(2)+1,MVAR
        IF(LPOINT(I).GT.0)LPOINT(I)=LPOINT(I)+RCEIL(7)
    8   CONTINUE
        DO 10 I=RCEIL(7)+1,MLEVEL
        READ(10)LEVEL(I)
   10   CONTINUE
      END IF
      READ(10)ILC
C
C  Read in variable names for crossed variables
C
      CALL RCHECK(13,ILC,0)
      SVTEMP=ILC+1
      DO 12 I=1,ILC
      READ(10)VTEMP(I)
   12 CONTINUE
      IF(NBY.GE.1) THEN
        READ(10)NBYGRP
        SDBYID=NXPTD
        K=NBYGRP*NBY
        CALL ROOMD(K)
        K=SDBYID-1
        DO 17 I=1,NBYGRP
        READ(10)(DX(K+J),J=1,NBY)
        K=K+NBY
   17   CONTINUE
      ELSE
        SDBYID=0
        NBYGRP=1
      END IF
      READ(10)NRPTOT
      IF(NRPTOT.GT.0) THEN
        SDCOEF=NXPTD
        CALL ROOMD(NRPTOT)
        CALL UNFIN(10,DX(SDCOEF),NRPTOT,ENDFLE)
      ELSE
        SDCOEF=0
      END IF
      RETURN
   99 CONTINUE
      CALL FSTOP
      END
      SUBROUTINE SETUP2
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (IXFLLD=19)
      PARAMETER (MAXFMT=20)
C
C  MVAR   represents the maximum number of incoming and created
C         variables, replicate factors and wts
C  MAXIDS is the maximum number of class variables
C  MRECOD is the maximum of variables transformed by CLASS, CAT
C         MISSING, SELECT, BY etc.
C  MRANGE is the maximum number of ranges
C  MRNSET is the maximum number of sets of ranges
C  MLEVEL is the maximum number of stored labels for levels
C  MCLBLK is the maximum number of class blocks
C  MCLBAR is the maximum number of cells of class block arrays
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
C
      LOGICAL REFRSH,ALPCHK,DGTCHK
      EXTERNAL REFRSH,ALPCHK,DGTCHK
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1,
     . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX
C
      DOUBLE PRECISION RANGE(2,MRANGE)
      INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET),
     . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD),
     . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI)
C
      COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP,
     . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO,
     . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS,
     . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT,
     . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS,
     . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO,
     . NLEVEL,NRNSET,NRANGE,NHADAM,IXFILL
      INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS,
     . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN,
     . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IXFILL(IXFLLD)
C
C  Usage in this subroutine:
C
C  BLXSTR  -  Pointer for block to X matrix
C  BLVSTR  -  revised to become pointer to first variable in block
C  BLVSIZ  -  revised to number of variables in block
C  BLNCLS  -  number of class variables in block
C  BLCPNT  -  pointer for classes to CLTYPE
C  CLTYPE  -  used as pointers to class variables
C
  103 FORMAT(/,5X,'Generalized replication assumed')
  104 FORMAT(/,5X,'(Simple) jackknife replication assumed')
  105 FORMAT(/,5X,'Stratified jackknife replication assumed')
  205 FORMAT(' UNRECOGNIZED VARIABLE NAME ',A12)
  206 FORMAT(' DUPLICATED ',A12)
  220 FORMAT(' MISSING ONE OR MORE REPLICATES, INCLUDING',I6)
C
C  Changes 9/97:
C  Cluster count and replicate count will be interpreted as number
C  of replicates, excluding the full sample (replicate 0)
C
C 299 FORMAT(' IOUTC=',I5,' NVIN=',I5)
C
C  If BY variables are present, eliminate them from the list
C  of classes
C
      IF(NBY.GT.0) THEN
        ICLBAR=0
        DO 5 ICLBLK=1,NCLBLK
        IF(BLNCLS(ICLBLK).GT.0) THEN
          ICLB=BLCPNT(ICLBLK)
          NCL=0
          DO 4 I=1,BLNCLS(ICLBLK)
          DO 2 J=1,NBY
          IF(BYLIST(J).EQ.CLTYPE(ICLB))GO TO 3
    2     CONTINUE
          ICLBAR=ICLBAR+1
          CLTYPE(ICLBAR)=CLTYPE(ICLB)
          NCL=NCL+1
    3     CONTINUE
          ICLB=ICLB+1
    4     CONTINUE
          BLNCLS(ICLBLK)=NCL
          BLCPNT(ICLBLK)=ICLBAR-NCL+1
        END IF
    5   CONTINUE
        NCLBAR=ICLBAR
      END IF
C
C  If more than one block is present, ensure that the list of
C  classes for later blocks does not duplicate the first.  Under
C  the new syntax, with explicit BLOCK  / CLASS combinations,
C  this block is zeroed out in NSETP1, so BLNCLS(1)=0
C
      IF(NCLBLK.GT.1.AND.BLNCLS(1).GT.0) THEN
        ICLBAR=BLNCLS(1)
        DO 10 ICLBLK=2,NCLBLK
        IF(BLNCLS(ICLBLK).GT.0) THEN
          ICLB=BLCPNT(ICLBLK)
          NCL=0
          DO 9 I=1,BLNCLS(ICLBLK)
          DO 7 J=1,BLNCLS(1)
          IF(CLTYPE(J).EQ.CLTYPE(ICLB))GO TO 8
    7     CONTINUE
          ICLBAR=ICLBAR+1
          CLTYPE(ICLBAR)=CLTYPE(ICLB)
          NCL=NCL+1
    8     CONTINUE
          ICLB=ICLB+1
    9     CONTINUE
          BLNCLS(ICLBLK)=NCL
          BLCPNT(ICLBLK)=ICLBAR-NCL+1
        END IF
   10   CONTINUE
        NCLBAR=ICLBAR
      END IF
      NID=0
      IF(IWGT.EQ.0.AND.NOWGTF.EQ.0) THEN
C                                                  ! Default weight
        CALL VNMTCH('WEIGHT ',VNAME,NVIN,IWGT)
      END IF
      IF(ISTRCD.EQ.0.AND.ISTRNO.EQ.0) THEN
C                                                  ! ISTRC2 - match to
        CALL VNMTCH('STRATUM ',VNAME,NVIN,ISTRC2)
C                                                  ! 'STRATUM'
      END IF
      IF((IREPF.GT.0.OR.IREPW.GT.0).AND.NREPW.EQ.0) THEN
        NREPW=0
        DO 11 I=1,NVIN
C                                                  ! If replicate
        IF(MTYPE(I).GT.50+NREPW)NREPW=MTYPE(I)-50
C                                                  ! weights/factors
   11   CONTINUE
C                                                  ! appear, confirm
        DO 13 J=1,NREPW
C                                                  ! completeness
        DO 12 I=1,NVIN
        IF(MTYPE(I).EQ.50+J)GO TO 13
   12   CONTINUE
        WRITE(U6,220)J
        CALL FESTOP(30230)
C                                                  ! Error if gap
   13   CONTINUE
      END IF
      IF(IREPNO.EQ.0.AND.NREPW.EQ.0.AND.
C                                                  ! ICLUS2 - match to
     .   ICLUSN.EQ.0.AND.ICLUSC.EQ.0) THEN
C                                                  ! 'CLUSTER'
        CALL VNMTCH('CLUSTER ',VNAME,NVIN,ICLUS2)
        IF(ICLUS2.EQ.0) THEN
          CALL FESTOP(30231)
        END IF
      END IF
      IF(IREPF.GE.1.OR.IREPW.EQ.1) THEN
C                                           ! If replicate factors or
        NRPTOT=NREPW
C                                           ! weights have been
      END IF
C                                           ! established, set NRPTOT
      IF(ICLCNT.GT.0) THEN
        IF(NRPTOT.GT.0.AND.ICLCNT.NE.NRPTOT) THEN
          CALL FESTOP(30232)
        END IF
      END IF
C
C VFTYPE = 3  Weighted obs. with cluster/replicate number
C         4  Unweighted  "
C         5  Replicate weights
C         6  Unweighted initial obs. followed by replicate weights
C         7  Replicate factors multiplying initial weight
C         8  Replicate factors of unweighted initial obs ( = VFTYPE 6)
C        11  Replicate factors multiplying initial weight, including
C            factor for replicate 0, overall estimate
C        12  Unweighted initial obs  "  (= VFTYPE 5)
C        13  Weighted obs. with cluster code
C        14  Unweighted "
C        15  Weighted obs. Stratum no. cluster code
C        16  Unweighted "
C        17  Wtd.          Stratum code, cluster code
C        18  Unwtd      "
C        21  Wtd.      Stratum no. 2nd stage no, cluster code
C        22  Unwtd.     "
C        23  Wtd.      Stratum no. 2nd stage cd, cluster code
C        24  Unwtd.     "
C        25  Wtd.      Stratum code  2nd stage no. cluster code
C        26  Unwtd      "
C        27  Wtd.      Stratum code  2nd stage cd, cluster code
C        28  Unwtd.     "
C        29  Wtd       2nd stage number cluster code
C        30  Unwtd.     "
C        31  Wtd       2nd stage code  cluster code
C        32  Unwtd      "
C        33  Wtd       Replicate number governed by stratum counts
C        34  Unwtd      "
C        35  Wtd       Rep numb govrned by stratum and 2nd stage counts
C        36  Unwtd      "
C        37  Wtd       Rep number governed by 2nd stage counts
C        38  Unwtd      "
C
      IF(SDCOEF.GT.0) THEN
C                                           ! Coefficients establish
        IF(VROPTN.EQ.0) THEN
C                                           ! generalized replication
          VROPTN=5
          IF(U5ECHO.GT.0)WRITE(U6,103)
        ELSE IF(VROPTN.NE.5.AND.
     .          VROPTN.NE.6) THEN
          CALL FESTOP(30233)
C                                           ! COEFFICIENTS unexpected
        END IF
      ELSE IF(VROPTN.EQ.5) THEN
        CALL FESTOP(30251)
C                                           ! COEFFICIENTS missing
      END IF
C
C  For half-sample replication, generalized, or simple random group
C
      IF(VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5.OR.VROPTN.EQ.7) THEN
        IF(ISTRCD.GT.0.OR.ISTRNO.GT.0.OR.ISNDCD.GT.0.OR.
     .     ISNDNO.GT.0) THEN
          CALL FESTOP(30234)
C                                         ! Error if stratum/2nd stage
        END IF
C                                         ! specification
        IF(NRPTOT.EQ.0) THEN
          IF(VROPTN.EQ.7) THEN
            NRPTOT=ICLCNT
C                                         ! Except for random group,
          ELSE
C                                         ! require specification of
            IF(ICLCNT.GT.0) THEN
C                                         ! number of replicates
              NRPTOT=ICLCNT
            ELSE
              CALL FESTOP(30235)
            END IF
          END IF
        END IF
        IF(SDFPC2.GT.0) THEN
C                                         ! Check for misspecification
          CALL FESTOP(30236)
C                                         ! of FPC's
        ELSE IF(VROPTN.EQ.7) THEN
          IF(SDFPC1.GT.0.AND.NDFPC1.NE.1) THEN
            CALL FESTOP(30238)
C                                              ! too many FPC1
          END IF
        ELSE IF(SDFPC1.GT.0) THEN
          CALL FESTOP(30237)
C                                         ! FPC1 unexpected
        END IF
        NID=1
C                                         ! NID - count of ID's
        IF(ICLUSN.GT.0) THEN
          VFTYPE=4
          VIDS(NID)=ICLUSN
        ELSE IF(IREPNO.GT.0) THEN
          VFTYPE=4
          VIDS(NID)=IREPNO
        ELSE IF((ICLUSC.GT.0.OR.ICLUS2.GT.0).AND.VROPTN.EQ.7) THEN
          IF(ICLUSC.EQ.0)ICLUSC=ICLUS2
          VFTYPE=14
          VIDS(NID)=ICLUSC
        ELSE IF(IREPW.EQ.1.OR.IREPF.GE.1) THEN
          VIDS(NID)=0
          IF(IREPW.EQ.1) THEN
            VFTYPE=6
          ELSE IF(IREPF.EQ.1) THEN
            VFTYPE=8
          ELSE IF(IREPF.EQ.2) THEN
            VFTYPE=12
          END IF
        ELSE
          CALL FESTOP(30239)
        END IF
        IF(IWGT.GT.0)VFTYPE=VFTYPE-1
C
C  Adjustment of NRPTOT for random group
C
C
      ELSE IF(VROPTN.NE.6) THEN
C                                ! Simple and stratified jackknife,
C                                ! stratified random group
        IF(NRPTOT.EQ.0) THEN
          NRPTOT=ICLCNT
        END IF
        IF(ISTRCD.EQ.0.AND.ISTRNO.EQ.0.AND.
C                                           ! Recognition of stratum
     .     ISTRC2.GT.0.AND.VROPTN.NE.1) THEN
          ISTRCD=ISTRC2
        END IF
        IF(ICLUSC.EQ.0.AND.ICLUSN.EQ.0.AND.IREPNO.EQ.0.AND.
     .     VROPTN.EQ.0) THEN
C                                           ! If no explicit
          IF(ICLUS2.GT.0) THEN
C                                           ! identification of
            ICLUSC=ICLUS2
C                                           ! variance identifier,
          ELSE IF(NREPW.EQ.0) THEN
C                                           ! use a variable
            CALL FESTOP(30231)
C                                           ! named "cluster,"
          ELSE
C                                           ! else stop.
            CALL FESTOP(30264)
          END IF
        END IF
        IF(ISTRCD.GT.0.OR.ISTRNO.GT.0.OR.ISNDCD.GT.0.OR.
     .     ISNDNO.GT.0.OR.NISTRS.GT.1.OR.NISNDS.GT.0) THEN
          IF(VROPTN.NE.4.AND.VROPTN.NE.8) THEN
            IF(U5ECHO.GT.0)WRITE(U6,105)
            VROPTN=4
          END IF
          VFTYPE=0
          IF(SDFPC2.GT.0) THEN
C                                           ! Edits with FPC2
            IF(SDFPC1.EQ.0) THEN
              CALL FESTOP(30240)
            ELSE IF(ISNDCD.EQ.0.AND.ISNDNO.EQ.0.AND.SISNDS.EQ.0) THEN
              CALL FESTOP(30241)
            END IF
          END IF
          IF(ISTRNO.GT.0) THEN
C                                           ! STRATUM NUMBER
            VIDS(NID+1)=ISTRNO
            IF(ISNDNO.GT.0.OR.ISNDCD.GT.0) THEN
              NID=NID+2
              IF(ISNDNO.GT.0) THEN
                VFTYPE=22
                VIDS(NID)=ISNDNO
              ELSE
                VFTYPE=24
                VIDS(NID)=ISNDCD
              END IF
            ELSE
              VFTYPE=16
              NID=NID+1
            END IF
          ELSE IF(ISTRCD.GT.0) THEN
C                                           ! STRATUM CODE, stratum
            VIDS(NID+1)=ISTRCD
            IF(ISNDNO.GT.0.OR.ISNDCD.GT.0) THEN
              NID=NID+2
              IF(ISNDNO.GT.0) THEN
                VFTYPE=26
                VIDS(NID)=ISNDNO
              ELSE
                VFTYPE=28
                VIDS(NID)=ISNDCD
              END IF
            ELSE
              VFTYPE=18
              NID=NID+1
            END IF
          ELSE IF(ISNDNO.GT.0.OR.ISNDCD.GT.0) THEN
C                                                  ! Second-stage only
            NID=NID+1
            IF(ISNDNO.GT.0) THEN
              VFTYPE=30
              VIDS(NID)=ISNDNO
            ELSE
              VFTYPE=32
              VIDS(NID)=ISNDCD
            END IF
          END IF
          NID=NID+1
          IF(ICLUSC.GT.0) THEN
C                                           ! Cluster code
            VIDS(NID)=ICLUSC
          ELSE IF(ICLUSN.GT.0) THEN
C                                           ! Cluster number
            VIDS(NID)=ICLUSN
          ELSE IF(IREPNO.GT.0) THEN
            VIDS(NID)=IREPNO
          ELSE IF(IREPW.EQ.1.OR.IREPF.GE.1) THEN
C                                                ! Use of REPW/REPF
            VIDS(NID)=0
            IF(IREPW.EQ.1) THEN
              VFTYPE=6
            ELSE IF(IREPF.EQ.1) THEN
              VFTYPE=8
            ELSE IF(IREPF.EQ.2) THEN
              VFTYPE=12
            END IF
          ELSE
            CALL FESTOP(30242)
C                                           ! Error if no cluster/repw
          END IF
          ISUM1=0
C                                           ! Number of specified units
C                                           ! within strata
          IF(SISTRS.GT.0) THEN
            IF(NDFPC1.GT.0.AND.NDFPC1.NE.NISTRS) THEN
              CALL FESTOP(30243)
            END IF
            DO 16 I=1,NISTRS
            ISUM1=ISUM1+IX(I+SISTRS-1)
   16       CONTINUE
            IF(VFTYPE.EQ.0) THEN
C                                           ! No stratum code/number,
              IF(ICLUSN.GT.0.OR.
C                                           ! but strata determined by
     .           IREPNO.GT.0) THEN
C                                           ! cluster/replicate num
                VFTYPE=34
C                                           ! and strata counts
              ELSE
                CALL FESTOP(30248)
              END IF
            END IF
            IF(NDFPC2.GT.0.AND.NDFPC2.NE.ISUM1) THEN
              CALL FESTOP(30244)
            END IF
          END IF
          ISUM2=0
          IF(SISNDS.GT.0) THEN
            IF(ISUM1.GT.0.AND.NISNDS.NE.ISUM1) THEN
              CALL FESTOP(30245)
            ELSE IF(ISUM1.EQ.0) THEN
              IF(NDFPC1.NE.0.AND.NDFPC1.NE.1) THEN
                CALL FESTOP(30246)
              END IF
            END IF
            IF(NDFPC2.GT.0.AND.NDFPC1.EQ.0) THEN
              CALL FESTOP(30247)
            END IF
            DO 18 I=1,NISNDS
            ISUM2=ISUM2+IX(I+SISNDS-1)
   18       CONTINUE
            IF(NRPTOT.GT.0) THEN
              IF(NRPTOT.NE.ISUM2) THEN
                CALL FESTOP(30249)
              END IF
            END IF
            NRPTOT=ISUM2
            IF(VFTYPE.EQ.0) THEN
              IF(ICLUSN.GT.0.OR.IREPNO.GT.0) THEN
                VFTYPE=38
              ELSE
                CALL FESTOP(30248)
              END IF
            ELSE IF(VFTYPE.EQ.34) THEN
              VFTYPE=36
            END IF
          END IF
          IF(ISUM2.EQ.0.AND.ISUM1.GT.0) THEN
            IF(NRPTOT.GT.0) THEN
              IF(NRPTOT.NE.ISUM1) THEN
                CALL FESTOP(30250)
              END IF
            END IF
            NRPTOT=ISUM1
          END IF
        ELSE
          IF(VROPTN.EQ.0) THEN
            IF(U5ECHO.GT.0)WRITE(U6,104)
            VROPTN=1
          END IF
          NID=NID+1
          IF(NDFPC1.NE.1.AND.NDFPC1.NE.0) THEN
            CALL FESTOP(30252)
          ELSE IF(NDFPC2.GT.0) THEN
            CALL FESTOP(30253)
          END IF
          IF(ICLUSN.GT.0) THEN
            VIDS(NID)=ICLUSN
            VFTYPE=4
          ELSE IF(ICLUSC.GT.0) THEN
            VIDS(NID)=ICLUSC
            VFTYPE=14
          ELSE IF(IREPNO.GT.0) THEN
            VIDS(NID)=IREPNO
            VFTYPE=4
          ELSE IF(IREPW.EQ.1.OR.IREPF.GE.1) THEN
            VIDS(NID)=0
            IF(IREPW.EQ.1) THEN
              VFTYPE=6
            ELSE IF(IREPF.EQ.1) THEN
              VFTYPE=8
            ELSE IF(IREPF.EQ.2) THEN
              VFTYPE=12
            END IF
          ELSE
            CALL FESTOP(30248)
          END IF
          IF(SISTRS.GT.0) THEN
            IF(NISTRS.GT.1) THEN
              CALL FESTOP(30254)
            ELSE IF(NRPTOT.GT.0.AND.IX(SISTRS).NE.NRPTOT) THEN
              CALL FESTOP(30255)
            END IF
            NRPTOT=IX(SISTRS)
          END IF
        END IF
        IF(IWGT.GT.0)VFTYPE=VFTYPE-1
      ELSE
C                                           ! VROPTN=6  NONE
        NRPTOT=0
      END IF
      IF(NBY.GT.0) THEN
C                                           ! edit BY variables
        DO 24 I=1,NBY
        J=BYLIST(I)
        IF(IWGT.EQ.J) THEN
          CALL FESTOP(30261)
        ELSE IF(NID.GT.0) THEN
          DO 20 L=1,NID
          IF(VIDS(L).EQ.J) THEN
            CALL FESTOP(30262)
          END IF
   20     CONTINUE
        END IF
        IF(MTYPE(J).EQ.4) THEN
          MTYPE(J)=5
        ELSE IF(MTYPE(J).EQ.1.OR.MTYPE(J).EQ.2) THEN
          MTYPE(J)=6
        ELSE
          CALL FESTOP(30256)
        END IF
        NID=NID+1
        VIDS(NID)=J
   24   CONTINUE
      END IF
C
C  NIDTOT - the total length of the ID record on the outgoing file
C
      IF((VROPTN.EQ.4.OR.VROPTN.EQ.8).AND.
     .   (VFTYPE.LT.5.OR.VFTYPE.GT.12)) THEN
        IF(VFTYPE.GE.33) THEN
          NIDTOT=NID+2
          IF(SISTRS.GT.0)NIDTOT=NIDTOT+3
          IF(SISNDS.GT.0)NIDTOT=NIDTOT+3
        ELSE
          NIDTOT=2*NID-NBY+1
        END IF
      ELSE
        NIDTOT=NID+2
      END IF
      IOUTC=0
      BLXSTR(1)=1
      ILOC=2
C                                               ! Offset ILOC for N(1)
      IF(NCLBLK.GT.1.AND.BLVSIZ(1).EQ.0) THEN
C                                               ! When first block
        ICLBLK=2
C                                               ! contains no vars.
        BLXSTR(2)=1
   30   CONTINUE
        IF(BLVSIZ(ICLBLK).EQ.0.AND.ICLBLK.LT.NCLBLK) THEN
          ICLBLK=ICLBLK+1
          BLXSTR(ICLBLK)=ILOC
          ILOC=ILOC+1
          GO TO 30
        END IF
      ELSE
        ICLBLK=1
      END IF
      IF(VKEEPF.EQ.1.OR.NCLBLK.GT.1) THEN
C                                           ! Reverse sign of MTYPE to
        DO 32 K=1,NVIN
C                                           ! as marker for assignment
        MTYPE(K)=-IABS(MTYPE(K))
C                                           ! to block if BLOCKS
   32   CONTINUE
C                                           ! specified or if KEEP
      END IF
      IF(NKEEP.GT.0) THEN
C                                           ! If KEEP, DROP, or
        DO 36 I=1,NKEEP
C                                           ! BLOCK with one or more
        CALL VNMTCH(VNKEEP(I),VNAME,NVIN,J)
C                                           ! variables, edit list
        IF(J.EQ.0) THEN
          WRITE(U6,205)VNKEEP(I)
          CALL FESTOP(30257)
        ELSE IF(VKEEPF.EQ.1) THEN
C                                           ! Edit KEEP or BLOCK
          MTYPE(J)=IABS(MTYPE(J))
C                                           ! for type
          IF(MTYPE(J).GE.4.AND.
     .       MTYPE(J).LE.6) THEN
            CALL FESTOP(30259)
          ELSE IF(MTYPE(J).GE.50.OR.
C                                           ! Exclude weight, repw
     .            J.EQ.IWGT) THEN
            CALL FESTOP(30260)
          ELSE IF(NID.GT.0) THEN
C                                           ! Exclude var ids
            DO 34 L=1,NID
            IF(VIDS(L).EQ.J) THEN
              CALL FESTOP(30263)
            END IF
   34       CONTINUE
          END IF
          IOUTC=IOUTC+1
          IOUT(IOUTC)=J
        ELSE
C                                           ! DROP - change MTYPE to
          MTYPE(J)=-IABS(MTYPE(J))
C                                           ! negative
        END IF
   36   CONTINUE
      END IF
      K=0
      IC=0
      IF(IOUTC.EQ.0) THEN
C                                           ! If no list assembled in
        LL=NVIN
C                                           ! IOUT, loop over all vars
      ELSE
        LL=IOUTC
C                                           ! else loop over IOUT
      END IF
      DO 46 I=1,LL
      IF(IOUTC.EQ.0) THEN
        J=I
      ELSE
        J=IOUT(I)
      END IF
      IF(IABS(MTYPE(J)).EQ.49)GO TO 44
C                                           ! skip over KEY variables
      IC=IC+1
      IF(IABS(MTYPE(J)).GE.50)GO TO 44
C                                           ! skip weight, repw
      IF(J.EQ.IWGT)GO TO 44
      IF(NID.GT.0) THEN
C                                           ! skip var ids
        DO 38 L=1,NID
        IF(VIDS(L).EQ.J)GO TO 44
   38   CONTINUE
      END IF
      IF(NCLBAR.GT.0) THEN
C                                           ! skip class vars named in
        DO 40 L=1,NCLBAR
C                                           ! block statements
        IF(CLTYPE(L).EQ.J)GO TO 44
   40   CONTINUE
      END IF
      IF(MTYPE(J).GT.0) THEN
C                                           ! Exclude DROPped variables
        K=K+1
        IOUT(K)=J
        IOUTL(K)=ILOC
        VMAPL(J)=ILOC
        IF(MXSIZE(J).GT.MSIZE(J)) THEN
C                                           ! set aside the greater of
          ILOC=ILOC+MXSIZE(J)
C                                           ! the final size and
        ELSE
C                                           ! interim size
          ILOC=ILOC+MSIZE(J)
        END IF
        IF(K.GT.1) THEN
          DO 42 L=1,K-1
          IF(IOUT(L).EQ.J) THEN
C                                           ! Duplicate
            WRITE(U6,206)VNAME(J)
            CALL FESTOP(30258)
          END IF
   42     CONTINUE
        END IF
      END IF
   44 CONTINUE
      IF(IC.GE.BLVSIZ(ICLBLK)) THEN
C                                           ! Detect whether moving to next
        IF(BLVSIZ(ICLBLK).GT.0) THEN
C                                           ! block.
          BLVSIZ(ICLBLK)=K-BLVSTR(ICLBLK)+1
C                                           ! Adjust BLVSIZ to actual size.
        END IF
        IF(ICLBLK.LT.NCLBLK) THEN
          ICLBLK=ICLBLK+1
          BLXSTR(ICLBLK)=ILOC
          IF(IC.GT.BLVSIZ(ICLBLK-1)) THEN
            BLVSTR(ICLBLK)=K
          ELSE
            BLVSTR(ICLBLK)=K+1
          END IF
          ILOC=ILOC+1
          IC=0
          GO TO 44
C                                           ! Loop to check next block
        END IF
      END IF
   46 CONTINUE
      IOUTC=K
      DO 47 I=1,NVIN
C                                           ! Reverse sign all output
      MTYPE(I)=-MTYPE(I)
C                                           ! variables are negative
   47 CONTINUE
      NVREG=IOUTC
      IF(NCLBLK.EQ.1) THEN
        BLVSTR(1)=1
        BLVSIZ(1)=NVREG
      END IF
      ILOC1=ILOC-1
      IF(NCLBAR.GT.0) THEN
C                                           ! Loop over blocks to find
        NCLSS1=0
C                                           ! class variables used
        DO 52 I=1,NCLBAR
        J=CLTYPE(I)
        IF(NBY.GT.0) THEN
C                                           ! Exclude class variables
          DO 48 L=1,NBY
C                                           ! on BY list
          IF(BYLIST(L).EQ.J) GO TO 52
   48     CONTINUE
        END IF
        IF(NCLSS1.GE.1) THEN
          DO 50 L=NVREG+1,NVREG+NCLSS1
          IF(IOUT(L).EQ.J)GO TO 52
   50     CONTINUE
        END IF
        NCLSS1=NCLSS1+1
        IOUTC=IOUTC+1
        IOUT(IOUTC)=J
        IOUTL(IOUTC)=ILOC
        VMAPL(J)=ILOC
        ILOC=ILOC+MXSIZE(J)
        MTYPE(J)=-IABS(MTYPE(J))
   52   CONTINUE
        NCLASS=NCLSS1
      END IF
      IF(NID.GT.0) THEN
C                                           ! Placement of VARID's
        DO 54 I=1,NID
        J=VIDS(I)
        IF(J.EQ.0)GO TO 54
        IOUTC=IOUTC+1
        IOUT(IOUTC)=J
        IOUTL(IOUTC)=ILOC
        VMAPL(J)=ILOC
        ILOC=ILOC+MXSIZE(J)
        MTYPE(J)=-IABS(MTYPE(J))
   54   CONTINUE
      END IF
      IF(IWGT.NE.0) THEN
C                                           ! Placement of weight
        IOUTC=IOUTC+1
        IOUT(IOUTC)=IWGT
        IOUTL(IOUTC)=ILOC
        VMAPL(IWGT)=ILOC
        ILOC=ILOC+MXSIZE(IWGT)
        MTYPE(IWGT)=-IABS(MTYPE(IWGT))
      END IF
      IOUTC2=IOUTC
      IF(NREPW.GT.0) THEN
        IXFILL(5)=1
C                                           ! Setting IREPL
        IXFILL(6)=NREPW
C                                           ! Setting IREPH
        DO 58 I=1,NREPW+1
        DO 56 J=1,NVIN
        IF(IABS(MTYPE(J)).EQ.49+I) THEN
          IOUTC=IOUTC+1
          IOUT(IOUTC)=J
          IOUTL(IOUTC)=ILOC
          VMAPL(J)=ILOC
          IF(I.EQ.2)IXFILL(8)=ILOC
C                                           ! Setting of SDRWF
          ILOC=ILOC+MXSIZE(J)
          MTYPE(J)=-IABS(MTYPE(J))
          GO TO 58
        END IF
   56   CONTINUE
   58   CONTINUE
      END IF
      DO 60 J=1,NVIN
      IF(MTYPE(J).GT.0.OR.
C                                           ! Positive MTYPE are
     .   IABS(MTYPE(J)).EQ.49) THEN
C                                           ! not yet assigned
        IOUTC=IOUTC+1
C                                           ! space
        IOUT(IOUTC)=J
        IOUTL(IOUTC)=ILOC
        VMAPL(J)=ILOC
        ILOC=ILOC+MXSIZE(J)
      END IF
      MTYPE(J)=IABS(MTYPE(J))
   60 CONTINUE
      LOCEND=ILOC-1
      RETURN
      END
      SUBROUTINE CREAT1
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (IXFLLD=17)
      PARAMETER (MAXFMT=20)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1,
     . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX
C
      DOUBLE PRECISION RANGE(2,MRANGE)
      INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET),
     . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD),
     . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI)
C
      COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP,
     . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO,
     . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS,
     . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT,
     . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS,
     . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO,
     . NLEVEL,NRNSET,NRANGE,NHADAM,IXFILL,SDSTCK,MSDPTH
      INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS,
     . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN,
     . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IXFILL(IXFLLD),
     . SDSTCK,MSDPTH
C
C  Usage in this subroutine:
C
C  BLXSTR  -  pointer for block to X matrix
C  BLXINC  -  length of the X matrix for a single combination
C             of the class variables in the block
C  BLXSIZ  -  total size of block data in X matrix (integer multiple
C             of BLXINC)
C  BLVSTR  -  Pointer to first variable in block on outgoing file
C  BLVSIZ  -  Number of variables in block
C  BLNCLS  -  number of class variables in block
C  BLCPNT  -  pointer for classes to CLTYPE
C  CLTYPE  -  used as pointers to class variables
C
C
  100 FORMAT(/,5X,'Number of passes of original data =',I3)
  101 FORMAT(/,5X,'Total size of tally matrix =',I7)
  102 FORMAT(/,5X,'Size of block',I4,'  =',8X,I7)
  298 FORMAT(' LOGICAL ERROR')
C
      SIINCR=NXPTI
      CALL ROOMI(NCLBAR)
      II=SIINCR
      IBASE=1
      ICLBAR=0
      NCLBR2=0
      TSIZE=0
      NCBLK2=0
      DO 2 ICLBLK=1,NCLBLK
      IMULT=IBASE
      IF(BLNCLS(ICLBLK).GT.0) THEN
        IF(ICLBLK.EQ.1) THEN
          IF(NCLBLK.EQ.1) THEN
            NCLBR2=BLNCLS(1)
          ELSE IF(BLXSTR(2).GT.1) THEN
            NCLBR2=BLNCLS(1)
          END IF
        ELSE
          NCLBR2=NCLBR2+BLNCLS(ICLBLK)+BLNCLS(1)
        END IF
        DO 1 I=1,BLNCLS(ICLBLK)
        CALL RINCR(9,ICLBAR,1)
        IX(II)=IMULT
        IMULT=IMULT*MSIZE(CLTYPE(ICLBAR))
        II=II+1
    1   CONTINUE
        IF(ICLBLK.EQ.1)IBASE=IMULT
      ELSE IF(ICLBLK.GT.1) THEN
        NCLBR2=NCLBR2+BLNCLS(1)
      END IF
      IF(ICLBLK.EQ.NCLBLK) THEN
        BLXINC(ICLBLK)=ILOC1-BLXSTR(NCLBLK)+1
      ELSE
        BLXINC(ICLBLK)=BLXSTR(ICLBLK+1)-BLXSTR(ICLBLK)
      END IF
      IF(ICLBLK.NE.1.OR.BLXINC(ICLBLK).NE.0) THEN
        NCBLK2=NCBLK2+1
        BLXSIZ(ICLBLK)=BLXINC(ICLBLK)*IMULT
        IF(U5ECHO.GT.0)WRITE(U6,102)NCBLK2,BLXSIZ(ICLBLK)
        TSIZE=TSIZE+BLXSIZ(ICLBLK)
      ELSE
        BLXSIZ(ICLBLK)=0
      END IF
    2 CONTINUE
      CALL RCHECK(9,NCLBR2,0)
      IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN
        SDWGT=NXPTD
        K=NRPTOT+1
        CALL ROOMD(K)
      ELSE
        SDWGT=0
      END IF
      SDVIN=NXPTD
      CALL ROOMD(LOCEND)
      IF(MSDPTH.GT.0) THEN
C                                           ! Space for stack
        K=2*MSDPTH
        SDSTCK=NXPTD
        CALL ROOMD(K)
      END IF
      IF(U5ECHO.GT.0)WRITE(U6,101)TSIZE
      SDCLUS=NXPTD
      SDTOT=SDCLUS+TSIZE
      MDMX=(SIZED-SDCLUS+1)/TSIZE
      USTRT=0
      USNDS=0
      UIDS=0
      UTOT=0
      IF(MDMX.LE.0)CALL ROOMD(TSIZE)
C                                           ! Insufficient space
      IF((VROPTN.EQ.1.OR.VROPTN.EQ.7).AND.
     .   (VFTYPE.EQ.3.OR.VFTYPE.EQ.4.OR.
     .    VFTYPE.EQ.13.OR.VFTYPE.EQ.14)) THEN
        NDMX=2
        UCLUS=13
        IF(NBY.GE.1) THEN
          NSCRCH=3
          UTOT=14
          UIDS=15
        ELSE
          NSCRCH=2
          UIDS=14
        END IF
      ELSE IF((VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5).AND.
     .   (VFTYPE.EQ.3.OR.VFTYPE.EQ.4.OR.
     .    VFTYPE.EQ.13.OR.VFTYPE.EQ.14)) THEN
        NDMX=2
        IF(NBY.GE.1) THEN
          NSCRCH=2
          UCLUS=13
          UIDS=14
        ELSE
          UCLUS=11
          NSCRCH=0
        END IF
      ELSE IF((VROPTN.EQ.4.OR.VROPTN.EQ.8).AND.VFTYPE.GE.15) THEN
        UCLUS=13
        IF(VFTYPE.EQ.35.OR.VFTYPE.EQ.36.OR.
     .    (VFTYPE.GE.21.AND.VFTYPE.LE.28)) THEN
          SDTOT2=SDTOT+TSIZE
          SDTOT3=SDTOT2+TSIZE
          NDMX=4
          USTRT=14
          USNDS=15
          IF(NBY.GE.1) THEN
            UTOT=16
            UIDS=17
            NSCRCH=5
          ELSE
            NSCRCH=4
            UIDS=16
          END IF
        ELSE IF(VFTYPE.EQ.33.OR.VFTYPE.EQ.34.OR.
     .         (VFTYPE.GE.15.AND.VFTYPE.LE.18)) THEN
          SDTOT2=SDTOT+TSIZE
          NDMX=3
          USTRT=14
          IF(NBY.EQ.0) THEN
            NSCRCH=3
            UIDS=15
          ELSE
            UTOT=15
            UIDS=16
            NSCRCH=4
          END IF
        ELSE IF(VFTYPE.EQ.37.OR.VFTYPE.EQ.38.OR.
     .         (VFTYPE.GE.29.AND.VFTYPE.LE.32)) THEN
          SDTOT3=SDTOT+TSIZE
          NDMX=3
          USNDS=14
          IF(NBY.EQ.0) THEN
            NSCRCH=3
            UIDS=15
          ELSE
            UTOT=15
            UIDS=16
            NSCRCH=4
          END IF
        ELSE
          GO TO 98
        END IF
      ELSE IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN
        NDMX=MDMX
        IF(VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5) THEN
          NRPT1=NRPTOT+1
        ELSE
          NRPT1=NRPTOT
        END IF
        NPASS=(NRPT1-1)/NDMX+1
        IF(NDMX.GT.NRPT1)NDMX=NRPT1
        IF(NPASS.GT.1) THEN
          IF(U5ECHO.GT.0)WRITE(U6,100)NPASS
        END IF
        IF(VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5) THEN
          IF(NBY.EQ.0) THEN
            UCLUS=11
            NSCRCH=0
          ELSE
            UCLUS=13
            UIDS=14
            NSCRCH=2
          END IF
        ELSE IF(VROPTN.EQ.4.OR.VROPTN.EQ.8) THEN
          IF(NPASS.EQ.1) THEN
            UCLUS=13
          ELSE
            UCLUS=14
          END IF
          IF(SISTRS.GT.0.AND.SISNDS.GT.0) THEN
            SDTOT2=SDTOT+TSIZE
            SDTOT3=SDTOT2+TSIZE
            USTRT=14
            USNDS=15
            IF(NBY.GE.1) THEN
              NSCRCH=5
              UTOT=16
              UIDS=17
            ELSE
              NSCRCH=4
              UIDS=16
            END IF
          ELSE IF(SISTRS.GT.0) THEN
            SDTOT2=SDTOT+TSIZE
            USTRT=14
            IF(NBY.GE.1) THEN
              NSCRCH=4
              UTOT=15
              UIDS=16
            ELSE
              NSCRCH=3
              UIDS=15
            END IF
          ELSE IF(SISNDS.GT.0) THEN
            SDTOT3=SDTOT+TSIZE
            USNDS=14
            IF(NBY.GE.1) THEN
              NSCRCH=4
              UTOT=15
              UIDS=16
            ELSE
              NSCRCH=3
              UIDS=15
            END IF
          END IF
        ELSE
          IF(NPASS.EQ.1) THEN
            UCLUS=13
          ELSE
            UCLUS=14
          END IF
          IF(NBY.GE.1) THEN
            UTOT=14
            UIDS=15
            NSCRCH=3
          ELSE
            UIDS=14
            NSCRCH=2
          END IF
        END IF
      END IF
      ITSIZE=TSIZE*NDMX
      CALL ROOMD(ITSIZE)
      DO 3 I=1,5
      IF(I.LE.NSCRCH) THEN
        IUNIT=I+12
        CALL SCOPEN(IUNIT)
      END IF
    3 CONTINUE
      IVERSN=9203
      WRITE(11,ERR=97)IVERSN
      IF(IWGT.GT.0) THEN
        NWGT=1
      ELSE
        NWGT=0
      END IF
C
C  Calculation of NVTOT, the total number of variables on VPLX file
C  Note that NVARID will include allowance for NVARID=1 for
C  replicate weight input, even though no variable is included in
C  NVTOT
C
      NVTOT=NVREG+NCLASS+NID+NWGT
      IF(VFTYPE.GE.5.AND.VFTYPE.LE.12)NVTOT=NVTOT-1
      NVARID=NID-NBY
      WRITE(11,ERR=97)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE,
     . VROPTN,NIDTOT,TSIZE,NCBLK2,NCLBR2
      K=1
      J=1
      I=1
      DO 4 ICLBLK=1,NCLBLK
      IF(ICLBLK.NE.1.OR.BLXINC(1).GT.0) THEN
        IF(ICLBLK.EQ.1) THEN
          II=BLNCLS(ICLBLK)
        ELSE
          II=BLNCLS(ICLBLK)+BLNCLS(1)
        END IF
        WRITE(11,ERR=97)K,J,BLXINC(ICLBLK),BLXSIZ(ICLBLK),
     .    BLVSTR(ICLBLK),BLVSIZ(ICLBLK),II,I
        J=J+BLXSIZ(ICLBLK)
        I=I+II
      END IF
    4 CONTINUE
      IF(NCLBAR.GT.0) THEN
        DO 5 I=1,NCLBR2
        CLPNT(I)=1
    5   CONTINUE
        CALL INTOUT(11,CLPNT,NCLBR2)
        ICLBAR=0
        ICLB=0
        DO 8 ICLBLK=1,NCLBLK
        IF(ICLBLK.EQ.1) THEN
          IF(BLNCLS(1).GT.0) THEN
            IF(BLXINC(1).GT.0) THEN
              DO 555 I=1,BLNCLS(1)
              CLPNT(I)=-CLTYPE(I)
  555         CONTINUE
              ICLBAR=BLNCLS(1)
            END IF
            ICLB=BLNCLS(1)
          END IF
        ELSE
          IF(BLNCLS(1).GT.0) THEN
            DO 6 I=1,BLNCLS(1)
            ICLBAR=ICLBAR+1
            CLPNT(ICLBAR)=-CLTYPE(I)
    6       CONTINUE
          END IF
          IF(BLNCLS(ICLBLK).GT.0) THEN
            DO 7 I=1,BLNCLS(ICLBLK)
            ICLBAR=ICLBAR+1
            ICLB=ICLB+1
            CLPNT(ICLBAR)=-CLTYPE(ICLB)
    7       CONTINUE
          END IF
        END IF
    8   CONTINUE
        DO 10 I=NVREG+1,NVREG+NCLASS
        DO 9 J=1,NCLBR2
        IF(CLPNT(J).EQ.-IOUT(I))CLPNT(J)=I
    9   CONTINUE
   10   CONTINUE
        CALL INTOUT(11,CLPNT,NCLBR2)
      END IF
      NXPTIS=NXPTI
      CALL ROOMI(NVREG)
      IF(NVREG.GT.0) THEN
        K=NXPTIS
        IL=1
        I=0
        IBASE=1
        DO 511 ICLBLK=1,NCLBLK
        IF(ICLBLK.EQ.1) THEN
          IF(BLXINC(1).GT.0) THEN
            IL=2
          ELSE
            GO TO 511
          END IF
        ELSE
          IL=IBASE+1
        END IF
        DO 510 J=1,BLVSIZ(ICLBLK)
        I=I+1
        IX(K)=IL
        IF(MXSIZE(IOUT(I)).GT.MSIZE(IOUT(I))) THEN
          IL=IL+MXSIZE(IOUT(I))
        ELSE
          IL=IL+MSIZE(IOUT(I))
        END IF
        K=K+1
  510   CONTINUE
        IBASE=IBASE+BLXSIZ(ICLBLK)
  511   CONTINUE
      END IF
      DO 12 I=1,IOUTC2
      MXSIZE(I)=MTYPE(IOUT(I))
   12 CONTINUE
      IF(NVTOT.GT.0)CALL INTOUT(11,MXSIZE,NVTOT)
      DO 13 I=1,IOUTC2
      MXSIZE(I)=MSIZE(IOUT(I))
   13 CONTINUE
      IF(NVTOT.GT.0)CALL INTOUT(11,MXSIZE,NVTOT)
      IF(NVREG.GT.0)CALL INTOUT(11,IX(NXPTIS),NVREG)
      NXPTI=NXPTIS
      ILC=0
      IVC=0
      DO 15 I=1,IOUTC2
      J=MTYPE(IOUT(I))
      IF(J.EQ.8.OR.J.EQ.9) THEN
        K=CDMPNT(IOUT(I))
        L=CROSSD(K)
        ILC=ILC+1
        MXSIZE(ILC)=L
        DO 14 M=1,L
        K=K+1
        ILC=ILC+1
        MXSIZE(ILC)=CROSSD(K)
   14   CONTINUE
        ILC=ILC+1
        MXSIZE(ILC)=IVC+1
        IVC=IVC+L
      END IF
   15 CONTINUE
      WRITE(11,ERR=97)ILC
      IF(ILC.GT.0)CALL INTOUT(11,MXSIZE,ILC)
      ILC=0
      DO 17 I=1,IOUTC2
      J=MTYPE(IOUT(I))
      WRITE(11,ERR=97)VNAME(IOUT(I)),LABEL(IOUT(I))
      IF(J.EQ.3.OR.J.EQ.4.OR.J.EQ.5) THEN
        ILC=ILC+MSIZE(IOUT(I))
      ELSE IF(J.EQ.8.OR.J.EQ.9) THEN
        K=CDMPNT(IOUT(I))
        L=CROSSD(K)
        DO 16 M=1,L
        K=K+1
        ILC=ILC+CROSSD(K)+1
   16   CONTINUE
      END IF
   17 CONTINUE
      WRITE(11,ERR=97)ILC
      DO 20 I=1,IOUTC2
      J=MTYPE(IOUT(I))
      IF(J.EQ.3.OR.J.EQ.4.OR.J.EQ.5) THEN
        ILC=MSIZE(IOUT(I))
      ELSE IF(J.EQ.8.OR.J.EQ.9) THEN
        K=CDMPNT(IOUT(I))
        L=CROSSD(K)
        ILC=0
        DO 18 M=1,L
        K=K+1
        ILC=ILC+CROSSD(K)+1
   18   CONTINUE
      ELSE
        GO TO 20
      END IF
      L=LPOINT(IOUT(I))
      DO 19 J=1,ILC
      WRITE(11,ERR=97)LEVEL(L)
      L=L+1
   19 CONTINUE
   20 CONTINUE
      WRITE(11,ERR=97)IVC
      DO 22 I=1,IOUTC2
      J=MTYPE(IOUT(I))
      IF(J.EQ.8.OR.J.EQ.9) THEN
        K=CDMPNT(IOUT(I))
        L=CROSSD(K)
        K2=CROSSD(K+L+1)
        DO 21 M=1,L
        WRITE(11,ERR=97)VTEMP(K2)
        K2=K2+1
   21   CONTINUE
      END IF
   22 CONTINUE
      IF(UCLUS.EQ.11) THEN
        WRITE(11,ERR=97)NRPTOT
        IF(VROPTN.EQ.5) THEN
          CALL UNFOUT(11,DX(SDCOEF),NRPTOT)
        ELSE IF(VROPTN.EQ.2.OR.VROPTN.EQ.3) THEN
          IF(MSIZED-SDCLUS.LT.NRPTOT)CALL ROOMD(NRPTOT)
          DFACT=1.D0/DBLE(NRPTOT)
          DO 23 I=SDCLUS,SDCLUS+NRPTOT-1
          DX(I)=DFACT
   23     CONTINUE
          CALL UNFOUT(11,DX(SDCLUS),NRPTOT)
        END IF
      END IF
      IUPPER=SDCLUS+ITSIZE-1
      DO 24 I=SDCLUS,IUPPER
      DX(I)=0.
   24 CONTINUE
      DO 25 I=1,NVIN
      IF(VMAPL(I).GT.0) THEN
        VMAPL(I)=VMAPL(I)+SDVIN-1
        IOUTL(I)=IOUTL(I)+SDVIN-1
      END IF
   25 CONTINUE
      IXFILL(8)=IXFILL(8)+SDVIN-1
C                                    ! SDRWF
C
C  Based on VMAPL, update stored commands
C
      I=1
   27 CONTINUE
C
C  INPUT
C
      IF(RCTYPE(I).GE.40.AND.RCTYPE(I).LE.42) THEN
C
C  Check for keys, and update the pointer in V2 to the stored value
C
        IF(RSTPNT(I).GT.0) THEN
          K=RSTPNT(I)
          I=I+2
          DO 28 J=1,K
          I=I+1
          V2(I)=VMAPL(V2(I))
   28     CONTINUE
        ELSE
          I=I+2
        END IF
C
C  OUTPUT, update list of output variable locations
C
      ELSE IF(RCTYPE(I).EQ.47) THEN
        N=V1(I)
        JJ=V2(I)+1
        DO 29 K=1,N
        JJ=JJ+1
        IX(JJ)=VMAPL(IX(JJ))
   29   CONTINUE
      END IF
      I=I+1
      IF(I.LE.NRECOD)GO TO 27
      RETURN
   97 CONTINUE
      CALL FWSTOP(11)
   98 CONTINUE
      WRITE(U6,298)
   99 CONTINUE
      CALL FSTOP
      END
C
C  C4.FOR
C
      SUBROUTINE CREAT2(DONE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL DONE
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (IXFLLD=19)
      PARAMETER (MAXFMT=20)
C
C  MVAR   represents the maximum number of incoming and created
C         variables, replicate factors and wts
C  MAXIDS is the maximum number of class variables
C  MRECOD is the maximum of variables transformed by CLASS, CAT
C         MISSING, SELECT, BY etc.
C  MRANGE is the maximum number of ranges
C  MRNSET is the maximum number of sets of ranges
C  MLEVEL is the maximum number of stored labels for levels
C  MCLBLK is the maximum number of class blocks
C  MCLBAR is the maximum number of cells of class block arrays
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
C
C       NVTOT   (NTOTV)
C       NVREG   (IOUTC1)
C       NVARID  (NID1)
C
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1,
     . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX
C
      DOUBLE PRECISION RANGE(2,MRANGE)
      INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET),
     . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD),
     . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI)
C
      COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP,
     . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO,
     . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS,
     . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT,
     . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS,
     . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO,
     . NLEVEL,NRNSET,NRANGE,NHADAM,IXFILL
      INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS,
     . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN,
     . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IXFILL(IXFLLD)
      LOGICAL IXDROP
C
C  Usage in this subroutine:
C
C  BLXSTR  -  pointer for block to X matrix
C  BLXINC  -  length of the X matrix for a single combination
C             of the class variables in the block
C  BLXSIZ  -  total size of block data in X matrix (integer multiple
C             of BLXINC)
C  BLVSTR  -  Pointer to first variable in block on outgoing file
C  BLVSIZ  -  Number of variables in block
C  BLNCLS  -  number of class variables in block
C  BLCPNT  -  pointer for classes to CLTYPE
C  CLTYPE  -  used as pointers to class variables
C
      LOGICAL ENDF12,RFIRST,IDCHNG,BYCHNG,STCHNG,SNCHNG
      DOUBLE PRECISION VIDNOW(MAXIDS),VIDSAV(MAXIDS)
  201 FORMAT(/,' Sequence error for BY variables')
  202 FORMAT(/,' Sequence error for stratum/2nd/cluster identifiers')
  203 FORMAT(/,' Current values',4(/,4F18.4))
  204 FORMAT(/,' Previous values',4(/,4F18.4))
C
C  Logicals:
C
C  IXDROP - returned by RECODX to denote an entire case to be dropped
C  ENDF12 - denotes end of primary file - returned by RECODX
C  RFIRST - true when the current record is the first valid record
C  IDCHNG - denotes a change in ID(s) - stratum, cluster, etc.
C  BYCHNG - change in BY group, always false when no BY groups are used
C  STCHNG - change in stratum number/code
C  SNCHNG - change in second stage number/code
C  DONE   - set to true if this subroutine is the last needed to
C           create the VPLX file.
C
      IF(NWGT.GT.0)LWGT=VMAPL(IWGT)
      RFIRST=.TRUE.
      DNCLUS=1.
      IF(UCLUS.EQ.11) THEN
        NIDOUT=NIDTOT
        VIDSAV(NIDOUT-1)=0.
        VIDSAV(NIDOUT)=1.
      ELSE
        NIDOUT=NID
      END IF
      IF(VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5)DNCLUS=0.
      NCCLUS=1
      NBYGRP=0
C
      DONE=.FALSE.
C
C  29 is the return point when multi-passes of the input file
C  are required.
C
   29 CONTINUE
      ENDF12=.FALSE.
C
C  30 is the return point for each observation
C
   30 CONTINUE
C
C  If IVZERO=1, then initialize all data to zero (necessary when
C  one or more real variables are created within an IF condition)
C
      IF(IVZERO.EQ.1) THEN
        K=SDVIN
        DO 25 I=1,LOCEND
        DX(K)=0.
        K=K+1
   25   CONTINUE
      END IF
C
C  For each block, set the cell denoting block inclusion to 1
C
      DO 305 ICLBLK=1,NCLBLK
      DX(SDVIN+BLXSTR(ICLBLK)-1)=1.0D0
  305 CONTINUE
      IXDROP=.FALSE.
      CALL RECODX(IXDROP,ENDF12)
      IF(ENDF12)GO TO 50
C
C  Loop to expand types 3, 4, 8, and 9
C
      DO 43 I=1,NVREG
      J=IOUT(I)
      IF(MTYPE(J).EQ.3.OR.MTYPE(J).EQ.4.OR.MTYPE(J).EQ.9) THEN
        L=IOUTL(I)
        L2=L+MSIZE(J)-1
        IVAL=DX(L)
        DO 41 K=L,L2
        DX(K)=0.
   41   CONTINUE
        IF(IVAL.GT.0)DX(L+IVAL-1)=1.0D0
      ELSE IF(MTYPE(J).EQ.8) THEN
        L=IOUTL(I)
        IVAL=DX(L+1)
        XV1=DX(L)
        L2=L+MSIZE(J)-1
        DO 42 K=L,L2
        DX(K)=0.
   42   CONTINUE
        IF(IVAL.GT.0) THEN
          DX(L+2*IVAL-2)=XV1
          DX(L+2*IVAL-1)=1.0D0
        END IF
      END IF
   43 CONTINUE
C
C  Determine if there has been a change in IDs
C
      IDCHNG=.FALSE.
      BYCHNG=.FALSE.
C
C  For the first valid record, treat as a change in id
C
      IF(RFIRST) THEN
        IDCHNG=.TRUE.
        IF(NID.GT.0) THEN
          DO 44 I=1,NID
          J=VIDS(I)
          IF(J.EQ.0)GO TO 44
          VIDNOW(I)=DX(VMAPL(J))
C
C  Don't include if any of the ids - stratum, cluster, etc. are missing
C
          IF(MTYPE(J).EQ.4.AND.VIDNOW(I).EQ.0.)GO TO 30
          IF(MTYPE(J).EQ.2) THEN
            IF(DX(VMAPL(J)+1).EQ.0.) GO TO 30
          END IF
   44     CONTINUE
        END IF
C
C  For subsequent valid records, check for change in id
C
      ELSE IF(NID.GT.0) THEN
        DO 45 I=1,NID
        J=VIDS(I)
        IF(J.EQ.0) GO TO 45
        VIDNOW(I)=DX(VMAPL(J))
        IF(MTYPE(J).EQ.4.AND.VIDNOW(I).EQ.0.)GO TO 30
        IF(MTYPE(J).EQ.2) THEN
          IF(DX(VMAPL(J)+1).EQ.0.)GO TO 30
        END IF
        IF(DABS(VIDNOW(I)-VIDSAV(I)).GT..1D-5) THEN
          IDCHNG=.TRUE.
          IF(I.GT.NVARID)BYCHNG=.TRUE.
        END IF
   45   CONTINUE
C
C  If there is a change in the BY ids, check that there has
C  been an increase.
C
        IF(BYCHNG) THEN
          DO 46 I=NVARID+1,NID
          IF(VIDNOW(I).GT.VIDSAV(I)+.1D-5) GO TO 47
          IF(VIDNOW(I).LT.VIDSAV(I)-.1D-5) THEN
            WRITE(U6,201)
            WRITE(U6,203)(VIDNOW(K),K=NVARID+1,NID)
            WRITE(U6,204)(VIDSAV(K),K=NVARID+1,NID)
            CALL FESTOP(34001)
          END IF
   46     CONTINUE
   47     CONTINUE
C
C  If there is a change in the var ids without a change in the BY ids,
C  check that there is an increase in the var ids.
C
        ELSE IF(IDCHNG) THEN
          DO 48 I=1,NVARID
          IF(VIDNOW(I).GT.VIDSAV(I)+.1D-5) GO TO 49
          IF(VIDNOW(I).LT.VIDSAV(I)-.1D-5) THEN
            WRITE(U6,202)
            WRITE(U6,203)(VIDNOW(K),K=1,NVARID)
            WRITE(U6,204)(VIDSAV(K),K=1,NVARID)
            CALL FESTOP(34002)
          END IF
   48     CONTINUE
   49     CONTINUE
        END IF
      END IF
   50 CONTINUE
C
C  Come here to finish processing of previous data before processing
C  the current record (or at end of file)
C
      IF(IDCHNG.OR.ENDF12) THEN
        IF(VFTYPE.LT.5.OR.VFTYPE.GT.12) THEN
          IF(.NOT.RFIRST) THEN
C
C  Write out cluster-level data and add to stratum and second-stage
C  totals.
C
            IF(NID.GT.0)WRITE(UNIT=UCLUS,ERR=971)(VIDSAV(I),I=1,NIDOUT)
            CALL UNFOUT(UCLUS,DX(SDCLUS),TSIZE)
            IF(USTRT.GT.0) THEN
              DO 51 I=1,TSIZE
              DX(SDTOT2+I-1)=DX(SDTOT2+I-1)+DX(SDCLUS+I-1)
   51         CONTINUE
            END IF
            IF(USNDS.GT.0) THEN
              DO 52 I=1,TSIZE
              DX(SDTOT3+I-1)=DX(SDTOT3+I-1)+DX(SDCLUS+I-1)
   52         CONTINUE
            END IF
            IF(VROPTN.EQ.1.OR.VROPTN.EQ.4.OR.
     .         VROPTN.EQ.7.OR.VROPTN.EQ.8) THEN
              DO 53 I=1,TSIZE
              DX(SDTOT+I-1)=DX(SDTOT+I-1)+DX(SDCLUS+I-1)
   53         CONTINUE
            END IF
            NCCLUS=NCCLUS+1
            DO 54 I=SDCLUS,SDTOT-1
            DX(I)=0.
   54       CONTINUE
            IF(UIDS.GT.0)WRITE(UNIT=UIDS,ERR=975)(VIDSAV(I),I=1,NID)
C
C  Now check if the stratum has changed.  If so, write to file.
C
            IF(USTRT.GT.0) THEN
              STCHNG=.FALSE.
              IF(ENDF12.OR.BYCHNG) THEN
                STCHNG=.TRUE.
              ELSE IF(VFTYPE.GE.15.AND.VFTYPE.LE.28) THEN
                IF(DABS(VIDSAV(1)-VIDNOW(1)).GT..1D-5)STCHNG=.TRUE.
              ELSE IF(VFTYPE.GE.33.AND.VFTYPE.LE.36) THEN
                I=SISTRS
                J=SISNDS
                NC1=VIDSAV(1)+.5D0
                NC2=VIDNOW(1)+.5D0
                IST1=0
                IST2=0
                IBOUND=0
                DO 56 L=1,NISTRS
                IF(VFTYPE.LE.34) THEN
                  IBOUND=IBOUND+IX(I)
                ELSE
                  KK=IX(I)
                  DO 55 K=1,KK
                  IBOUND=IBOUND+IX(J)
                  J=J+1
   55             CONTINUE
                END IF
                IF(IST1.EQ.0.AND.IBOUND.GE.NC1)IST1=L
                IF(IST2.EQ.0.AND.IBOUND.GE.NC2)IST2=L
                I=I+1
   56           CONTINUE
                IF(IST1.NE.IST2)STCHNG=.TRUE.
              END IF
              IF(STCHNG) THEN
                WRITE(UNIT=USTRT,ERR=972)(VIDSAV(I),I=1,NID)
                CALL UNFOUT(USTRT,DX(SDTOT2),TSIZE)
                DO 60 I=SDTOT2,SDTOT2+TSIZE-1
                DX(I)=0.
   60           CONTINUE
              END IF
            END IF
C
C  Similarly, check if the second-stage has changed.
C
            IF(USNDS.GT.0) THEN
              SNCHNG=.FALSE.
              IF(ENDF12.OR.BYCHNG) THEN
                SNCHNG=.TRUE.
              ELSE IF(VFTYPE.GE.21.AND.VFTYPE.LE.28) THEN
                IF(DABS(VIDSAV(2)-VIDNOW(2)).GT..1D-5)SNCHNG=.TRUE.
              ELSE IF(VFTYPE.GE.29.AND.VFTYPE.LE.32) THEN
                IF(DABS(VIDSAV(1)-VIDNOW(1)).GT..1D-5)SNCHNG=.TRUE.
              ELSE IF(VFTYPE.GE.35.AND.VFTYPE.LE.38) THEN
                J=SISNDS
                NC1=VIDSAV(1)+.5D0
                NC2=VIDNOW(1)+.5D0
                IST1=0
                IST2=0
                IBOUND=0
                DO 61 L=1,NISNDS
                IBOUND=IBOUND+IX(J)
                J=J+1
                IF(IST1.EQ.0.AND.IBOUND.GE.NC1)IST1=L
                IF(IST2.EQ.0.AND.IBOUND.GE.NC2)IST2=L
                I=I+1
   61           CONTINUE
                IF(IST1.NE.IST2)STCHNG=.TRUE.
              END IF
              IF(SNCHNG) THEN
                WRITE(UNIT=USNDS,ERR=973)(VIDSAV(I),I=1,NID)
                CALL UNFOUT(USNDS,DX(SDTOT3),TSIZE)
                DO 62 I=SDTOT3,SDTOT3+TSIZE-1
                DX(I)=0.
   62           CONTINUE
              END IF
            END IF
            IF(BYCHNG.OR.ENDF12) THEN
              NBYGRP=NBYGRP+1
              NCCLUS=1
              IF(UTOT.GT.0) THEN
                WRITE(UNIT=UTOT,ERR=974)(VIDSAV(I),I=1,NID)
                CALL UNFOUT(UTOT,DX(SDTOT),TSIZE)
                DO 64 I=SDTOT,SDTOT+TSIZE-1
                DX(I)=0.
   64           CONTINUE
              END IF
            END IF
            IF(ENDF12)GO TO 90
          ELSE
            IF(ENDF12) THEN
              CALL FESTOP(34003)
            ELSE
              RFIRST=.FALSE.
            END IF
          END IF
C
C  This else covers types 5-12 (replicate weights/factors)
C
        ELSE
          IF(.NOT.RFIRST.OR.ENDF12.OR.BYCHNG) THEN
            IF(NCCLUS.EQ.1) THEN
              NBYGRP=NBYGRP+1
              IF(UIDS.GT.0.AND.NID.GT.1) THEN
                WRITE(UNIT=UIDS,ERR=975)(VIDSAV(K),K=2,NID)
              END IF
            END IF
            DO 65 I=1,NDMX
            VIDSAV(1)=DNCLUS+DBLE(I-1)
            WRITE(UNIT=UCLUS,ERR=971)(VIDSAV(K),K=1,NIDOUT)
            J=SDCLUS+(I-1)*TSIZE
            CALL UNFOUT(UCLUS,DX(J),TSIZE)
   65       CONTINUE
            DO 66 I=SDCLUS,IUPPER
            DX(I)=0.
   66       CONTINUE
            IF(ENDF12) THEN
              NCCLUS=NCCLUS+NDMX
              DNCLUS=DNCLUS+DBLE(NDMX)
              IF(NCCLUS.GT.NRPT1)GO TO 90
              IF(NCCLUS+NDMX-1.GT.NRPT1) THEN
                NDMX=NRPT1-NCCLUS+1
              END IF
C
C  On end of file, loop through commands to update.
C
              IF(NRECOD.GT.0) THEN
                I=1
   67           CONTINUE
C
C  INPUT, rewind unit and set number read to 0
C
                IF(RCTYPE(I).GE.40.AND.RCTYPE(I).LE.42) THEN
                  REWIND(UNIT=V1(I))
                  V2(I)=0
C
C  IDCHANGE, store missing for previous IDs
C
                ELSE IF(RCTYPE(I).EQ.62.OR.RCTYPE(I).EQ.142) THEN
                  DO 671 ITMP=1,RSTPNT(I)
                  DX(V3(I+ITMP))=-98765.432109D0
  671             CONTINUE
                  I=I+RSTPNT(I)
C
C  PRINT
C
                ELSE IF(RCTYPE(I).EQ.63) THEN
                  V2(I)=0
                END IF
                I=I+1
                IF(I.LE.NRECOD)GO TO 67
              END IF
              RFIRST=.TRUE.
              GO TO 29
            END IF
          ELSE
            RFIRST=.FALSE.
          END IF
        END IF
        IF(NID.GT.0) THEN
          DO 69 I=1,NID
          VIDSAV(I)=VIDNOW(I)
   69     CONTINUE
        END IF
      END IF
C
C  If the current observation is to be dropped, return to 30
C
      IF(IXDROP) GO TO 30
      IBASE1=0
      J=SDCLUS
      IS=SIINCR
C
C  Compute index to account for all global class variables.  If
C  any are out of range, return to 30.  IBASE1 is used as a
C  starting point in computations below.
C
      IF(BLNCLS(1).GE.1) THEN
        DO 71 I=1,BLNCLS(1)
        IV1=VMAPL(CLTYPE(I))
        IV2=DX(IV1)
        IF(IV2.LE.0)GO TO 30
        IBASE1=IBASE1+IX(IS)*(IV2-1)
        IS=IS+1
   71   CONTINUE
      END IF
C
C  Add in contribution of this observation, for types 1-4, 13+
C
      IF(VFTYPE.LT.5.OR.VFTYPE.GT.12) THEN
        IF(MOD(VFTYPE,2).EQ.1.OR.VROPTN.EQ.2) THEN
          IF(MOD(VFTYPE,2).EQ.0) THEN
            WGT=1.0D0
          ELSE
            WGT=DX(LWGT)
          END IF
          IF(VROPTN.EQ.2.AND.NCCLUS.GT.1)WGT=2.D0*WGT
          IF(WGT.NE.0.) THEN
C
C  The loop to 75 considers each block and determines whether the
C  observation is still included.
C
            DO 75 ICLBLK=1,NCLBLK
            IBASE=IBASE1
            IF(ICLBLK.GT.1) THEN
              IF(BLNCLS(ICLBLK).GT.0) THEN
                DO 72 I=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1
                IV1=VMAPL(CLTYPE(I))
                IV2=DX(IV1)
                IF(IV2.LE.0) THEN
                  IS=IS+BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-I
                  GO TO 74
                END IF
                IBASE=IBASE+IX(IS)*(IV2-1)
                IS=IS+1
   72           CONTINUE
              END IF
            END IF
            KK=J+BLXINC(ICLBLK)*IBASE
            KL=SDVIN+BLXSTR(ICLBLK)-1
            IF(DX(KL).EQ.0.)GO TO 74
            DO 73 K=1,BLXINC(ICLBLK)
            IF(DX(KL).NE.0.) THEN
              DX(KK)=DX(KK)+WGT*DX(KL)
            END IF
            KK=KK+1
            KL=KL+1
   73       CONTINUE
   74       CONTINUE
            J=J+BLXSIZ(ICLBLK)
   75       CONTINUE
          END IF
C
C  Treatment for unweighted data
C  Note: there is some overlap in algorithm compared to previous code
C  but this code is separated for efficient processing
C
        ELSE
          DO 175 ICLBLK=1,NCLBLK
          IBASE=IBASE1
          IF(ICLBLK.GT.1) THEN
            IF(BLNCLS(ICLBLK).GT.0) THEN
              DO 172 I=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1
              IV1=VMAPL(CLTYPE(I))
              IV2=DX(IV1)
              IF(IV2.LE.0) THEN
                IS=IS+BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-I
                GO TO 174
              END IF
              IBASE=IBASE+IX(IS)*(IV2-1)
              IS=IS+1
  172         CONTINUE
            END IF
          END IF
          KK=J+BLXINC(ICLBLK)*IBASE
          KL=SDVIN+BLXSTR(ICLBLK)-1
          IF(DX(KL).EQ.0.)GO TO 174
          DO 173 K=1,BLXINC(ICLBLK)
          IF(DX(KL).NE.0.) THEN
            DX(KK)=DX(KK)+DX(KL)
          END IF
          KK=KK+1
          KL=KL+1
  173     CONTINUE
  174     CONTINUE
          J=J+BLXSIZ(ICLBLK)
  175     CONTINUE
        END IF
C
C  Treatment for VFTYPE 5-12
C
      ELSE
        DO 77 I=1,NDMX
        J=I+NCCLUS-2
        IF(J.EQ.0) THEN
          IF(VFTYPE.EQ.5.OR.VFTYPE.EQ.7.OR.VFTYPE.EQ.11) THEN
            WGT=DX(LWGT)
            IF(VFTYPE.EQ.11)WGT=WGT*DX(IOUTL(IOUTC2+1))
          ELSE
            WGT=1.0D0
          END IF
        ELSE
          IF(VFTYPE.EQ.5.OR.VFTYPE.EQ.6.OR.VFTYPE.EQ.8) THEN
            WGT=DX(IOUTL(IOUTC2+J))
          ELSE IF(VFTYPE.EQ.7) THEN
            WGT=DX(IOUTL(IOUTC2+J))*DX(LWGT)
          ELSE IF(VFTYPE.EQ.11) THEN
            WGT=DX(IOUTL(IOUTC2+J+1))*DX(LWGT)
          ELSE IF(VFTYPE.EQ.12) THEN
            WGT=DX(IOUTL(IOUTC2+J+1))
          END IF
          IF(VROPTN.EQ.2)WGT=2.D0*WGT
        END IF
        DX(SDWGT+I-1)=WGT
   77   CONTINUE
        I2=SDWGT+NDMX-1
        J=SDCLUS
        DO 88 ICLBLK=1,NCLBLK
        IBASE=IBASE1
        IF(ICLBLK.GT.1) THEN
          IF(BLNCLS(ICLBLK).GT.0) THEN
            DO 81 I=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1
            IV1=VMAPL(CLTYPE(I))
            IV2=DX(IV1)
            IF(IV2.LE.0) THEN
              IS=IS+BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-I
              GO TO 87
            END IF
            IBASE=IBASE+IX(IS)*(IV2-1)
            IS=IS+1
   81       CONTINUE
          END IF
        END IF
        KK=J+BLXINC(ICLBLK)*IBASE
        KL=SDVIN+BLXSTR(ICLBLK)-1
        IF(DX(KL).EQ.0.)GO TO 87
        DO 84 K=1,BLXINC(ICLBLK)
        IF(DX(KL).NE.0.) THEN
          TEMP=DX(KL)
          IBASE2=KK
          DO 83 I=SDWGT,I2
C
C  Possible optimization if many replicate weights are zero
C
C       IF(DX(I).EQ.0.)GO TO 82
C
          DX(IBASE2)=DX(IBASE2)+DX(I)*TEMP
   82     CONTINUE
          IBASE2=IBASE2+TSIZE
   83     CONTINUE
        END IF
        KK=KK+1
        KL=KL+1
   84   CONTINUE
   87   CONTINUE
        J=J+BLXSIZ(ICLBLK)
   88   CONTINUE
      END IF
      GO TO 30
C
C  We come here at end of all processing
C
   90 CONTINUE
      IF(UCLUS.EQ.11) THEN
        DONE=.TRUE.
        CLOSE(UNIT=11)
      END IF
C
C  Close all input files
C
      DO 91 IRECOD=1,NRECOD
      IF(RCTYPE(IRECOD).GE.40.AND.RCTYPE(IRECOD).LE.42) THEN
        CLOSE(UNIT=V1(IRECOD))
      END IF
   91 CONTINUE
      RETURN
C
C  Error returns for output write error.
C
  971 CONTINUE
      UIDS=UCLUS
      GO TO 975
  972 CONTINUE
      UIDS=USTRT
      GO TO 975
  973 CONTINUE
      UIDS=USNDS
      GO TO 975
  974 CONTINUE
      UIDS=UTOT
      GO TO 975
  975 CONTINUE
      CALL FWSTOP(UIDS)
      END
C
C  End of C4.for
C
      SUBROUTINE CREAT3(DONE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL DONE
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (IXFLLD=19)
      PARAMETER (MAXFMT=20)
C
C  MVAR   represents the maximum number of incoming and created
C         variables, replicate factors and wts
C  MAXIDS is the maximum number of class variables
C  MRECOD is the maximum of variables transformed by CLASS, CAT
C         MISSING, SELECT, BY etc.
C  MRANGE is the maximum number of ranges
C  MRNSET is the maximum number of sets of ranges
C  MLEVEL is the maximum number of stored labels for levels
C  MCLBLK is the maximum number of class blocks
C  MCLBAR is the maximum number of cells of class block arrays
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
C
C       NVTOT   (NTOTV)
C       NVREG   (IOUTC1)
C       NVARID  (NID1)
C
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1,
     . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX
C
      DOUBLE PRECISION RANGE(2,MRANGE)
      INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET),
     . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD),
     . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI)
C
      COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP,
     . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO,
     . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS,
     . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT,
     . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS,
     . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO,
     . NLEVEL,NRNSET,NRANGE,NHADAM,IXFILL
      INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS,
     . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN,
     . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IXFILL(IXFLLD)
C
      LOGICAL ENDF12
      DOUBLE PRECISION VIDNOW(MAXIDS),VIDSAV(MAXIDS)
      INTEGER UOUT,SISTR2,SISND2,SDBLST
      LOGICAL ICHECK
      EXTERNAL ICHECK
C
  102 FORMAT(/,5X,' Maximum stratum number is',I6)
  103 FORMAT(/,5X,I6,' strata observed on incoming file')
  104 FORMAT(/,5X,I6,' second-stage units observed on incoming file')
  201 FORMAT(/,' STRATUM NUMBER ',D20.12,' IS NOT AN INTEGER')
  202 FORMAT(/,' MAXIMUM STRATUM NUMBER ',I8,' EXCEEDS EXPECTED',I5)
  203 FORMAT(/,5X,'ONLY ',I5,' STRATA OBSERVED FROM EXPECTED',I6)
  204 FORMAT(/,' OSBERVED STRATA ',I5,' EXCEEDS EXPECTED',I5)
  205 FORMAT(/,' SECOND-STAGE NUMBER ',D20.12,' IS NOT AN INTEGER')
  206 FORMAT(/,' CLUSTER NUMBER ',D20.12,' IS NOT AN INTEGER')
  207 FORMAT(' OR IS OUT OF RANGE')
  208 FORMAT(/,' IN STRATUM NUMBER',I3,' COUNT',I5,' OF UNITS EXCEEDS EX
     .PECTED',I5)
  209 FORMAT(/,' OBSERVED SECOND-STAGE UNITS',I4,' EXCEEDS EXPECTED',I4)
  210 FORMAT(/,' IN SECOND-STAGE NUMBER',I4,' COUNT',I5,' OF UNITS EXCEE
     .DS EXPECTED',I5)
      DONE=.FALSE.
      IF(UCLUS.GT.0.AND.UCLUS.NE.11)REWIND(UNIT=UCLUS)
      IF(USTRT.GT.0)REWIND(UNIT=USTRT)
      IF(USNDS.GT.0)REWIND(UNIT=USNDS)
      IF(UTOT.GT.0)REWIND(UNIT=UTOT)
      IF(UIDS.GT.0)REWIND(UNIT=UIDS)
      IF(UTOT.GT.0) THEN
        NXPTD=SDCLUS
      ELSE
        NXPTD=SDTOT+TSIZE
      END IF
      IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN
C
C  If VFTYPE is 5-12, then UIDS will contain the values of the BY
C  variables defining the BY groups.  These are written to the
C  output VPLX file here.
C
        IF(NBY.GE.1) THEN
          WRITE(11)NBYGRP
          DO 2 I=1,NBYGRP
          READ(UNIT=UIDS)(VIDSAV(ID),ID=2,NID)
          WRITE(11)(VIDSAV(ID),ID=2,NID)
    2     CONTINUE
        END IF
C
C  If VFTYPE is 5-12 and UCLUS has been used, write NRPTOT and
C  the replicate factors to the output at this point.
C  For VROPTN=5, general replication, replicate factors have
C  already been provided.  For VROPTN=2 or 3, half-sample
C  replication, compute them here.
C
        IF(UCLUS.EQ.13.AND.
     .    (VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5)) THEN
          WRITE(11)NRPTOT
          IF(VROPTN.EQ.5) THEN
            CALL UNFOUT(11,DX(SDCOEF),NRPTOT)
          ELSE
            IF(MSIZED-SDCLUS.LT.NRPTOT)CALL ROOMD(NRPTOT)
            DFACT=1.D0/DBLE(NRPTOT)
            DO 4 I=SDCLUS,SDCLUS+NRPTOT-1
            DX(I)=DFACT
    4       CONTINUE
            CALL UNFOUT(11,DX(SDCLUS),NRPTOT)
          END IF
        END IF
C
C  If UCLUS=14, regroup replicates and write to 13
C  If UCLUS=13 and VROPTN=2, 3, or 5, can write directly to
C  final output.  If UCLUS=14, first summarize to UOUT=13.
C
        IF(UCLUS.EQ.14.OR.
     .    (UCLUS.EQ.13.AND.
     .     (VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5))) THEN
          IF(UCLUS.EQ.14) THEN
            UOUT=13
            NIDOUT=NID
          ELSE IF(UCLUS.EQ.13) THEN
            UOUT=11
            NIDOUT=NIDTOT
            VIDSAV(NIDOUT-1)=0.
            VIDSAV(NIDOUT)=1.
          END IF
C
C  Code added for 94.11 to increase efficiency for UCLUS=13 and large
C  NBYGRP
C
          IF(UCLUS.EQ.13.AND.NBYGRP.GT.10) THEN
            NPER=DSQRT(DBLE(FLOAT(NBYGRP)))
C
C  BY groups will be summarized to UIDS in groups of NPER
C
            DO 60 I=1,NBYGRP,NPER
            IF(I.GT.1)REWIND (UNIT=UCLUS)
            REWIND(UNIT=UIDS)
            NCCLUS=1
            NDMX=MDMX
            IF(NDMX.GT.NRPT1)NDMX=NRPT1
            DO 53 IPASS=1,NPASS
            DO 52 J=1,NBYGRP
            DO 51 L=1,NDMX
            READ(UNIT=UCLUS)(VIDSAV(ID),ID=1,NID)
            CALL UNFIN(UCLUS,DX(SDCLUS),TSIZE,ENDF12)
            IF(J.GE.I.AND.J.LT.I+NPER) THEN
              WRITE(UNIT=UIDS)(VIDSAV(ID),ID=1,NIDOUT)
              CALL UNFOUT(UIDS,DX(SDCLUS),TSIZE)
            END IF
   51       CONTINUE
   52       CONTINUE
            NCCLUS=NCCLUS+NDMX
            IF(IPASS.EQ.NPASS-1) THEN
              IF(NCCLUS+NDMX-1.GT.NRPT1) THEN
                NDMX=NRPT1+1-NCCLUS
              END IF
            END IF
   53       CONTINUE
            IF(I+NPER.GT.NBYGRP) THEN
              NPER1=NBYGRP-I+1
            ELSE
              NPER1=NPER
            END IF
C
C  From here to 58, the BY groups will now be extracted from UIDS
C  and placed onto UOUT
C
            DO 58 II=1,NPER1
            REWIND(UNIT=UIDS)
            NCCLUS=1
            NDMX=MDMX
            IF(NDMX.GT.NRPT1)NDMX=NRPT1
            DO 57 IPASS=1,NPASS
            DO 56 J=1,NPER1
            DO 55 L=1,NDMX
            READ(UNIT=UIDS)(VIDSAV(ID),ID=1,NID)
            CALL UNFIN(UIDS,DX(SDCLUS),TSIZE,ENDF12)
            IF(J.EQ.II) THEN
              WRITE(UNIT=UOUT)(VIDSAV(ID),ID=1,NIDOUT)
              CALL UNFOUT(UOUT,DX(SDCLUS),TSIZE)
            END IF
   55       CONTINUE
   56       CONTINUE
            NCCLUS=NCCLUS+NDMX
            IF(IPASS.EQ.NPASS-1) THEN
              IF(NCCLUS+NDMX-1.GT.NRPT1) THEN
                NDMX=NRPT1+1-NCCLUS
              END IF
            END IF
   57       CONTINUE
   58       CONTINUE
   60       CONTINUE
          ELSE
 
C
C  The DO loop to 8 groups together the replicates for each BY
C  group.
C
            DO 8 I=1,NBYGRP
            IF(I.GT.1)REWIND (UNIT=UCLUS)
            NCCLUS=1
            NDMX=MDMX
            IF(NDMX.GT.NRPT1)NDMX=NRPT1
            DO 7 IPASS=1,NPASS
            DO 6 J=1,NBYGRP
            DO 5 L=1,NDMX
            READ(UNIT=UCLUS)(VIDSAV(ID),ID=1,NID)
            CALL UNFIN(UCLUS,DX(SDCLUS),TSIZE,ENDF12)
            IF(J.EQ.I) THEN
              WRITE(UNIT=UOUT)(VIDSAV(ID),ID=1,NIDOUT)
              CALL UNFOUT(UOUT,DX(SDCLUS),TSIZE)
            END IF
    5       CONTINUE
    6       CONTINUE
            NCCLUS=NCCLUS+NDMX
            IF(IPASS.EQ.NPASS-1) THEN
              IF(NCCLUS+NDMX-1.GT.NRPT1) THEN
                NDMX=NRPT1+1-NCCLUS
              END IF
            END IF
    7       CONTINUE
    8       CONTINUE
          END IF
C
C  If UCLUS=13, the completed output has been written to 11.
C  If UCLUS=14, the output to 13 is now ready for a second
C  level of summarization.
C
          IF(UCLUS.EQ.13) THEN
            CLOSE(11)
            DONE=.TRUE.
            RETURN
          ELSE
            REWIND(13)
            REWIND(14)
            UCLUS=13
          END IF
        END IF
C
C  The code from here to 20 handles two circumstances:
C    VROPTN = 2, 3, or 5, and a summary has been created on 13
C             The objective will be to calculate totals.
C    VROPTN = 1, 4, 6, 7, 8, in which case either SISTRS or
C          SISNDS > 0, or both.
C             The objective will be to create stratum
C             and/or second-stage totals.
C
        DO 20 NC=1,NBYGRP
        I=SISTRS
        J=SISNDS
        IF(I.GT.0)IST1=IX(I)
        IF(J.GT.0)IST2=IX(J)
        DO 10 K=SDTOT,SDTOT+TSIZE-1
        DX(K)=0.
   10   CONTINUE
        IF(USTRT.GT.0) THEN
          DO 11 K=SDTOT2,SDTOT2+TSIZE-1
          DX(K)=0.
   11     CONTINUE
        END IF
        IF(USNDS.GT.0) THEN
          DO 12 K=SDTOT3,SDTOT3+TSIZE-1
          DX(K)=0.
   12     CONTINUE
        END IF
        DO 18 IREP=1,NRPTOT
        READ(UNIT=UCLUS)(VIDSAV(ID),ID=1,NID)
        CALL UNFIN(UCLUS,DX(SDCLUS),TSIZE,ENDF12)
C
C  Aggregation of stratum totals
C
        IF(USTRT.GT.0) THEN
          DO 13 K=1,TSIZE
          DX(SDTOT2+K-1)=DX(SDTOT2+K-1)+DX(SDCLUS+K-1)
   13     CONTINUE
          IF(IREP.EQ.IST1) THEN
            WRITE(UNIT=USTRT)(VIDSAV(ID),ID=1,NID)
            CALL UNFOUT(USTRT,DX(SDTOT2),TSIZE)
            I=I+1
            IF(IREP.LT.NRPTOT)IST1=IST1+IX(I)
            DO 14 K=SDTOT2,SDTOT2+TSIZE-1
            DX(K)=0.
   14       CONTINUE
          END IF
        END IF
C
C  Aggregation of second-stage totals
C
        IF(USNDS.GT.0) THEN
          DO 15 K=1,TSIZE
          DX(SDTOT3+K-1)=DX(SDTOT3+K-1)+DX(SDCLUS+K-1)
   15     CONTINUE
          IF(IREP.EQ.IST2) THEN
            WRITE(UNIT=USNDS)(VIDSAV(ID),ID=1,NID)
            CALL UNFOUT(USNDS,DX(SDTOT3),TSIZE)
            J=J+1
            IF(IREP.LT.NRPTOT)IST2=IST2+IX(J)
            DO 16 K=SDTOT3,SDTOT3+TSIZE-1
            DX(K)=0.
   16       CONTINUE
          END IF
        END IF
C
C  Accumulate full-sample total, and write if required
C
        DO 17 K=1,TSIZE
        DX(SDTOT+K-1)=DX(SDTOT+K-1)+DX(SDCLUS+K-1)
   17   CONTINUE
   18   CONTINUE
        IF(UTOT.GT.0) THEN
          WRITE(UNIT=UTOT)(VIDSAV(ID),ID=1,NID)
          CALL UNFOUT(UTOT,DX(SDTOT),TSIZE)
          DO 19 K=SDTOT,SDTOT+TSIZE-1
          DX(K)=0.
   19     CONTINUE
        END IF
   20   CONTINUE
        REWIND(UNIT=UCLUS)
        IF(USTRT.GT.0)REWIND(UNIT=USTRT)
        IF(USNDS.GT.0)REWIND(UNIT=USNDS)
        IF(UTOT.GT.0)REWIND(UNIT=UTOT)
        IF(UIDS.GT.0)REWIND(UNIT=UIDS)
      ELSE
C
C  For VFTYPE < 5 or VFTYPE > 12
C
        IF(NBY.GE.1) THEN
C
C  If there are BY groups, build a single list of them, starting at
C  SDBLST, by reading them from UIDS.
C
          WRITE(11)NBYGRP
          SDBLST=NXPTD
          K=(NID-NVARID)*NBYGRP
          CALL ROOMD(K)
          IBLST=SDBLST-NID+NVARID
          NVIDCM=0
C
C  Statement 21 begins the top of a loop to read the ids from UIDS.
C  The exit will be through reading the end of file, with transfer
C  to 35.  Note that only the BY ids are being checked and saved,
C  differences in the VARIDS are being ignored.
C
   21     CONTINUE
          READ(UNIT=UIDS,END=35)(VIDNOW(ID),ID=1,NID)
C
C  Check whether this BY group has already been stored.
C
          IF(IBLST.GE.SDBLST) THEN
            DO 22 I=NVARID+1,NID
            IF(DABS(DX(IBLST-NVARID+I-1)-VIDNOW(I)).GT..1D-3) GO TO 23
   22       CONTINUE
C
C  If this BY group has already been stored, go to 25
C
            GO TO 25
          END IF
C
C  Come to 23 if this is a new BY group.  Increment IBLST and output.
C
   23     CONTINUE
          IBLST=NBY+IBLST
          IF(IBLST.GE.NXPTD) THEN
            CALL FSTOP
          END IF
          DO 24 I=NVARID+1,NID
          DX(IBLST-NVARID+I-1)=VIDNOW(I)
   24     CONTINUE
          WRITE(11)(VIDNOW(I),I=NVARID+1,NID)
   25     CONTINUE
C
C  Whether or not the BY group is new, build up the cumulative
C  list of all variance IDS, across BY groups
C
          IF(NVARID.EQ.0) GO TO 21
          L=NXPTD-1
          IF(NVIDCM.GT.0) THEN
            DO 28 K=1,NVIDCM
            DO 26 I=1,NVARID
C
C  If the stored variance ID < the current ID, skip to the next.
C
            IF(DX(L+I)-VIDNOW(I).LT.-.1D-3)GO TO 27
C
C  If the stored variance ID > the current ID, it should be
C  inserted into the list here.
C
            IF(DX(L+I)-VIDNOW(I).GT..1D-3)GO TO 29
   26       CONTINUE
C
C  If there is an exact match to a previous ID, go to the next
C  input from UIDS.
C
            GO TO 21
   27       CONTINUE
            L=L+NVARID
   28       CONTINUE
          END IF
C
C  Come here to insert an ID in the list or to add it to the end.
C
   29     CONTINUE
C
C  Check that there is still room to store the variance id
C
          IF(NXPTD+(NVIDCM+1)*NVARID.GT.MSIZED) THEN
            K=NVARID*(NVIDCM+1)
            CALL ROOMD(K)
          END IF
C
C  Compute the upper limit of the stored IDS.
C  If the new ID should be inserted into the list, first move
C  those above the spot where the new ID should be inserted.
C
          L2=NXPTD+NVIDCM*NVARID-1
          IF(L.LT.L2) THEN
            DO 30 I=L2,L+1,-1
            DX(I+NVARID)=DX(I)
   30       CONTINUE
          END IF
C
C  Store the new ID
C
          DO 31 I=1,NVARID
          DX(L+I)=VIDNOW(I)
   31     CONTINUE
          NVIDCM=NVIDCM+1
C
C  Process the next record from UIDS
C
          GO TO 21
        ELSE
C
C  If there are no BY groups, then building up the list of variance
C  IDS is simpler, since they need only be read in from UIDS.
C
          NVIDCM=0
          L=NXPTD
   34     CONTINUE
          READ(UNIT=UIDS,END=35)(DX(I),I=L,L+NVARID-1)
          L=L+NVARID
          NVIDCM=NVIDCM+1
          IF(L+NVARID.GT.MSIZED) THEN
            L=L+NVARID+1-NXPTD
            CALL ROOMD(L)
          END IF
          GO TO 34
        END IF
C
C  On arrival at 35, the matrix of variance IDS has been built up
C  in one of the two alternative paths above.  Allocate space by a
C  call to ROOMD.
C
   35   CONTINUE
        K=NVARID*NVIDCM
C
C  NXPTDS will save the beginning of the list of variance ids, which
C  is held in common and passed to CREAT4
C
        NXPTDS=NXPTD
        CALL ROOMD(K)
C
C  The next IF condition considers all TYPEs with strata identified by
C  either a stratum code or number.
C
        IF(VFTYPE.GE.15.AND.VFTYPE.LE.28) THEN
C
C  NISTR2 builds up a count of unique stratum codes/numbers
C  NISTRM records the largest stratum number, for VFTYPES 15, 16, 21-24.
C
          NISTR2=0
          NISTRM=0
          L=NXPTDS
          DO 36 I=1,NVIDCM
          IF(I.EQ.1) THEN
            NISTR2=NISTR2+1
          ELSE
            IF(DABS(DX(L)-DX(L-NVARID)).GT..1D-3)NISTR2=NISTR2+1
          END IF
C
C  For stratum numbers, check that each is an integer.
C
          IF(VFTYPE.EQ.15.OR.VFTYPE.EQ.16.OR.
     .      (VFTYPE.GE.21.AND.VFTYPE.LE.24)) THEN
            IF(.NOT.ICHECK(DX(L),DVALUE)) THEN
              WRITE(U6,201)DX(L)
              CALL FSTOP
            ELSE IF(DVALUE.LT..5) THEN
              WRITE(U6,201)DX(L)
              WRITE(U6,207)
              CALL FSTOP
            ELSE
              IVALUE=DVALUE+.05
              IF(IVALUE.GT.NISTRM)NISTRM=IVALUE
            END IF
          END IF
          L=L+NVARID
   36     CONTINUE
C
C  For VFTYPEs 15, 16, 21-24, confirm that observed stratum numbers
C  do not violate specified number of strata, NISTRS.
C
          IF(NISTRM.GT.0) THEN
            IF(NISTRS.GT.0) THEN
              IF(NISTRM.GT.NISTRS) THEN
                WRITE(U6,202)NISTRM,NISTRS
                CALL FSTOP
C
C  Print message if not all the expected strata observed.
C
              ELSE IF(NISTR2.LT.NISTRS) THEN
                WRITE(U6,203)NISTR2,NISTRS
                NISTR2=NISTRS
              END IF
            ELSE
              IF(U5ECHO.GT.0)WRITE(U6,102)NISTRM
              NISTR2=NISTRM
            END IF
C
C  For VFTYPEs 17-18, 25-28, based on stratum codes, observed count
C  must be consistent with any specification NISTRS
C
          ELSE
            IF(NISTRS.GT.0) THEN
              IF(NISTR2.GT.NISTRS) THEN
                WRITE(U6,204)NISTR2,NISTRS
                CALL FSTOP
              ELSE IF(NISTR2.LT.NISTRS) THEN
                WRITE(U6,203)NISTR2,NISTRS
                CALL FSTOP
              END IF
            ELSE
              IF(U5ECHO.GT.0)WRITE(U6,103)NISTR2
            END IF
          END IF
        END IF
C
C  End of checks for VFTYPES 15-28
C
C       IF(VROPTN.NE.8) THEN
        IF(VROPTN.NE.6) THEN
          IF(NISTRS.EQ.0.AND.VFTYPE.LE.32) THEN
C
C  VFTYPEs 15-28 all involve either strata or second-stage units
C  Define L such that the second-stage code or replicate number
C  is at L+1 within the matrix of IDS.
C
            IF(VFTYPE.GE.15.AND.VFTYPE.LE.28) THEN
              L=NXPTDS
              N1=NVIDCM
C
C  VFTYPES 1-4, 29-32 involve cluster codes or numbers only
C  Set both NISTRS=1, and NISTR2=1
C  If half-sample or general replication, set L to the starting
C  location of the IDS; otherwise, offset L by 1 since no stratum
C  code will be present.
C
            ELSE
              NISTRS=1
              NISTR2=1
              IF(VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5) THEN
                L=NXPTDS
                N1=NVIDCM-1
              ELSE
                L=NXPTDS-1
                N1=NVIDCM
              END IF
              IL=1
            END IF
C
C  Set SISTRS=SISTR2 and allocate NISTR2 space for counts
C
            SISTRS=NXPTI
            CALL ROOMI(NISTR2)
            SISTR2=SISTRS
C
C  For VFTYPES 33-38, governed by replicate numbers, allocate space for
C  a single count, offsetting L by 1
C
          ELSE IF(VFTYPE.GE.33) THEN
            SISTR2=NXPTI
            NISTR2=1
            CALL ROOMI(NISTR2)
            IL=1
            L=NXPTDS-1
            N1=NVIDCM
C
C  For VFTYPES 1-32, with NISTRS > 0, allocate NISTR2 of space,
C  Give L no offset
C
          ELSE
            L=NXPTDS
            N1=NVIDCM
            SISTR2=NXPTI
            CALL ROOMI(NISTR2)
          END IF
C
C  For all replication methods, initialize matrix to contain the
C  counts.
C
          DO 37 I=SISTR2,SISTR2+NISTR2-1
          IX(I)=0
   37     CONTINUE
C
C  Loop over the matrix of stored IDS.
C
          DO 38 I=1,N1
C
C  For stratum numbers, set IL to the actual value read
C
 
          IF(VFTYPE.EQ.15.OR.VFTYPE.EQ.16.OR.
     .      (VFTYPE.GE.21.AND.VFTYPE.LE.24)) THEN
            IL=DX(L)+.05
C
C  For stratum codes, start IL at 1 and increment for each change over
C  .1D-3
C
          ELSE IF(VFTYPE.GE.17.AND.VFTYPE.LE.28) THEN
            IF(I.EQ.1) THEN
              IL=1
            ELSE IF(DABS(DX(L)-DX(L-NVARID)).GT..1D-3) THEN
              IL=IL+1
            END IF
          END IF
          IF(VFTYPE.EQ.21.OR.VFTYPE.EQ.22.OR.VFTYPE.EQ.25.OR.
     .       VFTYPE.EQ.26.OR.VFTYPE.EQ.29.OR.VFTYPE.EQ.30.OR.
     .       VFTYPE.EQ.3.OR.VFTYPE.EQ.4.OR.VFTYPE.GE.33) THEN
C
C  For VFTYPES 21, 22, 25, 26, 29, 30, 3, 4, 33-38, assure that the
C  second stage number/replicate number is an integer.
C
            IF(.NOT.ICHECK(DX(L+1),DVALUE)) THEN
              IF(VFTYPE.GE.21.AND.VFTYPE.LE.30) THEN
                WRITE(U6,205)DX(L+1)
              ELSE
                WRITE(U6,206)DX(L+1)
              END IF
              CALL FSTOP
C
C  For these types, also assure that the number is nonnegative,
C  and > 0 for VROPTN 1, 4, 6, and 7.
C
            ELSE IF(DVALUE.LT.0..OR.(VROPTN.NE.2.AND.VROPTN.NE.3.AND.
     .         VROPTN.NE.5.AND.DVALUE.LE..5D0)) THEN
              IF(VFTYPE.GE.21.AND.VFTYPE.LE.26) THEN
                WRITE(U6,205)DX(L+1)
              ELSE
                WRITE(U6,206)DX(L+1)
              END IF
              WRITE(U6,207)
              CALL FSTOP
            ELSE
C
C  Build up the counts of second-stage units
C
              IX(SISTR2+IL-1)=DX(L+1)+.05
            END IF
C
C  For second stage codes or cluster codes, build up counts
C  based on the change in codes.
C
          ELSE
            IF(I.EQ.1) THEN
              IX(SISTR2+IL-1)=1
            ELSE
C
C  When we have a stratum code or number, check for a change in
C  either the stratum or second-stage
C
              IF(VFTYPE.GE.15.AND.VFTYPE.LE.28) THEN
                IF(DABS(DX(L)-DX(L-NVARID)).GT..1D-3.OR.
     .             DABS(DX(L+1)-DX(L-NVARID+1)).GT..1D-3) THEN
                   IX(SISTR2+IL-1)=IX(SISTR2+IL-1)+1
                END IF
C
C  Without a stratum code/number, check only the second-stage
C
              ELSE IF(DABS(DX(L+1)-DX(L-NVARID+1)).GT..1D-3) THEN
                IX(SISTR2+IL-1)=IX(SISTR2+IL-1)+1
              END IF
            END IF
          END IF
          L=L+NVARID
   38     CONTINUE
C
C  If a replicate number is being used with half-sample or
C  general replication, reduce the count by 1 if the full-sample is
C  labelled with 1.
C
          IF((VFTYPE.EQ.3.OR.VFTYPE.EQ.4).AND.
     .      (VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5).AND.
     .      DABS(DX(NXPTDS)-1.0D0).LT..1D-3)IX(SISTR2)=IX(SISTR2)-1
C
C  If counts within strata had been provided, assure that
C  observed count < or = to the specified count.
C
          IF(SISTRS.NE.SISTR2.AND.VFTYPE.LE.32) THEN
            DO 39  I=1,NISTR2
            IF(IX(SISTR2+I-1).GT.IX(SISTRS+I-1)) THEN
              WRITE(U6,208)I,IX(SISTR2+I-1),IX(SISTRS+I-1)
              CALL FSTOP
            END IF
   39       CONTINUE
          END IF
C
C  If NISTRS was previously unspecified, set it to the observed
C  count at this point.
C
          IF(NISTRS.EQ.0)NISTRS=NISTR2
        END IF
C
C  For TYPES 21-28, count second-stage units within strata.
C  For TYPES 29-32, count clusters within second stage units.
C
        IF(VFTYPE.GE.21.AND.VFTYPE.LE.32) THEN
          K=0
          DO 41 I=SISTRS,SISTRS+NISTRS-1
          K=K+IX(I)
   41     CONTINUE
C
C  If second stage counts have been specified, assure that
C  observed count < or = specified count.
C
          IF(NISNDS.GT.0) THEN
            IF(K.GT.NISNDS) THEN
              WRITE(U6,209)K,NISNDS
              CALL FSTOP
            END IF
            SISND2=NXPTI
            CALL ROOMI(NISNDS)
          ELSE
            SISNDS=NXPTI
            NISNDS=K
            CALL ROOMI(NISNDS)
            IF(U5ECHO.GT.0)WRITE(U6,104)NISNDS
            SISND2=SISNDS
          END IF
C
C  If a stratum code/number is present, offset L by 1
C
          IF(VFTYPE.LE.28) THEN
            L=NXPTDS+1
          ELSE
            L=NXPTDS
          END IF
C
C  Initialize the matrix of counts to 0.
C
          DO 42 I=SISND2,SISND2+NISNDS-1
          IX(I)=0
   42     CONTINUE
          DO 46 I=1,NVIDCM
C
C  For VFTYPES 21-24, derive the index IL from the stratum number
C
          IF(VFTYPE.GE.21.AND.VFTYPE.LE.24) THEN
            IL=DX(L-1)+.05
C
C  For VFTYPES 25-28, derive IL from changes in the stratum code
C
          ELSE IF(VFTYPE.LE.28) THEN
            IF(I.EQ.1) THEN
              IL=1
            ELSE IF(DABS(DX(L-1)-DX(L-NVARID-1)).GT..1D-3) THEN
              IL=IL+1
            END IF
C
C  For other cases IL=1
C
          ELSE
            IL=1
          END IF
          IS=0
C
C  If IL > 1, build up the count in IS for previous strata
C
          IF(IL.GT.1) THEN
            DO 44 J=1,IL-1
            IS=IS+IX(SISTRS+J-1)
   44       CONTINUE
          END IF
C
C  For VFTYPES 21, 22, 25, 26, 29, and 30, increment IS according
C  to the second-stage/cluster number.
C  IDINT is a standard function to convert double precision to
C  integer.
C
          IF(VFTYPE.EQ.21.OR.VFTYPE.EQ.22.OR.VFTYPE.EQ.25.OR.
     .       VFTYPE.EQ.26.OR.VFTYPE.EQ.29.OR.VFTYPE.EQ.30) THEN
              IS=IS+IDINT(DX(L)+.05)
          ELSE
C
C  Otherwise, if using second-stage code, increment for changes in
C  the code.
C  If I=1, at first ID, so set IS=1
C
            IF(I.EQ.1) THEN
              IS=IS+1
C
C  Check first, for VFTYPE < 28, for changes in the stratum code/number
C  If different, increment IS by 1
C
            ELSE IF(VFTYPE.LE.28.AND.DABS(DX(L-1)-DX(L-NVARID-1)).GT.
     .          .1D-3) THEN
              IS=IS+1
C
C  Otherwise, check whether this second-stage code is the same as last
C  time.
C  If not, set IS to IS1 + 1, where IS1 retains the last value of IS.
C  If so, set IS to the previous value
C
 
            ELSE IF(DABS(DX(L)-DX(L-NVARID)).GT..1D-3) THEN
              IS=IS1+1
            ELSE
              IS=IS1
            END IF
            IS1=IS
          END IF
C
C  Build up the count of second-stage units here.
C
          IX(SISND2+IS-1)=IX(SISND2+IS-1)+1
          L=L+NVARID
   46     CONTINUE
C
C  Check that the observed second-stage counts are not greater
C  than specified values.
C
          IF(SISND2.NE.SISNDS) THEN
            DO 48 I=1,NISNDS
            IF(IX(SISND2+I-1).GT.IX(SISNDS+I-1)) THEN
              WRITE(U6,210)I,IX(SISND2+I-1),IX(SISNDS+I-1)
              CALL FSTOP
            END IF
   48       CONTINUE
          END IF
        END IF
        IF(UIDS.GT.0)REWIND(UNIT=UIDS)
      END IF
      RETURN
      END
      SUBROUTINE CREAT4
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (IXFLLD=19)
      PARAMETER (MAXFMT=20)
C
C  MVAR   represents the maximum number of incoming and created
C         variables, replicate factors and wts
C  MAXIDS is the maximum number of class variables
C  MRECOD is the maximum of variables transformed by CLASS, CAT
C         MISSING, SELECT, BY etc.
C  MRANGE is the maximum number of ranges
C  MRNSET is the maximum number of sets of ranges
C  MLEVEL is the maximum number of stored labels for levels
C  MCLBLK is the maximum number of class blocks
C  MCLBAR is the maximum number of cells of class block arrays
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
C
C       NVTOT   (NTOTV)
C       NVREG   (IOUTC1)
C       NVARID  (NID1)
C
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1,
     . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX
C
      DOUBLE PRECISION RANGE(2,MRANGE)
      INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET),
     . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD),
     . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI)
C
      COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP,
     . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO,
     . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS,
     . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT,
     . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS,
     . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO,
     . NLEVEL,NRNSET,NRANGE,NHADAM,IXFILL
      INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS,
     . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN,
     . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IXFILL(IXFLLD)
C
      LOGICAL ENDF12,BYCHNG,ENDCL,ENDSTR,ENDSND
      LOGICAL BYCSTR,BYCSND
      DOUBLE PRECISION VIDNOW(MAXIDS),VIDSAV(MAXIDS),VIDOUT(MAXIDS)
      DOUBLE PRECISION VIDSTR(MAXIDS),VIDSND(MAXIDS)
      DOUBLE PRECISION VIDCL(MAXIDS)
      DOUBLE PRECISION VIDSTL(MAXIDS),VIDSTH(MAXIDS)
      DOUBLE PRECISION VIDSNL(MAXIDS),VIDSNH(MAXIDS)
      INTEGER SISTR2,SISND2
      LOGICAL USECL,USESTR,USESND,SKIPST,SKIPSN
      LOGICAL ICHECK
      EXTERNAL ICHECK
C
      IF(VROPTN.NE.5) THEN
        SDCOEF=NXPTD
        CALL ROOMD(NRPTOT)
      END IF
C
C  If no previous information is stored about strata, establish
C  a single stratum.
C
      IF(SISTRS.EQ.0) THEN
        SISTRS=NXPTI
        NISTRS=1
        CALL ROOMI(1)
        IF(SISNDS.GT.0) THEN
          IX(SISTRS)=NISNDS
        ELSE IF(NRPTOT.GT.0) THEN
          IX(SISTRS)=NRPTOT
C
C  Just-in case check
C
        ELSE
          CALL FSTOP
        END IF
      END IF
C
C  For VFTYPE < 5 or VFTYPE > 12, set L to be the location of the
C  first ID (not counting full sample ID for half-sample/general
C  LU - upper bound on stored IDS
C  LINCR - increment to move through stored IDS
C
      IF(VFTYPE.LE.4.OR.VFTYPE.GE.13) THEN
        IF(VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5) THEN
          L=NXPTDS+NVARID
        ELSE
          L=NXPTDS
        END IF
        LU=NXPTDS+NVARID*(NVIDCM-1)
        LINCR=NVARID
C
C  For TYPE 5-12, set start L=1, upper limit LU=NRPTOT, and
C  increment LINCR = 1
C
      ELSE
        L=1
        LU=NRPTOT
        LINCR=1
      END IF
C
C  Establish initial values for the extended loop to 15 over the
C  number of strata.
C
C  L1L  -  lower bound for index wrt strata
C  L2L  -  lower bound for index wrt second-stage
C  SISTR2 - beginning of revised count of strata
C  SISND2 - if appropriate, beginning of revised count of second-
C           stage units.
C  NRPT - a revised count of replicates.
C  NSND - index used when second-stage units present, lower bound
C  NSND2 - upper bound above NSND
C  NC1 - index of clusters wrt old list starting with SISTRS
C  NC2 - index of clusters wrt new list starting with SISTR2
C
      L1L=L
      L2L=L
      SISTR2=NXPTI
      CALL ROOMI(NISTRS)
      NRPT=0
      NSND=1
      NSND2=1
      IF(NISNDS.GT.0) THEN
        SISND2=NXPTI
        CALL ROOMI(NISNDS)
      END IF
      NC1=1
      NC2=1
C
C  For half-sample/general, set NC1 to the full sample ID, which
C  might either be 1 or 0
C
      IF(VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5) THEN
        IF(VFTYPE.EQ.3.OR.VFTYPE.EQ.4)NC1=DX(NXPTDS)+.05D0
      END IF
      DO 15 ISTR=1,NISTRS
C
C  USESTR - boolean to indicate whether to use the stratum in
C  constructing replicates, set to .FALSE. if the finite population
C  correction is within .1D-12 of 1.
C
      USESTR=.TRUE.
C
C  Initially, set the revised stratum count to the current count,
C  but then revise for special condition below.
C
      IX(SISTR2+ISTR-1)=IX(SISTRS+ISTR-1)
      IF(SDFPC1.GT.0) THEN
        IF(DABS(DX(SDFPC1+ISTR-1)).LT..1D-12)USESTR=.FALSE.
      END IF
C
C  Add a second replicate if there is only a single hit within the
C  stratum.
C
      IF(IX(SISTR2+ISTR-1).EQ.1.AND.USESTR) THEN
        IX(SISTR2+ISTR-1)=2
      END IF
C
C  NCU1 - upper index wrt the old list
C
      NC1U=NC1+IX(SISTRS+ISTR-1)-1
C
C  NSND2 - upper index of second-stage units wrt the old list
C
      IF(NISNDS.GT.0) THEN
        NSND2=NSND+IX(SISTRS+ISTR-1)-1
        M=IX(SISTR2+ISTR-1)
      ELSE
        NC=IX(SISTR2+ISTR-1)
      END IF
C
C  If stratum totals have been written to a file, find
C  L1U - the upper index
C
      IF(USTRT.GT.0) THEN
        L1U=0
        IF(L1L.LE.LU) THEN
          DO 2 I=L1L,LU,LINCR
C
C  For TYPE=3,4 or > 32, can get LIU directly from stored code
C
          IF(VFTYPE.LE.4.OR.VFTYPE.GE.33) THEN
            IF(DX(I).LE.DBLE(NC1U)+.05)L1U=I
C
C  For TYPE 5-12, LIU can be obtained directly from NC1U
C
          ELSE IF(VFTYPE.LE.12) THEN
            L1U=NC1U
C
C  For TYPE 13, 14, based on cluster codes, and, in effect, a
C  single stratum, derive LIU from the number of observed
C  cluster codes.
C
          ELSE IF(VFTYPE.LE.14) THEN
            L1U=L1L+LINCR*(IX(SISTRS+ISTR-1)-1)
            IF(L1U.GT.LU)L1U=LU
C
C  For TYPE 15, 16, 21-24, based on stratum numbers, keep
C  setting L1U=I until the stored ID exceeds the current number of
C  the stratum.
C
          ELSE IF(VFTYPE.LE.16.OR.(VFTYPE.GE.21.AND.VFTYPE.LE.24)) THEN
            IF(DX(I).LE.DBLE(ISTR)+.05)L1U=I
C
C  For TYPEs 17-18, 25-28, based on stratum codes, keep setting
C  LIU=I until the stored ID differs from the stratum ID for the
C  current stratum.
C
          ELSE
            IF(DABS(DX(I)-DX(L1L)).LT..1D-3)L1U=I
          END IF
    2     CONTINUE
        END IF
C
C  If L1U is equal to or greater than L1L, write lower and upper
C  limits to UIDS, else write -9876., the code for a missing stratum
C
        IF(L1U.GE.L1L) THEN
          IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN
            VIDOUT(1)=L1L
            WRITE(UNIT=UIDS)VIDOUT(1)
            VIDOUT(1)=L1U
            WRITE(UNIT=UIDS)VIDOUT(1)
          ELSE
            WRITE(UNIT=UIDS)(DX(I),I=L1L,L1L+NVARID-1)
            WRITE(UNIT=UIDS)(DX(I),I=L1U,L1U+NVARID-1)
            DO 3 I=1,LINCR
            VIDOUT(I)=DX(L1U+I-1)
    3       CONTINUE
          END IF
        ELSE
          DO 4 I=1,LINCR
          VIDOUT(I)=-9876.
    4     CONTINUE
          WRITE(UNIT=UIDS)(VIDOUT(I),I=1,LINCR)
          WRITE(UNIT=UIDS)(VIDOUT(I),I=1,LINCR)
        END IF
C
C  If there is not a stratum file, then set L1L and L1U to lower
C  and upper limits of the ID array.
C
      ELSE
        L1L=L
        L1U=LU
      END IF
C
C  In all cases, write the new stratum count to UIDS.
C
      WRITE(UNIT=UIDS)IX(SISTR2+ISTR-1)
C
C  Within this stratum, loop over second-stage units.
C  Note that NSND=NSND2=1 if USNDSS=0
C
      DO 12 ISND=NSND,NSND2
C
C  If second-stage totals have been written to a file, then
C  determine L2U by a logic similar to the definition of L1U, above
C
      IF(USNDS.GT.0) THEN
        L2U=0
        NC2U=NC2+IX(SISNDS+ISND-1)-1
        IF(L2L.LE.L1U) THEN
          DO 5 I=L2L,L1U,LINCR
C
C  For VFTYPE 3, 4, 33 - 38, get L2U directly from count
C
          IF(VFTYPE.LE.4.OR.VFTYPE.GE.33) THEN
            IF(DX(I).LE.DBLE(NC2U)+.05)L2U=I
C
C  For VFTYPE 5-12, get L2U from the count itself
C
          ELSE IF(VFTYPE.LE.12) THEN
            IF(I.LE.NC2U)L2U=I
C
C  For VFTYPE 13-14, based on the cluster code, compute L2U from the
C  stored count.
C
          ELSE IF(VFTYPE.LE.14) THEN
            L2U=L2L+LINCR*(IX(SISNDS+ISND-1)-1)
            IF(L2U.GT.LU)L2U=LU
C
C  For VFTYPE 21, 22, 25, 26, which use second stage numbers, get L2U
C  by comparing against the count in this stratum.
C
          ELSE IF(VFTYPE.EQ.21.OR.VFTYPE.EQ.22.OR.VFTYPE.EQ.25.OR.
     .            VFTYPE.EQ.26) THEN
            IF(DX(I+1).LE.DBLE(ISND-NSND+1)+.05)L2U=I
C
C  For VFTYPE 23, 24, 27, 28, derive L2U as last matching second-stage
C  code.
C
          ELSE IF(VFTYPE.EQ.23.OR.VFTYPE.EQ.24.OR.VFTYPE.EQ.27.OR.
     .            VFTYPE.EQ.28) THEN
            IF(DABS(DX(I+1)-DX(L2L+1)).LE..1D-3)L2U=I
C
C  For VFTYPE 29, 30, check against count, similar to handling of TYPES
C  21, 22, 25, 26.
C
          ELSE IF(VFTYPE.EQ.29.OR.VFTYPE.EQ.30) THEN
            IF(DX(I).LE.DBLE(ISND-NSND+1)+.05)L2U=I
C
C  For VFTYPE 31, 32, derive L2U as last matching second-stage code.
C
          ELSE IF(VFTYPE.EQ.31.OR.VFTYPE.EQ.32) THEN
            IF(DABS(DX(I)-DX(L2L)).LE..1D-3)L2U=I
          END IF
    5     CONTINUE
        END IF
C
C  IF L2U is greater than or equal to L2L, write out to UIDS,
C  similar to previous treatment of strata.
C
        IF(L2U.GE.L2L) THEN
          IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN
            VIDOUT(1)=L2L
            WRITE(UNIT=UIDS)VIDOUT(1)
            VIDOUT(1)=L2U
            WRITE(UNIT=UIDS)VIDOUT(1)
          ELSE
            WRITE(UNIT=UIDS)(DX(I),I=L2L,L2L+NVARID-1)
            WRITE(UNIT=UIDS)(DX(I),I=L2U,L2U+NVARID-1)
            DO 6 I=1,LINCR
            VIDOUT(I)=DX(L2U+I-1)
    6       CONTINUE
          END IF
        ELSE
          DO 7 I=1,LINCR
          VIDOUT(I)=-9876.
    7     CONTINUE
          WRITE(UNIT=UIDS)(VIDOUT(I),I=1,LINCR)
          WRITE(UNIT=UIDS)(VIDOUT(I),I=1,LINCR)
        END IF
C
C  Build up count of second-stage units actually to be used in
C  SISND2.  Again, set this initially to the observed/specified
C  count.
C
        IX(SISND2+ISND-1)=IX(SISNDS+ISND-1)
        USESND=.TRUE.
        IF(SDFPC1.GT.0) THEN
C
C  If the stratum factor is 1.0 = (1-fpc1),
C  or if fpc2 = 1.0, or if fpc1 = 0.0 (not specified),
C  don't compute second-stage.
C
          IF(DABS(DX(SDFPC1+ISTR-1)-1.D0).LT..1D-12) THEN
            USESND=.FALSE.
          ELSE IF(SDFPC2.GT.0) THEN
            IF(DABS(DX(SDFPC2+ISND-1)).LT..1D-12) USESND=.FALSE.
          END IF
        ELSE
          USESND=.FALSE.
        END IF
C
C  If there is a single second-stage unit to be used in variance
C  calculation, create a second "phantom" unit, in the same manner
C  as a single hit within stratum, previously.
C
        IF(USESND.AND.IX(SISND2+ISND-1).EQ.1)IX(SISND2+ISND-1)=2
        NC=IX(SISND2+ISND-1)
        WRITE(UNIT=UIDS)NC
      ELSE
C
C  If there is no second-stage file, simply set L2L and L2U to the full
C  first-stage limits.  Don't write anything to UIDS, yet.
C
        L2L=L1L
        L2U=L1U
        USESND=.FALSE.
      END IF
C
C  NC, the number of units within the stratum, is either based
C  on the revised number of second-stage units (about 8 lines above)
C  or the number of clusters within the stratum (just after the
C  beginning of this loop to 15
C
      DO 10 J=1,NC
      USECL=.FALSE.
C
C  For VFTYPEs 5 - 12, base the inclusion of the cluster on the count
C
      IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN
        IF(J+L2L-1.LE.L2U)USECL=.TRUE.
C
C  For VFTYPEs 3-4, check the match on the cluster number
C
      ELSE IF(VFTYPE.EQ.3.OR.VFTYPE.EQ.4) THEN
        IF(DX(L).LE.DBLE(J)+.05)USECL=.TRUE.
C
C  For VFTYPEs 13-38, check based on L in the range L2L-L2U
C
      ELSE
        IF(L.GE.L2L.AND.L.LE.L2U)USECL=.TRUE.
      END IF
C
C  Handle two cases at this point:
C    Second-stage units with USESND = .TRUE.
C    No second-stage units, but USESTR = .TRUE.
C
      IF((NISNDS.EQ.0.AND.USESTR).OR.(NISNDS.GT.0.AND.USESND)) THEN
        IF(NISNDS.GT.0) THEN
          IF(SDFPC1.GT.0) THEN
            IF(SDFPC2.GT.0) THEN
              IF(VROPTN.NE.8) THEN
                DX(SDCOEF+NRPT)=(1.-DX(SDFPC1+ISTR-1))*
     .            DX(SDFPC2+ISND-1)*DBLE(NC-1)/DBLE(NC)
              ELSE
                DX(SDCOEF+NRPT)=(1.-DX(SDFPC1+ISTR-1))*
     .            DX(SDFPC2+ISND-1)/(DBLE(NC)*DBLE(NC-1))
              END IF
            ELSE
              IF(VROPTN.NE.8) THEN
                DX(SDCOEF+NRPT)=(1.-DX(SDFPC1+ISTR-1))*DBLE(NC-1)
     .               /DBLE(NC)
              ELSE
                DX(SDCOEF+NRPT)=(1.-DX(SDFPC1+ISTR-1))
     .               /(DBLE(NC)*DBLE(NC-1))
              END IF
            END IF
          ELSE
            IF(VROPTN.NE.8) THEN
              DX(SDCOEF+NRPT)=DBLE(NC-1)/DBLE(NC)
            ELSE
              DX(SDCOEF+NRPT)=1.D0/(DBLE(NC)*DBLE(NC-1))
            END IF
          END IF
        ELSE
          IF(SDFPC1.GT.0.AND.VROPTN.NE.5) THEN
C
C  Random group, with FPC1
C
            IF(VROPTN.EQ.7.OR.VROPTN.EQ.8) THEN
              DX(SDCOEF+NRPT)=DX(SDFPC1+ISTR-1)/(DBLE(NC-1)*DBLE(NC))
C
C  Half-sample, with FPC1
C
            ELSE IF(VROPTN.EQ.2.OR.VROPTN.EQ.3) THEN
              DX(SDCOEF+NRPT)=DX(SDFPC1+ISTR-1)/DBLE(NC)
C
C  Jackknife, stratified jackknife, with FPC1
C
            ELSE
              DX(SDCOEF+NRPT)=DX(SDFPC1+ISTR-1)*DBLE(NC-1)/DBLE(NC)
            END IF
          ELSE IF(VROPTN.NE.5) THEN
C
C  Random group
C
            IF(VROPTN.EQ.7.OR.VROPTN.EQ.8) THEN
              DX(SDCOEF+NRPT)=1.D0/(DBLE(NC-1)*DBLE(NC))
C
C  Half-sample
C
            ELSE IF(VROPTN.EQ.2.OR.VROPTN.EQ.3) THEN
              DX(SDCOEF+NRPT)=1.D0/DBLE(NC)
C
C  Jackknife, stratified jackknife
C
            ELSE
              DX(SDCOEF+NRPT)=DBLE(NC-1)/DBLE(NC)
            END IF
          END IF
        END IF
C
C  Increment NRPT, the counter for created replicates
C
        NRPT=NRPT+1
        IF(NRPTOT.EQ.0)CALL ROOMD(1)
      END IF
C
C  If USECL, write out ID to UIDS and increment L
C  else write out -9876.
C
      IF(USECL) THEN
        IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN
          VIDOUT(1)=J+L2L-1
          WRITE(UNIT=UIDS)VIDOUT(1)
        ELSE
          WRITE(UNIT=UIDS)(DX(I),I=L,L+LINCR-1)
        END IF
        L=L+LINCR
      ELSE
        VIDOUT(LINCR)=-9876.
        WRITE(UNIT=UIDS)(VIDOUT(ID),ID=1,LINCR)
      END IF
C
C  End of loop over clusters
C
   10 CONTINUE
C
C  If second-stage units, increment L2L at this point
C
      IF(NISNDS.GT.0) THEN
        IF(L2U.GE.L2L)L2L=L2U+LINCR
        NC2=NC2+IX(SISNDS+ISND-1)
      END IF
C
C  If no second-stage units or the stratum is to be skipped,
C  go to the end of the second-stage loop to 12
C
      IF(NISNDS.NE.0.AND.USESTR) THEN
C
C  Create a replicate for the second-stage unit here as long
C  as FPC1 not 1.0.  Note that M is the revised count of
C  second-stage units within the stratum, defined above
C
        IF(SDFPC1.GT.0) THEN
          IF(DABS(DX(SDFPC1+ISTR-1)).LT..1D-12)GO TO 12
          IF(VROPTN.NE.8) THEN
            DX(SDCOEF+NRPT)=DX(SDFPC1+ISTR-1)*DBLE(M-1)/DBLE(M)
          ELSE
            DX(SDCOEF+NRPT)=DX(SDFPC1+ISTR-1)/(DBLE(M)*DBLE(M-1))
          END IF
        ELSE
          IF(VROPTN.NE.8) THEN
            DX(SDCOEF+NRPT)=DBLE(M-1)/DBLE(M)
          ELSE
            DX(SDCOEF+NRPT)=1.D0/(DBLE(M)*DBLE(M-1))
          END IF
        END IF
C
C  Increment NRPT, the counter for replicates
C
        NRPT=NRPT+1
        IF(NRPTOT.EQ.0)CALL ROOMD(1)
      END IF
C
C  End of loop over second-stage units
C
   12 CONTINUE
C
C  Increment NC1 and L1L here.
C
      NC1=NC1+IX(SISTRS+ISTR-1)
      IF(USTRT.GT.0.AND.L1U.GE.L1L)L1L=L1U+LINCR
C
C  If a single-second stage unit has been included in the variance
C  calculation, construct a second "phantom" unit here.  (M=2 in
C  this case.)
C
      IF(NISNDS.GT.0.AND.NSND.EQ.NSND2.AND.USESTR) THEN
        IF(SDFPC1.GT.0) THEN
          IF(DABS(DX(SDFPC1+ISTR-1)).LT..1D-12)GO TO 15
          IF(VROPTN.NE.8) THEN
            DX(SDCOEF+NRPT)=DX(SDFPC1+ISTR-1)*DBLE(M-1)/DBLE(M)
          ELSE
            DX(SDCOEF+NRPT)=DX(SDFPC1+ISTR-1)/(DBLE(M)*DBLE(M-1))
          END IF
        ELSE
          IF(VROPTN.NE.8) THEN
            DX(SDCOEF+NRPT)=DBLE(M-1)/DBLE(M)
          ELSE
            DX(SDCOEF+NRPT)=1.D0/(DBLE(M)*DBLE(M-1))
          END IF
        END IF
        NRPT=NRPT+1
        IF(NRPTOT.EQ.0)CALL ROOMD(1)
C
C  For TYPES 21-28, preserve the previously stored stratum code
C  in writing the ID to UIDS
C
        IF(VFTYPE.GE.21.AND.VFTYPE.LE.28) THEN
          ISTART=2
        ELSE
          ISTART=1
        END IF
        DO 14 ID=ISTART,LINCR
        VIDOUT(ID)=-9876.
   14   CONTINUE
        WRITE(UNIT=UIDS)(VIDOUT(ID),ID=1,LINCR)
        WRITE(UNIT=UIDS)(VIDOUT(ID),ID=1,LINCR)
C
C  No replicate clusters will be present
C
        NCN=0
        WRITE(UNIT=UIDS)NCN
      END IF
      IF(NISNDS.GT.0)NSND=NSND+IX(SISTRS+ISTR-1)
C
C  End of loop over strata.
C
   15 CONTINUE
C
C  Final number of replicates, NRPTOT, has been determined.
C  Write coefficients to VPLX file.
C
      IF(VROPTN.NE.5) THEN
        NRPTOT=NRPT
        NXPTD=SDCOEF
        CALL ROOMD(NRPT)
      END IF
      WRITE(11)NRPTOT
      CALL UNFOUT(11,DX(SDCOEF),NRPTOT)
      NXPTD=SDTOT+TSIZE
      IF(USTRT.GT.0) CALL ROOMD(TSIZE)
      IF(USNDS.GT.0) CALL ROOMD(TSIZE)
C
C  Read in first IDS from UCLUS
C
      READ(UNIT=UCLUS)(VIDCL(I),I=1,NID)
C
C  ENDCL - end of file on cluster file
C  BYCSTR - change in BY variables on stratum file
C  BYCSND - change in BY variables on second-stage file
C
      ENDCL=.FALSE.
      BYCSTR=.FALSE.
      BYCSND=.FALSE.
      IBYGRP=1
   20 CONTINUE
      DNCLUS=1.
      IF(UIDS.GT.0)REWIND(UNIT=UIDS)
C
C  If stratum file, read ids and stratum tallies unless a change
C  in BY variables has occurred.
C
      IF(USTRT.GT.0.AND.(VFTYPE.LE.4.OR.VFTYPE.GE.13)) THEN
        IF(.NOT.BYCSTR) THEN
          READ(UNIT=USTRT)(VIDSTR(I),I=1,NID)
          CALL UNFIN(USTRT,DX(SDTOT2),TSIZE,ENDF12)
        END IF
        ENDSTR=.FALSE.
      ELSE IF(USTRT.EQ.0) THEN
        ENDSTR=.TRUE.
      ELSE
        ENDSTR=.FALSE.
      END IF
C
C  If second-stage file, read ids and second-stage tallies unless
C  a change in BY variables has occurred.
C
      IF(USNDS.GT.0.AND.(VFTYPE.LE.4.OR.VFTYPE.GE.13)) THEN
        IF(.NOT.BYCSND) THEN
          READ(UNIT=USNDS)(VIDSND(I),I=1,NID)
          CALL UNFIN(USNDS,DX(SDTOT3),TSIZE,ENDF12)
        END IF
        ENDSND=.FALSE.
      ELSE IF(USNDS.EQ.0) THEN
        ENDSND=.TRUE.
      ELSE
        ENDSND=.FALSE.
      END IF
C
      BYCHNG=.FALSE.
      BYCSTR=.FALSE.
      BYCSND=.FALSE.
C
C  For half-sample/generalized, read in first replicate data and
C  set DNCLUS = 2 as the effective identifier of the replicate
C
      IF((VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5).AND.
     .    UCLUS.NE.11)THEN
        CALL UNFIN(UCLUS,DX(SDTOT),TSIZE,ENDCL)
        DNCLUS=2.D0
        DO 22 ID=1,NID
        VIDSAV(ID)=VIDCL(ID)
   22   CONTINUE
        READ(UNIT=UCLUS)(VIDCL(ID),ID=1,NID)
      ELSE IF(NBY.GE.1) THEN
C
C  For jackknife/random group, if NBY > 0, then UTOT > 0,
C  read in full sample values for the BY group
C
        READ(UNIT=UTOT)(VIDSAV(I),I=1,NID)
        CALL UNFIN(UTOT,DX(SDTOT),TSIZE,ENDF12)
      END IF
C
C  Write out the IDS for the full sample, including any BY
C  variables.
C
      DO 24 I=1,NIDTOT
      IF(I.LE.NVARID) THEN
        VIDOUT(I)=-9878
      ELSE IF(I.LE.NID) THEN
        VIDOUT(I)=VIDSAV(I)
      ELSE
        VIDOUT(I)=1.D0
      END IF
   24 CONTINUE
      WRITE(11)(VIDOUT(I),I=1,NIDTOT)
      IF(VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5.OR.VROPTN.EQ.7)
     .  VIDOUT(NID+1)=0.
C
C  Write out the full sample values
C
      CALL UNFOUT(11,DX(SDTOT),TSIZE)
C
C  Partially replicate the logic of the DO loop to 15 above.
C  Indices NRPT, NSND, and NSND2 are used in the same way as before.
C
      NRPT=0
      NSND=1
      NSND2=1
C
C  Loop over strata
C
      DO 95 ISTR=1,NISTRS
      USESTR=.FALSE.
      SKIPST=.FALSE.
      IF(SDFPC1.GT.0) THEN
        IF(DABS(DX(SDFPC1+ISTR-1)).LT..1D-12)SKIPST=.TRUE.
      END IF
C
C  If USTRT > 0, UIDS will contain records with lower and upper
C  bounds of IDS in the strata and the number of units
C
      IF(USTRT.GT.0) THEN
        READ(UNIT=UIDS)(VIDSTL(I),I=1,LINCR)
        READ(UNIT=UIDS)(VIDSTH(I),I=1,LINCR)
        READ(UNIT=UIDS)NCS
C
C  For VFTYPE 5-12, read stratum totals
C
        IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN
          READ(UNIT=USTRT,END=34)(VIDSTR(ID),ID=1,NID)
          CALL UNFIN(USTRT,DX(SDTOT2),TSIZE,ENDSTR)
          USESTR=.TRUE.
C
C  For other VFTYPEs, check whether ID stored in VIDSTL has the code
C  indicating missing stratum
C
        ELSE
          IF(DABS(VIDSTL(LINCR)-9876.D0).LT..1D-3)GO TO 34
          IF(ENDSTR.OR.BYCSTR)GO TO 34
   26     CONTINUE
C
C  Check the current IDs to determine if it falls within the range
C  for the stratum indicated on the file
C
          DO 28 I=1,LINCR
C
C  Go to 31 if the ID read from the stratum file falls below the
C  range indicated on UID
C
          IF(VIDSTR(I)-VIDSTL(I).LT.-.1D-3) GO TO 31
C
C  Go to 34, and do not use the stratum, if the ID read from the
C  stratum file falls above the range indicated on UID
C
          IF(VIDSTR(I)-VIDSTH(I).GT..1D-3) GO TO 34
   28     CONTINUE
C
C  If fall through to here, the ID on the stratum file falls within
C  the required range, so use it.
C
          USESTR=.TRUE.
          GO TO 34
C
C  Come here to read next records from USTRT
C
   31     CONTINUE
          READ(UNIT=USTRT,END=33)(VIDSTR(ID),ID=1,NID)
          CALL UNFIN(USTRT,DX(SDTOT2),TSIZE,ENDSTR)
C
C  Check for a change in BY variables on the stratum file.
C
          IF(NVARID.LT.NID) THEN
            DO 32 ID=NVARID+1,NID
            IF(DABS(VIDSTR(ID)-VIDSAV(ID)).GT..1D-3) THEN
              BYCSTR=.TRUE.
              GO TO 34
            END IF
   32       CONTINUE
          END IF
C
C  Try again to match to the current range of IDS
C
          GO TO 26
   33     CONTINUE
          ENDSTR=.TRUE.
        END IF
      ELSE
C
C  If USTRT = 0, simply read number of units, NCS, from UIDS
C
        READ(UNIT=UIDS)NCS
      END IF
C
   34 CONTINUE
      IF(VFTYPE.GE.33.AND.VFTYPE.LE.36) THEN
        VIDOUT(NID+2)=VIDSTL(1)
        VIDOUT(NID+3)=VIDSTH(1)
      END IF
C
C  If NISNDS > 0, then set upper bound NSND2 to process NCS
C  second stage units in the following loop to 90.
C  NC is not set to a value yet, it will vary according to the
C  number of clusters within the second-stage unit.
C
      IF(NISNDS.GT.0) THEN
        NSND2=NSND+NCS-1
      ELSE
C
C  If NISNDS = 0, NSND2 is not updated and the following loop to 90
C  will be executed once
C
        NC=NCS
      END IF
C
C  Loop over second-stage units within the stratum.
C
      DO 90 ISND=NSND,NSND2
      SKIPSN=.FALSE.
C
C
C
      IF(NISNDS.GT.0) THEN
        IF(SDFPC1.GT.0) THEN
          IF(DABS(DX(SDFPC1+ISTR-1)-1.D0).LT..1D-12) THEN
            SKIPSN=.TRUE.
          ELSE IF(SDFPC2.GT.0) THEN
            IF(DABS(DX(SDFPC2+ISND-1)).LT..1D-12) SKIPSN=.TRUE.
          END IF
        ELSE
          SKIPSN=.TRUE.
        END IF
      END IF
      USESND=.FALSE.
      IF(USNDS.GT.0)THEN
        READ(UNIT=UIDS)(VIDSNL(I),I=1,LINCR)
        READ(UNIT=UIDS)(VIDSNH(I),I=1,LINCR)
        READ(UNIT=UIDS)NCN
        NC=NCN
        IF(DABS(VIDSNL(LINCR)-9876.D0).LT..1D-3)GO TO 44
C
C  For VFTYPE 5-12, read stratum totals
C
        IF(VFTYPE.GE.5.AND.VFTYPE.LE.12)THEN
          READ(UNIT=USNDS)(VIDSND(ID),ID=1,NID)
          CALL UNFIN(USNDS,DX(SDTOT3),TSIZE,ENDSND)
          USESND=.TRUE.
C
C  For other VFTYPEs, check the current IDs to determine if it falls
C  within the range indicated on the second-stage file
C
        ELSE
          IF(ENDSND.OR.BYCSND)GO TO 44
  36      CONTINUE
          DO 38 I=1,LINCR
C
C  Go to 41 if the ID read from the second-stage file falls below the
C  range indicated on UID
C
          IF(VIDSND(I)-VIDSNL(I).LT.-.1D-3) GO TO 41
C
C  Go to 44, and do not use the second-stage unit, if the ID read
C  from the second-stage file falls above the range indicated on UID
C
          IF(VIDSND(I)-VIDSNH(I).GT..1D-3) GO TO 44
  38      CONTINUE
C
C  If fall through to here, the ID on the second-stage file falls
C  within the required range, so use it.
C
          USESND=.TRUE.
          GO TO 44
C
C  Come here to read next records from USNDS
C
  41      CONTINUE
          READ(UNIT=USNDS,END=43)(VIDSND(ID),ID=1,NID)
          CALL UNFIN(USNDS,DX(SDTOT3),TSIZE,ENDSND)
C
C  Check for a change in BY variables on the second-stage file.
C
          IF(NVARID.LT.NID) THEN
            DO 42 ID=NVARID+1,NID
            IF(DABS(VIDSND(ID)-VIDSAV(ID)).GT..1D-3) THEN
              BYCSND=.TRUE.
              GO TO 44
            END IF
   42       CONTINUE
          END IF
C
C  Try again to match to the current range of IDS
C
          GO TO 36
   43     CONTINUE
          ENDSND=.TRUE.
        END IF
      END IF
   44 CONTINUE
      IF(VFTYPE.GE.35.AND.VFTYPE.LE.38) THEN
        VIDOUT(NIDTOT-3)=VIDSNL(1)
        VIDOUT(NIDTOT-2)=VIDSNH(1)
      END IF
C
C  The loop to 72 is over clusters within a stratum or second-stage
C  unit.
C  NC will be zero if the finite population correction within a
C  second-stage unit is 1.
C
      IF(NC.EQ.0) GO TO 74
      DO 72 J=1,NC
      USECL=.FALSE.
      READ(UNIT=UIDS)(VIDNOW(ID),ID=1,LINCR)
      DO 49 ID=1,LINCR
      VIDOUT(ID)=VIDNOW(ID)
   49 CONTINUE
C
C  Skip if the stratum is missing
C
      IF(DABS(VIDNOW(LINCR)-9876.D0).LT..1D-3)GO TO 55
C
C  Check if in the same BY group
C
      IF(ENDCL.OR.BYCHNG)GO TO 55
   50 CONTINUE
      IF(NVARID.LT.NID) THEN
        DO 51 ID=NVARID+1,NID
        IF(DABS(VIDCL(ID)-VIDSAV(ID)).GT..1D-3) THEN
          BYCHNG=.TRUE.
          GO TO 55
        END IF
   51   CONTINUE
      END IF
C
C  For VFTYPEs 5-12, determine if the cluster is within range
C
      IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN
        IF(DNCLUS-VIDNOW(1).LT.-.1D-3)GO TO 53
        IF(DNCLUS-VIDNOW(1).GT..1D-3)GO TO 55
C
C  For other VFTYPEs, check whether current ID falls within the
C  range
C
      ELSE
        DO 52 ID=1,LINCR
        IF(VIDCL(ID)-VIDNOW(ID).LT.-.1D-3) GO TO 53
        IF(VIDCL(ID)-VIDNOW(ID).GT..1D-3) GO TO 55
   52   CONTINUE
      END IF
      USECL=.TRUE.
      GO TO 55
C
C  Come to 53 to read in another cluster
C
   53 CONTINUE
      CALL UNFIN(UCLUS,DX(SDCLUS),TSIZE,ENDCL)
      READ(UNIT=UCLUS,END=54)(VIDCL(ID),ID=1,NID)
      DNCLUS=DNCLUS+1.D0
C
C  Return to 50 to check the new cluster
C
      GO TO 50
C
C  Come to 54 for end of file on UCLUS
C
   54 CONTINUE
      ENDCL=.TRUE.
C
C  Come here under all circumstances
C
   55 CONTINUE
C
C  Read in the cluster totals if the cluster is to be used
C
      IF(USECL.AND..NOT.ENDCL) THEN
        CALL UNFIN(UCLUS,DX(SDCLUS),TSIZE,ENDCL)
        DNCLUS=DNCLUS+1.D0
      END IF
      IF(USECL.AND..NOT.ENDCL.AND.
     .   ((NISNDS.GT.0.AND..NOT.SKIPSN).OR.
     .    (NISNDS.EQ.0.AND..NOT.SKIPST))) THEN
C
C  Random group
C
        IF(VROPTN.EQ.7) THEN
          F1=DBLE(NC)
          DO 57 K=1,TSIZE
          DX(SDCLUS+K-1)=F1*DX(SDCLUS+K-1)
   57     CONTINUE
          VIDOUT(NIDTOT)=F1
C
        ELSE IF(USESND) THEN
C
C  Cluster within second-stage unit
C
          IF(VROPTN.NE.8) THEN
            F1=DBLE(NC)
            F2=1.0D0/(F1-1.0D0)
            DO 58 K=1,TSIZE
            DX(SDCLUS+K-1)=DX(SDTOT+K-1)
     .              +F2*(DX(SDTOT3+K-1)-F1*DX(SDCLUS+K-1))
   58       CONTINUE
            IF(VFTYPE.LE.32) THEN
              VIDOUT(NIDTOT-2)=1.D0
            ELSE IF(VFTYPE.EQ.35.OR.VFTYPE.EQ.36) THEN
              VIDOUT(NID+4)=1.D0
            ELSE
              VIDOUT(NID+1)=1.D0
            END IF
            VIDOUT(NIDTOT-1)=F1*F2
            VIDOUT(NIDTOT)=0.
          ELSE
            F1=DBLE(NC)
C           F2=1.0D0/(F1-1.0D0)
            DO 582 K=1,TSIZE
            DX(SDCLUS+K-1)=DX(SDTOT+K-1)
     .              -DX(SDTOT3+K-1)+F1*DX(SDCLUS+K-1)
  582       CONTINUE
            IF(VFTYPE.LE.32) THEN
              VIDOUT(NIDTOT-2)=1.D0
            ELSE IF(VFTYPE.EQ.35.OR.VFTYPE.EQ.36) THEN
              VIDOUT(NID+4)=1.D0
            ELSE
              VIDOUT(NID+1)=1.D0
            END IF
            VIDOUT(NIDTOT-1)=0.
            VIDOUT(NIDTOT)=F1
          END IF
        ELSE IF(USESTR) THEN
C
C  Cluster within stratum
C
          IF(VROPTN.NE.8) THEN
            F1=DBLE(NCS)
            F2=1.D0/(F1-1.D0)
            DO 59 K=1,TSIZE
            DX(SDCLUS+K-1)=DX(SDTOT+K-1)
     .              +F2*(DX(SDTOT2+K-1)-F1*DX(SDCLUS+K-1))
   59       CONTINUE
            IF(VFTYPE.LE.28) THEN
              VIDOUT(NID+2)=F1*F2
            ELSE
              VIDOUT(NID+4)=F1*F2
            END IF
            VIDOUT(NIDTOT)=0.
          ELSE
            F1=DBLE(NCS)
            DO 592 K=1,TSIZE
            DX(SDCLUS+K-1)=DX(SDTOT+K-1)
     .              -DX(SDTOT2+K-1)+F1*DX(SDCLUS+K-1)
  592       CONTINUE
            IF(VFTYPE.LE.28) THEN
              VIDOUT(NID+2)=0.
            ELSE
              VIDOUT(NID+4)=0.
            END IF
            VIDOUT(NIDTOT)=F1
          END IF
        ELSE IF(VROPTN.NE.2.AND.VROPTN.NE.3.AND.VROPTN.NE.5) THEN
C
C  Simple jackknife
C
          F1=DBLE(NRPTOT)
          F2=1.D0/(F1-1.D0)
          DO 60 K=1,TSIZE
          DX(SDCLUS+K-1)=DX(SDTOT+K-1)
     .              +F2*(DX(SDTOT+K-1)-F1*DX(SDCLUS+K-1))
   60     CONTINUE
          VIDOUT(NID+1)=F1*F2
          VIDOUT(NID+2)=0.
        END IF
C
C  Same conditions as above, but UCLUST = .FALSE. or ENDCL
C
      ELSE IF((NISNDS.GT.0.AND..NOT.SKIPSN).OR.
     .     (NISNDS.EQ.0.AND..NOT.SKIPST)) THEN
C
C  For Half-sample or general replication, store zeros
C
        IF(VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5.OR.VROPTN.EQ.7)
     .      THEN
          DO 62 K=1,TSIZE
          DX(SDCLUS+K-1)=0.
   62     CONTINUE
          IF(VROPTN.EQ.7)VIDOUT(NIDTOT)=NC
C
C  If second-stage units, reweight second-stage total
C
        ELSE IF(USESND) THEN
          IF(VROPTN.NE.8) THEN
            F2=1.0D0/(DBLE(NC)-1.D0)
            DO 63 K=1,TSIZE
            DX(SDCLUS+K-1)=DX(SDTOT+K-1)
     .                +F2*DX(SDTOT3+K-1)
   63       CONTINUE
            IF(VFTYPE.LE.32) THEN
              VIDOUT(NIDTOT-2)=1.D0
            ELSE IF(VFTYPE.EQ.35.OR.VFTYPE.EQ.36) THEN
              VIDOUT(NID+4)=1.D0
            ELSE
              VIDOUT(NID+1)=1.0D0
            END IF
            VIDOUT(NIDTOT-1)=DBLE(NC)*F2
            VIDOUT(NIDTOT)=0.
          ELSE
            DO 632 K=1,TSIZE
            DX(SDCLUS+K-1)=DX(SDTOT+K-1)
     .                -DX(SDTOT3+K-1)
  632       CONTINUE
            IF(VFTYPE.LE.32) THEN
              VIDOUT(NIDTOT-2)=1.D0
            ELSE IF(VFTYPE.EQ.35.OR.VFTYPE.EQ.36) THEN
              VIDOUT(NID+4)=1.D0
            ELSE
              VIDOUT(NID+1)=1.0D0
            END IF
            VIDOUT(NIDTOT-1)=0.
            VIDOUT(NIDTOT)=DBLE(NC)
          END IF
C
C  Else if strata, reweight stratum total
C
        ELSE IF(USESTR.AND.USNDS.EQ.0) THEN
          IF(VROPTN.NE.8) THEN
            F2=1.0D0/(DBLE(NCS)-1.D0)
            DO 64 K=1,TSIZE
            DX(SDCLUS+K-1)=DX(SDTOT+K-1)
     .                +F2*DX(SDTOT2+K-1)
   64       CONTINUE
            IF(VFTYPE.LE.28) THEN
              VIDOUT(NID+2)=DBLE(NCS)*F2
            ELSE
              VIDOUT(NID+4)=DBLE(NCS)*F2
            END IF
            VIDOUT(NIDTOT)=0.
          ELSE
            DO 642 K=1,TSIZE
            DX(SDCLUS+K-1)=DX(SDTOT+K-1)
     .                -DX(SDTOT2+K-1)
  642       CONTINUE
            IF(VFTYPE.LE.28) THEN
              VIDOUT(NID+2)=0.
            ELSE
              VIDOUT(NID+4)=0.
            END IF
            VIDOUT(NIDTOT)=DBLE(NCS)
          END IF
C
C  Else use full-sample value if replication involves stratum
C  or second-stage ids
C
        ELSE IF(USTRT.GT.0.OR.USNDS.GT.0) THEN
          IF(VROPTN.NE.8) THEN
            DO 65 K=1,TSIZE
            DX(SDCLUS+K-1)=DX(SDTOT+K-1)
   65       CONTINUE
            F2=1.0D0/(DBLE(NC)-1.D0)
            IF(USNDS.GT.0) THEN
              IF(VFTYPE.LE.32) THEN
                VIDOUT(NIDTOT-2)=1.D0
              ELSE IF(VFTYPE.EQ.35.OR.VFTYPE.EQ.36) THEN
                VIDOUT(NID+4)=1.D0
              ELSE
                VIDOUT(NID+1)=1.D0
              END IF
              VIDOUT(NIDTOT-1)=DBLE(NC)*F2
              VIDOUT(NIDTOT)=0.
            ELSE
              IF(VFTYPE.LE.28) THEN
                VIDOUT(NID+2)=DBLE(NC)*F2
              ELSE
                VIDOUT(NID+4)=DBLE(NC)*F2
              END IF
              VIDOUT(NIDTOT)=0.
            END IF
          ELSE
            DO 652 K=1,TSIZE
            DX(SDCLUS+K-1)=DX(SDTOT+K-1)
  652       CONTINUE
            IF(USNDS.GT.0) THEN
              IF(VFTYPE.LE.32) THEN
                VIDOUT(NIDTOT-2)=1.D0
              ELSE IF(VFTYPE.EQ.35.OR.VFTYPE.EQ.36) THEN
                VIDOUT(NID+4)=1.D0
              ELSE
                VIDOUT(NID+1)=1.D0
              END IF
              VIDOUT(NIDTOT-1)=0.
              VIDOUT(NIDTOT)=DBLE(NC)
            ELSE
              IF(VFTYPE.LE.28) THEN
                VIDOUT(NID+2)=0.
              ELSE
                VIDOUT(NID+4)=0.
              END IF
              VIDOUT(NIDTOT)=DBLE(NC)
            END IF
          END IF
C
C  Simple jackknife
C
        ELSE
          F2=DBLE(NC)/(DBLE(NC)-1.D0)
          DO 66 K=1,TSIZE
          DX(SDCLUS+K-1)=F2*DX(SDTOT+K-1)
   66     CONTINUE
          VIDOUT(NID+1)=F2
          VIDOUT(NID+2)=0.
        END IF
      ELSE
        GO TO 71
      END IF
   70 CONTINUE
      NRPT=NRPT+1
      WRITE(11)(VIDOUT(ID),ID=1,NIDTOT)
      CALL UNFOUT(11,DX(SDCLUS),TSIZE)
C
C  Cluster loop ends here
C
 
   71 CONTINUE
      IF(USECL.AND..NOT.ENDCL) THEN
        READ(UNIT=UCLUS,END=61)(VIDCL(ID),ID=1,NID)
        GO TO 72
   61   CONTINUE
        ENDCL=.TRUE.
      END IF
   72 CONTINUE
   74 CONTINUE
C
C  Check if need to generate replicate for second-stage variation
C  within stratum
C
      IF(NISNDS.EQ.0.OR.SKIPST)GO TO 90
      IF(VROPTN.NE.8) THEN
        F1=NCS
        F2=1.0D0/(F1-1.D0)
        VIDOUT(NIDTOT)=0.
        VIDOUT(NIDTOT-1)=0.
        IF(VFTYPE.LE.32) THEN
          VIDOUT(NIDTOT-2)=F1*F2
        ELSE
          VIDOUT(NIDTOT-4)=F1*F2
        END IF
        IF(USESND) THEN
          IF(USESTR) THEN
            DO 76 K=1,TSIZE
            DX(SDCLUS+K-1)=DX(SDTOT+K-1)
     .                  +F2*(DX(SDTOT2+K-1)-F1*DX(SDTOT3+K-1))
   76       CONTINUE
          ELSE
            DO 77 K=1,TSIZE
            DX(SDCLUS+K-1)=DX(SDTOT+K-1)
     .                  +F2*(DX(SDTOT+K-1)-F1*DX(SDTOT3+K-1))
   77       CONTINUE
          END IF
        ELSE IF(USESTR) THEN
          DO 78 K=1,TSIZE
          DX(SDCLUS+K-1)=DX(SDTOT+K-1)
     .                  +F2*DX(SDTOT2+K-1)
   78     CONTINUE
        ELSE IF(USTRT.GT.0) THEN
          DO 795 K=1,TSIZE
          DX(SDCLUS+K-1)=DX(SDTOT+K-1)
  795     CONTINUE
        ELSE
          F2=F1*F2
          DO 79 K=1,TSIZE
          DX(SDCLUS+K-1)=F2*DX(SDTOT+K-1)
   79     CONTINUE
        END IF
      ELSE
        F1=NCS
        VIDOUT(NIDTOT)=F1
        VIDOUT(NIDTOT-1)=F1
        IF(VFTYPE.LE.32) THEN
          VIDOUT(NIDTOT-2)=0.
        ELSE
          VIDOUT(NIDTOT-4)=0.
        END IF
        IF(USESND) THEN
          IF(USESTR) THEN
            DO 762 K=1,TSIZE
            DX(SDCLUS+K-1)=DX(SDTOT+K-1)
     .                  -DX(SDTOT2+K-1)+F1*DX(SDTOT3+K-1)
  762       CONTINUE
          ELSE
            DO 772 K=1,TSIZE
            DX(SDCLUS+K-1)=F1*DX(SDTOT3+K-1)
  772       CONTINUE
          END IF
        ELSE IF(USESTR) THEN
          DO 782 K=1,TSIZE
          DX(SDCLUS+K-1)=DX(SDTOT+K-1)
     .                   -DX(SDTOT2+K-1)
  782     CONTINUE
        ELSE IF(USTRT.GT.0) THEN
          DO 7952 K=1,TSIZE
          DX(SDCLUS+K-1)=DX(SDTOT+K-1)
 7952     CONTINUE
        ELSE
          F2=F1*F2
          DO 792 K=1,TSIZE
          DX(SDCLUS+K-1)=0.
  792     CONTINUE
        END IF
      END IF
      IF(NVARID.GT.0) THEN
        DO 81 ID=1,NVARID
        VIDOUT(ID)=VIDSNH(ID)
   81   CONTINUE
      END IF
      WRITE(11)(VIDOUT(ID),ID=1,NIDTOT)
      CALL UNFOUT(11,DX(SDCLUS),TSIZE)
C
C  End of loop over strata
C
   90 CONTINUE
      IF(NISNDS.GT.0)NSND=NSND+IX(SISTRS+ISTR-1)
   95 CONTINUE
C
C  Check to see if another BY group remains to be processed
C
      IBYGRP=IBYGRP+1
      IF(NBY.GE.1.AND.IBYGRP.LE.NBYGRP)GO TO 20
      CLOSE(11)
      RETURN
      END
      SUBROUTINE RECODX(IXDROP,ENDF12)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (IXFLLD=3)
      PARAMETER (MAXFMT=20)
      PARAMETER (MAXIXM=1000)
      INTEGER IXM(MAXIXM)
      REAL RXM(MAXIXM)
      LOGICAL ENDF,ENDF12,IOERR
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1,
     . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX
C
      DOUBLE PRECISION RANGE(2,MRANGE)
      INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET),
     . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD),
     . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI)
C
      COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP,
     . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO,
     . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS,
     . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT,
     . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS,
     . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO,
     . NLEVEL,NRNSET,NRANGE,NHADAM,SDHADM,SDOUTP,SDVID,SDVPIN,IREPL,
     . IREPH,IFILE,SDRFW,IPASS,METHOD,NFILES,SDROUT,NROUT,NMAX,IXFILL,
     . SDSTCK,MSDPTH
      INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS,
     . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN,
     . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,SDHADM,SDOUTP,SDVID,
     . SDVPIN,SDRFW,SDROUT,IXFILL(IXFLLD),SDSTCK,MSDPTH
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
      LOGICAL IXDROP,ICHECK
      EXTERNAL ICHECK
      DOUBLE PRECISION MISSNG
      DATA MISSNG/-98765.432109D0/
C
C  Usage in this subroutine:
C
C  BLXSTR  -  pointer for block to X matrix
C  BLXINC  -  length of the X matrix for a single combination
C             of the class variables in the block
C  BLXSIZ  -  total size of block data in X matrix (integer multiple
C             of BLXINC)
C  BLVSTR  -  Pointer to first variable in block on outgoing file
C  BLVSIZ  -  Number of variables in block
C  BLNCLS  -  number of class variables in block
C  BLCPNT  -  pointer for classes to CLTYPE
C  CLTYPE  -  used as pointers to class variables
C
  101 FORMAT(/,5X,'End of primary input file after obs #',I8)
  102 FORMAT(/,5X,'I/O error on primary input file after obs #',I8)
  103 FORMAT(/,5X,'End on unit',I3,' after obs #',11X,I8)
  104 FORMAT(/,5X,'I/O error on unit',I3,' after obs #',I8)
  105 FORMAT(/,5X,'Unit',I3,' at obs #',I8,' on end of primary file')
  201 FORMAT(' MISMATCH OF KEYS, UNIT',I3,' OBS #',I8)
  202 FORMAT(1X,A12,F20.4)
  203 FORMAT(' REQUIRED MATCH')
  204 FORMAT(' NONASCENDING KEYS ON UNIT',I3,' OBS #',I8)
  205 FORMAT(/,' PREVIOUS OBSERVATION UNIT',I3,' OBS #',I8)
  206 FORMAT(' PREMATURE END ON UNIT',I3,' OBS #',I8)
  208 FORMAT(' MISMATCHING BY VAR(S)')
  209 FORMAT(' EMPTY PRIMARY FILE')
  210 FORMAT(' NONINTEGER ROW:',F20.4)
  212 FORMAT(1X,A12,2F20.4)
  213 FORMAT(' NEW VALUES OF BY VARIABLES FOR THE OBSERVATION')
  221 FORMAT(' PRINT request',I5:)
  222 FORMAT(6X,A12,F20.6,F10.0,2X,'Crossed real')
  223 FORMAT(6X,A12,11X,'(M)')
  224 FORMAT(6X,A12,F14.0,18X,'Categorical')
  225 FORMAT(6X,A12,F14.0,18X,'Class')
  226 FORMAT(6X,A12,F14.0,18X,'Crossed categorical')
  230 FORMAT(6X,A12,F14.4,10X,A12,F14.4)
C
      DO 32 I=1,NVIN
      MTYPE(I)=MTSTRT(I)
      IF(MTSTRT(I).EQ.2) THEN
        MSIZE(I)=2
      ELSE
        MSIZE(I)=1
      END IF
   32 CONTINUE
      IRECOD=0
      ISTACK=SDSTCK-2
    1 CONTINUE
      IRECOD=IRECOD+1
    2 CONTINUE
      IF(IRECOD.GT.NRECOD) THEN
        RETURN
      END IF
      IRC=RCTYPE(IRECOD)
C
C   100 =   store (and push down stack)
C   101 =   load variable
C   102 =   add variable
C   103 =   subtract variable
C   104 =   multiply variable
C   105 =   divide variable
C   106 =   power variable
C   108 =   store with stack in place (for multiple stores)
C   109 =   go to when stack is 0 or missing
C   111 =   load constant
C   112 =   add constant
C   113 =   subtract constant
C   114 =   multiply constant
C   115 =   divide constant
C   116 =   power constant (noninteger)
C   117 =   power positive integer
C   118 =   power negative integer
C   119 =   square
C   121 =   or stack
C   122 =   and stack
C   124 =   LT stack
C   125 =   LE stack
C   126 =   EQ stack
C   127 =   NE stack
C   128 =   GT stack
C   129 =   GE stack
C   130 =   IN stack (compare stack to interval)
C   132 =   add stack
C   133 =   subtract stack
C   134 =   multiply stack
C   135 =   divide stack
C   136 =   power stack
C   140 =   apply function to stack
C   141 =   apply function to many in stack
C   142 =   IDCHANGE
C   202 =   add        many to one
C   203 =   subtract        "
C   204 =   multiply        "
C   205 =   divide          "
C   206 =   power           "
C   212 =   add        one to many
C   213 =   subtract        "
C   214 =   multiply        "
C   215 =   divide          "
C   216 =   power           "
C   222 =   add        many to many
C   223 =   subtract        "
C   224 =   multiply        "
C   225 =   divide          "
C   226 =   power           "
C
C   250 =   load value from VPLX file, 0 replicate
C               v1        v2        v3        rstpnt
C                                vplxin v     #classes
C          for each class:
C               v1        v2        v3        rstpnt
C            class/cat           0 offset    increment
C
C   254 =   loop to load values from VPLX files, replicate 1+
C               v1        v2        v3        rstpnt
C             1st rep   # rep   vplxin var  #classes
C          for each class:
C               v1        v2        v3        rstpnt
C            class/cat           0 offset    increment
C
C   255 =   loop to store replicate values, replicate 1+
C               v1        v2
C             1st rep   # rep
C
C   256 =   loop to load replicate values, replicate 1+
C               v1        v2
C             1st rep   # rep
C
C  OR     1   1
C  AND    2   2
C  NOT    3   3 (implemented with PLACE and function)
C  LT     4   4
C  LE     5   4
C  EQ     6   4
C  NE     7   4
C  GT     8   4
C  GE     9   4
C  IN    10   4
C  CHS   11   5
C  +     12   5
C  -     13   5
C  *     14   6
C  /     15   6
C  **    16   7
C
      IF(IRC.GE.100.AND.IRC.LT.200.AND..NOT.ENDF12) THEN
        IF(IRC.LE.108) THEN
          IV1=V1(IRECOD)
          JV1=VMAPL(IV1)
          IF(IRC.EQ.100.OR.IRC.EQ.108) THEN
            DX(JV1)=DX(ISTACK)
            IF(MTYPE(IV1).EQ.2) THEN
              DX(JV1+1)=DX(ISTACK+1)
            END IF
            IF(IRC.EQ.100) THEN
              ISTACK=ISTACK-2
            END IF
C           write(*,*)irc,istack
          ELSE IF(IRC.EQ.101) THEN
            ISTACK=ISTACK+2
C           write(*,*)irc,istack
            DX(ISTACK)=DX(JV1)
            IF(MTYPE(IV1).EQ.2) THEN
              DX(ISTACK+1)=DX(JV1+1)
            ELSE
              DX(ISTACK+1)=1.D0
            END IF
          ELSE
            IF(DX(ISTACK+1).GT.0.) THEN
              IF(MTYPE(IV1).EQ.2.AND.DX(JV1+1).EQ.0.) THEN
                DX(ISTACK)=0.
                DX(ISTACK+1)=0.
              ELSE
                IF(IRC.EQ.102) THEN
                  DX(ISTACK)=DX(ISTACK)+DX(JV1)
                ELSE IF(IRC.EQ.103) THEN
                  DX(ISTACK)=DX(ISTACK)-DX(JV1)
                ELSE IF(IRC.EQ.104) THEN
                  DX(ISTACK)=DX(ISTACK)*DX(JV1)
                ELSE IF(IRC.EQ.105) THEN
                  IF(DX(JV1).EQ.0.) THEN
                    DX(ISTACK)=0.
                    DX(ISTACK+1)=0.
                  ELSE
                    DX(ISTACK)=DX(ISTACK)/DX(JV1)
                  END IF
                ELSE IF(IRC.EQ.106) THEN
C                                                        ! x**y
                  IF(DX(ISTACK).LT.0.) THEN
C                                                        ! negative x
                    IF(ICHECK(DX(JV1),DVALUE)) THEN
C                                                        ! integer y
                      IF(DVALUE.LT.0) THEN
                        J=DVALUE-.05D0
                      ELSE
                        J=DVALUE+.05D0
                      END IF
                      IF(J.EQ.(J/2)*2) THEN
                        DX(ISTACK)=(DABS(DX(ISTACK)))**J
                      ELSE
                        K=(J/2)*2
                        IF(J.LT.0) THEN
                          DX(ISTACK)=((DABS(DX(ISTACK)))**K)/DX(ISTACK)
                        ELSE
                          DX(ISTACK)=((DABS(DX(ISTACK)))**K)*DX(ISTACK)
                        END IF
                      END IF
                    ELSE
C                                                        ! noninteger y
                      DX(ISTACK)=0
                      DX(ISTACK+1)=0
                    END IF
                  ELSE IF(DX(ISTACK).EQ.0) THEN
C                                                        ! x=0
                    IF(DX(JV1).LE.0.) THEN
C                                                        ! y<=0
                      DX(ISTACK)=0
                      DX(ISTACK+1)=0
                    END IF
                  ELSE
                    DX(ISTACK)=DX(ISTACK)**DX(JV1)
                  END IF
                END IF
              END IF
            END IF
          END IF
        ELSE IF(IRC.GE.111.AND.IRC.LE.119) THEN
          JV1=V1(IRECOD)
          IF(IRC.EQ.111) THEN
            ISTACK=ISTACK+2
C           write(*,*)irc,istack
            DX(ISTACK)=DX(JV1)
            DX(ISTACK+1)=1.D0
          ELSE
            IF(DX(ISTACK+1).GT.0.) THEN
              IF(IRC.EQ.112) THEN
                DX(ISTACK)=DX(ISTACK)+DX(JV1)
              ELSE IF(IRC.EQ.113) THEN
                DX(ISTACK)=DX(ISTACK)-DX(JV1)
              ELSE IF(IRC.EQ.114) THEN
                DX(ISTACK)=DX(ISTACK)*DX(JV1)
              ELSE IF(IRC.EQ.115) THEN
                IF(DX(JV1).EQ.0.) THEN
                  DX(ISTACK)=0.
                  DX(ISTACK+1)=0.
                ELSE
                  DX(ISTACK)=DX(ISTACK)/DX(JV1)
                END IF
              ELSE IF(IRC.EQ.116) THEN
C                                                        ! noninteger
                IF(DX(ISTACK).LT.0.) THEN
C                                                        ! exponent
                  DX(ISTACK)=0.
                  DX(ISTACK+1)=0.
                ELSE IF(DX(ISTACK).GT.0.) THEN
                  DX(ISTACK)=DX(ISTACK)**DX(JV1)
                ELSE IF(DX(JV1).LE.0.) THEN
                  DX(ISTACK+1)=0.
                END IF
              ELSE IF(IRC.EQ.117.OR.IRC.EQ.118) THEN
C                                                        ! positive 117
                IF(DX(ISTACK).LT.0.) THEN
C                                                        ! negative 118
                  IF(JV1.EQ.(JV1/2)*2) THEN
C                                                        ! integer
                    DX(ISTACK)=(DABS(DX(ISTACK)))**JV1
                  ELSE
                    K=(JV1/2)*2
                    IF(IRC.EQ.118) THEN
                      DX(ISTACK)=((DABS(DX(ISTACK)))**K)/DX(ISTACK)
                    ELSE
                      DX(ISTACK)=((DABS(DX(ISTACK)))**K)*DX(ISTACK)
                    END IF
                  END IF
                ELSE IF(DX(ISTACK).GT.0) THEN
                  DX(ISTACK)=DX(ISTACK)**JV1
                ELSE IF(JV1.LE.0) THEN
                  DX(ISTACK+1)=0.
                END IF
              ELSE IF(IRC.EQ.119) THEN
                DX(ISTACK)=DX(ISTACK)*DX(ISTACK)
              END IF
            END IF
          END IF
        ELSE IF(IRC.GE.121.AND.IRC.LE.136.AND.IRC.NE.130) THEN
          ISTACK=ISTACK-2
          IF(IRC.EQ.121) THEN
            IF((DX(ISTACK).NE.0..AND.DX(ISTACK+1).NE.0.).OR.
     .         (DX(ISTACK+2).NE.0..AND.DX(ISTACK+3).NE.0.)) THEN
               DX(ISTACK)=1.D0
               DX(ISTACK+1)=1.D0
            ELSE IF(DX(ISTACK+1).NE.0..AND.DX(ISTACK+3).NE.0.) THEN
               DX(ISTACK)=0.
               DX(ISTACK+1)=1.
            ELSE
               DX(ISTACK)=0.
               DX(ISTACK+1)=0.
            END IF
          ELSE IF(DX(ISTACK+3).EQ.0.) THEN
            DX(ISTACK)=0.
            DX(ISTACK+1)=0
          ELSE IF(DX(ISTACK+1).NE.0.) THEN
            IF(IRC.GT.130) THEN
              IF(IRC.EQ.132) THEN
                DX(ISTACK)=DX(ISTACK)+DX(ISTACK+2)
              ELSE IF(IRC.EQ.133) THEN
                DX(ISTACK)=DX(ISTACK)-DX(ISTACK+2)
              ELSE IF(IRC.EQ.134) THEN
                DX(ISTACK)=DX(ISTACK)*DX(ISTACK+2)
              ELSE IF(IRC.EQ.135) THEN
                IF(DX(ISTACK+2).EQ.0.) THEN
                  DX(ISTACK)=0.
                  DX(ISTACK+1)=0.
                ELSE
                  DX(ISTACK)=DX(ISTACK)/DX(ISTACK+2)
                END IF
              ELSE IF(IRC.EQ.136) THEN
                IF(DX(ISTACK).LT.0.) THEN
                  IF(ICHECK(DX(ISTACK+2),DVALUE)) THEN
                    IF(DVALUE.LT.0) THEN
                      J=DVALUE-.05D0
                    ELSE
                      J=DVALUE+.05D0
                    END IF
                    IF(J.EQ.(J/2)*2) THEN
                      DX(ISTACK)=(DABS(DX(ISTACK)))**J
                    ELSE
                      K=(J/2)*2
                      IF(J.LT.0) THEN
                        DX(ISTACK)=((DABS(DX(ISTACK)))**K)/DX(ISTACK)
                      ELSE
                        DX(ISTACK)=((DABS(DX(ISTACK)))**K)*DX(ISTACK)
                      END IF
                    END IF
                  ELSE
                    DX(ISTACK)=0
                    DX(ISTACK+1)=0
                  END IF
                ELSE
                  DX(ISTACK)=DX(ISTACK)**DX(ISTACK+2)
                END IF
              END IF
            ELSE
              IF(IRC.EQ.122) THEN
                IF(DX(ISTACK).NE.0..AND.DX(ISTACK+2).NE.0) THEN
                  DX(ISTACK)=1.D0
                ELSE
                  DX(ISTACK)=0.
                END IF
              ELSE
                IF(ICHECK(DX(ISTACK),DVALUE)) THEN
                  DX(ISTACK)=DVALUE
                END IF
                IF(ICHECK(DX(ISTACK+2),DVALUE)) THEN
                  DX(ISTACK+2)=DVALUE
                END IF
                DVALUE=0.
                IF(IRC.EQ.124) THEN
                  IF(DX(ISTACK).LT.DX(ISTACK+2)) THEN
                    DVALUE=1.D0
                  END IF
                ELSE IF(IRC.EQ.125) THEN
                  IF(DX(ISTACK).LE.DX(ISTACK+2)) THEN
                    DVALUE=1.D0
                  END IF
                ELSE IF(IRC.EQ.126) THEN
                  IF(DX(ISTACK).EQ.DX(ISTACK+2)) THEN
                    DVALUE=1.D0
                  END IF
                ELSE IF(IRC.EQ.127) THEN
                  IF(DX(ISTACK).NE.DX(ISTACK+2)) THEN
                    DVALUE=1.D0
                  END IF
                ELSE IF(IRC.EQ.128) THEN
                  IF(DX(ISTACK).GT.DX(ISTACK+2)) THEN
                    DVALUE=1.D0
                  END IF
                ELSE IF(IRC.EQ.129) THEN
                  IF(DX(ISTACK).GE.DX(ISTACK+2)) THEN
                    DVALUE=1.D0
                  END IF
                END IF
                DX(ISTACK)=DVALUE
              END IF
            END IF
          END IF
        ELSE IF(IRC.EQ.130) THEN
          IRNSET=RSTPNT(IRECOD)
          IRNGPT=RNGPNT(IRNSET)
          INRNG=NRNG(IRNSET)
C
C  Range type
C  1  value1 - value2
C  2  LOW - value
C  3  value - HIGH
C  4  LOW - HIGH
C  5  MISSING
C  6  value - n
C
          DO 935 I=IRNGPT,IRNGPT+INRNG-1
          IF(RTYPE(I).EQ.5) THEN
            IF(DX(ISTACK+1).NE.0.) GO TO 935
            DX(ISTACK+1)=1.D0
          ELSE IF(DX(ISTACK+1).EQ.0.) THEN
            GO TO 935
          ELSE IF(RTYPE(I).EQ.1) THEN
            IF(DX(ISTACK).LT.RANGE(1,I).OR.
     .         DX(ISTACK).GT.RANGE(2,I)) GO TO 935
          ELSE IF(RTYPE(I).EQ.2) THEN
            IF(DX(ISTACK).GT.RANGE(2,I)) GO TO 935
          ELSE IF(RTYPE(I).EQ.3) THEN
            IF(DX(ISTACK).LT.RANGE(1,I)) GO TO 935
          END IF
          DX(ISTACK)=1.D0
          GO TO 936
  935     CONTINUE
          DX(ISTACK)=0.
  936     CONTINUE
        ELSE IF(IRC.EQ.140.OR.IRC.EQ.141) THEN
          IF(IRC.EQ.140) THEN
            N=1
          ELSE
            N=V2(IRECOD)
          END IF
          IS=ISTACK-2*N+2
          DO 58 I=1,N
          IV1=V1(IRECOD)
          IF(IV1.EQ.8) THEN
C                                           ! MISSING
            IF(DX(IS+1).NE.0.) THEN
              DX(IS)=0.
            ELSE
              DX(IS)=1.D0
              DX(IS+1)=1.D0
            END IF
          ELSE IF(DX(IS+1).NE.0.) THEN
            IF(IV1.EQ.1) THEN
C                                           ! NOT
              IF(DX(IS).EQ.0.) THEN
                DX(IS)=1.D0
              ELSE
                DX(IS)=0.
              END IF
            ELSE IF(IV1.EQ.2) THEN
C                                           ! - X
              DX(IS)=-DX(IS)
            ELSE IF(IV1.EQ.3) THEN
C                                           ! SQRT
              IF(DX(IS).GT.0.) THEN
                DX(IS)=DSQRT(DX(IS))
              ELSE IF(DX(ISTACK).LT.0.) THEN
                DX(IS)=0.
                DX(IS+1)=0.
              END IF
            ELSE IF(IV1.EQ.4) THEN
C                                           ! ABS
              DX(IS)=DABS(DX(IS))
            ELSE IF(IV1.EQ.5) THEN
C                                           ! LOG
              IF(DX(IS).GT.0.) THEN
                DX(IS)=DLOG(DX(IS))
              ELSE
                DX(IS)=0.
                DX(IS+1)=0.
              END IF
            ELSE IF(IV1.EQ.6) THEN
C                                           ! EXP
              DX(IS)=DEXP(DX(IS))
            ELSE IF(IV1.EQ.7) THEN
C                                           ! INT
              IF(ICHECK(DX(IS),DVALUE)) THEN
                DX(IS)=DVALUE
              ELSE
                DX(IS)=DVALUE
              END IF
            END IF
          END IF
          IS=IS+2
   58     CONTINUE
        ELSE IF(IRC.EQ.142) THEN
C                                           ! IDCHANGE (as function)
          ISTACK=ISTACK+2
          DX(ISTACK)=0.
          DX(ISTACK+1)=1.D0
          DO 60 I=1,RSTPNT(IRECOD)
          IV1=V2(IRECOD+I)
          IF(DABS(DX(VMAPL(IV1))-DX(V3(IRECOD+I))).GT..1D-3) THEN
            DX(ISTACK)=1.D0
            DO 59 II=1,RSTPNT(IRECOD)
            DX(V3(IRECOD+II))=DX(VMAPL(V2(IRECOD+II)))
   59       CONTINUE
            GO TO 61
          END IF
   60     CONTINUE
   61     CONTINUE
          IRECOD=IRECOD+RSTPNT(IRECOD)
        ELSE IF(IRC.EQ.109) THEN
C                                           ! GO TO on stack 0/missing
          ISTACK=ISTACK-2
          IF(DX(ISTACK+2).EQ.0..OR.DX(ISTACK+3).EQ.0.) THEN
            IRECOD=V3(IRECOD)
            GO TO 2
          END IF
        END IF
        GO TO 1
      ELSE IF(IRC.GE.200.AND..NOT.ENDF12) THEN
        N=V2(IRECOD)
        IF(IRC.LE.209) THEN
          IS=ISTACK-2*N
          DO 50 I=1,N
          IF(DX(ISTACK+1).EQ.0.) THEN
            DX(IS)=0.
            DX(IS+1)=0.
          ELSE IF(DX(IS+1).NE.0.) THEN
            IF(IRC.EQ.202) THEN
              DX(IS)=DX(IS)+DX(ISTACK)
            ELSE IF(IRC.EQ.203) THEN
              DX(IS)=DX(IS)-DX(ISTACK)
            ELSE IF(IRC.EQ.204) THEN
              DX(IS)=DX(IS)*DX(ISTACK)
            ELSE IF(IRC.EQ.205) THEN
              IF(DX(ISTACK).EQ.0.) THEN
                DX(IS)=0.
                DX(IS+1)=0.
              ELSE
                DX(IS)=DX(IS)/DX(ISTACK)
              END IF
            ELSE IF(IRC.EQ.206) THEN
              IF(DX(IS).LT.0.) THEN
                IF(ICHECK(DX(ISTACK),DVALUE)) THEN
                  IF(DVALUE.LT.0) THEN
                    J=DVALUE-.05D0
                  ELSE
                    J=DVALUE+.05D0
                  END IF
                  IF(J.EQ.(J/2)*2) THEN
                    DX(IS)=(DABS(DX(IS)))**J
                  ELSE
                    K=(J/2)*2
                    IF(J.LT.0) THEN
                      DX(IS)=((DABS(DX(IS)))**K)/DX(IS)
                    ELSE
                      DX(IS)=((DABS(DX(IS)))**K)*DX(IS)
                    END IF
                  END IF
                ELSE
                  DX(IS)=0
                  DX(IS+1)=0
                END IF
              ELSE
                DX(IS)=DX(IS)**DX(ISTACK)
              END IF
            END IF
          END IF
          IS=IS+2
   50     CONTINUE
          ISTACK=ISTACK-2
        ELSE IF(IRC.LE.219) THEN
          ISB=ISTACK-2*N
          IS=ISB+2
          DO 52 I=1,N
          IF(DX(ISB+1).EQ.0.) THEN
            DX(IS)=0.
            DX(IS+1)=0.
          ELSE IF(DX(IS+1).NE.0.) THEN
            IF(IRC.EQ.212) THEN
              DX(IS)=DX(ISB)+DX(IS)
            ELSE IF(IRC.EQ.213) THEN
              DX(IS)=DX(ISB)-DX(IS)
            ELSE IF(IRC.EQ.214) THEN
              DX(IS)=DX(ISB)*DX(IS)
            ELSE IF(IRC.EQ.215) THEN
              IF(DX(IS).EQ.0.) THEN
                DX(IS)=0.
                DX(IS+1)=0.
              ELSE
                DX(IS)=DX(ISB)/DX(IS)
              END IF
            ELSE IF(IRC.EQ.216) THEN
              IF(DX(ISB).LT.0.) THEN
                IF(ICHECK(DX(IS),DVALUE)) THEN
                  IF(DVALUE.LT.0) THEN
                    J=DVALUE-.05D0
                  ELSE
                    J=DVALUE+.05D0
                  END IF
                  IF(J.EQ.(J/2)*2) THEN
                    DX(IS)=(DABS(DX(ISB)))**J
                  ELSE
                    K=(J/2)*2
                    IF(J.LT.0) THEN
                      DX(IS)=((DABS(DX(ISB)))**K)/DX(ISB)
                    ELSE
                      DX(IS)=((DABS(DX(ISB)))**K)*DX(ISB)
                    END IF
                  END IF
                ELSE
                  DX(IS)=0
                  DX(IS+1)=0
                END IF
              ELSE
                DX(IS)=DX(ISB)**DX(IS)
              END IF
            END IF
          END IF
          IS=IS+2
   52     CONTINUE
          IS=ISB+2
          DO 54 I=1,N
          DX(ISB)=DX(IS)
          DX(ISB+1)=DX(IS+1)
          ISB=ISB+2
          IS=IS+2
   54     CONTINUE
          ISTACK=ISTACK-2
        ELSE IF(IRC.LE.229) THEN
          IS=ISTACK-4*N+2
          ISB=IS+2*N
          DO 56 I=1,N
          IF(DX(ISB+1).EQ.0.) THEN
            DX(IS)=0.
            DX(IS+1)=0.
          ELSE IF(DX(IS+1).NE.0.) THEN
            IF(IRC.EQ.222) THEN
              DX(IS)=DX(IS)+DX(ISB)
            ELSE IF(IRC.EQ.223) THEN
              DX(IS)=DX(IS)-DX(ISB)
            ELSE IF(IRC.EQ.224) THEN
              DX(IS)=DX(IS)*DX(ISB)
            ELSE IF(IRC.EQ.225) THEN
              IF(DX(ISB).EQ.0.) THEN
                DX(IS)=0.
                DX(IS+1)=0.
              ELSE
                DX(IS)=DX(IS)/DX(ISB)
              END IF
            ELSE IF(IRC.EQ.226) THEN
              IF(DX(IS).LT.0.) THEN
                IF(ICHECK(DX(ISB),DVALUE)) THEN
                  IF(DVALUE.LT.0) THEN
                    J=DVALUE-.05D0
                  ELSE
                    J=DVALUE+.05D0
                  END IF
                  IF(J.EQ.(J/2)*2) THEN
                    DX(IS)=(DABS(DX(IS)))**J
                  ELSE
                    K=(J/2)*2
                    IF(J.LT.0) THEN
                      DX(IS)=((DABS(DX(IS)))**K)/DX(IS)
                    ELSE
                      DX(IS)=((DABS(DX(IS)))**K)*DX(IS)
                    END IF
                  END IF
                ELSE
                  DX(IS)=0
                  DX(IS+1)=0
                END IF
              ELSE
                DX(IS)=DX(IS)**DX(ISB)
              END IF
            END IF
          END IF
          IS=IS+2
          ISB=ISB+2
   56     CONTINUE
          ISTACK=ISTACK-2*N
C
        ELSE IF(IRC.EQ.250.OR.IRC.EQ.254) THEN
          IF(IRC.EQ.254) THEN
            NV=V2(IRECOD)
            MT=V1(IRECOD)
          END IF
C
C  calculate the location in the VPLXIN file of the matching factor.
C
          JV3=VMAPL(V3(IRECOD))+SDVPIN-1
          K=RSTPNT(IRECOD)
          IF(K.GT.0) THEN
            DO 561 I=1,K
            IRECOD=IRECOD+1
            JV1A=VMAPL(V1(IRECOD))
            INDX=DX(JV1A)+.05
            IF(INDX.EQ.0) THEN
              JV3=0
            ELSE IF(JV3.GT.0) THEN
              IF(V3(IRECOD).EQ.1) THEN
                JV3=JV3+RSTPNT(IRECOD)*INDX
              ELSE
                JV3=JV3+RSTPNT(IRECOD)*(INDX-1)
              END IF
            END IF
  561       CONTINUE
          END IF
C
C  The following transfer was copied from analogous code to handle
C  IRC=50 through 57, but it is not clear that it is needed.
C
          IF(ENDF12)GO TO 1
C
C               K=SDRFW+IREPL-1-NMAX
C
          IF(IRC.EQ.250) THEN
            ISTACK=ISTACK+2
            IF(JV3.EQ.0) THEN
              DX(ISTACK)=0.
              DX(ISTACK+1)=0.
            ELSE IF(DABS(DX(JV3)-MISSNG).LE..1D-6) THEN
              DX(ISTACK)=0.
              DX(ISTACK+1)=0.
            ELSE
              DX(ISTACK)=DX(JV3)
              DX(ISTACK+1)=1.D0
            END IF
          ELSE
C
C  MT is the index of the first replicate weight/factor to be operated on.
C
            DO 562 I=MT,MT+NV-1
            ISTACK=ISTACK+2
            IF(I.LT.IREPL.OR.I.GT.IREPH.OR.JV3.EQ.0) THEN
              DX(ISTACK)=0.
              DX(ISTACK+1)=0.
            ELSE
              JV3T=JV3+TSIZE*(I-IREPL+1)
              IF(DABS(DX(JV3T)-MISSNG).LE..1D-6) THEN
                DX(ISTACK)=0.
                DX(ISTACK+1)=0.
              ELSE
                DX(ISTACK)=DX(JV3T)
                DX(ISTACK+1)=1.D0
              END IF
            END IF
  562       CONTINUE
          END IF
        ELSE IF(IRC.EQ.255) THEN
          NV=V2(IRECOD)
          MT=VMAPL(V1(IRECOD))-SDRFW+1
          DO 563 I=MT+NV-1,MT,-1
C                                              ! Unload stack in
          IF(I.GE.IREPL.AND.I.LE.IREPH) THEN
C                                              ! reverse order
            IF(DX(ISTACK+1).EQ.0.) THEN
              DX(I+SDRFW-1)=0.
            ELSE
              DX(I+SDRFW-1)=DX(ISTACK)
            END IF
          END IF
          ISTACK=ISTACK-2
  563     CONTINUE
        ELSE IF(IRC.EQ.256) THEN
          NV=V2(IRECOD)
          MT=VMAPL(V1(IRECOD))-SDRFW+1
          DO 564 I=MT,MT+NV-1
          ISTACK=ISTACK+2
          DX(ISTACK)=DX(I+SDRFW-1)
          DX(ISTACK+1)=1.D0
  564     CONTINUE
        END IF
        GO TO 1
      ELSE IF(IRC.EQ.36) THEN
        IRECOD=V3(IRECOD)
        GO TO 2
C
C  INPUT
C
      ELSE IF(IRC.GE.40.AND.IRC.LE.42) THEN
        L=V3(IRECOD)
        K=V2(IRECOD+1)
        KF=RSTPNT(IRECOD+2)
C                                          ! INFLAG
        IF(KF.GT.0) THEN
          DX(VMAPL(KF))=1.D0
C                                          ! Initialize INFLAG = 1
        END IF
    3   CONTINUE
C
C  If keyed link, check for matching keys.
C
        IF(RSTPNT(IRECOD).GT.0.AND.V2(IRECOD).GT.0.AND..NOT.ENDF12) THEN
          J=IRECOD+3
          DO 7 I=1,RSTPNT(IRECOD)
          DIFFID=DX(V1(J))-DX(V2(J))
          IF(DIFFID.LT.-.1D-03) THEN
C
C  If DIFFID is significantly negative, go to 8 to read a record
C  from the input file
C
            GO TO 8
C
C  If the KEY variable is higher on the LINK file, then either
C  print error message under LINK or set values to missing under
C  LINK_MISSING or to 0 if LINK and
C
          ELSE IF(DIFFID.GT..1D-03) THEN
C
C  Error message under LINK
C
            IF(IRC.EQ.41.AND.KF.EQ.0) THEN
              WRITE(U6,201)V1(IRECOD),V2(IRECOD)
              J=IRECOD+3
              DO 4 K=1,RSTPNT(IRECOD)
              WRITE(U6,202)VNAME(RSTPNT(J)),DX(V1(J))
              J=J+1
    4         CONTINUE
              WRITE(U6,203)
              J=IRECOD+3
              DO 5 K=1,RSTPNT(IRECOD)
              WRITE(U6,202)VNAME(RSTPNT(J)),DX(V2(J))
              J=J+1
    5         CONTINUE
              CALL FESTOP(35001)
C
C  Set values to missing under LINK_MISSING or =0 for INFLAG
C
            ELSE
              IF(KF.GT.0) THEN
                DX(VMAPL(KF))=0.
              END IF
              DO 6 K=V1(IRECOD+1),V1(IRECOD+1)+L-1
              II=IX(K)
              DX(VMAPL(II))=0.
              IF(IRC.EQ.42) THEN
                DX(VMAPL(II)+1)=0.
              END IF
    6         CONTINUE
C
C  Update IRECOD and process next transformation
C
              IRECOD=IRECOD+2+RSTPNT(IRECOD)
              GO TO 1
            END IF
          END IF
          J=J+1
    7     CONTINUE
          GO TO 16
        END IF
    8   CONTINUE
C
C  If end of file has not yet occurred, this section reads the next
C  record from the file.
C
        IF(V2(IRECOD).GE.0) THEN
C
C  Test for premature end of file for NOBS= specification
C
          IF(V2(IRECOD+2).GT.0.AND.V2(IRECOD).GE.V2(IRECOD+2)) THEN
            ENDF=.TRUE.
          ELSE
            KV=V1(IRECOD+1)
            IF(V3(IRECOD+2).LE.1) THEN
              IF(RSTPNT(IRECOD+1).EQ.1) THEN
                CALL XREAD1(DX(K),L,V1(IRECOD),INFRMT(V3(IRECOD+1)),
     .            ENDF,IOERR,V2(IRECOD),IX(KV),V1(IRECOD+2))
              ELSE
                CALL XREAD(DX(K),L,V1(IRECOD),INFRMT(V3(IRECOD+1)),
     .            RSTPNT(IRECOD+1),ENDF,IOERR,V2(IRECOD),IX(KV),
     .            V1(IRECOD+2))
              END IF
            ELSE IF(V3(IRECOD+2).EQ.3) THEN
              CALL XREADI(DX(K),IXM,L,V1(IRECOD),ENDF,IOERR,V2(IRECOD),
     .          IX(KV),V1(IRECOD+2))
            ELSE IF(V3(IRECOD+2).EQ.4) THEN
              CALL XREADR(DX(K),RXM,L,V1(IRECOD),ENDF,IOERR,V2(IRECOD),
     .          IX(KV),V1(IRECOD+2))
            ELSE IF(V3(IRECOD+2).EQ.5) THEN
              CALL XREADD(DX(K),L,V1(IRECOD),ENDF,IOERR,V2(IRECOD),
     .          IX(KV),V1(IRECOD+2))
            END IF
          END IF
C
C  If error on read, then
C    1) If primary file, set ENDF12=.TRUE., but terminate immediately
C       if no valid records have been read.
C    2) If secondary file, terminate unless ENDF12
C
          IF(IOERR) THEN
            IF(IRC.EQ.40) THEN
              WRITE(U6,102)V2(IRECOD)
              ENDF12=.TRUE.
              IF(V2(IRECOD).EQ.0) THEN
                CALL FESTOP(35002)
              END IF
            ELSE
              WRITE(U6,104)V1(IRECOD),V2(IRECOD)
              IF(.NOT.ENDF12) THEN
                CALL FESTOP(35003)
              END IF
            END IF
            V2(IRECOD)=-1
            GO TO 16
C
C  On end of file:
C    1) If primary file, set ENDF12=.TRUE., but terminate immediately
C       if no valid records have been read.
C    2) If secondary file, terminate under LINK unless ENDF12
C
          ELSE IF(ENDF) THEN
            IF(IRC.EQ.40) THEN
              IF(V2(IRECOD).EQ.0) THEN
                WRITE(U6,209)
                CALL FESTOP(35004)
              ELSE
                IF(U5ECHO.GT.0) THEN
                  WRITE(U6,101)V2(IRECOD)
                END IF
                ENDF12=.TRUE.
              END IF
            ELSE
              IF((RSTPNT(IRECOD).EQ.0.OR.IRC.EQ.41).AND.KF.EQ.0.AND.
     .             .NOT.ENDF12) THEN
                WRITE(U6,206)V1(IRECOD),V2(IRECOD)
                CALL FESTOP(35005)
              ELSE IF(U5ECHO.GT.0) THEN
                WRITE(U6,103)V1(IRECOD),V2(IRECOD)
              END IF
            END IF
            V2(IRECOD)=-1
            GO TO 16
          ELSE IF(ENDF12) THEN
            WRITE(U6,105)V1(IRECOD),V2(IRECOD)
            GO TO 16
          END IF
C
C  Check that matching keys have increased under LINK or LINK_MISSING
C
          IF((IRC.EQ.41.OR.IRC.EQ.42).AND.RSTPNT(IRECOD).GT.0) THEN
            IF(V2(IRECOD).GT.0) THEN
              J=IRECOD+3
              DO 10 KK=1,RSTPNT(IRECOD)
              DIFFID=DX(V1(J))-DX(V3(J))
              IF(DIFFID.LT.-.1D-03) THEN
                GO TO 11
              ELSE IF(DIFFID.GT..1D-03) THEN
C
C  Transfer to 14 when keys have increased on file.
C
                GO TO 14
              END IF
              J=J+1
   10         CONTINUE
   11         CONTINUE
              KK=V2(IRECOD)+1
              WRITE(U6,204)V1(IRECOD),KK
              J=IRECOD+3
              DO 12 KK=1,RSTPNT(IRECOD)
              WRITE(U6,202)VNAME(RSTPNT(J)),DX(V1(J))
              J=J+1
   12         CONTINUE
              WRITE(U6,205)V1(IRECOD),V2(IRECOD)
              J=IRECOD+3
              DO 13 K=1,RSTPNT(IRECOD)
              WRITE(U6,202)VNAME(RSTPNT(J)),DX(V3(J))
              J=J+1
   13         CONTINUE
              CALL FESTOP(35006)
   14         CONTINUE
            END IF
C
C  Copy values of key variables for this record to cells to hold
C  values of keys for previous record
C
            J=IRECOD+3
            DO 15 KK=1,RSTPNT(IRECOD)
            DX(V3(J))=DX(V1(J))
            J=J+1
   15       CONTINUE
            V2(IRECOD)=V2(IRECOD)+1
            GO TO 3
          END IF
C
C  When get to here, new record has been succesfully processed, so
C  increase record count.
C
          V2(IRECOD)=V2(IRECOD)+1
        END IF
   16   CONTINUE
        IF(.NOT.ENDF12) THEN
C
C  Storage of incoming data before end of file
C
          IF(V2(IRECOD).GT.0) THEN
            IF(IRC.EQ.42) THEN
              DO 17 KV=V1(IRECOD+1),V1(IRECOD+1)+L-1
              I=IX(KV)
              DX(VMAPL(I))=DX(K)
              DX(VMAPL(I)+1)=1.0D0
              K=K+1
   17         CONTINUE
            ELSE
              DO 18 KV=V1(IRECOD+1),V1(IRECOD+1)+L-1
              I=IX(KV)
              DX(VMAPL(I))=DX(K)
              K=K+1
   18         CONTINUE
            END IF
          ELSE
C
C  Store missing under LINK_MISSING if at end of file.
C
            IF(KF.GT.0) THEN
              DX(VMAPL(KF))=0.
            END IF
            DO 20 KV=V1(IRECOD+1),V1(IRECOD+1)+L-1
            II=IX(KV)
            DX(VMAPL(II))=0.
            IF(IRC.EQ.42) THEN
              DX(VMAPL(II)+1)=0.
            END IF
   20       CONTINUE
          END IF
        END IF
        IRECOD=IRECOD+2+RSTPNT(IRECOD)
        GO TO 1
      END IF
C
C    50  =  add, 0 replicate,      using vplxin data
C               v1        v2        v3        rstpnt
C             1st op   target   vplxin v     #classes
C          for each class:
C               v1        v2        v3        rstpnt
C            class/cat           0 offset    increment
C
C    51  =  subtract, 0 replicate   using vplxin data
C    52  =  multiply, 0 replicate       "
C    53  =  divide, 0 replicate         "
C    54  =  add loop to replicate weights/factors, using vplxin
C               v1        v2        v3        rstpnt
C             1st rf/rw  # rf/rw  vplxin var  #classes
C          for each class:
C               v1        v2        v3        rstpnt
C            class/cat           0 offset    increment
C
C    55  =  subtract loop to replicate weights/factors, using vplxin
C    56  =  multiply loop            "                       "
C    57  =  divide   loop            "                       "
C
 
      IF(IRC.GE.50.AND.IRC.LE.57) THEN
        IV1=V1(IRECOD)
        JV1=VMAPL(IV1)
        IF(IRC.LE.53) THEN
          IV2=V2(IRECOD)
          JV2=VMAPL(IV2)
          MTYPE(IV2)=MTYPE(IV1)
        ELSE
          NV=V2(IRECOD)
          MT=JV1-SDRFW+1
          JV2=JV1
        END IF
C
C  calculate the location in the VPLXIN file of the matching factor.
C
        JV3=VMAPL(V3(IRECOD))+SDVPIN-1
        K=RSTPNT(IRECOD)
        IF(K.GT.0) THEN
          DO 301 I=1,K
          IRECOD=IRECOD+1
          JV1A=VMAPL(V1(IRECOD))
          INDX=DX(JV1A)+.05
          IF(INDX.EQ.0) THEN
            JV3=0
          ELSE IF(JV3.GT.0) THEN
            IF(V3(IRECOD).EQ.1) THEN
              JV3=JV3+RSTPNT(IRECOD)*INDX
            ELSE
              JV3=JV3+RSTPNT(IRECOD)*(INDX-1)
            END IF
          END IF
  301     CONTINUE
C
C  If one or more indices are out of range, do nothing.
C  Note: transfer to 1 is delayed until this point to leave
C  IRECOD at the correct value.
C
          IF(JV3.EQ.0)GO TO 1
        END IF
C
C  Placement of this transfer insures that IRECOD has been
C  incremented correctly.
C
        IF(ENDF12)GO TO 1
        IF(IRC.GT.53) THEN
C
C  MT is the index of the first replicate weight/factor to be operated on.
C
          IF(MT.GT.IREPL) THEN
            IF(MT.GT.IREPH)GO TO 1
            I=MT
            JV3=JV3+TSIZE*(I-IREPL+1)
          ELSE
            I=IREPL
            JV1=JV1+IREPL-MT
            JV2=JV1
C
C  Since we are starting at IREPL, the first element we need to use is
C  we need to use is stored just beyond the full sample matrix.
C
            JV3=JV3+TSIZE
          END IF
C
C  Figure out the stopping index K.
C
          IF(MT+NV-1.LT.IREPH) THEN
            IF(MT+NV-1.LT.IREPL)GO TO 1
            K=MT+NV-1
          ELSE
            K=IREPH
          END IF
        END IF
  302   CONTINUE
        IF(DABS(DX(JV3)-MISSNG).LE..1D-6) THEN
          DX(JV2)=0.
        ELSE IF(IRC.EQ.50.OR.IRC.EQ.54) THEN
          DX(JV2)=DX(JV1)+DX(JV3)
        ELSE IF(IRC.EQ.51.OR.IRC.EQ.55) THEN
          DX(JV2)=DX(JV1)-DX(JV3)
        ELSE IF(IRC.EQ.52.OR.IRC.EQ.56) THEN
          DX(JV2)=DX(JV1)*DX(JV3)
        ELSE
          DX(JV2)=DX(JV1)/DX(JV3)
        END IF
        IF(IRC.LE.53)GO TO 1
        I=I+1
        IF(I.GT.K)GO TO 1
        JV3=JV3+TSIZE
        JV2=JV2+1
        JV1=JV1+1
        GO TO 302
      ELSE IF(IRC.EQ.58.OR.IRC.EQ.61) THEN
        IV1=V1(IRECOD)
        JV1=VMAPL(IV1)
        NV=V2(IRECOD)
        JK=RSTPNT(IRECOD)
        IF(V3(IRECOD).GT.0) THEN
          K=VMAPL(V3(IRECOD))
          XV3=DX(K)
        ELSE
          XV3=1.D0
        END IF
        IF(IRC.EQ.58) THEN
          JV2=SDVID
          DO 313 I=1,NV
          IF(I.GE.IREPL.AND.I.LE.IREPH) THEN
            JV2=JV2+NIDTOT
            DX(JV1)=DX(JV2+NID)
            IF(VFTYPE.LE.32) THEN
              DO 311 J=1,JK
              KK=VMAPL(V1(IRECOD+J))
              IF(DABS(DX(KK)-DX(JV2+J-1)).GT..1D-3)GO TO 312
              DX(JV1)=DX(JV2+NID+J)
  311         CONTINUE
  312         CONTINUE
            ELSE
              KK=VMAPL(V1(IRECOD+1))
              IF(DX(KK)-DX(JV2+NID+1).GT.-.1D-03.AND.
     .           DX(JV2+NID+2)-DX(KK).GT.-.1D-03) THEN
                DX(JV1)=DX(JV2+NID+3)
                IF(VFTYPE.EQ.35.OR.VFTYPE.EQ.36) THEN
                  IF(DX(KK)-DX(JV2+NID+4).GT.-1.D-03.AND.
     .               DX(JV2+NID+5)-DX(KK).GT.-1.D-03) THEN
                    DX(JV1)=DX(JV2+NID+6)
                  END IF
                END IF
                IF(DABS(DX(JV2)-DX(KK)).LT..1D-03) THEN
                  DX(JV1)=DX(JV2+NIDTOT-1)
                END IF
              END IF
            END IF
          ELSE
            DX(JV1)=1.D0
          END IF
          DX(JV1)=DX(JV1)*XV3
          JV1=JV1+1
  313     CONTINUE
        ELSE
C                                            ! IRC = 61
          DO 321 I=1,NV
          DX(JV1+I-1)=1.D0
  321     CONTINUE
          DO 325 J=1,JK
          KK=VMAPL(V1(IRECOD+J))
          IF(ICHECK(DX(KK),XV1)) THEN
            KK=XV1
            IF(KK.GT.0) THEN
              KK=KK-(KK/NHADAM)*NHADAM
              IF(KK.EQ.0)KK=NHADAM
              KK=NHADAM*(KK-1)+SDHADM
              IF(V2(IRECOD+J).NE.0) THEN
                JV3=VMAPL(V2(IRECOD+J))
                XV1=DX(JV3)
              ELSE
                XV1=1.0D0
              END IF
              DO 322 JV3=1,NHADAM
              DX(JV1+JV3-1)=DX(JV1+JV3-1)+XV1*DX(KK)
              KK=KK+1
  322         CONTINUE
            END IF
          ELSE
            WRITE(U6,210)DX(KK)
            CALL FESTOP(35009)
          END IF
  325     CONTINUE
          IF(DABS(XV3-1.D0).GT..1D-12) THEN
            DO 326 I=1,NHADAM
            DX(JV1+I-1)=XV3*DX(JV1+I-1)
  326       CONTINUE
          END IF
        END IF
        IRECOD=IRECOD+JK
        GO TO 1
      ELSE IF(IRC.EQ.47) THEN
        IF(ENDF12)GO TO 1
        IF(METHOD.NE.1) THEN
          IF(METHOD.EQ.2.AND.IPASS.EQ.NPASS) THEN
            K=SDRFW
            DO 314 I=1,NFILES
            J=12+I
            CALL UNFIN(J,DX(K),NMAX,ENDF)
            K=K+NMAX
  314       CONTINUE
          ELSE IF(METHOD.EQ.3) THEN
            IF(IPASS.LT.NPASS) THEN
              IF(IFILE.LT.12+NFILES) THEN
                K=SDRFW+IREPL-1-NMAX
                J=NMAX
                DO 315 I=12+NFILES,IFILE+1,-1
                CALL UNFIN(I,DX(K),J,ENDF)
                J=J*2
                K=K-J
  315           CONTINUE
              END IF
            ELSE
              J=IPASS-1
              K=SDRFW
              N=2**(NFILES-1)
              DO 316 I=13,12+NFILES
              IF(J.GE.N) THEN
                NN=N*NMAX
                CALL UNFIN(I,DX(K),NN,ENDF)
                J=J-N
                K=K+NN
              END IF
              N=N/2
  316         CONTINUE
            END IF
          END IF
        END IF
        IF(IPASS.EQ.NPASS) THEN
          J=SDOUTP
          N=V1(IRECOD)
          JJ=V2(IRECOD)
          IUNIT=IX(JJ)
          JJ=JJ+1
          IOUTFV=IX(JJ)
          DO 304 I=1,N
          JJ=JJ+1
          DX(J)=DX(IX(JJ))
          J=J+1
  304     CONTINUE
          IF(IOUTFV.LE.2) THEN
            CALL XWRITE(DX(SDOUTP),N,INFRMT(V3(IRECOD)),
     .          RSTPNT(IRECOD),IUNIT)
          ELSE IF(IOUTFV.EQ.3) THEN
            CALL XWRITI(DX(SDOUTP),IXM,N,IUNIT)
          ELSE IF(IOUTFV.EQ.4) THEN
            CALL XWRITR(DX(SDOUTP),RXM,N,IUNIT)
          ELSE IF(IOUTFV.EQ.5) THEN
            CALL XWRITD(DX(SDOUTP),N,IUNIT)
          END IF
        ELSE
          CALL UNFOUT(IFILE,DX(SDROUT),NROUT)
        END IF
        GO TO 1
      ELSE IF(IRC.EQ.60) THEN
        LL=RSTPNT(IRECOD)
        IF(ENDF12) THEN
          IRECOD=IRECOD+LL
          GO TO 1
        END IF
        L=IRECOD
  305   CONTINUE
        IRECOD=L
        DO 310 I=1,LL
        IRECOD=IRECOD+1
        VBY=DX(SDVID+RSTPNT(IRECOD)-1)
        XV3=DX(VMAPL(V1(IRECOD)))
        IF(VBY+.1D-3.LT.XV3) THEN
          K=SDVID-1
          KK=SDVPIN
          IF(IREPH.LT.NRPTOT) THEN
            DO 306 J=IREPH+1,NRPTOT
            READ(10,END=98)(DX(K+JJ),JJ=1,NIDTOT)
            CALL UNFIN(10,DX(KK),TSIZE,ENDF)
            IF(ENDF)GO TO 98
  306       CONTINUE
          END IF
          READ(10,END=98)(DX(K+JJ),JJ=1,NIDTOT)
          CALL UNFIN(10,DX(KK),TSIZE,ENDF)
          IF(ENDF)GO TO 98
          K=K+NIDTOT
          KK=KK+TSIZE
          IF(IREPL.GT.1) THEN
            DO 307 J=1,IREPL-1
            READ(10,END=98)(DX(K+JJ),JJ=1,NIDTOT)
            CALL UNFIN(10,DX(KK),TSIZE,ENDF)
            IF(ENDF)GO TO 98
  307       CONTINUE
          END IF
          DO 308 J=IREPL,IREPH
          READ(10,END=98)(DX(K+JJ),JJ=1,NIDTOT)
          CALL UNFIN(10,DX(KK),TSIZE,ENDF)
          IF(ENDF)GO TO 98
          K=K+NIDTOT
          KK=KK+TSIZE
  308     CONTINUE
          GO TO 305
        ELSE IF(VBY-.1D-3.GT.XV3) THEN
          WRITE(U6,208)
          IRECOD=L
          DO 309 J=1,LL
          IRECOD=IRECOD+1
          VBY=DX(SDVID+RSTPNT(IRECOD)-1)
          XV3=DX(VMAPL(V1(IRECOD)))
          WRITE(U6,212)VNAME(V1(IRECOD)),XV3,VBY
  309     CONTINUE
          CALL FESTOP(35008)
        END IF
  310   CONTINUE
        GO TO 1
   98   CONTINUE
        WRITE(U6,213)
        IRECOD=L
        DO 331 J=1,LL
        IRECOD=IRECOD+1
        XV3=DX(VMAPL(V1(IRECOD)))
        WRITE(U6,202)VNAME(V1(IRECOD)),XV3
  331   CONTINUE
        CALL FESTOP(35007)
      END IF
      IF(ENDF12)GO TO 1
      IV1=V1(IRECOD)
      IV2=V2(IRECOD)
C
C  ADD/SUBTRACT/MULTIPLY/DIVIDE loops for replicate factors/weights
C
      IF(IRC.GE.43.AND.IRC.LE.46) THEN
        IV3=V3(IRECOD)
        JV3=VMAPL(IV3)
        XV3=DX(JV3)
        JV1=VMAPL(IV1)
        IF(IRC.EQ.43) THEN
          DO 25 I=1,IV2
          DX(JV1)=DX(JV1)+XV3
          JV1=JV1+1
   25     CONTINUE
        ELSE IF(IRC.EQ.44) THEN
          DO 26 I=1,IV2
          DX(JV1)=DX(JV1)-XV3
          JV1=JV1+1
   26     CONTINUE
        ELSE IF(IRC.EQ.45) THEN
          DO 27 I=1,IV2
          DX(JV1)=DX(JV1)*XV3
          JV1=JV1+1
   27     CONTINUE
        ELSE
          DO 28 I=1,IV2
          IF(XV3.NE.0.) THEN
            DX(JV1)=DX(JV1)/XV3
          ELSE
            DX(JV1)=0.
          END IF
          JV1=JV1+1
   28     CONTINUE
        END IF
        GO TO 1
      ELSE IF(IRC.EQ.62) THEN
C
C    62  =  idchange to return 1 if change in variables
C               v1        v2        v3        rstpnt
C               0     idchange       0         # keys
C           for each key:
C               0      match v    pointer to   var # of match v
C                                 last value
C
        JV2=VMAPL(IV2)
        DX(JV2)=0.
        MSIZE(IV2)=1
        MTYPE(IV2)=1
        DO 292 I=1,RSTPNT(IRECOD)
        IV1=V2(IRECOD+I)
        IF(DABS(DX(VMAPL(IV1))-DX(V3(IRECOD+I))).GT..1D-3) THEN
          DX(JV2)=1.
          DO 291 II=1,RSTPNT(IRECOD)
          DX(V3(IRECOD+II))=DX(VMAPL(V2(IRECOD+II)))
  291     CONTINUE
          GO TO 293
        END IF
  292   CONTINUE
  293   CONTINUE
        IRECOD=IRECOD+RSTPNT(IRECOD)
        GO TO 1
C
C  PRINT
C
C    63 =   print
C               v1        v2        v3        rstpnt
C             # print   #obs     # list       # pointer to IX
C             # request
C
      ELSE IF(IRC.EQ.63.OR.IRC.EQ.64) THEN
        V2(IRECOD)=IV2+1
        IF(IV1.EQ.0.OR.IV1.GT.IV2) THEN
          WRITE(U6,221)V1(IRECOD+1)
          K=RSTPNT(IRECOD)
          IF(IRC.EQ.63) THEN
            DO 294 I=1,V3(IRECOD)
            IV1=IX(K)
            MT1=MTYPE(IV1)
            JV1=VMAPL(IV1)
            IF(MT1.EQ.1.OR.MT1.GE.10) THEN
              WRITE(U6,222)VNAME(IV1),DX(JV1)
            ELSE IF(MT1.EQ.2) THEN
              IF(DX(JV1+1).NE.0.) THEN
                WRITE(U6,222)VNAME(IV1),DX(JV1)
              ELSE
                WRITE(U6,223)VNAME(IV1)
              END IF
            ELSE IF(MT1.EQ.3) THEN
              WRITE(U6,224)VNAME(IV1),DX(JV1)
            ELSE IF(MT1.EQ.4) THEN
              WRITE(U6,225)VNAME(IV1),DX(JV1)
            ELSE IF(MT.EQ.8) THEN
              WRITE(U6,222)VNAME(IV1),DX(JV1),DX(JV1+1)
            ELSE IF(MT.EQ.9) THEN
              WRITE(U6,226)VNAME(IV1),DX(JV1)
            END IF
            K=K+1
  294       CONTINUE
          ELSE
            DO 295 I=1,V3(IRECOD),2
            IV1=IX(K)
            JV1=VMAPL(IV1)
            IF(I.EQ.V3(IRECOD)) THEN
              WRITE(U6,230)VNAME(IV1),DX(JV1)
            ELSE
              IV2=IX(K+1)
              JV2=VMAPL(IV2)
              WRITE(U6,230)VNAME(IV1),DX(JV1),VNAME(IV2),DX(JV2)
            END IF
            K=K+2
  295       CONTINUE
          END IF
        END IF
        IRECOD=IRECOD+1
        GO TO 1
      END IF
      JV2=VMAPL(IV2)
      IF(IRC.EQ.34) THEN
        DX(JV2)=DX(IV1)
        MTYPE(IV2)=1
        MSIZE(IV2)=1
        GO TO 1
      END IF
      JV1=VMAPL(IV1)
      MT1=MTYPE(IV1)
      XV1=DX(JV1)
      IF(IRC.NE.7.AND.IRC.NE.35) THEN
        IV3=V3(IRECOD)
        JV3=VMAPL(IV3)
        XV3=DX(JV3)
        MT3=MTYPE(IV3)
      ELSE
        JV3=JV1
        XV3=XV1
        IV3=IV1
        MT3=MT1
      END IF
      IF(IRC.EQ.8.OR.IRC.EQ.9) THEN
        IX3=XV3
        IF(IX3.EQ.0) GO TO 33
        IF(MT1.EQ.2.OR.MT1.EQ.8) THEN
          IF(DX(JV1+1).EQ.0.) GO TO 33
        ELSE IF(MT1.EQ.3.OR.MT1.EQ.4.OR.MT1.EQ.9)
     .      THEN
          IF(XV1.EQ.0.) GO TO 33
        END IF
        IF(IRC.EQ.8) THEN
          DX(JV2)=XV1
          IF(MT1.EQ.1.OR.MT1.EQ.2) THEN
            DX(JV2+1)=IX3
          ELSE
            IX1=DX(JV1+1)
            DX(JV2+1)=(IX3-1)*(MSIZE(IV1)/2)+IX1
          END IF
        ELSE
          IX1=XV1
          DX(JV2)=(IX3-1)*MSIZE(IV1)+IX1
        END IF
        GO TO 34
   33   CONTINUE
        DX(JV2)=0.
        IF(IRC.EQ.8)DX(JV2+1)=0.
   34   CONTINUE
        IF(IRC.EQ.9.OR.MT1.EQ.8) THEN
          MSIZE(IV2)=MSIZE(IV1)*MSIZE(IV3)
        ELSE
          MSIZE(IV2)=2*MSIZE(IV3)
        END IF
        MTYPE(IV2)=IRC
      ELSE IF(IRC.GE.26.AND.IRC.LE.33) THEN
        KFLAG=0
        KFLAG1=0
        KFLAG2=0
        IF(MT1.NE.1) THEN
          KFLAG=1
          IF(DX(JV1+1).EQ.0.)KFLAG1=1
          IF(IRC.LT.30) THEN
            DX(JV2+1)=DX(JV1+1)
          END IF
        END IF
        IF(MT3.NE.1) THEN
          KFLAG=1
          IF(DX(JV3+1).EQ.0.)KFLAG2=1
        END IF
        IF(IRC.EQ.29.OR.IRC.EQ.33) THEN
          KFLAG=1
          IF(XV3.EQ.0.)KFLAG2=1
        END IF
        IF(IRC.GE.30) THEN
          MTYPE(IV2)=1
          MSIZE(IV2)=1
        ELSE IF(MT1.EQ.1.AND.KFLAG.EQ.1) THEN
          MTYPE(IV2)=2
          MSIZE(IV2)=2
          DX(JV2+1)=1.D0
        ELSE
          MTYPE(IV2)=MT1
          MSIZE(IV2)=MSIZE(IV1)
        END IF
        IF(IRC.LE.29) THEN
          IF(KFLAG1.EQ.1.OR.KFLAG2.EQ.1) THEN
            DX(JV2)=0.
            DX(JV2+1)=0.
          ELSE IF(IRC.EQ.26) THEN
            DX(JV2)=XV1+XV3
          ELSE IF(IRC.EQ.27) THEN
            DX(JV2)=XV1-XV3
          ELSE IF(IRC.EQ.28) THEN
            DX(JV2)=XV1*XV3
          ELSE
            DX(JV2)=XV1/XV3
          END IF
        ELSE
          IF(KFLAG1.EQ.1.AND.KFLAG2.EQ.1) THEN
            IF(IRC.EQ.32) THEN
              DX(JV2)=1.D0
            ELSE
              DX(JV2)=0.
            END IF
          ELSE IF(KFLAG1.EQ.1) THEN
            IF(IRC.EQ.30.OR.IRC.EQ.32) THEN
              DX(JV2)=XV3
            ELSE IF(IRC.EQ.31) THEN
              DX(JV2)=-XV3
            ELSE
              DX(JV2)=0.
            END IF
          ELSE IF(KFLAG2.EQ.1) THEN
            IF(IRC.EQ.33) THEN
              DX(JV2)=0.
            ELSE
              DX(JV2)=XV1
            END IF
          ELSE IF(IRC.EQ.30) THEN
            DX(JV2)=XV1+XV3
          ELSE IF(IRC.EQ.31) THEN
            DX(JV2)=XV1-XV3
          ELSE IF(IRC.EQ.32) THEN
            DX(JV2)=XV1*XV3
          ELSE
            DX(JV2)=XV1/XV3
          END IF
        END IF
      ELSE IF(IRC.EQ.23.OR.IRC.EQ.24) THEN
        KFLAG1=1
        KFLAG2=1
        IF(XV1.EQ.0.) THEN
          KFLAG1=0
        ELSE IF(MT1.NE.1) THEN
          IF(DX(JV1+1).EQ.0.)KFLAG1=0
        END IF
        IF(XV3.EQ.0.) THEN
          KFLAG2=0
        ELSE IF(MT3.NE.1) THEN
          IF(DX(JV3+1).EQ.0.)KFLAG1=0
        END IF
        MSIZE(IV2)=1
        MTYPE(IV2)=1
        IF(IRC.EQ.23) THEN
          IF(KFLAG1+KFLAG2.EQ.2) THEN
            DX(JV2)=1.D0
          ELSE
            DX(JV2)=0.
          END IF
        ELSE
          IF(KFLAG1+KFLAG2.GE.1) THEN
            DX(JV2)=1.D0
          ELSE
            DX(JV2)=0.
          END IF
        END IF
      ELSE IF(IRC.EQ.22.OR.IRC.EQ.25) THEN
        KFLAG1=1
        IF(XV1.EQ.0.) THEN
          KFLAG1=0
        ELSE IF(MT1.EQ.2.OR.MT1.EQ.8) THEN
          IF(DX(JV1+1).EQ.0.)KFLAG1=0
        END IF
        MTYPE(IV2)=1
        MSIZE(IV2)=1
        IF(IRC.EQ.22) THEN
          IF(KFLAG1.EQ.1) THEN
            DX(JV2)=1.D0
          ELSE
            DX(JV2)=0.
          END IF
        ELSE
          IF(KFLAG1.EQ.1) THEN
            DX(JV2)=0.
          ELSE
            DX(JV2)=1.D0
          END IF
        END IF
      ELSE IF(IRC.NE.10) THEN
        IRNSET=RSTPNT(IRECOD)
        IF(IRNSET.EQ.0) THEN
          IF(MT3.EQ.2.OR.MT3.EQ.8) THEN
            IF(DX(JV3+1).EQ.0) GO TO 36
          ELSE IF(MT3.EQ.3.OR.MT3.EQ.4.OR.MT3.EQ.9) THEN
            IF(XV3.EQ.0) GO TO 36
          END IF
          IF(XV3.EQ.0.) GO TO 36
          IF(MT3.EQ.2.OR.MT3.EQ.8) THEN
            IF(DX(JV3+1).EQ.0.)GO TO 36
          END IF
          GO TO 365
        ELSE
          IRNGPT=RNGPNT(IRNSET)
          INRNG=NRNG(IRNSET)
C
C  Range type
C  1  value1 - value2
C  2  LOW - value
C  3  value - HIGH
C  4  LOW - HIGH
C  5  MISSING
C  6  value - n
C
          DO 35 I=IRNGPT,IRNGPT+INRNG-1
          IF(RTYPE(I).EQ.5) THEN
            IF(MT3.EQ.2.OR.MT3.EQ.8) THEN
              IF(DX(JV3+1).NE.0) GO TO 35
            ELSE IF(MT3.EQ.3.OR.MT3.EQ.4.OR.MT3.EQ.9) THEN
              IF(XV3.NE.0) GO TO 35
            ELSE
              GO TO 35
            END IF
          ELSE
            IF(MT3.EQ.3.OR.MT3.EQ.4.OR.MT3.EQ.9) THEN
              IF(XV3.EQ.0) GO TO 35
            END IF
            IF(RTYPE(I).EQ.1) THEN
              IF(XV3.LT.RANGE(1,I).OR.XV3.GT.RANGE(2,I)) GO TO 35
            ELSE IF(RTYPE(I).EQ.2) THEN
              IF(XV3.GT.RANGE(2,I)) GO TO 35
            ELSE IF(RTYPE(I).EQ.3) THEN
              IF(XV3.LT.RANGE(1,I)) GO TO 35
            END IF
          END IF
          GO TO 365
   35     CONTINUE
        END IF
   36   CONTINUE
        IF(IRC.EQ.2) THEN
          DX(JV2)=XV1
          IF(MT1.EQ.1) THEN
            DX(JV2+1)=1.0D0
          ELSE IF(MT1.EQ.2.OR.MT1.EQ.8) THEN
            DX(JV2+1)=DX(JV1+1)
          END IF
        ELSE IF(IRC.EQ.3.OR.IRC.EQ.4) THEN
          DX(JV2)=0.
        ELSE IF(IRC.EQ.21) THEN
          DX(JV2)=0.
        ELSE IF(IRC.EQ.35) THEN
          IRECOD=V3(IRECOD)
          GO TO 2
        ELSE
          IF(V3(IRECOD).EQ.1) THEN
            IXDROP=.TRUE.
          ELSE
            DX(BLXSTR(V3(IRECOD))+SDVIN-1)=0.
          END IF
        END IF
        GO TO 37
  365   CONTINUE
        IF(IRC.EQ.2) THEN
          DX(JV2)=0.
          IF(MT1.LE.2.OR.MT1.EQ.8)DX(JV2+1)=0.
        ELSE IF(IRC.EQ.3.OR.IRC.EQ.4) THEN
          DX(JV2)=RGROUP(I)
        ELSE IF(IRC.EQ.21) THEN
          DX(JV2)=1.0D0
        END IF
   37   CONTINUE
        IF(IRC.EQ.2.AND.MT1.EQ.1) THEN
          MSIZE(IV2)=2
          MTYPE(IV2)=2
        ELSE IF(IRC.EQ.2) THEN
          MSIZE(IV2)=MSIZE(IV1)
          MTYPE(IV2)=MTYPE(IV1)
        ELSE IF(IRC.EQ.3.OR.IRC.EQ.4) THEN
          MSIZE(IV2)=RGROUP(IRNGPT+INRNG-1)
          MTYPE(IV2)=IRC
        ELSE IF(IRC.EQ.21) THEN
          MSIZE(IV2)=1
          MTYPE(IV2)=1
        END IF
      ELSE
        MSIZE(IV2)=MSIZE(IV1)
        MTYPE(IV2)=MT1
        DO 38 I=1,MSIZE(IV2)
        DX(I+JV2-1)=DX(I+JV1-1)
   38   CONTINUE
      END IF
      GO TO 1
      END
      SUBROUTINE XREAD(DXM,N,IUNIT,INF,NFMT,ENDF12,IOERR,NPREV,NVLIST,
     . NPRINT)
C
      INTEGER N,IUNIT,NPREV,NPRINT
      INTEGER NVLIST(N)
      DOUBLE PRECISION DXM(N)
      LOGICAL ENDF12,IOERR
      CHARACTER*128 INF(NFMT)
C
C  DXM    - output matrix,
C  N      - number of items in DXM
C  IUNIT  - input unit number.
C  IFLOW  - starting element of format in INFRMT
C  NFMT   - number of lines in this format (128 char/line)
C  ENDF12 - end of input on unit 12.
C  IOERR  - error flag
C  NPREV  - previous observation number
C  NVLIST - list of variables to read
C  NPRINT - number to print
C
      PARAMETER (MVAR=10000)
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
  100 FORMAT(/,' Observation',I6,' from unit',I3)
  101 FORMAT(6X,A12,F14.4,10X,A12,F14.4)
  102 FORMAT(' (Printing discontinued on unit',I3,')')
C
      ENDF12=.FALSE.
      IOERR=.FALSE.
C
C  Different versions to handle different options on storage of
C  format.
C
      READ(UNIT=IUNIT,FMT=INF,END=10,ERR=20)DXM
      IF(NPREV+1.LE.NPRINT) THEN
        I=NPREV+1
        IF(U5ECHO.GT.0) THEN
          WRITE(U6,100)I,IUNIT
          DO 5 I=1,N,2
          J1=NVLIST(I)
          IF(I.EQ.N) THEN
            WRITE(U6,101)VNAME(J1),DXM(I)
          ELSE
            J2=NVLIST(I+1)
            WRITE(U6,101)VNAME(J1),DXM(I),VNAME(J2),DXM(I+1)
          END IF
    5     CONTINUE
        END IF
        IF(NPREV+1.EQ.NPRINT) THEN
          IF(U5ECHO.GT.0)WRITE(U6,102)IUNIT
        END IF
      END IF
      RETURN
   10 CONTINUE
      ENDF12=.TRUE.
      RETURN
   20 CONTINUE
      IOERR=.TRUE.
      RETURN
      END
C
      SUBROUTINE XREAD1(DXM,N,IUNIT,INF,ENDF12,IOERR,NPREV,NVLIST,
     . NPRINT)
C
      INTEGER N,IUNIT,NPREV,NPRINT
      INTEGER NVLIST(N)
      DOUBLE PRECISION DXM(N)
      LOGICAL ENDF12,IOERR
      CHARACTER*128 INF
C
C  DXM    - output matrix,
C  N      - number of items in DXM
C  IUNIT  - input unit number.
C  IFLOW  - starting element of format in INFRMT
C  NFMT   - number of lines in this format (128 char/line)
C  ENDF12 - end of input on unit 12.
C  IOERR  - error flag
C  NPREV  - previous observation number
C  NVLIST - list of variables to read
C  NPRINT - number to print
C
      PARAMETER (MVAR=10000)
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
  100 FORMAT(/,' Observation',I6,' from unit',I3)
  101 FORMAT(6X,A12,F14.4,10X,A12,F14.4)
  102 FORMAT(' (Printing discontinued on unit',I3,')')
C
      ENDF12=.FALSE.
      IOERR=.FALSE.
C
C  Different versions to handle different options on storage of
C  format.
C
      READ(UNIT=IUNIT,FMT=INF,END=10,ERR=20)DXM
      IF(NPREV+1.LE.NPRINT) THEN
        I=NPREV+1
        IF(U5ECHO.GT.0) THEN
          WRITE(U6,100)I,IUNIT
          DO 5 I=1,N,2
          J1=NVLIST(I)
          IF(I.EQ.N) THEN
            WRITE(U6,101)VNAME(J1),DXM(I)
          ELSE
            J2=NVLIST(I+1)
            WRITE(U6,101)VNAME(J1),DXM(I),VNAME(J2),DXM(I+1)
          END IF
    5     CONTINUE
        END IF
        IF(NPREV+1.EQ.NPRINT) THEN
          IF(U5ECHO.GT.0)WRITE(U6,102)IUNIT
        END IF
      END IF
      RETURN
   10 CONTINUE
      ENDF12=.TRUE.
      RETURN
   20 CONTINUE
      IOERR=.TRUE.
      RETURN
      END
C
      SUBROUTINE XREADD(DXM,N,IUNIT,ENDF12,IOERR,NPREV,NVLIST,
     . NPRINT)
C
      INTEGER N,IUNIT,NPREV,NPRINT
      INTEGER NVLIST(N)
      DOUBLE PRECISION DXM(N)
      LOGICAL ENDF12,IOERR
C
C  DXM    - output matrix,
C  IXM    - temporary storage for integers
C  N      - number of items in DXM
C  IUNIT  - input unit number.
C  ENDF12 - end of input on unit 12.
C  IOERR  - error flag
C  NPREV  - previous observation number
C  NV1ST  - pointer to first variable to read
C  NPRINT - number to print
C
      PARAMETER (MVAR=10000)
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
  100 FORMAT(/,' Observation',I6,' from unit',I3)
  101 FORMAT(6X,A12,F14.4,10X,A12,F14.4)
  102 FORMAT(' (Printing discontinued on unit',I3,')')
C
      ENDF12=.FALSE.
      IOERR=.FALSE.
C
C  Different versions to handle different options on storage of
C  format.
C
      READ(UNIT=IUNIT,END=10,ERR=20)DXM
      IF(NPREV+1.LE.NPRINT) THEN
        I=NPREV+1
        IF(U5ECHO.GT.0) THEN
          WRITE(U6,100)I,IUNIT
          DO 5 I=1,N,2
          J1=NVLIST(I)
          IF(I.EQ.N) THEN
            WRITE(U6,101)VNAME(J1),DXM(I)
          ELSE
            J2=NVLIST(I+1)
            WRITE(U6,101)VNAME(J1),DXM(I),VNAME(J2),DXM(I+1)
          END IF
    5     CONTINUE
        END IF
        IF(NPREV+1.EQ.NPRINT) THEN
          IF(U5ECHO.GT.0)WRITE(U6,102)IUNIT
        END IF
      END IF
      RETURN
   10 CONTINUE
      ENDF12=.TRUE.
      RETURN
   20 CONTINUE
      IOERR=.TRUE.
      RETURN
      END
C
      SUBROUTINE XREADI(DXM,IXM,N,IUNIT,ENDF12,IOERR,NPREV,NVLIST,
     . NPRINT)
C
      INTEGER N,IUNIT,NPREV,NPRINT
      INTEGER NVLIST(N)
      INTEGER IXM(N)
      DOUBLE PRECISION DXM(N)
      LOGICAL ENDF12,IOERR
C
C  DXM    - output matrix,
C  IXM    - temporary storage for integers
C  N      - number of items in DXM
C  IUNIT  - input unit number.
C  ENDF12 - end of input on unit 12.
C  IOERR  - error flag
C  NPREV  - previous observation number
C  NV1ST  - pointer to first variable to read
C  NPRINT - number to print
C
      PARAMETER (MVAR=10000)
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
  100 FORMAT(/,' Observation',I6,' from unit',I3)
  101 FORMAT(6X,A12,F14.4,10X,A12,F14.4)
  102 FORMAT(' (Printing discontinued on unit',I3,')')
C
      ENDF12=.FALSE.
      IOERR=.FALSE.
C
C  Different versions to handle different options on storage of
C  format.
C
      READ(UNIT=IUNIT,END=10,ERR=20)IXM
      DO 30 I=1,N
      DXM(I)=IXM(I)
   30 CONTINUE
      IF(NPREV+1.LE.NPRINT) THEN
        I=NPREV+1
        IF(U5ECHO.GT.0) THEN
          WRITE(U6,100)I,IUNIT
          DO 5 I=1,N,2
          J1=NVLIST(I)
          IF(I.EQ.N) THEN
            WRITE(U6,101)VNAME(J1),DXM(I)
          ELSE
            J2=NVLIST(I+1)
            WRITE(U6,101)VNAME(J1),DXM(I),VNAME(J2),DXM(I+1)
          END IF
    5     CONTINUE
        END IF
        IF(NPREV+1.EQ.NPRINT) THEN
          IF(U5ECHO.GT.0)WRITE(U6,102)IUNIT
        END IF
      END IF
      RETURN
   10 CONTINUE
      ENDF12=.TRUE.
      RETURN
   20 CONTINUE
      IOERR=.TRUE.
      RETURN
      END
C
      SUBROUTINE XREADR(DXM,RXM,N,IUNIT,ENDF12,IOERR,NPREV,NVLIST,
     . NPRINT)
C
      INTEGER N,IUNIT,NPREV,NPRINT
      INTEGER NVLIST(N)
      REAL RXM(N)
      DOUBLE PRECISION DXM(N)
      LOGICAL ENDF12,IOERR
C
C  DXM    - output matrix,
C  IXM    - temporary storage for integers
C  N      - number of items in DXM
C  IUNIT  - input unit number.
C  ENDF12 - end of input on unit 12.
C  IOERR  - error flag
C  NPREV  - previous observation number
C  NV1ST  - pointer to first variable to read
C  NPRINT - number to print
C
      PARAMETER (MVAR=10000)
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
  100 FORMAT(/,' Observation',I6,' from unit',I3)
  101 FORMAT(6X,A12,F14.4,10X,A12,F14.4)
  102 FORMAT(' (Printing discontinued on unit',I3,')')
C
      ENDF12=.FALSE.
      IOERR=.FALSE.
C
C  Different versions to handle different options on storage of
C  format.
C
      READ(UNIT=IUNIT,END=10,ERR=20)RXM
      DO 30 I=1,N
      DXM(I)=RXM(I)
   30 CONTINUE
      IF(NPREV+1.LE.NPRINT) THEN
        I=NPREV+1
        IF(U5ECHO.GT.0) THEN
          WRITE(U6,100)I,IUNIT
          DO 5 I=1,N,2
          J1=NVLIST(I)
          IF(I.EQ.N) THEN
            WRITE(U6,101)VNAME(J1),DXM(I)
          ELSE
            J2=NVLIST(I+1)
            WRITE(U6,101)VNAME(J1),DXM(I),VNAME(J2),DXM(I+1)
          END IF
    5     CONTINUE
        END IF
        IF(NPREV+1.EQ.NPRINT) THEN
          IF(U5ECHO.GT.0)WRITE(U6,102)IUNIT
        END IF
      END IF
      RETURN
   10 CONTINUE
      ENDF12=.TRUE.
      RETURN
   20 CONTINUE
      IOERR=.TRUE.
      RETURN
      END
C
      SUBROUTINE XWRITD(DXM,N,IUNIT)
C
      INTEGER N,IUNIT
      DOUBLE PRECISION DXM(N)
C
C  DXM   - array to write
C  N     - number of elements to write
C
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
C
      WRITE(UNIT=IUNIT,ERR=20)DXM
      RETURN
   20 CONTINUE
      IMERR1=90003
      CALL FWSTOP(IUNIT)
      END
C
      SUBROUTINE XWRITE(DXM,N,INF,NFMT,IUNIT)
C
      INTEGER N,NFMT,IUNIT
      DOUBLE PRECISION DXM(N)
      CHARACTER*128 INF(NFMT)
C
C  DXM   - array to write
C  N     - number of elements to write
C  INF   - format
C  NFMT  - number of lines of format
C
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
C
      WRITE(UNIT=IUNIT,FMT=INF,ERR=20)DXM
      RETURN
   20 CONTINUE
      IMERR1=90003
      CALL FWSTOP(IUNIT)
      END
C
      SUBROUTINE XWRITI(DXM,IXM,N,IUNIT)
C
      INTEGER N,IUNIT
      DOUBLE PRECISION DXM(N)
      INTEGER IXM(N)
C
C  DXM   - array to write
C  N     - number of elements to write
C
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
C
      DO 10 I=1,N
      IF(DXM(I).GE..5D0) THEN
        IXM(I)=DXM(I)+.5D0
      ELSE
        IXM(I)=DXM(I)-.5D0
      END IF
   10 CONTINUE
      WRITE(UNIT=IUNIT,ERR=20)IXM
      RETURN
   20 CONTINUE
      IMERR1=90003
      CALL FWSTOP(IUNIT)
      END
C
      SUBROUTINE XWRITR(DXM,RXM,N,IUNIT)
C
      INTEGER N,IUNIT
      DOUBLE PRECISION DXM(N)
      REAL RXM(N)
C
C  DXM   - array to write
C  N     - number of elements to write
C
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
C
      DO 10 I=1,N
      RXM(I)=DXM(I)
   10 CONTINUE
      WRITE(UNIT=IUNIT,ERR=20)RXM
      RETURN
   20 CONTINUE
      IMERR1=90003
      CALL FWSTOP(IUNIT)
      END
C
      SUBROUTINE RWGHT2
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (IXFLLD=3)
      PARAMETER (MAXFMT=20)
 
C
C  MVAR   represents the maximum number of incoming and created
C         variables, replicate factors and wts
C  MAXIDS is the maximum number of class variables
C  MRECOD is the maximum of variables transformed by CLASS, CAT
C         MISSING, SELECT, BY etc.
C  MRANGE is the maximum number of ranges
C  MRNSET is the maximum number of sets of ranges
C  MLEVEL is the maximum number of stored labels for levels
C  MCLBLK is the maximum number of class blocks
C  MCLBAR is the maximum number of cells of class block arrays
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
C
      LOGICAL REFRSH,ALPCHK,DGTCHK,ENDF12,ENDFLE,FOPEND
      EXTERNAL REFRSH,ALPCHK,DGTCHK
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1,
     . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX
C
      DOUBLE PRECISION RANGE(2,MRANGE)
      INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET),
     . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD),
     . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI)
C
      COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP,
     . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO,
     . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS,
     . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT,
     . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS,
     . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO,
     . NLEVEL,NRNSET,NRANGE,NHADAM,SDHADM,SDOUTP,SDVID,SDVPIN,IREPL,
     . IREPH,IFILE,SDRFW,IPASS,METHOD,NFILES,SDROUT,NROUT,NMAX,IXFILL,
     . SDSTCK,MSDPTH
      INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS,
     . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN,
     . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,SDHADM,SDOUTP,SDVID,
     . SDVPIN,SDRFW,SDROUT,IXFILL(IXFLLD),SDSTCK,MSDPTH
       LOGICAL IXDROP
C
C  Usage in this subroutine:
C
C  BLXSTR  -  Pointer for block to X matrix
C  BLVSTR  -  revised to become pointer to first variable in block
C  BLVSIZ  -  revised to number of variables in block
C  BLNCLS  -  number of class variables in block
C  BLCPNT  -  pointer for classes to CLTYPE
C  CLTYPE  -  used as pointers to class variables
C
  201 FORMAT(' MISMATCHING REPF/W')
  214 FORMAT(' COMBINATION OF REPLICATION SPECIFICATIONS NOT ALLOWED')
  216 FORMAT(' AMBIGUOUS NUMBER OF REPLICATES')
  220 FORMAT(' MISSING ONE OR MORE REPLICATES, INCLUDING',I6)
  221 FORMAT(/,5X,'PASSES REQUIRED:',I6)
  222 FORMAT(' INSUFFICIENT ROOM')
  223 FORMAT(/,5X,'Passes required:',I6,', using',I2,' scratch files')
C
      IF(IVERSN.EQ.9004)NIDTOT=NID
      IF(IWGT.EQ.0.AND.NOWGTF.EQ.0) THEN
        CALL VNMTCH('WEIGHT ',VNAME,NVIN,IWGT)
      END IF
      IF((IREPF.GT.0.OR.IREPW.GT.0).AND.NREPW.EQ.0) THEN
        NREPW=0
        DO 1 I=1,NVIN
        IF(MTYPE(I).GT.50+NREPW)NREPW=MTYPE(I)-50
    1   CONTINUE
        DO 3 J=1,NREPW
        DO 2 I=1,NVIN
        IF(MTYPE(I).EQ.50+J)GO TO 3
    2   CONTINUE
        WRITE(U6,220)J
        GO TO 99
    3   CONTINUE
        IF(NREPW.NE.NRPTOT) THEN
          WRITE(U6,201)
          GO TO 99
        END IF
      END IF
      IF(ICLCNT.GT.0.AND.ICLCNT.NE.NRPTOT) GO TO 98
C
C VFTYPE = 3  Weighted obs. with cluster/replicate number
C         4  Unweighted  "
C         5  Replicate weights
C         6  Unweighted initial obs. followed by replicate weights
C         7  Replicate factors multiplying initial weight
C         8  Replicate factors of unweighted initial obs ( = VFTYPE 6)
C        11  Replicate factors multiplying initial weight, including
C            factor for replicate 0, overall estimate
C        12  Unweighted initial obs  "  (= VFTYPE 5)
C        13  Weighted obs. with cluster code
C        14  Unweighted "
C        15  Weighted obs. Stratum no. cluster code
C        16  Unweighted "
C        17  Wtd.          Stratum code, cluster code
C        18  Unwtd      "
C        21  Wtd.      Stratum no. 2nd stage no, cluster code
C        22  Unwtd.     "
C        23  Wtd.      Stratum no. 2nd stage cd, cluster code
C        24  Unwtd.     "
C        25  Wtd.      Stratum code  2nd stage no. cluster code
C        26  Unwtd      "
C        27  Wtd.      Stratum code  2nd stage cd, cluster code
C        28  Unwtd.     "
C        29  Wtd       2nd stage number cluster code
C        30  Unwtd.     "
C        31  Wtd       2nd stage code  cluster code
C        32  Unwtd      "
C        33  Wtd       Replicate number governed by stratum counts
C        34  Unwtd      "
C        35  Wtd       Rep numb govrned by stratum and 2nd stage counts
C        36  Unwtd      "
C        37  Wtd       Rep number governed by 2nd stage counts
C        38  Unwtd      "
C
      ISUM1=0
      DO 5 I=1,NRECOD
      IF(RCTYPE(I).EQ.47) THEN
        IRCOUT=I
        GO TO 7
      END IF
    5 CONTINUE
      GO TO 98
    7 CONTINUE
      IF(SISTRS.GT.0) THEN
        IF(NDFPC1.GT.0.AND.NDFPC1.NE.NISTRS)GO TO 97
        DO 6 I=1,NISTRS
        ISUM1=ISUM1+IX(I+SISTRS-1)
    6   CONTINUE
        IF(NDFPC2.GT.0.AND.NDFPC2.NE.ISUM1)GO TO 97
      END IF
      ISUM2=0
      IF(SISNDS.GT.0) THEN
        IF(ISUM1.GT.0.AND.NISNDS.NE.ISUM1) THEN
          GO TO 98
        ELSE IF((ISUM1.EQ.0.AND.((NDFPC1.NE.0.AND.NDFPC1.NE.1).OR.
     .    (NDFPC2.GT.0.AND.NDFPC1.EQ.0)))) THEN
          GO TO 97
        END IF
        DO 8 I=1,NISNDS
        ISUM2=ISUM2+IX(I+SISNDS-1)
    8   CONTINUE
        IF(NRPTOT.NE.ISUM2)GO TO 98
      END IF
      IF(ISUM2.EQ.0.AND.ISUM1.GT.0.AND.NRPTOT.NE.ISUM1)GO TO 98
      ILOC=NXPTD
      SDVIN=ILOC
      N=V1(IRCOUT)
      JJ=V2(IRCOUT)+1
      DO 10 I=1,N
      JJ=JJ+1
      J=IX(JJ)
      IF(MTYPE(J).LE.50) THEN
        IX(JJ)=-ILOC
        VMAPL(J)=ILOC
        IF(MXSIZE(J).GE.2) THEN
          ILOC=ILOC+2
        ELSE
          ILOC=ILOC+1
        END IF
        MTYPE(J)=-MTYPE(J)
      END IF
   10 CONTINUE
      SDRFW=ILOC
      DO 13 I=1,NREPW
      DO 12 J=1,NVIN
      IF(MTYPE(J).EQ.50+I) THEN
        VMAPL(J)=ILOC
        ILOC=ILOC+1
      END IF
   12 CONTINUE
   13 CONTINUE
      JJ=V2(IRCOUT)+1
      DO 15 I=1,N
      JJ=JJ+1
      IF(IX(JJ).LT.0) THEN
        IX(JJ)=-IX(JJ)
      ELSE
        J=IX(JJ)
        IX(JJ)=VMAPL(J)
      END IF
   15 CONTINUE
      DO 17 I=1,NVIN
      IF(MTYPE(I).GE.0.AND.MTYPE(I).LE.50) THEN
        VMAPL(I)=ILOC
        IF(MXSIZE(I).GE.2) THEN
          ILOC=ILOC+2
        ELSE
          ILOC=ILOC+1
        END IF
      END IF
   17 CONTINUE
      LOCEND=ILOC-NXPTD
      CALL ROOMD(LOCEND)
      SDOUTP=NXPTD
      CALL ROOMD(N)
      IF(MSDPTH.GT.0) THEN
        K=2*MSDPTH
        SDSTCK=NXPTD
        CALL ROOMD(K)
      END IF
      I=1
   20 CONTINUE
      IF(RCTYPE(I).GE.40.AND.RCTYPE(I).LE.42) THEN
        IF(RSTPNT(I).GT.0) THEN
          K=RSTPNT(I)
          I=I+2
          DO 21 J=1,K
          I=I+1
          V2(I)=VMAPL(V2(I))
   21     CONTINUE
        ELSE
          I=I+2
        END IF
      END IF
      I=I+1
      IF(I.LE.NRECOD)GO TO 20
      SDVID=NXPTD
      NMAX=(MSIZED-NXPTD+1)/(TSIZE+NIDTOT)-1
      IF(NMAX.GE.NRPTOT) THEN
        NFILES=0
        NPASS=1
        NMAX=NRPTOT
        IFILE=11
        METHOD=1
        SDROUT=0
        NROUT=0
      ELSE IF(NMAX.LE.0) THEN
        WRITE(U6,222)
        GO TO 99
      ELSE
        NPASS=(NRPTOT-1)/NMAX+1
        NFILES=NPASS-1
        IF(NFILES.GT.31) THEN
          IF(U5ECHO.GT.0)WRITE(U6,221)NPASS
          GO TO 99
        ELSE IF(NFILES.LT.3) THEN
          METHOD=2
        ELSE IF(NFILES.LE.5) THEN
          DO 22 I=13,17
          INQUIRE(UNIT=I,OPENED=FOPEND)
          IF(.NOT.FOPEND)GO TO 23
   22     CONTINUE
          I=18
   23     CONTINUE
          I=I-13
          IF(NFILES.EQ.3.AND.I.EQ.2) THEN
            NFILES=2
            METHOD=3
          ELSE IF(NFILES.GE.4.AND.I.EQ.3) THEN
            NFILES=3
            METHOD=3
          ELSE
            METHOD=2
          END IF
        ELSE
          METHOD=3
          IF(NFILES.LE.7) THEN
            NFILES=3
          ELSE IF(NFILES.LE.15) THEN
            NFILES=4
          ELSE
            NFILES=5
          END IF
        END IF
        DO 24 I=1,NFILES
        J=12+I
        CALL SCOPEN(J)
   24   CONTINUE
        IF(METHOD.EQ.3) THEN
          IFILE=12+NFILES
        ELSE
          IFILE=13
        END IF
        IF(U5ECHO.GT.0)WRITE(U6,223)NPASS,NFILES
        SDROUT=SDRFW
        NROUT=NMAX
      END IF
      J=NIDTOT*(NMAX+1)
      CALL ROOMD(J)
      SDVPIN=NXPTD
      J=TSIZE*(NMAX+1)
      CALL ROOMD(J)
   25 CONTINUE
      IREPL=1
      IPASS=1
   26 CONTINUE
      K=SDVID-1+NIDTOT
      KK=SDVPIN+TSIZE
      IF(IPASS.EQ.1.OR.NBYGRP.GT.1) THEN
        READ(10)(DX(SDVID+J-1),J=1,NIDTOT)
        CALL UNFIN(10,DX(SDVPIN),TSIZE,ENDFLE)
        IF(IPASS.GT.1) THEN
          DO 27 I=1,IREPH
          READ(10)(DX(K+J),J=1,NIDTOT)
          CALL UNFIN(10,DX(KK),TSIZE,ENDFLE)
   27     CONTINUE
        END IF
      END IF
      IREPH=IREPL+NMAX-1
      IF(IREPH.GT.NRPTOT) THEN
        IREPH=NRPTOT
      END IF
      ENDF12=.FALSE.
      DO 28 I=IREPL,IREPH
      READ(10)(DX(K+J),J=1,NIDTOT)
      CALL UNFIN(10,DX(KK),TSIZE,ENDFLE)
      K=K+NIDTOT
      KK=KK+TSIZE
   28 CONTINUE
   30 CONTINUE
      IF(IVZERO.EQ.1) THEN
        K=SDVIN
        DO 35 I=1,LOCEND
        DX(K)=0.
        K=K+1
   35   CONTINUE
      END IF
      CALL RECODX(IXDROP,ENDF12)
      IF(.NOT.ENDF12) GO TO 30
      IF(IREPH.LT.NRPTOT) THEN
        IF(NRECOD.GT.0) THEN
          I=1
   37     CONTINUE
          IF(RCTYPE(I).GE.40.AND.RCTYPE(I).LE.42) THEN
            REWIND(UNIT=V1(I))
            V2(I)=0
          ELSE IF(RCTYPE(I).EQ.62) THEN
            DO 38 ITMP=1,RSTPNT(I)
            DX(V3(I+ITMP))=-98765.432109D0
   38       CONTINUE
            I=I+RSTPNT(I)
          ELSE IF(RCTYPE(I).EQ.63) THEN
            V2(I)=0
          END IF
          I=I+1
          IF(I.LE.NRECOD)GO TO 37
        END IF
        REWIND(UNIT=IFILE)
        IF(METHOD.EQ.3) THEN
          IF(IFILE.LT.12+NFILES) THEN
            DO 40 I=IFILE+1,12+NFILES
            REWIND(UNIT=I)
   40       CONTINUE
          END IF
        END IF
        IREPL=IREPL+NMAX
        IPASS=IPASS+1
        IF(IREPL.GT.1.AND.NBYGRP.GT.1) THEN
          REWIND(UNIT=10)
          CALL PREAMR
        END IF
        IF(IPASS.EQ.NPASS) THEN
          IFILE=11
        ELSE
          IF(METHOD.EQ.2) THEN
            IFILE=IFILE+1
            SDROUT=SDROUT+NMAX
          ELSE
            N=2**(NFILES-1)
            DO 44 I=1,NFILES
            IF((IPASS/N)*N.EQ.IPASS) THEN
              IFILE=12+I
              NROUT=N*NMAX
              SDROUT=SDRFW+IREPL-1-(N-1)*NMAX
              GO TO 45
            END IF
            N=N/2
   44       CONTINUE
   45       CONTINUE
          END IF
        END IF
        GO TO 26
      END IF
      DO 59 IRECOD=1,NRECOD
      IF(RCTYPE(IRECOD).GE.40.AND.RCTYPE(IRECOD).LE.42) THEN
        CLOSE(UNIT=V1(IRECOD))
      END IF
   59 CONTINUE
      CLOSE(10)
      CLOSE(11)
      CLOSE(12)
      RETURN
   97 CONTINUE
      WRITE(U6,214)
      GO TO 99
   98 CONTINUE
      WRITE(U6,216)
   99 CONTINUE
      CALL FSTOP
      END
      SUBROUTINE PREAMR
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      LOGICAL ENDFLE
C
      READ(10)IVERSN
      READ(10)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE,
     . VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR
      DO 1 I=1,NCLBLK
      READ(10)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I),
     . BLVSIZ(I),BLNCLS(I),BLCPNT(I)
    1 CONTINUE
      IF(NCLBAR.GT.0) THEN
        CALL INTIN(10,CLTYPE,NCLBAR,ENDFLE)
        CALL INTIN(10,CLPNT,NCLBAR,ENDFLE)
      END IF
C
C  RCEIL(2), RCEIL(7), AND RCEIL(10) were set in PREAMC initially
C
      I=RCEIL(2)+1
      IF(NVTOT.GT.0) THEN
        CALL INTIN(10,MTYPE(I),NVTOT,ENDFLE)
        CALL INTIN(10,MSIZE(I),NVTOT,ENDFLE)
      END IF
      IF(NVREG.GT.0) THEN
        CALL INTIN(10,VMAPL(I),NVREG,ENDFLE)
      END IF
      READ(10)NCRSSD
      ILC=RCEIL(10)+1
      IF(NCRSSD.GT.0)CALL INTIN(10,CROSSD(ILC),NCRSSD,ENDFLE)
      DO 6 I=RCEIL(2)+1,MVAR
      READ(10)VNAME(I),LABEL(I)
    6 CONTINUE
C
C  Read in labels for the levels
C
      READ(10)NCRVL
      IF(NCRVL.GT.0) THEN
        DO 10 I=RCEIL(7)+1,MLEVEL
        READ(10)LEVEL(I)
   10   CONTINUE
      END IF
      READ(10)ILC
      DO 12 I=1,ILC
      READ(10)VTEMP(I)
   12 CONTINUE
      IF(NBY.GE.1) THEN
        READ(10)NBYGRP
        K=SDBYID-1
        DO 17 I=1,NBYGRP
        READ(10)(DX(K+J),J=1,NBY)
        K=K+NBY
   17   CONTINUE
      END IF
      READ(10)NRPTOT
      IF(NRPTOT.GT.0) THEN
        CALL UNFIN(10,DX(SDCOEF),NRPTOT,ENDFLE)
      END IF
      RETURN
      END
      SUBROUTINE REPGEN
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (IXFLLD=3)
      PARAMETER (MAXFMT=20)
 
C
C  MVAR   represents the maximum number of incoming and created
C         variables, replicate factors and wts
C  MAXIDS is the maximum number of class variables
C  MRECOD is the maximum of variables transformed by CLASS, CAT
C         MISSING, SELECT, BY etc.
C  MRANGE is the maximum number of ranges
C  MRNSET is the maximum number of sets of ranges
C  MLEVEL is the maximum number of stored labels for levels
C  MCLBLK is the maximum number of class blocks
C  MCLBAR is the maximum number of cells of class block arrays
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
C
      LOGICAL REFRSH,ALPCHK,DGTCHK,ENDF12
      EXTERNAL REFRSH,ALPCHK,DGTCHK
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1,
     . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX
C
      DOUBLE PRECISION RANGE(2,MRANGE)
      INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET),
     . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD),
     . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI)
C
      COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP,
     . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO,
     . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS,
     . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT,
     . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS,
     . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO,
     . NLEVEL,NRNSET,NRANGE,NHADAM,SDHADM,SDOUTP,SDVID,SDVPIN,IREPL,
     . IREPH,IFILE,SDRFW,IPASS,METHOD,NFILES,SDROUT,NROUT,NMAX,IXFILL,
     . SDSTCK,MSDPTH
      INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS,
     . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN,
     . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,SDHADM,SDOUTP,SDVID,
     . SDVPIN,SDRFW,SDROUT,IXFILL(IXFLLD),SDSTCK,MSDPTH
      LOGICAL IXDROP
C
C
C  Usage in this subroutine:
C
C  BLXSTR  -  Pointer for block to X matrix
C  BLVSTR  -  revised to become pointer to first variable in block
C  BLVSIZ  -  revised to number of variables in block
C  BLNCLS  -  number of class variables in block
C  BLCPNT  -  pointer for classes to CLTYPE
C  CLTYPE  -  used as pointers to class variables
C
  200 FORMAT(' ERROR IN SPECIFICATION')
  220 FORMAT(' MISSING ONE OR MORE REPLICATES, INCLUDING',I6)
C
      NPASS=1
      IPASS=1
      METHOD=1
      IF((IREPF.GT.0.OR.IREPW.GT.0).AND.NREPW.EQ.0) THEN
        NREPW=0
        DO 1 I=1,NVIN
        IF(MTYPE(I).GT.50+NREPW)NREPW=MTYPE(I)-50
    1   CONTINUE
        DO 3 J=1,NREPW
        DO 2 I=1,NVIN
        IF(MTYPE(I).EQ.50+J)GO TO 3
    2   CONTINUE
        WRITE(U6,220)J
        GO TO 99
    3   CONTINUE
      END IF
      ILOC=NXPTD
      SDVIN=ILOC
      DO 10 I=1,NKEEP
      J=IOUT(I)
      IF(MTYPE(J).LE.50) THEN
        IOUTL(I)=ILOC
        VMAPL(J)=ILOC
        IF(MXSIZE(J).GE.2) THEN
          ILOC=ILOC+2
        ELSE
          ILOC=ILOC+1
        END IF
        MTYPE(J)=-MTYPE(J)
      END IF
   10 CONTINUE
      SDRFW=ILOC
      DO 13 I=1,NREPW
      DO 12 J=1,NVIN
      IF(MTYPE(J).EQ.50+I) THEN
        VMAPL(J)=ILOC
        ILOC=ILOC+1
      END IF
   12 CONTINUE
   13 CONTINUE
      DO 15 I=1,NKEEP
      J=IOUT(I)
      IF(MTYPE(J).GT.50) THEN
        IOUTL(I)=VMAPL(J)
      END IF
   15 CONTINUE
      DO 17 I=1,NVIN
      IF(MTYPE(I).GE.0.AND.MTYPE(I).LE.50) THEN
        VMAPL(I)=ILOC
        IF(MXSIZE(I).GE.2) THEN
          ILOC=ILOC+2
        ELSE
          ILOC=ILOC+1
        END IF
      END IF
   17 CONTINUE
      LOCEND=ILOC-NXPTD
      CALL ROOMD(LOCEND)
      SDOUTP=NXPTD
      CALL ROOMD(NKEEP)
      I=1
      IF(MSDPTH.GT.0) THEN
        K=2*MSDPTH
        SDSTCK=NXPTD
        CALL ROOMD(K)
      END IF
   20 CONTINUE
      IF(RCTYPE(I).GE.40.AND.RCTYPE(I).LE.42) THEN
        IF(RSTPNT(I).GT.0) THEN
          K=RSTPNT(I)
          I=I+2
          DO 21 J=1,K
          I=I+1
          V2(I)=VMAPL(V2(I))
   21     CONTINUE
        ELSE
          I=I+2
        END IF
      ELSE IF(RCTYPE(I).EQ.47) THEN
        K=V2(I)+1
        DO 25 J=1,V1(I)
        K=K+1
        KK=IX(K)
        IX(K)=VMAPL(KK)
   25   CONTINUE
      END IF
      I=I+1
      IF(I.LE.NRECOD)GO TO 20
      SDROUT=SDRFW
      ENDF12=.FALSE.
   30 CONTINUE
      IF(IVZERO.EQ.1) THEN
        K=SDVIN
        DO 35 I=1,LOCEND
        DX(K)=0.
        K=K+1
   35   CONTINUE
      END IF
      CALL RECODX(IXDROP,ENDF12)
      IF(.NOT.ENDF12) GO TO 30
      DO 59 IRECOD=1,NRECOD
      IF(RCTYPE(IRECOD).GE.40.AND.RCTYPE(IRECOD).LE.42) THEN
        CLOSE(UNIT=V1(IRECOD))
      END IF
   59 CONTINUE
      CLOSE(11)
      CLOSE(12)
      RETURN
   99 CONTINUE
      CALL FSTOP
      END
C
C  Parsing for DISPLAY step, original syntax
C
      SUBROUTINE DSETUP(DONE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL DONE
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MAXFMT=20)
C
      PARAMETER (MDSZI=MSIZEI+6*MRANGE+2*MRNSET+3*MVAR)
      PARAMETER (IXFLLD=56+3*MAXIDS)
      PARAMETER (NPOPTN=9)
      PARAMETER (NOPTN=21)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
C
      COMMON /STMBLK/IX,RSTPNT,RCTYPE,V1,V2,V3,MXSIZE
      INTEGER IX(MDSZI),RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),
     . V2(MRECOD),V3(MRECOD),MXSIZE(MVAR)
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID,
     . SDWRK,VKEEPF,OUTFMT,IXFILL(IXFLLD)
      COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,
     . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF,
     . OUTFMT,IXFILL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
C
      LOGICAL REFRSH,LTEMP
      EXTERNAL REFRSH
      INTEGER ITYPEF(3),IFILEF(3)
C
      INTEGER IOPTND(NPOPTN),IOPTNC(NPOPTN)
      INTEGER SICLSS,VTMPSZ
      CHARACTER*5 CWORK5
      CHARACTER*4 CWORK4
      INTEGER INDX(NOPTN)
      INTEGER IVALUE(NOPTN)
      CHARACTER*12 OPTNW(NOPTN)
      DATA OPTNW /    'PRINT       ','NOPRINT     ','WRITE       ',
     . 'NOWRITE     ','LINESIZE    ','CLASSSTUB   ','CLASS_STUB  ',
     . 'CLASSHEAD   ','CLASS_HEAD  ','PAGESIZE    ','CENTER      ',
     . 'CENTERED    ','UNCENTER    ','UNCENTERED  ','OUTFORMAT   ',
     . 'NDECIMAL    ','DECIMAL     ','MEAN        ','MEANS       ',
     . 'TOTAL       ','TOTALS      '/
      DATA INDX/1,1,2,2,3,4,4,4,4,5,6,6,6,6,8,9,9,7,7,7,7/
      DATA IVALUE/1,2,1,2,0,2,2,1,1,0,1,1,2,2,0,4,4,1,1,2,2/
C
  101 FORMAT(/,1X)
  103 FORMAT(/,5X,'OUTFORMAT SET PREVIOUSLY')
  141 FORMAT(I1)
  142 FORMAT(I2)
  143 FORMAT(I3)
  144 FORMAT(I4)
  151 FORMAT('11',8I4)
  152 FORMAT('12',I4,I2,I4,I2,I4,A12,A24)
  153 FORMAT('13',I2,I4,A12,A24)
  154 FORMAT('14',I4,A24)
  155 FORMAT('15',I4,' 0   0 0   0_N_',A5,4X,'N (wtd) for block ',A4,2X)
  156 FORMAT('16',I4,2I2,2I4)
  157 FORMAT('17',2I4,I2)
  158 FORMAT('18',2I4,2I2)
  170 FORMAT(5X,'OUTFORMAT3 SWITCHED TO OUTFORMAT4')
  171 FORMAT(/,5X,'Format of type 99 record for classes',/,5X,'Positions
     .  Class')
  172 FORMAT(/,5X,'Format of type 99 records for classes',/,5X,'Rec no
     .Positions  Class')
  173 FORMAT(7X,I2,'-',I2,4X,A12)
  174 FORMAT(6X,I4,5X,I2,'-',I2,4X,A12)
  175 FORMAT(/,5X,'MEAN SWITCHED TO TOTAL: ',A12)
  176 FORMAT(/,5X,'NO N FOR: ',A12)
  177 FORMAT(/,5X,'NO N FOR BLOCK:',I4)
  200 FORMAT(' ERROR IN SPECIFICATION')
  201 FORMAT(' UNRECOGNIZED VARIABLE NAME: ',A12)
  202 FORMAT(' CLASS VARIABLE NOT ALLOWED ON LIST: ',A12)
  233 FORMAT(' TEMPORARY ERROR: new syntax not yet implemented for thi',
     . 's step')
C
      ITYPEF(1)=2
      ITYPEF(2)=1
      ITYPEF(3)=0
      IF(U5ECHO.GT.0)WRITE(U6,101)
      CALL CRDPRN(3)
      CALL KYFIND(IKEY,IPT)
      CALL FNREAD(IPT,ITYPEF,IFILEF,1,IPOSSC)
      CALL PREAMB
      IF(IMERR1.GT.0) THEN
        CALL FSTOP
      END IF
      IF(IPOSSC.GT.0) THEN
C                                          ! new syntax
        CALL NDISPL(IPOSSC,ITYPEF,IFILEF)
        DONE=.TRUE.
        WRITE(U6,233)
        CALL FSTOP
      END IF
      DONE=.FALSE.
      RCEIL(1)=MDSZI
C                                 ! size of IX in this step
      IOPTND(1)=1
C                                 ! default is PRINT
      IF(IFILEF(2).EQ.1) THEN
        IOPTND(2)=1
      ELSE
        IOPTND(2)=2
C                                 ! NOWRITE
      END IF
      IOPTND(3)=80
C                          ! LINESIZE=80
      IOPTND(4)=1
C                          ! CLASSHEAD (other options
 
C                          !    not implemented.)
      IOPTND(5)=57
C                          ! pagesize=57
      IOPTND(6)=2
C                          ! UNCENTERED
      IOPTND(NPOPTN-2)=1
C                          ! MEANS
      IOPTND(NPOPTN-1)=0
C                          ! OUTFORMAT=0
      IOPTND(NPOPTN)=4
C                          ! NDECIMAL=4
      OUTFMT=0
      ISOPEN=0
C                          !  scratch1 not yet open
      NVIN=NVTOT
      VTMPSZ=MVAR-SVTEMP+1
      IF(NCLASS.GT.0) THEN
C                          ! space reserved as work
        I=3*NCLASS
C                          ! array for calls to CLCHCK
        CALL ROOMI(I)
      END IF
C
C  For each variable store the number of the block in MXSIZE
C
      IV=0
      DO 7 ICLBLK=1,NCLBLK
      IF(BLVSIZ(ICLBLK).GT.0) THEN
        DO 6 I=1,BLVSIZ(ICLBLK)
        IV=IV+1
        MXSIZE(IV)=ICLBLK
    6   CONTINUE
      END IF
    7 CONTINUE
      NXPTDS=NXPTD
      NXPTIS=NXPTI
      MAXVN=MVAR-NVIN
C
C
    3 CONTINUE
      IF(U5END.GT.0)GO TO 60
      LTEMP=REFRSH(IPT)
    4 CONTINUE
      IF(U5END.GT.0)GO TO 60
      CALL KYFIND(IKEY,IPT)
      IF(IKEY.EQ.-1) THEN
        CALL CRDPRN(1)
        GO TO 4
      END IF
      IF(IKEY.LT.39.AND.IKEY.NE.36.AND.IKEY.NE.1)GO TO 60
      IF(IKEY.GT.48)GO TO 60
      IF(IKEY.EQ.1) THEN
        I=13
        CALL CRDPRN(1)
        CALL SCOPEN(I)
        ISOPEN=1
        GO TO 3
      ELSE IF(IKEY.EQ.36) THEN
        CALL CRDPRN(1)
        IOPTSV=IOPTND(NPOPTN-1)
        IOPTND(NPOPTN-1)=0
        CALL OPTNTR(NOPTN,INDX,IVALUE,OPTNW,IPT,IPOS,IOPTND)
        IF(IOPTND(NPOPTN-1).EQ.0) THEN
          IOPTND(NPOPTN-1)=IOPTSV
        ELSE IF(IOPTSV.GT.0) THEN
          IF(U5ECHO.GT.0)WRITE(U6,103)
          IOPTND(NPOPTN-1)=IOPTSV
        END IF
        IF(IFILEF(2).NE.1) THEN
          IOPTND(2)=2
        END IF
        IF(IOPTND(1).NE.1.AND.IOPTND(1).NE.2) IOPTND(1)=1
        IF(IOPTND(2).NE.1.AND.IOPTND(2).NE.2) IOPTND(2)=1
        IF(IOPTND(3).LT.120) THEN
          IOPTND(3)=80
        ELSE IF(IOPTND(3).LT.132) THEN
          IOPTND(3)=120
        ELSE
          IOPTND(3)=132
        END IF
        IF(IOPTND(4).NE.1.AND.IOPTND(4).NE.2)IOPTND(4)=1
        IF(IOPTND(5).LT.30)IOPTND(5)=30
        IF(IOPTND(6).NE.1)IOPTND(6)=2
        IF(IOPTND(NPOPTN-2).NE.2)IOPTND(NPOPTN-2)=1
        IF(IOPTND(NPOPTN).LT.0.OR.IOPTND(NPOPTN).GT.19)IOPTND(NPOPTN)=4
        IF(IPT.EQ.1) THEN
          GO TO 4
        ELSE
          GO TO 3
        END IF
C
C  LIST, COV, COVARIANCE(S), CORR, CORRELATION(S), T-TEST, TEST, TABLE
C
      ELSE IF(IKEY.GE.40.AND.IKEY.LE.47) THEN
        IF(IKEY.EQ.42) THEN
          IKEY=41
        ELSE IF(IKEY.EQ.44) THEN
          IKEY=43
        ELSE IF(IKEY.EQ.46) THEN
          IKEY=45
        END IF
        IF(ISOPEN.EQ.0) THEN
          I=13
          CALL SCOPEN(I)
          ISOPEN=1
        END IF
        CALL CRDPRN(1)
        DO 5 I=1,NPOPTN
        IOPTNC(I)=IOPTND(I)
    5   CONTINUE
        IBEYND=0
        INEXT=0
        IF(IPT.EQ.2) THEN
          IF(CARD(2:2).EQ.'-')IPT=3
          CALL CMATCH(CARD(3:6),3,6,'TEST',4,IPOS,1)
          IF(IPOS.GT.0) THEN
            IPT=7
            IF(CARD(7:7).EQ.'S'.OR.CARD(7:7).EQ.'s')IPT=8
          END IF
        END IF
        SICLSS=NXPTIS
        IV=0
        IVS=1
        ILTOT=0
        IXTOT=0
   10   CONTINUE
        CALL NBFND2(IPT,IPOS)
        IF(IPT.EQ.1)IBEYND=1
        IF(IPOS.LE.0) THEN
          INEXT=1
          GO TO 50
        END IF
        IF(CARD(IPOS:IPOS).EQ.'/') THEN
          IPT=IPOS+1
          IF(IPOS.GT.256) THEN
            IBEYND=1
            IF(.NOT.REFRSH(IPT)) THEN
              INEXT=1
              GO TO 50
            ELSE
              GO TO 10
            END IF
          END IF
          GO TO 10
        END IF
C       IF(IPOS.LE.76) THEN
          CALL CMATCH(CARD(IPOS:256),IPOS,256,'CLASS',5,IPOS2,1)
          IF(IPOS2.GT.0) THEN
            IPOS=IPOS2
            MAXIA=(MDSZI-SICLSS-2)/3
            MAXRT=MSIZED-NXPTD+1
            IF(MVAR-IV.LT.MAXRT)MAXRT=MVAR-IV
            CALL CLSCAN(IPOS,IPOS2,IX(SICLSS+2),MAXIA,IX(SICLSS),
     .        VTEMP(SVTEMP),VTMPSZ,DX(NXPTD),MAXRT,V1(IV+1),V2(IV+1),
     .        NVIN)
            IF(IPOS.EQ.1)IBEYND=1
            K=SICLSS+2
            ICLSIZ=0
   15       CONTINUE
            N=IX(K)
            ICLSIZ=ICLSIZ+IX(K+2)
            K=K+3*IX(K)+3
            IF(K.LT.SICLSS+3*IX(SICLSS)+2)GO TO 15
            ILTOT=ILTOT+IXTOT*ICLSIZ
            IXTOT=0
            IF(IVS.LE.IV) THEN
              DO 19 I=IVS,IV
              ICLX=SICLSS+2
  185         CONTINUE
              IF(V2(I).EQ.9) THEN
                CALL CLCHCK(V1(I),V1(I),V2(I),IX(ICLX),IX(ICLX))
              ELSE
                CALL CLCHCK(MXSIZE(V1(I)),V1(I),V2(I),IX(ICLX),IX(ICLX))
              END IF
              IF(ICLX+3+3*IX(ICLX).LE.SICLSS+3*IX(SICLSS)+1) THEN
                ICLX=ICLX+3+3*IX(ICLX)
                GO TO 185
              END IF
              V3(I)=SICLSS-NXPTIS+1
   19         CONTINUE
            END IF
            IVS=IV+1
            SICLSS=SICLSS+3*IX(SICLSS)+2
            IF(IPOS2.EQ.0) THEN
              INEXT=1
              GO TO 50
            ELSE
              IPT=IPOS2
              GO TO 10
            END IF
          END IF
C       END IF
        CALL CMATCH(CARD(IPOS:256),IPOS,256,'OPTIONS',7,IPOS2,1)
        IF(IPOS2.EQ.0) THEN
          CALL CMATCH(CARD(IPOS:256),IPOS,256,'OPTION',6,IPOS2,1)
        END IF
        IF(IPOS2.GT.256) THEN
          IF(.NOT.REFRSH(IPOS2))GO TO 10
        END IF
        IF(IPOS2.GT.0) THEN
          IPT=IPOS2
          IOPTNC(NPOPTN-1)=0
          CALL OPTNTR(NOPTN,INDX,IVALUE,OPTNW,IPT,IPOS,IOPTNC)
          IF(IOPTNC(NPOPTN-1).GT.0) THEN
            IF(IOPTNC(NPOPTN-1).GT.5)IOPTNC(NPOPTN-1)=1
            IF(IOPTND(NPOPTN-1).EQ.0) THEN
              IOPTND(NPOPTN-1)=IOPTNC(NPOPTN-1)
            ELSE
              IF(U5ECHO.GT.0)WRITE(U6,103)
            END IF
          END IF
          IF(IPT.EQ.1)IBEYND=1
          IF(IFILEF(2).NE.1) THEN
            IOPTNC(2)=2
          END IF
          IF(IOPTNC(1).NE.1.AND.IOPTNC(1).NE.2) IOPTNC(1)=1
          IF(IOPTNC(2).NE.1.AND.IOPTNC(2).NE.2) IOPTNC(2)=1
          IF(IOPTNC(3).LT.120) THEN
            IOPTNC(3)=80
          ELSE IF(IOPTNC(3).LT.132) THEN
            IOPTNC(3)=120
          ELSE
            IOPTNC(3)=132
          END IF
          IF(IOPTNC(4).NE.1.AND.IOPTNC(4).NE.2)IOPTNC(4)=1
          IF(IOPTNC(5).LT.30)IOPTNC(5)=30
          IF(IOPTNC(6).NE.1)IOPTNC(6)=2
          IF(IOPTNC(NPOPTN-2).NE.2)IOPTNC(NPOPTN-2)=1
          IF(IOPTNC(NPOPTN).LT.0.OR.IOPTNC(NPOPTN).GT.19)
     .       IOPTNC(NPOPTN)=4
          IPT=IPOS
          IF(IPOS.EQ.0) THEN
            INEXT=1
            GO TO 50
          ELSE
            GO TO 10
          END IF
        END IF
        IPT=IPOS
        K=MVAR-IV
        CALL VTSCAN(IPT,VNAME,MTYPE,MSIZE,CDMPNT,CROSSD,NVIN,
     .    VTEMP(SVTEMP),VTMPSZ,V1(IV+1),V2(IV+1),RSTPNT(IV+1),K,
     .    N,LTOT,IPOS,IERR)
        IF(IERR.GT.0)GO TO 95
        IF(IPT.EQ.1)IBEYND=1
        IXLOC=0
        DO 30 I=1,N
        RCTYPE(IV+I)=IOPTNC(NPOPTN)
        IF(V2(IV+I).NE.9) THEN
          MT=MTYPE(V1(IV+I))
          IF(MT.EQ.4) THEN
            K=V1(IV+I)
            WRITE(U6,202)VNAME(K)
            GO TO 99
          ELSE IF(V2(IV+I).EQ.0) THEN
            IF(MT.LT.10) THEN
              V2(IV+I)=IOPTNC(NPOPTN-2)
              IF(MT.EQ.2.OR.MT.EQ.8)RSTPNT(IV+I)=RSTPNT(IV+I)/2
            ELSE
              V2(IV+I)=10
            END IF
          END IF
          IF(MT.EQ.1) THEN
            K=V1(IV+I)
            IF(BLTYPE(MXSIZE(K)).NE.1) THEN
              IF(V2(IV+I).EQ.1) THEN
                V2(IV+I)=2
                IF(U5ECHO.GT.0)WRITE(U6,175)VNAME(K)
              ELSE IF(V2(IV+I).EQ.8) THEN
                WRITE(U6,176)VNAME(K)
                GO TO 99
              END IF
            END IF
          END IF
        ELSE
          IF(BLTYPE(V1(IV+I)).NE.1) THEN
            WRITE(U6,177)V1(IV+I)
            GO TO 99
          END IF
        END IF
        IXTOT=IXTOT+RSTPNT(IV+I)
   30   CONTINUE
        IV=IV+N
        IF(IPOS.EQ.0) THEN
          INEXT=1
          GO TO 50
        ELSE
          IPT=IPOS
          IF(N.EQ.0)IPT=IPT+1
          GO TO 10
        END IF
   50   CONTINUE
        IF(IV.GE.IVS) THEN
          DO 52 I=IVS,IV
          V3(I)=0
          IF(V2(I).EQ.9) THEN
            CALL CLCHCK(V1(I),V1(I),V2(I),IX,0)
          ELSE
            CALL CLCHCK(MXSIZE(V1(I)),V1(I),V2(I),IX,0)
          END IF
   52     CONTINUE
          ILTOT=ILTOT+IXTOT
        END IF
        K=SICLSS-NXPTIS
        WRITE(13)IKEY,IV,ILTOT,K
        WRITE(13)(IOPTNC(I),I=1,NPOPTN-3)
        IF(IV.GT.0) THEN
          CALL INTOUT(13,V1,IV)
          CALL INTOUT(13,V2,IV)
          CALL INTOUT(13,V3,IV)
          CALL INTOUT(13,RSTPNT,IV)
          CALL INTOUT(13,RCTYPE,IV)
          IF(K.GT.0) THEN
            CALL INTOUT(13,IX(NXPTIS),K)
          END IF
        END IF
        IF(IBEYND.EQ.1) THEN
          GO TO 4
        ELSE
          GO TO 3
        END IF
      END IF
C
C
C
   59 CONTINUE
      U5END=1
   60 CONTINUE
      IF(IOPTND(NPOPTN-1).GT.0) THEN
        OUTFMT=IOPTND(NPOPTN-1)
      ELSE
        OUTFMT=1
      END IF
      IF(OUTFMT.EQ.3.OR.OUTFMT.EQ.4) THEN
   61   CONTINUE
        J=1
        K=3
        L=0
        IF(NCLASS.GT.0) THEN
          DO 62 I=NVREG+1,NVREG+NCLASS
          IF(OUTFMT.EQ.3) THEN
            IF(MSIZE(I).GT.999) THEN
              IF(U5ECHO.GT.0)WRITE(U6,170)
              OUTFMT=4
              GO TO 61
            ELSE
              KK=3
            END IF
          ELSE
            IF(MSIZE(I).LE.9) THEN
              KK=1
            ELSE IF(MSIZE(I).LE.99) THEN
              KK=2
            ELSE IF(MSIZE(I).LE.999) THEN
              KK=3
            ELSE
              KK=4
            END IF
          END IF
          IF(K+KK.GE.80) THEN
            J=J+1
            K=3
          END IF
          IX(L+1)=J
          IX(L+2)=K
          IX(L+3)=KK
          L=L+3
          K=K+KK
   62     CONTINUE
        END IF
        K=(NBY+2)/3
        L=0
        DO 63 I=1,NCLBLK
        IF(BLTYPE(I).EQ.1)L=L+1
   63   CONTINUE
        WRITE(11,151)NVTOT,NVREG,NCLASS,NBY,NCLBLK,L,J,K
        DO 68 I=1,NVTOT
        IF(I.LE.NVREG+NCLASS.OR.MTYPE(I).EQ.5.OR.
     .    MTYPE(I).EQ.6) THEN
          IF(MTYPE(I).EQ.8.OR.MTYPE(I).EQ.9.OR.MTYPE(I).EQ.19) THEN
            K=CDMPNT(I)
            N=CROSSD(K)
            L=0
          ELSE IF(MTYPE(I).GE.3.AND.MTYPE(I).LE.5) THEN
            N=0
            L=MSIZE(I)
          ELSE
            N=0
            L=0
          END IF
          WRITE(11,152)I,MTYPE(I),MSIZE(I),N,L,VNAME(I),LABEL(I)
          IF(L.GT.0) THEN
            K=LPOINT(I)
            DO 64 J=1,L
            WRITE(11,154)J,LEVEL(K)
            K=K+1
   64       CONTINUE
          ELSE IF(N.GT.0) THEN
            KK=LPOINT(I)
            KL=CROSSD(K+N+1)
            DO 66 J=1,N
            K=K+1
            WRITE(11,153)J,CROSSD(K),VTEMP(KL),LEVEL(KK)
            KL=KL+1
            KK=KK+1
            IF(CROSSD(K).GT.0) THEN
              DO 65 II=1,CROSSD(K)
              WRITE(11,154)II,LEVEL(KK)
              KK=KK+1
   65         CONTINUE
            END IF
   66       CONTINUE
          END IF
        END IF
   68   CONTINUE
        DO 69 I=1,NCLBLK
        IF(BLTYPE(I).EQ.1) THEN
          K=NVTOT+I
          IF(I.LE.9) THEN
            WRITE(CWORK4,141)I
            WRITE(CWORK5,141)I
            CWORK5(2:2)='_'
          ELSE IF(I.LE.99) THEN
            WRITE(CWORK4,142)I
            WRITE(CWORK5,142)I
            CWORK5(3:3)='_'
          ELSE IF(I.LE.999) THEN
            WRITE(CWORK4,143)I
            WRITE(CWORK5,143)I
            CWORK5(4:4)='_'
          ELSE IF(I.LE.9999) THEN
            WRITE(CWORK4,144)I
            WRITE(CWORK5,144)I
            CWORK5(5:5)='_'
          END IF
          J=NVTOT+I
          WRITE(11,155)J,CWORK5,CWORK4
        END IF
   69   CONTINUE
        DO 71 I=1,NCLBLK
        J=BLVSTR(I)+BLVSIZ(I)-1
        WRITE(11,156)I,BLTYPE(I),BLNCLS(I),BLVSTR(I),J
        IF(BLNCLS(I).GT.0) THEN
          K=BLCPNT(I)
          DO 70 J=1,BLNCLS(I)
          WRITE(11,157)J,CLPNT(K),CLTYPE(K)
          K=K+1
   70     CONTINUE
        END IF
   71   CONTINUE
        IF(NCLASS.GT.0) THEN
          L=NCLASS*3-2
          J=IX(L)
          IF(J.EQ.1) THEN
            IF(U5ECHO.GT.0)WRITE(U6,171)
          ELSE
            IF(U5ECHO.GT.0)WRITE(U6,172)
          END IF
          K=NVREG
          L=0
          DO 72 I=1,NCLASS
          K=K+1
          WRITE(11,158)K,IX(L+1),IX(L+2),IX(L+3)
          JJ=IX(L+2)+IX(L+3)-1
          IF(J.EQ.1) THEN
            IF(U5ECHO.GT.0)WRITE(U6,173)IX(L+2),JJ,VNAME(K)
          ELSE
            IF(U5ECHO.GT.0)WRITE(U6,174)IX(L+1),IX(L+2),JJ,VNAME(K)
          END IF
          L=L+3
   72     CONTINUE
        END IF
      END IF
      RETURN
   95 CONTINUE
      WRITE(U6,200)
   99 CONTINUE
      CALL FSTOP
      END
      SUBROUTINE CLCHCK(ICLBLK,IV,IT,IA,NA)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
C
      INTEGER ICLBLK,IV,IT,IA(3,*),NA
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
C
  200 FORMAT(' DERIVED TYPE DOES NOT ALLOW COLLAPSING: ',A12)
  201 FORMAT(' ERROR IN CLASS SPECIFICATION: ',A12)
  202 FORMAT(' ERROR IN CLASS SPECIFICATION, BLOCK: ',I5)
C
      NIN=BLNCLS(ICLBLK)
C
C  If the block has no class variables, then there should either be:
C     No class specification for the variable, or
C     A specification of "/CLASS TOTAL"
C
      NOUT=0
C
C  Loop through specification to identify class variables
C
      IF(NA.GT.0) THEN
        K=1
    7   CONTINUE
        N=IA(1,K)
        K=K+1
        J=1
    9   CONTINUE
C
C  If the specification includes TOTAL, treat it simply as TOTAL
C
        IF(IA(1,K).EQ.0) THEN
          NOUT=0
          GO TO 20
        ELSE
          NOUT=NOUT+1
          IF(NIN.EQ.0)GO TO 98
          ICLBAR=BLCPNT(ICLBLK)
          DO 12 I=1,NIN
          IF(CLPNT(ICLBAR).EQ.IA(1,K))GO TO 13
          ICLBAR=ICLBAR+1
   12     CONTINUE
          GO TO 98
   13     CONTINUE
          IF(IT.NE.9) THEN
            IF(MTYPE(IV).GT.10) THEN
              IF(IA(2,K).EQ.0.AND.IA(3,K).NE.0.AND.
     .          CLTYPE(ICLBAR).EQ.1)GO TO 97
            END IF
          END IF
          IF(J.LT.N) THEN
            K1=K+1
            IF(IA(1,K1).EQ.IA(1,K)) THEN
              IF(IT.NE.9) THEN
                IF(MTYPE(IV).GT.10) THEN
                  IF(IA(3,K).EQ.IA(3,K1))GO TO 97
                END IF
              END IF
              K=K+1
              J=J+1
              GO TO 13
            ELSE
              DO 14 J1=J+1,N
              IF(IA(1,K1).EQ.IA(1,K)) THEN
                GO TO 98
              ELSE
                K1=K1+1
              END IF
   14         CONTINUE
            END IF
          END IF
          J=J+1
          K=K+1
          IF(J.LE.N)GO TO 9
          IF(K.LE.NA)GO TO 7
        END IF
      END IF
   20 CONTINUE
      IF(IT.NE.9.AND.NIN.GT.0) THEN
        IF(MTYPE(IV).GT.10) THEN
          ICLBAR=BLCPNT(ICLBLK)
          DO 30 I=1,NIN
          IF(NOUT.GT.0) THEN
            K=1
   23       CONTINUE
            N=IA(1,K)
            K=K+1
            J=1
   25       CONTINUE
            IF(IA(1,K).EQ.CLPNT(ICLBAR))GO TO 29
            J=J+1
            K=K+1
            IF(J.LE.N)GO TO 25
            IF(K.LE.NA)GO TO 23
          END IF
          IF(CLTYPE(ICLBAR).EQ.1)GO TO 97
   29     CONTINUE
          ICLBAR=ICLBAR+1
   30     CONTINUE
        END IF
      END IF
      RETURN
   97 CONTINUE
      WRITE(U6,200)VNAME(IV)
      GO TO 99
   98 CONTINUE
      IF(IT.NE.9) THEN
        WRITE(U6,201)VNAME(IV)
      ELSE
        WRITE(U6,202)IV
      END IF
   99 CONTINUE
      CALL FSTOP
      END
      SUBROUTINE DCREAT
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
C
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
C
      PARAMETER (MDSZI=MSIZEI+6*MRANGE+2*MRNSET+3*MVAR)
      PARAMETER (IXFLLD=56+3*MAXIDS)
      PARAMETER (NPOPTN=6)
      PARAMETER (NINCR=NPOPTN+3)
      PARAMETER (MAXLST=20)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
C
      COMMON /STMBLK/IX,RSTPNT,RCTYPE,V1,V2,V3,MXSIZE
      INTEGER IX(MDSZI),RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),
     . V2(MRECOD),V3(MRECOD),MXSIZE(MVAR)
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID,
     . SDWRK,VKEEPF,OUTFMT,IXFILL(IXFLLD)
      COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,
     . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF,
     . OUTFMT,IXFILL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      INTEGER SDRIN,SDTOT,SDREP,SDVAR,SDVFLG,SDCENT
C     LOGICAL ENDFLE,HFIRST,END13
      LOGICAL ENDFLE,END13
      LOGICAL PRINTX,WRITEX
      INTEGER SDCOSV,SDBYSV
      DOUBLE PRECISION MISSNG,DT(6),CSUM
      DATA MISSNG/-98765.432109D0/
C
  101 FORMAT('1 ')
  102 FORMAT('1',22X,'Covariances of the Sample Estimates')
  105 FORMAT(5X,A24,':',3X,A24)
  106 FORMAT(5X,A24,':',3X,F15.3)
  107 FORMAT('1',21X,'Correlations of the Sample Estimates')
  108 FORMAT('1',28X,'T-Tests for Differences')
  151 FORMAT('01',I4,I6,2F22.8)
  152 FORMAT('02',3I4,F22.8,2D22.14)
  153 FORMAT('03',3I4,3D22.14)
  154 FORMAT('04',3I4,F22.8,4F11.8)
  155 FORMAT('05',3I4,6F11.8)
  156 FORMAT('06',3I4,F22.8,4F11.6)
  157 FORMAT('07',3I4,6F11.6)
  200 FORMAT(' ERROR IN SPECIFICATION')
      REWIND(13)
      NREQIN=0
      READ(13)IKEYIN,NVINP,ILTOTI,NSCLSS
      NXPTDS=NXPTD
      NXPTIS=NXPTI
      SDCOSV=SDCOEF
      SDBYSV=SDBYID
    1 CONTINUE
      NXPTD=NXPTDS
      SICMUL=NXPTI
      CALL ROOMI(NCLBLK)
      DO 706 ICLBLK=1,NCLBLK
      ICSIZE=1
      IF(BLNCLS(ICLBLK).GE.1) THEN
        DO 702 I=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1
        IF(CLTYPE(I).EQ.0) THEN
          ICSIZE=ICSIZE*(MSIZE(CLPNT(I))+1)
        ELSE
          ICSIZE=ICSIZE*(MSIZE(CLPNT(I)))
        END IF
  702   CONTINUE
      END IF
      IX(SICMUL+ICLBLK-1)=ICSIZE
  706 CONTINUE
      SDRIN=NXPTD
      CALL ROOMD(TSIZE)
      END13=.FALSE.
      LBASE=NXPTI-NINCR-1
      K=MAXLST*NINCR
      CALL ROOMI(K)
      NLIST=0
      ISBASE=NXPTI
      IV=0
      IXSIZE=0
      IXSIZ2=0
      IXSIZC=0
    2 CONTINUE
      IF(NLIST.GE.MAXLST)GO TO 4
      IF(IV+NVINP.GT.MVAR)GO TO 4
      IF(ISBASE+NSCLSS+2*NCLASS.GT.MDSZI)GO TO 4
      K=NXPTDS+3*IXSIZE+2*IXSIZ2+IXSIZC
      IF(NLIST.GT.0) THEN
        IF(IKEYIN.EQ.40.OR.IKEYIN.EQ.47) THEN
          IF(K+6*ILTOTI+TSIZE.GT.MSIZED)GO TO 4
        ELSE
          IF(K+4*ILTOTI+ILTOTI*(ILTOTI+1)+TSIZE.GT.MSIZED)GO TO 4
        END IF
      END IF
      NLIST=NLIST+1
      NREQIN=NREQIN+1
      K=LBASE+NINCR*NLIST
      IX(K+1)=IKEYIN
      IX(K+2)=NVINP
      IX(K+3)=ILTOTI
      IXSIZE=IXSIZE+ILTOTI
      IF(IKEYIN.EQ.40.OR.IKEYIN.EQ.47) THEN
        IXSIZ2=IXSIZ2+ILTOTI
      ELSE
        IXSIZ2=IXSIZ2+(ILTOTI*(ILTOTI+1))/2
      END IF
      READ(13)(IX(J),J=K+4,K+NINCR)
      IF(IX(K+9).EQ.1)IXSIZC=IXSIZC+ILTOTI
      K=3*IXSIZE+2*IXSIZ2+IXSIZC
      IF(K+NXPTD.GT.MSIZED+1)CALL ROOMD(K)
      IF(NVINP.GT.0) THEN
        CALL INTIN(13,V1(IV+1),NVINP,END13)
        CALL INTIN(13,V2(IV+1),NVINP,END13)
        CALL INTIN(13,V3(IV+1),NVINP,END13)
        DO 801 J=1,NVINP
        IF(V3(IV+J).GT.0)V3(IV+J)=V3(IV+J)+ISBASE-1
  801   CONTINUE
        CALL INTIN(13,RSTPNT(IV+1),NVINP,END13)
        CALL INTIN(13,RCTYPE(IV+1),NVINP,END13)
        IF(NSCLSS.GT.0) then
          CALL INTIN(13,IX(ISBASE),NSCLSS,END13)
        END IF
        ISBASE=ISBASE+NSCLSS
      END IF
      IV=IV+NVINP
      READ(13,END=3)IKEYIN,NVINP,ILTOTI,NSCLSS
      GO TO 2
    3 CONTINUE
      END13=.TRUE.
    4 CONTINUE
      NREQBS=NREQIN-NLIST
      K=ISBASE-NXPTI
      IF(K.GT.0)CALL ROOMI(K)
      SDTOT=NXPTD
      CALL ROOMD(IXSIZE)
      SDREP=NXPTD
      CALL ROOMD(IXSIZE)
      SDVAR=NXPTD
      CALL ROOMD(IXSIZ2)
      SDVFLG=NXPTD
      CALL ROOMD(IXSIZ2)
      SDCENT=NXPTD
      IF(IXSIZC.GT.0)CALL ROOMD(IXSIZC)
      IF(NBYGRP.EQ.0)NBYGRP=1
      DO 99 IBYGRP=1,NBYGRP
      IF(IXSIZC.GT.0) THEN
        DO 991 I=1,IXSIZC
        DX(SDCENT+I-1)=0.
  991   CONTINUE
      END IF
      CSUM=0.
      DO 992 I=1,IXSIZ2
      DX(SDVAR+I-1)=0.
  992 CONTINUE
      MAXDFL=0
      DO 40 IREP=0,NRPTOT
      READ(12)(DX(NXPTD+I-1),I=1,NIDTOT)
      IF(IREP.EQ.0) THEN
        IF(IBYGRP.GT.1) THEN
          J=SDBYID+NBY*(IBYGRP-1)-1
          DO 993 I=1,NBY
          DX(SDBYID+I-1)=DX(J+I)
  993     CONTINUE
        END IF
        IBASE=SDTOT-1
      ELSE
        T=DX(SDCOEF+IREP-1)
        CSUM=CSUM+T
        IBASE=SDREP-1
      END IF
      CALL UNFIN(12,DX(SDRIN),TSIZE,ENDFLE)
      ICELL=0
      ICELLV=0
      IV=0
      ICENT=SDCENT
      DO 39 ILIST=1,NLIST
      LBASE1=LBASE+ILIST*NINCR
      IKEY=IX(LBASE1+1)
      ICHEAD=IX(LBASE1+7)
      ICELLS=ICELL
      NICL1=IX(LBASE1+2)
      DO 31 ICL=1,NICL1
      ICHECK=0
      IV=IV+1
      IF(ICL.EQ.1) THEN
        IF(ICHEAD.EQ.1) THEN
          ICHECK=1
        ELSE
          ICHINC=1
        END IF
      ELSE IF(ICHEAD.EQ.1) THEN
        IF(V3(IV-1).NE.V3(IV)) THEN
          ICHECK=1
        END IF
      END IF
      IF(ICHECK.EQ.1) THEN
        ICHINC=0
        DO 721 ICL1=ICL,NICL1
        IF(V3(ICL1-ICL+IV).NE.V3(IV))GO TO 722
        ICHINC=ICHINC+RSTPNT(ICL1-ICL+IV)
  721   CONTINUE
  722   CONTINUE
      END IF
      ICLSS=V3(IV)
      IF(V2(IV).EQ.9) THEN
        ICLBLK=V1(IV)
        IS=BLXSTR(ICLBLK)+SDRIN-1
      ELSE
        ICLBLK=MXSIZE(V1(IV))
        IF(V2(IV).EQ.8) THEN
          IF(MTYPE(V1(IV)).EQ.1.OR.
     .      (MTYPE(V1(IV)).EQ.3.AND.MSIZE(V1(IV)).EQ.1)) THEN
            IS=BLXSTR(ICLBLK)+SDRIN-1
          ELSE
            IS=VMAPL(V1(IV))+SDRIN-1
          END IF
        ELSE
          IS=VMAPL(V1(IV))+SDRIN-1
        END IF
      END IF
      ISN=BLXSTR(ICLBLK)+SDRIN-1
      IF(ICLSS.GT.0) THEN
        ICLX=ICLSS+2
        ICELLT=ICELL
   15   CONTINUE
        IP=IBASE+ICELLT+1
        CALL TMOVE1(IS,BLXINC(ICLBLK),ISN,BLXINC(ICLBLK),IP,ICHINC,
     .      IX(ICLX),IX(ICLX),ICLBLK,V1(IV),V2(IV))
        IF(ICLX+3+3*IX(ICLX).LE.ICLSS+3*IX(ICLSS)+1) THEN
          IF(ICHEAD.EQ.1) THEN
            ICELLT=ICELLT+ICHINC*(IX(ICLX+2))
          ELSE
            ICELLT=ICELLT+RSTPNT(IV)*IX(ICLX+2)
          END IF
          ICLX=ICLX+3+3*IX(ICLX)
          GO TO 15
        END IF
        IF(ICHEAD.EQ.1) THEN
          ICHECK=0
          IF(ICL.EQ.NICL1) THEN
            ICHECK=1
          ELSE
            IF(V3(IV+1).NE.V3(IV)) THEN
              ICHECK=1
            END IF
          END IF
          IF(ICHECK.EQ.1) THEN
            ICELL=ICELLT+RSTPNT(IV)+ICHINC*(IX(ICLX+2)-1)
          ELSE
            ICELL=ICELL+RSTPNT(IV)
          END IF
        ELSE
          ICELL=ICELLT+RSTPNT(IV)*IX(ICLX+2)
        END IF
      ELSE
        IP=IBASE+ICELL+1
        CALL TMOVE1(IS,BLXINC(ICLBLK),ISN,BLXINC(ICLBLK),IP,1,IX,
     .      0,ICLBLK,V1(IV),V2(IV))
        ICELL=ICELL+RSTPNT(IV)
      END IF
   31 CONTINUE
      NVC=ICELL-ICELLS
      IF(IREP.EQ.0) THEN
        IF(IKEY.GT.40.AND.IKEY.NE.47) THEN
          DO 33 I=1,NVC
          DO 32 J=1,I
          IF(DABS(DX(IBASE+ICELLS+I)-MISSNG).LT..1D-6.OR.
     .         DABS(DX(IBASE+ICELLS+J)-MISSNG).LT..1D-6) THEN
             DX(SDVFLG+ICELLV)=2.D0
          ELSE
             DX(SDVFLG+ICELLV)=1.D0
          END IF
          ICELLV=ICELLV+1
   32     CONTINUE
   33     CONTINUE
        ELSE
          DO 34 I=1,NVC
          IF(DABS(DX(IBASE+ICELLS+I)-MISSNG).LT..1D-6) THEN
             DX(SDVFLG+ICELLV)=2.D0
          ELSE
             DX(SDVFLG+ICELLV)=1.D0
          END IF
          ICELLV=ICELLV+1
   34     CONTINUE
        END IF
      ELSE
        IF(IX(LBASE1+9).EQ.1) THEN
          DO 994 I=1,NVC
          IF(DABS(DX(SDREP+ICELLS+I-1)-MISSNG).GT..1D-06) THEN
            DX(ICENT)=DX(ICENT)+T*(DX(SDREP+ICELLS+I-1)-
     .                             DX(SDTOT+ICELLS+I-1))
          END IF
          ICENT=ICENT+1
  994     CONTINUE
        END IF
        IF(IKEY.GT.40.AND.IKEY.NE.47) THEN
          DO 36 I=1,NVC
          DO 35 J=1,I
          IF(DABS(DX(SDREP+ICELLS+I-1)-MISSNG).LT..1D-6.OR.
     .       DABS(DX(SDREP+ICELLS+J-1)-MISSNG).LT..1D-6) THEN
            IF(DABS(DX(SDVFLG+ICELLV)-2.D0).EQ.1.D0) THEN
              DX(SDVFLG+ICELLV)=3.D0
            END IF
          ELSE IF(DABS(DX(SDREP+ICELLS+I-1)-MISSNG).GT..1D-6.AND.
     .            DABS(DX(SDREP+ICELLS+J-1)-MISSNG).GT..1D-6) THEN
            DX(SDVAR+ICELLV)=DX(SDVAR+ICELLV)+T*
     .               (DX(SDREP+ICELLS+I-1) - DX(SDTOT+ICELLS+I-1))*
     .               (DX(SDREP+ICELLS+J-1) - DX(SDTOT+ICELLS+J-1))
          END IF
          ICELLV=ICELLV+1
   35     CONTINUE
   36     CONTINUE
        ELSE
          DO 38 I=1,NVC
          IF(DABS(DX(SDREP+ICELLS+I-1)-MISSNG).LT..1D-6) THEN
            IF(DABS(DX(SDVFLG+ICELLV)-2.D0).EQ.1.D0) THEN
              DX(SDVFLG+ICELLV)=3.D0
            END IF
          ELSE
            DX(SDVAR+ICELLV)=DX(SDVAR+ICELLV)+T*
     .               (DX(SDREP+ICELLS+I-1) - DX(SDTOT+ICELLS+I-1))*
     .               (DX(SDREP+ICELLS+I-1) - DX(SDTOT+ICELLS+I-1))
          END IF
          ICELLV=ICELLV+1
   38     CONTINUE
        END IF
      END IF
   39 CONTINUE
   40 CONTINUE
      ICELLS=0
      ICELLV=SDVAR
      ICELL=SDTOT
      IV=0
      ICENT=SDCENT
      DO 96 ILIST=1,NLIST
      ICLLVS=ICELLV
      LBASE1=LBASE+NINCR*ILIST
      IKEY=IX(LBASE1+1)
      IPRINT=IX(LBASE1+4)
      IF(IPRINT.EQ.1) THEN
        PRINTX=.TRUE.
      ELSE
        PRINTX=.FALSE.
      END IF
      IWRITE=IX(LBASE1+5)
      IF(IKEY.EQ.40.OR.IKEY.EQ.47) THEN
        IF(IX(LBASE1+9).EQ.1.AND.CSUM.NE.0.) THEN
          DO 995 I=1,IX(LBASE1+3)
          T=DX(ICENT)*DX(ICENT)/CSUM
          IF(T.LE.DX(ICELLV+I-1)) THEN
            DX(ICELLV+I-1)=DX(ICELLV+I-1)-T
          ELSE
            DX(ICELLV+I-1)=0.
          END IF
          ICENT=ICENT+1
  995     CONTINUE
        END IF
        IFTYPE=0
        DO 41 I=1,IX(LBASE1+3)
        IF(DX(ICELLV+I-1).GT.0.) THEN
          DX(ICELLV+I-1)=DSQRT(DX(ICELLV+I-1))
        END IF
   41   CONTINUE
        IF(IWRITE.EQ.1.AND.(OUTFMT.EQ.1.OR.OUTFMT.EQ.2)) THEN
          J=NREQBS+ILIST
          DO 415 I=1,IX(LBASE1+3)
          WRITE(11,151)J,I,DX(ICELL+I-1),DX(ICELLV+I-1)
  415     CONTINUE
        END IF
        IV2END=1
        IV2INC=1
      ELSE
        IV2END=IX(LBASE1+3)
        IF(IX(LBASE1+9).EQ.1.AND.CSUM.NE.0.) THEN
          K=0
          DO 997 I=1,IV2END
          DO 996 J=1,I
          T=DX(ICENT+I-1)*DX(ICENT+J-1)/CSUM
          IF(I.NE.J.OR.T.LE.DX(ICELLV+K)) THEN
            DX(ICELLV+K)=DX(ICELLV+K)-T
          ELSE
            DX(ICELLV+K)=0.
          END IF
          K=K+1
  996     CONTINUE
  997     CONTINUE
          ICENT=ICENT+IV2END
        END IF
        IF(IKEY.EQ.43) THEN
          IFTYPE=1
          J=IX(LBASE1+6)
          IF(J.EQ.132) THEN
            IV2INC=12
          ELSE IF(J.EQ.120) THEN
            IV2INC=11
          ELSE
            IV2INC=6
          END IF
          J=0
          DO 42 I=1,IV2END
          IF(DX(ICELLV+J).GT..0) THEN
            DX(ICELLV+J)=DSQRT(DX(ICELLV+J))
          END IF
          J=J+I+1
   42     CONTINUE
          K3=1
          DO 45 I=2,IV2END
          K1=(I*(I+1))/2-1
          DO 44 J=1,I-1
          K2=(J*(J+1))/2-1
          IF(DX(ICELLV+K1).GT.0..AND.
     .       DX(ICELLV+K2).GT.0.) THEN
            DX(ICELLV+K3)=DX(ICELLV+K3)/
     .        (DX(ICELLV+K1)*DX(ICELLV+K2))
          END IF
          K3=K3+1
   44     CONTINUE
          K3=K3+1
   45     CONTINUE
          J=0
          DO 46 I=1,IV2END
          IF(DX(ICELLV+J).GT..0) THEN
            DX(ICELLV+J)=1.D0
          END IF
          J=J+I+1
   46     CONTINUE
        ELSE IF(IKEY.EQ.45) THEN
          IFTYPE=1
          J=IX(LBASE1+6)
          IF(J.EQ.132) THEN
            IV2INC=12
          ELSE IF(J.EQ.120) THEN
            IV2INC=11
          ELSE
            IV2INC=6
          END IF
          K3=1
          DO 49 I=2,IV2END
          K1=(I*(I+1))/2-1
          DO 48 J=1,I-1
          K2=(J*(J+1))/2-1
          IF((DX(ICELLV+K1).GT.0..OR.
     .       DX(ICELLV+K2).GT.0.).AND.
     .       DABS(DX(ICELL+I-1)-MISSNG).GT..1D-6.AND.
     .       DABS(DX(ICELL+J-1)-MISSNG).GT..1D-6) THEN
            TVAR=DX(ICELLV+K1)+DX(ICELLV+K2)
     .        -2.0D0*DX(ICELLV+K3)
            IF(TVAR*TVAR.GT..1D-12*DX(ICELLV+K1)*
     .                             DX(ICELLV+K2)) THEN
               DX(ICELLV+K3)=
     .            (DX(ICELL+I-1)-DX(ICELL+J-1))/
     .             DSQRT(TVAR)
              IF(DX(ICELLV+K3).GT.999.999D0) THEN
                DX(ICELLV+K3)=999.999D0
              ELSE IF(DX(ICELLV+K3).LT.-999.999D0) THEN
                DX(ICELLV+K3)=-999.999D0
              END IF
            ELSE
              DX(ICELLV+K3)=0.
            END IF
          END IF
          K3=K3+1
   48     CONTINUE
          K3=K3+1
   49     CONTINUE
          J=0
          DO 50 I=1,IV2END
          DX(ICELLV+J)=0.
          J=J+I+1
   50     CONTINUE
        ELSE
          IFTYPE=2
          J=IX(LBASE1+6)
          IF(J.EQ.132) THEN
            IV2INC=6
          ELSE IF(J.EQ.120) THEN
            IV2INC=5
          ELSE
            IV2INC=3
          END IF
        END IF
        IF(IWRITE.EQ.1.AND.(OUTFMT.EQ.1.OR.OUTFMT.EQ.2)) THEN
          L=NREQBS+ILIST
          DO 60 I=1,IX(LBASE1+3)
          JSTART=1
          IF(OUTFMT.EQ.1) THEN
            IF(IKEY.EQ.41) THEN
              JEND=JSTART+2
            ELSE
              JEND=JSTART+5
            END IF
          ELSE
            IF(IKEY.EQ.41) THEN
              JEND=JSTART+1
            ELSE
              JEND=JSTART+3
            END IF
          END IF
   51     CONTINUE
          IF(JEND.GT.IX(LBASE1+3))JEND=IX(LBASE1+3)
          K1=0
          DO 52 JJ=JSTART,JEND
          K1=K1+1
          IF(I.GE.JJ) THEN
            K3=(I*(I-1))/2+JJ
          ELSE
            K3=(JJ*(JJ-1))/2+I
          END IF
          DT(K1)=DX(ICELLV+K3-1)
   52     CONTINUE
          IF(JSTART.EQ.1.AND.OUTFMT.EQ.2) THEN
            IF(IKEY.EQ.41) THEN
              WRITE(11,152)L,I,IX(LBASE1+3),DX(ICELL+I-1),
     .          (DT(K3),K3=1,K1)
            ELSE IF(IKEY.EQ.43) THEN
              WRITE(11,154)L,I,IX(LBASE1+3),DX(ICELL+I-1),
     .          (DT(K3),K3=1,K1)
            ELSE
              WRITE(11,156)L,I,IX(LBASE1+3),DX(ICELL+I-1),
     .          (DT(K3),K3=1,K1)
            END IF
          ELSE
            IF(IKEY.EQ.41) THEN
              WRITE(11,153)L,I,IX(LBASE1+3),(DT(K3),K3=1,K1)
            ELSE IF(IKEY.EQ.43) THEN
              WRITE(11,155)L,I,IX(LBASE1+3),(DT(K3),K3=1,K1)
            ELSE
              WRITE(11,157)L,I,IX(LBASE1+3),(DT(K3),K3=1,K1)
            END IF
          END IF
          JSTART=JEND+1
          IF(IKEY.EQ.41) THEN
            JEND=JSTART+2
          ELSE
            JEND=JSTART+5
          END IF
          IF(JSTART.LE.IX(LBASE1+3))GO TO 51
   60     CONTINUE
        END IF
      END IF
      LINE=2
      IF(IPRINT.EQ.1) THEN
        IF(IKEY.EQ.40.OR.IKEY.EQ.47) THEN
          WRITE(U6,101)
        ELSE IF(IKEY.EQ.41) THEN
          WRITE(U6,102)
        ELSE IF(IKEY.EQ.43) THEN
          WRITE(U6,107)
        ELSE IF(IKEY.EQ.45) THEN
          WRITE(U6,108)
        END IF
        IF(NBY.GT.0) THEN
          K=SDBYID+NBY*(IBYGRP-1)
          IF(VFTYPE.LE.4.OR.VFTYPE.GE.13) THEN
            L=NVREG+NCLASS+NVARID+1
          ELSE
            L=NVREG+NCLASS+NVARID
          END IF
          DO 300 I=1,NBY
          IF(MTYPE(L).EQ.5) THEN
            ITEMP=DX(K)+.05D0
            WRITE(U6,105)LABEL(L),LEVEL(LPOINT(L)+ITEMP-1)
          ELSE
            WRITE(U6,106)LABEL(L),DX(K)
          END IF
          LINE=LINE+1
          L=L+1
          K=K+1
  300     CONTINUE
        END IF
      END IF
      ICHEAD=IX(LBASE+NINCR*ILIST+7)
      IF(IWRITE.EQ.1.AND.(OUTFMT.EQ.3.OR.OUTFMT.EQ.4)) THEN
        WRITEX=.TRUE.
      ELSE
        WRITEX=.FALSE.
      END IF
      NREQST=NREQBS+ILIST
      IF(IKEY.EQ.40.AND.ICHEAD.EQ.1) THEN
        K=LBASE+NINCR*ILIST+1
        CALL LIST(IV,ICELL,ICELLV,IX(K),LINE,PRINTX,WRITEX,NREQST,
     .    IXSIZ2)
        GO TO 96
      ELSE IF(ICHEAD.EQ.1) THEN
        K=LBASE+NINCR*ILIST+1
        CALL COVLST(IV,ICELL,ICELLV,IX(K),IV2INC,IV2END,PRINTX,WRITEX,
     .    NREQST)
        GO TO 96
      END IF
   96 CONTINUE
   99 CONTINUE
      IF(END13) THEN
        CLOSE(12)
        INQUIRE(UNIT=11,OPENED=WRITEX)
        IF(WRITEX)CLOSE(11)
        RETURN
      ELSE
        REWIND(12)
        NXPTI=NXPTIS
        NXPTD=NXPTDS
        CALL PREAMB
        SDCOEF=SDCOSV
        SDBYID=SDBYSV
        GO TO 1
      END IF
      END
      SUBROUTINE LIST(IV,ICELL,ICELLV,IOPTN,LINE,PRINTX,WRITEX,NREQST,
     . IXSIZ2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
C
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
C
      PARAMETER (MDSZI=MSIZEI+6*MRANGE+2*MRNSET+3*MVAR)
      PARAMETER (IXFLLD=56+3*MAXIDS)
      PARAMETER (NPOPTN=5)
      PARAMETER (NINCR=NPOPTN+3)
      PARAMETER (MAXLST=20)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
C
      COMMON /STMBLK/IX,RSTPNT,RCTYPE,V1,V2,V3,MXSIZE
      INTEGER IX(MDSZI),RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),
     . V2(MRECOD),V3(MRECOD),MXSIZE(MVAR)
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID,
     . SDWRK,VKEEPF,OUTFMT,IXFILL(IXFLLD)
      COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,
     . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF,
     . OUTFMT,IXFILL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      DIMENSION IOPTN(NINCR)
      LOGICAL HFIRST,PRINTX,WRITEX
      INTEGER SI1,SI2,SI3,SI4
      CHARACTER *11 VTYPE(7)
      CHARACTER *41 VLINE
C     DOUBLE PRECISION MISSNG
C     DATA MISSNG/-98765.432109D0/
      DATA VTYPE /   'MEAN       ','TOTAL      ','PERCENTS   ',
     . 'VALUE      ','PROPORTION ','WEIGHTED N ','2-WAY PCNT '/
C
  101 FORMAT('1 ')
  105 FORMAT(5X,A24,':',3X,A24)
  107 FORMAT(/,51X,'Estimate',6X,'Standard error',/)
  110 FORMAT(/,' Sample N (wtd) for block',I4,10X,A41)
  111 FORMAT(/,1X,A24,':  ',A11,A41)
  112 FORMAT(/,1X,A24,':  ',A11)
  113 FORMAT(4X,A24,11X,A41)
  114 FORMAT(/,' Crossed values of ',A24,': ',A11)
  115 FORMAT(4X,A24,':  ',A24)
  116 FORMAT(4X,A24)
  117 FORMAT(7X,A24,8X,A41)
  118 FORMAT(7X,A24,8X,A41)
  124 FORMAT(/)
  161 FORMAT(5X,A24,':  TOTAL')
  162 FORMAT(33X,A24)
  163 FORMAT(33X,'TOTAL')
  171 FORMAT('99',I4,I6,' 1',I2,2I4,2F22.8)
      SIVMAP=NXPTI
      I=2*NCLASS+1
      CALL ROOMI(I)
      IDCELL=0
        NICL1=IOPTN(2)
        IPAGE=IOPTN(8)
        ICL=1
  301   CONTINUE
        ICHINC=0
        DO 302 ICL2=ICL,NICL1
        IF(V3(ICL2+IV).NE.V3(IV+ICL))GO TO 303
        ICHINC=ICHINC+RSTPNT(IV+ICL2)
  302   CONTINUE
        ICL2=NICL1+1
  303   CONTINUE
        ICL2=ICL2-1
        ICLSS=V3(IV+ICL)
        IF(ICLSS.GT.0) THEN
          ICLX=ICLSS+2
        ELSE
          IX(SIVMAP)=0
          ICLX=0
          NCLV=0
        END IF
  305   CONTINUE
        IF(ICLX.GT.0) THEN
          N=IX(ICLX)
          SI1=NXPTI
          NCLV=IX(ICLX+1)
          IF(NCLV.EQ.0) GO TO 311
          SI2=SI1+NCLV
          J=2*NCLV
          CALL ROOMI(J)
          DO 306 J=0,NCLV-1
          IX(SI1+J)=0
  306     CONTINUE
          IX(SI1)=-1
          J=0
          KICLX=ICLX+3
          DO 310 JJ=1,N
          IF(JJ.LT.N) THEN
            IF(IX(KICLX+3).EQ.IX(KICLX))GO TO 309
          END IF
          IF(IX(KICLX).EQ.0) THEN
            NCLV=0
          ELSE IF(IX(KICLX+2).EQ.0) THEN
            IX(SI2+J)=MSIZE(IX(KICLX))
          ELSE
            IX(SI2+J)=IX(KICLX+2)
          END IF
          J=J+1
  309     CONTINUE
          KICLX=KICLX+3
  310     CONTINUE
  311     CONTINUE
        END IF
  312   CONTINUE
        IF(NCLV.GT.0) THEN
          DO 315 I=1,NCLV
          IX(SI1+I-1)=IX(SI1+I-1)+1
          IF(IX(SI1+I-1).LT.IX(SI2+I-1)) THEN
            IF(I.GT.1) THEN
              DO 314 J=1,I-1
              IX(SI1+J-1)=0
  314         CONTINUE
            END IF
            GO TO 316
          END IF
  315     CONTINUE
          GO TO 342
  316     CONTINUE
          IF(LINE.GT.IPAGE-12) THEN
            IF(PRINTX)WRITE(U6,101)
            LINE=2
          ELSE IF(PRINTX) THEN
            WRITE(U6,124)
            LINE=LINE+2
          END IF
          N=IX(ICLX)
          L=SIVMAP
          DO 320 I=1,NCLV
          J=0
          KICLX=ICLX+3
          DO 319 JJ=1,N
          IF(JJ.EQ.1) THEN
            J=J+1
          ELSE IF(IX(KICLX).NE.IX(KICLX-3)) THEN
            J=J+1
          END IF
          IF(J.NE.I) GO TO 318
          IF(IX(KICLX+2).NE.0) THEN
            IF(IX(KICLX+2).NE.IX(SI1+I-1)+1)GO TO 318
            ICHECK=0
            IF(JJ.GT.1) THEN
              IF(IX(KICLX).EQ.IX(KICLX-3).AND.
     .           IX(KICLX+2).EQ.IX(KICLX-1)) THEN
                IF(IX(KICLX+1).EQ.0) THEN
                  IF(PRINTX)WRITE(U6,163)
                ELSE
                  IVC=IX(KICLX)
                  IF(PRINTX)
     .              WRITE(U6,162)LEVEL(LPOINT(IVC)+IX(KICLX+1)-1)
                END IF
                LINE=LINE+1
                ICHECK=1
              END IF
            END IF
            IF(ICHECK.EQ.0) THEN
              IVC=IX(KICLX)
              IX(L)=IVC-NVREG
              IX(L+1)=IX(KICLX+1)
              L=L+2
              IF(IX(KICLX+1).EQ.0) THEN
                IF(PRINTX)WRITE(U6,161)LABEL(IVC)
              ELSE IF(PRINTX) THEN
                WRITE(U6,105)LABEL(IVC),LEVEL(LPOINT(IVC)+IX(KICLX+1)-1)
              END IF
              LINE=LINE+1
            END IF
          ELSE
            IVC=IX(KICLX)
            IX(L)=IVC-NVREG
            IX(L+1)=IX(SI1+I-1)+1
            L=L+2
            IF(PRINTX)
     .        WRITE(U6,105)LABEL(IVC),LEVEL(LPOINT(IVC)+IX(SI1+I-1))
            LINE=LINE+1
          END IF
  318     CONTINUE
          KICLX=KICLX+3
  319     CONTINUE
  320     CONTINUE
          IX(L)=0
        ELSE
          IF(LINE.GT.IPAGE-7) THEN
            IF(PRINTX)WRITE(U6,101)
            LINE=2
          END IF
        END IF
        IF(PRINTX)WRITE(U6,107)
        LINE=LINE+3
        DO 340 ICL1=ICL,ICL2
        IF(LINE.GT.56) THEN
          IF(PRINTX)WRITE(U6,101)
          LINE=2
        END IF
        IF(V2(IV+ICL1).EQ.9) THEN
          IF(PRINTX) THEN
            CALL FVLINE(DX(ICELL),DX(ICELLV),DX(ICELLV+IXSIZ2),
     .        RCTYPE(IV+ICL1),VLINE)
            WRITE(U6,110)V1(IV+ICL1),VLINE
          END IF
          IF(WRITEX) THEN
            CALL CLWRTE
            IDCELL=IDCELL+1
            II=NVTOT+V1(IV+ICL1)
            I=2
            JJ=1
            WRITE(11,171)NREQST,IDCELL,I,II,JJ,DX(ICELL),DX(ICELLV)
          END IF
          ICELLV=ICELLV+1
          ICELL=ICELL+1
          LINE=LINE+2
        ELSE
          IVX=V1(IV+ICL1)
          ITTYPE=V2(IV+ICL1)
          MT=MTYPE(IVX)
          IF(ITTYPE.EQ.8) THEN
            IFLAG=6
          ELSE IF(MT.EQ.11.OR.MT.EQ.13.OR.MT.EQ.19) THEN
            IFLAG=4
          ELSE IF(ITTYPE.EQ.2.OR.ITTYPE.EQ.4) THEN
            IFLAG=2
          ELSE IF(ITTYPE.EQ.5) THEN
            IFLAG=7
          ELSE IF(ITTYPE.EQ.1.OR.ITTYPE.EQ.3) THEN
            IF(MT.EQ.3.OR.MT.EQ.9) THEN
              IFLAG=3
            ELSE
              IFLAG=1
            END IF
          ELSE IF(ITTYPE.EQ.6.OR.ITTYPE.EQ.7) THEN
            IFLAG=5
          END IF
          IF(MT.EQ.1.OR.MT.EQ.2.OR.MT.EQ.11.OR.
     .      (MT.EQ.3.AND.(ITTYPE.EQ.8.OR.MSIZE(IVX).EQ.1)).OR.
     .      (MSIZE(IVX).EQ.2.AND.MT.EQ.3.AND.
     .      (ITTYPE.EQ.3.OR.ITTYPE.EQ.4.OR.ITTYPE.EQ.7))) THEN
            IF(PRINTX) THEN
              CALL FVLINE(DX(ICELL),DX(ICELLV),DX(ICELLV+IXSIZ2),
     .          RCTYPE(IV+ICL1),VLINE)
              WRITE(U6,111)LABEL(IVX),VTYPE(IFLAG),VLINE
            END IF
            IF(WRITEX) THEN
              CALL CLWRTE
              IDCELL=IDCELL+1
              J=1
              WRITE(11,171)NREQST,IDCELL,ITTYPE,IVX,J,DX(ICELL),
     .          DX(ICELLV)
            END IF
            ICELLV=ICELLV+1
            ICELL=ICELL+1
            LINE=LINE+2
          ELSE IF(MT.EQ.3.OR.MT.EQ.13) THEN
            IF(MSIZE(IVX).LE.6) THEN
              IF(LINE+MSIZE(IVX)+2.GT.IPAGE) THEN
                IF(PRINTX)WRITE(U6,101)
                LINE=2
              END IF
            ELSE
              IF(LINE+5.GT.IPAGE) THEN
                IF(PRINTX)WRITE(U6,101)
                LINE=2
              END IF
            END IF
            IF(PRINTX)WRITE(U6,112)LABEL(IVX),VTYPE(IFLAG)
            LINE=LINE+2
            IF(ITTYPE.EQ.3.OR.ITTYPE.EQ.4.OR.ITTYPE.EQ.7) THEN
              II=MSIZE(IVX)-1
            ELSE
              II=MSIZE(IVX)
            END IF
            DO 325 I=1,II
            IF(LINE.GE.IPAGE) THEN
              IF(PRINTX)WRITE(U6,101)
              LINE=2
            END IF
            IF(PRINTX) THEN
              CALL FVLINE(DX(ICELL),DX(ICELLV),DX(ICELLV+IXSIZ2),
     .          RCTYPE(IV+ICL1),VLINE)
              WRITE(U6,113)LEVEL(LPOINT(IVX)+I-1),VLINE
            END IF
            IF(WRITEX) THEN
              CALL CLWRTE
              IDCELL=IDCELL+1
              WRITE(11,171)NREQST,IDCELL,ITTYPE,IVX,II,DX(ICELL),
     .          DX(ICELLV)
            END IF
            LINE=LINE+1
            ICELLV=ICELLV+1
            ICELL=ICELL+1
  325       CONTINUE
          ELSE IF(MT.EQ.8.OR.MT.EQ.9.OR.MT.EQ.19) THEN
            L=LPOINT(IVX)
            K=CDMPNT(IVX)
            HFIRST=.TRUE.
            IF(MT.EQ.8) THEN
              KSIZE=MSIZE(IVX)/2
              KINCR=1
            ELSE IF(ITTYPE.EQ.8) THEN
              KSIZE=MSIZE(IVX)/CROSSD(K+1)
              KINCR=1
            ELSE IF(ITTYPE.EQ.3.OR.ITTYPE.EQ.4.OR.ITTYPE.EQ.7) THEN
              IF(CROSSD(K+1).EQ.1) THEN
                KINCR=1
                KSIZE=MSIZE(IVX)
              ELSE
                KINCR=CROSSD(K+1)-1
                KSIZE=KINCR*MSIZE(IVX)/CROSSD(K+1)
              END IF
            ELSE
              KSIZE=MSIZE(IVX)
              KINCR=CROSSD(K+1)
            END IF
            N=CROSSD(K)
            NM=CROSSD(K+N+1)
            SI3=NXPTI
            SI4=SI3+N
            I=2*N
            CALL ROOMI(I)
            DO 327 I=1,N
            IF(I.EQ.2) THEN
              IX(SI3+I-1)=0
            ELSE
              IX(SI3+I-1)=1
            END IF
            IX(SI4+I-1)=L
            L=L+1+CROSSD(K+I)
  327       CONTINUE
            IF(KINCR.EQ.1) THEN
              IF(CROSSD(K+2).GT.6) THEN
                IF(LINE+N+4.GT.IPAGE) LINE=0
              ELSE
                IF(LINE+N+1+CROSSD(K+2).GT.IPAGE) LINE=0
              END IF
            ELSE
              IF(CROSSD(K+1).GT.6) THEN
                IF(LINE+N+4.GT.IPAGE) LINE=0
              ELSE
                IF(LINE+N+1+CROSSD(K+1).GT.IPAGE) LINE=0
              END IF
            END IF
            IF(LINE.EQ.0) THEN
              IF(PRINTX)WRITE(U6,101)
              LINE=2
            END IF
            IF(PRINTX)WRITE(U6,114)LEVEL(IX(SI4)),VTYPE(IFLAG)
            LINE=LINE+2
  328       CONTINUE
            J=2
  330       CONTINUE
            IX(SI3+J-1)=IX(SI3+J-1)+1
            IF(IX(SI3+J-1).GT.CROSSD(K+J)) THEN
              IF(J.LT.N) THEN
                IX(SI3+J-1)=1
                J=J+1
                GO TO 330
              ELSE
                NXPTI=SI3
              END IF
            ELSE
              IF(J.GT.2.OR.HFIRST) THEN
                IF(HFIRST) THEN
                  JJ=N
                ELSE
                  JJ=J
                END IF
                IF(KINCR.EQ.1) THEN
                  IF(CROSSD(K+2).GT.6) THEN
                    IF(LINE+JJ+2.GT.IPAGE) LINE=0
                  ELSE
                    IF(LINE+JJ-1+CROSSD(K+2).GT.IPAGE) LINE=0
                  END IF
                ELSE
                  IF(CROSSD(K+1).GT.6) THEN
                    IF(LINE+JJ+2.GT.IPAGE) LINE=0
                  ELSE
                    IF(LINE+JJ-1+CROSSD(K+1).GT.IPAGE) LINE=0
                  END IF
                END IF
                IF(LINE.EQ.0) THEN
                  IF(PRINTX)WRITE(U6,101)
                  LINE=2
                END IF
                DO 331 I=JJ,3,-1
                IF(PRINTX)WRITE(U6,115)LEVEL(IX(SI4+I-1)),
     .            LEVEL(IX(SI4+I-1)+IX(SI3+I-1))
                LINE=LINE+1
  331           CONTINUE
                HFIRST=.FALSE.
              END IF
              IF(KINCR.EQ.1) THEN
                IF(LINE+2.GT.IPAGE) THEN
                  IF(PRINTX)WRITE(U6,101)
                  LINE=2
                END IF
                IF(IX(SI3+1).EQ.1) THEN
                  IF(PRINTX)WRITE(U6,116)LEVEL(IX(SI4+1))
                  LINE=LINE+1
                END IF
                IF(PRINTX) THEN
                  CALL FVLINE(DX(ICELL),DX(ICELLV),DX(ICELLV+IXSIZ2),
     .              RCTYPE(IV+ICL1),VLINE)
                  WRITE(U6,117)LEVEL(IX(SI4+1)+IX(SI3+1)),VLINE
                END IF
                IF(WRITEX) THEN
                  CALL CLWRTE
                  IDCELL=IDCELL+1
                  WRITE(11,171)NREQST,IDCELL,ITTYPE,IVX,RSTPNT(IV+ICL1),
     .              DX(ICELL),DX(ICELLV)
                END IF
                LINE=LINE+1
                ICELLV=ICELLV+1
                ICELL=ICELL+1
              ELSE
                IF(CROSSD(K+1).LE.6) THEN
                  IF(LINE+CROSSD(K+1)+1.GT.IPAGE) THEN
                    IF(PRINTX)WRITE(U6,101)
                    LINE=2
                  END IF
                END IF
                IF(PRINTX)WRITE(U6,115)LEVEL(IX(SI4+1)),
     .            LEVEL(IX(SI4+1)+IX(SI3+1))
                LINE=LINE+1
                DO 333 I=1,KINCR
                IF(LINE.GT.IPAGE) THEN
                  IF(PRINTX)WRITE(U6,101)
                  LINE=2
                END IF
                IF(PRINTX) THEN
                  CALL FVLINE(DX(ICELL),DX(ICELLV),DX(ICELLV+IXSIZ2),
     .              RCTYPE(IV+ICL1),VLINE)
                  WRITE(U6,118)LEVEL(IX(SI4)+I),VLINE
                END IF
                IF(WRITEX) THEN
                  CALL CLWRTE
                  IDCELL=IDCELL+1
                  WRITE(11,171)NREQST,IDCELL,ITTYPE,IVX,RSTPNT(IV+ICL1),
     .              DX(ICELL),DX(ICELLV)
                END IF
                ICELLV=ICELLV+1
                ICELL=ICELL+1
                LINE=LINE+1
  333           CONTINUE
              END IF
              GO TO 328
            END IF
          END IF
        END IF
  340   CONTINUE
        IF(NCLV.GT.0) GO TO 312
  342   CONTINUE
        IF(ICLSS.GT.0) THEN
          ICLX=ICLX+3+3*IX(ICLX)
          IF(ICLX.LE.ICLSS+3*IX(ICLSS)+1) GO TO 305
        END IF
        ICL=ICL2+1
        IF(ICL.LE.NICL1) GO TO 301
        IV=IV+NICL1
        NXPTI=SIVMAP
        RETURN
      END
      SUBROUTINE FVLINE(V,SE,SEFLAG,ND,VLINE)
      DOUBLE PRECISION V,SE,SEFLAG
      INTEGER ND
      CHARACTER*41 VLINE
      CHARACTER*12 FLINE
      CHARACTER*1 STAR
      DOUBLE PRECISION MISSNG
      DATA MISSNG/-98765.432109D0/
  100 FORMAT('(2F20.',I1,',A1) ')
  101 FORMAT('(2F20.',I2,',A1)')
  102 FORMAT(17X,'(M)',19X,'- ')
      IF(DABS(V-MISSNG).LT..1D-06) THEN
        WRITE(VLINE,102)
      ELSE
        IF(ND.LT.10) THEN
          WRITE(FLINE,100)ND
        ELSE
          WRITE(FLINE,101)ND
        END IF
        IF(DABS(SEFLAG-3.0D0).LT..1D-06) THEN
          STAR='*'
        ELSE
          STAR=' '
        END IF
        WRITE(VLINE,FMT=FLINE)V,SE,STAR
      END IF
      RETURN
      END
      SUBROUTINE COVLST(IV,ICELL,ICELLV,IOPTN,IV2INC,IV2END,PRINTX,
     . WRITEX,NREQST)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
C
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
C
      PARAMETER (MDSZI=MSIZEI+6*MRANGE+2*MRNSET+3*MVAR)
      PARAMETER (IXFLLD=56+3*MAXIDS)
      PARAMETER (NPOPTN=5)
      PARAMETER (NINCR=NPOPTN+3)
      PARAMETER (MAXLST=20)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
C
      COMMON /STMBLK/IX,RSTPNT,RCTYPE,V1,V2,V3,MXSIZE
      INTEGER IX(MDSZI),RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),
     . V2(MRECOD),V3(MRECOD),MXSIZE(MVAR)
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID,
     . SDWRK,VKEEPF,OUTFMT,IXFILL(IXFLLD)
      COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,
     . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF,
     . OUTFMT,IXFILL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
C
      DIMENSION IOPTN(NINCR)
      LOGICAL HFIRST,PRINTX,WRITEX
      INTEGER SI1,SI2,SI3,SI4
      CHARACTER *11 VTYPE(7)
      DOUBLE PRECISION SECOV
      EXTERNAL SECOV
C
C     DOUBLE PRECISION MISSNG,SETEMP
      DOUBLE PRECISION SETEMP
C     DATA MISSNG/-98765.432109D0/
      DATA VTYPE /   'MEAN       ','TOTAL      ','PERCENTS   ',
     . 'VALUE      ','PROPORTION ','WEIGHTED N ','2-WAY PCNT '/
C
  105 FORMAT(5X,A24,':',3X,A24)
  108 FORMAT(1X)
  124 FORMAT(/)
  127 FORMAT(/,31X,6(12X,I4))
  130 FORMAT(/,1X,I4,': Sample N for block',I4,2X,6D16.8)
  131 FORMAT(/,5X,A24,':  ',A11,/,1X,I4,26X,6D16.8)
  132 FORMAT(/,5X,A24,':  ',A11)
  133 FORMAT(1X,I4,': ',A24,6D16.8)
  134 FORMAT(/,5X,'Crossed values of ',A24,': ',A11)
  135 FORMAT(8X,A24,':  ',A24)
  136 FORMAT(8X,A24)
  137 FORMAT(1X,I4,': ',A24,6D16.8)
  138 FORMAT(1X,I4,': ',A24,6D16.8)
  147 FORMAT(/,31X,12(4X,I4))
  150 FORMAT(/,1X,I4,': Sample N for block',I4,2X,12F8.3)
  151 FORMAT(/,5X,A24,':  ',A11,/,1X,I4,26X,12F8.3)
  153 FORMAT(1X,I4,': ',A24,12F8.3)
  157 FORMAT(1X,I4,': ',A24,12F8.3)
  158 FORMAT(1X,I4,': ',A24,12F8.3)
  161 FORMAT(5X,A24,':  TOTAL')
  162 FORMAT(33X,A24)
  163 FORMAT(33X,'TOTAL')
  171 FORMAT('99',I4,I6,2I2,2I4,2F22.8)
  200 FORMAT(1X)
  227 FORMAT(/,39X,'Estimate',5(12X,I4))
  230 FORMAT(/,1X,I4,': Sample N for block',I4,2X,F16.4,5D16.8)
  231 FORMAT(/,5X,A24,':  ',A11,/,1X,I4,26X,F16.4,5D16.8)
  233 FORMAT(1X,I4,': ',A24,F16.4,5D16.8)
  237 FORMAT(1X,I4,': ',A24,F16.4,5D16.8)
  238 FORMAT(1X,I4,': ',A24,F16.4,5D16.8)
  247 FORMAT(/,39X,'Estimate',12(4X,I4))
  250 FORMAT(/,1X,I4,': Sample N for block',I4,2X,F16.4,10F8.3)
  251 FORMAT(/,5X,A24,':  ',A11,/,1X,I4,26X,F16.4,10F8.3)
  253 FORMAT(1X,I4,': ',A24,F16.4,10F8.3)
  257 FORMAT(1X,I4,': ',A24,F16.4,10F8.3)
  258 FORMAT(1X,I4,': ',A24,F16.4,10F8.3)
      SIVMAP=NXPTI
      I=2*NCLASS+1
      CALL ROOMI(I)
      NICL1=IOPTN(2)
      ILTOT=IOPTN(3)
      IKEY=IOPTN(1)
      IKEYC=(IKEY-37)/2
      IV2=1
      ICELLS=ICELL
      ICLLVS=ICELLV
  400 CONTINUE
      ICL=1
      ICELL=ICELLS
      ITOPW=0
      IF(ITOPW.EQ.0) THEN
        IF(IV2.EQ.1) THEN
          IF(IKEY.EQ.41) THEN
            IV2TOP=IV2+IV2INC-2
            IF(IV2TOP.GT.IV2END)IV2TOP=IV2END
            IF(PRINTX)WRITE(U6,227)(ID,ID=IV2,IV2TOP)
          ELSE
            IV2TOP=IV2+IV2INC-3
            IF(IV2TOP.GT.IV2END)IV2TOP=IV2END
            IF(PRINTX)WRITE(U6,247)(ID,ID=IV2,IV2TOP)
          END IF
        ELSE
          IV2TOP=IV2+IV2INC-1
          IF(IV2TOP.GT.IV2END)IV2TOP=IV2END
          IF(IKEY.EQ.41) THEN
            IF(PRINTX)WRITE(U6,127)(ID,ID=IV2,IV2TOP)
          ELSE
            IF(PRINTX)WRITE(U6,147)(ID,ID=IV2,IV2TOP)
          END IF
        END IF
        IF(PRINTX)WRITE(U6,200)
      END IF
  401 CONTINUE
      ICHINC=0
      DO 402 ICL2=ICL,NICL1
      IF(V3(ICL2+IV).NE.V3(IV+ICL))GO TO 403
      ICHINC=ICHINC+RSTPNT(IV+ICL2)
  402 CONTINUE
      ICL2=NICL1+1
  403 CONTINUE
      ICL2=ICL2-1
      ICLSS=V3(IV+ICL)
      IF(ICLSS.GT.0) THEN
        ICLX=ICLSS+2
      ELSE
        IX(SIVMAP)=0
        ICLX=0
        NCLV=0
      END IF
  405 CONTINUE
      IF(ICLX.GT.0) THEN
        N=IX(ICLX)
        IF(IX(ICLX+2).GT.0) THEN
          IMULTF=IX(ICLX+2)
        ELSE
          IMULTF=1
        END IF
        IF(ICHINC*IMULTF+ICELL.LT.IV2+ICELLS) THEN
          ICELL=ICELL+ICHINC*IMULTF
          ICLX=ICLX+3+3*IX(ICLX)
          IF(ICLX.LE.ICLSS+3*IX(ICLSS)+1) GO TO 405
          ICL=ICL2+1
          IF(ICL.LE.NICL1) GO TO 401
        END IF
        SI1=NXPTI
        NCLV=IX(ICLX+1)
        IF(NCLV.EQ.0) THEN
          ICLX=ICLX+3+3*N
          GO TO 411
        END IF
        SI2=SI1+NCLV
        J=2*NCLV
        CALL ROOMI(J)
        DO 406 J=0,NCLV-1
        IX(SI1+J)=0
  406   CONTINUE
        IX(SI1)=-1
        J=0
        KICLX=ICLX+3
        DO 410 JJ=1,N
        IF(JJ.LT.N) THEN
          IF(IX(KICLX+3).EQ.IX(KICLX))GO TO 409
        END IF
        IF(IX(KICLX).EQ.0) THEN
          NCLV=0
        ELSE IF(IX(KICLX+2).EQ.0) THEN
          IX(SI2+J)=MSIZE(IX(KICLX))
        ELSE
          IX(SI2+J)=IX(KICLX+2)
        END IF
        J=J+1
  409   CONTINUE
        KICLX=KICLX+3
  410   CONTINUE
  411   CONTINUE
      ELSE
        IF(ICHINC+ICELL.LT.IV2+ICELLS) THEN
          ICELL=ICELL+ICHINC
          ICL=ICL2+1
          IF(ICL.LE.NICL1) GO TO 401
        END IF
      END IF
  412 CONTINUE
      IF(NCLV.GT.0) THEN
        DO 415 I=1,NCLV
        IX(SI1+I-1)=IX(SI1+I-1)+1
        IF(IX(SI1+I-1).LT.IX(SI2+I-1)) THEN
          IF(I.GT.1) THEN
            DO 414 J=1,I-1
            IX(SI1+J-1)=0
  414       CONTINUE
          END IF
          GO TO 416
        END IF
  415   CONTINUE
        GO TO 442
  416   CONTINUE
        IF(ICHINC+ICELL.LT.IV2+ICELLS) THEN
          ICELL=ICELL+ICHINC
          GO TO 412
        END IF
        IF(PRINTX)WRITE(U6,124)
        N=IX(ICLX)
        L=SIVMAP
        DO 420 I=1,NCLV
        J=0
        KICLX=ICLX+3
        DO 419 JJ=1,N
        IF(JJ.EQ.1) THEN
          J=J+1
        ELSE IF(IX(KICLX).NE.IX(KICLX-3)) THEN
          J=J+1
        END IF
        IF(J.NE.I) GO TO 418
        IF(IX(KICLX+2).NE.0) THEN
          IF(IX(KICLX+2).NE.IX(SI1+I-1)+1)GO TO 418
          ICHECK=0
          IF(JJ.GT.1) THEN
            IF(IX(KICLX).EQ.IX(KICLX-3).AND.
     .         IX(KICLX+2).EQ.IX(KICLX-1)) THEN
              IF(IX(KICLX+1).EQ.0) THEN
                IF(PRINTX)WRITE(U6,163)
              ELSE
                IVC=IX(KICLX)
                IF(PRINTX)
     .            WRITE(U6,162)LEVEL(LPOINT(IVC)+IX(KICLX+1)-1)
              END IF
              ICHECK=1
            END IF
          END IF
          IF(ICHECK.EQ.0) THEN
            IVC=IX(KICLX)
            IX(L)=IVC-NVREG
            IX(L+1)=IX(KICLX+1)
            L=L+2
            IF(IX(KICLX+1).EQ.0) THEN
              IF(PRINTX)WRITE(U6,161)LABEL(IVC)
            ELSE IF(PRINTX) THEN
              WRITE(U6,105)LABEL(IVC),LEVEL(LPOINT(IVC)+IX(KICLX+1)-1)
            END IF
          END IF
        ELSE
          IVC=IX(KICLX)
          IX(L)=IVC-NVREG
          IX(L+1)=IX(SI1+I-1)+1
          L=L+2
          IF(PRINTX)
     .      WRITE(U6,105)LABEL(IVC),LEVEL(LPOINT(IVC)+IX(SI1+I-1))
        END IF
  418   CONTINUE
        KICLX=KICLX+3
  419   CONTINUE
  420   CONTINUE
        IX(L)=0
      END IF
      IF(PRINTX)WRITE(U6,108)
      DO 440 ICL1=ICL,ICL2
      IF(ICELL+RSTPNT(IV+ICL1).LT.IV2+ICELLS) THEN
        ICELL=ICELL+RSTPNT(IV+ICL1)
        GO TO 440
      END IF
      IDCELL=ICELL-ICELLS+1
      ILOC=(IDCELL*(IDCELL-1))/2-1+ICLLVS
      IF(IV2.EQ.1) THEN
        IF(IKEY.EQ.41) THEN
          IV2TOP=IV2+IV2INC-2
        ELSE
          IV2TOP=IV2+IV2INC-3
        END IF
      ELSE
        IV2TOP=IV2+IV2INC-1
      END IF
      IF(IV2TOP.GT.IDCELL)IV2TOP=IDCELL
      IF(V2(IV+ICL1).EQ.9) THEN
        IF(IV2.EQ.1) THEN
          IF(IKEY.EQ.41.AND.PRINTX) THEN
            WRITE(U6,230)IDCELL,V1(IV+ICL1),DX(ICELL),
     .        (DX(ILOC+IV2I),IV2I=IV2,IV2TOP)
          ELSE
            WRITE(U6,250)IDCELL,V1(IV+ICL1),DX(ICELL),
     .        (DX(ILOC+IV2I),IV2I=IV2,IV2TOP)
          END IF
          IF(WRITEX) THEN
            CALL CLWRTE
            II=NVTOT+V1(IV+ICL1)
            I=2
            JJ=1
            J=1
            SETEMP=SECOV(DX(ICLLVS),IDCELL)
            WRITE(11,171)NREQST,IDCELL,IKEYC,I,JJ,J,DX(ICELL),SETEMP
            CALL WRCOV(DX(ICLLVS),IDCELL,ILTOT,IKEY)
          END IF
        ELSE IF(PRINTX) THEN
          IF(IKEY.EQ.41) THEN
            WRITE(U6,130)IDCELL,V1(IV+ICL1),
     .        (DX(ILOC+IV2I),IV2I=IV2,IV2TOP)
          ELSE
            WRITE(U6,150)IDCELL,V1(IV+ICL1),
     .        (DX(ILOC+IV2I),IV2I=IV2,IV2TOP)
          END IF
        END IF
        ICELL=ICELL+1
      ELSE
        IVX=V1(IV+ICL1)
        ITTYPE=V2(IV+ICL1)
        MT=MTYPE(IVX)
        IF(ITTYPE.EQ.8) THEN
          IFLAG=6
        ELSE IF(MT.EQ.11.OR.MT.EQ.13.OR.MT.EQ.19) THEN
          IFLAG=4
        ELSE IF(ITTYPE.EQ.2.OR.ITTYPE.EQ.4) THEN
          IFLAG=2
        ELSE IF(ITTYPE.EQ.5) THEN
          IFLAG=7
        ELSE IF(ITTYPE.EQ.1.OR.ITTYPE.EQ.3) THEN
          IF(MT.EQ.3.OR.MT.EQ.9) THEN
            IFLAG=3
          ELSE
            IFLAG=1
          END IF
        ELSE IF(ITTYPE.EQ.6.OR.ITTYPE.EQ.7) THEN
          IFLAG=5
        END IF
        IF(MT.EQ.1.OR.MT.EQ.2.OR.MT.EQ.11.OR.
     .    (MT.EQ.3.AND.(ITTYPE.EQ.8.OR.MSIZE(IVX).EQ.1)).OR.
     .    (MSIZE(IVX).EQ.2.AND.MT.EQ.3.AND.
     .    (ITTYPE.EQ.3.OR.ITTYPE.EQ.4.OR.ITTYPE.EQ.7))) THEN
          IF(IV2.EQ.1) THEN
            IF(IKEY.EQ.41.AND.PRINTX) THEN
              WRITE(U6,231)LABEL(IVX),VTYPE(IFLAG),IDCELL,
     .          DX(ICELL),(DX(ILOC+IV2I),IV2I=IV2,IV2TOP)
            ELSE IF (PRINTX) THEN
              WRITE(U6,251)LABEL(IVX),VTYPE(IFLAG),IDCELL,
     .          DX(ICELL),(DX(ILOC+IV2I),IV2I=IV2,IV2TOP)
            END IF
            IF(WRITEX) THEN
              CALL CLWRTE
              JJ=1
              SETEMP=SECOV(DX(ICLLVS),IDCELL)
              WRITE(11,171)NREQST,IDCELL,IKEYC,ITTYPE,IVX,JJ,DX(ICELL),
     .          SETEMP
              CALL WRCOV(DX(ICLLVS),IDCELL,ILTOT,IKEY)
            END IF
          ELSE IF(PRINTX) THEN
            IF(IKEY.EQ.41) THEN
              WRITE(U6,131)LABEL(IVX),VTYPE(IFLAG),IDCELL,
     .          (DX(ILOC+IV2I),IV2I=IV2,IV2TOP)
            ELSE
              WRITE(U6,151)LABEL(IVX),VTYPE(IFLAG),IDCELL,
     .          (DX(ILOC+IV2I),IV2I=IV2,IV2TOP)
            END IF
          END IF
          ICELL=ICELL+1
        ELSE IF(MT.EQ.3.OR.MT.EQ.13) THEN
          IF(PRINTX)WRITE(U6,132)LABEL(IVX),VTYPE(IFLAG)
          IF(ITTYPE.EQ.3.OR.ITTYPE.EQ.4.OR.ITTYPE.EQ.7) THEN
            II=MSIZE(IVX)-1
          ELSE
            II=MSIZE(IVX)
          END IF
          DO 425 I=1,II
          IDCELL=ICELL-ICELLS+1
          IF(IDCELL.GE.IV2) THEN
            ILOC=(IDCELL*(IDCELL-1))/2-1+ICLLVS
            IF(IV2.EQ.1) THEN
              IF(WRITEX) THEN
                CALL CLWRTE
                SETEMP=SECOV(DX(ICLLVS),IDCELL)
                WRITE(11,171)NREQST,IDCELL,IKEYC,ITTYPE,IVX,II,
     .            DX(ICELL),SETEMP
                CALL WRCOV(DX(ICLLVS),IDCELL,ILTOT,IKEY)
              END IF
              IF(IKEY.EQ.41) THEN
                IV2TOP=IV2+IV2INC-2
                IF(IV2TOP.GT.IDCELL)IV2TOP=IDCELL
                IF(PRINTX)WRITE(U6,233)IDCELL,LEVEL(LPOINT(IVX)+I-1),
     .            DX(ICELL),(DX(ILOC+IV2I),IV2I=IV2,IV2TOP)
              ELSE
                IV2TOP=IV2+IV2INC-3
                IF(IV2TOP.GT.IDCELL)IV2TOP=IDCELL
                IF(PRINTX)WRITE(U6,253)IDCELL,LEVEL(LPOINT(IVX)+I-1),
     .            DX(ICELL),(DX(ILOC+IV2I),IV2I=IV2,IV2TOP)
              END IF
            ELSE IF(PRINTX) THEN
              IV2TOP=IV2+IV2INC-1
              IF(IV2TOP.GT.IDCELL)IV2TOP=IDCELL
              IF(IKEY.EQ.41) THEN
                WRITE(U6,133)IDCELL,LEVEL(LPOINT(IVX)+I-1),
     .            (DX(ILOC+IV2I),IV2I=IV2,IV2TOP)
              ELSE
                WRITE(U6,153)IDCELL,LEVEL(LPOINT(IVX)+I-1),
     .            (DX(ILOC+IV2I),IV2I=IV2,IV2TOP)
              END IF
            END IF
          END IF
          ICELL=ICELL+1
  425     CONTINUE
        ELSE IF(MT.EQ.8.OR.MT.EQ.9.OR.MT.EQ.19) THEN
          L=LPOINT(IVX)
          K=CDMPNT(IVX)
          HFIRST=.TRUE.
          IF(MT.EQ.8) THEN
            KSIZE=MSIZE(IVX)/2
            KINCR=1
          ELSE IF(ITTYPE.EQ.8) THEN
            KSIZE=MSIZE(IVX)/CROSSD(K+1)
            KINCR=1
          ELSE IF(ITTYPE.EQ.3.OR.ITTYPE.EQ.4.OR.ITTYPE.EQ.7) THEN
            IF(CROSSD(K+1).EQ.1) THEN
              KINCR=1
              KSIZE=MSIZE(IVX)
            ELSE
              KINCR=CROSSD(K+1)-1
              KSIZE=KINCR*MSIZE(IVX)/CROSSD(K+1)
            END IF
          ELSE
            KSIZE=MSIZE(IVX)
            KINCR=CROSSD(K+1)
          END IF
          N=CROSSD(K)
          NM=CROSSD(K+N+1)
          SI3=NXPTI
          SI4=SI3+N
          I=2*N
          CALL ROOMI(I)
          DO 427 I=1,N
          IF(I.EQ.2) THEN
            IX(SI3+I-1)=0
          ELSE
            IX(SI3+I-1)=1
          END IF
          IX(SI4+I-1)=L
          L=L+1+CROSSD(K+I)
  427     CONTINUE
          IF(PRINTX)WRITE(U6,134)LEVEL(IX(SI4)),VTYPE(IFLAG)
  428     CONTINUE
          J=2
  430     CONTINUE
          IX(SI3+J-1)=IX(SI3+J-1)+1
          IF(IX(SI3+J-1).GT.CROSSD(K+J)) THEN
            IF(J.LT.N) THEN
              IX(SI3+J-1)=1
              J=J+1
              GO TO 430
            ELSE
              NXPTI=SI3
            END IF
          ELSE
            IF(J.GT.2.OR.HFIRST) THEN
              IF(HFIRST) THEN
                JJ=N
              ELSE
                JJ=J
              END IF
              IF(ICELL-ICELLS+KINCR.GE.IV2.AND.PRINTX) THEN
                DO 431 I=JJ,3,-1
                WRITE(U6,135)LEVEL(IX(SI4+I-1)),
     .            LEVEL(IX(SI4+I-1)+IX(SI3+I-1))
  431           CONTINUE
              END IF
            END IF
            IF(KINCR.EQ.1) THEN
              IF(ICELL-ICELLS+CROSSD(K+2).GE.IV2) THEN
                IF(HFIRST.OR.IX(SI3+1).EQ.1) THEN
                  IF(PRINTX)WRITE(U6,136)LEVEL(IX(SI4+1))
                  HFIRST=.FALSE.
                END IF
              END IF
              IF(ICELL-ICELLS+1.GE.IV2) THEN
                IDCELL=ICELL-ICELLS+1
                ILOC=(IDCELL*(IDCELL-1))/2-1+ICLLVS
                IF(IV2.EQ.1) THEN
                  IF(WRITEX) THEN
                    CALL CLWRTE
                    SETEMP=SECOV(DX(ICLLVS),IDCELL)
                    WRITE(11,171)NREQST,IDCELL,IKEYC,ITTYPE,IVX,KSIZE,
     .                DX(ICELL),SETEMP
                    CALL WRCOV(DX(ICLLVS),IDCELL,ILTOT,IKEY)
                  END IF
                  IF(IKEY.EQ.41) THEN
                    IV2TOP=IV2+IV2INC-2
                    IF(IV2TOP.GT.IDCELL)IV2TOP=IDCELL
                    IF(PRINTX) THEN
                      WRITE(U6,237)IDCELL,LEVEL(IX(SI4+1)+IX(SI3+1)),
     .                  DX(ICELL),(DX(ILOC+IV2I),IV2I=IV2,IV2TOP)
                    END IF
                  ELSE
                    IV2TOP=IV2+IV2INC-3
                    IF(IV2TOP.GT.IDCELL)IV2TOP=IDCELL
                    IF(PRINTX) THEN
                      WRITE(U6,257)IDCELL,LEVEL(IX(SI4+1)+IX(SI3+1)),
     .                DX(ICELL),(DX(ILOC+IV2I),IV2I=IV2,IV2TOP)
                    END IF
                  END IF
                ELSE
                  IV2TOP=IV2+IV2INC-1
                  IF(IV2TOP.GT.IDCELL)IV2TOP=IDCELL
                  IF(IKEY.EQ.41.AND.PRINTX) THEN
                    WRITE(U6,137)IDCELL,LEVEL(IX(SI4+1)+IX(SI3+1)),
     .                (DX(ILOC+IV2I),IV2I=IV2,IV2TOP)
                  ELSE IF(PRINTX) THEN
                    WRITE(U6,157)IDCELL,LEVEL(IX(SI4+1)+IX(SI3+1)),
     .                (DX(ILOC+IV2I),IV2I=IV2,IV2TOP)
                  END IF
                END IF
              END IF
              ICELL=ICELL+1
            ELSE
              IF(ICELL-ICELLS+KINCR.GE.IV2) THEN
                IF(PRINTX)WRITE(U6,135)LEVEL(IX(SI4+1)),
     .            LEVEL(IX(SI4+1)+IX(SI3+1))
                DO 433 I=1,KINCR
                IDCELL=ICELL-ICELLS+1
                ILOC=(IDCELL*(IDCELL-1))/2-1+ICLLVS
                IF(IDCELL.GE.IV2) THEN
                  IF(IV2.EQ.1) THEN
                    IF(WRITEX) THEN
                      CALL CLWRTE
                      SETEMP=SECOV(DX(ICLLVS),IDCELL)
                      WRITE(11,171)NREQST,IDCELL,IKEYC,ITTYPE,IVX,
     .                  KSIZE,DX(ICELL),SETEMP
                      CALL WRCOV(DX(ICLLVS),IDCELL,ILTOT,IKEY)
                    END IF
                    IF(IKEY.EQ.41) THEN
                      IV2TOP=IV2+IV2INC-2
                      IF(IV2TOP.GT.IDCELL)IV2TOP=IDCELL
                      IF(PRINTX)WRITE(U6,238)IDCELL,LEVEL(IX(SI4)+I),
     .                  DX(ICELL),(DX(ILOC+IV2I),IV2I=IV2,IV2TOP)
                    ELSE
                      IV2TOP=IV2+IV2INC-3
                      IF(IV2TOP.GT.IDCELL)IV2TOP=IDCELL
                      IF(PRINTX)WRITE(U6,258)IDCELL,LEVEL(IX(SI4)+I),
     .                  DX(ICELL),(DX(ILOC+IV2I),IV2I=IV2,IV2TOP)
                    END IF
                  ELSE IF(PRINTX) THEN
                    IV2TOP=IV2+IV2INC-1
                    IF(IV2TOP.GT.IDCELL)IV2TOP=IDCELL
                    IF(IKEY.EQ.41) THEN
                      WRITE(U6,138)IDCELL,LEVEL(IX(SI4)+I),
     .                  (DX(ILOC+IV2I),IV2I=IV2,IV2TOP)
                    ELSE
                      WRITE(U6,158)IDCELL,LEVEL(IX(SI4)+I),
     .                  (DX(ILOC+IV2I),IV2I=IV2,IV2TOP)
                    END IF
                  END IF
                END IF
                ICELL=ICELL+1
  433           CONTINUE
              ELSE
                ICELL=ICELL+CROSSD(K+1)
              END IF
            END IF
            GO TO 428
          END IF
        END IF
      END IF
  440 CONTINUE
      IF(NCLV.GT.0) GO TO 412
  442 CONTINUE
      IF(ICLSS.GT.0) THEN
        NXPTI=SI1
        ICLX=ICLX+3+3*IX(ICLX)
        IF(ICLX.LE.ICLSS+3*IX(ICLSS)+1) GO TO 405
      END IF
      ICL=ICL2+1
      IF(ICL.LE.NICL1) GO TO 401
      IF(IV2.EQ.1) THEN
        IF(IKEY.EQ.41) THEN
          IV2=IV2+IV2INC-1
        ELSE
          IV2=IV2+IV2INC-2
        END IF
      ELSE
        IV2=IV2+IV2INC
      END IF
      IF(IV2.LE.IV2END) GO TO 400
      IV=IV+NICL1
      ICELLV=ICLLVS+(IV2END*(IV2END+1))/2
      NXPTI=SIVMAP
      RETURN
      END
      SUBROUTINE CLWRTE
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
C
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MAXFMT=20)
C
      PARAMETER (MDSZI=MSIZEI+6*MRANGE+2*MRNSET+3*MVAR)
      PARAMETER (IXFLLD=56+3*MAXIDS)
      PARAMETER (NPOPTN=5)
      PARAMETER (NINCR=NPOPTN+3)
      PARAMETER (MAXLST=20)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
C
      COMMON /STMBLK/IX,RSTPNT,RCTYPE,V1,V2,V3,MXSIZE
      INTEGER IX(MDSZI),RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),
     . V2(MRECOD),V3(MRECOD),MXSIZE(MVAR)
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID,
     . SDWRK,VKEEPF,OUTFMT,IXFILL(IXFLLD)
      COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,
     . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF,
     . OUTFMT,IXFILL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
  101 FORMAT('99',78A1)
  102 FORMAT('99',3F22.3)
  141 FORMAT(I1)
  142 FORMAT(I2)
  143 FORMAT(I3)
  144 FORMAT(I4)
      IF(NCLASS.GT.0) THEN
        I=3*NCLASS-2
        NREC=IX(I)
        DO 10 IREC=1,NREC
        L=1
        DO 2 I=1,NCLASS
        IF(IX(L).EQ.IREC)LEN=IX(L+1)+IX(L+2)-3
        L=L+3
    2   CONTINUE
        DO 4 I=1,LEN
        INFRMT(1)(I:I)=' '
    4   CONTINUE
        L=SIVMAP
    6   CONTINUE
        IF(IX(L).EQ.0)GO TO 8
        I=3*IX(L)-2
        IF(IX(I).EQ.IREC) THEN
          J=IX(I+1)-2
          JJ=J+IX(I+2)-1
          IF(IX(I+2).EQ.1) THEN
            WRITE(INFRMT(1)(J:JJ),141)IX(L+1)
          ELSE IF(IX(I+2).EQ.2) THEN
            WRITE(INFRMT(1)(J:JJ),142)IX(L+1)
          ELSE IF(IX(I+2).EQ.3) THEN
            WRITE(INFRMT(1)(J:JJ),143)IX(L+1)
          ELSE IF(IX(I+2).EQ.4) THEN
            WRITE(INFRMT(1)(J:JJ),144)IX(L+1)
          END IF
        END IF
        L=L+2
        GO TO 6
    8   CONTINUE
        WRITE(11,101)(INFRMT(1)(I:I),I=1,LEN)
   10   CONTINUE
      END IF
      IF(NBY.GT.0) THEN
        WRITE(11,102)(DX(I+SDBYID-1),I=1,NBY)
      END IF
      RETURN
      END
      DOUBLE PRECISION FUNCTION SECOV(DXM,IDCELL)
      DOUBLE PRECISION DXM(*)
      II=(IDCELL*(IDCELL+1))/2
      IF(DXM(II).LE.0.) THEN
        SECOV=0.
      ELSE
        SECOV=DSQRT(DXM(II))
      END IF
      RETURN
      END
      SUBROUTINE WRCOV(DXM,IDCELL,NCELL,IKEY)
      DOUBLE PRECISION DXM(*)
      DOUBLE PRECISION DT(6)
  100 FORMAT('96',I4)
  101 FORMAT('97',3D22.14)
  102 FORMAT('98',6F11.8)
      WRITE(11,100)NCELL
      IF(IKEY.EQ.41) THEN
        INCR=3
      ELSE
        INCR=6
      END IF
      DO 20 I=1,NCELL,INCR
      II=I+INCR-1
      IF(II.GT.NCELL)II=NCELL
      J=0
      DO 10 JJ=I,II
      IF(IDCELL.GE.JJ) THEN
        K=(IDCELL*(IDCELL-1))/2+JJ
      ELSE
        K=(JJ*(JJ-1))/2+IDCELL
      END IF
      J=J+1
      DT(J)=DXM(K)
   10 CONTINUE
      IF(IKEY.EQ.41) THEN
        WRITE(11,101)(DT(JJ),JJ=1,J)
      ELSE
        WRITE(11,102)(DT(JJ),JJ=1,J)
      END IF
   20 CONTINUE
      RETURN
      END
C
C  Master routine for DISPLAY step, new syntax.
C  This routine is called from DSETUP.  Unlike DSETUP,
C  the placement of IX in /STMBLK/ here is consistent with RECODX
C  and other routines used to implement the new syntax
C
      SUBROUTINE NDISPL(IPOSSC,ITYPEF,IFILEF)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER ITYPEF(3),IFILEF(3)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MAXFMT=20)
C
      PARAMETER (IXFLLD=56+3*MAXIDS)
      PARAMETER (NPOPTN=9)
      PARAMETER (NOPTN=21)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
C
      COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1,
     . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX
C
      DOUBLE PRECISION RANGE(2,MRANGE)
      INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET),
     . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD),
     . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI)
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID,
     . SDWRK,VKEEPF,OUTFMT,IXFILL(IXFLLD)
      COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,
     . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF,
     . OUTFMT,IXFILL
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
      CHARACTER*256 CARDWK,CARDSV,CARDIM
      COMMON /CMBLK2/CARDWK,CARDSV,CARDIM
C
      PARAMETER (MAXSUB=500,MAXSBL=2000,MAXSNL=24)
      PARAMETER (MAXSBC=6000)
      PARAMETER (MAXALT=5)
      INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL),
     .   U5LCSW
      COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW
C
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
C
      LOGICAL REFRSH,LTEMP
      EXTERNAL REFRSH
C
C
      TSWTCH=4
C                                 ! indicates display step to CMPAR1
      RCEIL(1)=MSIZEI
C                                 ! size of IX in this step
      CALL STBLNK(CARD,1,IPOSSC)
      IPOSSC=IPOSSC+1
      U5LCSW=1
C                                 ! Reset U5LCSW used by REFRSH
      CALL CMPAR1(IX,IPOSSC)
      CALL NDSETP(IX(NLINE+NLINE2+1),IX,IX(NLINE+1),ITYPEF,IFILEF)
C
      RETURN
      END
C
C  Parsing for DISPLAY step, new syntax
C
      SUBROUTINE NDSETP(IXM,LNMAP,LNECHO,ITYPEF,IFILEF)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (IXDIM=13)
      INTEGER IXM(IXDIM,*),LNMAP(*),LNECHO(*)
      INTEGER ITYPEF(3),IFILEF(3)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MAXFMT=20)
C
      PARAMETER (IXFLLD=56+3*MAXIDS)
      PARAMETER (NPOPTN=9)
      PARAMETER (NOPTN=21)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
C
      COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1,
     . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX
C
      DOUBLE PRECISION RANGE(2,MRANGE)
      INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET),
     . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD),
     . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI)
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID,
     . SDWRK,VKEEPF,OUTFMT,IXFILL(IXFLLD)
      COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,
     . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF,
     . OUTFMT,IXFILL
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
      CHARACTER*256 CARDWK,CARDSV,CARDIM
      COMMON /CMBLK2/CARDWK,CARDSV,CARDIM
C
      PARAMETER (MAXSUB=500,MAXSBL=2000,MAXSNL=24)
      PARAMETER (MAXSBC=6000)
      PARAMETER (MAXALT=5)
      INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL),
     .   U5LCSW
      COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW
C
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
C
      LOGICAL REFRSH,LTEMP
      EXTERNAL REFRSH
C
      INTEGER IOPTND(NPOPTN),IOPTNC(NPOPTN)
      INTEGER SICLSS,VTMPSZ
      CHARACTER*5 CWORK5
      CHARACTER*4 CWORK4
      INTEGER INDX(NOPTN)
      INTEGER IVALUE(NOPTN)
      CHARACTER*12 OPTNW(NOPTN)
      DATA OPTNW /    'PRINT       ','NOPRINT     ','WRITE       ',
     . 'NOWRITE     ','LINESIZE    ','CLASSSTUB   ','CLASS_STUB  ',
     . 'CLASSHEAD   ','CLASS_HEAD  ','PAGESIZE    ','CENTER      ',
     . 'CENTERED    ','UNCENTER    ','UNCENTERED  ','OUTFORMAT   ',
     . 'NDECIMAL    ','DECIMAL     ','MEAN        ','MEANS       ',
     . 'TOTAL       ','TOTALS      '/
      DATA INDX/1,1,2,2,3,4,4,4,4,5,6,6,6,6,8,9,9,7,7,7,7/
      DATA IVALUE/1,2,1,2,0,2,2,1,1,0,1,1,2,2,0,4,4,1,1,2,2/
C
C
C
C
C
C
  101 FORMAT(/,1X)
  103 FORMAT(/,5X,'OUTFORMAT SET PREVIOUSLY')
  141 FORMAT(I1)
  142 FORMAT(I2)
  143 FORMAT(I3)
  144 FORMAT(I4)
  151 FORMAT('11',8I4)
  152 FORMAT('12',I4,I2,I4,I2,I4,A12,A24)
  153 FORMAT('13',I2,I4,A12,A24)
  154 FORMAT('14',I4,A24)
  155 FORMAT('15',I4,' 0   0 0   0_N_',A5,4X,'N (wtd) for block ',A4,2X)
  156 FORMAT('16',I4,2I2,2I4)
  157 FORMAT('17',2I4,I2)
  158 FORMAT('18',2I4,2I2)
  170 FORMAT(5X,'OUTFORMAT3 SWITCHED TO OUTFORMAT4')
  171 FORMAT(/,5X,'Format of type 99 record for classes',/,5X,'Positions
     .  Class')
  172 FORMAT(/,5X,'Format of type 99 records for classes',/,5X,'Rec no
     .Positions  Class')
  173 FORMAT(7X,I2,'-',I2,4X,A12)
  174 FORMAT(6X,I4,5X,I2,'-',I2,4X,A12)
  175 FORMAT(/,5X,'MEAN SWITCHED TO TOTAL: ',A12)
  176 FORMAT(/,5X,'NO N FOR: ',A12)
  177 FORMAT(/,5X,'NO N FOR BLOCK:',I4)
  200 FORMAT(' ERROR IN SPECIFICATION')
  201 FORMAT(' UNRECOGNIZED VARIABLE NAME: ',A12)
  202 FORMAT(' CLASS VARIABLE NOT ALLOWED ON LIST: ',A12)
C
      RCEIL(1)=MSIZEI
C                          ! size of IX in this step
      NVIN=NVTOT
      U5ECSV=U5ECHO
      U5ECHO=0
      REWIND(14)
      U5=15
      ILINE=1
      READ(14)CARD
C
C  Most of the routine falls within a loop to 1 CONTINUE.  The loop
C  is over the statements identified and organized by CMPAR1.
C  The listing file has already been written to 13 (all as unformatted
C  character data of length 256).  For each statement, the contents
C  of CARD will be read from 14 and written to 15, which will then
C  be the input read by REFRSH, etc. and parsed in detail here and
C  in related routines.
C
      ENDMRG=.FALSE.
      DO 1 ISTATE=1,NSTATE
C
      REWIND(15)
      U5END=0
C
C  If starting position for this statement is beyond the current
C  position of 14, read necessary records.  Otherwise, restore
C  CARD from CARDSV
C
      IF(ILINE.LT.IXM(8,ISTATE)) THEN
        DO 3 I=ILINE+1,IXM(8,ISTATE)
        READ(14)CARD
    3   CONTINUE
        ILINE=IXM(8,ISTATE)
      ELSE IF(ISTATE.NE.1) THEN
        CARD=CARDSV
      END IF
C
C  LNCNTR is set to the current position in the overall file
C  here.  Calls to REFRSH increment LNCNTR as records are read
C  from 15.
C
      LNCNTR=IXM(8,ISTATE)
C
C  Construct the first line where parsing of the statement should
C  begin in CARDWK.  For safety, blank out any characters leading
C  up to the starting point.
C
      CARDWK=CARD
      I=IXM(9,ISTATE)-1
      CALL STBLNK(CARDWK,1,I)
C
C  If this is also the last line of the statement, blank out
C  anything following the ending ;
C
      IF(ILINE.EQ.IXM(3,ISTATE)) THEN
        K=IXM(4,ISTATE)+1
        CALL STBLNK(CARDWK,K,256)
      END IF
      WRITE(15)CARDWK
C
C  Read and process remaining lines.  In all cases, save the
C  current line from 14 in CARDSV
C
      IF(ILINE.LT.IXM(3,ISTATE)) THEN
        DO 4 I=ILINE+1,IXM(3,ISTATE)
        READ(14)CARD
        IF(I.EQ.IXM(3,ISTATE)) THEN
          CARDSV=CARD
          K=IXM(4,ISTATE)+1
          CARDWK=CARD
          CALL STBLNK(CARDWK,K,256)
          WRITE(15)CARDWK
        ELSE
          WRITE(15)CARD
        END IF
    4   CONTINUE
        ILINE=IXM(3,ISTATE)
      ELSE
        CARDSV=CARD
      END IF
      REWIND(15)
      READ(15)CARD
C
C  IPT is the starting position for parsing.  In many cases, it
C  is the position beyond a key word.
C
      IPT=IXM(9,ISTATE)
C
      IF(IXM(5,ISTATE).NE.16) THEN
C                                      ! inappropriate key word,
        IF(ISTEPC.EQ.1) THEN
C                                      ! unexpected arithmetic statement
          IMERR1=130036
C                                      ! etc.
        ELSE
          IMERR1=130037
        END IF
        ILINE=IXM(1,ISTATE)
        IMERR2=IXM(2,ISTATE)
        CALL CMPRNT(IXM,LNMAP)
      END IF
C
C  AS              8,6
C  SELECT          7,1
C  STEPOPTION      2,15
C  STEP            2,14
C  OPTION          2,11
C  INCORPORATE     8,7
C  OUTPUT CLASS    7,25
C  DROP            7,6
C  KEEP            2,7
C
      IGROUP=IXM(10,ISTATE)
      IKEY=IXM(11,ISTATE)
    1 CONTINUE
      U5ECHO=U5ECSV
      REWIND(14)
      DO 92 ILINE2=1,NLINE2
      U5ECHO=LNECHO(ILINE2)
C     write(*,*)iline2,u5echo
      READ(13)CARDIM
      IF(ILINE2.EQ.1) THEN
        CALL CRDPRN(1)
      ELSE
        CALL CRDPRN(0)
      END IF
   92 CONTINUE
      REWIND(13)
C     VTMPSZ=MVAR-SVTEMP+1
C     IF(NCLASS.GT.0) THEN
C       I=3*NCLASS
C       CALL ROOMI(I)
C     END IF
C
C  For each variable store the number of the block in MXSIZE
C
C     IV=0
C     DO 7 ICLBLK=1,NCLBLK
C     IF(BLVSIZ(ICLBLK).GT.0) THEN
C       DO 6 I=1,BLVSIZ(ICLBLK)
C       IV=IV+1
C       MXSIZE(IV)=ICLBLK
C   6   CONTINUE
C     END IF
C   7 CONTINUE
C     NXPTDS=NXPTD
C     NXPTIS=NXPTI
C     MAXVN=MVAR-NVIN
C
      RETURN
      END
C
C  Start of T1.FOR - Parsing for TRANSFORM Step
C
      SUBROUTINE TSET1
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MAXFMT=20)
C
      PARAMETER (MTRANS=1500,MRANGS=20)
      PARAMETER (MTRSZI=MSIZEI+6*MRANGE-6*MRANGS+2*MRNSET+MRECOD+MVAR)
      PARAMETER (IXFLLD=57+3*MAXIDS)
      PARAMETER (NOPTNG=2,NOPTNP=5,NOPTNM=8,NOPTNR=8,NOPTRS=1,NOPTNX=6)
      PARAMETER (NOPTNW=NOPTNR-2)
      PARAMETER (NOPTNT=2,NOPTNV=7)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
C
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
C
      COMMON /STMBLK/IX,RANGE,RGROUP,RTYPE,RSTPNT,V1,V2,V3,MXSIZE,
     . IOUT,IOUTL
      DOUBLE PRECISION RANGE(2,MRANGS)
      INTEGER IX(MTRSZI),RGROUP(MRANGS),RTYPE(MRANGS),RSTPNT(MRECOD),
     . V1(MRECOD),V2(MRECOD),V3(MRECOD),MXSIZE(MVAR),IOUT(MVAR),
     . IOUTL(MVAR)
C
C  Usage in this subroutine:
C  V1     - Variable number
C  V2     - Transformation code
C  V3     - Pointer to CLASS specification
C  RSTPNT - Size of variable in V1 (ignoring CLASS specification)
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
      INTEGER VTMPSZ
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
      LOGICAL REFRSH,ALPCHK,CLMTCH,ICHECK
      EXTERNAL REFRSH,ALPCHK,CLMTCH,ICHECK
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
      INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID,
     . SDWRK,VKEEPF,IXFILL(IXFLLD)
      COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,
     . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF,
     . IXFILL
C
      COMMON /VABLCK/AVERSN,ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT,
     . ATYPE,AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR,ANID,ANCRSS,ANCRVL,
     . AVNCRS,ANBYGR,ASDBID,ANRPTT,ASDCOF
      INTEGER  AVERSN,ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT,
     . ATYPE,AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR,ANID,ANCRSS,ANCRVL,
     . AVNCRS,ANBYGR,ASDBID,ANRPTT,ASDCOF
C
C
C  Usage in this subroutine:
C
C  BLVSTR  -  (Not used by TRANSFORM step)
C  BLVSIZ  -  read from incoming file only, used to record block numbers
C             in MXSIZE only.  Not updated for new blocks.
C  BLNCLS  -  number of classes in block
C  BLCPNT  -  pointer for classes to CLTYPE
C  BLXSIZ  -  flag to indicate whether block is to be retained
C             Initialized to 1, set to 0 by REMOVE BLOCK
C  CLTYPE  -  used as pointers to class variables
C
      INTEGER ITYPEF(3),IFILEF(3)
      LOGICAL NDEFLT,LTEMP,ENDTRN
C
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
C
      CHARACTER*12 OPTNG(NOPTNG),OPTNP(NOPTNP),OPTNM(NOPTNM),
     . OPTNW(NOPTNR),OPTNRS(NOPTRS),OPTNX(NOPTNX),OPTNT(NOPTNT),
     . OPTNV(NOPTNV)
      INTEGER INDXG(NOPTNG),INDXP(NOPTNP),INDXM(NOPTNM),INDXW(NOPTNR),
     .        INDXRS(NOPTRS),INDXX(NOPTNX),INDXT(NOPTNT),INDXV(NOPTNV)
      INTEGER IVALG(NOPTNG),IVALP(NOPTNP),IVALM(NOPTNM),IVALW(NOPTNR),
     .        IVALRS(NOPTRS),IVALX(NOPTNX),IVALT(NOPTNT),IVALV(NOPTNV)
      DATA OPTNG /    'SLICE       ','NSLICE      '/
      DATA OPTNP /    'NPRINT      ','NREP        ','WIDTH       ',
     .                'NDECIMAL    ','DECIMAL     '/
      DATA OPTNM /    'NROW1       ','NCOL1       ','NROW2       ',
     .                'NCOL2       ','ROW1        ','COL1        ',
     .                'ROW2        ','COL2        '/
      DATA OPTNW /    'BYGROUP     ','CONSTANTS   ','REPLICATE   ',
     .                'CONSTANT    ','FULL        ','NSLICE      ',
     .                'BYREPEAT    ','REPEAT      '/
      DATA OPTNRS/    'NCELL       '/
      DATA OPTNX /    'PERCENT     ','PERCENTILE  ','NBELOW      ',
     .                'BELOW       ','NABOVE      ','ABOVE       '/
      DATA OPTNT /    'INTERNAL    ','EXTERNAL    '/
      DATA OPTNV /    'BYGROUP     ','CONSTANTS   ','REPLICATE   ',
     .                'CONSTANT    ','FULL        ','BYREPEAT    ',
     .                'REPEAT      '/
      DATA INDXG/1,1/
      DATA INDXP/1,1,2,3,3/
      DATA INDXM/1,2,3,4,1,2,3,4/
      DATA INDXW/3,3,3,3,3,4,3,3/
      DATA INDXX/1,1,2,2,3,3/
      DATA INDXV/3,3,3,3,3,3,3/
      DATA INDXRS/1/
      DATA INDXT/1,1/
      DATA IVALG/0,0/
      DATA IVALP/0,0,0,0,0/
      DATA IVALM/0,0,0,0,0,0,0,0/
      DATA IVALW/1,2,3,2,1,0,4,4/
      DATA IVALX/0,0,0,0,0,0/
      DATA IVALRS/1/
      DATA IVALT/0,1/
      DATA IVALV/1,2,3,2,1,4,4/
C
  102 FORMAT(/,5X,'(assigned to block',I4,')')
  205 FORMAT(' UNRECOGNIZED VARIABLE NAME ',A12)
  211 FORMAT(' THIS VARIABLE IS NOT OF TYPE CLASS OR CATEGORICAL - ',A12
     .)
  212 FORMAT(' VARIABLE OF INAPPROPRIATE TYPE - ',A12)
  215 FORMAT(' Variable already exists - ',A12)
  219 FORMAT(' N(BLOCK) WITH BLOCK OUT OF RANGE:',I8)
  228 FORMAT(/,' ****  BEGINNING OF SUBROUTINE',I5)
  229 FORMAT(/,' DUPLICATED CLASS VARIABLE: ',A12)
  230 FORMAT(/,' MEAN UNAVAILABLE: ',A12)
  232 FORMAT(' WARNING: ONE OR MORE VALUES DID NOT APPEAR TO BE INTEGERS
     .')
  233 FORMAT(' TEMPORARY ERROR: new syntax not yet implemented for thi',
     . 's step')
C
C  Initializations.
C    RCEIL(1) - maximum size of integer array, set to parameter value
C    NKEEP    - number of variables in KEEP or DROP statement(s)
C    VKEEPF   - flag to indicate KEEP (1) or DROP (2) statement
C               encountered
C    NPASS    - cumumlative number of variable arguments to subroutines
C    NTRANS   - number of subroutines
C    NXTSTR   - next available position in string (character) array
C               Note: reserve first string as work for REPPRINT.
C               (Multiple calls to REPPRINT may use the same string
C               as working space.)
C    IEXTRN   = 1 use external storage for subroutines such as
C                 SAVEFULL as default
C             = 0 use internal storage as default (which is the default
C                 option for the step)
C    ISOPTN   = 1 step options have been set
C
      RCEIL(1)=MTRSZI
      NKEEP=0
      VKEEPF=0
      NPASS=0
      NTRANS=0
      ENDTRN=.FALSE.
      NXTSTR=2
      IEXTRN=0
      ISOPTN=0
C
C
C  IX(NTRANS*12-11)= Starting location for integer constants
C  IX(NTRANS*12-10) = Starting string number
C  IX(NTRANS*12-9) = Transformation code
C  IX(NTRANS*12-8) = Number of old variables
C  IX(NTRANS*12-7) = Number of modified variables
C  IX(NTRANS*12-6) = Number of new variables
C  IX(NTRANS*12-5) = Starting location for constants
C  IX(NTRANS*12-4) = Number of constants
C  IX(NTRANS*12-3) = Number of strings
C  IX(NTRANS*12-2) = Number of integer constants
C  IX(NTRANS*12-1) = Starting value of NPASS
C  IX(NTRANS*12)   = Pointer to storage for each variable, calculated
C                    in TCREA1 (called subsequently)
C
C  Error call if parameter MTRSZI is too small.
C
      NXPTI=1+12*MTRANS
      IF(NXPTI+12.GT.MTRSZI) THEN
        CALL FESTOP(200001)
      END IF
C
C  Contents of MTYPE, codes for transformations
C     1  =  real variable
C     2  =  real variable with missing checks
C     3  =  categorical variable
C     4  =  class variable, known dimension
C     5  =  by variable, known dimension
C     6  =  by variable, unknown dimension
C     7  =  select transformation (not variable type)
C     8  =  cross variable, real value
C     9  =  cross variable, categorical
C    10  =  copy (not variable type)
C    11  =  derived
C    13  =  crossed derived, single dimension
C    19  =  crossed variable, derived, more than one dimension
C
C  In preparation to call FNREAD, set flags to expect binary input and
C  output.
C
      ITYPEF(1)=2
      ITYPEF(2)=2
      ITYPEF(3)=0
      CALL CRDPRN(3)
      CALL KYFIND(IKEY,IPT)
      CALL FNREAD(IPT,ITYPEF,IFILEF,1,IPOSSC)
      IF(IPOSSC.GT.0) THEN
        WRITE(U6,233)
        CALL FSTOP
      END IF
      IF(IMERR1.GT.0) THEN
        CALL FSTOP
      END IF
C
C  Require that an output be specified.
C
      IF(IFILEF(2).EQ.0) THEN
        CALL FESTOP(200002)
      END IF
C
C  Before calling PREAMB to read the metadata on the input file,
C  initialize all blocks.  (BLXSIZ is set to 0 by REMOVE BLOCK.)
C
      DO 901 ICLBLK=1,MCLBLK
      BLXSIZ(ICLBLK)=1
  901 CONTINUE
      CALL PREAMB
      IF(IPOSSC.GT.0) THEN
        WRITE(U6,233)
        CALL FSTOP
      END IF
C
C  SVTEMP is set in PREAMB to be the next available position, after
C  variable names associated with crossed variables have been stored
C  in VTEMP.  VTMPSZ stores the remaining working space in VTEMP.
C
      VTMPSZ=MVAR-SVTEMP+1
      SDCONS=NXPTD
C
C  SDCONS records the starting position of any specified constants,
C  after space is allocated for input VPLX file.  (PREAMB accesses
C  space for BYGROUP ids and the variance coefficients.)
C
      NVIN=NVTOT
      IV=0
C
C  Store the number of the block for each variable in MXSIZE
C
      DO 7 ICLBLK=1,NCLBLK
      IF(BLVSIZ(ICLBLK).GT.0) THEN
        DO 6 I=1,BLVSIZ(ICLBLK)
        IV=IV+1
        MXSIZE(IV)=ICLBLK
    6   CONTINUE
      END IF
    7 CONTINUE
C
C  NCLBLS saves the number of blocks on the incoming file.  NCLBLK
C  is updated to reflect the total number of blocks as new variables
C  are created during the step.
C
      NCLBLS=NCLBLK
C
    1 CONTINUE
      LTEMP=REFRSH(IPT)
    2 CONTINUE
C
C  If no more instructions remain, conclude specification for the step.
C
      IF(U5END.GT.0) THEN
        IF(U5.GE.13.AND.U5.LE.17) THEN
          GO TO 1
        ELSE
          GO TO 90
        END IF
      END IF
C
      CALL KYFIND(IKEY,IPT)
      IF(IKEY.EQ.33)IKEY=68
      IF((IKEY.GE.1.AND.IKEY.LE.5).OR.IKEY.EQ.9.OR.
     .   (IKEY.GE.11.AND.IKEY.LE.15).OR.
     .   (IKEY.GE.23.AND.IKEY.LE.30).OR.IKEY.EQ.32.OR.IKEY.EQ.33.OR.
     .    IKEY.EQ.35.OR.
     .   (IKEY.GE.37.AND.IKEY.LE.47).OR.IKEY.EQ.49.OR.
     .   (IKEY.GT.91.AND.IKEY.NE.112.AND.IKEY.NE.119.AND.
     .    IKEY.NE.120.AND.((IKEY.LT.161.OR.IKEY.GT.170).AND.
     .    (IKEY.LT.123.OR.
     .       (IKEY.GT.155.AND.IKEY.LT.198)))))GO TO 90
C
C  If a beginning of a subroutine, skip to 77 to conclude processing
C  of any current subroutine and to begin set up for this one.
C
      IF((IKEY.GE.58.AND.IKEY.LE.86).OR.IKEY.EQ.112.OR.IKEY.EQ.119.OR.
     .     IKEY.EQ.120.OR.(IKEY.GE.123.AND.IKEY.LE.155).OR.
     .       (IKEY.GE.161.AND.IKEY.LT.198).OR.IKEY.EQ.17) THEN
        GO TO 77
      END IF
      CALL CRDPRN(1)
C
C  If continuation line without keyword, read next record
C
      IF(IKEY.EQ.-1) THEN
        GO TO 1
      END IF
C
C  CLASS, CATEGORICAL, CAT, MISSING, DERIVED, REAL,
C  CROSSED (REAL, CAT, CATEGORICAL, DERIVED), COUNT
C
      IF((IKEY.GE.6.AND.IKEY.LE.10).OR.IKEY.EQ.31.OR.
     .        (IKEY.GE.53.AND.IKEY.LE.56)) THEN
        IF(IKEY.NE.6) THEN
          IF(NTRANS.EQ.0) THEN
            CALL FESTOP(200004)
          ELSE IF(IX(NTRANS*12-9).EQ.-60) THEN
            CALL FESTOP(200073)
          END IF
        END IF
C
C  Initializations:
C    IBEYND - indicates have read beyond first record.
C    INEXT  - indicates that the first record of the next statement
C             has been read.
C    NDEFLT - logical variable to denote whether default option should
C             be used for characteristics of cat or crossed variable
C
        IBEYND=0
        INEXT=0
        IBLOCK=0
        ICLSS=0
        NDEFLT=.FALSE.
        MAXVN=MVAR-NVIN+1
C
C  Check that it is possible to add at least 1 more variable.
C
        CALL RCHECK(2,NVIN,1)
        CALL VNFIND(IPT,VNAME(NVIN+1),MAXVN,N,IPOS,2,VNAME,NVIN)
        IF(N.LE.0) THEN
          IF(IPT.GT.1) THEN
            CALL FPSTOP(200005,IPT)
          ELSE
            CALL FESTOP(200006)
          END IF
        END IF
        IF(IPT.EQ.1)IBEYND=1
        IF(IPOS.EQ.0)INEXT=1
        ISTART=1
C
C  For CROSS or CROSSED -
C
        IF(IKEY.EQ.31.OR.IKEY.EQ.56) THEN
          ITYPE=0
          CALL VNMTCH('REAL ',VNAME(NVIN+1),1,IPOS2)
          IF(IPOS2.GT.0)ITYPE=8
          CALL VNMTCH('CAT ',VNAME(NVIN+1),1,IPOS2)
          IF(IPOS2.GT.0)ITYPE=9
          CALL VNMTCH('CATEGORICAL ',VNAME(NVIN+1),1,IPOS2)
          IF(IPOS2.GT.0)ITYPE=9
          CALL VNMTCH('DERIVED ',VNAME(NVIN+1),1,IPOS2)
          IF(IPOS2.GT.0)ITYPE=19
C
C  A CROSSED variable is treated as CROSSED REAL
C
          IF(ITYPE.EQ.0) THEN
            ITYPE=8
C
C  Reposition variables in VNAME because first is REAL, CAT, etc.
C
          ELSE
            IF(N.EQ.1) THEN
              CALL FESTOP(200006)
            END IF
            DO 13 I=2,N
            VNAME(NVIN+I-1)=VNAME(NVIN+I)
   13       CONTINUE
            N=N-1
          END IF
C
C  CLASS
C
        ELSE IF(IKEY.EQ.6) THEN
          ITYPE=4
C
C  CAT or CATEGORICAL
C
        ELSE IF(IKEY.EQ.7.OR.IKEY.EQ.8) THEN
          ITYPE=3
C
C  MISSING
C
        ELSE IF(IKEY.EQ.10) THEN
          ITYPE=2
          IMSIZE=2
C
C  DERIVED
C
        ELSE IF(IKEY.EQ.53) THEN
          ITYPE=11
          IMSIZE=1
C
C  REAL
C
        ELSE IF(IKEY.EQ.54) THEN
          ITYPE=1
          IMSIZE=1
C
C  COUNT
C
        ELSE IF(IKEY.EQ.55) THEN
          CALL VNMTCH('N ',VNAME(NVIN+1),1,IPOS2)
          IF(N.NE.1.OR.IPOS2.NE.1) THEN
            CALL FESTOP(200007)
          END IF
          ITYPE=0
          IMSIZE=1
        END IF
C
C  For all cases except COUNT, check that variables have not been
C  previously defined.
C
        IF(IKEY.NE.55) THEN
          DO 16 I=1,N
          CALL VNMTCH(VNAME(NVIN+I),VNAME,NVIN,K)
          IF(K.GT.0) THEN
            WRITE(U6,215)VNAME(NVIN+I)
            CALL FESTOP(200008)
          END IF
C
C  Store variable name as default label.
C
          LABEL(NVIN+I)(1:12)=VNAME(NVIN+I)
          LABEL(NVIN+I)(13:24)='            '
   16     CONTINUE
        END IF
C
C  For CAT, CLASS, CROSSED REAL, CROSSED CAT, CROSSED DERIVED, COUNT
C  read in the dimensions, or set the dimensions under the default
C  option.
C
        IF(ITYPE.EQ.3.OR.ITYPE.EQ.4.OR.ITYPE.EQ.8.OR.ITYPE.EQ.9.OR.
     .     ITYPE.EQ.19.OR.IKEY.EQ.55) THEN
C
C  If have already completed reading, must use default option.
C
          IF(INEXT.EQ.1) THEN
            NDEFLT=.TRUE.
          ELSE
C
C  If IPOS=0, have read all of statement and continuations.  Set
C  INEXT and use default option.
C
            IF(IPOS.EQ.0) THEN
              NDEFLT=.TRUE.
              INEXT=1
            ELSE
C
C  Use default option if encounter /
C
              IF(CARD(IPOS:IPOS).EQ.'/') THEN
                NDEFLT=.TRUE.
              ELSE IF(CARD(IPOS:IPOS).EQ.'(') THEN
                IPOS=IPOS+1
                IF(IPOS.GE.256) THEN
                  IF(.NOT.REFRSH(IPOS)) THEN
                    CALL FESTOP(200009)
                  END IF
                  IBEYND=1
                END IF
              ELSE
                CALL FPSTOP(200010,IPOS)
              END IF
            END IF
          END IF
C
C  Definitions of characteristics provided by the default option.
C
          IF(NDEFLT) THEN
C
C  COUNT and CLASS may not use the default option.
C
            IF(IKEY.EQ.55) THEN
              CALL FESTOP(200011)
            ELSE IF(ITYPE.EQ.4) THEN
              CALL FESTOP(200012)
            END IF
C
C  If the number of NEW variables, counting the ones specified in the
C  statement, exceeds the number of old variables, cannot use the
C  default option.
C
            IF(IX(NTRANS*12-6)+N.GT.IX(NTRANS*12-8)) THEN
              CALL FESTOP(200013)
            END IF
C
C  Save the number of previously defined arguments and the previous
C  number of variables.
C
            NPASSV=NPASS
            NVINSV=NVIN
            DO 60 I=1,N
            CALL RINCR(2,NVIN,1)
C
C  IPASSB points to the matching OLD variable from which the
C  characteristics are to be copied.
C
            IPASSB=IX(NTRANS*12-1)+IX(NTRANS*12-6)+I-1
C
C  The size of the new variable should be copied from RSTPNT of
C  the matching variable.  V2 is set to 0 because no transformation
C  applies to new variables.
C
            MSIZE(NVIN)=RSTPNT(IPASSB)
            CALL RINCR(4,NPASS,1)
            V1(NPASS)=NVIN
            V2(NPASS)=0
            RSTPNT(NPASS)=RSTPNT(IPASSB)
            ITRANB=V2(IPASSB)
C
C  An error occurs if the matching old variable is N(block).
C
            IF(ITRANB.EQ.9) THEN
              CALL FESTOP(200014)
            END IF
            IVB=V1(IPASSB)
            ITYPEB=MTYPE(IVB)
            ITYPET=ITYPE
C
C  For CROSSED DERIVED, distinguish between single-dimensional version
C  (TYPE=13) and multiple dimensions.  Note that N(cat) etc. produces
C  a different dimension from the original.
C
            IF(ITYPE.EQ.19) THEN
C
C  Except for N(cat), assign TYPE=13 for CAT or single-dimensional
C  CROSSED DERIVED.
C
              IF((ITYPEB.EQ.3.OR.ITYPEB.EQ.13).AND.ITRANB.NE.8) THEN
                ITYPET=13
C
C  For N(crossed cat), N(crossed real) or value(crossed real), set
C  TYPE=13 if original dimension 2 => resulting dimension 1.
C
              ELSE IF((ITYPEB.EQ.9.AND.ITRANB.EQ.8).OR.
     .          (ITYPEB.EQ.8.AND.(ITRANB.EQ.8.OR.ITRANB.EQ.10))) THEN
                K=CDMPNT(IVB)
                IF(CROSSD(K).EQ.2)ITYPET=13
              END IF
            END IF
            MTYPE(NVIN)=ITYPET
C
C  Determination of dimensions for the new variable.
C
C  For TYPE=3 or 13 (i.e., CAT or single-dimension CROSSED DERIVED):
C
            IF(ITYPE.EQ.3.OR.ITYPET.EQ.13) THEN
              CDMPNT(NVIN)=0
C
C  For CAT or single-dimensional CROSSED DERIVED, except for N( ),
C  point to the level labels of the matching old variable.
C
              IF((ITYPEB.EQ.3.OR.ITYPEB.EQ.13).AND.ITRANB.NE.8) THEN
                LPOINT(NVIN)=LPOINT(IVB)
C
C  For N(crossed cat), N(crossed real) or value(crossed real), point
C  to the level labels of the second dimension.
C
 
              ELSE IF((ITYPEB.EQ.9.AND.ITRANB.EQ.8).OR.
     .           (ITYPEB.EQ.8.AND.(ITRANB.EQ.8.OR.ITRANB.EQ.10))) THEN
                K=CDMPNT(IVB)
                IF(CROSSD(K).NE.2) THEN
                  CALL FESTOP(200015)
                END IF
                LPOINT(NVIN)=LPOINT(IVB)+CROSSD(K+1)+2
              ELSE
                CALL FESTOP(200016)
              END IF
C
C  For TYPE=9 or 19 (i.e., CROSSED CAT or multi-dimensional CROSSED
C  DERIVED):
C
            ELSE IF(ITYPE.EQ.9.OR.ITYPE.EQ.19) THEN
C
C    Case 1: matching OLD variable is also CROSSED CAT or DERIVED:
C
              IF(ITYPEB.EQ.9.OR.ITYPEB.EQ.19) THEN
C
C  For default trans., PERCENT, MEAN, TOTAL, PERCENT2, PROPORTION or
C  VALUE, copy information from matching OLD variable.
C
                IF(ITRANB.LE.2.OR.ITRANB.EQ.5.OR.ITRANB.EQ.6.OR.
     .             ITRANB.EQ.10) THEN
                  LPOINT(NVIN)=LPOINT(IVB)
                  CDMPNT(NVIN)=CDMPNT(IVB)
C
C  For PERCENT1, TOTAL1, PROPORTION1, copy information out of matching
C  OLD variable, but adjust first dimension.
C
                ELSE IF(ITRANB.EQ.3.OR.ITRANB.EQ.4.OR.ITRANB.EQ.7) THEN
                  K=CDMPNT(IVB)
                  CDMPNT(NVIN)=NCRSSD+1
                  CALL RINCR(10,NCRSSD,1)
                  NK=CROSSD(K)
                  CROSSD(NCRSSD)=NK
                  LP=LPOINT(IVB)
                  LPOINT(NVIN)=NCRVL+1
                  CALL RINCR(10,NCRSSD,1)
                  CROSSD(NCRSSD)=CROSSD(K+1)-1
C
C  Exception:  if the first dimension of the matching variable is 1,
C  set the outcome to 1.
C
                  IF(CROSSD(NCRSSD).LT.1)CROSSD(NCRSSD)=1
                  DO 61 II=1,CROSSD(NCRSSD)+1
                  CALL RINCR(7,NCRVL,1)
                  LEVEL(NCRVL)=LEVEL(LP)
                  LP=LP+1
   61             CONTINUE
                  LP=LPOINT(IVB)+CROSSD(K+1)+1
                  DO 63 II=2,NK
                  CALL RINCR(10,NCRSSD,1)
                  CROSSD(NCRSSD)=CROSSD(K+II)
                  DO 62 III=1,CROSSD(K+II)+1
                  CALL RINCR(7,NCRVL,1)
                  LEVEL(NCRVL)=LEVEL(LP)
                  LP=LP+1
   62             CONTINUE
   63             CONTINUE
                  CALL RINCR(10,NCRSSD,1)
                  CROSSD(NCRSSD)=CROSSD(K+NK+1)
C
C  For N( ), reduce the dimensions by 1, by copy renaming information.
C
                ELSE IF(ITRANB.EQ.8) THEN
                  K=CDMPNT(IVB)
                  CDMPNT(NVIN)=NCRSSD+1
                  CALL RINCR(10,NCRSSD,1)
                  NK=CROSSD(K)
                  CROSSD(NCRSSD)=NK-1
                  LPOINT(NVIN)=LPOINT(IVB)+CROSSD(K+1)+1
                  DO 64 II=2,NK
                  CALL RINCR(10,NCRSSD,1)
                  CROSSD(NCRSSD)=CROSSD(K+II)
   64             CONTINUE
                  CALL RINCR(10,NCRSSD,1)
                  CROSSD(NCRSSD)=CROSSD(K+NK+1)+1
                ELSE
C
C  Error message if wrong function.
C
                  CALL FESTOP(200017)
                END IF
C
C  Case 2: matching variable is crossed real
C
              ELSE IF(ITYPEB.EQ.8) THEN
                IF(ITRANB.EQ.1.OR.ITRANB.EQ.2.OR.ITRANB.EQ.8.OR.
     .             ITRANB.EQ.10) THEN
                  K=CDMPNT(IVB)
                  CDMPNT(NVIN)=NCRSSD+1
                  CALL RINCR(10,NCRSSD,1)
                  NK=CROSSD(K)
C
C  Error message if CROSSED REAL has single categorical.
C
                  IF(NK.EQ.2) THEN
                    CALL FESTOP(200018)
                  END IF
                  CROSSD(NCRSSD)=NK-1
                  LPOINT(NVIN)=LPOINT(IVB)+1
                  DO 65 II=2,NK
                  CALL RINCR(10,NCRSSD,1)
                  CROSSD(NCRSSD)=CROSSD(K+II)
   65             CONTINUE
                  CALL RINCR(10,NCRSSD,1)
                  CROSSD(NCRSSD)=CROSSD(K+NK+1)+1
                ELSE
C
C  Error message if wrong function for CROSSED REAL.
C
                  CALL FESTOP(200019)
                END IF
              ELSE
C
C  Error message if OLD variable is of wrong type, i.e., not CROSSED
C  DERIVED, CROSSED CAT, or CROSSED REAL
C
                CALL FESTOP(200020)
              END IF
C
C  For new CROSSED REAL, only accept if matching variable is CROSSED
C  real, no transformation
C
            ELSE
              IF(ITYPEB.EQ.8.AND.ITRANB.EQ.0) THEN
                LPOINT(NVIN)=LPOINT(IVB)
                CDMPNT(NVIN)=CDMPNT(IVB)
              ELSE
                CALL FESTOP(200021)
              END IF
            END IF
   60       CONTINUE
C
C  At end of loop, restore NPASS and NVIN
C
            NPASS=NPASSV
            NVIN=NVINSV
C
C  Not the default option.
C
C  At this point, have already read "(" and
C  therefore expect specification, e.g., number of levels.
C
          ELSE
            CALL RNSCAN(IPOS,IPOS2,RANGE,MRANGS,RTYPE,RGROUP,
     .        NR,3,LEVEL,1)
            IF(IPOS.EQ.1) THEN
              IBEYND=1
              IF(IPOS2.EQ.0) THEN
                CALL FESTOP(200022)
              END IF
            ELSE IF(IPOS2.EQ.0) THEN
              CALL FPSTOP(200022,IPOS)
            END IF
            IPOS=IPOS2
            IF(IPOS.GE.256) THEN
              IBEYND=1
              IF(.NOT.REFRSH(IPOS))INEXT=1
            END IF
C
C  Distinguish between CROSSED DERIVED of single dimension
C  (TYPE=13) and multiple (TYPE=19)
C
            IF(ITYPE.EQ.19.AND.NR.EQ.1)ITYPE=13
            NCRVLS=NCRVL
C
C  Determine block number for COUNT N(#)
C
            IF(IKEY.EQ.55) THEN
              IF(NR.GT.1.OR.RTYPE(1).NE.1) THEN
                CALL FESTOP(200023)
              END IF
              CALL RINCR(4,NPASS,1)
              V1(NPASS)=RANGE(2,1)
              IF(V1(NPASS).LE.0) THEN
                CALL FESTOP(200023)
              END IF
              V2(NPASS)=9
              IBLOCK=V1(NPASS)
C
C  Determine dimension of categorical, class, and single-dimension
C  crossed derived
C
            ELSE IF(ITYPE.EQ.3.OR.ITYPE.EQ.4.OR.ITYPE.EQ.13) THEN
              IF(NR.GT.1.OR.RTYPE(1).NE.1) THEN
                IF(ITYPE.EQ.13) THEN
                  CALL FESTOP(200024)
                ELSE
                  CALL FESTOP(200025)
                END IF
              END IF
              IMSIZE=RANGE(2,1)
              IF(IMSIZE.LE.0) THEN
                IF(ITYPE.EQ.13) THEN
                  CALL FESTOP(200024)
                ELSE
                  CALL FESTOP(200025)
                END IF
              END IF
              DO 17 I=1,IMSIZE
              CALL RINCR(7,NCRVL,1)
              LEVEL(NCRVL)(1:12)='            '
              LEVEL(NCRVL)(13:24)=LEVEL(NCRVL)(1:12)
   17         CONTINUE
              IF(INEXT.EQ.0) THEN
                CALL LEVELR(IPOS,IPOS2,NL,LEVEL(NCRVLS+1),IMSIZE)
                IF(IPOS.EQ.1)IBEYND=1
                IF(IPOS2.EQ.0)INEXT=1
                IPOS=IPOS2
              END IF
C
C  Provide default labels for levels if blank.
C
              CALL LEVELD(LEVEL(NCRVLS+1),IMSIZE)
C
C  CROSSED REAL, CROSSED CAT, and CROSSED DERIVED of more than one
C  dimension.  Each of these forms requires entries in CROSSD
C
            ELSE
              ICLSV=NCRSSD+1
              IF(ITYPE.EQ.9.OR.ITYPE.EQ.19) THEN
C
C  Compute in IMSIZE the size of the variable.  Initialize IMSIZE to
C  1 for CROSSED CAT and CROSSED DERIVED variables.  The first entry
C  in CROSSD will be the dimension of the variable.
C
                IMSIZE=1
                CALL RINCR(10,NCRSSD,1)
                CROSSD(NCRSSD)=NR
                IF(ITYPE.EQ.9.AND.NR.LT.2) THEN
                  CALL FESTOP(200026)
                END IF
              ELSE
C
C  Initialize IMSIZE to 2 for a CROSSED REAL variable.  CROSSED REAL
C  variables have an initial dimension of 2 and are crossed by each of
C  the specified levels, so store the number of specified levels plus
C  1 as the first entry of CROSSD.
C
                IMSIZE=2
                CALL RINCR(10,NCRSSD,2)
                CROSSD(NCRSSD-1)=NR+1
                CROSSD(NCRSSD)=0
              END IF
C
C  Store dimensions, etc. of new crossed variable(s) in CROSSD
C
              DO 18 I=1,NR
              IF(RTYPE(I).NE.1) THEN
                CALL FESTOP(200027)
              END IF
              CALL RINCR(10,NCRSSD,1)
              CROSSD(NCRSSD)=RANGE(2,I)
              IF(CROSSD(NCRSSD).LE.0) THEN
                CALL FESTOP(200027)
              END IF
              IMSIZE=IMSIZE*CROSSD(NCRSSD)
   18         CONTINUE
              CALL RINCR(10,NCRSSD,1)
              CROSSD(NCRSSD)=SVTEMP
              ICL=ICLSV
              ISVTMP=SVTEMP
C
C  Loop to blank out labels for crossed variables
C
              DO 20 I=1,CROSSD(ICLSV)
              ICL=ICL+1
              VTEMP(SVTEMP)='           '
              DO 19 J=1,CROSSD(ICL)+1
              CALL RINCR(7,NCRVL,1)
              LEVEL(NCRVL)(1:12)=VTEMP(SVTEMP)
              LEVEL(NCRVL)(13:24)=VTEMP(SVTEMP)
   19         CONTINUE
              CALL RINCR(13,SVTEMP,1)
   20         CONTINUE
C
C  VTMPSZ is computed as the remaining space available to VNFIND.
C
              VTMPSZ=MVAR-SVTEMP+1
              ICL=ICLSV
              NCRVL2=NCRVLS+1
C
C  Read in labels for crossed variables, if present
C
              IF(INEXT.EQ.0) THEN
                DO 22 I=1,CROSSD(ICLSV)
                CALL VNFIND(IPOS,VTEMP(ISVTMP),VTMPSZ,NN,IPOS2,3,VNAME,
     .            NVIN)
C
C  Because SVTEMP was already checked, there is enough space to
C  increment ISVTMP without checking it.
C
                ISVTMP=ISVTMP+1
                IF(IPOS.EQ.1)IBEYND=1
                IF(IPOS2.EQ.0)INEXT=1
                IPOS=IPOS2
C
C  Leave loop if no more information provided.
C
                IF(INEXT.EQ.1)GO TO 23
                ICL=ICL+1
                K=CROSSD(ICL)+1
                CALL LEVELR(IPOS,IPOS2,NL,LEVEL(NCRVL2),K)
                NCRVL2=NCRVL2+K
                IF(IPOS.EQ.1)IBEYND=1
                IF(IPOS2.EQ.0)INEXT=1
                IPOS=IPOS2
C
C  Leave loop if no more information provided.
C
                IF(INEXT.EQ.1)GO TO 23
   22           CONTINUE
              END IF
            END IF
          END IF
        END IF
C
C  Top of loop to look for /CLASS and /BLOCK statements
C
   23   CONTINUE
        IF(INEXT.EQ.0.AND.ITYPE.NE.4) THEN
          CALL NBFND2(IPOS,IPOS2)
          IF(IPOS.EQ.1)IBEYND=1
          IF(IPOS2.LE.0) THEN
            INEXT=1
            GO TO 23
          END IF
          IPOS=IPOS2
          IF(CARD(IPOS:IPOS).NE.'/') THEN
            CALL FPSTOP(200028,IPOS)
          END IF
          IPOS=IPOS+1
          IF(IPOS.GT.256) THEN
            IBEYND=1
            IF(.NOT.REFRSH(IPOS))INEXT=1
          END IF
        END IF
C
C  The seemingly redundant conditions recheck the current status
C  of INEXT, which could have been redefined within the previous
C  IF block.
C
        IF(INEXT.EQ.0.AND.ITYPE.NE.4) THEN
C
C  Use VNFIND to locate either CLASS or BLOCK.
C
          CALL VNFIND(IPOS,VTEMP(SVTEMP),VTMPSZ,NN,IPOS2,3,VNAME,
     .          NVIN)
          IF(NN.EQ.0.OR.IPOS2.EQ.0) THEN
            IF(IPOS.GT.1) THEN
              CALL FPSTOP(200029,IPOS)
            ELSE
              CALL FESTOP(200029)
            END IF
          END IF
          IF(IPOS.EQ.1)IBEYND=1
          IPOS=IPOS2
          CALL VNMTCH('CLASS ',VTEMP(SVTEMP),1,J)
C
C  /CLASS
C
          IF(J.EQ.1) THEN
            IF(ICLSS.GT.0) THEN
              CALL FESTOP(200030)
            END IF
C
C  Setup for call to CLSCAN, ensuring that resources are available.
C
            ICLSS=NXPTI
            MAXIA=(MTRSZI-ICLSS-1)/3
            IF(MAXIA.LE.0) THEN
              CALL FESTOP(200031)
            END IF
            MAXRT=(MSIZED-NXPTD+1)/2
            IB=NPASS+N+1
            IF(MVAR-IB.LT.MAXRT)MAXRT=MRECOD-IB+1
            IF(MAXRT.LE.0) THEN
              CALL FESTOP(200032)
            END IF
            CALL CLSCAN(IPOS,IPOS2,IX(ICLSS+2),MAXIA,IX(ICLSS),
     .         VTEMP(SVTEMP),VTMPSZ,DX(NXPTD),MAXRT,V1(IB),V2(IB),
     .         NVIN)
C
C  The following check insures that a single "group" is defined -
C  that is, all class variables are linked as a single product by *
C
            IF(IX(ICLSS).NE.IX(ICLSS+2)+1) THEN
              CALL FESTOP(200033)
            END IF
C
C  Allocate space to save class specification.
C
            K=3*IX(ICLSS)+2
            CALL ROOMI(K)
            J=NXPTI
            K=ICLSS+2
C
C  Edit class specification to insure no duplicates
C
   24       CONTINUE
            NN=IX(K)
            K=K+3
            DO 27 I=1,NN
            IF(I.LT.NN) THEN
              IF(IX(K).EQ.IX(K+3))GO TO 26
            END IF
C
C  We build up a list of class variables starting at NXPTI.  Except
C  for an error call for overflow, this information is not subsequently
C  kept.
C
            IX(J)=IX(K)
            IF(J.GT.NXPTI) THEN
              DO 25 JJ=NXPTI,J-1
              IF(IX(JJ).EQ.IX(J)) THEN
                WRITE(U6,229)VNAME(IX(J))
                CALL FESTOP(200034)
              END IF
   25         CONTINUE
            END IF
            J=J+1
            IF(J.GT.MTRSZI) THEN
              J=MTRSZI+2-NXPTI
              CALL ROOMI(J)
            END IF
   26       CONTINUE
            K=K+3
   27       CONTINUE
C
C  Surviving but nonfunctional code?  The next statement loops back
C  again if there is more to do.  However, this should only occur if
C  there is more than one group, and a check has already been made to
C  ensure only a single group.
C
            IF(K.LT.NXPTI)GO TO 24
C
            IF(IPOS.EQ.1)IBEYND=1
            IF(IPOS2.EQ.0) INEXT=1
            IPOS=IPOS2
            GO TO 23
          ELSE
C
C  /BLOCK
C
            CALL VNMTCH('BLOCK ',VTEMP(SVTEMP),1,J)
            IF(J.EQ.1) THEN
              IF(IBLOCK.GT.0) THEN
                CALL FPSTOP(200035,IPOS)
              END IF
              CALL NBFND2(IPOS,IPOS2)
              IF(IPOS.EQ.1)IBEYND=1
              IPOS=IPOS2
              IF(IPOS.EQ.0) THEN
                CALL FESTOP(200036)
              END IF
              CALL IFIND(CARD(IPOS:256),IPOS,256,IPOS2,IBLOCK)
              IF(IPOS2.LE.0) THEN
                CALL FPSTOP(200036,IPOS)
              END IF
              IPOS=IPOS2
              GO TO 23
            ELSE
              CALL FESTOP(200037)
            END IF
          END IF
        END IF
C
C  Save the current position of NCLBAR
C
        NCLBR2=NCLBAR
C
C  Translate class specification into entries in BLNCLS, etc.
C
        IF(ICLSS.GT.0.AND.ITYPE.NE.4) THEN
          CALL CLFORM(IX(ICLSS+2),IX(ICLSS))
C
C  If no /CLASS specification is given:
C
        ELSE IF(ITYPE.NE.4) THEN
          CALL RINCR(8,NCLBLK,1)
          BLNCLS(NCLBLK)=0
          BLTYPE(NCLBLK)=0
          BLXINC(NCLBLK)=1
        END IF
C
C  If the block was not specified by /BLOCK, look for an existing block
C  matching the /CLASS specification.  NCLBLS is the number of the
C  last block in the input VPLX file.
C
        IF(IBLOCK.EQ.0.AND.ITYPE.NE.4) THEN
          IF(NCLBLK.EQ.NCLBLS+1) THEN
            IBLOCK=NCLBLK
          ELSE
            DO 28 ICLBLK=NCLBLS+1,NCLBLK-1
            IF(CLMTCH(ICLBLK,NCLBLK)) THEN
              NCLBLK=NCLBLK-1
              NCLBAR=NCLBR2
              IBLOCK=ICLBLK
              GO TO 29
            END IF
   28       CONTINUE
            IBLOCK=NCLBLK
   29       CONTINUE
          END IF
          IF(U5ECHO.EQ.1)WRITE(U6,102)IBLOCK
C
C  If there is a /BLOCK specification, check.
C
        ELSE IF(ITYPE.NE.4) THEN
          IF(IKEY.EQ.55)BLTYPE(IBLOCK)=1
          IF(IBLOCK.GT.NCLBLK) THEN
            CALL FESTOP(200038)
          ELSE IF(IBLOCK.LT.NCLBLK) THEN
            IF(.NOT.CLMTCH(IBLOCK,NCLBLK)) THEN
              IF(ICLSS.GT.0) THEN
                CALL FESTOP(200039)
              ELSE
                CALL FESTOP(200040)
              END IF
C
C  If the /BLOCK specification points to a compatible existing block,
C  adjust NCLBLK, NCLBAR to avoid creating a new block.
C
            ELSE IF(IBLOCK.LT.NCLBLK) THEN
              NCLBLK=NCLBLK-1
              NCLBAR=NCLBR2
            END IF
          END IF
        END IF
C
C  Adjust the number of new variables.
C
        IF(ITYPE.NE.4)IX(NTRANS*12-6)=IX(NTRANS*12-6)+N
C
C  For new COUNT variable
C
        IF(IKEY.EQ.55) THEN
          V3(NPASS)=ICLSS
          RSTPNT(NPASS)=1
C
C  All other variables.
C
        ELSE
          DO 30 I=1,N
          CALL RINCR(2,NVIN,1)
C
C  Under the default option, MTYPE, etc. have already been determined.
C  In all other cases, set MTYPE etc. now.
C
          IF(.NOT.NDEFLT) THEN
            MTYPE(NVIN)=ITYPE
            MSIZE(NVIN)=IMSIZE
C
C  For all variables except CLASS
C
            IF(ITYPE.NE.4) THEN
              CALL RINCR(4,NPASS,1)
              V1(NPASS)=NVIN
              V2(NPASS)=0
              V3(NPASS)=ICLSS
              RSTPNT(NPASS)=IMSIZE
              MXSIZE(NVIN)=IBLOCK
              IF(ITYPE.EQ.3.OR.ITYPE.EQ.8.OR.ITYPE.EQ.9.OR.
     .           ITYPE.EQ.13.OR.ITYPE.EQ.19) THEN
                LPOINT(NVIN)=NCRVLS+1
              ELSE
                LPOINT(NVIN)=0
              END IF
              IF(ITYPE.EQ.8.OR.ITYPE.EQ.9.OR.ITYPE.EQ.19)
     .            THEN
                CDMPNT(NVIN)=ICLSV
              ELSE
                CDMPNT(NVIN)=0
              END IF
C
C  For CLASS variables.
C
            ELSE
              MXSIZE(NVIN)=0
              LPOINT(NVIN)=NCRVLS+1
              CDMPNT(NVIN)=0
            END IF
C
C  For default variables, set only information about block placement and
C  /CLASS
C
          ELSE
            CALL RINCR(4,NPASS,1)
            V3(NPASS)=ICLSS
            MXSIZE(NVIN)=IBLOCK
          END IF
   30     CONTINUE
        END IF
C
C  Go to 2 if do not need to read the next input record.
C
        IF(U5END.EQ.1.OR.(ALPCHK(CARD(1:1)).AND.IBEYND.EQ.1))GO TO 2
        GO TO 1
C
C  DROP, KEEP
C
      ELSE IF(IKEY.EQ.18.OR.IKEY.EQ.19) THEN
        IF(VKEEPF.NE.0) THEN
          IF((IKEY.EQ.18.AND.VKEEPF.EQ.1).OR.
     .       (IKEY.EQ.19.AND.VKEEPF.EQ.2)) THEN
            CALL FESTOP(200041)
          END IF
        ELSE IF(IKEY.EQ.18) THEN
          VKEEPF=2
        ELSE
          VKEEPF=1
        END IF
        J=MVAR-NKEEP
        IF(IPT.LE.0) THEN
          IPOS=IPT
          CALL NBFND2(IPOS,IPT)
          IF(IPT.LE.0) THEN
            CALL FESTOP(200042)
          END IF
        END IF
        CALL VNFIND(IPT,VNKEEP(NKEEP+1),J,N,IPOS,2,VNAME,NVIN)
        IF(N.LE.0) THEN
          CALL FESTOP(200042)
        END IF
        NKEEP=NKEEP+N
        IF(IPOS.GT.0) THEN
          CALL FPSTOP(200043,IPOS)
        END IF
        GO TO 2
C
C  LABEL, LABELS
C
      ELSE IF(IKEY.EQ.20) THEN
        CALL RLABEL(IPT,VNAME,NVIN,VTEMP(SVTEMP),VTMPSZ,VTEMP,
     .    MTYPE,LPOINT,CDMPNT,CROSSD,LABEL,LEVEL,NCRVL,MLEVEL,IPOS)
        IF(IPT.EQ.1) THEN
          GO TO 2
        ELSE
          GO TO 1
        END IF
C
C  LEVEL, LEVELS
C
      ELSE IF(IKEY.EQ.21) THEN
        CALL RLEVEL(IPT,VNAME,NVIN,VTEMP(SVTEMP),VTMPSZ,LPOINT,MSIZE,
     .    LEVEL,NCRVL,MLEVEL,IPOS)
        IF(IPT.EQ.1) THEN
          GO TO 2
        ELSE
          GO TO 1
        END IF
C
C  RENAME
C
      ELSE IF(IKEY.EQ.22) THEN
        CALL RENAMV(IPT,VNAME,NVIN,VTEMP(SVTEMP),VTMPSZ,VTEMP,
     .    VNKEEP,NKEEP,MTYPE,LPOINT,CDMPNT,CROSSD,LABEL,LEVEL,IPOS)
        IF(IPT.EQ.1) THEN
          GO TO 2
        ELSE
          GO TO 1
        END IF
C
C  OLD, MODIFY
C
      ELSE IF(IKEY.EQ.50.OR.IKEY.EQ.51) THEN
        IF(NTRANS.EQ.0) THEN
          CALL FESTOP(200004)
        ELSE IF(IX(NTRANS*12-9).EQ.-60) THEN
          CALL FESTOP(200073)
        END IF
        IBEYND=0
        INEXT=0
        ICLSS=0
        MAXOUT=MRECOD-NPASS+1
        IF(MAXOUT.LE.0) THEN
          CALL FESTOP(200067)
        END IF
        CALL VTSCAN(IPT,VNAME,MTYPE,MSIZE,CDMPNT,CROSSD,NVIN,
     .    VTEMP(SVTEMP),VTMPSZ,V1(NPASS+1),V2(NPASS+1),
     .    RSTPNT(NPASS+1),MAXOUT,N,LTOT,IPOS,IERR)
        IF(IERR.EQ.1) THEN
          CALL FESTOP(200044)
        ELSE IF(IERR.EQ.2) THEN
          CALL FESTOP(200045)
        ELSE IF(N.LE.0) THEN
          CALL FESTOP(200046)
        END IF
        IF(IPT.EQ.1)IBEYND=1
        IF(IPOS.EQ.0)INEXT=1
C
C  Edit the list of variables.
C
        DO 41 I=1,N
        IF(V2(NPASS+I).EQ.9) THEN
          IF(V1(NPASS+I).LE.0.OR.V1(NPASS+I).GT.NCLBLK) THEN
            WRITE(U6,219)V1(NPASS+I)
            CALL FESTOP(200047)
          END IF
        ELSE
C
C  For MODIFY, do not permit any transformations
C
          IF(IKEY.EQ.51) THEN
            IF(V2(NPASS+I).NE.0) THEN
              CALL FESTOP(200048)
            END IF
          ELSE
C
C  For OLD, check that MEAN( ) can be computed based on N(block).
C
            IF(V2(NPASS+I).EQ.1) THEN
              K=V1(NPASS+I)
              IF(MTYPE(K).EQ.1) THEN
                IF(BLTYPE(MXSIZE(K)).NE.1) THEN
                  WRITE(U6,230)VNAME(K)
                  CALL FESTOP(200049)
                END IF
              END IF
            END IF
          END IF
        END IF
   41   CONTINUE
   43   CONTINUE
C
C  Check for a / CLASS specification.
C
        IF(INEXT.EQ.0) THEN
          CALL NBFND2(IPOS,IPOS2)
          IF(IPOS.EQ.1)IBEYND=1
          IF(IPOS2.LE.0) THEN
            INEXT=1
            GO TO 43
          END IF
          IPOS=IPOS2
          IF(CARD(IPOS:IPOS).NE.'/') THEN
            CALL FPSTOP(200050,IPOS)
          END IF
          IPOS=IPOS+1
          IF(IPOS.GT.256) THEN
            IBEYND=1
            IF(.NOT.REFRSH(IPOS))INEXT=1
          END IF
        END IF
        IF(INEXT.EQ.0) THEN
          CALL VNFIND(IPOS,VTEMP(SVTEMP),VTMPSZ,NN,IPOS2,3,VNAME,
     .          NVIN)
          IF(NN.EQ.0.OR.IPOS2.EQ.0) THEN
            IF(IPOS.NE.1) THEN
              CALL FPSTOP(200051,IPOS)
            ELSE
              CALL FESTOP(200051)
            END IF
          END IF
          IF(IPOS.EQ.1)IBEYND=1
          IPOS=IPOS2
          CALL VNMTCH('CLASS ',VTEMP(SVTEMP),1,J)
          IF(J.EQ.1) THEN
            IF(ICLSS.GT.0) THEN
              CALL FESTOP(200030)
            END IF
C
C  Set up arrays for call to CLSCAN
C
            ICLSS=NXPTI
            MAXIA=(MTRSZI-ICLSS-1)/3
            MAXRT=MSIZED-NXPTD+1
            IB=NPASS+N+1
            IF(MVAR-IB.LT.MAXRT)MAXRT=MRECOD-IB+1
            IF(MAXRT.LE.0) THEN
              CALL FESTOP(200032)
            END IF
            CALL CLSCAN(IPOS,IPOS2,IX(ICLSS+2),MAXIA,IX(ICLSS),
     .         VTEMP(SVTEMP),VTMPSZ,DX(NXPTD),MAXRT,V1(IB),V2(IB),
     .         NVIN)
C
C  Insure that the class specification is of the form of a single
C  product.
C
            IF(IX(ICLSS).NE.IX(ICLSS+2)+1) THEN
              CALL FESTOP(200033)
            END IF
            K=3*IX(ICLSS)+2
            CALL ROOMI(K)
            IF(IPOS.EQ.1)IBEYND=1
            IF(IPOS2.EQ.0) INEXT=1
            IPOS=IPOS2
C
C  Loop back just in case there is remaining unexpected information.
C
            GO TO 43
          ELSE
            CALL FESTOP(200051)
          END IF
        END IF
C
C  Check if it is necessary to reposition variables.
C
C  For OLD variables, define ISTART to be the first MODIFY variable
C
        IF(IKEY.EQ.50) THEN
          IF(IX(NTRANS*12-7)+IX(NTRANS*12-6).GT.0) THEN
            ISTART=IX(NTRANS*12-1)+IX(NTRANS*12-8)
          ELSE
            ISTART=0
          END IF
C
C  For MODIFY variables, define ISTART to be the first new variable.
C
        ELSE
          IF(IX(NTRANS*12-6).GT.0) THEN
            ISTART=IX(NTRANS*12-1)+IX(NTRANS*12-8)+IX(NTRANS*12-7)
          ELSE
            ISTART=0
          END IF
        END IF
C
C  Working backwards, shift all the pointers from NPASS+N back to ISTART
C  each up by N
C
        IF(ISTART.GT.0) THEN
          IEND=NPASS+N
          CALL RCHECK(4,IEND,N)
          DO 45 I=IEND,ISTART,-1
          V1(I+N)=V1(I)
          V2(I+N)=V2(I)
          V3(I+N)=V3(I)
          RSTPNT(I+N)=RSTPNT(I)
   45     CONTINUE
          ISTART=ISTART-1
C
C  Now move the added variables into their proper place.
C
          DO 46 I=1,N
          V1(I+ISTART)=V1(I+IEND)
          V2(I+ISTART)=V2(I+IEND)
          V3(I+ISTART)=V3(I+IEND)
          RSTPNT(I+ISTART)=RSTPNT(I+IEND)
   46     CONTINUE
        ELSE
          ISTART=NPASS
        END IF
C
C  Checking of class specifications.
C
        DO 47 I=1,N
        K=I+ISTART
        V3(K)=ICLSS
C
C  For OLD variables:
C
        IF(IKEY.EQ.50) THEN
          IF(ICLSS.GT.0) THEN
            IF(V2(K).EQ.9) THEN
              CALL CLCHCK(V1(K),V1(K),V2(K),IX(ICLSS+2),IX(ICLSS+2))
            ELSE
              CALL CLCHCK(MXSIZE(V1(K)),V1(K),V2(K),IX(ICLSS+2),
     .          IX(ICLSS+2))
            END IF
          ELSE
            IF(V2(K).EQ.9) THEN
              CALL CLCHCK(V1(K),V1(K),V2(K),IX,0)
            ELSE
              CALL CLCHCK(MXSIZE(V1(K)),V1(K),V2(K),IX,0)
            END IF
          END IF
C
C  For MODIFY variables:
C
        ELSE
          IF(ICLSS.GT.0) THEN
            IF(V2(K).EQ.9) THEN
              CALL CLCHK3(V1(K),V1(K),V2(K),IX(ICLSS+2),IX(ICLSS+2))
            ELSE
              CALL CLCHK3(MXSIZE(V1(K)),V1(K),V2(K),IX(ICLSS+2),
     .          IX(ICLSS+2))
            END IF
          ELSE
            IF(V2(K).EQ.9) THEN
              CALL CLCHK3(V1(K),V1(K),V2(K),IX,0)
            ELSE
              CALL CLCHK3(MXSIZE(V1(K)),V1(K),V2(K),IX,0)
            END IF
          END IF
        END IF
   47   CONTINUE
C
C  Finally, increment NPASS.  The range of NPASS has been previously
C  checked for validity through the computation of MAXOUT earlier and
C  screening by VTSCAN.
C
        NPASS=NPASS+N
        IF(IKEY.EQ.50) THEN
          IX(NTRANS*12-8)=IX(NTRANS*12-8)+N
        ELSE
          IX(NTRANS*12-7)=IX(NTRANS*12-7)+N
        END IF
        IF(U5END.EQ.1.OR.(ALPCHK(CARD(1:1)).AND.IBEYND.EQ.1))GO TO 2
        GO TO 1
C
C  REMOVE BLOCK
C
      ELSE IF(IKEY.EQ.57) THEN
        IPOS=IPT
        CALL CMATCH(CARD(IPOS:256),IPOS,256,'BLOCK',5,IPOS3,1)
        IF(IPOS3.EQ.0) THEN
          CALL CMATCH(CARD(IPOS:256),IPOS,256,'BLOCKS',6,IPOS3,1)
          IF(IPOS3.EQ.0) THEN
            CALL FPSTOP(200052,IPOS)
          END IF
        END IF
        CALL NBFND2(IPOS3,IPOS)
        IF(IPOS3.EQ.1)IPT=1
        IF(IPOS.EQ.0) THEN
          CALL FESTOP(200053)
        END IF
        CALL IFIND(CARD(IPOS:256),IPOS,256,IPOS2,IBLOCK)
        IF(IPOS2.GT.0) THEN
C
C  This statement was changed in Jan. 1996 to allow REMOVE BLOCK to
C  apply to all blocks.  Previously, an error occurred if IBLOCK was
C  greater than NCLBLS, the number of blocks on the incoming file.
C
          IF(IBLOCK.LE.0.OR.IBLOCK.GT.NCLBLK) THEN
            CALL FPSTOP(200054,IPOS)
          END IF
C
C  Setting BLXSIZ to 0 signals that the block is to be dropped.
C
          BLXSIZ(IBLOCK)=0
          CALL NBFND2(IPOS2,IPOS)
          IF(IPOS2.EQ.1)IPT=1
          IF(IPOS.NE.0) THEN
            CALL FPSTOP(200055,IPOS)
          END IF
C
C  REMOVE BLOCK (range) form:
C
        ELSE
          IF(CARD(IPOS:IPOS).EQ.'(') THEN
            IPOS=IPOS+1
            CALL RNSCAN(IPOS,IPOS2,RANGE,MRANGS,RTYPE,RGROUP,
     .        NR,3,LEVEL,1)
            IF(IPOS.EQ.1)IPT=1
            IF(IPOS2.EQ.0.OR.NR.EQ.0) THEN
              CALL FESTOP(200056)
            END IF
            DO 67 IBLOCK=1,NCLBLK
            DO 673 IR=1,NR
            IF(RTYPE(IR).EQ.5)GO TO 673
            IF(RTYPE(IR).EQ.1.OR.RTYPE(IR).EQ.3.OR.RTYPE(IR).EQ.6) THEN
              IF(DBLE(FLOAT(IBLOCK)).LT.RANGE(1,IR)) GO TO 673
            END IF
            IF(RTYPE(IR).EQ.1.OR.RTYPE(IR).EQ.2) THEN
              IF(DBLE(FLOAT(IBLOCK)).GT.RANGE(2,IR)) GO TO 673
            END IF
            BLXSIZ(IBLOCK)=0
            GO TO 67
  673       CONTINUE
   67       CONTINUE
          ELSE
            CALL FESTOP(200057)
          END IF
        END IF
        IF(IPT.GT.1) THEN
          GO TO 1
        ELSE
          GO TO 2
        END IF
C
C  CONSTANT(S), INTEGER CONSTANT(S), SLICELENGTH, SLICE_LENGTH
C
      ELSE IF(IKEY.EQ.52.OR.(IKEY.GE.89.AND.IKEY.LE.91)) THEN
        IF(NTRANS.EQ.0) THEN
          CALL FESTOP(200004)
        END IF
C
        INEXT=0
C
C  For INTEGER CONSTANT(S)
C
        IF(IKEY.EQ.89) THEN
          IF(IPT.LE.0) THEN
            CALL NBFND2(IPT,IPOS)
            IF(IPOS.GT.0) THEN
              IPT=IPOS
            ELSE
              CALL FESTOP(200061)
            END IF
          END IF
          CALL CMATCH(CARD(IPT:256),IPT,256,'CONSTANT',8,IPOS,1)
          IF(IPOS.GT.0) THEN
            IPT=IPOS
          ELSE
            CALL CMATCH(CARD(IPT:256),IPT,256,'CONSTANTS',9,IPOS,1)
            IF(IPOS.GT.0)IPT=IPOS
          END IF
        END IF
        I=IX(NTRANS*12-9)
C
C  Force interpretation of CONSTANTS, ignoring INTEGER CONSTANTS,
C  for ADD, SUBTRACT, etc., and VPLX_APPEND
C
        IF((I.GE.-14.AND.I.LE.-1).OR.I.EQ.-60) THEN
          IKEY=52
C
C  Force intepretation of INTEGER CONSTANTS for GLUE and REPPRINT.
C
        ELSE IF(I.EQ.-15.OR.I.EQ.-16) THEN
          IKEY=89
        END IF
C
C  Constants:
C
        IF(IKEY.EQ.52) THEN
          IF(IX(NTRANS*12-5).GT.0) THEN
            CALL FESTOP(200058)
          ELSE
            IX(NTRANS*12-5)=NXPTD
          END IF
C
C  For REPREAD, REPWRITE, BINARYREAD, and BINARYWRITE, don't permit
C  specification of integer constants.
C
        ELSE IF(IX(NTRANS*12-9).GE.-20.AND.IX(NTRANS*12-9).LE.-17)
     .      THEN
          IF(IKEY.EQ.89.OR.IX(NTRANS*12-9).EQ.-19.OR.
     .       IX(NTRANS*12-9).EQ.-20) THEN
            CALL FESTOP(200059)
C
C  Space has already been allocated to integer constants to translate
C  options.  Move previous values.
C
          ELSE
            K=IX(NTRANS*12-11)
            IX(NTRANS*12-11)=NXPTI
            CALL ROOMI(4)
            IX(NXPTI-4)=IX(K)
            IX(NXPTI-3)=IX(K+1)
            IX(NXPTI-2)=IX(K+2)
            IX(NXPTI-1)=IX(K+3)
          END IF
          K=NXPTD
C
C  Other instances of INTEGER CONSTANTS
C
        ELSE
          IF(IX(NTRANS*12-2).GT.0) THEN
            CALL FESTOP(200060)
          ELSE
            IX(NTRANS*12-11)=NXPTI
          END IF
          K=NXPTD
        END IF
        L=SIZED-NXPTD+1
C
C  Read in values with DASCAN (double precision) regardless of whether
C  CONSTANTS or INTEGER CONSTANTS
C
        CALL DASCAN(IPT,IPOS2,DX(NXPTD),L,N)
        IF(N.LE.0) THEN
          IF(IPOS2.GT.0) THEN
            CALL FPSTOP(200061,IPOS2)
          ELSE
            CALL FESTOP(200061)
          END IF
        END IF
C
C  Translate double precision into integer values.
C
        IF(IKEY.GE.89.AND.IKEY.LE.91) THEN
          NXPTD=K
          L=NXPTI
          CALL ROOMI(N)
          LL=0
          DO 68 I=1,N
          IF(.NOT.ICHECK(DX(K),DVALU2))LL=1
          IF(DX(K).LT.0.) THEN
            IX(L)=DX(K)-.5D-01
          ELSE
            IX(L)=DX(K)+.5D-01
          END IF
          K=K+1
          L=L+1
   68     CONTINUE
          IF(LL.EQ.1) THEN
            WRITE(U6,232)
          END IF
          IX(NTRANS*12-2)=IX(NTRANS*12-2)+N
        ELSE
          IX(NTRANS*12-4)=N
          CALL ROOMD(N)
C
C  For SIPPCOL, CONSTANTS represent scale values.  Allocate an
C  additional bank of 0's for calculation.
C
          IF(IX(NTRANS*12-9).EQ.-24.OR.IX(NTRANS*12-9).EQ.-61) THEN
            CALL ROOMD(N)
            IX(NTRANS*12-4)=2*N
            K=IX(NTRANS*12-5)+N
            DO 69 I=1,N
            DX(K)=0.
            K=K+1
   69       CONTINUE
          END IF
        END IF
        IF(IPT.EQ.1.OR.INEXT.EQ.1) THEN
          GO TO 2
        ELSE
          GO TO 1
        END IF
C
C  STRING, FORMAT, LONGSTRING
C
      ELSE IF(IKEY.EQ.16.OR.IKEY.EQ.87.OR.IKEY.EQ.88) THEN
        IF(NTRANS.EQ.0) THEN
          CALL FESTOP(200004)
        ELSE IF(IX(NTRANS*12-9).EQ.-60) THEN
          CALL FESTOP(200073)
        END IF
C
C  If have run out of space, call RCHECK to generate fatal error.
C
        IF(NXTSTR.EQ.0) THEN
          CALL RCHECK(11,MAXFMT,2)
        END IF
        DO 70 I=1,128
        INFRMT(NXTSTR)(I:I)=' '
   70   CONTINUE
        K=1
   71   CONTINUE
        CALL NBFND2(IPT,IPOS)
        IF(IPOS.LE.0) THEN
          NXTSTR=NXTSTR+1
          IX(NTRANS*12-3)=IX(NTRANS*12-3)+1
          IF(NXTSTR.GT.MAXFMT)NXTSTR=0
          GO TO 2
        END IF
        DO 72 J=256,IPOS,-1
        IF(CARD(J:J).NE.' ')GO TO 73
   72   CONTINUE
   73   CONTINUE
        J=J+1
        DO 75 I=IPOS,J
        IF(K.GT.128) THEN
C
C  Fatal error for STRING if exceed 128
C
          IF(IKEY.EQ.87) THEN
            CALL FPSTOP(200062,I)
          ELSE
            NXTSTR=NXTSTR+1
            IX(NTRANS*12-3)=IX(NTRANS*12-3)+1
C
C  Fatal error if out of space.
C
            IF(NXTSTR.GT.MAXFMT) THEN
              CALL RCHECK(11,MAXFMT,2)
            END IF
            DO 74 K=1,128
            INFRMT(NXTSTR)(K:K)=' '
   74       CONTINUE
            K=1
          END IF
        END IF
        IF(I.LE.256) THEN
          INFRMT(NXTSTR)(K:K)=CARD(I:I)
        ELSE
          INFRMT(NXTSTR)(K:K)=' '
        END IF
        K=K+1
   75   CONTINUE
        IPT=J
        GO TO 71
C
C  OPTION
C
      ELSE IF(IKEY.EQ.36) THEN
        IF(NTRANS.GT.0) THEN
C
C  OPTIONS: GLUE
C
          IF(IX(NTRANS*12-9).EQ.-15) THEN
            IX(NXPTI)=0
            CALL OPTNTR(NOPTNG,INDXG,IVALG,OPTNG,IPT,IPOS,IX(NXPTI))
C
C  If SLICELENGTH or INTEGER CONSTANTS have already been established,
C  cannot also give NSLICE.
C
C  The value originally stored is multiplied by -1.  This was probably
C  used as a program signal but could now be done in a different way?
C
            IF(IX(NXPTI).GT.0) THEN
              IF(IX(NTRANS*12-2).GT.0) THEN
                CALL FESTOP(200063)
              END IF
              IX(NTRANS*12-11)=NXPTI
              IX(NTRANS*12-2)=1
              IX(NXPTI)=-IX(NXPTI)
              CALL ROOMI(1)
            END IF
C
C  OPTIONS: REPPRINT
C    1. NPRINT, NREP
C    2. WIDTH
C    3. NDECIMAL
C
          ELSE IF(IX(NTRANS*12-9).EQ.-16) THEN
            IX(NXPTI)=-1
            IX(NXPTI+1)=0
            IX(NXPTI+2)=-1
            CALL OPTNTR(NOPTNP,INDXP,IVALP,OPTNP,IPT,IPOS,IX(NXPTI))
            IF(IX(NTRANS*12-2).GT.0) THEN
              CALL FESTOP(200063)
            END IF
            IX(NTRANS*12-11)=NXPTI
            IX(NTRANS*12-2)=3
            CALL ROOMI(3)
C
C  OPTIONS: REPREAD, REPWRITE, BINARYREAD, BINARYWRITE
C
          ELSE IF(IX(NTRANS*12-9).GE.-20.AND.IX(NTRANS*12-9).LE.-17)
     .        THEN
            I=IX(NTRANS*12-11)
            IF(IX(NTRANS*12-9).EQ.-17.OR.IX(NTRANS*12-9).EQ.-19) THEN
              K=NOPTNW
            ELSE
              K=NOPTNR
            END IF
            CALL OPTNTR(K,INDXW,IVALW,OPTNW,IPT,IPOS,IX(I))
C
C  OPTIONS: VPLXAPPEND, VPLX APPEND
C
          ELSE IF(IX(NTRANS*12-9).EQ.-60) THEN
            I=IX(NTRANS*12-11)
            CALL OPTNTR(NOPTNV,INDXV,IVALV,OPTNV,IPT,IPOS,IX(I))
C
C  OPTIONS: MATRIX ALGEBRA ROUTINES
C
          ELSE IF(IX(NTRANS*12-9).GE.-48.AND.IX(NTRANS*12-9).LE.-25)
     .        THEN
            IX(NXPTI)=0
            IX(NXPTI+1)=0
            IX(NXPTI+2)=0
            IX(NXPTI+3)=0
            CALL OPTNTR(NOPTNM,INDXM,IVALM,OPTNM,IPT,IPOS,IX(NXPTI))
            IF(IX(NXPTI)+IX(NXPTI+1)+IX(NXPTI+2)+IX(NXPTI+3).GT.0)
     .          THEN
              IF(IX(NTRANS*12-2).GT.0) THEN
                CALL FESTOP(200063)
              END IF
              IX(NTRANS*12-11)=NXPTI
              IX(NTRANS*12-2)=4
              CALL ROOMI(4)
            END IF
C
C  OPTIONS: Rao-Shao
C
          ELSE IF(IX(NTRANS*12-9).EQ.-52) THEN
            IX(NXPTI)=1
            CALL OPTNTR(NOPTRS,INDXRS,IVALRS,OPTNRS,IPT,IPOS,IX(NXPTI))
            IX(NTRANS*12-11)=NXPTI
            IX(NTRANS*12-2)=1
            CALL ROOMI(1)
C
C  OPTIONS: XMEDIAN
C
          ELSE IF(IX(NTRANS*12-9).EQ.-56) THEN
            IX(NXPTI)=50
            IX(NXPTI+1)=-1
            IX(NXPTI+2)=-1
            CALL OPTNTR(NOPTNX,INDXX,IVALX,OPTNX,IPT,IPOS,IX(NXPTI))
            IX(NTRANS*12-11)=NXPTI
            IX(NTRANS*12-2)=3
            CALL ROOMI(3)
          ELSE
            CALL FESTOP(200063)
          END IF
        ELSE
          CALL FESTOP(200004)
        END IF
        IF(IPT.EQ.1) THEN
          GO TO 2
        ELSE
          GO TO 1
        END IF
C
C  STEPOPTION, STEP_OPTION
C
      ELSE IF(IKEY.GE.198.AND.IKEY.LE.200) THEN
        IF(IKEY.EQ.198) THEN
          IF(IPT.LE.0) THEN
            CALL NBFND2(IPT,IPOS)
            IF(IPOS.GT.0) THEN
              IPT=IPOS
            ELSE
              CALL FESTOP(200070)
            END IF
          END IF
          CALL CMATCH(CARD(IPT:256),IPT,256,'OPTION',6,IPOS,1)
          IF(IPOS.GT.0) THEN
            IPT=IPOS
          ELSE
            CALL CMATCH(CARD(IPT:256),IPT,256,'OPTIONS',7,IPOS,1)
            IF(IPOS.GT.0) THEN
              IPT=IPOS
            ELSE
              CALL FESTOP(200070)
            END IF
          END IF
        END IF
        IF(ISOPTN.EQ.1.OR.NTRANS.GT.0) THEN
          CALL FESTOP(200069)
        END IF
        IX(NXPTI)=1
        ISOPTN=1
        CALL OPTNTR(NOPTNT,INDXT,IVALT,OPTNT,IPT,IPOS,IX(NXPTI))
        IEXTRN=IX(NXPTI)
        IF(IPT.EQ.1) THEN
          GO TO 2
        ELSE
          GO TO 1
        END IF
      END IF
C
C  USER1 - USER10, REFORMAT, ADD, SUBTRACT, MULTIPLY, DIVIDE,
C  POWER, RECIPROCAL, LOG, PAIRED (ADD, SUBTRACT, MULTIPLY, DIVIDE)
C  RMULTIPLY, SAVEFULL, GLUE, RPRINT, REPPRINT, REPWRITE, REPREAD,
C  BINARYWRITE, BINARYREAD, COLLAPSE, MODIFYREPF, COPY, CPSCOL
C  SIPPCOL, PINVERT, PSOLVE, XMEDIAN
C
   77 CONTINUE
C
C  The first section of code is executed at the beginning of a
C  new subroutine, when encountering a COMPUTE statement or at the end
C  of the TRANSFORM specification to complete the specification for
C  any subroutine in progress.
C
      IF(NTRANS.GT.0) THEN
        IF(IX(NTRANS*12-9).EQ.-60) THEN
          IF(NLIST.EQ.0) THEN
            CALL VAPSET(IX,NLIST,NPASS)
          ELSE
            CALL VAPSET(IX(ILISTX),NLIST,NPASS)
          END IF
        ELSE IF(IX(NTRANS*12-8)+IX(NTRANS*12-7)+IX(NTRANS*12-6).EQ.0)
     .      THEN
          CALL FESTOP(200065)
        END IF
C
C  Under INTERNAL step option, set aside 1 entry in constant array
C  to signal that subroutine should use internal storage, for
C  RAO_SHAO, SAVEFULL, MODIFYREPF, REPREAD (with CONSTANT option),
C  BINARYREAD (with CONSTANT option), VPLXAPPEND (with FULL option)
C
        I=IX(NTRANS*12-9)
        IF(I.EQ.-52.OR.I.EQ.-14.OR.I.EQ.-22.OR.I.EQ.-18.OR.I.EQ.-20.OR.
     .     I.EQ.-60) THEN
          IF(IEXTRN.EQ.0) THEN
            IF(IX(NTRANS*12-4).EQ.0) THEN
              IX(NTRANS*12-4)=1
              IX(NTRANS*12-5)=NXPTD
              CALL ROOMD(1)
            END IF
          END IF
        END IF
      END IF
C
C  Normal exit from the subroutine at this point.
C
      IF(ENDTRN) THEN
        RETURN
      END IF
      IF((IKEY.GE.58.AND.IKEY.LE.86).OR.IKEY.EQ.112.OR.
     .    IKEY.EQ.119.OR.IKEY.EQ.120.OR.
     .(IKEY.GE.123.AND.IKEY.LE.156).OR.IKEY.GE.161) THEN
        CALL RINCR(12,NTRANS,1)
C
C  REFORMAT    -1
C  ADD         -2
C  SUBTRACT    -3
C  MULTIPLY    -4
C  DIVIDE      -5
C  POWER       -6
C  RECIPROCAL  -7
C  LOG         -8
C  PAIRED:
C    ADD       -9
C    SUBTRACT -10
C    MULTIPLY -11
C    DIVIDE   -12
C  RMULTIPLY  -13
C  SAVEFULL   -14
C  GLUE       -15
C  RPRINT     -16
C    REPPRINT -16
C  REPWRITE   -17
C  REPREAD    -18
C  BINARYWRITE-19
C  BINARYREAD -20
C  COLLAPSE   -21
C  MODIFYREPF -22
C  CPSCOL     -23
C  SIPPCOL    -24
C  PINVERT    -25
C  PSOLVE     -26
C  PMULTIPLYM -27
C  PMULTIPLYP -28
C  PSYMMULTM  -29
C  PSYMMULTP  -30
C  PPACK      -31
C  PUNPACK    -32
C  PTRACE     -33
C  PDIAG      -34
C  PEIGENVECTOR -35
C  PEIGENVALUE -36
C  PSQRT      -37
C  MINVERT    -38
C  MSOLVE     -39
C  MMULTIPLY  -40
C  MMULTIPLYM -40
C  MSYMMULT   -41
C  MSYMMULTM  -41
C  MTRACE     -42
C  MDIAG      -43
C  PBMULTIPLYM -44
C  PBMULTIPLYP -45
C  PBSYMMULTM  -46
C  PBSYMMULTP -47
C  PBDIAG     -48
C  CPSCHILDCOL -49
C  CPSNICOL    -50
C  GRIDSEARCH  -51
C  RAO_SHAO    -52
C  NEWCPSCHCOL -53
C  NPSCHILDCOL -54
C  OLDCPSCHCOL -55
C  XMEDIAN     -56
C  SIPPC_ROWCOL -57
C  SIPPC_CLMCOL -58
C  SIPPC_RAKE  -59
C  VPLXAPPEND  -60
C  SIPPC_NICOL -61
C
C  Beginning of a subroutine
C
        IF(MOD(NTRANS,5).EQ.0) THEN
          IF(U5ECHO.EQ.1)WRITE(U6,228)NTRANS
        END IF
        CALL CRDPRN(1)
C
C  For subroutines with a file specification or key words that must
C  be followed by additional information
C
        IF(IKEY.LE.57.OR.(IKEY.GE.87.AND.IKEY.LE.91).OR.
     .        (IKEY.GE.165.AND.IKEY.LE.167)) THEN
          IF(IPT.LE.0) THEN
            IPT=20
            CALL NBFND2(IPT,IPOS)
            IF(IPOS.LE.0) THEN
              IF(IKEY.LE.57) THEN
                CALL FESTOP(200072)
              ELSE
                CALL FESTOP(200003)
              END IF
            END IF
            IPT=IPOS
          END IF
        END IF
        IF(IKEY.LE.67) THEN
          IX(NTRANS*12-9)=IKEY-57
        ELSE IF(IKEY.LE.75) THEN
          IX(NTRANS*12-9)=-1*(IKEY-67)
        ELSE IF(IKEY.EQ.76) THEN
          CALL NBFIND(CARD(IPT:256),IPT,256,IPOS)
          IF(IPOS.EQ.0) THEN
            CALL FESTOP(200066)
          END IF
          CALL CMATCH(CARD(IPOS:256),IPOS,256,'ADD',3,IPOS2,1)
          IF(IPOS2.GT.0) THEN
            IX(NTRANS*12-9)=-9
          ELSE
            CALL CMATCH(CARD(IPOS:256),IPOS,256,'SUBTRACT',8,IPOS2,1)
            IF(IPOS2.GT.0) THEN
              IX(NTRANS*12-9)=-10
            ELSE
              CALL CMATCH(CARD(IPOS:256),IPOS,256,'MULTIPLY',8,IPOS2,1)
              IF(IPOS2.GT.0) THEN
                IX(NTRANS*12-9)=-11
              ELSE
                CALL CMATCH(CARD(IPOS:256),IPOS,256,'DIVIDE',6,IPOS2,1)
                IF(IPOS2.GT.0) THEN
                  IX(NTRANS*12-9)=-12
                ELSE
                  CALL FPSTOP(200066,IPOS)
                END IF
              END IF
            END IF
          END IF
        ELSE IF(IKEY.LE.80) THEN
          IX(NTRANS*12-9)=-1*(IKEY-64)
        ELSE IF(IKEY.LE.86) THEN
          IX(NTRANS*12-9)=-1*(IKEY-65)
        ELSE IF(IKEY.EQ.112) THEN
          IX(NTRANS*12-9)=-22
        ELSE IF(IKEY.EQ.119) THEN
          IX(NTRANS*12-9)=-23
        ELSE IF(IKEY.EQ.120) THEN
          IX(NTRANS*12-9)=-24
        ELSE IF(IKEY.GE.123.AND.IKEY.LE.138) THEN
          IX(NTRANS*12-9)=98-IKEY
        ELSE IF(IKEY.EQ.139.OR.IKEY.EQ.140) THEN
          IX(NTRANS*12-9)=99-IKEY
        ELSE IF(IKEY.GE.141.AND.IKEY.LE.155) THEN
          IX(NTRANS*12-9)=100-IKEY
        ELSE IF(IKEY.GE.161.AND.IKEY.LE.164) THEN
          IX(NTRANS*12-9)=105-IKEY
        ELSE IF(IKEY.GE.165.AND.IKEY.LE.167) THEN
          IX(NTRANS*12-9)=-60
        ELSE IF(IKEY.EQ.169) THEN
          IX(NTRANS*12-9)=-61
        ELSE IF(IKEY.EQ.170) THEN
          IX(NTRANS*12-9)=-62
        END IF
C
C  For REPREAD, REPWRITE, etc., assign unit number here.
C
        IF(IX(NTRANS*12-9).GE.-20.AND.IX(NTRANS*12-9).LE.-17) THEN
          IX(NTRANS*12-11)=NXPTI
          IX(NTRANS*12-2)=4
          CALL ROOMI(4)
          IX(NXPTI-3)=1
          IX(NXPTI-2)=0
          IX(NXPTI-1)=0
          IF(IX(NTRANS*12-9).EQ.-17) THEN
            ITYPEF(1)=0
            ITYPEF(2)=1
            CALL FNREAD(IPT,ITYPEF,IFILEF,2,IPOSSC)
            K=IFILEF(2)
          ELSE IF(IX(NTRANS*12-9).EQ.-18) THEN
            ITYPEF(1)=1
            ITYPEF(2)=0
            CALL FNREAD(IPT,ITYPEF,IFILEF,2,IPOSSC)
            K=IFILEF(1)
          ELSE IF(IX(NTRANS*12-9).EQ.-19) THEN
            ITYPEF(1)=0
            ITYPEF(2)=2
            CALL FNREAD(IPT,ITYPEF,IFILEF,2,IPOSSC)
            K=IFILEF(2)
          ELSE
            ITYPEF(1)=2
            ITYPEF(2)=0
            CALL FNREAD(IPT,ITYPEF,IFILEF,2,IPOSSC)
            K=IFILEF(1)
          END IF
          IF(IMERR1.GT.0) THEN
            CALL FSTOP
          END IF
          IX(IX(NTRANS*12-11))=K
          IF(K.EQ.0) THEN
            CALL FESTOP(200067)
          END IF
C
C  VPLXAPPEND, VPLX APPEND, etc.
C
        ELSE IF(IX(NTRANS*12-9).EQ.-60) THEN
C
C  If first key word is VPLX, find APPEND
C
          IF(IKEY.EQ.167) THEN
            IF(IPT.LE.0) THEN
              CALL NBFND2(IPT,IPOS)
              IF(IPOS.GT.0) THEN
                IPT=IPOS
              ELSE
                CALL FESTOP(200071)
              END IF
            END IF
            CALL CMATCH(CARD(IPT:256),IPT,256,'APPEND',6,IPOS,1)
            IF(IPOS.GT.0) THEN
              IPT=IPOS
            ELSE
              CALL FESTOP(200071)
            END IF
          END IF
          NLIST=0
          ILISTX=0
          IX(NTRANS*12-11)=NXPTI
          IX(NTRANS*12-2)=7
          CALL ROOMI(7)
          IX(NXPTI-6)=1
          IX(NXPTI-5)=0
          IX(NXPTI-4)=0
          ITYPEF(1)=2
          ITYPEF(2)=0
          CALL FNREAD(IPT,ITYPEF,IFILEF,2,IPOSSC)
          IF(IMERR1.GT.0) THEN
            CALL FSTOP
          END IF
          K=IFILEF(1)
          IX(IX(NTRANS*12-11))=K
          IF(K.EQ.0) THEN
            CALL FESTOP(200067)
          END IF
          CALL PREAMD(K)
          IX(NXPTI-3)=ANIDTT
          IX(NXPTI-2)=ATSIZE
          IX(NXPTI-1)=ANRPTT
          VTMPSZ=MVAR-SVTEMP+1
C
C  All other subroutines:
C  Starting position for integer constants given dummy value 1 and
C  number of integer constants set to 0.
C
        ELSE
          IX(NTRANS*12-11)=1
          IX(NTRANS*12-2)=0
        END IF
        IF(NXTSTR.GT.0) THEN
          IX(NTRANS*12-10)=NXTSTR
        ELSE
          IX(NTRANS*12-10)=1
        END IF
        IX(NTRANS*12-8)=0
        IX(NTRANS*12-7)=0
        IX(NTRANS*12-6)=0
        IX(NTRANS*12-5)=0
        IX(NTRANS*12-4)=0
        IX(NTRANS*12-3)=0
        IX(NTRANS*12-1)=NPASS+1
C
C  RPRINT, REPPRINT, allocate first string as working string.
C
        IF(IKEY.EQ.80.OR.IKEY.EQ.81) THEN
          IX(NTRANS*12-3)=1
          IX(NTRANS*12-10)=1
        END IF
C       IF(IX(NTRANS*12-9).EQ.-60.AND.IPT.EQ.1) THEN
C         GO TO 2
C       ELSE
          GO TO 1
C       END IF
C
C  COMPUTE
C
      ELSE IF(IKEY.EQ.17) THEN
C
C       write(*,*)u5,' ***'
C       CALL CRDPRN(1)
C
        TSWTCH=1
        CALL CMPAR1(IX,IPT)
        GO TO 1
      END IF
   90 CONTINUE
      ENDTRN=.TRUE.
      GO TO 77
C
C  Return to 77 to complete the processing of the last subroutine,
C  if any, before exiting the routine
C
      END
C
      SUBROUTINE CLFORM(IA,NSPTOT)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      INTEGER NSPTOT
      INTEGER IA(3,NSPTOT)
C
C  Converts the specification in IA(3,*) into the class specifications
C  for the next block to be added during TRANSFORM.
C
C  NSPTOT  - dimension of IA(3,*)
C  IA(3,*) - specification of class cross-classification, provided
C  by CLSCAN.
C
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
C
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      LOGICAL CLDONE
C
  100 FORMAT(' ERROR IN CLASS SPECIFICATION')
      CALL RINCR(8,NCLBLK,1)
C
C  Until the end of the routine, work with NCLBR1, a temporary working
C  value of NCLBAR, the total number of class variables stored in
C  arrays defining blocks.
C
      NCLBR1=NCLBAR
C
C  BLCPNT points to the beginning of the block specification.
C
      BLCPNT(NCLBLK)=NCLBR1+1
C
C  Initialize new blocks to not include a defined N.
C
      BLTYPE(NCLBLK)=0
      IS=1
   10 CONTINUE
      N=IA(1,IS)
      CLDONE=.FALSE.
      DO 15 I=1,N
      IS=IS+1
C
C  If one or more classes have already been processed, check that
C  current class does not repeat an earlier class.
C
      IF(NCLBR1.GE.BLCPNT(NCLBLK)) THEN
        DO 11 J=BLCPNT(NCLBLK),NCLBR1
        IF(CLPNT(J).EQ.IA(1,IS)) THEN
          IS1=IS-1
          IF(J.NE.NCLBR1) THEN
            CALL FESTOP(200101)
          ELSE IF(IA(2,IS1)+1.NE.IA(2,IS)) THEN
            CALL FESTOP(200102)
          ELSE IF(IA(3,IS1)+1.NE.IA(3,IS)) THEN
            CALL FESTOP(200103)
C
C  CLTYPE has now already been defined in this case (code below).
C  Perform additional check that range conforms to (0-n) or (1-n)
C  rule.  This check may be redundant, however, since CLSCAN
C  should have already checked that the class specification was within
C  range.?
C
          ELSE IF(CLTYPE(NCLBR1).EQ.0) THEN
            IF(IA(3,IS).GT.MSIZE(CLPNT(NCLBR1))+1) THEN
              CALL FESTOP(200104)
            ELSE IF(IA(3,IS).EQ.MSIZE(CLPNT(NCLBR1))+1) THEN
              CLDONE=.TRUE.
            END IF
          ELSE
            IF(IA(3,IS).GT.MSIZE(CLPNT(NCLBR1))) THEN
              CALL FESTOP(200104)
            ELSE IF(IA(3,IS).EQ.MSIZE(CLPNT(NCLBR1))) THEN
              CLDONE=.TRUE.
            END IF
          END IF
C
C  Transfer to 15 now skips processing to add a new class variable,
C  since only adding an additional level of a class.  Further checks
C  are performed at 15.
C
          GO TO 15
        END IF
   11   CONTINUE
      END IF
C
C  The check based on CLDONE assures that no specifications of
C  class ranges are incomplete, e.g. sex (0-1) if sex is a class
C  variable with 2 levels.
C
      IF(I.GT.1) THEN
        IF(CLDONE) THEN
          CLDONE=.FALSE.
        ELSE
          CALL FESTOP(200105)
        END IF
      END IF
C
C  Add the class variable at this point.
C
      IF(IA(1,IS).GT.0) THEN
        CALL RINCR(9,NCLBR1,1)
        CLPNT(NCLBR1)=IA(1,IS)
C
C  CLTYPE = 0 margin present (nonsummable variables only)
C         = 1 no margin present
C
        IF(IA(2,IS).EQ.0.AND.IA(3,IS).EQ.1) THEN
          CLTYPE(NCLBR1)=0
        ELSE
          CLTYPE(NCLBR1)=1
C
C  If no range is present, set CLDONE to TRUE
C
          IF(IA(2,IS).EQ.0.AND.IA(3,IS).EQ.0)CLDONE=.TRUE.
        END IF
      END IF
   15 CONTINUE
      IF(N.GT.1.OR.IA(1,IS).NE.0) THEN
        IF(.NOT.CLDONE) THEN
          CALL FESTOP(200105)
        END IF
      END IF
      IS=IS+1
C
C  Loop if not in form of product (however, editing in TSET1 may
C  eliminate this case?)
C
      IF(IS.LE.NSPTOT)GO TO 10
C
C  Calculation of number of class variables added.
C
      BLNCLS(NCLBLK)=NCLBR1-NCLBAR
C
C  Now make change to NCLBAR (in common block)
C
      NCLBAR=NCLBR1
      RETURN
      END
C
      LOGICAL FUNCTION CLMTCH(ICLBL1,ICLBL2)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER ICLBL1,ICLBL2
C
C  Returns true if blocks ICLBL1 and ICLBL2 match identically (after
C  permutation), false otherwise.
C
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      CLMTCH=.FALSE.
      IF(BLNCLS(ICLBL1).NE.BLNCLS(ICLBL2))GO TO 95
      N=BLNCLS(ICLBL1)
      IF(N.EQ.0)GO TO 90
      ICLBR1=BLCPNT(ICLBL1)
      ICLBR2=BLCPNT(ICLBL2)
      DO 20 I=1,N
      IV=CLPNT(ICLBR1+I-1)
      DO 10 J=1,N
      IF(CLPNT(ICLBR2+J-1).EQ.IV) THEN
        IF(CLTYPE(ICLBR1+I-1).EQ.CLTYPE(ICLBR2+J-1)) THEN
          GO TO 20
        ELSE
          GO TO 95
        END IF
      END IF
   10 CONTINUE
      GO TO 95
   20 CONTINUE
   90 CONTINUE
      CLMTCH=.TRUE.
   95 CONTINUE
      RETURN
      END
C
      SUBROUTINE CLCHK3(ICLBLK,IV,IT,IA,NA)
C
C  Subroutine to check the class specification used with
C  MODIFY variables
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER ICLBLK,IV,IT,IA(3,*),NA
C
C  ICLBLK - block number to be checked
C  IV     - variable number (block number if N of block, redundantly)
C  IT     - type - 9 for N of block
C  IA(3,*)- class specification (from CLSCAN) if any.  May be dummy
C           matrix if no class specification
C  NA     - second dimension of IA, but may be 0 if no class
C           specification
C
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      LOGICAL DERIVD
C
  200 FORMAT(' NO COLLAPSING WITH MODIFY: ',A12)
  201 FORMAT(' ERROR IN CLASS SPECIFICATION: ',A12)
  202 FORMAT(' ERROR IN CLASS SPECIFICATION, BLOCK: ',I5)
  203 FORMAT(' NO COLLAPSING WITH MODIFY, BLOCK: ',I5)
C
      NIN=BLNCLS(ICLBLK)
C
C  If the block has no class variables, then there should either be:
C     No class specification for the variable, or
C     A specification of "/CLASS TOTAL"
C
      NOUT=0
C
C  Loop through specification to identify class variables
C  DERIVD distinguishes nonsummable variables.
C
      DERIVD=.FALSE.
      IF(IT.NE.9) THEN
        IF(MTYPE(IV).GT.10)DERIVD=.TRUE.
      END IF
      IF(NA.GT.0) THEN
        K=1
    7   CONTINUE
        N=IA(1,K)
        K=K+1
        J=1
    9   CONTINUE
C
C  If the specification includes TOTAL, treat it simply as TOTAL
C
        IF(IA(1,K).EQ.0) THEN
          NOUT=0
          GO TO 20
        ELSE
          NOUT=NOUT+1
          IF(NIN.EQ.0) THEN
            IMERR1=200110
            GO TO 98
          END IF
          ICLBAR=BLCPNT(ICLBLK)
          DO 12 I=1,NIN
          IF(CLPNT(ICLBAR).EQ.IA(1,K))GO TO 13
          ICLBAR=ICLBAR+1
   12     CONTINUE
          IMERR1=200111
          GO TO 98
   13     CONTINUE
C
C  Accept a margin only if the margin exists and the type of variable
C  is summable.
C
          IF(IA(2,K).EQ.0.AND.IA(3,K).NE.0.AND.
     .        (.NOT.DERIVD.OR.CLTYPE(ICLBAR).EQ.1)) THEN
            IF(.NOT.DERIVD) THEN
              IMERR1=200112
            ELSE
              IMERR1=200113
            END IF
            GO TO 97
          END IF
          IF(J.LT.N) THEN
            K1=K+1
C
C  If the current variable appears again, check only to assure "+"
C  has not been used.
C
            IF(IA(1,K1).EQ.IA(1,K)) THEN
              IF(IA(3,K).EQ.IA(3,K1)) THEN
                IMERR1=200114
                GO TO 98
              END IF
              K=K+1
              J=J+1
              GO TO 13
C
C  Else look ahead to ensure class variable does not appear a second
C  time.
C
            ELSE
              DO 14 J1=J+1,N
              IF(IA(1,K1).EQ.IA(1,K)) THEN
                IMERR1=200115
                GO TO 98
              ELSE
                K1=K1+1
              END IF
   14         CONTINUE
            END IF
          END IF
          J=J+1
          K=K+1
C
C  Loop back if not done with specification in IA(3,*)
C
          IF(J.LE.N)GO TO 9
          IF(K.LE.NA)GO TO 7
        END IF
      END IF
   20 CONTINUE
C
C  Now perform checks to see that each class variable associated with
C  the block has been appropriately handled by the /CLASS specification.
C
      IF(NIN.GT.0) THEN
        ICLBAR=BLCPNT(ICLBLK)
        DO 30 I=1,NIN
        IF(NOUT.GT.0) THEN
          K=1
   23     CONTINUE
          N=IA(1,K)
          K=K+1
          J=1
   25     CONTINUE
          IF(IA(1,K).EQ.CLPNT(ICLBAR))GO TO 29
          J=J+1
          K=K+1
          IF(J.LE.N)GO TO 25
          IF(K.LE.NA)GO TO 23
        END IF
        IF(.NOT.DERIVD.OR.CLTYPE(ICLBAR).EQ.1) THEN
          IF(.NOT.DERIVD) THEN
            IMERR1=200112
          ELSE
            IMERR1=200113
          END IF
          GO TO 97
        END IF
   29   CONTINUE
        ICLBAR=ICLBAR+1
   30   CONTINUE
      END IF
      RETURN
   97 CONTINUE
      IF(IT.NE.9) THEN
        WRITE(U6,200)VNAME(IV)
      ELSE
        WRITE(U6,203)IV
      END IF
      GO TO 99
   98 CONTINUE
      IF(IT.NE.9) THEN
        WRITE(U6,201)VNAME(IV)
      ELSE
        WRITE(U6,202)IV
      END IF
   99 CONTINUE
      CALL FSTOP
      END
C
      SUBROUTINE PREAMD(IUNIT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER IUNIT
C
      PARAMETER (MSIZED=1000000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,
     . BLVSIZ,BLNCLS,BLCPNT,CLTYPE,CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,
     . CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /VABLCK/AVERSN,ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT,
     . ATYPE,AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR,ANID,ANCRSS,ANCRVL,
     . AVNCRS,ANBYGR,ASDBID,ANRPTT,ASDCOF
      INTEGER  AVERSN,ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT,
     . ATYPE,AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR,ANID,ANCRSS,ANCRVL,
     . AVNCRS,ANBYGR,ASDBID,ANRPTT,ASDCOF
C
      LOGICAL ENDFLE
C
C  All matrices from the file are read into the ends of the respective
C  allocated storage.  Many pointer arrays are adjusted to the resulting
C  positions.
C
C  Adjusted arrays:
C  BLCPNT  - pointer for class information
C  CLPNT   - pointer to class variables
C  CDMPNT  - pointer to dimension information
C  LPOINT  - pointer to level labels
C
C  Unadjusted arrays, giving only relative positions:
C  BLXSTR  - pointer to first cell of incoming data in X matrix
C  BLVSTR  - pointer to first variable
C  VMAPL   - pointer to starting location for variable
C
      READ(IUNIT,END=99)AVERSN
      IF(AVERSN.NE.9004.AND.AVERSN.NE.9203) THEN
        CALL FESTOP(200120)
      END IF
      READ(IUNIT,END=99)ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT,ATYPE,
     . AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR
      CALL RCHECK(2,NVTOT,ANVTOT)
      ANID=ANVRID+ANBY
      IF(AVERSN.EQ.9004)ANIDTT=ANID
C
C  ANVTOT  - total number of variables on file
C  ANVREG  - number of variables, excluding class, variance id's,
C            BY variables, and weight variable
C  ANCLSS  - total number of class variables
C  ANVRID  - number of variance id's, excluding BY variables
C  ANBY    - number of BY variables
C  ANWGT   - 0 or 1 indicating unweighted vs. weighted analysis
C  ATYPE   - type of input used to create the file
C  AVROPT  - variance option
C  ATSIZE  - total size of matrix
C  ANCLBL  - total number of class blocks
C  ANCLBR  - total size of class block information arrays
C
C  ATYPE= 3  Weighted obs. with cluster/replicate number
C         4  Unweighted  "
C         5  Replicate weights
C         6  Unweighted initial obs. followed by replicate weights
C         7  Replicate factors multiplying initial weight
C         8  Replicate factors of unweighted initial obs ( = VFTYPE 6)
C        11  Replicate factors multiplying initial weight, including
C            factor for replicate 0, overall estimate
C        12  Unweighted initial obs  "  (= VFTYPE 5)
C        13  Weighted obs. with cluster code
C        14  Unweighted "
C        15  Weighted obs. Stratum no. cluster code
C        16  Unweighted "
C        17  Wtd.          Stratum code, cluster code
C        18  Unwtd      "
C        21  Wtd.      Stratum no. 2nd stage no, cluster code
C        22  Unwtd.     "
C        23  Wtd.      Stratum no. 2nd stage cd, cluster code
C        24  Unwtd.     "
C        25  Wtd.      Stratum code  2nd stage no. cluster code
C        26  Unwtd      "
C        27  Wtd.      Stratum code  2nd stage cd, cluster code
C        28  Unwtd.     "
C        29  Wtd       2nd stage number cluster code
C        30  Unwtd.     "
C        31  Wtd       2nd stage code  cluster code
C        32  Unwtd      "
C        33  Wtd       Replicate number governed by stratum counts
C        34  Unwtd      "
C        35  Wtd       Rep numb govrned by stratum and 2nd stage counts
C        36  Unwtd      "
C        37  Wtd       Rep number governed by 2nd stage counts
C        38  Unwtd      "
C
      CALL RCHECK(8,NCLBLK,ANCLBL)
      CALL RCHECK(9,NCLBAR,ANCLBR)
      I=RCEIL(8)-ANCLBL+1
      DO 1 J=1,ANCLBL
      READ(IUNIT,END=99)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),
     . BLVSTR(I),BLVSIZ(I),BLNCLS(I),BLCPNT(I)
      IF(BLCPNT(I).GT.0) THEN
        BLCPNT(I)=BLCPNT(I)+RCEIL(9)-ANCLBR
      END IF
      I=I+1
    1 CONTINUE
C
C  Note that on input, CLPNT points to the relative positions of the
C  CLASS variables wrt the appended VPLX file.
C
      IF(ANCLBR.GT.0) THEN
        I=RCEIL(9)-ANCLBR+1
        CALL INTIN(IUNIT,CLTYPE(I),ANCLBR,ENDFLE)
        IF(ENDFLE) GO TO 99
        CALL INTIN(IUNIT,CLPNT(I),ANCLBR,ENDFLE)
C
C  Adjust CLPNT to point to actual positions of class variables.
C
        DO 2 J=1,ANCLBR
        CLPNT(I)=CLPNT(I)+RCEIL(2)-ANVTOT
        I=I+1
    2   CONTINUE
C
        IF(ENDFLE) GO TO 99
      END IF
C
C  BLTYPE  - 1 or 0 indicating row of (weighted) n vs. no row
C  BLXSTR  - pointer to first cell of incoming data in X matrix
C  BLXINC  - length of the X matrix for a single combination
C            of the class variables in the block
C  BLXSIZ  - total size of block data in X matrix (integer multiple
C            of BLXINC) (TRANSFORM step uses differently)
C  BLVSTR  - pointer to first variable
C  BLVSIZ  - number of variables in block
C  BLNCLS  - number of class variables in block
C  BLCPNT  - pointer for class information
C  CLTYPE  - type of class in array
C  CLPNT   - pointer to class variables
C
      I=RCEIL(2)-ANVTOT+1
      IF(ANVTOT.GT.0) THEN
        CALL INTIN(IUNIT,MTYPE(I),ANVTOT,ENDFLE)
        IF(ENDFLE)GO TO 99
C
C  Variable types are read into MTYPE
C
C  Contents of MTYPE
C     1  =  real variable (total)
C     2  =  real variable with missing checks
C     3  =  categorical variable
C     4  =  class variable, known dimension
C     5  =  by variable, known dimension
C     6  =  by variable, unknown dimension
C     7  =  select transformation (not variable type)
C     8  =  cross variable, real value
C     9  =  cross variable, categorical
C    11  =  derived variable
C    13  =  crossed derived variable, single dimension
C    19  =  crossed derived variable
C
C
C  Sizes are read into MSIZE
C
        CALL INTIN(IUNIT,MSIZE(I),ANVTOT,ENDFLE)
        IF(ENDFLE)GO TO 99
      END IF
C
C  VMAPL contains pointers to the first ANVREG variables
C  These are relative positions; absolute positions not determined
C  here.
C
      IF(ANVREG.GT.0) THEN
        CALL INTIN(IUNIT,VMAPL(I),ANVREG,ENDFLE)
        IF(ENDFLE)GO TO 99
      END IF
C
      READ(IUNIT,END=99)ANCRSS
      CALL RCHECK(10,NCRSSD,ANCRSS)
      ILC=RCEIL(10)-ANCRSS+1
      IF(ANCRSS.GT.0) THEN
        CALL INTIN(IUNIT,CROSSD(ILC),ANCRSS,ENDFLE)
        IF(ENDFLE)GO TO 99
      END IF
C
C  Create an array of pointers, CDMPNT, from the variables to
C  the starting entries in CROSSD.  These will point to actual, not
C  relative positions.
C
      I=RCEIL(2)-ANVTOT+1
      DO 3 II=1,ANVTOT
      J=MTYPE(I)
      IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN
        CDMPNT(I)=ILC
        ILC=CROSSD(ILC)+ILC+2
      ELSE
        CDMPNT(I)=0
      END IF
      I=I+1
    3 CONTINUE
C
      IF(RCEIL(10)+1.NE.ILC) THEN
        CALL FESTOP(200122)
      END IF
      ILC=0
C
C  Read variable names and labels, and create an array of pointers,
C  LPOINT, to labels for the levels of the variables.  In this loop
C  store relative positions in LPOINT.
C
      I=RCEIL(2)-ANVTOT+1
      DO 6 II=1,ANVTOT
      READ(IUNIT,END=99)VNAME(I),LABEL(I)
      J=MTYPE(I)
      IF(J.EQ.3.OR.J.EQ.4.OR.J.EQ.5.OR.J.EQ.13) THEN
        LPOINT(I)=ILC+1
        ILC=ILC+MSIZE(I)
      ELSE IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN
        LPOINT(I)=ILC+1
        K=CDMPNT(I)
        L=CROSSD(K)
        DO 4 M=1,L
        K=K+1
        ILC=ILC+CROSSD(K)+1
    4   CONTINUE
      ELSE
        LPOINT(I)=0
      END IF
      I=I+1
    6 CONTINUE
C
C  Read in labels for the levels
C
      READ(IUNIT,END=99)ANCRVL
      CALL RCHECK(7,NCRVL,ANCRVL)
      IF(ILC.NE.ANCRVL) THEN
        CALL FESTOP(200122)
      END IF
      II=RCEIL(7)-ILC
      IF(ILC.GT.0) THEN
C
C  This loop adjusts LPOINT to point to actual locations
C
        DO 8 I=RCEIL(2)-ANVTOT+1,RCEIL(2)
        IF(LPOINT(I).GT.0)LPOINT(I)=LPOINT(I)+II
    8   CONTINUE
        DO 10 I=II+1,RCEIL(7)
        READ(IUNIT,END=99)LEVEL(I)
   10   CONTINUE
      END IF
C
      READ(IUNIT,END=99)AVNCRS
C
C  Read in variable names for crossed variables
C
      CALL RCHECK(13,SVTEMP,AVNCRS)
      II=RCEIL(13)-AVNCRS
      IF(AVNCRS.GT.0) THEN
        DO 12 I=1,AVNCRS
        READ(IUNIT,END=99)VTEMP(II+I)
   12   CONTINUE
C
C  Adjust pointers in CROSSD
C
        I=RCEIL(2)-ANVTOT+1
        DO 14 K=1,ANVTOT
        J=MTYPE(I)
        IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN
          M=CDMPNT(I)
          M=CROSSD(M)+M+1
          CROSSD(M)=CROSSD(M)+II
        END IF
        I=I+1
   14   CONTINUE
      END IF
      IF(ANBY.GE.1) THEN
        READ(IUNIT,END=99)ANBYGR
        ASDBID=NXPTD
        K=ANBYGR*ANBY
        CALL ROOMD(K)
        K=ASDBID-1
        DO 17 I=1,ANBYGR
        READ(IUNIT,END=99)(DX(K+J),J=1,ANBY)
        K=K+ANBY
   17   CONTINUE
      ELSE
        ASDBID=0
        ANBYGR=1
      END IF
      READ(IUNIT,END=99)ANRPTT
      IF(ANRPTT.GT.0) THEN
        ASDCOF=NXPTD
        CALL ROOMD(ANRPTT)
        CALL UNFIN(IUNIT,DX(ASDCOF),ANRPTT,ENDFLE)
        IF(ENDFLE)GO TO 99
      ELSE
        ASDCOF=0
      END IF
      RETURN
   99 CONTINUE
      CALL FESTOP(200121)
      END
C
      SUBROUTINE VAPSET(ILIST,NLIST,NPASS)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER ILIST(*),NLIST
C
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MAXFMT=20)
C
      PARAMETER (MTRANS=1500,MRANGS=20)
      PARAMETER (MTRSZI=MSIZEI+6*MRANGE-6*MRANGS+2*MRNSET+MRECOD+MVAR)
      PARAMETER (IXFLLD=57+3*MAXIDS)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,
     . BLVSIZ,BLNCLS,BLCPNT,CLTYPE,CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,
     . CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /VABLCK/AVERSN,ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT,
     . ATYPE,AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR,ANID,ANCRSS,ANCRVL,
     . AVNCRS,ANBYGR,ASDBID,ANRPTT,ASDCOF
      INTEGER  AVERSN,ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT,
     . ATYPE,AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR,ANID,ANCRSS,ANCRVL,
     . AVNCRS,ANBYGR,ASDBID,ANRPTT,ASDCOF
C
      INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID,
     . SDWRK,VKEEPF,IXFILL(IXFLLD)
      COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,
     . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF,
     . IXFILL
C
      COMMON /STMBLK/IX,RANGE,RGROUP,RTYPE,RSTPNT,V1,V2,V3,MXSIZE,
     . IOUT,IOUTL
      DOUBLE PRECISION RANGE(2,MRANGS)
      INTEGER IX(MTRSZI),RGROUP(MRANGS),RTYPE(MRANGS),RSTPNT(MRECOD),
     . V1(MRECOD),V2(MRECOD),V3(MRECOD),MXSIZE(MVAR),IOUT(MVAR),
     . IOUTL(MVAR)
C
  100 FORMAT(/,' Integration of blocks from appended file:',//,
     .  '    Block in     Internal',/,
     .  '  appended file   block')
  101 FORMAT(1X,I7,8X,I7)
  201 FORMAT(' CONFLICT -  with variable ',A12)
C
C  All matrices from the file are read into the ends of the respective
C  allocated storage.  Many pointer arrays are adjusted to the resulting
C  positions.
C
C  Adjusted arrays:
C  BLCPNT  - pointer for class information
C  CLPNT   - pointer to class variables
C  CDMPNT  - pointer to dimension information
C  LPOINT  - pointer to level labels
C
C  Unadjusted arrays, giving only relative positions:
C  BLXSTR  - pointer to first cell of incoming data in X matrix
C  BLVSTR  - pointer to first variable
C  VMAPL   - pointer to starting location for variable
C
C
C  ANVTOT  - total number of variables on file
C  ANVREG  - number of variables, excluding class, variance id's,
C            BY variables, and weight variable
C  ANCLSS  - total number of class variables
C  ANVRID  - number of variance id's, excluding BY variables
C  ANBY    - number of BY variables
C  ANWGT   - 0 or 1 indicating unweighted vs. weighted analysis
C  ATYPE   - type of input used to create the file
C  AVROPT  - variance option
C  ATSIZE  - total size of matrix
C  ANCLBL  - total number of class blocks
C  ANCLBR  - total size of class block information arrays
C
      IF(U5ECHO.GT.0)WRITE(U6,100)
      ICLBLK=RCEIL(8)-ANCLBL+1
C
C  Create matrix of starting positions and increments first.
C  Save NPASSV to find out how many new variables are created,
C  including N of block but excluding classes.
C
      NPASSV=NPASS
      NXPTIS=NXPTI
      DO 50 IBLK=1,ANCLBL
C
C  For NLIST > 0, include the block if listed in the EXTRACT statement
C  or if one or more of its associated variables is included.
C
      IF(NLIST.GT.0) THEN
        IF(BLVSIZ(ICLBLK).GT.0) THEN
          ILOW=BLVSTR(ICLBLK)
          IHIGH=ILOW+BLVSIZ(ICLBLK)-1
        ELSE
          ILOW=0
          IHIGH=0
        END IF
        DO 12 I=1,NLIST
        IF(ILIST(I).EQ.-IBLK.OR.
     .    (ILIST(I).GE.ILOW.AND.ILIST(I).LE.IHIGH)) THEN
          GO TO 14
        END IF
   12   CONTINUE
C
C  If arrive here, do not include the block
C
        GO TO 49
   14   CONTINUE
      END IF
C
C  Inclusion of block
C  NCLBLK may be safely incremented here; adequate storage is available.
C  Similarly, NCLBAR is adequate because of previous checks.
C
      NCLBLK=NCLBLK+1
      BLNCLS(NCLBLK)=BLNCLS(ICLBLK)
      BLTYPE(NCLBLK)=BLTYPE(ICLBLK)
      BLCPNT(NCLBLK)=NCLBAR+1
      WRITE(U6,101)IBLK,NCLBLK
C
C  Just in case, reset BLXSIZ to 1 as a flag indicating that block
C  should be retained.
C
      BLXSIZ(NCLBLK)=1
C
C  Transfer of N of the block
C
      IF(BLTYPE(ICLBLK).EQ.1) THEN
        CALL RINCR(4,NPASS,1)
        V1(NPASS)=NCLBLK
        V2(NPASS)=9
        RSTPNT(NPASS)=1
        CALL ROOMI(3)
        IF(NXPTI+NLIST-1.GT.MTRSZI) THEN
          CALL ROOMI(NLIST)
        END IF
        IX(NXPTI-3)=BLXSTR(ICLBLK)
        IX(NXPTI-2)=BLXINC(ICLBLK)
        IX(NTRANS*12-2)=IX(NTRANS*12-2)+3
      END IF
C
C  Set up of class variables for block.  Add class variables, as
C  necessary.
C
      IF(BLNCLS(ICLBLK).GT.0) THEN
        DO 20 ICLBAR=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1
C
C  Space to increment NCLBAR has already been confirmed.
C
        NCLBAR=NCLBAR+1
        K=CLPNT(ICLBAR)
        CLTYPE(NCLBAR)=CLTYPE(ICLBAR)
        CALL VNMTCH(VNAME(K),VNAME,NVIN,J)
C
C  If find matching variable in first NVIN, confirm attributes.
C
        IF(J.GT.0) THEN
          IF(MTYPE(J).NE.4) THEN
            WRITE(U6,201)VNAME(J)
            CALL FESTOP(200130)
          ELSE IF(MSIZE(J).NE.MSIZE(K)) THEN
            WRITE(U6,201)VNAME(J)
            CALL FESTOP(200131)
          END IF
          CLPNT(NCLBAR)=J
c        write(6,*)nclblk,nclbar,blcpnt(nclblk),clpnt(nclbar)
C
C  If the class variable does not match, add it as a new variable
C
        ELSE
          NVIN=NVIN+1
          IF(NVIN+ANVTOT.GT.MVAR) THEN
            CALL RCHECK(2,NVIN,ANVTOT)
          END IF
          VNAME(NVIN)=VNAME(K)
          MTYPE(NVIN)=MTYPE(K)
          MSIZE(NVIN)=MSIZE(K)
          LABEL(NVIN)=LABEL(K)
          MXSIZE(NVIN)=0
          CDMPNT(NVIN)=0
          L=LPOINT(K)
          LPOINT(NVIN)=NCRVL+1
          DO 16 I=1,MSIZE(K)
          CALL RINCR(7,NCRVL,1)
          CALL RCHECK(7,NCRVL,ANCRVL)
          LEVEL(NCRVL)=LEVEL(L)
          L=L+1
   16     CONTINUE
c        write(6,*)nvin,nclblk,nclbar,blcpnt(nclblk),clpnt(nclbar)
          CLPNT(NCLBAR)=NVIN
        END IF
   20   CONTINUE
      END IF
C
C  Search for variables to add.
C
      IF(BLVSIZ(ICLBLK).GT.0) THEN
        DO 40 IVIN=BLVSTR(ICLBLK),BLVSTR(ICLBLK)+BLVSIZ(ICLBLK)-1
        IF(NLIST.GT.0) THEN
          DO 22 I=1,NLIST
          IF(ILIST(I).EQ.IVIN)GO TO 24
   22     CONTINUE
          GO TO 40
   24     CONTINUE
        END IF
        K=RCEIL(2)-ANVTOT+IVIN
        NVIN=NVIN+1
        IF(NVIN+ANVTOT.GT.MVAR) THEN
          CALL RCHECK(2,NVIN,ANVTOT)
        END IF
        VNAME(NVIN)=VNAME(K)
        MTYPE(NVIN)=MTYPE(K)
        MSIZE(NVIN)=MSIZE(K)
        LABEL(NVIN)=LABEL(K)
        MXSIZE(NVIN)=NCLBLK
C
C  RSTPNT holds the size of the variable, after transformation, but
C  before considering effects of classes.  In this case, this is always
C  the size of the variable.
C
        CALL RINCR(4,NPASS,1)
        RSTPNT(NPASS)=MSIZE(K)
        V1(NPASS)=NVIN
        V2(NPASS)=0
        CALL ROOMI(3)
        IF(NXPTI+NLIST-1.GT.MTRSZI) THEN
          CALL ROOMI(NLIST)
        END IF
        IX(NXPTI-3)=VMAPL(K)
        IX(NXPTI-2)=BLXINC(ICLBLK)
        IX(NTRANS*12-2)=IX(NTRANS*12-2)+3
        ITYPE=MTYPE(NVIN)
        IF(ITYPE.EQ.3.OR.ITYPE.EQ.13) THEN
          LPOINT(NVIN)=NCRVL+1
          L=LPOINT(K)
          DO 26 I=1,MSIZE(K)
          CALL RINCR(7,NCRVL,1)
          CALL RCHECK(7,NCRVL,ANCRVL)
          LEVEL(NCRVL)=LEVEL(L)
          L=L+1
   26     CONTINUE
          CDMPNT(NVIN)=0
        ELSE IF(ITYPE.EQ.8.OR.ITYPE.EQ.9.OR.ITYPE.EQ.19) THEN
          LPOINT(NVIN)=NCRVL+1
          CDMPNT(NVIN)=NCRSSD+1
          II=CDMPNT(K)
          L=LPOINT(K)
          DO 30 I=II,II+CROSSD(II)
          CALL RINCR(10,NCRSSD,1)
          CALL RCHECK(10,NCRSSD,ANCRSS)
          CROSSD(NCRSSD)=CROSSD(I)
          IF(I.GT.II) THEN
            DO 28 J=1,CROSSD(I)+1
            CALL RINCR(7,NCRVL,1)
            CALL RCHECK(7,NCRVL,ANCRVL)
            LEVEL(NCRVL)=LEVEL(L)
            L=L+1
   28       CONTINUE
          END IF
   30     CONTINUE
          IJ=II+CROSSD(II)+1
          IJ=CROSSD(IJ)
          CALL RINCR(10,NCRSSD,1)
          CALL RCHECK(10,NCRSSD,ANCRSS)
          CROSSD(NCRSSD)=SVTEMP+1
          DO 32 I=IJ,IJ+CROSSD(II)-1
          CALL RINCR(13,SVTEMP,1)
          VTEMP(SVTEMP)=VTEMP(I)
   32     CONTINUE
        ELSE
          LPOINT(NVIN)=0
          CDMPNT(NVIN)=0
        END IF
   40   CONTINUE
      END IF
C
C  Set BLXINC now to 1, since this is done elsewhere in the TRANSFORM
C  step for added blocks.
C
      BLXINC(NCLBLK)=1
C
   49 CONTINUE
      ICLBLK=ICLBLK+1
   50 CONTINUE
      IX(NTRANS*12-6)=NPASS-NPASSV
C
      ICLSS=NXPTI
C
C  Now set up pointers in ICLSS
C
      LASTBL=0
      II=NXPTIS
      DO 70 IPASS=NPASSV+1,NPASS
      IF(V2(IPASS).EQ.9) THEN
        ICLBLK=V1(IPASS)
      ELSE
        IV=V1(IPASS)
        ICLBLK=MXSIZE(IV)
      END IF
c    write(6,*)iclblk,blcpnt(iclblk),blncls(iclblk)
      IF(ICLBLK.EQ.LASTBL) THEN
        V3(IPASS)=V3(IPASS-1)
        IX(II+2)=ISIZE
        GO TO 69
      ELSE
        LASTBL=ICLBLK
      END IF
      ISIZE=1
      IF(BLNCLS(ICLBLK).GT.0) THEN
        ICLSSV=ICLSS
        K=ICLSSV+5
        CALL ROOMI(5)
        DO 60 ICLBAR=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1
        L=CLPNT(ICLBAR)
        IF(CLTYPE(ICLBAR).EQ.0) THEN
          ISIZE=ISIZE*(MSIZE(L)+1)
          DO 52 I=0,MSIZE(L)
          CALL ROOMI(3)
          IX(K)=L
          IX(K+1)=I
          IX(K+2)=I+1
          K=K+3
   52     CONTINUE
        ELSE
          ISIZE=ISIZE*MSIZE(L)
          CALL ROOMI(3)
          IX(K)=L
          IX(K+1)=0
          IX(K+2)=0
          K=K+3
        END IF
   60   CONTINUE
        ICLSS=K
        IX(ICLSSV+1)=ISIZE
        IX(ICLSSV)=(ICLSS-ICLSSV)/3-1
        IX(ICLSSV+2)=IX(ICLSSV)
        IX(ICLSSV+3)=0
        IX(ICLSSV+4)=0
        V3(IPASS)=ICLSSV
c
c      write(6,*)iclssv,(ix(i),i=iclssv,iclss-1)
c
      ELSE
        V3(IPASS)=0
      END IF
      IX(II+2)=ISIZE
   69 CONTINUE
      II=II+3
   70 CONTINUE
      RETURN
      END
C
C  End of T1.FOR
CC
C  Start of T2.FOR - Initial file setup and start of execution for
C                    TRANSFORM step.
C
      SUBROUTINE TCREA1
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
C
      PARAMETER (MTRANS=1500,MRANGS=20)
      PARAMETER (MTRSZI=MSIZEI+6*MRANGE-6*MRANGS+2*MRNSET+MRECOD+MVAR)
      PARAMETER (IXFLLD=57+3*MAXIDS)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
C
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STMBLK/IX,RANGE,RGROUP,RTYPE,RSTPNT,V1,V2,V3,MXSIZE,
     . IOUT,IOUTL
      DOUBLE PRECISION RANGE(2,MRANGS)
      INTEGER IX(MTRSZI),RGROUP(MRANGS),RTYPE(MRANGS),RSTPNT(MRECOD),
     . V1(MRECOD),V2(MRECOD),V3(MRECOD),MXSIZE(MVAR),IOUT(MVAR),
     . IOUTL(MVAR)
C
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      LOGICAL REFRSH,ALPCHK,DGTCHK
      EXTERNAL REFRSH,ALPCHK,DGTCHK
C
      INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID,
     . SDWRK,VKEEPF,IXFILL(IXFLLD)
      COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,
     . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF,
     . IXFILL
C
      INTEGER SIDMPT,SIDXPT,SIMSIZ,SIMTYP,SIDIM
C
  106 FORMAT(/,15X,'Reduction in Blocks',/,16X,'Old   Retained as')
  107 FORMAT(/,15X,I4,7X,I4)
  205 FORMAT(' UNRECOGNIZED VARIABLE NAME ',A12)
C
C  Edit VNKEEP for unrecognized names
C
      IF(NKEEP.GT.0) THEN
        DO 1 I=1,NKEEP
        CALL VNMTCH(VNKEEP(I),VNAME,NVIN,J)
        IF(J.EQ.0) THEN
          WRITE(U6,205)VNKEEP(I)
          CALL FESTOP(200300)
        END IF
    1   CONTINUE
      END IF
C
C  IOUT   - stores internal order of variables wrt outgoing order
C  IOUTL  - stores variable order on outgoing file wrt internal order
C  IOUTC  - index of outgoing variable
C  ILOC   - computed position in output VPLX file
C  NCLBL2 - index of outgoing block
C  NCLBR2 - index of outgoing associated classes
C  SICLBK - starting location for pointers to original blocks, wrt
C           blocks on outgoing file
C  SIXINC - starting location for lengths of X vector for each
C           block, including N of block, if present
C  SICMUL - starting location for multipliers showing effect of
C           classes on total block size
C  SIXSTR - starting location for starting positions of each block
C           to be written to outgoing file.
C  SIVMAP - starting location for storage in outgoing VPLX file,
C           for outgoing variables
C
      DO 75 I=1,NVIN
      IOUTL(I)=0
  75  CONTINUE
      IOUTC=0
      ILOC=1
      NCLBL2=0
      NCLBR2=0
      SICLBK=NXPTI
      SIXINC=NXPTI+NCLBLK
      SICMUL=SIXINC+NCLBLK
      SIXSTR=SICMUL+NCLBLK
      K=4*NCLBLK
      CALL ROOMI(K)
      SIVMAP=NXPTI
      CALL ROOMI(NVIN)
C
C  Loop over blocks, computing ICSIZE - multiplier from class variables
C  to be stored starting at SICMUL
C
      DO 6 ICLBLK=1,NCLBLK
      ILOCSV=ILOC
      ICSIZE=1
      IF(BLNCLS(ICLBLK).GE.1) THEN
        DO 2 I=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1
        IF(CLTYPE(I).EQ.0) THEN
          ICSIZE=ICSIZE*(MSIZE(CLPNT(I))+1)
        ELSE
          ICSIZE=ICSIZE*(MSIZE(CLPNT(I)))
        END IF
    2   CONTINUE
      END IF
      IX(SICMUL+ICLBLK-1)=ICSIZE
C
C  Check for reduction in blocks
C
      IF(BLXSIZ(ICLBLK).EQ.0)GO TO 5
C
C  Save space for N of block
C
      IF(BLTYPE(ICLBLK).EQ.1)ILOC=ILOC+1
C
C  If KEEP statement, select variables in block on basis of block
C  number stored in MXSIZE by TSET1
C
      IF(NKEEP.GT.0.AND.VKEEPF.EQ.1) THEN
        DO 3 I=1,NKEEP
        CALL VNMTCH(VNKEEP(I),VNAME,NVIN,J)
        IF((J.LE.NVREG.OR.J.GT.NVTOT).AND.MTYPE(J).NE.4) THEN
          IF(MXSIZE(J).EQ.ICLBLK) THEN
            IX(SIVMAP+IOUTC)=ILOC
            IOUTC=IOUTC+1
            IOUT(IOUTC)=J
            IOUTL(J)=IOUTC
            ILOC=ILOC+MSIZE(J)
          END IF
        END IF
    3   CONTINUE
C
C  Treatment of DROP and instances without either KEEP or DROP
C
      ELSE
        DO 4 I=1,NVIN
        IF(MTYPE(I).EQ.4)GO TO 4
        IF(I.LE.NVREG.OR.I.GT.NVTOT) THEN
          IF(NKEEP.GT.0) THEN
            CALL VNMTCH(VNAME(I),VNKEEP,NKEEP,J)
            IF(J.GT.0)GO TO 4
          END IF
          IF(MXSIZE(I).EQ.ICLBLK) THEN
            IX(SIVMAP+IOUTC)=ILOC
            IOUTC=IOUTC+1
            IOUT(IOUTC)=I
            IOUTL(I)=IOUTC
            ILOC=ILOC+MSIZE(I)
          END IF
        END IF
    4   CONTINUE
      END IF
C
C  Whether or not any variables from block on output, compute
C  position of internal storage
C
    5 CONTINUE
      IX(SIXINC+ICLBLK-1)=ILOC-ILOCSV
C
C  Adjust ILOC for effect of class variables
C
      ILOC=ILOC+(ICSIZE-1)*(ILOC-ILOCSV)
C
C  If any part of the block is saved, save associated classes
C
      IF(ILOC.GT.ILOCSV) THEN
        NCLBR2=NCLBR2+BLNCLS(ICLBLK)
        IX(SICLBK+NCLBL2)=ICLBLK
        NCLBL2=NCLBL2+1
      END IF
    6 CONTINUE
C
C  Display for reduction in blocks
C
      IF(NCLBL2.LT.NCLBLK.AND.U5ECHO.GT.0) THEN
        WRITE(U6,106)
        DO 7 I=1,NCLBL2
        WRITE(U6,107)IX(SICLBK+I-1),I
    7   CONTINUE
      END IF
C
C  IOUTC3 - saves number of outgoing regular variables (excluding
C           class variables
C  NC     - count of class variables on outgoing file.
C
      IOUTC3=IOUTC
      NC=0
C
C  Identify class variables on output file
C
      DO 12 I=1,NVIN
      IF(MTYPE(I).NE.4)GO TO 12
C
C  ICLBL2 loops over outgoing blocks.
C
      DO 9 ICLBL2=1,NCLBL2
C
C  ICLBLK picks up corresponding internal block number
C
      ICLBLK=IX(SICLBK+ICLBL2-1)
      IF(BLNCLS(ICLBLK).GT.0) THEN
        DO 8 I2=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1
        IF(CLPNT(I2).EQ.I) THEN
C
C  Inclusion of class variable on outgoing file.
C
          NC=NC+1
          IOUTC=IOUTC+1
          IOUT(IOUTC)=I
          IOUTL(I)=IOUTC
C
C  Once class variable is stored, end search over blocks.
C
          GO TO 12
        END IF
    8   CONTINUE
      END IF
    9 CONTINUE
C
C  If the class variable is not used on any outgoing block, exclude
C  it from the outgoing file.
C
   12 CONTINUE
C
C  IOUTC4 - saves total outgoing variables, including class variables
C
      IOUTC4=IOUTC
C
C  Continue to carry BY variables, weight variables, etc.
C
      IF(NVARID+NBY+NWGT.GT.0) THEN
        DO 13 I=NVREG+NCLASS+1,NVTOT
        IOUTC=IOUTC+1
        IOUT(IOUTC)=I
   13   CONTINUE
      END IF
C
C  IOUTSZ - total size of outgoing file
C
      IOUTSZ=ILOC-1
C
C  Begin to write outgoing file here
C
      WRITE(11)IVERSN
      WRITE(11)IOUTC,IOUTC3,NC,NVARID,NBY,NWGT,VFTYPE,
     .   VROPTN,NIDTOT,IOUTSZ,NCLBL2,NCLBR2
C
C  IXST   - for outgoing file, pointer to starting position of
C           block in X matrix.
C
      IXST=1
      IVS=1
      J=1
      IBLPNT=1
C
C  Assemble information on each outgoing block.  There is an apparent
C  recalculation of information previously determined and stored
C  starting at SICMUL ? in loop to 15
C
      DO 17 ICLBL2=1,NCLBL2
C
C  ICLBLK picks up corresponding internal block number
C
      ICLBLK=IX(SICLBK+ICLBL2-1)
      IXINC=0
      IV=0
      IF(BLTYPE(ICLBLK).EQ.1)IXINC=1
   14 CONTINUE
      IF(J.LE.IOUTC3) THEN
        IF(MXSIZE(IOUT(J)).EQ.ICLBLK) THEN
          IXINC=IXINC+MSIZE(IOUT(J))
          IV=IV+1
          J=J+1
          GO TO 14
        END IF
      END IF
      IXSIZ=IXINC
      IF(BLNCLS(ICLBLK).GT.0) THEN
        DO 15 I=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1
        IF(CLTYPE(I).EQ.0) THEN
          IXSIZ=IXSIZ*(MSIZE(CLPNT(I))+1)
        ELSE
          IXSIZ=IXSIZ*(MSIZE(CLPNT(I)))
        END IF
   15   CONTINUE
      END IF
      WRITE(11)BLTYPE(ICLBLK),IXST,IXINC,IXSIZ,IVS,IV,
     .         BLNCLS(ICLBLK),IBLPNT
      IX(SIXSTR+ICLBLK-1)=IXST
      IXST=IXST+IXSIZ
      IXINC=0
      IVS=IVS+IV
      IV=0
      IBLPNT=IBLPNT+BLNCLS(ICLBLK)
   17 CONTINUE
C
C  Class information for outgoing blocks
C
      IF(NCLBR2.GT.0) THEN
        NXPTIS=NXPTI
        CALL ROOMI(NCLBR2)
C
C  Loop to collect CLTYPE (presence of margin)
C
        ICLBAR=0
        DO 20 ICLBL2=1,NCLBL2
        ICLBLK=IX(SICLBK+ICLBL2-1)
        IF(BLNCLS(ICLBLK).GT.0) THEN
          DO 18 I=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1
          IX(NXPTIS+ICLBAR)=CLTYPE(I)
          ICLBAR=ICLBAR+1
   18     CONTINUE
        END IF
   20   CONTINUE
        CALL INTOUT(11,IX(NXPTIS),ICLBAR)
C
C  Loop to construct pointers to class variables
C
        ICLBAR=0
        DO 22 ICLBL2=1,NCLBL2
        ICLBLK=IX(SICLBK+ICLBL2-1)
        IF(BLNCLS(ICLBLK).GT.0) THEN
          DO 21 I=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1
          IX(NXPTIS+ICLBAR)=IOUTL(CLPNT(I))
          ICLBAR=ICLBAR+1
   21     CONTINUE
        END IF
   22   CONTINUE
        CALL INTOUT(11,IX(NXPTIS),ICLBAR)
        NXPTI=NXPTIS
      END IF
C
C  Information on outgoing variables
C
      IF(IOUTC.GT.0) THEN
        NXPTIS=NXPTI
        CALL ROOMI(IOUTC)
C
C  Loop to collect variable types
C
        IC=0
        DO 24 I=1,IOUTC
        IX(NXPTIS+IC)=MTYPE(IOUT(I))
        IC=IC+1
   24   CONTINUE
        CALL INTOUT(11,IX(NXPTIS),IOUTC)
C
C  Loop to collect variable sizes
C
        IC=0
        DO 26 I=1,IOUTC
        IX(NXPTIS+IC)=MSIZE(IOUT(I))
        IC=IC+1
   26   CONTINUE
        CALL INTOUT(11,IX(NXPTIS),IOUTC)
        NXPTI=NXPTIS
      END IF
C
C  If any regular variables, output pointers to starting locations
C
      IF(IOUTC3.GT.0) THEN
        CALL INTOUT(11,IX(SIVMAP),IOUTC3)
      END IF
C
C  Dimensions of crossed variables.
C
      ILC=0
      IVC=0
      DO 30 I=1,IOUTC3
      J=MTYPE(IOUT(I))
      IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN
        K=CDMPNT(IOUT(I))
        L=CROSSD(K)
        IF(NXPTI+ILC+L.GT.MTRSZI) THEN
          L=L+ILC+2
          CALL ROOMI(L)
        END IF
        IX(NXPTI+ILC)=L
        ILC=ILC+1
        DO 28 M=1,L
        K=K+1
        IX(NXPTI+ILC)=CROSSD(K)
        ILC=ILC+1
   28   CONTINUE
        IX(NXPTI+ILC)=IVC+1
        ILC=ILC+1
        IVC=IVC+L
      END IF
   30 CONTINUE
      WRITE(11)ILC
      IF(ILC.GT.0)CALL INTOUT(11,IX(NXPTI),ILC)
C
      ILC=0
C
C  Output variable names and labels, and compute total number of output
C  levels, ILC
C
      DO 33 I=1,IOUTC
      J=MTYPE(IOUT(I))
      WRITE(11)VNAME(IOUT(I)),LABEL(IOUT(I))
      IF(J.EQ.3.OR.J.EQ.4.OR.J.EQ.5.OR.J.EQ.13) THEN
        ILC=ILC+MSIZE(IOUT(I))
      ELSE IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN
        K=CDMPNT(IOUT(I))
        L=CROSSD(K)
        DO 32 M=1,L
        K=K+1
        ILC=ILC+CROSSD(K)+1
   32   CONTINUE
      END IF
   33 CONTINUE
      WRITE(11)ILC
C
C  Output level labels here.
C
      DO 38 I=1,IOUTC
      J=MTYPE(IOUT(I))
      IF(J.EQ.3.OR.J.EQ.4.OR.J.EQ.5.OR.J.EQ.13) THEN
        ILC=MSIZE(IOUT(I))
      ELSE IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN
        K=CDMPNT(IOUT(I))
        L=CROSSD(K)
        ILC=0
        DO 36 M=1,L
        K=K+1
        ILC=ILC+CROSSD(K)+1
   36   CONTINUE
      ELSE
        GO TO 38
      END IF
      L=LPOINT(IOUT(I))
      DO 37 J=1,ILC
      WRITE(11)LEVEL(L)
      L=L+1
   37 CONTINUE
   38 CONTINUE
C
C  IVC is number of associated variable names for crossed variables
C
      WRITE(11)IVC
C
C  Output crossed variable names.
C
      DO 42 I=1,IOUTC
      J=MTYPE(IOUT(I))
      IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN
        K=CDMPNT(IOUT(I))
        L=CROSSD(K)
        K2=CROSSD(K+L+1)
        DO 41 M=1,L
        WRITE(11)VTEMP(K2)
        K2=K2+1
   41   CONTINUE
      END IF
   42 CONTINUE
C
C  Output information on BY variables.
C
      IF(NBY.GE.1) THEN
        WRITE(11)NBYGRP
        K=SDBYID-1
        DO 44 I=1,NBYGRP
        WRITE(11)(DX(K+J),J=1,NBY)
        K=K+NBY
   44   CONTINUE
      END IF
C
C  Information on replicates
C
      WRITE(11)NRPTOT
      IF(NRPTOT.GT.0) THEN
        CALL UNFOUT(11,DX(SDCOEF),NRPTOT)
      END IF
C
C  From here to the end of the routine, determine use of double
C  precision array.
C
C  Move any CONSTANTS to follow incoming matrix.
C
      IF(NXPTD.GT.SDCONS) THEN
        IF(SDCONS.GT.TSIZE+1) THEN
          K=TSIZE+1
          DO 45 I=SDCONS,NXPTD-1
          DX(K)=DX(I)
          K=K+1
   45     CONTINUE
        ELSE IF(SDCONS.LT.TSIZE+1) THEN
          K=TSIZE+NXPTD-SDCONS
          DO 46 I=NXPTD-1,SDCONS,-1
          DX(K)=DX(I)
          K=K-1
   46     CONTINUE
        END IF
        K=TSIZE-SDCONS+1
        DO 47 I=1,NTRANS
        IF(IX(I*12-5).GT.0)IX(I*12-5)=IX(I*12-5)+K
   47   CONTINUE
      END IF
C
C  Reset the current use of double precision to accommodate the
C  incoming matrix and the constants.
C
      I=TSIZE+NXPTD-SDCONS
      NXPTD=1
      CALL ROOMD(I)
      ILOC=NXPTD
C
C  Allocate space for new variables not output, just beyond incoming
C  variables and constants.  These variables will be stored without
C  regard to block.
C
      IF(NVIN.GT.NVTOT) THEN
        DO 50 I=NVTOT+1,NVIN
        IF(MTYPE(I).EQ.4)GO TO 50
        IF(IOUTL(I).EQ.0) THEN
          VMAPL(I)=ILOC
          ICLBLK=MXSIZE(I)
          ILOC=ILOC+MSIZE(I)*IX(SICMUL+ICLBLK-1)
        END IF
   50   CONTINUE
      END IF
C
C  Allocate space for new N of block not included on outgoing file.
C  This code was added Jan. 1996 and expanded the scope of the
C  REMOVE BLOCK statement.  Previously, REMOVE BLOCK was restricted
C  to blocks on the incoming file, but in Jan. 1996, the scope was
C  expanded to all blocks.
C
      IF(NCLBLK.GT.NCLBLS) THEN
        DO 51 ICLBLK=NCLBLS+1,NCLBLK
        IF(BLXSIZ(ICLBLK).EQ.0.AND.BLTYPE(ICLBLK).EQ.1) THEN
          BLXSTR(ICLBLK)=ILOC
          BLXINC(ICLBLK)=1
          ILOC=ILOC+IX(SICMUL+ICLBLK-1)
        END IF
   51   CONTINUE
      END IF
C
C  Readjust IX(SIVMAP) to point to actual locations.  The resulting
C  order in DX will be:
C     1) Incoming matrix
c     2) Constants
C     3) New variables not on output file
C     4) Output matrix
C
      NXPTD=1
      SDTOUT=ILOC
      ILOC=ILOC-1+IOUTSZ
      CALL ROOMD(ILOC)
      ILOC=SDTOUT-1
      IF(IOUTC3.GT.0) THEN
        DO 52 I=1,IOUTC3
        IF(MTYPE(IOUT(I)).EQ.4) GO TO 52
        IX(SIVMAP+I-1)=IX(SIVMAP+I-1)+ILOC
   52   CONTINUE
      END IF
C
C  Allocate space for ID of replicate
C  DX(SDID) will hold the number of the replicate, 0, 1, etc.
C  to be passed to subroutines, followed by the NIDTOT id's on the
C  incoming and outgoing file.
C
      SDID=NXPTD
      IF(IVERSN.EQ.9004) THEN
        NID=NVARID+NBY+1
      ELSE
        NID=NIDTOT+1
      END IF
      CALL ROOMD(NID)
      IXBASE=1
C
C  SDWRK, in common, is start of work space.
C
      SDWRK=NXPTD
C
C  Final loop over all transformations to create pointers to variables
C
      IF(NTRANS.GT.0) THEN
        DO 78 ITRANS=1,NTRANS
        IX(ITRANS*12)=NXPTI
        NV=IX(ITRANS*12-8)+IX(ITRANS*12-7)+IX(ITRANS*12-6)
        IX(NXPTI)=NV
C
C  SIDMPT - starting location to pointer to dimensions of each passed
C           variable
C  SIDXPT - starting location to pointers to work space used to store
C           each variable
C  SIMSIZ - starting location to size attribute of each variable
C  SIMTYP - starting location to type attribute of each variable
C  SIDIM  - starting location of arrays with dimensions of each variable
C
        SIDMPT=NXPTI+2
        SIDXPT=SIDMPT+NV
        SIMSIZ=SIDXPT+NV
        SIMTYP=SIMSIZ+NV
        SIDIM=SIMTYP+NV
        K=4*NV+2
        CALL ROOMI(K)
        IPASS=IX(ITRANS*12-1)
C
C  IDIM   - relative position in dimension array
C  MDIM   - maximum size of dimension array
C  IWKR   - set to SDWRK and incremented to show storage of variables in
C           temporary space.  This is a position in the DX array, not a
C           relative position
C  MXISIZ - maximum size of matrix with any one variable.
C
        IDIM=0
        MDIM=MTRSZI-NXPTI
        IWRK=SDWRK
        MXISIZ=1
        DO 76 IV=1,NV
        IX(SIDMPT+IV-1)=IDIM+1
        IX(SIDXPT+IV-1)=IWRK
        IDIMSV=IDIM
        IDIM=IDIM+1
C
C  Generate error message if out of room for dimensions.
C
        IF(IDIM.GT.MDIM)CALL ROOMI(IDIM)
C
C  Adjustments for N of block.
C
        IF(V2(IPASS).EQ.9) THEN
          ICLBLK=V1(IPASS)
          IX(SIMSIZ+IV-1)=1
          IX(SIMTYP+IV-1)=0
          IF(IX(SICMUL+ICLBLK-1).GT.MXISIZ)MXISIZ=IX(SICMUL+ICLBLK-1)
C
C  All other variable types.
C
        ELSE
          IVAR=V1(IPASS)
          ICLBLK=MXSIZE(IVAR)
          IMTYPE=MTYPE(IVAR)
          IX(SIMTYP+IV-1)=IMTYPE
C
C  OLD variables
C
          IF(IPASS.LT.IX(ITRANS*12-1)+IX(ITRANS*12-8)) THEN
C
C  The size of the variable was previously determined in TSET1
C
            IX(SIMSIZ+IV-1)=RSTPNT(IPASS)
C
C  CAT or single-dimensioned DERIVED variable.
C
            IF(IMTYPE.EQ.3.OR.IMTYPE.EQ.13) THEN
C
C  default, TOTAL, PROPORTION
C
              IF(V2(IPASS).LE.2.OR.V2(IPASS).EQ.6) THEN
                IX(SIDIM+IDIM)=MSIZE(IVAR)
                IDIM=IDIM+1
                IF(IDIM.GT.MDIM)CALL ROOMI(IDIM)
C
C  PERCENT1, TOTAL1, PROPORTION1
C
              ELSE IF(V2(IPASS).EQ.3.OR.V2(IPASS).EQ.4.OR.
     .                V2(IPASS).EQ.7) THEN
                IX(SIDIM+IDIM)=MSIZE(IVAR)-1
                IF(MSIZE(IVAR).EQ.1)IX(SIDIM+IDIM)=1
                IDIM=IDIM+1
                IF(IDIM.GT.MDIM)CALL ROOMI(IDIM)
              END IF
C
C  CROSSED REAL variables
C
            ELSE IF(IMTYPE.EQ.8) THEN
              J=CDMPNT(IVAR)
              N=CROSSD(J)
              J=J+1
              DO 63 I=2,N
              J=J+1
              IX(SIDIM+IDIM)=CROSSD(J)
              IDIM=IDIM+1
              IF(IDIM.GT.MDIM)CALL ROOMI(IDIM)
   63         CONTINUE
C
C  CROSSED CAT, CROSSED DERIVED.
C
            ELSE IF(IMTYPE.EQ.9.OR.IMTYPE.EQ.19) THEN
              J=CDMPNT(IVAR)
              N=CROSSD(J)
C
C  N of variable
C
              IF(V2(IPASS).EQ.8) THEN
                J=J+1
                DO 64 I=2,N
                J=J+1
                IX(SIDIM+IDIM)=CROSSD(J)
                IDIM=IDIM+1
                IF(IDIM.GT.MDIM)CALL ROOMI(IDIM)
   64           CONTINUE
C
C  All other transformations.
C
              ELSE
                DO 65 I=1,N
                J=J+1
                IF(V2(IPASS).LE.2.OR.V2(IPASS).EQ.5.OR.V2(IPASS).EQ.6
     .             .OR.I.GT.1) THEN
                  IX(SIDIM+IDIM)=CROSSD(J)
                ELSE
                  IX(SIDIM+IDIM)=CROSSD(J)-1
                  IF(CROSSD(J).EQ.1)IX(SIDIM+IDIM)=1
                END IF
                IDIM=IDIM+1
                IF(IDIM.GT.MDIM)CALL ROOMI(IDIM)
   65           CONTINUE
              END IF
            END IF
C
C  MODIFY or new variables.
C
          ELSE
            IX(SIMSIZ+IV-1)=MSIZE(IVAR)
C
C  CAT or single-dimension CROSS DERIVED
C
            IF(IMTYPE.EQ.3.OR.IMTYPE.EQ.13) THEN
              IX(SIDIM+IDIM)=MSIZE(IVAR)
              IDIM=IDIM+1
              IF(IDIM.GT.MDIM)CALL ROOMI(IDIM)
C
C  CROSSED REAL
C
            ELSE IF(IMTYPE.EQ.8) THEN
              J=CDMPNT(IVAR)
              N=CROSSD(J)
              J=J+1
              DO 66 I=2,N
              J=J+1
              IX(SIDIM+IDIM)=CROSSD(J)
              IDIM=IDIM+1
              IF(IDIM.GT.MDIM)CALL ROOMI(IDIM)
   66         CONTINUE
C
C  CROSSED CAT, CROSSED DERIVED
C
            ELSE IF(IMTYPE.EQ.9.OR.IMTYPE.EQ.19) THEN
              J=CDMPNT(IVAR)
              N=CROSSD(J)
              DO 67 I=1,N
              J=J+1
              IX(SIDIM+IDIM)=CROSSD(J)
              IDIM=IDIM+1
              IF(IDIM.GT.MDIM)CALL ROOMI(IDIM)
   67         CONTINUE
            END IF
          END IF
C
C  Compute total original size of variable multiplied by effect of
C  classes, and update MXISIZ, if appropriate.
C
          K=MSIZE(IVAR)*IX(SICMUL+ICLBLK-1)
          IF(K.GT.MXISIZ)MXISIZ=K
        END IF
C
C  For all variable types, including N of block, work out effect of
C  class variables.
C
        ISIZE=IX(SIMSIZ+IV-1)
        ICLSS=V3(IPASS)
        IF(ICLSS.GT.0) THEN
          NSPTOT=IX(ICLSS)
          IS=ICLSS+2
   68     CONTINUE
          N=IX(IS)
          IS=IS+3
          DO 70 I=1,N
          IF(IX(IS).EQ.0)GO TO 69
          IF(I.LT.N) THEN
            IF(IX(IS).EQ.IX(IS+3))GO TO 69
          END IF
          IF(IX(IS+2).EQ.0) THEN
            IG=MSIZE(IX(IS))
          ELSE
            IG=IX(IS+2)
          END IF
          IX(SIDIM+IDIM)=IG
          IDIM=IDIM+1
          IF(IDIM.GT.MDIM)CALL ROOMI(IDIM)
          ISIZE=ISIZE*IG
   69     CONTINUE
          IS=IS+3
   70     CONTINUE
          IF(IS.LT.ICLSS+NSPTOT*3+2)GO TO 68
        END IF
        IWRK=IWRK+ISIZE
C
C  Compute number of elements in dimension array for the variable
C  and store as first element
C
        IX(SIDIM+IDIMSV)=IDIM-IDIMSV-1
        IPASS=IPASS+1
   76   CONTINUE
        CALL ROOMI(IDIM)
        IX(IX(ITRANS*12)+1)=IWRK-SDWRK
        IF(IWRK+MXISIZ.GT.MSIZED) THEN
          IWRK=IWRK-SDWRK+1+MXISIZ
          CALL ROOMD(IWRK)
        END IF
   78   CONTINUE
      END IF
      RETURN
      END
C
C  End of T2.FOR
CC
C  Start of T3.FOR - TRANSFORM execution, and some of the associated
C                    subroutines that it calls (others in UC.FOR)
C
      SUBROUTINE TCREA2
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
C
      PARAMETER (MTRANS=1500,MRANGS=20)
      PARAMETER (MTRSZI=MSIZEI+6*MRANGE-6*MRANGS+2*MRNSET+MRECOD+MVAR)
      PARAMETER (IXFLLD=57+3*MAXIDS)
C
      PARAMETER (MAXFMT=20)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
C
      LOGICAL REFRSH,ALPCHK,DGTCHK
      EXTERNAL REFRSH,ALPCHK,DGTCHK
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
C
C       NVARID  (NID1)
C
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STMBLK/IX,RANGE,RGROUP,RTYPE,RSTPNT,V1,V2,V3,MXSIZE,
     . IOUT,IOUTL
      DOUBLE PRECISION RANGE(2,MRANGS)
      INTEGER IX(MTRSZI),RGROUP(MRANGS),RTYPE(MRANGS),RSTPNT(MRECOD),
     . V1(MRECOD),V2(MRECOD),V3(MRECOD),MXSIZE(MVAR),IOUT(MVAR),
     . IOUTL(MVAR)
C
      INTEGER SIDMPT,SIDXPT,SIMSIZ,SIMTYP,SIDIM
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
      LOGICAL ENDFLE
C
      INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID,
     . SDWRK,VKEEPF,IXFILL(IXFLLD)
      COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,
     . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF,
     . IXFILL
C
  200 FORMAT(' FATAL ERROR ON FIRST CALL TO SUBROUTINE',I6)
  201 FORMAT(' FATAL ERROR, SUBROUTINE',I6,', REPLICATE',I6)
  202 FORMAT(' FATAL ERROR, SUBROUTINE',I6,', REPLICATE',I6,
     . ', BY GROUP #',I6)
  203 FORMAT(' (WARNING FROM FIRST CALL TO SUBROUTINE',I6,')',/)
  204 FORMAT(' (WARNING FROM SUBROUTINE',I6,', REPLICATE',I6,')',/)
  205 FORMAT(' (WARNING FROM SUBROUTINE',I6,', REPLICATE',I6,
     . ', BY GROUP #',I6,')',/)
  206 FORMAT(/,5X,'Additional space allocated by subroutine',I6)
C
      CALL SCOPEN(13)
      IFIRST=1
      IERROR=0
C
C  Loop over each BY group and each replicate
C
      DO 90 IGRP=1,NBYGRP
      DO 89 IREP=0,NRPTOT
      DX(SDID)=IREP
C
C  Read ID record from input file and copy directly to output
C
      READ(12)(DX(SDID+J),J=1,NID-1)
      WRITE(11)(DX(SDID+J),J=1,NID-1)
C
C  Read incoming variables.
C
      CALL UNFIN(12,DX,TSIZE,ENDFLE)
C
C  Move incoming variables that will be retained on output
C
      DO 25 I=1,NVREG
      K=IOUTL(I)
      IF(K.GT.0) THEN
        ICLBLK=MXSIZE(I)
        II=VMAPL(I)
        KK=IX(SIVMAP+K-1)
        N=IX(SICMUL+ICLBLK-1)
        I1=BLXINC(ICLBLK)
        K1=IX(SIXINC+ICLBLK-1)
        DO 23 J=1,N
        DO 22 M=0,MSIZE(I)-1
        DX(KK+M)=DX(II+M)
   22   CONTINUE
        II=II+I1
        KK=KK+K1
   23   CONTINUE
      END IF
   25 CONTINUE
C
C  Move block n's that will be retained on output
C
      DO 28 ICLBLK=1,NCLBLS
      IF(BLXSIZ(ICLBLK).GT.0.AND.BLTYPE(ICLBLK).EQ.1) THEN
        II=BLXSTR(ICLBLK)
        KK=IX(SIXSTR+ICLBLK-1)+SDTOUT-1
        N=IX(SICMUL+ICLBLK-1)
        I1=BLXINC(ICLBLK)
        K1=IX(SIXINC+ICLBLK-1)
        DO 26 J=1,N
        DX(KK)=DX(II)
        II=II+I1
        KK=KK+K1
   26   CONTINUE
      END IF
   28 CONTINUE
C
C  Loop over subroutines.
C
      IF(NTRANS.GT.0) THEN
        DO 85 ITRANS=1,NTRANS
        NV=IX(IX(ITRANS*12))
        NXPTD=SDWRK
        CALL ROOMD(IX(IX(ITRANS*12)+1))
        NXPTDS=NXPTD
C
C  Same usage as in TCREA1:
C
C  SIDMPT - starting location to pointer to dimensions of each passed
C           variable
C  SIDXPT - starting location to pointers to work space used to store
C           each variable
C  SIMSIZ - starting location to size attribute of each variable
C  SIMTYP - starting location to type attribute of each variable
C  SIDIM  - starting location of arrays with dimensions of each variable
C
        SIDMPT=IX(ITRANS*12)+2
        SIDXPT=SIDMPT+NV
        SIMSIZ=SIDXPT+NV
        SIMTYP=SIMSIZ+NV
        SIDIM=SIMTYP+NV
        IPASS=IX(ITRANS*12-1)
C
C  Loop over OLD and MODIFY variables to copy information
C
        DO 35 IV=1,IX(ITRANS*12-8)+IX(ITRANS*12-7)
C
C  ICLBLK is block of variable.  Distinguish between N of a block and
C  all other transformations.
C
        IF(V2(IPASS).EQ.9) THEN
          ICLBLK=V1(IPASS)
        ELSE
          ICLBLK=MXSIZE(V1(IPASS))
        END IF
C
C  BLXSIZ is set to 0 in TSET1 for reduce blocks.  Find location of
C  N of block.
C
        IF(BLXSIZ(ICLBLK).GT.0) THEN
          ISN=IX(SIXSTR+ICLBLK-1)+SDTOUT-1
          INCN=IX(SIXINC+ICLBLK-1)
        ELSE
          ISN=BLXSTR(ICLBLK)
          INCN=BLXINC(ICLBLK)
        END IF
C
C  For N of block, location and increment has already been determined.
C  Otherwise, find location and increment of variable.
C
        IF(V2(IPASS).EQ.9) THEN
          IS=ISN
          INC=INCN
        ELSE
C
C  For a variable on the outgoing file:
C
          IF(IOUTL(V1(IPASS)).GT.0) THEN
            K=IOUTL(V1(IPASS))-1
            IS=IX(SIVMAP+K)
            INC=IX(SIXINC+ICLBLK-1)
C
C  For other variables.  New variables have an increment of 1.
C
          ELSE
            IS=VMAPL(V1(IPASS))
            IF(V1(IPASS).LE.NVTOT) THEN
              INC=BLXINC(ICLBLK)
            ELSE
              INC=1
            END IF
          END IF
        END IF
        ICLSS=V3(IPASS)
        IF(ICLSS.GT.0) THEN
          CALL TMOVE1(IS,INC,ISN,INCN,IX(SIDXPT+IV-1),1,
     .      IX(ICLSS+2),IX(ICLSS),ICLBLK,V1(IPASS),V2(IPASS))
        ELSE
          CALL TMOVE1(IS,INC,ISN,INCN,IX(SIDXPT+IV-1),1,IX,0,
     .      ICLBLK,V1(IPASS),V2(IPASS))
        END IF
C
C  If TMOVE1 returned in error, print error message identifying
C  subroutine number.
C
        IF(IMERR1.GT.0)GO TO 36
        IPASS=IPASS+1
   35   CONTINUE
C
C  Set up call to subroutine
C
        IKEY=IX(ITRANS*12-9)
        IPASS=IX(ITRANS*12-1)
        IFMT=IX(ITRANS*12-10)
        INT=IX(ITRANS*12-11)
        IF(IKEY.EQ.1) THEN
          CALL USER1(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),ITRANS,IERROR)
        ELSE IF(IKEY.EQ.2) THEN
          CALL USER2(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),ITRANS,IERROR)
        ELSE IF(IKEY.EQ.3) THEN
          CALL USER3(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),ITRANS,IERROR)
        ELSE IF(IKEY.EQ.4) THEN
          CALL USER4(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),ITRANS,IERROR)
        ELSE IF(IKEY.EQ.5) THEN
          CALL USER5(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),ITRANS,IERROR)
        ELSE IF(IKEY.EQ.6) THEN
          CALL USER6(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),ITRANS,IERROR)
        ELSE IF(IKEY.EQ.7) THEN
          CALL USER7(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),ITRANS,IERROR)
        ELSE IF(IKEY.EQ.8) THEN
          CALL USER8(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),ITRANS,IERROR)
        ELSE IF(IKEY.EQ.9) THEN
          CALL USER9(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),ITRANS,IERROR)
        ELSE IF(IKEY.EQ.10) THEN
          CALL USER10(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),ITRANS,IERROR)
        ELSE IF(IKEY.EQ.-1) THEN
          CALL REFRMT(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMTYP),V2(IPASS),IERROR)
        ELSE IF((IKEY.GE.-13.AND.IKEY.LE.-2).OR.IKEY.EQ.-21) THEN
          CALL ARITHM(IKEY,DX(SDID),NID,IFIRST,IX(ITRANS*12-8),
     .       IX(SIDMPT),IX(SIDIM),IX(SIDXPT),DX,IX(SIMTYP),V2(IPASS),
     .       IERROR)
        ELSE IF(IKEY.EQ.-14.OR.IKEY.EQ.-22) THEN
          CALL SAVEFL(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMTYP),V2(IPASS),IKEY,ITRANS,
     .       IERROR)
        ELSE IF(IKEY.EQ.-15) THEN
          CALL GLUE(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMTYP),V2(IPASS),IX(INT),
     .       IERROR)
        ELSE IF(IKEY.EQ.-16) THEN
          CALL RPRINT(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),V1(IPASS),IERROR)
        ELSE IF(IKEY.GE.-20.AND.IKEY.LE.-17) THEN
          CALL RWRITE(IKEY,DX(SDID),NID,IFIRST,IX(ITRANS*12-8),
     .       IX(SIDMPT),IX(SIDIM),IX(SIDXPT),DX,IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),ITRANS,IERROR)
        ELSE IF(IKEY.EQ.-23) THEN
          CALL CPSCOL(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),IERROR)
        ELSE IF(IKEY.EQ.-24) THEN
          CALL SIPCOL(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),IERROR)
        ELSE IF(IKEY.LE.-25.AND.IKEY.GE.-34) THEN
          CALL PSOLVE(IKEY,DX(SDID),NID,IFIRST,IX(ITRANS*12-8),
     .       IX(SIDMPT),IX(SIDIM),IX(SIDXPT),DX,IX(SIMTYP),V2(IPASS),
     .       IX(INT),IERROR)
        ELSE IF(IKEY.LE.-35.AND.IKEY.GE.-37) THEN
          CALL PEIGEN(IKEY,DX(SDID),NID,IFIRST,IX(ITRANS*12-8),
     .       IX(SIDMPT),IX(SIDIM),IX(SIDXPT),DX,IX(SIMTYP),V2(IPASS),
     .       IX(INT),IERROR)
        ELSE IF(IKEY.LE.-38.AND.IKEY.GE.-43) THEN
          CALL MSOLVE(IKEY,DX(SDID),NID,IFIRST,IX(ITRANS*12-8),
     .       IX(SIDMPT),IX(SIDIM),IX(SIDXPT),DX,IX(SIMTYP),V2(IPASS),
     .       IX(INT),IERROR)
        ELSE IF(IKEY.LE.-44.AND.IKEY.GE.-48) THEN
          CALL PBDIAG(IKEY,DX(SDID),NID,IFIRST,IX(ITRANS*12-8),
     .       IX(SIDMPT),IX(SIDIM),IX(SIDXPT),DX,IX(SIMTYP),V2(IPASS),
     .        IX(INT),IERROR)
        ELSE IF(IKEY.EQ.-49) THEN
          CALL CPSCHL(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),IERROR)
        ELSE IF(IKEY.EQ.-50) THEN
          CALL CPSNIC(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),IERROR)
        ELSE IF(IKEY.EQ.-51) THEN
          CALL GRIDSC(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),IERROR)
        ELSE IF(IKEY.EQ.-52) THEN
          CALL RAOSH(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMTYP),V2(IPASS),
     .       IX(INT),ITRANS,IERROR)
        ELSE IF(IKEY.EQ.-53) THEN
          CALL NCPSCH(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),IERROR)
        ELSE IF(IKEY.EQ.-54) THEN
          CALL NPSCHL(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),IERROR)
        ELSE IF(IKEY.EQ.-55) THEN
          CALL OCPSCH(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),IERROR)
        ELSE IF(IKEY.EQ.-56) THEN
          CALL XMEDN(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),IERROR)
        ELSE IF(IKEY.EQ.-57) THEN
          CALL SCRCOL(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),IERROR)
        ELSE IF(IKEY.EQ.-58) THEN
          CALL SCCCOL(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),IERROR)
        ELSE IF(IKEY.EQ.-59) THEN
          CALL SCRAKE(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),IERROR)
        ELSE IF(IKEY.EQ.-60) THEN
          CALL VAPPND(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),
     .       IX(SIDXPT),DX,IX(SIMSIZ),
     .       IX(INT),ITRANS,IERROR)
        ELSE IF(IKEY.EQ.-61) THEN
          CALL SCNCOL(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),IERROR)
        ELSE IF(IKEY.EQ.-62) THEN
          CALL CMPCOL(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT),
     .       IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS),
     .       INFRMT(IFMT),IX(INT),IERROR)
        END IF
   36   CONTINUE
C
C  Printing of error messages, if any
C
        IF(IERROR.EQ.1.OR.IMERR1.GT.0) THEN
          IF(IFIRST.EQ.1) THEN
            WRITE(U6,200)ITRANS
          ELSE IF(NBYGRP.EQ.1) THEN
            WRITE(U6,201)ITRANS,IREP
          ELSE
            WRITE(U6,202)ITRANS,IREP,IGRP
          END IF
          CALL FSTOP
        ELSE IF(IERROR.EQ.2) THEN
          IF(IFIRST.EQ.1) THEN
            WRITE(U6,203)ITRANS
          ELSE IF(NBYGRP.EQ.1) THEN
            WRITE(U6,204)ITRANS,IREP
          ELSE
            WRITE(U6,205)ITRANS,IREP,IGRP
          END IF
          IERROR=0
        END IF
C
C  Store MODIFY and new variables into locations.
C
        IPASS=IX(ITRANS*12-1)+IX(ITRANS*12-8)
        DO 45 IV=IX(ITRANS*12-8)+1,NV
C
C  Determine location for N of block
C
        IF(V2(IPASS).EQ.9) THEN
          ICLBLK=V1(IPASS)
          IF(BLXSIZ(ICLBLK).GT.0) THEN
            IS=IX(SIXSTR+ICLBLK-1)+SDTOUT-1
            INC=IX(SIXINC+ICLBLK-1)
          ELSE
            IS=BLXSTR(ICLBLK)
            INC=BLXINC(ICLBLK)
          END IF
C
C  Determine location for all other variables.
C
        ELSE
          ICLBLK=MXSIZE(V1(IPASS))
          IF(IOUTL(V1(IPASS)).GT.0) THEN
            K=IOUTL(V1(IPASS))-1
            IS=IX(SIVMAP+K)
            INC=IX(SIXINC+ICLBLK-1)
          ELSE
            IS=VMAPL(V1(IPASS))
            IF(V1(IPASS).LE.NVTOT) THEN
              INC=BLXINC(ICLBLK)
            ELSE
              INC=1
            END IF
          END IF
        END IF
c       if(ikey.eq.-60) then
c         write(6,*)iclblk,is,inc,ix(sidxpt+iv-1),dx(ix(sidxpt+iv-1)),
c    .     v3(ipass),(ix(v3(ipass)+iz),iz=0,4)
c       end if
        CALL TMOVE2(IPASS,IS,INC,IX(SIDXPT+IV-1),1,ICLBLK)
c       write(6,*)dx(is),dx(is+3)
        IPASS=IPASS+1
   45   CONTINUE
C
C  If the subroutine changed NXPTD, assume that the constants have been
C  specified/respecified.  Change the pointer to the start of the
C  constants matrix, and move the resulting constants below SDWRK, the
C  start of the working arrays to be passed to the subroutines.
C  Readjust all pointers starting at SIDXPT.
C
        IF(NXPTDS.NE.NXPTD) THEN
          IX(12*ITRANS-5)=SDWRK
          WRITE(U6,206)ITRANS
          DO 50 I=NXPTDS,NXPTD-1
          DX(SDWRK)=DX(I)
          SDWRK=SDWRK+1
   50     CONTINUE
          K=NXPTD-NXPTDS
          DO 55 I=1,NTRANS
          NV=IX(IX(I*12))
          SIDXPT=IX(I*12)+2+NV
          DO 53 IV=1,NV
          IX(SIDXPT+IV-1)=IX(SIDXPT+IV-1)+K
   53     CONTINUE
   55     CONTINUE
        END IF
   85   CONTINUE
      END IF
      CALL UNFOUT(11,DX(SDTOUT),IOUTSZ)
      IFIRST=0
      REWIND(13)
   89 CONTINUE
   90 CONTINUE
      CALL FCLALL
      RETURN
      END
C
      SUBROUTINE TMOVE2(IPASS,IS,INC1,IP,INC2,ICLBLK)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
C
      PARAMETER (MTRANS=1500,MRANGS=20)
      PARAMETER (MTRSZI=MSIZEI+6*MRANGE-6*MRANGS+2*MRNSET+MRECOD+MVAR)
      PARAMETER (IXFLLD=57+3*MAXIDS)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
C
C       NVARID  (NID1)
C
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STMBLK/IX,RANGE,RGROUP,RTYPE,RSTPNT,V1,V2,V3,MXSIZE,
     . IOUT,IOUTL
      DOUBLE PRECISION RANGE(2,MRANGS)
      INTEGER IX(MTRSZI),RGROUP(MRANGS),RTYPE(MRANGS),RSTPNT(MRECOD),
     . V1(MRECOD),V2(MRECOD),V3(MRECOD),MXSIZE(MVAR),IOUT(MVAR),
     . IOUTL(MVAR)
C
      INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID,
     . SDWRK,VKEEPF,IXFILL(IXFLLD)
      COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,
     . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF,
     . IXFILL
C
      INTEGER SI1,SI2,SI3,SI4,SI7,SI8,SI10
C
      ICLSS=V3(IPASS)
      NIN=BLNCLS(ICLBLK)
C
C  IVLEN is the length to be passed, for each combination of class
C  variables
C
 
      IF(V2(IPASS).EQ.9) THEN
        IVLEN=1
      ELSE
        IVLEN=MSIZE(V1(IPASS))
      END IF
      IS1=IS
C
C  If there is no class specification, then copy the values and return
C
      IF(ICLSS.EQ.0) THEN
        IF(IVLEN.EQ.1) THEN
C
C  Copy for single element
C
          DX(IS1)=DX(IP)
c         write(6,*)is1,dx(is1),iclss
        ELSE
C
C  Copy for multiple elements
C
          K=IP
          DO 2 I=1,IVLEN
          DX(IS1)=DX(K)
c         write(6,*)is1,dx(is1),iclss
          IS1=IS1+1
          K=K+1
    2     CONTINUE
        END IF
        RETURN
      END IF
C
C  Code when a class specification is provided.
C
C  Determine the increment for the temporary matrix
C
      IF(INC2.EQ.1) THEN
        IS2INC=IVLEN
      ELSE
        IS2INC=INC2
      END IF
C
C  This next section of code closely parallels SUBROUTINE TM1
C  The object is to discover whether the transfer can be handled
C  under the special case, beginning at statement 55, or the general
C  case, starting at 10.
C
      K=ICLSS+2
      ICLBAR=BLCPNT(ICLBLK)
   4  CONTINUE
      N=IX(K)
      K=K+3
      DO 6 J=1,N
C
C  The next statement assures that ICLBAR, which is incremented in
C  statements below, has not stepped beyond the appropriate range for
C  the block
C
c     write(6,*)iclblk,blcpnt(iclblk),nin,iclbar
      IF(BLCPNT(ICLBLK)+NIN.LE.ICLBAR)GO TO 10
C
C  The next statement checks that the CLASS specification points to
C  the right class variable.
C
C    write(6,*)k,ix(k),clpnt(iclbar)
      IF(IX(K).NE.CLPNT(ICLBAR))GO TO 10
C
C  If no range is given for the class variable, then the block
C  cannot be of type 0, with separate marginal total.
C
      IF(IX(K+2).EQ.0) THEN
C       write(6,*)ix(k+2),cltype(iclbar)
        IF(CLTYPE(ICLBAR).EQ.0)GO TO 10
        ICLBAR=ICLBAR+1
C
C  If a range is given for the class variable, then check that the
C  levels are specified in the right order.  For blocks of type 0,
C  level 0 must be specified first.
C
      ELSE
        IF(CLTYPE(ICLBAR).EQ.1) THEN
          IF(IX(K+1).NE.IX(K+2))GO TO 10
C
C  If the last level has been listed, then increment ICLBAR
C
          IF(IX(K+2).EQ.MSIZE(CLPNT(ICLBAR))) THEN
            ICLBAR=ICLBAR+1
          END IF
        ELSE
          IF(IX(K+1)+1.NE.IX(K+2))GO TO 10
C
C  If the last level has been listed, then increment ICLBAR
C
          IF(IX(K+2).EQ.MSIZE(CLPNT(ICLBAR))+1) THEN
            ICLBAR=ICLBAR+1
          END IF
        END IF
      END IF
      K=K+3
    6 CONTINUE
C
C  Loop back to 4 if more remains on the specification
C
c     write(6,*)k,iclss,ix(iclss)
      IF(K.LE.ICLSS+3*IX(ICLSS)+1) GO TO 4
C
C  This last check insures that all classes have matched, which will
C  be the case if ICLBAR has been incremented to just beyond the
C  range for the block.
C
C     write(6,*)iclbar,blcpnt(iclblk),nin
      IF(ICLBAR.EQ.BLCPNT(ICLBLK)+NIN)GO TO 55
C
C  Creating the output is handled either here or at statement 55
C  Treatment of the general case begins here.
C
   10 CONTINUE
C
C  Internal matrices:
C
C  IX(SI1+  ) - output dimensions
C  IX(SI2+  ) - output class
C  IX(SI3+  ) - pointer to first cell of output class
C  IX(SI4+  ) - ICLBAR for corresponding output class
C  IX(SI7+  ) - outgoing indices
C  IX(SI8+  ) - increments for input, in output order
C  IX(SI10+ ) - coordinate array for output cells, starts at 0
C
      NOUT=0
      NC=0
      SI1=NXPTI
      SI2=SI1+NIN
      SI3=SI2+NIN
      SI4=SI3+NIN
      SI8=SI4+NIN
      SI10=SI8+NIN
      K=6*NIN
C
C  Call ROOMI to allocate space
C
      CALL ROOMI(K)
C
C  Loop through specification to identify class variables
C
      K=ICLSS+2
      L=0
      IX(SI2)=0
      IS2=IP
   12 CONTINUE
      N=IX(K)
      K=K+3
C
C  The loop to 14 establishes the following
C    NOUT - the number of explicitly referenced class variables in the
C         specification
C    IX(SI1+  ) - output dimensions
C    IX(SI2+  ) - output class
C    IX(SI3+  ) - pointer to first cell of output class
C
      DO 14 J=1,N
      IF(IX(K).NE.IX(SI2+NOUT)) THEN
        IF(IX(SI2).GT.0)NOUT=NOUT+1
        IX(SI2+NOUT)=IX(K)
      END IF
C
C  Unless at the end of the specification, look ahead.
C  If the current part of the specification gives a level of a class
C  variable to be followed by other levels, do not store into IX(SI1+
C  yet.
C
      IF(J.LT.N) THEN
        K1=K+3
        IF(IX(K1).EQ.IX(K)) GO TO 13
      END IF
C
C  If this the last (possibly only) part of the specification to
C  refer to a class variable, store the number of outgoing levels
C  in IX(SI1+
C
      IF(IX(K+2).EQ.0) THEN
        IX(SI1+NOUT)=MSIZE(IX(K))
      ELSE
        IX(SI1+NOUT)=IX(K+2)
      END IF
      IX(SI3+NOUT)=NC
      NC=NC+IX(SI1+NOUT)
   13 CONTINUE
      K=K+3
   14 CONTINUE
      IF(K.LE.ICLSS+3*IX(ICLSS)+1)GO TO 12
C
C  The loop to 20 establishes the following:
C    IX(SI4+  ) - ICLBAR for corresponding output class
C    IX(SI8+  ) - increments for input, in output order
C  and initializes to 0
C    IX(SI10+ ) - coordinate array for output cells
C
      NOUT=NOUT+1
      ICLBAR=BLCPNT(ICLBLK)
      I1=INC1
      DO 20 I=1,NIN
      IX(SI10+I-1)=0
      DO 18 J=1,NOUT
      IF(IX(SI2+J-1).EQ.CLPNT(ICLBAR)) THEN
        IX(SI4+J-1)=ICLBAR
        IX(SI8+J-1)=I1
        GO TO 19
      END IF
   18 CONTINUE
   19 CONTINUE
      IF(CLTYPE(ICLBAR).EQ.1) THEN
        I1=I1*MSIZE(CLPNT(ICLBAR))
      ELSE
        I1=I1*(MSIZE(CLPNT(ICLBAR))+1)
      END IF
      ICLBAR=ICLBAR+1
   20 CONTINUE
C
      SI7=SI10+NIN
      CALL ROOMI(NC)
      K=ICLSS+2
      LOUT=0
      ICL=0
   22 CONTINUE
      N=IX(K)
      K=K+3
C
C  The loop to 24 computes:
C    IX(SI7+  ) - outgoing indices
C  LOUT points to current class variable in IX(SI2+ )
C
      DO 24 J=1,N
      IF(IX(K).NE.IX(SI2+LOUT)) THEN
        IF(ICL.GT.0)LOUT=LOUT+1
      END IF
      IF(IX(K+2).EQ.0) THEN
        DO 23 JJ=1,MSIZE(IX(K))
        IF(CLTYPE(IX(SI4+LOUT)).EQ.1) THEN
          IX(SI7+ICL)=JJ-1
        ELSE
          IX(SI7+ICL)=JJ
        END IF
        ICL=ICL+1
   23   CONTINUE
      ELSE IF(CLTYPE(IX(SI4+LOUT)).EQ.1) THEN
        IX(SI7+ICL)=IX(K+1)-1
        ICL=ICL+1
      ELSE
        IX(SI7+ICL)=IX(K+1)
        ICL=ICL+1
      END IF
      K=K+3
   24 CONTINUE
      IF(K.LE.ICLSS+3*IX(ICLSS)+1)GO TO 22
C
      IX(SI10)=-1
   32 CONTINUE
C
C  The loop to 34 increments the indices of output cells and
C  determines if done.
C
      DO 34 I=1,NOUT
      IX(SI10+I-1)=IX(SI10+I-1)+1
      IF(IX(SI10+I-1).LT.IX(SI1+I-1)) THEN
        IF(I.GT.1) THEN
          DO 33 J=1,I-1
          IX(SI10+J-1)=0
   33     CONTINUE
        END IF
        GO TO 36
      END IF
   34 CONTINUE
      NXPTI=SI1
      RETURN
   36 CONTINUE
      IS1=IS
C
C  The loop to 38 computes the index in the outgoing table.
C
      DO 38 I=1,NOUT
      ICL=IX(SI3+I-1)+IX(SI10+I-1)
      IS1=IS1+IX(SI8+I-1)*IX(SI7+ICL)
   38 CONTINUE
C
C  Store input into output
C
      IF(IVLEN.EQ.1) THEN
        DX(IS1)=DX(IS2)
C       write(6,*)is1,dx(is1)
      ELSE
        K=IS2
        DO 40 I=1,IVLEN
        DX(IS1)=DX(K)
C       write(6,*)is1,dx(is1)
        K=K+1
        IS1=IS1+1
   40   CONTINUE
      END IF
      IF(INC2.EQ.1) THEN
        IS2=IS2+IVLEN
      ELSE
        IS2=IS2+INC2
      END IF
      GO TO 32
   55 CONTINUE
      IS1=IS
      IS2=IP
      DO 50 I=1,IX(SICMUL+ICLBLK-1)
      IF(IVLEN.EQ.1) THEN
        DX(IS1)=DX(IS2)
C       write(6,*)is1,is2,dx(is1)
      ELSE
        J=IS1
        K=IS2
        DO 44 L=1,IVLEN
        DX(J)=DX(K)
C       write(6,*)is1,k,dx(is1)
        J=J+1
        K=K+1
   44   CONTINUE
      END IF
      IF(INC2.EQ.1) THEN
        IS2=IS2+IVLEN
      ELSE
        IS2=IS2+INC2
      END IF
      IS1=IS1+INC1
   50 CONTINUE
      RETURN
      END
C
C  Summary of general calling conventions from TCREA2 to subroutines.
C
C     Example calling sequence.
C
C     SUBROUTINE REFRMT(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
C    .  DX,MTYPE,MTRAN,IERROR)
C     INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),
C    . MTYPE(*),MTRAN(*),IERROR
C     DOUBLE PRECISION DID(NID),DX(*)
C
      SUBROUTINE REFRMT(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MTYPE,MTRAN,IERROR)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),
     . MTYPE(*),MTRAN(*),IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER ILIST(3),ISIZE(3)
      INTEGER MATSIZ
      EXTERNAL MATSIZ
  100 FORMAT(' COPY/REFORMAT ERROR:',/ ,' MUST BE CALLED WITH EITHER OLD
     . VARIABLES OR CONSTANTS')
  101 FORMAT (' COPY/REFORMAT ERROR: MUST BE CALLED WITH EITHER MODIFIED
     .OR NEW VARIABLES')
  102 FORMAT(' COPY/REFORMAT ERROR: MISMATCH OF LIST LENGTHS')
  103 FORMAT(' COPY/REFORMAT ERROR: MISMATCH OF SIZES, OLD VARIABLE',3I7
     .)
C
C  Checks performed for full sample
C
      IF(DID(1).EQ.0.) THEN
C
C  Call must use either OLD variables or constants, but not both
C
        IF((IVLIST(1).EQ.0.AND.IVLIST(5).EQ.0).OR.
     .     (IVLIST(1).GT.0.AND.IVLIST(5).GT.0)) THEN
          WRITE(U6,100)
          GO TO 99
        END IF
C
C  Call must use either MODIFY or new variables, but not both
C
        IF((IVLIST(2).EQ.0.AND.IVLIST(3).EQ.0).OR.
     .     (IVLIST(2).GT.0.AND.IVLIST(3).GT.0)) THEN
          WRITE(U6,101)
          GO TO 99
        END IF
      END IF
C
C  IOLD - index for old variable
C  INEW - index for new variables
C
      IOLD=1
      INEW=IVLIST(1)+1
    5 CONTINUE
C
C  If called with OLD variable(s)
C
      IF(IVLIST(1).GT.0) THEN
C
C  Check for done
C
        IF(INEW.GT.IVLIST(1)+IVLIST(2)+IVLIST(3).OR.
     .     IOLD.GT.IVLIST(1)) THEN
C
C  OK if both list of MODIFY/new variables and OLD variables
C  exhausted at same time, else error
C
          IF(INEW.EQ.IVLIST(1)+IVLIST(2)+IVLIST(3)+1.AND.
     .      IOLD.EQ.IVLIST(1)+1) RETURN
          WRITE(U6,102)
          GO TO 99
        END IF
C
C  Special handling of MISSING and CROSSED REAL variables, set NOLD=2
C  if OLD variable of these types.
C
        IF((MTYPE(IOLD).EQ.2.OR.MTYPE(IOLD).EQ.8).AND.MTRAN(IOLD).EQ.0)
     .     THEN
          NOLD=2
        ELSE
          NOLD=1
        END IF
C
C  Begin analogous checks for CONSTANTS (in place of OLD)
C
      ELSE
C
C  Check for done
C
        IF(INEW.GT.IVLIST(2)+IVLIST(3).OR.IOLD.GT.IVLIST(5)) THEN
C
C  OK if both list of MODIFY/new variables and CONSTANTS
C  exhausted at same time (or #CONSTANTS=1), else error
C
 
          IF(INEW.EQ.IVLIST(2)+IVLIST(3)+1.AND.
     .      (IOLD.EQ.IVLIST(5)+1.OR.IVLIST(5).EQ.1)) THEN
            RETURN
          END IF
          WRITE(U6,102)
          GO TO 99
        END IF
C
C  Always set NOLD=1 for CONSTANTS
C
        NOLD=1
      END IF
C
C  Now check for special handling of MISSING/CROSSED REAL for new
C  variable
C
      IF((MTYPE(INEW).EQ.2.OR.MTYPE(INEW).EQ.8).AND.MTRAN(INEW).EQ.0)
     .   THEN
        NNEW=2
      ELSE
        NNEW=1
      END IF
C
C  If NOLD=2 or CONSTANTS, and NNEW=2, then don't use special rules for
C  handling MISSING/CROSSED REAL - instead, make a straight copy.
C
      IF((NOLD.EQ.2.OR.IVLIST(5).GT.0).AND.NNEW.EQ.2) THEN
        NOLD=1
        NNEW=1
      END IF
C
C  Assemble in ILIST a list of variables, in order to call MATSIZ, below
C
C  If OLD variable, always obtain its length
C
      IF(IVLIST(1).GT.0) THEN
        ILIST(1)=IOLD
        NILIST=1
C
C  If full sample, get additional lengths
C
        IF(DID(1).EQ.0.) THEN
C
C  If NOLD=2, get length of next OLD variable
C
          IF(NOLD.EQ.2) THEN
            ILIST(2)=IOLD+1
            NILIST=2
          END IF
C
C  Get length of new variable
C
          NILIST=NILIST+1
          ILIST(NILIST)=INEW
C
C  If NNEW=2, get length of next MODIFY/NEW variable
C
          IF(NNEW.EQ.2) THEN
            NILIST=NILIST+1
            ILIST(NILIST)=INEW+1
          END IF
        END IF
      ELSE
C
C  Build up comparable list of variables for CONSTANTS
C
C  Always get length of new variable
C
        ILIST(1)=INEW
        NILIST=1
      END IF
C
C  Loop to get variable lengths.
C
      DO 10 I=1,NILIST
      J=ILIST(I)
      ISIZE(I)=MATSIZ(DIMX(DIMPNT(J)),MTYPE(J),MTRAN(J))
   10 CONTINUE
C
C  Further checks for full sample with OLD variables
C
      IF(DID(1).EQ.0..AND.IVLIST(1).GT.0) THEN
C
C  When NNEW=1 and NOLD=1, matrices should be of same size
C
        IF(NNEW.EQ.1.AND.NOLD.EQ.1) THEN
          IF(ISIZE(1).NE.ISIZE(2)) THEN
            WRITE(U6,103)IOLD,ISIZE(1),ISIZE(2)
            GO TO 99
          END IF
C
C  When NNEW=1 and NOLD=2, second OLD matrix must be same size as
C  first, and matrix for MODIFY/new variable must be twice as large
C  as each OLD matrix
C
        ELSE IF(NOLD.EQ.2) THEN
          IF(ISIZE(1).NE.ISIZE(2).OR.2*ISIZE(1).NE.ISIZE(3)) THEN
            WRITE(U6,103)IOLD
            GO TO 99
          END IF
        ELSE
C
C  When NNEW=2 and NOLD=1, second MODIFY/new matrix must be same size
C  as first, and matrix of OLD variable must be twice as large as each
C  MODIFY/new matrix.
C
          IF(ISIZE(2).NE.ISIZE(3).OR.ISIZE(1).NE.2*ISIZE(3)) THEN
            WRITE(U6,103)IOLD
            GO TO 99
          END IF
        END IF
      END IF
C
C  Actual copy when NOLD=1, NNEW=1
C
      IF(NOLD.EQ.1.AND.NNEW.EQ.1) THEN
C
C  K -  location of OLD variable or CONSTANT
C  IK - location of new variable
C
        IF(IVLIST(1).GT.0) THEN
          K=DXPNT(IOLD)
        ELSE
          K=IVLIST(4)+IOLD-1
        END IF
        IK=DXPNT(INEW)
C
C  Special loop to copy single CONSTANT into each cell
C
        IF(IVLIST(5).EQ.1) THEN
          DO 12 I=1,ISIZE(1)
          DX(IK)=DX(K)
          IK=IK+1
   12     CONTINUE
C
C  Loop for remaining COPY
C
        ELSE
          DO 15 I=1,ISIZE(1)
          DX(IK)=DX(K)
          K=K+1
          IK=IK+1
   15     CONTINUE
        END IF
C
C  For CONSTANT, increment INEW, and also IOLD unless there is only
C  one contant
C
        IF(IVLIST(5).GT.0) THEN
          INEW=INEW+1
          IF(IVLIST(5).GT.1) THEN
            IOLD=IOLD+ISIZE(1)
          END IF
        END IF
C
C  For NNEW=1, NOLD=2
C  K - index for first OLD variable
C  IK - index for second OLD variable
C  J  - index for output
C
      ELSE IF(NOLD.EQ.2) THEN
        K=DXPNT(IOLD)
        IK=DXPNT(IOLD+1)
        J=DXPNT(INEW)
        DO 20 I=1,ISIZE(1)
        DX(J)=DX(K)
        DX(J+1)=DX(IK)
        K=K+1
        IK=IK+1
        J=J+2
   20   CONTINUE
C
C  For NNEW=2, NOLD=1
C  J -  index for OLD variable
C  K -  index for first MODIFY/new variable
C  IK - index for second MODIFY/new variable
C
      ELSE
        J=DXPNT(IOLD)
        K=DXPNT(INEW)
        IK=DXPNT(INEW+1)
        DO 25 I=1,ISIZE(1),2
        DX(K)=DX(J)
        DX(IK)=DX(J+1)
        K=K+1
        IK=IK+1
        J=J+2
   25   CONTINUE
      END IF
C
C  For all cases using OLD variables, increment OLD and new variables
C
      IF(IVLIST(1).GT.0) THEN
        IOLD=IOLD+NOLD
        INEW=INEW+NNEW
      END IF
      GO TO 5
C
   99 CONTINUE
      IERROR=1
      RETURN
      END
C
      SUBROUTINE ARITHM(IKEY,DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MTYPE,MTRAN,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),
     . MTYPE(*),MTRAN(*),IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER ILIST(3),ISIZE(3)
      INTEGER MATSIZ
      LOGICAL ICHECK
      EXTERNAL MATSIZ,ICHECK
      DOUBLE PRECISION MISSNG
      DATA MISSNG/-98765.432109D0/
  100 FORMAT(' INAPPROPRIATE MIXING OF MODIFY AND NEW')
  102 FORMAT(' MISMATCH OF LIST LENGTHS')
  103 FORMAT(' CONSTANTS NOT ALLOWED')
  104 FORMAT(' MODIFIED OR NEW VARIABLES REQUIRED')
  105 FORMAT(' MATCH ON SIZE REQUIRED',2I6)
  106 FORMAT (' SIZE OF FIRST OPERAND MUST BE AN INTEGER MULTIPLE OF THE
     . SECOND')
  107 FORMAT(' NONINTEGER IN COLLAPSE:',F10.4)
C
C  IKEY  =  -2  add
C        =  -3  subtract
C        =  -4  multiply
C        =  -5  divide
C        =  -6  power
C        =  -7  reciprocal
C        =  -8  log
C        =  -9  paired add
C        = -10    "    subtract
C        = -11    "    multiply
C        = -12    "    divide
C        = -13  rmultiply
C        = -21  collapse
C
C
C  IV23 is sum of new and MODIFY variables (only one will be >0)
C
      IV23=IVLIST(2)+IVLIST(3)
C
C  Checks on first call:
C
      IF(IFIRST.EQ.1) THEN
C
C  Check that MODIFY and new variables don't appear together, but that
C  one type does
C
        IF(IVLIST(2).GT.0.AND.IVLIST(3).GT.0)GO TO 90
        IF(IV23.EQ.0)GO TO 94
C
C  Checks for ADD, SUBTRACT, MULTIPLY, DIVIDE, POWER, RMULTIPLY,
C  COLLAPSE (which each involve 2 operators)
C
        IF((IKEY.GE.-6.AND.IKEY.LE.-2).OR.IKEY.EQ.-13.OR.IKEY.EQ.-21)
     .       THEN
C
C  If CONSTANTS are given, then if #OLD >0, #OLD must agree with IV23
C  (number of new/MODIFY variables)
C
          IF(IVLIST(4).GT.0) THEN
            IF(IVLIST(1).GT.0.AND.IVLIST(1).NE.IV23)GO TO 92
          ELSE
C
C  If no CONSTANTS, then:
C    1) if #OLD = 1, then #new must be 0
C    2) #OLD must be 1 or more
C    3) #OLD must = #new/MODIFY + 1
C
            IF((IVLIST(1).EQ.1.AND.IVLIST(3).GT.0).OR.IVLIST(1).EQ.0.OR.
     .         (IVLIST(1).GT.1.AND.IVLIST(1).NE.IV23+1)) GO TO 92
          END IF
C
C  Check for RECIPROCAL and LOG (usually single operator):
C  # old var must= # new/MODIFY or MODIFY only
C
        ELSE IF(IKEY.EQ.-8.OR.IKEY.EQ.-7) THEN
          IF(IVLIST(1).NE.IV23.AND.
     .      (IVLIST(1).NE.0.OR.IVLIST(2).EQ.0))GO TO 92
C
C  Check for PAIRED ADD, SUBTRACT, MULTIPLY, DIVIDE, that either
C     1) #OLD = 2 * #new
C     2) #OLD = #MODIFY
C
        ELSE IF(IKEY.GE.-12.AND.IKEY.LE.-9) THEN
          IF(IVLIST(1).NE.2*IVLIST(3).AND.
     .       IVLIST(1).NE.IVLIST(2))GO TO 92
        END IF
C
C  Check for PAIRED ADD, SUBTRACT, MULTIPLY, DIVIDE, and LOG that there
C  are no CONSTANTS
C
        IF(IKEY.GE.-12.AND.IKEY.LE.-8) THEN
          IF(IVLIST(4).GT.0)GO TO 93
        END IF
      END IF
C
C  End of dimension checks on first call
C
C  INEW - index for outcome variable
C  IOLD1 - index for first operator variable
C  IOLD2 - index for second operator variable
C
      INEW=IVLIST(1)+1
C
C  For ADD, SUBTRACT, MULTIPLY, DIVIDE, POWER, RMULTIPLY,
C  COLLAPSE (which each involve 2 operators):
C
      IF((IKEY.GE.-6.AND.IKEY.LE.-2).OR.IKEY.EQ.-13.OR.IKEY.EQ.-21)
     .     THEN
C
C  If CONSTANTS, set IOLD2=0
C
        IF(IVLIST(4).GT.0) THEN
          IOLD2=0
          IOLD1=1
        ELSE
C
C  If no CONSTANTS, IOLD2 is last OLD variable
C
          IOLD2=IVLIST(1)
          IF(IVLIST(1).GT.1) THEN
            IOLD1=1
          ELSE
            IOLD1=IVLIST(1)+1
          END IF
        END IF
C
C  For RECIPROCAL and LOG (usually single operator):
C
      ELSE IF(IKEY.EQ.-8.OR.IKEY.EQ.-7) THEN
        IOLD1=1
        IOLD2=0
C
C  For PAIRED ADD, SUBTRACT, MULTIPLY, DIVIDE:
C
      ELSE IF(IKEY.GE.-12.AND.IKEY.LE.-9) THEN
        IF(IVLIST(2).GT.0) THEN
          IOLD1=IVLIST(1)+1
          IOLD2=1
        ELSE
          IOLD1=1
          IOLD2=(IVLIST(1)/2)+1
        END IF
      END IF
    5 CONTINUE
C
C  Check for return
C
      IF(INEW.GT.IVLIST(1)+IV23) RETURN
C
C  Build a list in ILIST of variables whose size is required
C  JOLD1 - cell index for first operator
C  JOLD2 - cell index for second operator, if present
C  JNEW - cell index for output
C
      ILIST(1)=IOLD1
      JOLD1=DXPNT(IOLD1)
      JNEW=DXPNT(INEW)
C
C  For all combinations except LOG and reciprocal without CONSTANTS,
C  set values for second operator
C
      IF((IKEY.GE.-13.AND.IKEY.LE.-9).OR.IKEY.EQ.-21.OR.
     .   (IKEY.GE.-6.AND.IKEY.LE.-2).OR.
     .   (IKEY.EQ.-7.AND.IVLIST(4).GT.0)) THEN
        ILIST(2)=IOLD2
        NILIST=2
C
C  If CONSTANTS, set JOLD2 to location of constants
C
        IF(IOLD2.EQ.0) THEN
          JOLD2=IVLIST(4)
        ELSE
          JOLD2=DXPNT(IOLD2)
        END IF
C
C  Temporarily set INCR to 0, to be recomputed below
C
        INCR=0
      ELSE
C
C  For LOG or RECIPROCAL without CONSTANTS
C
        NILIST=1
        JOLD2=0
        INCR=1
      END IF
C
C  On first call, add new variable to ILIST
C
      IF(IFIRST.EQ.1) THEN
        NILIST=NILIST+1
        ILIST(NILIST)=INEW
      END IF
C
C  Loop to determine lengths
C
      DO 10 I=1,NILIST
      J=ILIST(I)
C
C  J=0 present for CONSTANTS, in which case set ISIZE to the number
C  of constants.
C
      IF(J.EQ.0) THEN
        ISIZE(I)=IVLIST(5)
      ELSE
        ISIZE(I)=MATSIZ(DIMX(DIMPNT(J)),MTYPE(J),MTRAN(J))
      END IF
   10 CONTINUE
C
C  ADD, SUBTRACT, MULTIPLY, DIVIDE, PAIRED versions, RMULTIPLY
C  POWER, and COLLAPSE
C
      IF((IKEY.GE.-13.AND.IKEY.LE.-9).OR.IKEY.EQ.-21.OR.
     .   (IKEY.GE.-6.AND.IKEY.LE.-2)) THEN
C
C  Adjust lengths of array for MISSING or CROSSED REAL
C
        IF(IOLD2.GT.0) THEN
          IF((MTYPE(IOLD2).EQ.2.OR.MTYPE(IOLD2).EQ.8).AND.
     .        MTRAN(IOLD2).EQ.0) THEN
            ISIZE(2)=ISIZE(2)/2
            INCR2=2
          ELSE
            INCR2=1
          END IF
        ELSE
          INCR2=1
        END IF
      END IF
C
C  Checks on first call
C
      IF(IFIRST.EQ.1) THEN
C
C  Check that size of first operator matches size of target, unless
C  REAL with MISSING or CROSSED REAL are involved.
C
        IF(ISIZE(NILIST).NE.ISIZE(1)) THEN
          IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND.
     .        MTRAN(IOLD1).EQ.0) THEN
            IF(ISIZE(1).EQ.2*ISIZE(NILIST)) THEN
              IF(MTYPE(INEW).EQ.2.OR.MTYPE(INEW).EQ.8)GO TO 95
            ELSE
              GO TO 95
            END IF
          ELSE
            GO TO 95
          END IF
        END IF
C
C  If there is a second operator, then check the value of INCR2
C  and size of the second operator, for COLLAPSE
C
        IF(NILIST.EQ.3) THEN
          IF(IKEY.EQ.-21) THEN
            IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND.
     .          MTRAN(IOLD1).EQ.0) THEN
              IF(INCR2*ISIZE(1).NE.2*ISIZE(2))GO TO 95
            ELSE
              IF(INCR2*ISIZE(1).NE.ISIZE(2))GO TO 95
            END IF
          ELSE
            IF(ISIZE(1).NE.(ISIZE(1)/ISIZE(2))*ISIZE(2)) GO TO 96
          END IF
        END IF
      END IF
C
C  End of full sample checks
C
C  If INCR has not been previously determined, compute it here
C  Generally, INCR determines the number of cells of the first
C  operator to be operated on by the second
C
      IF(INCR.EQ.0)INCR=ISIZE(1)/ISIZE(2)
C
C  JINCR - increment for JOLD1
C  JINCR2 - increment for JNEW
C
      IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND.MTRAN(IOLD1).EQ.0)
     .    THEN
        JINCR=2
        IF(MTYPE(INEW).EQ.2.OR.MTYPE(INEW).EQ.8) THEN
          JINCR2=2
        ELSE
          JINCR2=1
        END IF
      ELSE
        JINCR=1
        JINCR2=1
      END IF
C
C  ADD, SUBTRACT, MULTIPLY, DIVIDE, PAIRED versions, POWER
C  and RMULTIPLY
C
      IF((IKEY.GE.-6.AND.IKEY.LE.-2).OR.
     .   (IKEY.GE.-13.AND.IKEY.LE.-9)) THEN
        DO 15 I=1,ISIZE(1),INCR
        DO 12 J=1,INCR,JINCR
C
C  Handling of missing values, with special rules for MULTIPLY,
C  PAIRED MULTIPLY, and RMULTIPLY
C
        IF(DABS(DX(JOLD1)-MISSNG).LT..1D-06.OR.
     .     DABS(DX(JOLD2)-MISSNG).LT..1D-06) THEN
          IF(IKEY.EQ.-4.OR.IKEY.EQ.-11.OR.IKEY.EQ.-13) THEN
            IF(DX(JOLD1).EQ.0..OR.DX(JOLD2).EQ.0.) THEN
              DX(JNEW)=0.
            ELSE
              DX(JNEW)=MISSNG
            END IF
          ELSE
            DX(JNEW)=MISSNG
          END IF
C
C  ADD and PAIRED ADD
C
        ELSE IF(IKEY.EQ.-2.OR.IKEY.EQ.-9) THEN
          DX(JNEW)=DX(JOLD1)+DX(JOLD2)
C
C  MULTIPLY, PAIRED MULTIPLY, and RMULTIPLY
C
        ELSE IF(IKEY.EQ.-4.OR.IKEY.EQ.-11.OR.IKEY.EQ.-13) THEN
          DX(JNEW)=DX(JOLD1)*DX(JOLD2)
C
C  SUBTRACT, PAIRED SUBTRACT
C
        ELSE IF(IKEY.EQ.-3.OR.IKEY.EQ.-10) THEN
          DX(JNEW)=DX(JOLD1)-DX(JOLD2)
C
C  DIVIDE, PAIRED DIVIDE
C
        ELSE IF(IKEY.EQ.-5.OR.IKEY.EQ.-12) THEN
          IF(DX(JOLD2).NE.0.) THEN
            DX(JNEW)=DX(JOLD1)/DX(JOLD2)
          ELSE
            DX(JNEW)=MISSNG
          END IF
C
C  POWER
C
        ELSE IF(IKEY.EQ.-6) THEN
          IF(DX(JOLD1).GT.0.) THEN
            IF(DABS(DX(JOLD2)-.5D0).LT..1D-12) THEN
              DX(JNEW)=DSQRT(DX(JOLD1))
            ELSE IF(DABS(DX(JOLD2)-2.D0).LT.1.D-12) THEN
              DX(JNEW)=DX(JOLD1)*DX(JOLD1)
            ELSE
              DX(JNEW)=DX(JOLD1)**DX(JOLD2)
            END IF
          ELSE IF(DX(JOLD1).EQ.0.) THEN
            IF(DX(JOLD2).GT.0.) THEN
              DX(JNEW)=0.
            ELSE
              DX(JNEW)=MISSNG
            END IF
          ELSE
            DX(JNEW)=MISSNG
          END IF
        END IF
C
C  Handling of second cell if JINCR (increment for JOLD1) is 2
C
        IF(JINCR.EQ.2) THEN
          IF(JINCR2.EQ.2) THEN
C
C  RMULTIPLY
C
            IF(IKEY.EQ.-13) THEN
              IF(DABS(DX(JOLD1+1)-MISSNG).LT..1D-06.OR.
     .           DABS(DX(JOLD2)-MISSNG).LT..1D-06) THEN
                IF(DX(JOLD1+1).EQ.0..OR.DX(JOLD2).EQ.0.) THEN
                  DX(JNEW+1)=0.
                ELSE
                  DX(JNEW+1)=MISSNG
                END IF
              ELSE
                DX(JNEW+1)=DX(JOLD1+1)*DX(JOLD2)
              END IF
            ELSE
              DX(JNEW+1)=DX(JOLD1+1)
            END IF
          END IF
C
C  Increment of JNEW and JOLD1
C
          JNEW=JNEW+JINCR2
          JOLD1=JOLD1+2
        ELSE
          JNEW=JNEW+1
          JOLD1=JOLD1+1
        END IF
   12   CONTINUE
        JOLD2=JOLD2+INCR2
   15   CONTINUE
C
C  LOG and RECIPROCAL without CONSTANTS
C
      ELSE IF(IKEY.EQ.-8.OR.(IKEY.EQ.-7.AND.IVLIST(4).EQ.0)) THEN
        DO 20 I=1,ISIZE(1),JINCR
        IF(DABS(DX(JOLD1)-MISSNG).LT..1D-06) THEN
          DX(JNEW)=MISSNG
        ELSE IF(IKEY.EQ.-7) THEN
          IF(DX(JOLD1).NE.0.) THEN
            DX(JNEW)=1.D0/DX(JOLD1)
          ELSE
            DX(JNEW)=MISSNG
          END IF
        ELSE
          IF(DX(JOLD1).GT.0.) THEN
            DX(JNEW)=DLOG(DX(JOLD1))
          ELSE
            DX(JNEW)=MISSNG
          END IF
        END IF
        IF(JINCR2.EQ.2) THEN
          DX(JNEW+1)=DX(JOLD1+1)
        END IF
        JNEW=JNEW+JINCR2
        JOLD1=JOLD1+JINCR
   20   CONTINUE
C
C  RECIPROCAL with CONSTANTS
C
      ELSE IF(IKEY.EQ.-7) THEN
        DO 25 I=1,ISIZE(1),INCR
        DO 22 J=1,INCR,JINCR
        IF(DX(JOLD1).NE.0.AND.DABS(DX(JOLD2)-MISSNG).GT..1D-06) THEN
          DX(JNEW)=DX(JOLD2)/DX(JOLD1)
        ELSE
          DX(JNEW)=MISSNG
        END IF
        IF(JINCR2.EQ.2) THEN
          DX(JNEW+1)=DX(JOLD1+1)
        END IF
        JNEW=JNEW+JINCR2
        JOLD1=JOLD1+JINCR
   22   CONTINUE
        JOLD2=JOLD2+1
   25   CONTINUE
C
C  COLLAPSE
C
      ELSE IF(IKEY.EQ.-21) THEN
C
C  First, save current indices
C
        JOLD1S=JOLD1
        JOLD2S=JOLD2
        JNEWS=JNEW
        J2TOP=JOLD2+INCR2*ISIZE(2)-1
        DO 40 I=1,ISIZE(1),INCR
        DO 38 J=1,INCR,JINCR
        IF(.NOT.ICHECK(DX(JOLD2),X1))GO TO 97
C
C  First check if cell does not need collapsing, including instances
C  where second variable is negative, and copy
C
        IF(DABS(DX(JOLD2)-MISSNG).LT..1D-06.OR.
     .      DX(JOLD2).LT..1D-06) THEN
          DX(JNEW)=DX(JOLD1)
          IF(JINCR.EQ.2.AND.JINCR2.EQ.2) THEN
            DX(JNEW+1)=DX(JOLD1+1)
          END IF
        ELSE
C
C  Next, check if previously collapsed
C
          IF(JOLD2S.LT.JOLD2) THEN
            DO 27 K=JOLD2S,JOLD2-1,INCR2
            IF(DABS(DX(JOLD2)-DX(K)).LT..1D-06)GO TO 35
   27       CONTINUE
          END IF
C
C  Accumulate sum(s) of matching cells, including sign flips
C  e.g., -1 with 1 etc.
C
          XV1=DX(JOLD1)
          IF(JINCR.EQ.2)XV2=DX(JOLD1+1)
          DO 29 K=JOLD2S,J2TOP,INCR2
          IF(K.EQ.JOLD2)GO TO 29
          IF(DABS(DX(JOLD2)-DX(K)).LT..1D-06.OR.
     .       DABS(DX(JOLD2)+DX(K)).LT..1D-06) THEN
            L=((K-JOLD2S)/INCR2)*JINCR+JOLD1S
            IF(DABS(DX(L)-MISSNG).LT..1D-06) THEN
              XV1=MISSNG
              XV2=0
            ELSE IF(DABS(XV1-MISSNG).GT..1D-06) THEN
              XV1=XV1+DX(L)
              IF(JINCR.EQ.2)XV2=XV2+DX(L+1)
            END IF
          END IF
   29     CONTINUE
C
C  Store sum in matching cells, positive signs only
C
          DO 31 K=JOLD2S,J2TOP,INCR2
          IF(DABS(DX(JOLD2)-DX(K)).LT..1D-06) THEN
            L=((K-JOLD2S)/INCR2)*JINCR2+JNEWS
            DX(L)=XV1
            IF(JINCR.EQ.2.AND.JINCR2.EQ.2)DX(L+1)=XV2
          END IF
   31     CONTINUE
   35     CONTINUE
        END IF
        JNEW=JNEW+JINCR2
        JOLD1=JOLD1+JINCR
   38   CONTINUE
        JOLD2=JOLD2+INCR2
   40   CONTINUE
      END IF
C
C  Increment IOLD1, INEW, and,
C  for PAIRED ADD, SUBTRACT, MULTIPY, and DIVIDE - IOLD2
C
      IOLD1=IOLD1+1
      INEW=INEW+1
      IF(IKEY.GE.-12.AND.IKEY.LE.-9)IOLD2=IOLD2+1
      GO TO 5
   90 CONTINUE
      WRITE(U6,100)
      GO TO 99
   92 CONTINUE
      WRITE(U6,102)
      GO TO 99
   93 CONTINUE
      WRITE(U6,103)
      GO TO 99
   94 CONTINUE
      WRITE(U6,104)
      GO TO 99
   95 CONTINUE
      WRITE(U6,105)ISIZE(1),ISIZE(NILIST)
      GO TO 99
   96 CONTINUE
      WRITE(U6,106)
      GO TO 99
   97 CONTINUE
      WRITE(U6,107)
   99 CONTINUE
      IERROR=1
      RETURN
      END
C
      SUBROUTINE RAOSH(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,DX,
     .  MTYPE,MTRAN,IX,ITRANS,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),
     . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
      INTEGER MATSIZ
      EXTERNAL MATSIZ
      DOUBLE PRECISION MISSNG
      LOGICAL ENDFLE
      DATA MISSNG/-98765.432109D0/
  200 FORMAT(' RAO_SHAO: MUST CALL WITH MODIFY AND OLD VARIABLES')
  201 FORMAT(' RAO_SHAO: MISMATCHING MATRICES')
  202 FORMAT(' RAO_SHAO: FINAL DIMENSION MUST BE 2')
  203 FORMAT(' RAO_SHAO: WRONG OLD VARIABLE TYPE')
C
C  Establish NCELL, the number of imputation cells.
C
      IF(IVLIST(7).GE.1) THEN
        NCELL=IX(1)
      ELSE
        NCELL=1
      END IF
      IF(IFIRST.EQ.1) THEN
C
C  Check for OLD and MODIFY variables only.
C
        IF(IVLIST(3).GT.0.OR.IVLIST(1).EQ.0.OR.IVLIST(2).EQ.0) THEN
          WRITE(U6,200)
          GO TO 99
        END IF
        IF(IVLIST(1).NE.1.AND.IVLIST(1).NE.IVLIST(2)) THEN
          GO TO 98
        END IF
C
C  Check that each final dimension is 2
C
        DO 2 I=1,IVLIST(1)+IVLIST(2)
        J=DIMPNT(I)+DIMX(DIMPNT(I))
        IF(DIMX(J).NE.2) THEN
          WRITE(U6,202)
          GO TO 99
        END IF
    2   CONTINUE
C
C  Now check that the sizes of matrices appear appropriate.
C  Determine the total storage that will be needed.
C
        IOLD=1
        INEW=IVLIST(1)+1
        N=0
        DO 4 I=1,IVLIST(2)
        NOLD=MATSIZ(DIMX(DIMPNT(IOLD)),MTYPE(IOLD),MTRAN(IOLD))
        NNEW=MATSIZ(DIMX(DIMPNT(INEW)),MTYPE(INEW),MTRAN(INEW))
        IF((MTYPE(IOLD).EQ.2.OR.MTYPE(IOLD).EQ.8).AND.
     .      MTRAN(IOLD).EQ.0) THEN
          WRITE(U6,203)
          GO TO 99
        END IF
        IF((MTYPE(INEW).EQ.2.OR.MTYPE(INEW).EQ.8).AND.
     .      MTRAN(INEW).EQ.0.AND.NOLD*2.EQ.NNEW) THEN
          NNEW=NNEW/2
        END IF
        IF(NCELL*2*(NOLD/(NCELL*2)).NE.NOLD)GO TO 98
        IF(NCELL*2*(NNEW/(NCELL*2)).NE.NNEW)GO TO 98
        IF(NOLD*(NNEW/NOLD).NE.NNEW)GO TO 98
        N=N+NCELL*(NNEW/NOLD)
        INEW=INEW+1
        IF(IVLIST(1).GT.1)IOLD=IOLD+1
    4   CONTINUE
C
C  If constants have been specified, check available space and
C  reallocate, if necessary.
C
        IF(IVLIST(5).GT.0) THEN
          IF(IVLIST(5).LT.N) THEN
            IVLIST(4)=NXPTD
            IVLIST(5)=N
            CALL ROOMD(N)
          END IF
        END IF
      END IF
      IF(IVLIST(5).EQ.0) THEN
C
C  If IVLIST(5)=0, then allocate temporary storage, and, if not full
C  sample, obtain the stored means from the scratch file.
C
        IVLIST(4)=NXPTD
        NXPTDS=NXPTD
        IF(DID(1).NE.0.) THEN
          CALL SCPOSN(ITRANS,N)
          CALL ROOMD(N)
          CALL UNFIN(13,DX(IVLIST(4)),N,ENDFLE)
        END IF
      END IF
C
      IOLD=1
      INEW=IVLIST(1)+1
C
C  N is recomputed here, in case DID(1)=0 but IFIRST is not 1.
C
      N=0
      J=IVLIST(4)
C
      DO 40 IV=1,IVLIST(2)
      NOLD=MATSIZ(DIMX(DIMPNT(IOLD)),MTYPE(IOLD),MTRAN(IOLD))
      NNEW=MATSIZ(DIMX(DIMPNT(INEW)),MTYPE(INEW),MTRAN(INEW))
      IF((MTYPE(INEW).EQ.2.OR.MTYPE(INEW).EQ.8).AND.
     .    MTRAN(INEW).EQ.0.AND.NOLD*2.EQ.NNEW) THEN
        INCR=2
      ELSE
        INCR=1
      END IF
C
C  For full sample, allocate the space if not already allocated.
C  NVAL is the number of values that need to be computed and
C  stored.
C
 
      NVAL=NCELL*(NNEW/(NOLD*INCR))
      N=N+NVAL
      IF(DID(1).EQ.0.) THEN
        IF(IVLIST(5).EQ.0) THEN
          CALL ROOMD(NVAL)
        END IF
      END IF
C
C  NNEWC represents the length of the vector of values to be
C  stored for each imputation cell.  NC is the number of cells
C  of the modified variable that are imputed from the same
C  imputation cell.
C
      NNEWC=NVAL/NCELL
      NC=NOLD/(NCELL*2)
      JOLD=DXPNT(IOLD)
      DO 37 ICELL=1,NCELL
      JNEW=DXPNT(INEW)+(ICELL-1)*NNEW/(2*NCELL)
      DO 35 NEWC=1,NNEWC
      JOLDT=JOLD
      JNEWT=JNEW
      TV=0.D0
      TN=0.D0
      DO 8 I=1,NC
      IF(DABS(TV-MISSNG).GT..1D-6) THEN
        IF(DABS(DX(JNEWT)-MISSNG).GT..1D-6) THEN
          TV=TV+DX(JNEWT)
        ELSE
          TV=MISSNG
        END IF
      END IF
      IF(DABS(TN-MISSNG).GT..1D-6) THEN
        IF(DABS(DX(JOLDT)-MISSNG).GT..1D-6) THEN
          TN=TN+DX(JOLDT)
        ELSE
          TN=MISSNG
        END IF
      END IF
      JNEWT=JNEWT+INCR*NNEWC
      JOLDT=JOLDT+1
    8 CONTINUE
C
C  Compute the mean within the imputation cell.
C
      IF(DABS(TV-MISSNG).GT..1D-6) THEN
        IF(DABS(TN-MISSNG).GT..1D-6) THEN
          IF(TN.EQ.0.) THEN
            TV=MISSNG
          ELSE
            TV=TV/TN
          END IF
        ELSE
          TV=MISSNG
        END IF
      END IF
C
C  For the full sample, simply store the mean.
C
      IF(DID(1).EQ.0.) THEN
        DX(J)=TV
      ELSE
C
C  For other replicates, subtract the full sample mean for the
C  imputation cell from the mean for this replicate, then
C  adjust each of the corresponding cells.
C
        IF(DABS(TV-MISSNG).GT..1D-6) THEN
          IF(DABS(DX(J)-MISSNG).GT..1D-6) THEN
            TV=TV-DX(J)
          ELSE
            TV=MISSNG
          END IF
        END IF
        JOLDT=JOLD+NOLD/2
        JNEWT=JNEW+NNEW/2
        DO 18 I=1,NC
        IF(DX(JOLDT).NE.0.) THEN
          IF(DABS(DX(JNEWT)-MISSNG).GT..1D-6) THEN
            IF(DABS(TV-MISSNG).GT..1D-6) THEN
              DX(JNEWT)=DX(JNEWT)+DX(JOLDT)*TV
            ELSE
              DX(JNEWT)=MISSNG
            END IF
          END IF
        END IF
        JNEWT=JNEWT+INCR*NNEWC
        JOLDT=JOLDT+1
   18   CONTINUE
      END IF
      J=J+1
      JNEW=JNEW+INCR
   35 CONTINUE
      JOLD=JOLD+NC
   37 CONTINUE
      INEW=INEW+1
      IF(IVLIST(1).GT.1)IOLD=IOLD+1
   40 CONTINUE
      IF(DID(1).EQ.0.) THEN
        IF(IVLIST(5).EQ.0) THEN
          WRITE(13)ITRANS,N
          CALL UNFOUT(13,DX(IVLIST(4)),N)
        END IF
      END IF
C
C  If IVLIST(5)=0, have been reusing temporary storage.  Setting
C  NXPTD=NXPTDS frees up temporary space.
C
      IF(IVLIST(5).EQ.0) THEN
        NXPTD=NXPTDS
      END IF
      RETURN
   98 CONTINUE
      WRITE(U6,201)
   99 CONTINUE
      IERROR=1
      RETURN
      END
C
      SUBROUTINE SAVEFL(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MTYPE,MTRAN,IKEY,ITRANS,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),
     . MTYPE(*),MTRAN(*),IKEY,ITRANS,IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
      INTEGER MATSIZ
      EXTERNAL MATSIZ
      DOUBLE PRECISION MISSNG
      LOGICAL ENDFLE
      DATA MISSNG/-98765.432109D0/
  100 FORMAT(' SAVEFULL/MODIFYREPF ERROR: MUST CALL WITH MODIFY '
     .,'VARIABLES')
  102 FORMAT(' MODIFYREPF REQUIRES REAL OR DERIVED')
C
C  Check for MODIFY variables only.
C
      IF(IFIRST.EQ.1) THEN
        IF(IVLIST(1)+IVLIST(3).GT.0.OR.IVLIST(2).EQ.0) THEN
          WRITE(U6,100)
          GO TO 99
        END IF
      END IF
C
C  Obtain the total length, N, of the matrices.
C
      IF(IFIRST.EQ.1.OR.IVLIST(5).EQ.0) THEN
        N=0
        DO 5 I=1,IVLIST(2)
        N=N+MATSIZ(DIMX(DIMPNT(I)),MTYPE(I),MTRAN(I))
    5   CONTINUE
      END IF
C
C  If there has been an attempt to allocate some storage for them,
C  revise the storage for constants, if necessary.
C
      IF(IFIRST.EQ.1) THEN
        IF(IVLIST(5).GT.0) THEN
          IF(N.GT.IVLIST(5)) THEN
            IVLIST(5)=N
            IVLIST(4)=NXPTD
            CALL ROOMD(N)
          END IF
        END IF
C
C  Check the variable types for MODIFYREP
C
        IF(IKEY.EQ.-22) THEN
          DO 7 I=1,IVLIST(2)
          IF(MTYPE(I).NE.1.AND.MTYPE(I).NE.11) THEN
            WRITE(U6,102)
            GO TO 99
          END IF
    7     CONTINUE
        END IF
      END IF
      IF(IVLIST(5).EQ.0) THEN
        NXPTDS=NXPTD
        CALL ROOMD(N)
        IVLIST(4)=NXPTDS
        IF(DID(1).GT.0.) THEN
          CALL SCPOSN(ITRANS,NCELL)
          CALL UNFIN(13,DX(IVLIST(4)),NCELL,ENDFLE)
        END IF
      END IF
      J=IVLIST(4)
C
C  N is recomputed here, in case DID(1)=0 but IFIRST is not 1.
C
      N=0
      DO 20 I=1,IVLIST(2)
      K=MATSIZ(DIMX(DIMPNT(I)),MTYPE(I),MTRAN(I))
      JJ=DXPNT(I)
      IF(DID(1).EQ.0) THEN
C
C  Storage of full-sample values
C
        N=N+K
        DO 12 L=1,K
        DX(J)=DX(JJ)
        J=J+1
        JJ=JJ+1
   12   CONTINUE
      ELSE IF(IKEY.EQ.-14) THEN
C
C  Restoration of full-sample values for SAVEFULL
C
        DO 14 L=1,K
        DX(JJ)=DX(J)
        JJ=JJ+1
        J=J+1
   14   CONTINUE
      ELSE
C
C  Adjustment for MODIFYREPF
C
        DO 16 L=1,K
        IF(DABS(DX(J)-MISSNG).LT..1D-6.OR.DABS(DX(JJ)-MISSNG).LT.
     .     .1D-6.OR.DX(J).EQ.0.) THEN
          DX(JJ)=MISSNG
        ELSE
          DX(JJ)=DX(JJ)/DX(J)
        END IF
        JJ=JJ+1
        J=J+1
   16   CONTINUE
      END IF
   20 CONTINUE
      IF(DID(1).EQ.0.) THEN
        IF(IVLIST(5).EQ.0) THEN
          WRITE(13)ITRANS,N
          CALL UNFOUT(13,DX(IVLIST(4)),N)
        END IF
      END IF
C
C  If IVLIST(5)=0, have been reusing temporary storage.  Setting
C  NXPTD=NXPTDS frees up temporary space.
C
      IF(IVLIST(5).EQ.0) THEN
        NXPTD=NXPTDS
      END IF
      RETURN
   99 CONTINUE
      IERROR=1
      RETURN
      END
      SUBROUTINE GLUE(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MTYPE,MTRAN,IX,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),
     . MTYPE(*),MTRAN(*),IX(*)
      DOUBLE PRECISION DID(NID),DX(*)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER MATSIZ
      EXTERNAL MATSIZ
  100 FORMAT(' GLUE ERROR: CALL WITH OLD VARS AND ONE NEW OR MODIFY VAR'
     .)
  101 FORMAT(' GLUE ERROR: WRONG NUMBER OF CONSTANTS')
  102 FORMAT(' GLUE ERROR: MISSING, CROSSED REAL MUST NOT BE MIXED WITH'
     .,' OTHER TYPES')
  103 FORMAT(' GLUE ERROR: CONSTANTS NOT PROPORTIONAL')
  104 FORMAT(' GLUE ERROR: SIZE MISMATCH')
      IF((MTYPE(1).EQ.2.OR.MTYPE(1).EQ.8).AND.MTRAN(1).EQ.0) THEN
        IMULT=2
      ELSE
        IMULT=1
      END IF
      NSLICE=0
      IF(IVLIST(7).EQ.1) THEN
        IF(IX(1).LT.0)NSLICE=-IX(1)
      END IF
      IF(IFIRST.EQ.1) THEN
        IF(IVLIST(1).LE.1.OR.IVLIST(2)+IVLIST(3).NE.1) THEN
          WRITE(U6,100)
          GO TO 98
        END IF
        IF(NSLICE.EQ.0.AND.IVLIST(7).GT.0.AND.IVLIST(1).NE.IVLIST(7))
     .      THEN
          WRITE(U6,101)
          GO TO 98
        END IF
        K=0
        DO 2 I=1,IVLIST(1)
        K=K+MATSIZ(DIMX(DIMPNT(I)),MTYPE(I),MTRAN(I))
        IF(IMULT.EQ.2) THEN
          IF((MTYPE(I).EQ.2.OR.MTYPE(I).EQ.8).AND.MTRAN(I).EQ.0)GO TO 2
        ELSE
          IF((MTYPE(I).NE.2.AND.MTYPE(I).NE.8).OR.MTRAN(I).NE.0)GO TO 2
        END IF
        WRITE(U6,102)
        GO TO 98
    2   CONTINUE
        I=IVLIST(1)+1
        IF(K.NE.MATSIZ(DIMX(DIMPNT(I)),MTYPE(I),MTRAN(I))) THEN
          WRITE(U6,104)
          GO TO 98
        END IF
        IF(IVLIST(7).GT.0) THEN
          KK=MATSIZ(DIMX(DIMPNT(1)),MTYPE(1),MTRAN(1))
          IF(NSLICE.GT.0) THEN
            IF((KK/(IMULT*NSLICE))*NSLICE*IMULT.NE.KK)GO TO 93
            IK=NSLICE
          ELSE
            IC=IMULT*IX(1)
            IF(IC.LE.0) GO TO 93
            IK=KK/IC
            IF(IK*IC.NE.KK) GO TO 93
          END IF
          DO 4 I=2,IVLIST(1)
          KK=MATSIZ(DIMX(DIMPNT(I)),MTYPE(I),MTRAN(I))
          IF(NSLICE.GT.0) THEN
            IF((KK/(IMULT*NSLICE))*NSLICE*IMULT.NE.KK)GO TO 93
          ELSE
            IC=IMULT*IX(I)
            IF(IK*IC.NE.KK)GO TO 93
          END IF
    4     CONTINUE
        END IF
      END IF
      I=IVLIST(1)+1
      J=DXPNT(I)
      IF(IVLIST(7).GT.0) THEN
        IF(NSLICE.GT.0) THEN
          IK=NSLICE
        ELSE
          KK=MATSIZ(DIMX(DIMPNT(1)),MTYPE(1),MTRAN(1))
          IC=IMULT*IX(1)
          IK=KK/IC
        END IF
        DO 10 II=1,IK
        DO 8 I=1,IVLIST(1)
        IF(NSLICE.GT.0) THEN
          IC=MATSIZ(DIMX(DIMPNT(I)),MTYPE(I),MTRAN(I))/NSLICE
        ELSE
          IC=IMULT*IX(I)
        END IF
        JJ=IC*(II-1)+DXPNT(I)
        DO 6 L=1,IC
        DX(J)=DX(JJ)
        J=J+1
        JJ=JJ+1
    6   CONTINUE
    8   CONTINUE
   10   CONTINUE
      ELSE
        DO 20 I=1,IVLIST(1)
        K=MATSIZ(DIMX(DIMPNT(I)),MTYPE(I),MTRAN(I))
        JJ=DXPNT(I)
        DO 15 L=1,K
        DX(J)=DX(JJ)
        J=J+1
        JJ=JJ+1
   15   CONTINUE
   20   CONTINUE
      END IF
      RETURN
   93 CONTINUE
      WRITE(U6,103)
   98 CONTINUE
      IERROR=1
      RETURN
      END
      SUBROUTINE RPRINT(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,INFRMT,IX,MV,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MVAR=10000)
      PARAMETER (MLEVEL=10000)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),MV(*),IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 INFRMT(*)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER MATSIZ
      EXTERNAL MATSIZ
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
C
      CHARACTER*11 VTYPE(7)
      CHARACTER*26 CTEMP
      DOUBLE PRECISION MISSNG,T
      DATA MISSNG/-98765.432109D0/
      DATA VTYPE /   'MEAN       ','TOTAL      ','PERCENTS   ',
     . 'VALUE      ','PROPORTION ','WEIGHTED N ','2-WAY PCNT '/
  100 FORMAT(' RPRINT ERROR: MUST BE CALLED WITH OLD VARIABLES')
  101 FORMAT(/,' RPRINT: REPLICATE',I5)
  102 FORMAT(12X,A12,':  ',A11,2X)
  103 FORMAT('Sample N (wtd) for block',I4,12X)
  104 FORMAT(I1)
  105 FORMAT(I2)
  106 FORMAT(1X,A80)
  107 FORMAT(1X,A40)
      IF(IVLIST(7).GT.0) THEN
        IF(IX(1).GE.0) THEN
          IF(DID(1).GT.IX(1)) RETURN
        END IF
      END IF
      IF(IFIRST.EQ.1) THEN
        IF(IVLIST(1).EQ.0.OR.IVLIST(2)+IVLIST(3).GT.0) THEN
          WRITE(U6,100)
          IERROR=1
          RETURN
        END IF
      END IF
      I=DID(1)+.5D-1
      WRITE(U6,101)I
      IF(IVLIST(7).GT.1) THEN
        IF(IX(2).GT.0) THEN
          LDEFLT=IX(2)
          IF(LDEFLT.GT.26) THEN
            LDEFLT=26
          ELSE IF(LDEFLT.LT.4) THEN
            LDEFLT=4
          END IF
        ELSE
          LDEFLT=8
        END IF
      ELSE
        LDEFLT=8
      END IF
      DO 50 I=1,IVLIST(1)
      N=MATSIZ(DIMX(DIMPNT(I)),MTYPE(I),MTRAN(I))
      IP=1
      T=1.D01
      J=DXPNT(I)
      DO 4 K=1,N
   2  CONTINUE
      IF(DABS(DX(J)-MISSNG).GT..1D-6) THEN
        IF(DABS(DX(J)).GE.T) THEN
          IF(IP.LT.23) THEN
            IP=IP+1
            T=T*1.D01
            GO TO 2
          END IF
        END IF
      END IF
      J=J+1
    4 CONTINUE
      IF(IP+3.GT.LDEFLT) THEN
        LEN=IP+3
      ELSE
        LEN=LDEFLT
      END IF
      IF(IVLIST(7).GT.0) THEN
        IF(IX(3).GE.0) THEN
          IF(IP+IX(3)+3.GT.LEN) THEN
            LEN=IP+IX(3)+3
            IF(LEN.GT.26)LEN=26
          END IF
        END IF
      END IF
      ITTYPE=MTRAN(I)
      IF(ITTYPE.NE.9) THEN
        MT=MTYPE(I)
        IF(ITTYPE.EQ.8) THEN
          IFLAG=6
        ELSE IF(MT.EQ.11.OR.MT.EQ.13.OR.MT.EQ.19) THEN
          IFLAG=4
        ELSE IF(ITTYPE.EQ.0.OR.ITTYPE.EQ.2.OR.ITTYPE.EQ.4) THEN
          IFLAG=2
        ELSE IF(ITTYPE.EQ.5) THEN
          IFLAG=7
        ELSE IF(ITTYPE.EQ.1.OR.ITTYPE.EQ.3) THEN
          IF(MT.EQ.3.OR.MT.EQ.9) THEN
            IFLAG=3
          ELSE
            IFLAG=1
          END IF
        ELSE IF(ITTYPE.EQ.6.OR.ITTYPE.EQ.7) THEN
          IFLAG=5
        ELSE IF(ITTYPE.EQ.10) THEN
          IFLAG=4
        END IF
        WRITE(INFRMT(1)(1:40),102)VNAME(MV(I)),VTYPE(IFLAG)
      ELSE
        WRITE(INFRMT(1)(1:40),103)MV(I)
      END IF
      INFRMT(1)(81:82)='(F'
      IPOS=83
      IF(LEN.GE.10) THEN
        WRITE(INFRMT(1)(83:84),105)LEN
        IPOS=85
      ELSE
        WRITE(INFRMT(1)(83:83),104)LEN
        IPOS=84
      END IF
      INFRMT(1)(IPOS:IPOS)='.'
      IPOS=IPOS+1
      K=LEN-IP-3
      IF(IVLIST(7).GT.0) THEN
        IF(IX(3).GE.0) THEN
          K=IX(3)
        END IF
      END IF
      IF(K.LE.9) THEN
        WRITE(INFRMT(1)(IPOS:IPOS),104)K
        IPOS=IPOS+1
      ELSE
        WRITE(INFRMT(1)(IPOS:IPOS+1),105)K
        IPOS=IPOS+2
      END IF
      INFRMT(1)(IPOS:IPOS)=')'
      IFEND=IPOS
      IF(N*LEN.LE.40) THEN
        IPOS=41
        DO 6 K=0,N-1
        IF(DABS(DX(DXPNT(I)+K)-MISSNG).LE..1D-06) THEN
          DO 5 IC=1,LEN-3
          INFRMT(1)(IPOS:IPOS)=' '
          IPOS=IPOS+1
    5     CONTINUE
          INFRMT(1)(IPOS:IPOS+2)='(M)'
          IPOS=IPOS+3
        ELSE
          WRITE(CTEMP,FMT=INFRMT(1)(81:IFEND))DX(DXPNT(I)+K)
          INFRMT(1)(IPOS:IPOS+LEN-1)=CTEMP(1:LEN)
C         WRITE(INFRMT(1)(IPOS:IPOS+LEN-1),FMT=INFRMT(1)(81:IFEND))
C     .           DX(DXPNT(I)+K)
          IPOS=IPOS+LEN
        END IF
    6   CONTINUE
        IF(IPOS.LT.81) THEN
          K=IPOS
          DO 7 IPOS=K,80
          INFRMT(1)(IPOS:IPOS)=' '
    7     CONTINUE
        END IF
        WRITE(U6,106)INFRMT(1)(1:80)
      ELSE
        WRITE(U6,107)INFRMT(1)(1:40)
        NC=N/MSIZE(I)
        J=DXPNT(I)
        IF(MSIZE(I)*LEN.GE.81) THEN
          NC2=1
          NLINE2=80/LEN
        ELSE
          NC2=80/(MSIZE(I)*LEN)
          NLINE2=MSIZE(I)*NC2
        END IF
        DO 25 IL=1,NC,NC2
        IF(IL+NC2.GT.NC) THEN
          NC3=NC-IL+1
        ELSE
          NC3=NC2
        END IF
        NLINE=MSIZE(I)*NC3
        DO 20 IC2=1,NLINE,NLINE2
        IPOS=1
        IF(IC2+NLINE2.GT.NLINE) THEN
          NLINE3=NLINE-IC2+1
        ELSE
          NLINE3=NLINE2
        END IF
        DO 14 M=1,NLINE3
        IF(DABS(DX(J)-MISSNG).LE..1D-06) THEN
          DO 12 IC=1,LEN-3
          INFRMT(1)(IPOS:IPOS)=' '
          IPOS=IPOS+1
   12     CONTINUE
          INFRMT(1)(IPOS:IPOS+2)='(M)'
          IPOS=IPOS+3
        ELSE
          WRITE(CTEMP,FMT=INFRMT(1)(81:IFEND))DX(J)
          INFRMT(1)(IPOS:IPOS+LEN-1)=CTEMP(1:LEN)
C         WRITE(INFRMT(1)(IPOS:IPOS+LEN-1),FMT=INFRMT(1)(81:IFEND))
C    .      DX(J)
          IPOS=IPOS+LEN
        END IF
        J=J+1
   14   CONTINUE
        IF(IPOS.LT.81) THEN
          K=IPOS
          DO 16 IPOS=K,80
          INFRMT(1)(IPOS:IPOS)=' '
   16     CONTINUE
        END IF
        WRITE(U6,106)INFRMT(1)(1:80)
   20   CONTINUE
   25   CONTINUE
      END IF
   50 CONTINUE
      RETURN
      END
C
      SUBROUTINE RWRITE(IKEY,DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MTYPE,MTRAN,INFRMT,IX,ITRANS,IERROR)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),
     . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR
      CHARACTER *128 INFRMT(*)
      DOUBLE PRECISION DID(NID),DX(*)
C     DOUBLE PRECISION DTEMP(3)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
      INTEGER MATSIZ
      EXTERNAL MATSIZ
      LOGICAL ENDFLE
C
  100 FORMAT(3D22.14)
  202 FORMAT(/,' PREMATURE END OF FILE',I3)
  203 FORMAT(/,' NSLICE IGNORED')
  204 FORMAT(/,' NSLICE/SLICELENGTH ERROR')
C
C  If a format is not specified, or if BINARYREAD or BINARYWRITE
C  then some options do not apply.  Distinguish by IPATH=1
C  vs. IPATH=2
C
      IF(IVLIST(6).EQ.0.OR.IKEY.EQ.-19.OR.IKEY.EQ.-20) THEN
        IF(IFIRST.EQ.1) THEN
          IF(IX(4).GT.0) THEN
            WRITE(U6,203)
            IERROR=2
            IX(4)=0
          END IF
        END IF
        IPATH=1
        NSLICE=0
C
C  Until version 95.08, binaryread and binarywrite used to output
C  an initial ID record.  In practice, this made the subroutines
C  less flexible.  The code is commented below
C
C       IF(IKEY.EQ.-17) THEN
C         WRITE(UNIT=IX(1),FMT=100)(DID(I),I=1,NID)
C       ELSE
C         DO 1 I=1,NID,3
C         IF(I+2.GT.NID) THEN
C           J=NID-I+1
C         ELSE
C           J=3
C         END IF
C         IF(IKEY.EQ.-18) THEN
C           READ(UNIT=IX(1),FMT=100)(DTEMP(K),K=1,J)
C         ELSE IF(IKEY.EQ.-19) THEN
C           I2=I+J-1
C           WRITE(UNIT=IX(1))(DID(K),K=I,I2)
C         ELSE
C           READ(UNIT=IX(1))(DTEMP(K),K=1,J)
C         END IF
C   1     CONTINUE
C       END IF
C
      ELSE
        IPATH=2
      END IF
      IF(IKEY.EQ.-17.OR.IKEY.EQ.-19) THEN
C
C  For REPWRITE or BINARYWRITE, reference the OLD variables.
C
        IV1=1
        IV2=IVLIST(1)
      ELSE
C
C  For REPREAD or BINARYREAD, reference MODIFY or new variables.
C
        IV1=IVLIST(1)+1
        IV2=IV1+IVLIST(2)+IVLIST(3)-1
      END IF
C
C  Compute in N the total length for all variables.
C
      N=0
      IF(IPATH.EQ.2) THEN
C
C  For formatted output, determine nslice
C
        NSLICE=IX(4)
        IF(IFIRST.EQ.1) THEN
C
C  If SLICELENGTH has been specified, check that the number of
C  lengths matches the number of variables.
C
          IF(IVLIST(7).GT.4) THEN
            IF(IV2-IV1+1.NE.IVLIST(7)-4)GO TO 94
          END IF
        END IF
        IF(IVLIST(7).GT.4.AND.NSLICE.EQ.0) THEN
C
C  If SLICELENGTH has been specified, compute NSLICE from the first
C  matrix.
C
          IF(IX(5).LE.0)GO TO 94
          NSLICE=MATSIZ(DIMX(DIMPNT(IV1)),MTYPE(IV1),MTRAN(IV1))/IX(5)
          IF(NSLICE.LE.0)GO TO 94
        END IF
      END IF
      DO 25 IV=IV1,IV2
      I=MATSIZ(DIMX(DIMPNT(IV)),MTYPE(IV),MTRAN(IV))
      N=N+I
      IF(IFIRST.EQ.1.AND.IPATH.EQ.2) THEN
        IF(NSLICE.GT.0) THEN
          IF(NSLICE*(I/NSLICE).NE.I)GO TO 94
          IF(IVLIST(7).GT.4) THEN
C
C  If SLICELENGTH has been specified, check that the length is
C  consistent with NSLICE.
C
            IF(IX(IV-IV1+5)*NSLICE.NE.I)GO TO 94
          END IF
        END IF
      END IF
   25 CONTINUE
C
C  IWRITE - keeps track of whether this case should be written
C  IREAD  - for path=1, keeps track of read status
C
      IWRITE=0
      IREAD=0
      NXPTDS=NXPTD
      IF(NSLICE.EQ.0)NSLICE=1
C
C  For IPATH=1, will need N space if reading and CONSTANTS or
C  FULL options are used.
C  On the first call, check that enough space has been set aside.
C  If there was an attempt to allocate space, reallocate if REPREAD.
C
      IF(IPATH.EQ.2.OR.(IPATH.EQ.1.AND.(IKEY.EQ.-18.OR.IKEY.EQ.-20)
     .   .AND.(IX(3).EQ.1.OR.IX(3).EQ.2))) THEN
        IF(IFIRST.EQ.1) THEN
          IF(N.GT.IVLIST(5)) THEN
            IF(IVLIST(5).GT.0.AND.(IKEY.EQ.-18.OR.IKEY.EQ.-20)) THEN
              IVLIST(5)=N
              IVLIST(4)=NXPTD
              CALL ROOMD(N)
            ELSE
C
C  For REPWRITE, reset IVLIST(5)=0 if not enough space in CONSTANTS,
C  so that temporary space will be allocated each time.
C
              IVLIST(5)=0
            END IF
          END IF
        END IF
C
C  If IVLIST(5)=0, allocate temporary storage
C
        IF(IVLIST(5).EQ.0) THEN
          CALL ROOMD(N)
          IVLIST(4)=NXPTDS
        END IF
      END IF
C
C  If OPTION CONSTANT, then either read here or set IWRITE.
C
      IF(IFIRST.EQ.1.AND.IX(3).EQ.2) THEN
        IF(IKEY.EQ.-18.OR.IKEY.EQ.-20) THEN
          IF(IPATH.EQ.1) THEN
            IREAD=1
          ELSE
            CALL DREAD(IX(1),DX(IVLIST(4)),N,INFRMT,IVLIST(6),IX(2))
          END IF
          IF(IVLIST(5).EQ.0) THEN
            IVLIST(5)=N
          END IF
        ELSE IF(IKEY.EQ.-17.OR.IKEY.EQ.-19) THEN
          IWRITE=1
        END IF
      ELSE IF(IX(3).EQ.0.OR.IX(3).EQ.3.OR.IX(3).EQ.4) THEN
C
C  OPTION REPLICATE  (default)  read/write for each replicate.
C
        IF(IX(2).EQ.1) THEN
          IF(IKEY.EQ.-18.OR.IKEY.EQ.-20) THEN
C
C  OPTION BYREPEAT - rewind file if replicate 0 of second or
C  later BY group.
C
            IF(IX(3).EQ.4) THEN
              IF(IFIRST.EQ.0.AND.DID(1).EQ.0.) THEN
                REWIND(UNIT=IX(1))
              END IF
            END IF
            IF(IPATH.EQ.1) THEN
              IREAD=1
            ELSE
              CALL DREAD(IX(1),DX(IVLIST(4)),N,INFRMT,IVLIST(6),IX(2))
C
C  If attempt read but hit end of file, then error off
C
              IF(IX(2).EQ.0) THEN
                WRITE(U6,202)
                IERROR=1
                RETURN
              END IF
            END IF
          ELSE IF(IKEY.EQ.-17.OR.IKEY.EQ.-19) THEN
            IWRITE=1
          END IF
        END IF
      ELSE IF(IX(3).EQ.1) THEN
C
C  Under FULL, read/write only for full samples.
C
        IF(IX(2).EQ.1.AND.DID(1).EQ.0.D0) THEN
          IF(IKEY.EQ.-18.OR.IKEY.EQ.-20) THEN
            IF(IPATH.EQ.1) THEN
              IREAD=1
            ELSE
              CALL DREAD(IX(1),DX(IVLIST(4)),N,INFRMT,IVLIST(6),IX(2))
C
C  If only temporary storage is used for REPREAD, then write the matrix
C  to the scratch file, for each set of full sample values.
C
              IF(IVLIST(5).EQ.0) THEN
                WRITE(13)ITRANS,N
                CALL UNFOUT(13,DX(IVLIST(4)),N)
              END IF
            END IF
          ELSE IF(IKEY.EQ.-17.OR.IKEY.EQ.-19) THEN
            IWRITE=1
          END IF
          IF(IX(2).EQ.0) THEN
            WRITE(U6,202)
            IERROR=1
            RETURN
          END IF
        ELSE IF((IKEY.EQ.-18.OR.IKEY.EQ.-20).AND.IVLIST(5).EQ.0) THEN
C
C  If only temporary storage is used for REPREAD, then read the matrix
C  for the full sample values back in from the scratch file.
C
          CALL SCPOSN(ITRANS,NCELL)
          CALL UNFIN(13,DX(IVLIST(4)),N,ENDFLE)
        END IF
      END IF
C
C
      IF(IPATH.EQ.1.AND.(IREAD.EQ.1.OR.IWRITE.EQ.1)) THEN
        IF(IREAD.EQ.1.AND.(IX(3).EQ.1.OR.IX(3).EQ.2)) THEN
          J=IVLIST(4)
        END IF
        DO 20 IV=IV1,IV2
        IBASE=DXPNT(IV)-1
        NM=MATSIZ(DIMX(DIMPNT(IV)),MTYPE(IV),MTRAN(IV))
C
C  For REPWRITE or REPREAD, can input or output in single line
C
        IF(IKEY.EQ.-17) THEN
          WRITE(UNIT=IX(1),FMT=100)(DX(IBASE+I),I=1,NM)
        ELSE IF(IKEY.EQ.-18) THEN
          READ(UNIT=IX(1),FMT=100)(DX(IBASE+I),I=1,NM)
        ELSE
C
C  Under BINARYREAD or BINARYWRITE, output is broken into segments of
C  length 32.
C
          DO 15 I1=1,NM,32
          IF(I1+31.GT.NM) THEN
            I2=NM
          ELSE
            I2=I1+31
          END IF
          IF(IKEY.EQ.-19) THEN
            WRITE(UNIT=IX(1))(DX(IBASE+I),I=I1,I2)
          ELSE
            READ(UNIT=IX(1))(DX(IBASE+I),I=I1,I2)
          END IF
   15     CONTINUE
        END IF
        IF(IREAD.EQ.1.AND.(IX(3).EQ.1.OR.IX(3).EQ.2)) THEN
          DO 17 I1=1,NM
          DX(J)=DX(IBASE+I1)
          J=J+1
   17     CONTINUE
        END IF
   20   CONTINUE
        IF(IREAD.EQ.1.AND.IX(3).EQ.1) THEN
C
C  Under FULL, read/write only for full samples.
C
          IF(IVLIST(5).EQ.0) THEN
            WRITE(13)ITRANS,N
            CALL UNFOUT(13,DX(IVLIST(4)),N)
          END IF
        END IF
      END IF
C
C  For REPREAD under format, always copy values back to matrices,
C  whether or not they have just been read.
C
      IF((IKEY.EQ.-18.OR.IKEY.EQ.-20).AND.
     .  (IPATH.EQ.2.OR.(IPATH.EQ.1.AND.IREAD.EQ.0))) THEN
        IF(NSLICE.EQ.0)NSLICE=1
        I=IVLIST(4)
        DO 48 ISLICE=1,NSLICE
        DO 45 IV=IV1,IV2
        N1=MATSIZ(DIMX(DIMPNT(IV)),MTYPE(IV),MTRAN(IV))/NSLICE
        J=DXPNT(IV)+N1*(ISLICE-1)
        DO 40 K=1,N1
        DX(J)=DX(I)
        I=I+1
        J=J+1
   40   CONTINUE
   45   CONTINUE
   48   CONTINUE
      ELSE IF(IWRITE.EQ.1.AND.IPATH.EQ.2) THEN
C
C  Under REPWRITE, write only if appropriate.
C
        I=IVLIST(4)
        DO 58 ISLICE=1,NSLICE
        DO 55 IV=IV1,IV2
        N1=MATSIZ(DIMX(DIMPNT(IV)),MTYPE(IV),MTRAN(IV))/NSLICE
        J=DXPNT(IV)+N1*(ISLICE-1)
        DO 50 K=1,N1
        DX(I)=DX(J)
        I=I+1
        J=J+1
   50   CONTINUE
   55   CONTINUE
   58   CONTINUE
        CALL DWRITE(IX(1),DX(IVLIST(4)),N,INFRMT,IVLIST(6))
      END IF
C
C  If IVLIST(5) is still 0, only temporary storage has been used.
C  By resetting NXPTD, the temporary storage will be freed by
C  TCREA2.  Otherwise, changes to NXPTD will result in permanent
C  storage.
C
      IF(IVLIST(5).EQ.0) THEN
        NXPTD=NXPTDS
      END IF
      RETURN
   94 CONTINUE
      WRITE(U6,204)
      IERROR=1
      RETURN
      END
C
      INTEGER FUNCTION MATSIZ(DIMX,MTYPE,MTRAN)
      INTEGER DIMX(*),MTYPE,MTRAN
      IF((MTYPE.EQ.2.OR.MTYPE.EQ.8).AND.MTRAN.EQ.0) THEN
        MATSIZ=2
      ELSE
        MATSIZ=1
      END IF
      NK=DIMX(1)
      IF(NK.GT.0) THEN
        DO 7 IK=2,NK+1
        MATSIZ=MATSIZ*DIMX(IK)
    7   CONTINUE
      END IF
      RETURN
      END
      SUBROUTINE DREAD(IU,DX,N,INFRMT,NF,IFLAG)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER IU,N,NF,IFLAG
      DOUBLE PRECISION DX(N)
      CHARACTER*128 INFRMT(NF)
      READ(UNIT=IU,FMT=INFRMT,END=2)DX
      GO TO 3
    2 CONTINUE
      IFLAG=0
    3 CONTINUE
      RETURN
      END
C
      SUBROUTINE DWRITE(IU,DX,N,INFRMT,NF)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER IU,N,NF
      DOUBLE PRECISION DX(N)
      CHARACTER*128 INFRMT(NF)
      WRITE(UNIT=IU,FMT=INFRMT)DX
      RETURN
      END
C
      SUBROUTINE VAPPND(DID,NID,IFIRST,IVLIST,DXPNT,
     .  DX,MSIZE,IX,ITRANS,IERROR)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DXPNT(*),MSIZE(*),
     . IX(*),ITRANS,IERROR
      DOUBLE PRECISION DID(NID),DX(*)
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      LOGICAL ENDFLE
C
  204 FORMAT(/,' PREMATURE END OF FILE',I3)
C
C  IX(1) - FORTRAN unit
C  IX(2) - 1 unit on end of file (not used)
C  IX(3) - read option
C          0 = not given (i.e., default option)
C          1 = FULL
C          2 = CONSTANTS
C          3 = REPLICATE
C          4 = BYREPEAT
C  IX(4) - ID checking option
C  IX(5) - ANIDTT - length of ID on file
C  IX(6) - ATSIZE - total size of matrix
C  IX(7) - ANRPTT - number of replicates
C
C  N the size of the incoming VPLX data matrix.
C
      N=IX(6)
      IF(IX(5).GT.N) THEN
        NSAVE=IX(5)
      ELSE
        NSAVE=N
      END IF
      NXPTDS=NXPTD
C
C  Will need NSAVE space if reading and CONSTANTS or
C  FULL options are used.
C
C  On the first call, check that enough space has been set aside.
C  If there was an attempt to allocate space, reallocate if REPREAD.
C
      IF(IX(3).EQ.1.OR.IX(3).EQ.2) THEN
        IF(IFIRST.EQ.1) THEN
          IF(NSAVE.GT.IVLIST(5)) THEN
            IF(IVLIST(5).GT.0.OR.IX(3).EQ.2) THEN
              IVLIST(5)=NSAVE
              IVLIST(4)=NXPTD
              CALL ROOMD(NSAVE)
            END IF
          END IF
        END IF
      END IF
C
C  If NSAVE > IVLIST(5), allocate temporary storage
C
      IF(NSAVE.GT.IVLIST(5)) THEN
        CALL ROOMD(NSAVE)
        IVLIST(4)=NXPTDS
      END IF
C
C  IREAD  - keeps track of read status
C         = 0 use previously read values
C         = 1 read from VPLX file
C
      IREAD=0
C
      IF(IFIRST.EQ.1.AND.IX(3).EQ.2) THEN
C
C  If OPTION CONSTANT, read only if IFIRST
C
        IREAD=1
      ELSE IF(IX(3).EQ.1) THEN
C
C  Under FULL, read only for full samples.
C
        IF(DID(1).EQ.0.D0) THEN
          IREAD=1
          IF(IFIRST.NE.1.AND.IX(7).GT.0) THEN
C
C         SPACE VPLX FILE TO NEXT BY GROUP HERE
C
            DO 2 I=1,IX(7)
            READ(IX(1),END=94)(DX(IVLIST(4)+J-1),J=1,IX(5))
            CALL UNFIN(IX(1),DX(IVLIST(4)),IX(6),ENDFLE)
            IF(ENDFLE)GO TO 94
    2       CONTINUE
          END IF
        ELSE IF(NSAVE.GT.IVLIST(5)) THEN
C
C  If only temporary storage is used for REPREAD, then read the matrix
C  for the full sample values back in from the scratch file.
C
          CALL SCPOSN(ITRANS,NCELL)
          CALL UNFIN(13,DX(IVLIST(4)),N,ENDFLE)
        END IF
      ELSE IF(IX(3).EQ.0.OR.IX(3).EQ.3.OR.IX(3).EQ.4) THEN
C
C  OPTION REPLICATE (default), or BYREPEAT - read for each replicate.
C
        IREAD=1
C
C  OPTION BYREPEAT - rewind file if replicate 0 of second or
C  later BY group.  PREAMD will allocate space for ids and coefficients:
C  free up the space.
C
        IF(IX(3).EQ.4) THEN
          IF(IFIRST.EQ.0.AND.DID(1).EQ.0.) THEN
            REWIND(UNIT=IX(1))
            NXPTD2=NXPTD
            CALL PREAMD(IX(1))
            NXPTD=NXPTD2
          END IF
        END IF
      END IF
C
C
      IF(IREAD.EQ.1) THEN
C
C       READ VPLX FILE
C
        READ(IX(1),END=94)(DX(IVLIST(4)+J-1),J=1,IX(5))
c       write(6,*)(DX(IVLIST(4)+J-1),J=1,IX(5))
        CALL UNFIN(IX(1),DX(IVLIST(4)),N,ENDFLE)
c       write(6,*)(dx(j),j=ivlist(4),ivlist(4)+n-1)
        IF(ENDFLE)GO TO 94
        IF(IX(3).EQ.1) THEN
C
C  Under FULL, write full sample.
C
          IF(NSAVE.GT.IVLIST(5)) THEN
            WRITE(13)ITRANS,N
            CALL UNFOUT(13,DX(IVLIST(4)),N)
          END IF
        END IF
      END IF
      K=8
      DO 20 IV=1,IVLIST(3)
c     write(6,*)ix(k),ix(k+1),ix(k+2)
      KK=DXPNT(IV)
      L=IVLIST(4)+IX(K)-1
      IF(MSIZE(IV).EQ.1) THEN
        DO 12 J=1,IX(K+2)
        DX(KK)=DX(L)
c       write(6,*)kk,l,dx(l)
        KK=KK+1
        L=L+IX(K+1)
   12   CONTINUE
      ELSE
        DO 16 J=1,IX(K+2)
        DO 14 JJ=1,MSIZE(IV)
        DX(KK)=DX(L+JJ-1)
c       write(6,*)kk,l,dx(l+jj-1)
        KK=KK+1
   14   CONTINUE
        L=L+IX(K+1)
   16   CONTINUE
      END IF
      K=K+3
   20 CONTINUE
 
C
C  If NSAVE > IVLIST(5), only temporary storage has been used.
C  By resetting NXPTD, the temporary storage will be freed by
C  TCREA2.  Otherwise, changes to NXPTD will result in permanent
C  storage.
C
      IF(NSAVE.GT.IVLIST(5)) THEN
        NXPTD=NXPTDS
      END IF
      RETURN
   94 CONTINUE
      WRITE(U6,204)
      IERROR=1
      RETURN
      END
 
C
C
C  End of T3.FOR
C
      SUBROUTINE TMOVE1(IS,INC1,ISN,INCN,IP,INC2,IA,NA,ICLBLK,IVP,
     .  ITRANP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MAXIDS=10)
      PARAMETER (IXFLLD=72+3*MAXIDS)
C
      INTEGER NA,IA(3,*)
 
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
      INTEGER SICMUL,IFILL(IXFLLD)
      COMMON /STPBLK/SICMUL,IFILL
C
      DOUBLE PRECISION TOT,MISSNG
      DATA MISSNG/-98765.432109D0/
C
C  Function type
C
C  0  -  Default
C  1  -  Percent or Mean
C  2  -  Total
C  3  -  Percent1
C  4  -  Total1
C  5  -  Percent2
C  6  -  Proportion
C  7  -  Proportion1
C  8  -  N of a variable
C  9  -  N of a block
C 10  -  Value of variable, i.e., without indicators
C
      ITRAN=ITRANP
      IV=IVP
      IS0=IS
      INC0=INC1
      IF(ITRAN.EQ.8) THEN
        IF(MTYPE(IV).EQ.1.OR.(MTYPE(IV).EQ.3.AND.MSIZE(IV).EQ.1)) THEN
          ITRAN=9
          IV=ICLBLK
          IS0=ISN
          INC0=INCN
        END IF
      END IF
      IF(ITRAN.EQ.9) THEN
        IS2=IP
        IC2=INC2
        MT=0
      ELSE
        MT=MTYPE(IV)
        IF(ITRAN.EQ.0.OR.ITRAN.EQ.5.OR.ITRAN.EQ.6.OR.ITRAN.EQ.10.OR.
     .    ((ITRAN.EQ.1.OR.ITRAN.EQ.2).AND.
     .      (MT.EQ.1.OR.MT.EQ.3.OR.MT.EQ.9))) THEN
          IS2=IP
          IF(INC2.GT.1) THEN
            IC2=INC2
          ELSE
            IC2=MSIZE(IV)
          END IF
        ELSE
          IS2=NXPTD
          IC2=MSIZE(IV)
        END IF
      END IF
      CALL TMOV1A(IS0,INC0,IS2,IC2,ICLBLK,IV,ITRAN,IA,NA,ISIZE)
      IF(IMERR1.GT.0)RETURN
      IF(ITRAN.EQ.0.OR.ITRAN.EQ.9.OR.ITRAN.EQ.10.OR.
     .  (ITRAN.EQ.2.AND.(MT.EQ.1.OR.MT.EQ.3.OR.MT.EQ.9))) RETURN
      IF(ITRAN.EQ.1.OR.ITRAN.EQ.5.OR.ITRAN.EQ.6) THEN
        IF(MT.EQ.1.OR.(MT.EQ.3.AND.MSIZE(IV).EQ.1)) THEN
          IS2=NXPTD
          CALL TMOV1A(ISN,INCN,IS2,1,ICLBLK,ICLBLK,9,IA,NA,
     .      ISIZE1)
          IF(IMERR1.GT.0)RETURN
          K=IP
          KK=NXPTD
          DO 3 I=1,ISIZE,IC2
          IF(DABS(DX(KK)-MISSNG).LT..1D-6) THEN
            DX(K)=MISSNG
          ELSE IF(DX(KK).GT.0..AND.DABS(DX(K)-MISSNG).GT..1D-6) THEN
            DX(K)=DX(K)/DX(KK)
            IF(MT.EQ.3.AND.ITRAN.EQ.1)DX(K)=100.D0*DX(K)
          ELSE
            DX(K)=MISSNG
          END IF
          K=K+IC2
          KK=KK+1
    3     CONTINUE
        ELSE IF(MT.EQ.2) THEN
          K=IP
          IF(INC2.GT.1) THEN
            IC2P=INC2
          ELSE
            IC2P=1
          END IF
          KK=NXPTD
          DO 5 I=1,ISIZE,IC2
          IF(DABS(DX(KK)-MISSNG).LT..1D-6.AND.
     .       DABS(DX(K)-MISSNG).GT..1D-6) THEN
            DX(K)=MISSNG
          ELSE IF(DX(KK+1).GT.0.) THEN
            DX(K)=DX(KK)/DX(KK+1)
          ELSE
            DX(K)=MISSNG
          END IF
          K=K+IC2P
          KK=KK+2
    5     CONTINUE
        ELSE IF(MT.EQ.3) THEN
          K=IP-1
          MS=MSIZE(IV)
          DO 8 I=1,ISIZE,IC2
          TOT=0.
          DO 6 J=1,MS
          IF(DABS(DX(K+J)-MISSNG).GT..1D-6) THEN
            IF(DABS(TOT-MISSNG).GT..1D-6) THEN
              TOT=TOT+DX(K+J)
            END IF
          ELSE
            TOT=MISSNG
          END IF
    6     CONTINUE
          DO 7 J=1,MS
          IF(TOT.LE.0.) THEN
            DX(K+J)=MISSNG
          ELSE
            IF(ITRAN.EQ.1) THEN
              DX(K+J)=100.D0*DX(K+J)/TOT
            ELSE
              DX(K+J)=DX(K+J)/TOT
            END IF
          END IF
    7     CONTINUE
          K=K+IC2
    8     CONTINUE
        ELSE IF(MT.EQ.8) THEN
          K=IP
          IF(INC2.GT.1) THEN
            IC2P=INC2
          ELSE
            IC2P=IC2/2
          END IF
          KK=NXPTD
          DO 12 I=1,ISIZE,IC2
          KL=K
          DO 10 J=1,MSIZE(IV),2
          IF(DABS(DX(KK)-MISSNG).LE..1D-6) THEN
            DX(KL)=MISSNG
          ELSE IF(DX(KK+1).GT.0.) THEN
            DX(KL)=DX(KK)/DX(KK+1)
          ELSE
            DX(KL)=MISSNG
          END IF
          KK=KK+2
          KL=KL+1
   10     CONTINUE
          K=K+IC2P
   12     CONTINUE
        ELSE IF(MT.EQ.9) THEN
          IF(ITRAN.EQ.5) THEN
            L=CROSSD(CDMPNT(IV)+1)*CROSSD(CDMPNT(IV)+2)
          ELSE
            L=CROSSD(CDMPNT(IV)+1)
          END IF
          K=IP
          MS=MSIZE(IV)
          DO 20 I=1,ISIZE,IC2
          KK=K-1
          DO 18 LL=1,MS,L
          TOT=0.
          DO 14 J=1,L
          IF(DABS(DX(KK+J)-MISSNG).GT..1D-6) THEN
            IF(DABS(TOT-MISSNG).GT..1D-6) THEN
              TOT=TOT+DX(KK+J)
            END IF
          ELSE
            TOT=MISSNG
          END IF
   14     CONTINUE
          DO 16 J=1,L
          IF(TOT.LE.0.) THEN
            DX(KK+J)=MISSNG
          ELSE
            IF(ITRAN.EQ.1.OR.ITRAN.EQ.5) THEN
              DX(KK+J)=100.D0*DX(KK+J)/TOT
            ELSE
              DX(KK+J)=DX(KK+J)/TOT
            END IF
          END IF
   16     CONTINUE
          KK=KK+L
   18     CONTINUE
          K=K+IC2
   20     CONTINUE
        END IF
      ELSE IF(ITRAN.EQ.3.OR.ITRAN.EQ.4.OR.ITRAN.EQ.7) THEN
        IF(MT.EQ.3) THEN
          MS=MSIZE(IV)
          K=IP-1
          IF(INC2.GT.1) THEN
            IC2P=INC2
          ELSE
            IC2P=MS-1
          END IF
          KK=NXPTD-1
          DO 25 I=1,ISIZE,IC2
          IF(ITRAN.EQ.3.OR.ITRAN.EQ.7) THEN
            TOT=0.
            DO 22 J=1,MS
            IF(DABS(DX(KK+J)-MISSNG).GT..1D-6) THEN
              IF(DABS(TOT-MISSNG).GT..1D-6) THEN
                TOT=TOT+DX(KK+J)
              END IF
            ELSE
              TOT=MISSNG
            END IF
   22       CONTINUE
          END IF
          DO 24 J=1,MS-1
          IF(ITRAN.EQ.4) THEN
            DX(K+J)=DX(KK+J)
          ELSE IF(TOT.LE.0.) THEN
            DX(K+J)=MISSNG
          ELSE
            IF(ITRAN.EQ.3) THEN
              DX(K+J)=100.D0*DX(KK+J)/TOT
            ELSE
              DX(K+J)=DX(KK+J)/TOT
            END IF
          END IF
   24     CONTINUE
          K=K+IC2P
          KK=KK+MS
   25     CONTINUE
        ELSE IF(MT.EQ.9) THEN
          L=CROSSD(CDMPNT(IV)+1)
          MS=MSIZE(IV)
          IF(INC2.GT.1) THEN
            IC2P=INC2
          ELSE
            IC2P=((L-1)*MS)/L
          END IF
          K=IP-1
          KK=NXPTD-1
          MS=MSIZE(IV)
          DO 30 I=1,ISIZE,IC2
          KL=K
          DO 29 LL=1,MS,L
          IF(ITRAN.EQ.3.OR.ITRAN.EQ.7) THEN
            TOT=0.
            DO 26 J=1,L
            IF(DABS(DX(KK+J)-MISSNG).GT..1D-6) THEN
              IF(DABS(TOT-MISSNG).GT..1D-6) THEN
                TOT=TOT+DX(KK+J)
              END IF
            ELSE
              TOT=MISSNG
            END IF
   26       CONTINUE
          END IF
          DO 27 J=1,L-1
          IF(ITRAN.EQ.4) THEN
            DX(KL+J)=DX(KK+J)
          ELSE IF(TOT.LE.0.) THEN
            DX(KL+J)=MISSNG
          ELSE
            IF(ITRAN.EQ.3) THEN
              DX(KL+J)=100.D0*DX(KK+J)/TOT
            ELSE
              DX(KL+J)=DX(KK+J)/TOT
            END IF
          END IF
   27     CONTINUE
          KK=KK+L
          KL=KL+L-1
   29     CONTINUE
          K=K+IC2P
   30     CONTINUE
        END IF
      ELSE IF(ITRAN.EQ.8) THEN
        IF(MT.EQ.2) THEN
          K=IP
          KK=NXPTD+1
          IF(INC2.GT.1) THEN
            IC2P=INC2
          ELSE
            IC2P=1
          END IF
          DO 31 I=1,ISIZE,IC2
          DX(K)=DX(KK)
          K=K+IC2P
          KK=KK+2
   31     CONTINUE
        ELSE IF(MT.EQ.3) THEN
          K=IP
          KK=NXPTD-1
          MS=MSIZE(IV)
          IF(INC2.GT.1) THEN
            IC2P=INC2
          ELSE
            IC2P=1
          END IF
          DO 33 I=1,ISIZE,IC2
          TOT=0.
          DO 32 J=1,MS
          IF(DABS(DX(KK+J)-MISSNG).GT..1D-6) THEN
            IF(DABS(TOT-MISSNG).GT..1D-6) THEN
              TOT=TOT+DX(KK+J)
            END IF
          ELSE
            TOT=MISSNG
          END IF
   32     CONTINUE
          DX(K)=TOT
          K=K+IC2P
          KK=KK+MS
   33     CONTINUE
        ELSE IF(MT.EQ.8) THEN
          IF(INC2.GT.1) THEN
            IC2P=INC2
          ELSE
            IC2P=MSIZE(IV)/2
          END IF
          K=IP
          KK=NXPTD+1
          DO 35 I=1,ISIZE,IC2
          KL=K
          DO 34 J=1,MSIZE(IV),2
          DX(KL)=DX(KK)
          KK=KK+2
          KL=KL+1
   34     CONTINUE
          K=K+IC2P
   35     CONTINUE
        ELSE IF(MT.EQ.9) THEN
          L=CROSSD(CDMPNT(IV)+1)
          K=IP
          KK=NXPTD-1
          MS=MSIZE(IV)
          IF(INC2.GT.1) THEN
            IC2P=INC2
          ELSE
            IC2P=MS/L
          END IF
          DO 40 I=1,ISIZE,IC2
          KL=K
          DO 39 LL=1,MS,L
          TOT=0.
          DO 36 J=1,L
          IF(DABS(DX(KK+J)-MISSNG).GT..1D-6) THEN
            IF(DABS(TOT-MISSNG).GT..1D-6) THEN
              TOT=TOT+DX(KK+J)
            END IF
          ELSE
            TOT=MISSNG
          END IF
   36     CONTINUE
          DX(KL)=TOT
          KK=KK+L
          KL=KL+1
   39     CONTINUE
          K=K+IC2P
   40     CONTINUE
        END IF
      ELSE IF(ITRAN.EQ.2) THEN
        IF(MT.EQ.2) THEN
          K=IP
          KK=NXPTD
          IF(INC2.GT.1) THEN
            IC2P=INC2
          ELSE
            IC2P=1
          END IF
          DO 45 I=1,ISIZE,IC2
          DX(K)=DX(KK)
          K=K+IC2P
          KK=KK+2
   45     CONTINUE
        ELSE IF(MT.EQ.8) THEN
          IF(INC2.GT.1) THEN
            IC2P=INC2
          ELSE
            IC2P=MSIZE(IV)/2
          END IF
          K=IP
          KK=NXPTD
          DO 48 I=1,ISIZE,IC2
          KL=K
          DO 47 J=1,MSIZE(IV),2
          DX(KL)=DX(KK)
          KK=KK+2
          KL=KL+1
   47     CONTINUE
          K=K+IC2P
   48     CONTINUE
        END IF
      END IF
      RETURN
      END
      SUBROUTINE TMOV1A(IS,INC1,IP,INC2,ICLBLK,IV1,IV2,IA,NA,ISIZE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MIXFLL=6*MRANGE+2*MRNSET+5*MRECOD+4*MVAR+MSIZEI)
      PARAMETER (IXFLLD=72+3*MAXIDS)
C
      INTEGER IS,INC1,IP,INC2,ICLBLK,IV1,IV2,IA(3,*),NA,ISIZE
      DOUBLE PRECISION DX(MSIZED)
      INTEGER IX(MIXFLL)
      COMMON /DBLOCK/DX
      COMMON /STMBLK/IX
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      INTEGER SICMUL,IFILL(IXFLLD)
      COMMON /STPBLK/SICMUL,IFILL
      INTEGER SI1,SI2,SI3,SI4,SI5,SI6,SI7,SI8,SI10,SI11
C
      DOUBLE PRECISION MISSNG
      DATA MISSNG/-98765.432109D0/
C
  200 FORMAT(' TMOV1A: ERROR IN COLLAPSING')
  201 FORMAT(' TMOV1A: J=',I6,' NL=',I6)
  202 FORMAT(' TMOV1A: L=',I6,' NOUT=',I6,' NIN=',I6)
C
C  Internal matrices:
C
C  IX(SI1+  ) - output dimensions
C  IX(SI2+  ) - output class variables
C  IX(SI3+  ) - pointer to first level of output class,
C               for use with SI5 and SI6, starts at 0
C  IX(SI4+  ) - ICLBAR for corresponding output class
C  IX(SI5+  ) - pointer to first cell, starts at 0
C  IX(SI6+  ) - number of cells
C  IX(SI7+  ) - individual cells, numbered from 0
C  IX(SI8+  ) - increments for input, in output order
C  IX(SI10+ ) - coordinate array for output cells, starts at 0
C  IX(SI11+ ) - coordinate array for input cells used to form output
C               starts at 0
C
      NIN=BLNCLS(ICLBLK)
      SI1=NXPTI
C
C  IVLEN is number of cells for each combination of class variables
C
      IF(IV2.EQ.9) THEN
        IVLEN=1
      ELSE
        IVLEN=MSIZE(IV1)
      END IF
C
C  Determine the increment for the temporary matrix
C
      IF(INC2.EQ.1) THEN
        IS2INC=IVLEN
      ELSE
        IS2INC=INC2
      END IF
C
C  Check whether specified class variables match, in identical order,
C  those for the block, a special case handled at statement 55
C  If the block has no class variables, then there should either be:
C     No class specification for the variable, or
C     A specification of "/CLASS TOTAL"
C
      IF(NIN.EQ.0) THEN
        IF(NA.EQ.0)GO TO 55
        IF(IA(1,1).EQ.1.AND.IA(1,2).EQ.0)GO TO 55
C
C  If the block has class variables, check whether the class variables
C  match.  All instances of failure are sent to statement 6.
C
      ELSE
        IF(NA.EQ.0)GO TO 6
        K=1
        ICLBAR=BLCPNT(ICLBLK)
   1    CONTINUE
        N=IA(1,K)
        K=K+1
        DO 3 J=1,N
C
C  The next statement assures that ICLBAR, which is incremented in
C  statements below, has not stepped beyond the appropriate range for
C  the block
C
        IF(BLCPNT(ICLBLK)+NIN.LE.ICLBAR)GO TO 6
C
C  The next statement checks that the CLASS specification points to
C  the right class variable.
C
        IF(IA(1,K).NE.CLPNT(ICLBAR))GO TO 6
C
C  If no range is given for the class variable, then the block
C  cannot be of type 0, with separate marginal total.
C
        IF(IA(3,K).EQ.0) THEN
          IF(CLTYPE(ICLBAR).EQ.0)GO TO 6
          ICLBAR=ICLBAR+1
C
C  If a range is given for the class variable, then check that the
C  levels are specified in the right order.  For blocks of type 0,
C  level 0 must be specified first.
C
        ELSE
          IF(CLTYPE(ICLBAR).EQ.1) THEN
            IF(IA(2,K).NE.IA(3,K))GO TO 6
C
C  If the last level has been listed, then increment ICLBAR
C
            IF(IA(3,K).EQ.MSIZE(CLPNT(ICLBAR))) THEN
              ICLBAR=ICLBAR+1
            END IF
          ELSE
            IF(IA(2,K)+1.NE.IA(3,K))GO TO 6
            IF(IA(3,K).EQ.MSIZE(CLPNT(ICLBAR))+1) THEN
              ICLBAR=ICLBAR+1
            END IF
          END IF
        END IF
        K=K+1
    3   CONTINUE
C
C  Loop back to 1 if more remains on the specification
C
        IF(K.LE.NA) GO TO 1
C
C  This last check insures that all classes have matched, which will
C  be the case if ICLBAR has been incremented to just beyond the
C  range for the block.
C
        IF(ICLBAR.EQ.BLCPNT(ICLBLK)+NIN)GO TO 55
      END IF
C
C  Creating the output is handled either here or at statement 55
C  Treatment of the general case begins here.
C
    6 CONTINUE
C
C  The code from here to statement 15 calculates the three variables:
C  NL  - upper bound on number of cells of input to be placed on list
C        to form output
C  NC  - index of levels for output
C  NOUT- number of output classes
C  It also computes entries for arrays starting with SI1, SI2, SI3, SI4
C    IX(SI1+  ) - output dimensions
C    IX(SI2+  ) - output class variables
C    IX(SI3+  ) - pointer to first level of output class,
C                 for use with SI5 and SI6, starts at 0
C    IX(SI4+  ) - ICLBAR for corresponding output class
C
      NOUT=0
      NC=0
      NL=0
      SI2=NXPTI+NIN
      SI3=SI2+NIN
      SI4=SI3+NIN
      K=4*NIN
C
C  Call ROOMI to allocate space
C
      IF(K.GT.0)CALL ROOMI(K)
C
C  Loop through specification to identify class variables
C
      IF(NA.GT.0) THEN
        K=1
   7    CONTINUE
        N=IA(1,K)
        K=K+1
        DO 9 J=1,N
C
C  If the specification includes TOTAL, treat it simply as TOTAL
C
        IF(IA(1,K).EQ.0) THEN
          NOUT=0
          NC=0
          NL=0
          GO TO 10
        END IF
C
C  Unless at the end of the specification, look ahead.
C  If the current part of the specification gives a level of a class
C  variable to be followed by other levels, adjust NL but do not
C  store into IX(SI1+  ) yet.
C
        IF(J.LT.N) THEN
          K1=K+1
          IF(IA(1,K1).EQ.IA(1,K)) THEN
            IF(IA(2,K).EQ.0) THEN
              NL=NL+MSIZE(IA(1,K))
            ELSE
              NL=NL+1
            END IF
            GO TO 8
          END IF
        END IF
C
C  If this the last (possibly only) part of the specification to
C  refer to a class variable, store the number of outgoing levels
C  in IX(SI1+
C
        IF(IA(3,K).EQ.0) THEN
          IX(SI1+NOUT)=MSIZE(IA(1,K))
          NL=NL+MSIZE(IA(1,K))
        ELSE
          IX(SI1+NOUT)=IA(3,K)
          IF(IA(2,K).EQ.0) THEN
            NL=NL+MSIZE(IA(1,K))
          ELSE
            NL=NL+1
          END IF
        END IF
C
C  Store the variable number of the class variable in IX(SI2+
C  and a cumulative total of IX(SI1+ into IX(SI3+
C
        IX(SI2+NOUT)=IA(1,K)
        IX(SI3+NOUT)=NC
        NC=NC+IX(SI1+NOUT)
        NOUT=NOUT+1
    8   CONTINUE
        K=K+1
    9   CONTINUE
C
C  If not done with the specification, return to statement 7
C
        IF(K.LE.NA)GO TO 7
      END IF
   10 CONTINUE
      L=NOUT
      ICLBAR=BLCPNT(ICLBLK)
C
C  Complete arrays for input class variables not output.
C  Loop over all variables in the block.
C
      DO 15 I=1,NIN
      IF(NOUT.GT.0) THEN
        DO 12 J=1,NOUT
        IF(IX(SI2+J-1).EQ.CLPNT(ICLBAR)) THEN
C
C  The class variable has already appeared in the specification
C
          IX(SI4+J-1)=ICLBAR
          GO TO 14
        END IF
   12   CONTINUE
      END IF
C
C  For class variables not mentioned in the specification.
C
      IX(SI1+L)=1
      IX(SI2+L)=CLPNT(ICLBAR)
      IX(SI3+L)=NC
      IX(SI4+L)=ICLBAR
      NC=NC+1
      L=L+1
      IF(CLTYPE(ICLBAR).EQ.0) THEN
        NL=NL+1
      ELSE
        NL=NL+MSIZE(CLPNT(ICLBAR))
      END IF
   14 CONTINUE
      ICLBAR=ICLBAR+1
   15 CONTINUE
C
C  The following statement performs a check that class variables
C  have been properly accounted for.
C
      IF(L.NE.NIN) THEN
        WRITE(U6,202)L,NOUT,NIN
        IMERR1=50001
        RETURN
      END IF
C
C  From here to just beyond statement 27, compute entries for
C  arrays starting with SI5, SI6, SI7
C    IX(SI5+  ) - pointer to first cell, starts at 0
C    IX(SI6+  ) - number of cells
C    IX(SI7+  ) - individual cells, numbered from 0
C  Note that their lengths, NC, NC, and NL, respectively, were
C  computed in the previous code.
C
      SI5=SI4+NIN
      SI6=SI5+NC
      SI7=SI6+NC
      K=2*NC+NL
      CALL ROOMI(K)
C
C  ICL - index for output levels
C  J   - index for output cells
C  LOUT- index for output classes
C
      ICL=0
      J=0
      LOUT=0
C
C  Loop over class variables in specification
C
      IF(NOUT.GT.0) THEN
        K=1
  17    CONTINUE
        N=IA(1,K)
        K=K+1
        DO 24 L=1,N
C
C  In performing loop, always look backwards 1
C
        IF(L.GT.1) THEN
          K1=K-1
C
C  If the current part of the specification is the first mention
C  of the class, increment LOUT
C
          IF(IA(1,K).NE.IA(1,K1)) THEN
 
            LOUT=LOUT+1
C
C  Else if the same class was mentioned in the previous part of the
C  specification:
C
          ELSE
C
C  Check to see if this level is included in the + condition, in
C  which case IA(3,K) and IA(3,K1) will agree
C
            IF(IA(3,K).EQ.IA(3,K1)) THEN
C
C   a.  If this is a case +TOTAL and the class type is 1, add all
C       the levels of the class into IX(SI7+ and increment IX(SI6+
C
              IF(IA(2,K).EQ.0.AND.CLTYPE(IX(SI4+LOUT)).EQ.1) THEN
                DO 18 I=1,MSIZE(IA(1,K))
                IX(SI7+J)=I-1
                J=J+1
   18           CONTINUE
                IX(SI6+ICL)=IX(SI6+ICL)+MSIZE(IA(1,K))
C
C    b.  In other cases, add the appropriate cell to IX(SI7+ and
C        increment IX(SI6+ by 1.
C
              ELSE
                IF(CLTYPE(IX(SI4+LOUT)).EQ.1) THEN
                  IX(SI7+J)=IA(2,K)-1
                ELSE
                  IX(SI7+J)=IA(2,K)
                END IF
                J=J+1
                IX(SI6+ICL-1)=IX(SI6+ICL-1)+1
              END IF
C
C Handling of + case completed
C
             GO TO 22
            END IF
          END IF
C
C  In addition to L > 1, increment LOUT if K > 2, which can
C  happen if the * was omitted between classes.
C
        ELSE IF(K.GT.2) THEN
          LOUT=LOUT+1
        END IF
C
C  Processing for first mention of an outgoing level.
C  First, set pointer in IX(SI5+ to current value of J to
C  retain start of cells for the outgoing level.
C
C
C    a.  If the specification doesn't include a range, fill
C        in implied 1-n range into IX(SI7+, store 1 in IX(SI6+
C
        IF(IA(3,K).EQ.0) THEN
          DO 19 I=1,MSIZE(IA(1,K))
          IF(CLTYPE(IX(SI4+LOUT)).EQ.1) THEN
            IX(SI7+J)=I-1
          ELSE
            IX(SI7+J)=I
          END IF
          IX(SI5+ICL)=J
          IX(SI6+ICL)=1
          J=J+1
          ICL=ICL+1
   19     CONTINUE
C
C    b.  Fill in cells for /CLASS TOTAL, for class type 1
C
        ELSE IF(IA(2,K).EQ.0.AND.CLTYPE(IX(SI4+LOUT)).EQ.1) THEN
          IX(SI5+ICL)=J
          IX(SI6+ICL)=MSIZE(IA(1,K))
          ICL=ICL+1
          DO 20 I=1,MSIZE(IA(1,K))
          IX(SI7+J)=I-1
          J=J+1
   20     CONTINUE
C
C    c.  Otherwise, enter single cell, including case of /CLASS TOTAL
C        for class type 0
C
        ELSE
          IX(SI5+ICL)=J
          IX(SI6+ICL)=1
          ICL=ICL+1
          IF(CLTYPE(IX(SI4+LOUT)).EQ.1) THEN
            IX(SI7+J)=IA(2,K)-1
          ELSE
            IX(SI7+J)=IA(2,K)
          END IF
          J=J+1
        END IF
   22   CONTINUE
        K=K+1
   24   CONTINUE
C
C  If more remains in the specification, loop back to 17
C
        IF(K.LE.NA)GO TO 17
      END IF
C
C  Complete arrays for input class variables not output
C
      IF(NOUT.LT.NIN) THEN
        DO 27 I=NOUT+1,NIN
        IX(SI5+ICL)=J
C
C  For class type 0, reference the marginal
C
        IF(CLTYPE(IX(SI4+I-1)).EQ.0) THEN
          IX(SI6+ICL)=1
          ICL=ICL+1
          IX(SI7+J)=0
          J=J+1
C
C  For class type 1, compute the marginal by summation
C
        ELSE
          IX(SI6+ICL)=MSIZE(IX(SI2+I-1))
          ICL=ICL+1
          DO 25 M=1,MSIZE(IX(SI2+I-1))
          IX(SI7+J)=M-1
          J=J+1
   25     CONTINUE
        END IF
   27   CONTINUE
      END IF
C
C  Another "just in case" check to detect an error in indexing
C  Note that NL was an upper bound, so that J < NL is OK
C
      IF(J.GT.NL) THEN
        WRITE(U6,201)J,NL
        IMERR1=50002
        RETURN
      END IF
C
C  Compute entries for arrays starting with S8, and
C    initialize S10 and S11.
C    IX(SI8+  ) - increments for input, in output order
C    IX(SI10+ ) - coordinate array for output cells, starts at 0
C    IX(SI11+ ) - coordinate array for input cells used to form output
C               starts at 0
C
      SI8=SI7+NL
      SI10=SI8+NIN
      SI11=SI10+NIN
      K=3*NIN
      CALL ROOMI(K)
C
C
C
      I1=INC1
      ICLBAR=BLCPNT(ICLBLK)
C
C  Loop through the class variables for the block, in their
C  initial order.  Find the position of the class variable in the
C  outgoing order and store I1 (the increment) in IX(SI8
C
      DO 33 I=1,NIN
      DO 30 J=1,NIN
      IF(IX(SI4+J-1).EQ.ICLBAR) THEN
        IX(SI8+J-1)=I1
      END IF
   30 CONTINUE
C
C  Now multiply I1 by the number of levels (including total, if
C  present) for the class variable.
C
      IF(CLTYPE(ICLBAR).EQ.1) THEN
        I1=I1*MSIZE(CLPNT(ICLBAR))
      ELSE
        I1=I1*(MSIZE(CLPNT(ICLBAR))+1)
      END IF
      IX(SI10+I-1)=0
      ICLBAR=ICLBAR+1
   33 CONTINUE
C
C  IS2 - cell for the outgoing matrix
C
      IS2=IP
C
C  Before entering the loop, set the first element of IX(SI10 to -1
C
      IX(SI10)=-1
   35 CONTINUE
C
C  Loop to increment IX(SI10 over class levels for the outgoing
C  matrix.  Systematically increment the elements of IX(SI10 over
C  combinations with IX(SI1 as the upper bound.
C
      DO 38 I=1,NIN
      IX(SI10+I-1)=IX(SI10+I-1)+1
      IF(IX(SI10+I-1).LT.IX(SI1+I-1)) THEN
        IF(I.GT.1) THEN
          DO 37 J=1,I-1
          IX(SI10+J-1)=0
   37     CONTINUE
        END IF
C
C  Enter zeroes into the outgoing matrix about to be created
C
        IF(IVLEN.EQ.1) THEN
          DX(IS2)=0.
        ELSE
          J=IS2
          DO 36 II=1,IVLEN
          DX(J)=0.
          J=J+1
   36     CONTINUE
        END IF
        GO TO 40
      END IF
   38 CONTINUE
C
C  If fall through to here, done with all outgoing cells.
C
      GO TO 60
   40 CONTINUE
C
C  Ready to begin tally for outgoing cell(s) for given levels
C  of outgoing classes.  First, initialize IX(SI11+, which will
C  be used to control the loop over all incoming cells involved in
C  the summation.
C
      IF(NIN.GT.1) THEN
        DO 41 I=2,NIN
        IX(SI11+I-1)=0
   41   CONTINUE
      END IF
      IX(SI11)=-1
   42 CONTINUE
C
C  Loop to systematically vary the elements of IX(SI11+ to sum over
C  all appropriate levels of incoming classes.
C
      DO 46 I=1,NIN
      IX(SI11+I-1)=IX(SI11+I-1)+1
      ICL=IX(SI3+I-1)+IX(SI10+I-1)
      IF(IX(SI11+I-1).LT.IX(SI6+ICL)) THEN
        IF(I.GT.1) THEN
          DO 44 J=1,I-1
          IX(SI11+J-1)=0
   44     CONTINUE
        END IF
C
C  After completing IX(SI11+ go to 48 for summation over the relevant
C  incoming values
C
        GO TO 48
      END IF
   46 CONTINUE
C
C  If we get to here, all the appropriate values of incoming classes
C  have now been summed.  Return to 35 to check if there are more
C  outgoing cells to be considered.
C  increment IS2 by IS2INC determined at beginning
C
      IS2=IS2+IS2INC
      GO TO 35
   48 CONTINUE
      IS1=IS
C
C  The loop to 50 calculates in IS1 the necessary offset for the
C  current levels of the incoming classes.
C
      DO 50 I=1,NIN
C
C  ICL combines a starting position given by IX(SI3+ with the current
C  level of the outgoing class in IX(SI10+
C
      ICL=IX(SI3+I-1)+IX(SI10+I-1)
C
C  J is determined by a lookup in IX(SI5 with an offset of ICL, plus
C  the current value in IX(SI11+, which is indexing the number of
C  levels.
C
      J=IX(SI5+ICL)+IX(SI11+I-1)
C
C  Use J to look up the index of the incoming class variable, in
C  IX(SI7+ , multiply this by the increment in IX(SI8+ for the class
C  and add this to IS1
C
      IS1=IS1+IX(SI7+J)*IX(SI8+I-1)
   50 CONTINUE
C
C  When we get to here, we are ready to sum into the outgoing cell(s)
C  There are separate loops for 1 cell vs. multiple cells.
C  The sum is missing if either component is missing.
C
      IF(IVLEN.EQ.1) THEN
        IF(DABS(DX(IS2)-MISSNG).GT..1D-6) THEN
          IF(DABS(DX(IS1)-MISSNG).GT..1D-6) THEN
            DX(IS2)=DX(IS2)+DX(IS1)
          ELSE
            DX(IS2)=MISSNG
          END IF
        END IF
      ELSE
        K=IS2
        DO 52 I=1,IVLEN
        IF(DABS(DX(K)-MISSNG).GT..1D-6) THEN
          IF(DABS(DX(IS1)-MISSNG).GT..1D-6) THEN
            DX(K)=DX(K)+DX(IS1)
          ELSE
            DX(K)=MISSNG
          END IF
        END IF
        K=K+1
        IS1=IS1+1
   52   CONTINUE
      END IF
C
C  Loop back to 42 to see if another combination of incoming classes
C  should be summed.
C
      GO TO 42
   55 CONTINUE
C
C  This code is for the special case only.
C  IS2 serves as index for outgoing matrix.
C  IS1 serves as index for incoming matrix.
C
      IS2=IP
      IS1=IS
C
C  This code makes use of the contents of IX(SICMUL+ to determine the
C  total number of cells.
C
      IF(IVLEN.EQ.1) THEN
        DO 56 J=1,IX(SICMUL+ICLBLK-1)
        DX(IS2)=DX(IS1)
        IS1=IS1+INC1
        IS2=IS2+IS2INC
   56   CONTINUE
      ELSE
        DO 58 J=1,IX(SICMUL+ICLBLK-1)
        M=IS1
        M2=IS2
        DO 57 I=1,IVLEN
        DX(M2)=DX(M)
        M2=M2+1
        M=M+1
   57   CONTINUE
        IS1=IS1+INC1
        IS2=IS2+IS2INC
   58   CONTINUE
      END IF
C
C  Normal end under either special or general cases.
C
   60 CONTINUE
      ISIZE=IS2-IP
      NXPTI=SI1
      RETURN
      END
C
C  CN.FOR
C
      SUBROUTINE CONTNT
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MAXFMT=20)
      PARAMETER (MAXSUB=500,MAXSBL=2000)
      PARAMETER (NOPTN=2)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
      CHARACTER*12 VNMIN(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNMIN,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL),
     .   U5LCSW
      COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
      INTEGER ITYPEF(3),IFILEF(3)
C
      DOUBLE PRECISION RVALUE(5)
      CHARACTER*6 RMULT(5)
C
      LOGICAL REFRSH,LTEMP
      EXTERNAL REFRSH
      CHARACTER*15 CTYPE(11)
      CHARACTER*12 OPTNW(NOPTN)
      INTEGER INDX(NOPTN),IVALUE(NOPTN),IOPTN(1)
      DATA CTYPE /'Real           ','Real w/missing ',
     .            'Categorical    ','Class          ',
     .            'BY             ','Crossed real   ',
     .            'Crossed cat    ','Var identifier ',
     .            'Weight         ','Derived        ',
     .            'Crossed derived'/
      DATA OPTNW /    'PRINT       ','NOPRINT     '/
      DATA INDX/1,1/
      DATA IVALUE/1,2/
  101 FORMAT('1 ')
  102 FORMAT(/,15X,'CONTENTS OF FILE ',A40)
  103 FORMAT(/,11X,'Total number of variables',I8)
  104 FORMAT(11X,'Number of basic variables',I8)
  105 FORMAT(11X,'Number of CLASS variables',I8)
  106 FORMAT(11X,'Number of variance identifiers',I3)
  107 FORMAT(11X,'Number of BY variables',9X,I2)
  108 FORMAT(11X,'Weighted analysis')
  109 FORMAT(11X,'Unweighted analysis')
  110 FORMAT(//,' NUMB  VAR NAME  LEVEL  VAR/LEVEL LABEL',11X,'TYPE',
     .11X,'SIZE',4X,'LOC')
  111 FORMAT(/,1X,I4,2X,A12,5X,A24,1X,A15,I5,I7)
  112 FORMAT(16X,I4,4X,A24)
  113 FORMAT(7X,A12,5X,A24)
  114 FORMAT(/,5X,'COMBINATIONS OF BY VARIABLES ON THE FILE')
  115 FORMAT(/,1X,5F15.3,/,1X,5F15.3)
  116 FORMAT(/,5X,'NUMBER OF REPLICATES',I6)
  117 FORMAT(/,5X,'COEFFICIENTS USED IN ESTIMATION OF VARIANCE',/)
  118 FORMAT(2X,4(1X,A6,F12.9))
  119 FORMAT(/,5X,'VALUES OF THE BY VARIABLE ON THE FILE')
  120 FORMAT(11X,'Number of blocks',12X,I5)
  121 FORMAT(//,20X,'CONTENTS OF BLOCK',I5,',  SIZE =',I6)
  122 FORMAT(/,7X,'N(',I5,')',34X,'Weighted N',9X,'1',I7)
  123 FORMAT(/,7X,'N(',I5,')',34X,'Sample N',11X,'1',I7)
  124 FORMAT(I5,'*')
  125 FORMAT(//)
  126 FORMAT(19X,'0',4X,'Total')
      IOPTN(1)=1
      ITYPEF(1)=2
      ITYPEF(2)=1
      ITYPEF(3)=0
      CALL KYFIND(IKEY,IPT)
      WRITE(U6,101)
      CALL CRDPRN(3)
      CALL FNREAD(IPT,ITYPEF,IFILEF,1,IPOSSC)
      IF(IMERR1.GT.0) THEN
        CALL FSTOP
      END IF
      IF(IPOSSC.GT.0) THEN
        U5LCSW=1
C                               ! Reset U5LCSW for REFRSH, etc.
        IPOS=IPOSSC+1
        CALL NBFND2(IPOS,IPT)
        IF(IPT.GT.0) THEN
          CALL KYCHK2(IPT,IGROUP,IKEY,IPOS)
          IF(IGROUP.NE.2.OR.IKEY.NE.11) THEN
            IMERR2=IPT
            CALL FESTOP(39001)
          END IF
          IPT=IPOS
          CALL OPTNTR(NOPTN,INDX,IVALUE,OPTNW,IPT,IPOS,IOPTN)
          IF(IPOS.EQ.0) THEN
            CALL FESTOP(39002)
          ELSE IF(CARD(IPOS:IPOS).NE.';') THEN
            IMERR2=IPOS
            CALL FESTOP(39002)
          END IF
          IPT=IPOS+1
        ELSE
          IF(U5END.GT.0) THEN
            GO TO 60
          ELSE
            GO TO 4
          END IF
        END IF
      END IF
    3 CONTINUE
      IF(U5END.GT.0)GO TO 60
      LTEMP=REFRSH(IPT)
    4 CONTINUE
      IF(U5END.GT.0)GO TO 60
      CALL KYFIND(IKEY,IPT)
      IF(IKEY.EQ.-1) THEN
        CALL CRDPRN(1)
        GO TO 4
      END IF
      IF(IKEY.EQ.36) THEN
        CALL CRDPRN(1)
        CALL OPTNTR(NOPTN,INDX,IVALUE,OPTNW,IPT,IPOS,IOPTN)
        IF(IPT.EQ.1) THEN
          GO TO 4
        ELSE
          GO TO 3
        END IF
      END IF
   60 CONTINUE
      CALL PREAMB
      IF(IOPTN(1).NE.2) THEN
        WRITE(U6,102)LSTVPL(1:60)
        WRITE(U6,103)NVTOT
        IF(NVREG.GT.0)WRITE(U6,104)NVREG
        IF(NCLASS.GT.0)WRITE(U6,105)NCLASS
        IF(NVARID.GT.0)WRITE(U6,106)NVARID
        IF(NBY.GT.0)WRITE(U6,107)NBY
        WRITE(U6,120)NCLBLK
        IF(NWGT.GT.0) THEN
          WRITE(U6,108)
        ELSE
          WRITE(U6,109)
        END IF
        DO 20 ICLBLK=1,NCLBLK
        WRITE(U6,121)ICLBLK,BLXSIZ(ICLBLK)
        WRITE(U6,110)
        IF(BLTYPE(ICLBLK).EQ.1) THEN
          IF(NWGT.GT.0) THEN
            WRITE(U6,122)ICLBLK,BLXSTR(ICLBLK)
          ELSE
            WRITE(U6,123)ICLBLK,BLXSTR(ICLBLK)
          END IF
        END IF
        IF(BLVSIZ(ICLBLK).GT.0) THEN
          DO 10 I=BLVSTR(ICLBLK),BLVSTR(ICLBLK)+BLVSIZ(ICLBLK)-1
          IF(MTYPE(I).LE.5) THEN
            J=MTYPE(I)
          ELSE IF(MTYPE(I).EQ.8) THEN
            J=6
          ELSE IF(MTYPE(I).EQ.9) THEN
            J=7
          ELSE IF(MTYPE(I).EQ.11) THEN
            J=10
          ELSE IF(MTYPE(I).EQ.13.OR.MTYPE(I).EQ.19) THEN
            J=11
          END IF
          WRITE(U6,111)I,VNMIN(I),LABEL(I),CTYPE(J),MSIZE(I),VMAPL(I)
          IF(MTYPE(I).EQ.8.OR.MTYPE(I).EQ.9.OR.MTYPE(I).EQ.19) THEN
            L=LPOINT(I)
            K=CDMPNT(I)
            N=CROSSD(K)
            NM=CROSSD(K+N+1)
            DO 6 J=1,N
            WRITE(U6,113)VTEMP(NM),LEVEL(L)
            NM=NM+1
            L=L+1
            IF(CROSSD(K+J).GT.0) THEN
              DO 5 JJ=1,CROSSD(K+J)
              WRITE(U6,112)JJ,LEVEL(L)
              L=L+1
    5         CONTINUE
            END IF
    6       CONTINUE
          ELSE IF(MTYPE(I).EQ.3.OR.MTYPE(I).EQ.13) THEN
            L=LPOINT(I)
            DO 8 J=1,MSIZE(I)
            WRITE(U6,112)J,LEVEL(L)
            L=L+1
    8       CONTINUE
          END IF
   10     CONTINUE
        END IF
        IF(BLNCLS(ICLBLK).GT.0) THEN
          DO 18 II=1,BLNCLS(ICLBLK)
          I=CLPNT(BLCPNT(ICLBLK)+II-1)
          ICSIZE=MSIZE(I)
          IF(CLTYPE(BLCPNT(ICLBLK)+II-1).EQ.0)ICSIZE=ICSIZE+1
          WRITE(U6,111)I,VNMIN(I),LABEL(I),CTYPE(4),ICSIZE
          L=LPOINT(I)
          IF(CLTYPE(BLCPNT(ICLBLK)+II-1).EQ.0)WRITE(U6,126)
          DO 12 J=1,MSIZE(I)
          WRITE(U6,112)J,LEVEL(L+J-1)
   12     CONTINUE
   18     CONTINUE
        END IF
   20   CONTINUE
        WRITE(U6,125)
        DO 30 I=NVREG+NCLASS+1,NVTOT
        IF(MTYPE(I).EQ.5) THEN
          WRITE(U6,111)I,VNMIN(I),LABEL(I),CTYPE(5),MSIZE(I)
        ELSE IF(MTYPE(I).EQ.6) THEN
          WRITE(U6,111)I,VNMIN(I),LABEL(I),CTYPE(5)
        ELSE IF((VFTYPE.GE.5.AND.VFTYPE.LE.12.AND.
     .    I.LE.NVREG+NCLASS+NVARID-1).OR.
     .    ((VFTYPE.LE.4.OR.VFTYPE.GE.13).AND.I.LE.NVREG+NCLASS+NVARID))
     .      THEN
          WRITE(U6,111)I,VNMIN(I),LABEL(I),CTYPE(8)
        ELSE IF(I.EQ.NVTOT.AND.NWGT.EQ.1) THEN
          WRITE(U6,111)I,VNMIN(I),LABEL(I),CTYPE(9)
        END IF
   30   CONTINUE
        IF(NBY.GE.1) THEN
          IF(NBY.GT.1) THEN
            WRITE(U6,114)
          ELSE
            WRITE(U6,119)
          END IF
          K=SDBYID-1
          DO 35 I=1,NBYGRP
          WRITE(U6,115)(DX(K+J),J=1,NBY)
          K=K+NBY
  35      CONTINUE
        END IF
      END IF
      IF(NRPTOT.GT.0) THEN
        IF(IOPTN(1).NE.2) THEN
          WRITE(U6,116)NRPTOT
          WRITE(U6,117)
        END IF
        RVALUE(1)=DX(SDCOEF)
        K=1
        L=1
        IF(NRPTOT.GT.1) THEN
          DO 40 I=1,NRPTOT-1
          IF(DABS(DX(SDCOEF+I)-RVALUE(L)).LT..1D-12) THEN
            K=K+1
          ELSE
            IF(K.EQ.1) THEN
              RMULT(L)='      '
            ELSE
              WRITE(RMULT(L),124)K
            END IF
            K=1
            L=L+1
            IF(L.GT.4) THEN
              IF(IOPTN(1).NE.2) THEN
                WRITE(U6,118)(RMULT(J),RVALUE(J),J=1,4)
              END IF
              IF(IFILEF(2).EQ.1) THEN
                WRITE(11,118)(RMULT(J),RVALUE(J),J=1,4)
              END IF
              L=1
            END IF
            RVALUE(L)=DX(SDCOEF+I)
          END IF
   40     CONTINUE
        END IF
        IF(K.EQ.1) THEN
          RMULT(L)='      '
        ELSE
          WRITE(RMULT(L),124)K
        END IF
        IF(IOPTN(1).NE.2) THEN
          WRITE(U6,118)(RMULT(J),RVALUE(J),J=1,L)
        END IF
        IF(IFILEF(2).EQ.1) THEN
          WRITE(11,118)(RMULT(J),RVALUE(J),J=1,L)
        END IF
      END IF
      CLOSE(12)
      RETURN
      END
C
      SUBROUTINE EXPORT
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MAXSUB=500,MAXSBL=2000)
      PARAMETER (MAXFMT=20)
      PARAMETER (NOPTN=3)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
      INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL),
     .   U5LCSW
      COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW
C
      INTEGER ITYPEF(3),IFILEF(3)
C
C
      LOGICAL REFRSH,LTEMP,ENDFLE
      EXTERNAL REFRSH
      CHARACTER*12 OPTNW(NOPTN)
      INTEGER INDX(NOPTN),IVALUE(NOPTN),IOPTN(2)
      DATA OPTNW /    'PRINT       ','NOPRINT     ','NREP        '/
      DATA INDX/1,1,2/
      DATA IVALUE/1,2,0/
  102 FORMAT(10I8)
  103 FORMAT(3D24.16)
  104 FORMAT(//,' IVERSN',/,1X,I7,//,'   NVTOT  NVREG NCLASS NVARID    N
     .BY   NWGT   TYPE VROPTN NIDTOT  TSIZE NCLBLK',/,1X,11I7,/,'  NCLBA
     .R',/,1X,I7)
  105 FORMAT(/,'  BLTYPE BLXSTR BLXINC BLXSIZ BLVSTR BLVSIZ BLNCLS BLCPN
     .T',(/,1X,8I7))
  106 FORMAT(/,' Class type flags (margins)',(/,1X,10I7))
  107 FORMAT(/,' Class pointers',(/,1X,10I7))
  108 FORMAT(/,' Variable types',(/,1X,10I7))
  109 FORMAT(/,' Variable sizes',(/,1X,10I7))
  110 FORMAT(/,' Variable locations',(/,1X,10I7))
  111 FORMAT(/,' Crossed dimensions',/,1X,I7)
  112 FORMAT(/,1X,10I7)
  113 FORMAT(/,' Variable names and labels')
  114 FORMAT(A12,A24)
  115 FORMAT(1X,A12,1X,A24)
  116 FORMAT(/,' Level labels',/,1X,I7)
  117 FORMAT(A24)
  118 FORMAT(1X,A24)
  119 FORMAT(/,' Variable names in crossings',/,1X,I7)
  120 FORMAT(/,' BY groups',/,1X,I7)
  121 FORMAT(/,' Number of replicates',/,1X,I7)
  122 FORMAT(/,' Coefficients',(/,10F7.3))
  124 FORMAT(1X,(/,5F14.4))
  201 FORMAT(' ERROR IN SPECIFICATION')
      ITYPEF(1)=2
      ITYPEF(2)=1
      ITYPEF(3)=0
      CALL KYFIND(IKEY,IPT)
      CALL CRDPRN(3)
      CALL FNREAD(IPT,ITYPEF,IFILEF,1,IPOSSC)
      IF(IMERR1.GT.0) THEN
        CALL FSTOP
      END IF
      IF(IFILEF(2).EQ.0) THEN
        IOPTN(1)=1
      ELSE
        IOPTN(1)=2
      END IF
      IOPTN(2)=-2
      IF(IPOSSC.GT.0) THEN
        U5LCSW=1
C                               ! Reset U5LCSW for REFRSH, etc.
        IPOS=IPOSSC+1
        CALL NBFND2(IPOS,IPT)
        IF(IPT.GT.0) THEN
          CALL KYCHK2(IPT,IGROUP,IKEY,IPOS)
          IF(IGROUP.NE.2.OR.IKEY.NE.11) THEN
            IMERR2=IPT
            CALL FESTOP(39011)
          END IF
          IPT=IPOS
          CALL OPTNTR(NOPTN,INDX,IVALUE,OPTNW,IPT,IPOS,IOPTN)
          IF(IPOS.EQ.0) THEN
            CALL FESTOP(39012)
          ELSE IF(CARD(IPOS:IPOS).NE.';') THEN
            IMERR2=IPOS
            CALL FESTOP(39012)
          END IF
          IPT=IPOS+1
        ELSE
          IF(U5END.GT.0) THEN
            GO TO 60
          ELSE
            GO TO 4
          END IF
        END IF
      END IF
    3 CONTINUE
      IF(U5END.GT.0)GO TO 60
      LTEMP=REFRSH(IPT)
    4 CONTINUE
      IF(U5END.GT.0)GO TO 60
      CALL KYFIND(IKEY,IPT)
      IF(IKEY.EQ.-1) THEN
        CALL CRDPRN(1)
        GO TO 4
      END IF
      IF(IKEY.EQ.36) THEN
        CALL CRDPRN(1)
        CALL OPTNTR(NOPTN,INDX,IVALUE,OPTNW,IPT,IPOS,IOPTN)
        IF(IPT.EQ.1) THEN
          GO TO 4
        ELSE
          GO TO 3
        END IF
      END IF
   60 CONTINUE
      IF(IOPTN(1).NE.1.AND.IFILEF(2).EQ.0)GO TO 94
      READ(12)IVERSN
      IF(IVERSN.NE.9004.AND.IVERSN.NE.9203)STOP
      READ(12)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE,
     . VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR
      CALL RCHECK(2,NVTOT,0)
      NID=NVARID+NBY
      IF(IVERSN.EQ.9004)NIDTOT=NID
      IF(IFILEF(2).NE.0) THEN
        WRITE(11,102)IVERSN
        WRITE(11,102)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE,
     .    VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR
      END IF
      IF(IOPTN(1).EQ.1) THEN
        WRITE(U6,104)IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,
     .    VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR
      END IF
C
C  NVTOT   - total number of variables on file
C  NVREG  - number of variables, excluding class, variance id's,
C            BY variables, and weight variable
C  NCLASS  - total number of class variables
C  NVARID   - number of variance id's, excluding BY variables
C  NBY     - number of BY variables
C  NWGT    - 0 or 1 indicating unweighted vs. weighted analysis
C  VFTYPE    - type of input used to create the file
C  VROPTN  - variance option
C  TSIZE   - total size of matrix
C  NCLBLK  - total number of class blocks
C  NCLBAR  - total size of class block information arrays
C
C VFTYPE = 3  Weighted obs. with cluster/replicate number
C         4  Unweighted  "
C         5  Replicate weights
C         6  Unweighted initial obs. followed by replicate weights
C         7  Replicate factors multiplying initial weight
C         8  Replicate factors of unweighted initial obs ( = VFTYPE 6)
C        11  Replicate factors multiplying initial weight, including
C            factor for replicate 0, overall estimate
C        12  Unweighted initial obs  "  (= VFTYPE 5)
C        13  Weighted obs. with cluster code
C        14  Unweighted "
C        15  Weighted obs. Stratum no. cluster code
C        16  Unweighted "
C        17  Wtd.          Stratum code, cluster code
C        18  Unwtd      "
C        21  Wtd.      Stratum no. 2nd stage no, cluster code
C        22  Unwtd.     "
C        23  Wtd.      Stratum no. 2nd stage cd, cluster code
C        24  Unwtd.     "
C        25  Wtd.      Stratum code  2nd stage no. cluster code
C        26  Unwtd      "
C        27  Wtd.      Stratum code  2nd stage cd, cluster code
C        28  Unwtd.     "
C        29  Wtd       2nd stage number cluster code
C        30  Unwtd.     "
C        31  Wtd       2nd stage code  cluster code
C        32  Unwtd      "
C        33  Wtd       Replicate number governed by stratum counts
C        34  Unwtd      "
C        35  Wtd       Rep numb govrned by stratum and 2nd stage counts
C        36  Unwtd      "
C        37  Wtd       Rep number governed by 2nd stage counts
C        38  Unwtd      "
C
      CALL RCHECK(8,NCLBLK,0)
      CALL RCHECK(9,NCLBAR,0)
      DO 11 I=1,NCLBLK
      READ(12)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I),
     . BLVSIZ(I),BLNCLS(I),BLCPNT(I)
      IF(IFILEF(2).NE.0) THEN
        WRITE(11,102)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I),
     .    BLVSIZ(I),BLNCLS(I),BLCPNT(I)
      END IF
   11 CONTINUE
      IF(IOPTN(1).EQ.1) THEN
        WRITE(U6,105)(BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I),
     .    BLVSIZ(I),BLNCLS(I),BLCPNT(I),I=1,NCLBLK)
      END IF
      IF(NCLBAR.GT.0) THEN
        CALL INTIN(12,CLTYPE,NCLBAR,ENDFLE)
        CALL INTIN(12,CLPNT,NCLBAR,ENDFLE)
        IF(IFILEF(2).NE.0) THEN
          WRITE(11,102)(CLTYPE(I),I=1,NCLBAR)
          WRITE(11,102)(CLPNT(I),I=1,NCLBAR)
        END IF
        IF(IOPTN(1).EQ.1) THEN
          WRITE(U6,106)(CLTYPE(I),I=1,NCLBAR)
          WRITE(U6,107)(CLPNT(I),I=1,NCLBAR)
        END IF
      END IF
C
C  BLTYPE  - 1 or 0 indicating row of (weighted) n vs. no row
C  BLXSTR  - pointer to first cell of incoming data in X matrix
C  BLXINC  - length of the X matrix for a single combination
C            of the class variables in the block
C  BLXSIZ  - total size of block data in X matrix (integer multiple
C            of BLXINC)
C  BLVSTR  - pointer to first variable
C  BLVSIZ  - number of variables in block
C  BLNCLS  - number of class variables in block
C  BLCPNT  - pointer for class information
C  CLTYPE  - type of class in array
C  CLPNT   - pointer to class variables
C
      IF(NVTOT.GT.0) THEN
        CALL INTIN(12,MTYPE,NVTOT,ENDFLE)
        CALL INTIN(12,MSIZE,NVTOT,ENDFLE)
        IF(IFILEF(2).NE.0) THEN
          WRITE(11,102)(MTYPE(I),I=1,NVTOT)
          WRITE(11,102)(MSIZE(I),I=1,NVTOT)
        END IF
        IF(IOPTN(1).EQ.1) THEN
          WRITE(U6,108)(MTYPE(I),I=1,NVTOT)
          WRITE(U6,109)(MSIZE(I),I=1,NVTOT)
        END IF
      END IF
C
C  Variable types are read into MTYPE
C
C  Contents of MTYPE
C     1  =  real variable (total)
C     2  =  real variable with missing checks
C     3  =  categorical variable
C     4  =  class variable, known dimension
C     5  =  by variable, known dimension
C     6  =  by variable, unknown dimension
C     7  =  select transformation (not variable type)
C     8  =  cross variable, real value
C     9  =  cross variable, categorical
C    11  =  derived variable
C    13  =  crossed derived variable, single dimension
C    19  =  crossed derived variable
C
C
C  Sizes are read into MSIZE
C
      IF(NVREG.GT.0) THEN
        CALL INTIN(12,VMAPL,NVREG,ENDFLE)
        IF(IFILEF(2).NE.0) THEN
          WRITE(11,102)(VMAPL(I),I=1,NVREG)
        END IF
        IF(IOPTN(1).EQ.1) THEN
          WRITE(U6,110)(VMAPL(I),I=1,NVREG)
        END IF
      END IF
C
C  VMAPL contains pointers to the first NVREG variables
C
      READ(12)NCRSSD
      IF(IFILEF(2).NE.0) THEN
        WRITE(11,102)NCRSSD
      END IF
      IF(IOPTN(1).EQ.1) THEN
        WRITE(U6,111)NCRSSD
      END IF
      CALL RCHECK(10,NCRSSD,0)
      IF(NCRSSD.GT.0) THEN
        CALL INTIN(12,CROSSD,NCRSSD,ENDFLE)
        IF(IFILEF(2).NE.0) THEN
          WRITE(11,102)(CROSSD(I),I=1,NCRSSD)
        END IF
        IF(IOPTN(1).EQ.1) THEN
          WRITE(U6,112)(CROSSD(I),I=1,NCRSSD)
        END IF
      END IF
      ILC=1
C
C  Create an array of pointers, CDMPNT, from the variables to
C  the starting entries in CROSSD
C
      DO 13 I=1,NVTOT
      J=MTYPE(I)
      IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN
        CDMPNT(I)=ILC
        ILC=CROSSD(ILC)+ILC+2
      ELSE
        CDMPNT(I)=0
      END IF
   13 CONTINUE
      IF(NCRSSD+1.NE.ILC) THEN
        WRITE(U6,201)
        GO TO 95
      END IF
      ILC=0
C
C  Read variable names and labels, and create an array of pointers,
C  LPOINT, to labels for the levels of the variables
C
      IF(IOPTN(1).EQ.1) THEN
        WRITE(U6,113)
      END IF
      DO 16 I=1,NVTOT
      READ(12)VNAME(I),LABEL(I)
      IF(IFILEF(2).NE.0) THEN
        WRITE(11,114)VNAME(I),LABEL(I)
      END IF
      IF(IOPTN(1).EQ.1) THEN
        WRITE(U6,115)VNAME(I),LABEL(I)
      END IF
      J=MTYPE(I)
      IF(J.EQ.3.OR.J.EQ.4.OR.J.EQ.5.OR.J.EQ.13) THEN
        LPOINT(I)=ILC+1
        ILC=ILC+MSIZE(I)
      ELSE IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN
        LPOINT(I)=ILC+1
        K=CDMPNT(I)
        L=CROSSD(K)
        DO 14 M=1,L
        K=K+1
        ILC=ILC+CROSSD(K)+1
   14   CONTINUE
      ELSE
        LPOINT(I)=0
      END IF
   16 CONTINUE
C
C  Read in labels for the levels
C
      READ(12)NCRVL
      CALL RCHECK(7,NCRVL,0)
      IF(IFILEF(2).NE.0) THEN
        WRITE(11,102)NCRVL
      END IF
      IF(IOPTN(1).EQ.1) THEN
        WRITE(U6,116)NCRVL
      END IF
      IF(ILC.NE.NCRVL) THEN
        WRITE(U6,201)
        GO TO 95
      END IF
      IF(ILC.GT.0) THEN
        DO 20 I=1,ILC
        READ(12)LEVEL(I)
        IF(IFILEF(2).NE.0) THEN
          WRITE(11,117)LEVEL(I)
        END IF
        IF(IOPTN(1).EQ.1) THEN
          WRITE(U6,118)LEVEL(I)
        END IF
   20   CONTINUE
      END IF
      READ(12)ILC
      IF(IFILEF(2).NE.0) THEN
        WRITE(11,102)ILC
      END IF
      IF(IOPTN(1).EQ.1) THEN
        WRITE(U6,119)ILC
      END IF
C
C  Read in variable names for crossed variables
C
      CALL RCHECK(13,ILC,0)
      SVTEMP=ILC+1
      IF(ILC.GT.0) THEN
        DO 22 I=1,ILC
        READ(12)VTEMP(I)
        IF(IFILEF(2).NE.0) THEN
          WRITE(11,114)VTEMP(I)
        END IF
        IF(IOPTN(1).EQ.1) THEN
          WRITE(U6,115)VTEMP(I)
        END IF
   22   CONTINUE
      END IF
      IF(NBY.GE.1) THEN
        READ(12)NBYGRP
        IF(IFILEF(2).NE.0) THEN
          WRITE(11,102)NBYGRP
        END IF
        IF(IOPTN(1).EQ.1) THEN
          WRITE(U6,120)NBYGRP
        END IF
        SDBYID=NXPTD
        K=NBYGRP*NBY
        CALL ROOMD(K)
        K=SDBYID-1
        DO 27 I=1,NBYGRP
        READ(12)(DX(K+J),J=1,NBY)
        IF(IFILEF(2).NE.0) THEN
          WRITE(11,103)(DX(K+J),J=1,NBY)
        END IF
        IF(IOPTN(1).EQ.1) THEN
          WRITE(U6,124)(DX(K+J),J=1,NBY)
        END IF
        K=K+NBY
   27   CONTINUE
      ELSE
        SDBYID=0
        NBYGRP=1
      END IF
      READ(12)NRPTOT
      IF(IFILEF(2).NE.0) THEN
        WRITE(11,102)NRPTOT
      END IF
      IF(IOPTN(1).EQ.1) THEN
        WRITE(U6,121)NRPTOT
      END IF
      IF(NRPTOT.GT.0) THEN
        SDCOEF=NXPTD
        CALL ROOMD(NRPTOT)
        CALL UNFIN(12,DX(SDCOEF),NRPTOT,ENDFLE)
        K=SDCOEF+NRPTOT-1
        IF(IFILEF(2).NE.0) THEN
          WRITE(11,103)(DX(I),I=SDCOEF,K)
        END IF
        IF(IOPTN(1).EQ.1) THEN
          WRITE(U6,122)(DX(I),I=SDCOEF,K)
        END IF
      ELSE
        SDCOEF=0
      END IF
      IF(IOPTN(2).LE.-2) THEN
        IOPTN(2)=NRPTOT
      END IF
      K1=NXPTD
      K2=NXPTD+NIDTOT
      I=NIDTOT+TSIZE
      CALL ROOMD(I)
      DO 50 IBY=1,NBYGRP
      DO 40 IREP=0,NRPTOT
      READ(12)(DX(K1+I-1),I=1,NIDTOT)
      CALL UNFIN(12,DX(K2),TSIZE,ENDFLE)
      IF(IFILEF(2).NE.0) THEN
        WRITE(11,103)(DX(K1+I-1),I=1,NIDTOT)
        WRITE(11,103)(DX(K2+I-1),I=1,TSIZE)
      END IF
      IF(IOPTN(1).EQ.1) THEN
        IF(IREP.LE.IOPTN(2)) THEN
          WRITE(U6,124)(DX(K1+I-1),I=1,NIDTOT)
          WRITE(U6,124)(DX(K2+I-1),I=1,TSIZE)
        ELSE
          IF(IBY.EQ.NBYGRP)GO TO 50
        END IF
      END IF
   40 CONTINUE
   50 CONTINUE
   94 CONTINUE
      CLOSE(12)
      IF(IFILEF(2).NE.0) THEN
        CLOSE(11)
      END IF
      RETURN
   95 CONTINUE
      WRITE(U6,201)
      CALL FSTOP
      END
      SUBROUTINE IMPORT
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MAXSUB=500,MAXSBL=2000)
      PARAMETER (MAXFMT=20)
      PARAMETER (NOPTN=3)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
      INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL),
     .   U5LCSW
      COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW
C
      INTEGER ITYPEF(3),IFILEF(3)
C
      LOGICAL REFRSH,LTEMP
      EXTERNAL REFRSH
  102 FORMAT(10I8)
  103 FORMAT(3D24.16)
  114 FORMAT(A12,A24)
  117 FORMAT(A24)
  200 FORMAT(' NO VPLX FILE')
  201 FORMAT(' ERROR IN SPECIFICATION')
      ITYPEF(1)=1
      ITYPEF(2)=2
      ITYPEF(3)=0
      CALL KYFIND(IKEY,IPT)
      CALL CRDPRN(3)
      CALL FNREAD(IPT,ITYPEF,IFILEF,1,IPOSSC)
      IF(IMERR1.GT.0) THEN
        CALL FSTOP
      END IF
      IF(IFILEF(2).EQ.0) THEN
        WRITE(U6,200)
        CALL FSTOP
      END IF
      IF(IPOSSC.GT.0) THEN
        U5LCSW=1
C                            !  Reset U5LCSW used by REFRSH, etc.
      END IF
    3 CONTINUE
      IF(U5END.GT.0)GO TO 60
      LTEMP=REFRSH(IPT)
    4 CONTINUE
      IF(U5END.GT.0)GO TO 60
      CALL KYFIND(IKEY,IPT)
      IF(IKEY.EQ.-1) THEN
        CALL CRDPRN(1)
        GO TO 4
      END IF
   60 CONTINUE
      READ(12,102)IVERSN
      IF(IVERSN.NE.9203)CALL FSTOP
      READ(12,102)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE,
     .    VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR
      WRITE(11)IVERSN
      WRITE(11)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE,
     . VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR
      CALL RCHECK(2,NVTOT,0)
      NID=NVARID+NBY
C
C  NVTOT   - total number of variables on file
C  NVREG  - number of variables, excluding class, variance id's,
C            BY variables, and weight variable
C  NCLASS  - total number of class variables
C  NVARID   - number of variance id's, excluding BY variables
C  NBY     - number of BY variables
C  NWGT    - 0 or 1 indicating unweighted vs. weighted analysis
C  VFTYPE    - type of input used to create the file
C  VROPTN  - variance option
C  TSIZE   - total size of matrix
C  NCLBLK  - total number of class blocks
C  NCLBAR  - total size of class block information arrays
C
C VFTYPE = 3  Weighted obs. with cluster/replicate number
C         4  Unweighted  "
C         5  Replicate weights
C         6  Unweighted initial obs. followed by replicate weights
C         7  Replicate factors multiplying initial weight
C         8  Replicate factors of unweighted initial obs ( = VFTYPE 6)
C        11  Replicate factors multiplying initial weight, including
C            factor for replicate 0, overall estimate
C        12  Unweighted initial obs  "  (= VFTYPE 5)
C        13  Weighted obs. with cluster code
C        14  Unweighted "
C        15  Weighted obs. Stratum no. cluster code
C        16  Unweighted "
C        17  Wtd.          Stratum code, cluster code
C        18  Unwtd      "
C        21  Wtd.      Stratum no. 2nd stage no, cluster code
C        22  Unwtd.     "
C        23  Wtd.      Stratum no. 2nd stage cd, cluster code
C        24  Unwtd.     "
C        25  Wtd.      Stratum code  2nd stage no. cluster code
C        26  Unwtd      "
C        27  Wtd.      Stratum code  2nd stage cd, cluster code
C        28  Unwtd.     "
C        29  Wtd       2nd stage number cluster code
C        30  Unwtd.     "
C        31  Wtd       2nd stage code  cluster code
C        32  Unwtd      "
C        33  Wtd       Replicate number governed by stratum counts
C        34  Unwtd      "
C        35  Wtd       Rep numb govrned by stratum and 2nd stage counts
C        36  Unwtd      "
C        37  Wtd       Rep number governed by 2nd stage counts
C        38  Unwtd      "
C
      CALL RCHECK(8,NCLBLK,0)
      CALL RCHECK(9,NCLBAR,0)
      DO 11 I=1,NCLBLK
      READ(12,102)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I),
     .  BLVSIZ(I),BLNCLS(I),BLCPNT(I)
      WRITE(11)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I),
     .  BLVSIZ(I),BLNCLS(I),BLCPNT(I)
   11 CONTINUE
      IF(NCLBAR.GT.0) THEN
        READ(12,102)(CLTYPE(I),I=1,NCLBAR)
        READ(12,102)(CLPNT(I),I=1,NCLBAR)
        CALL INTOUT(11,CLTYPE,NCLBAR)
        CALL INTOUT(11,CLPNT,NCLBAR)
      END IF
C
C  BLTYPE  - 1 or 0 indicating row of (weighted) n vs. no row
C  BLXSTR  - pointer to first cell of incoming data in X matrix
C  BLXINC  - length of the X matrix for a single combination
C            of the class variables in the block
C  BLXSIZ  - total size of block data in X matrix (integer multiple
C            of BLXINC)
C  BLVSTR  - pointer to first variable
C  BLVSIZ  - number of variables in block
C  BLNCLS  - number of class variables in block
C  BLCPNT  - pointer for class information
C  CLTYPE  - type of class in array
C  CLPNT   - pointer to class variables
C
      IF(NVTOT.GT.0) THEN
        READ(12,102)(MTYPE(I),I=1,NVTOT)
        READ(12,102)(MSIZE(I),I=1,NVTOT)
        CALL INTOUT(11,MTYPE,NVTOT)
        CALL INTOUT(11,MSIZE,NVTOT)
      END IF
C
C  Variable types are read into MTYPE
C
C  Contents of MTYPE
C     1  =  real variable (total)
C     2  =  real variable with missing checks
C     3  =  categorical variable
C     4  =  class variable, known dimension
C     5  =  by variable, known dimension
C     6  =  by variable, unknown dimension
C     7  =  select transformation (not variable type)
C     8  =  cross variable, real value
C     9  =  cross variable, categorical
C    11  =  derived variable
C    13  =  crossed derived variable, single dimension
C    19  =  crossed derived variable
C
C
C  Sizes are read into MSIZE
C
      IF(NVREG.GT.0) THEN
        READ(12,102)(VMAPL(I),I=1,NVREG)
        CALL INTOUT(11,VMAPL,NVREG)
      END IF
C
C  VMAPL contains pointers to the first NVREG variables
C
      READ(12,102)NCRSSD
      WRITE(11)NCRSSD
      CALL RCHECK(10,NCRSSD,0)
      IF(NCRSSD.GT.0) THEN
        READ(12,102)(CROSSD(I),I=1,NCRSSD)
        CALL INTOUT(11,CROSSD,NCRSSD)
      END IF
      ILC=1
C
C  Create an array of pointers, CDMPNT, from the variables to
C  the starting entries in CROSSD
C
      DO 13 I=1,NVTOT
      J=MTYPE(I)
      IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN
        CDMPNT(I)=ILC
        ILC=CROSSD(ILC)+ILC+2
      ELSE
        CDMPNT(I)=0
      END IF
   13 CONTINUE
      IF(NCRSSD+1.NE.ILC) THEN
        WRITE(U6,201)
        GO TO 95
      END IF
      ILC=0
C
C  Read variable names and labels, and create an array of pointers,
C  LPOINT, to labels for the levels of the variables
C
      DO 16 I=1,NVTOT
      READ(12,114)VNAME(I),LABEL(I)
      WRITE(11)VNAME(I),LABEL(I)
      J=MTYPE(I)
      IF(J.EQ.3.OR.J.EQ.4.OR.J.EQ.5.OR.J.EQ.13) THEN
        LPOINT(I)=ILC+1
        ILC=ILC+MSIZE(I)
      ELSE IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN
        LPOINT(I)=ILC+1
        K=CDMPNT(I)
        L=CROSSD(K)
        DO 14 M=1,L
        K=K+1
        ILC=ILC+CROSSD(K)+1
   14   CONTINUE
      ELSE
        LPOINT(I)=0
      END IF
   16 CONTINUE
C
C  Read in labels for the levels
C
      READ(12,102)NCRVL
      WRITE(11)NCRVL
      CALL RCHECK(7,NCRVL,0)
      IF(ILC.NE.NCRVL) THEN
        WRITE(U6,201)
        GO TO 95
      END IF
      IF(ILC.GT.0) THEN
        DO 20 I=1,ILC
        READ(12,117)LEVEL(I)
        WRITE(11)LEVEL(I)
   20   CONTINUE
      END IF
      READ(12,102)ILC
      WRITE(11)ILC
C
C  Read in variable names for crossed variables
C
      CALL RCHECK(13,ILC,0)
      SVTEMP=ILC+1
      IF(ILC.GT.0) THEN
        DO 22 I=1,ILC
        READ(12,114)VTEMP(I)
        WRITE(11)VTEMP(I)
   22   CONTINUE
      END IF
      IF(NBY.GE.1) THEN
        READ(12,102)NBYGRP
        WRITE(11)NBYGRP
        SDBYID=NXPTD
        K=NBYGRP*NBY
        CALL ROOMD(K)
        K=SDBYID-1
        DO 27 I=1,NBYGRP
        READ(12,103)(DX(K+J),J=1,NBY)
        WRITE(11)(DX(K+J),J=1,NBY)
        K=K+NBY
   27   CONTINUE
      ELSE
        SDBYID=0
        NBYGRP=1
      END IF
      READ(12,102)NRPTOT
      WRITE(11)NRPTOT
      IF(NRPTOT.GT.0) THEN
        SDCOEF=NXPTD
        CALL ROOMD(NRPTOT)
        K=SDCOEF+NRPTOT-1
        READ(12,103)(DX(I),I=SDCOEF,K)
        CALL UNFOUT(11,DX(SDCOEF),NRPTOT)
      ELSE
        SDCOEF=0
      END IF
      K1=NXPTD
      K2=NXPTD+NIDTOT
      I=NIDTOT+TSIZE
      CALL ROOMD(I)
      DO 50 IBY=1,NBYGRP
      DO 40 IREP=0,NRPTOT
      READ(12,103)(DX(K1+I-1),I=1,NIDTOT)
      READ(12,103)(DX(K2+I-1),I=1,TSIZE)
      WRITE(11)(DX(K1+I-1),I=1,NIDTOT)
      CALL UNFOUT(11,DX(K2),TSIZE)
   40 CONTINUE
   50 CONTINUE
   94 CONTINUE
      CLOSE(11)
      CLOSE(12)
      RETURN
   95 CONTINUE
      WRITE(U6,201)
      CALL FSTOP
      END
C
C  End of CN.FOR
C
      SUBROUTINE JACKKN
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MAXSUB=500,MAXSBL=2000)
      PARAMETER (MAXFMT=20)
C
      PARAMETER (MTRANS=1500,MRANGS=20)
      PARAMETER (MTRSZI=MSIZEI+6*MRANGE-6*MRANGS+2*MRNSET+MRECOD)
      PARAMETER (IXFLLD=32+3*MAXIDS)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
C
C       NVARID  (NID1)
C
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL),
     .   U5LCSW
      COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW
C
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      LOGICAL REFRSH,ALPCHK,CLMTCH
      EXTERNAL REFRSH,ALPCHK,CLMTCH
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
      INTEGER ITYPEF(3),IFILEF(3)
      LOGICAL LTEMP,ENDFLE
      INTEGER SDTOT,SDREP,SDCONS
C
      DOUBLE PRECISION MISSNG,T
      DATA MISSNG/-98765.432109D0/
C
  200 FORMAT(' INCOMPLETE FILE SPECIFICATION')
C
      ITYPEF(1)=2
      ITYPEF(2)=2
      ITYPEF(3)=0
      CALL CRDPRN(3)
      CALL KYFIND(IKEY,IPT)
      CALL FNREAD(IPT,ITYPEF,IFILEF,1,IPOSSC)
      IF(IMERR1.GT.0) THEN
        CALL FSTOP
      END IF
      IF(IFILEF(2).EQ.0) GO TO 95
      ISOPEN=0
      CALL PREAMB
      IF(IVERSN.EQ.9004) THEN
        NIDOUT=NID
      ELSE
        NIDOUT=NIDTOT
      END IF
      IF(IPOSSC.GT.0) THEN
        U5LCSW=1
C                            !  Reset U5LCSW used by REFRSH, etc.
      END IF
    1 CONTINUE
      LTEMP=REFRSH(IPT)
    2 CONTINUE
      IF(U5END.GT.0)GO TO 7
      CALL KYFIND(IKEY,IPT)
      IF(IKEY.EQ.-1) THEN
        CALL CRDPRN(1)
        GO TO 2
      END IF
    7 CONTINUE
      IF(ISOPEN.EQ.0.AND.NBY.GE.1) THEN
        I=13
        CALL SCOPEN(I)
      END IF
      WRITE(11)IVERSN
      WRITE(11)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE,
     . VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR
      DO 11 I=1,NCLBLK
      WRITE(11)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I),
     . BLVSIZ(I),BLNCLS(I),BLCPNT(I)
   11 CONTINUE
      IF(NCLBAR.GT.0) THEN
        CALL INTOUT(11,CLTYPE,NCLBAR)
        CALL INTOUT(11,CLPNT,NCLBAR)
      END IF
      IF(NVTOT.GT.0) THEN
        CALL INTOUT(11,MTYPE,NVTOT)
        CALL INTOUT(11,MSIZE,NVTOT)
      END IF
      IF(NVREG.GT.0)CALL INTOUT(11,VMAPL,NVREG)
      WRITE(11)NCRSSD
      IF(NCRSSD.GT.0)CALL INTOUT(11,CROSSD,NCRSSD)
      DO 12 I=1,NVTOT
      WRITE(11)VNAME(I),LABEL(I)
   12 CONTINUE
      WRITE(11)NCRVL
      IF(NCRVL.GT.0) THEN
        DO 13 I=1,NCRVL
        WRITE(11)LEVEL(I)
   13   CONTINUE
      END IF
      ILC=SVTEMP-1
      WRITE(11)ILC
      DO 14 I=1,ILC
      WRITE(11)VTEMP(I)
   14 CONTINUE
      IF(NBY.GE.1) THEN
        WRITE(11)NBYGRP
        K=SDBYID-1
        DO 15 I=1,NBYGRP
        WRITE(11)(DX(K+J),J=1,NBY)
        K=K+NBY
   15   CONTINUE
      ELSE
        NBYGRP=1
      END IF
      WRITE(11)NRPTOT
      IF(NRPTOT.GT.0) THEN
        CALL UNFOUT(11,DX(SDCOEF),NRPTOT)
      END IF
      SDTOT=NXPTD
      CALL ROOMD(TSIZE)
      SDREP=NXPTD
      CALL ROOMD(TSIZE)
      SDCONS=NXPTD
      CALL ROOMD(TSIZE)
      DO 25 IBYGRP=1,NBYGRP
      DO 20 IREP=0,NRPTOT
      READ(12)(DX(NXPTD+I-1),I=1,NIDOUT)
      IF(IREP.EQ.0) THEN
        K=SDTOT
        DO 16 I=1,TSIZE
        DX(SDCONS+I-1)=0.
   16   CONTINUE
      ELSE
        K=SDREP
        T=DX(SDCOEF+IREP-1)
      END IF
      CALL UNFIN(12,DX(K),TSIZE,ENDFLE)
      IF(IREP.GT.0) THEN
        DO 18 I=1,TSIZE
        IF(DABS(DX(SDREP+I-1)-MISSNG).GT..1D-6) THEN
          DX(SDCONS+I-1)=DX(SDCONS+I-1)+T*(DX(SDREP+I-1)-DX(SDTOT+I-1))
        END IF
   18   CONTINUE
      END IF
   20 CONTINUE
      DO 22 I=1,TSIZE
      IF(DABS(DX(SDTOT+I-1)-MISSNG).GT..1D-6) THEN
        DX(SDTOT+I-1)=DX(SDTOT+I-1)-DX(SDCONS+I-1)
      END IF
   22 CONTINUE
      IF(NBY.GE.1) THEN
        CALL UNFOUT(13,DX(SDTOT),TSIZE)
      END IF
   25 CONTINUE
      IF(NBY.GE.1)REWIND(13)
      REWIND(12)
      NXPTD=SDREP
      CALL PREAMB
      IF(NBYGRP.EQ.0)NBYGRP=1
      NXPTD=SDREP
      DO 35 IBYGRP=1,NBYGRP
      IF(NBY.GE.1)CALL UNFIN(13,DX(SDTOT),TSIZE,ENDFLE)
      DO 32 IREP=0,NRPTOT
      READ(12)(DX(NXPTD+I-1),I=1,NIDOUT)
      WRITE(11)(DX(NXPTD+I-1),I=1,NIDOUT)
      IF(IREP.EQ.0) THEN
        CALL UNFIN(12,DX(SDREP),TSIZE,ENDFLE)
      ELSE
        CALL UNFIN(12,DX(SDTOT),TSIZE,ENDFLE)
      END IF
      CALL UNFOUT(11,DX(SDTOT),TSIZE)
   32 CONTINUE
   35 CONTINUE
      REWIND(12)
      CLOSE (11)
      RETURN
   95 CONTINUE
      WRITE(U6,200)
   99 CONTINUE
      CALL FSTOP
      END
C
C  Arrays in calling sequences - Transform step execution
C
C  The USER routines have a common calling sequence for arrays.  The
C  built-in subroutines in the TRANSFORM step also employ the same
C  conventions, although often one or more of the arguments will be
C  omitted from the list if they are not used.
C
C  The arguments of USER1 have the following interpretations:
C
C  DID -    A double precision array with the identifiers for the
C           replicate.  Generally, these vary with the replication
C           method, and they are not fully documented here.
C
C           The first element, DID(1), provides a number for the
C           replicate, starting with DID(1)=0 for the full sample,
C           regardless of the replication method.  Thus, DID(1)
C           is useful to subroutines that must perform a different
C           action depending on whether it is being called with
C           the full sample values or for replicate values.
C
C  NID -    The integer dimension of DID.
C
C  IFIRST - An integer flag set to 1 if DID(1)=0 and if this is
C           the first BY group when one or more BY variables are
C           defined.  If there are no BY variables, then it is
C           simply set to 1 for DID(1)=0.  In either case, it
C           identifies the first call to the subroutine from the
C           user's application.
C
C  IVLIST - An array of integer constants with the following meanings:
C           IVLIST(1) - The number of old variables
C           IVLIST(2) - The number of modified variables
C           IVLIST(3) - The number of new variables
C                       Note:  Arrays such as DIMPNT are ordered with
C                       respect to old variables first, followed by
C                       modify variables and then new variables.
C           IVLIST(4) - = 0 - no double precision constants are
C                             provided
C                       > 0 - the starting location, in DX, of
C                             double precision constants.
C           IVLIST(5) - The number of double precision constants
C                       provided.  It is =0 if no constants are
C                       provided.
C                       Note: Subroutines may check either IVLIST(4)
C                       or IVLIST(5) to establish whether constants
C                       are provided.
C           IVLIST(6) - The number of strings of length 128 that
C                       have been passed.
C           IVLIST(7) - The number of integer constants passed in IX.
C
C  DIMPNT - An integer array, of dimension NVAR=IVLIST(1)+IVLIST(2)+
C           IVLIST(3), which points to starting positions in DIMX.
C           DIMPNT(1)=1, that is, entries for the first variable
C           begin in DIMX(1), but other values of DIMPNT may vary.
C
C  DIMX   - An integer array with information about the dimensions of
C           each variable.  DIMPNT provides pointers to each variable's
C           first position in DIMX.
C
C           The first element, DIMX(DIMPNT(IV)), provides the dimension
C           of variable IV.  It may be 0.  Otherwise, the number of
C           levels of each dimension follow in DIMX.  A real variable
C           crossed by 2 class variables thus would have 3 elements in
C           DIMX, the first of which is 2, followed by the number of
C           levels from each class.
C
C  DXPNT  - An integer array pointing to starting locations in DX for
C           each variable.  DXPNT(1) is typically >1, that is, DXPNT
C           will point to locations somewhere in DX, not necessarily
C           at the beginning.
C           Note:  Application subroutines must take care not to
C           address locations other than those indicated through
C           DXPNT.
C
C  DX     - The general double precision array.  Space in this array
C           is pointed to through IVLIST(4) and DXPNT.
C
C  MSIZE  - An integer array giving the total size of each variable.
C
C  MTYPE  - An integer array indicating the type of each variable.
C           =1 for real variables.
C
C  MTRAN  - A code indicating whether the variable has been transformed.
C
C  STRING - An array of character*128 constants, used for formats, etc.
C
C  IX     - An integer array of constants, beginning with IX(1).
C           IVLIST(7) indicates their number.  IVLIST(7) may be 0.
C
C  ITRANS - An integer indicating the subroutine number.  ITRANS may be
C           used for error messages and is used by subroutines
C           employing unit 13 to read and write scratch data.
C
C  IERROR - A flag indicating whether a warning or error condition
C           occurred.
C
C
      SUBROUTINE USER1(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,ITRANS,IERROR)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
  100 FORMAT(' REPLICATE',I3,', V1=',F8.2,', V2=',F8.2,' RATIO=',F8.4)
      IF(DX(DXPNT(1)).GT.1.D0) THEN
        DX(DXPNT(1))=1.D0
      END IF
      RETURN
      END
      SUBROUTINE USER2(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,ITRANS,IERROR)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
  100 FORMAT(' REPLICATE',I3,', V1=',F8.2,', V2=',F8.2,' RATIO=',F8.4)
      IF(DX(DXPNT(2)).GT.0.) THEN
        DX(DXPNT(3))=DX(DXPNT(1))/DX(DXPNT(2))
      ELSE
        DX(DXPNT(3))=0.
      END IF
      K=DID(1)+.05D0
      WRITE(6,100)K,DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3))
      RETURN
      END
      SUBROUTINE USER3(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,ITRANS,IERROR)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
  100 FORMAT(' USER3 NOT AVAILABLE')
      WRITE(6,100)
      IERROR=1
      RETURN
      END
      SUBROUTINE USER4(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,ITRANS,IERROR)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
  100 FORMAT(' USER4 NOT AVAILABLE')
      WRITE(6,100)
      IERROR=1
      RETURN
      END
      SUBROUTINE USER5(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,ITRANS,IERROR)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
  100 FORMAT(' USER5 NOT AVAILABLE')
      WRITE(6,100)
      IERROR=1
      RETURN
      END
      SUBROUTINE USER6(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,ITRANS,IERROR)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
  100 FORMAT(' USER6 NOT AVAILABLE')
      WRITE(6,100)
      IERROR=1
      RETURN
      END
      SUBROUTINE USER7(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,ITRANS,IERROR)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
  100 FORMAT(' USER7 NOT AVAILABLE')
      WRITE(6,100)
      IERROR=1
      RETURN
      END
      SUBROUTINE USER8(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,ITRANS,IERROR)
      implicit double precision (a-h,o-z)
      double precision y(396),v(396),ysum(396),y2sum(396),vsum(396),
     .   cisum(396),en(2,2,2),bval(6,2,2)
      double precision ymean(396)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
      integer icf(396),iv(396)
      common /iblck8/iex,icf,iv
      common /dblck8/y,v,ysum,y2sum,vsum,cisum,ymx,csum,ycsum,ymean
      character*11 fname,fnamea,fnameb,fnamec
      data (((bval(i,j,k),i=1,6),j=1,2),k=1,2)/
     . -.15,-.45,.00159,.00711,.01938,-.02808,
     . -.15,.45,.05625,-.01920,-.02310,-.01395,
     .  .15,.45,-.00159,-.00711,-.01938,.02808,
     .  .15,-.45,-.05625,.01920,.02310,.01395/
      data fname/'mars       '/
      data fnamea/'taba       '/
      data fnameb/'tabb       '/
      data fnamec/'tabc       '/
  100 format(i3)
  101 format(12x,2f22.8)
  102 format(14x,3d22.14,/,14x,3d22.14)
  201 format(i1,'.dat')
  202 format(i2,'.dat')
  203 format(i3,'.dat')
  204 format(d21.14,2d20.14,2i4,d20.14)
  205 format(3d22.14,/,3d22.14)
      if(ifirst.ne.1)return
      open(30,file='batchnum.dat')
      read(30,100)ibatch
      ibatch=ibatch+1
      rewind (30)
      write(30,100)ibatch
      close (30)
      if(ibatch.le.9) then
        write(fname(5:9),201)ibatch
      else if(ibatch.le.99) then
        write(fname(5:10),202)ibatch
      else
        write(fname(5:11),203)ibatch
      end if
      do 5 i=1,396
      ysum(i)=0.
      y2sum(i)=0.
      vsum(i)=0.
      icf(i)=0
      cisum(i)=0.
      iv(i)=0
    5 continue
      open(34,file=fname)
      do 80 irep=1,50
      if(irep.le.9) then
        write(fnamea(5:9),201)irep
        write(fnameb(5:9),201)irep
        write(fnamec(5:9),201)irep
      else if(irep.le.99) then
        write(fnamea(5:10),202)irep
        write(fnameb(5:10),202)irep
        write(fnamec(5:10),202)irep
      else
        write(fnamea(5:11),203)irep
        write(fnameb(5:11),203)irep
        write(fnamec(5:11),203)irep
      end if
      open(31,file=fnamea)
      open(32,file=fnameb)
      open(33,file=fnamec)
      do 7 i=1,66
      read(33,101)ymean(i)
      ymean(i+66)=ymean(i)
      ymean(i+132)=ymean(i)
      ymean(i+198)=ymean(i)
      ymean(i+264)=0.
    7 continue
      do 10 k=1,2
      do 9 i=1,2
      do 8 j=1,2
      read(33,101)en(i,j,k)
    8 continue
    9 continue
   10 continue
      close(33)
      do 20 j=1,2
      indj=265+j*18
      do 14 k=1,2
      jj=3-j
      ind=indj+k*6
      do 12 i=1,6
      ymean(ind)=bval(i,k,j)*en(jj,k,1)*en(j,k,2)/
     .  (.15d0 * (en(1,k,1) + en(2,k,1)))
      ind=ind+1
   12 continue
   14 continue
      ind=indj
      do 16 i=1,6
      ymean(ind)=(ymean(ind+6)+ymean(ind+12))/
     .  ( en(j,1,1)+en(j,2,1)+en(j,1,2)+en(j,2,2) )
      ind=ind+1
   16 continue
      do 19 k=1,2
      ind=indj+k*6
      do 18 i=1,6
      ymean(ind)=ymean(ind)/(en(j,k,1)+en(j,k,2))
      ind=ind+1
   18 continue
   19 continue
   20 continue
      ymean(320)=ymean(283)-ymean(301)
      ymean(322)=ymean(284)-ymean(302)
      ymean(327)=ymean(285)-ymean(303)
      ymean(328)=ymean(286)-ymean(304)
      ymean(329)=ymean(287)-ymean(305)
      ymean(330)=ymean(288)-ymean(306)
c     write(*,*)(((en(i,j,k),i=1,2),j=1,2),k=1,2)
      do 22 i=1,66
      ymean(i+330)=ymean(i+264)
c     write(*,*)ymean(i+264)
   22 continue
      do 62 i=1,396
      if(i.le.66) then
        read(31,101)y(i),v(i)
      else
        read(32,101)y(i),v(i)
      end if
      if(dabs(y(i)+98765.432109d0).gt.1.d0) then
        iv(i)=iv(i)+1
        ysum(i)=ysum(i)+y(i)
        y2sum(i)=y2sum(i)+(y(i)-ymean(i))*(y(i)-ymean(i))
        cisum(i)=cisum(i)+1.96d0*v(i)
        vsum(i)=vsum(i)+v(i)*v(i)
        if(dabs(y(i)-ymean(i)).lt.1.96d0*v(i)) then
          icf(i)=icf(i)+1
        end if
      end if
   62 continue
   79 continue
      close(31)
      close(32)
   80 continue
      do 82 i=1,396
      write(34,204)ysum(i),y2sum(i),vsum(i),icf(i),iv(i),cisum(i)
   82 continue
      close (34)
      RETURN
      END
      SUBROUTINE USER9(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZEM,MTYPE,MTRAN,STRING,IX,ITRANS,IERROR)
      parameter (mpsize=150,mm=5,nrep=1,mstsiz=25)
      parameter (ns=100,msize=100,npstrt=6,nstrt=4)
      parameter (nrepf=200)
      implicit double precision (a-h,o-z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZEM(*),
     . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
      double precision y(mpsize),yobs(mstsiz,nstrt)
      double precision fpc(nstrt)
      integer rf(mpsize),mx1(mpsize),mxa(mpsize)
      double precision yix(mpsize,mm),w1(msize),w2(msize)
      integer iclus(mpsize),irepf(nrepf),istrat(mpsize)
      double precision normal,drand
      external drand,normal
      integer nclusm(npstrt),mclszm(npstrt),nobs(npstrt)
      common /dblck9/y,yobs,fpc,yix,w1,w2
      common /iblck9/rf,mx1,mxa
      data nclusm/6*25/
      data mclszm/6*1/
  100 format(i12)
  101 format(i5,3i2,i4,f8.6,f10.6)
  102 format(4f10.7)
  201 format(i5,5i2,i4,' 0',f4.1,f10.6,200i1)
  202 format(i5,5i2,i4,i2,f4.1,f10.6,200i1)
  203 format(i5,' 2',4i2,i4,i2,f4.1,f10.6,200i1)
  301 format(i5,4i2,f10.6)
      if(ifirst.ne.1)return
      open(31,file='ex1.dat')
      open(32,file='ex2.dat')
      open(33,file='ex3.dat')
      open(30,file='rand.dat')
      read(30,100)iseed
      read(30,100)iseed2
      close(30)
      do 2 i=1,nrepf
      irepf(i)=1
    2 continue
      do 90 irep=1,nrep
C
C  This loop determines missing/observed and the counts in the
C  4-cell table cross-classifying the 2 categorical variables.
C
      i=0
      ic=0
      do 10 ist=1,npstrt
      nobs(ist)=0
      icsize=mclszm(ist)
      do 8 k = 1, nclusm(ist)
      ic=ic+1
      if(drand(iseed).le..7d0) then
        irf=1
      else
        irf=0
      end if
      clval=normal (iseed2)
      do 6 ii=1,icsize
      i=i+1
      rf(i)=irf
      iclus(i)=ic
      istrat(i)=ist
      if(ist.eq.2.or.ist.eq.4) then
        w1(i)=2.
      else
        w1(i)=1.
      end if
      if(drand(iseed).le..5d0) then
        mx1(i)=1
      else
        mx1(i)=2
      end if
      if(ist.le.2.or.ist.eq.5) then
        mxa(i)=1
      else
        mxa(i)=2
      end if
      y (i) = clval
      if(mx1(i).eq.1) then
        if(mxa(i).eq.1) then
c
          y(i)=y(i)+2.d0
c
c         y(i)=y(i)
        else
c
          y(i)=y(i)-1.d0
c
c         y(i)=y(i)
        end if
      else
        if(mxa(i).eq.1) then
c
          y(i)=y(i)+1.d0
c
c         y(i)=y(i)
        else
c
          y(i)=y(i)-2.d0
c
c         y(i)=y(i)
        end if
      end if
      if(rf(i).eq.1) then
        if(ist.le.4) then
          nobs(ist)=nobs(ist)+1
          yobs(nobs(ist),ist)=y(i)
        end if
      end if
    6 continue
    8 continue
   10 continue
C
C  Fractionally weighted imputation.
C
      i=0
      do 20 ist=1,nstrt
      icsize=mclszm(ist)
      wadj=dble(float(icsize*nclusm(ist)))/dble(float(nobs(ist)))
      if(ist.eq.1.or.ist.eq.3) then
        fpc(ist)=dble(float(nobs(ist)))
     .             /dble(float(icsize*nclusm(ist)))
      else
        fpc(ist)=dble(float(nobs(ist)))
     .             /dble(float(2*icsize*nclusm(ist)))
      end if
      do 18 k = 1, nclusm(ist)
      do 16 ii=1,icsize
      i=i+1
      w2(i)=wadj*w1(i)
   16 continue
   18 continue
   20 continue
      i=0
      do 30 ist=1,nstrt
      icsize=mclszm(ist)
      dn = nobs(ist)
      do 28 kk = 1, nclusm(ist)
      do 26 ii=1,icsize
      i=i+1
      do 24 m=1,mm
      k = drand (iseed) * dn +1.d0
      if(k.gt.nobs(ist)) k = nobs(ist)
      yix(i,m)= yobs(k,ist)
   24 continue
   26 continue
   28 continue
   30 continue
      do 32 i=1,ns
      if(rf(i).eq.1) then
        write(31,101)irep,mxa(i),mx1(i),istrat(i),iclus(i),w2(i),y(i)
      end if
   32 continue
      open(30,file='fpctemp.dat')
      write(30,102)fpc
      close(30)
      ipanl=0
      do 40 i=1,ns
      w3=.2d0*w1(i)
      irepf(50+i)=0
      if(i.gt.25.and.i.le.50) then
        irepf(i-25)=0
      else if(i.gt.75.and.i.le.100) then
        irepf(i-50)=0
      end if
      if(rf(i).eq.1) then
        write(32,201)irep,rf(i),mxa(i),mx1(i),istrat(i),ipanl,iclus(i),
     .   w1(i),y(i),irepf
        do 34 m=1,mm
        write(32,203)irep,mxa(i),mx1(i),istrat(i),ipanl,iclus(i),
     .      m,w3,yix(i,m),irepf
   34   continue
      else
        ipanl=ipanl+1
        if(ipanl.gt.10)ipanl=1
        do 36 m=1,mm
        k=145+5*ipanl+m
        irepf(k)=0
        write(32,202)irep,rf(i),mxa(i),mx1(i),istrat(i),ipanl,iclus(i),
     .    m,w3,yix(i,m),irepf
        irepf(k)=1
   36   continue
      end if
      irepf(50+i)=1
      if(i.gt.25.and.i.le.50) then
        irepf(i-25)=1
      else if(i.gt.75.and.i.le.100) then
        irepf(i-50)=1
      end if
   40 continue
      do 42 i=1,mpsize
      write(33,301)irep,rf(i),mxa(i),mx1(i),istrat(i),y(i)
   42 continue
   90 continue
      open(30,file='rand.dat')
      write(30,100)iseed
      write(30,100)iseed2
      close(30)
      close(31)
      close(32)
      close(33)
      RETURN
      END
      function normal(iseed)
      double precision normal
      integer iseed
      double precision drand,temp
      external drand
      temp=0.
      do 5 i=1,48
      temp=temp+drand(iseed)
    5 continue
      normal=(temp-24.d0)/2.d0
      return
      end
      function drand(iseed)
      double precision drand
      integer iseed
      double precision dtemp,dtwo16,drmod,div
      double precision dm1,dm2,dseed1,dseed2
      integer two16,iseed1,iseed2
c
c     multiplier = 742938285
c
      data two16/65536/,dtwo16/.65536d+05/
      data dm1/.11336d+05/,dm2/.22189d+05/
      div=.65536d+05*.32768d+05
      drmod=div-1.0d0
      iseed1=iseed/two16
      iseed2=mod(iseed,two16)
      dseed1=iseed1
      dseed2=iseed2
      dtemp=dmod(dm2*dseed2,drmod)+dmod(dm1*dtwo16*dseed2,drmod)
     .  +dmod(dm2*dtwo16*dseed1,drmod)+2.d0*dm1*dseed1
      dtemp=dmod(dtemp,drmod)
      iseed=dtemp+.5
      drand=dtemp/div
      return
      end
      SUBROUTINE USER10(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,ITRANS,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
      INTEGER MATSIZ
      EXTERNAL MATSIZ
      DOUBLE PRECISION MISSNG
      LOGICAL ENDFLE
      DATA MISSNG/-98765.432109D0/
  200 FORMAT(' RAO_SHAO: MUST CALL WITH MODIFY AND OLD VARIABLES')
  201 FORMAT(' RAO_SHAO: MISMATCHING MATRICES')
  202 FORMAT(' RAO_SHAO: FINAL DIMENSION MUST BE 2')
  203 FORMAT(' RAO_SHAO: WRONG OLD VARIABLE TYPE')
C
C  Establish NCELL, the number of imputation cells.
C
      IREP=DABS(DID(1))+.5D0
      IF(IVLIST(7).GE.1) THEN
        NCELL=IX(1)
        IF(IVLIST(7).GE.3) THEN
          NREP1=IX(2)
          NREP2=IX(3)
C
C  Immediate return for final replicates, which are to estimate
C  prediction error of model for finite population values.
C
          IF(IREP.GT.NREP1+NREP2) RETURN
        ELSE
          NREP1=IREP
          NREP2=0
        END IF
      ELSE
        NCELL=1
        NREP1=IREP
        NREP2=0
      END IF
      IF(IFIRST.EQ.1) THEN
C
C  Check for OLD and MODIFY variables only.
C
        IF(IVLIST(3).GT.0.OR.IVLIST(1).EQ.0.OR.IVLIST(2).EQ.0) THEN
          WRITE(U6,200)
          GO TO 99
        END IF
        IF(IVLIST(1).NE.1.AND.IVLIST(1).NE.IVLIST(2)) THEN
          GO TO 98
        END IF
C
C  Check that each final dimension is 2
C
        DO 2 I=1,IVLIST(1)+IVLIST(2)
        J=DIMPNT(I)+DIMX(DIMPNT(I))
        IF(DIMX(J).NE.2) THEN
          WRITE(U6,202)
          GO TO 99
        END IF
    2   CONTINUE
C
C  Now check that the sizes of matrices appear appropriate.
C  Determine the total storage that will be needed.
C
        IOLD=1
        INEW=IVLIST(1)+1
        N=0
        DO 4 I=1,IVLIST(2)
        NOLD=MATSIZ(DIMX(DIMPNT(IOLD)),MTYPE(IOLD),MTRAN(IOLD))
        NNEW=MATSIZ(DIMX(DIMPNT(INEW)),MTYPE(INEW),MTRAN(INEW))
        IF((MTYPE(IOLD).EQ.2.OR.MTYPE(IOLD).EQ.8).AND.
     .      MTRAN(IOLD).EQ.0) THEN
          WRITE(U6,203)
          GO TO 99
        END IF
        IF((MTYPE(INEW).EQ.2.OR.MTYPE(INEW).EQ.8).AND.
     .      MTRAN(INEW).EQ.0.AND.NOLD*2.EQ.NNEW) THEN
          NNEW=NNEW/2
        END IF
        IF(NCELL*2*(NOLD/(NCELL*2)).NE.NOLD)GO TO 98
        IF(NCELL*2*(NNEW/(NCELL*2)).NE.NNEW)GO TO 98
        IF(NOLD*(NNEW/NOLD).NE.NNEW)GO TO 98
        N=N+NCELL*(NNEW/NOLD)+NNEW
        IF(I.EQ.1.OR.IVLIST(1).GT.1) THEN
          N=N+NOLD
        END IF
        INEW=INEW+1
        IF(IVLIST(1).GT.1)IOLD=IOLD+1
    4   CONTINUE
C
C  If constants have been specified, check available space and
C  reallocate, if necessary.
C
        IF(IVLIST(5).GT.0) THEN
          IF(IVLIST(5).LT.N) THEN
            IVLIST(4)=NXPTD
            IVLIST(5)=N
            CALL ROOMD(N)
          END IF
        END IF
      END IF
      IF(IVLIST(5).EQ.0) THEN
C
C  If IVLIST(5)=0, then allocate temporary storage, and, if not full
C  sample, obtain the stored values from the scratch file.
C
        IVLIST(4)=NXPTD
        NXPTDS=NXPTD
        IF(IREP.NE.0) THEN
          CALL SCPOSN(ITRANS,N)
          CALL ROOMD(N)
          CALL UNFIN(13,DX(IVLIST(4)),N,ENDFLE)
        END IF
      END IF
C
      IOLD=1
      INEW=IVLIST(1)+1
C
C  N is recomputed here, in case DID(1)=0 but IFIRST is not 1.
C
      N=0
      DO 40 IV=1,IVLIST(2)
      NOLD=MATSIZ(DIMX(DIMPNT(IOLD)),MTYPE(IOLD),MTRAN(IOLD))
      NNEW=MATSIZ(DIMX(DIMPNT(INEW)),MTYPE(INEW),MTRAN(INEW))
      IF((MTYPE(INEW).EQ.2.OR.MTYPE(INEW).EQ.8).AND.
     .    MTRAN(INEW).EQ.0.AND.NOLD*2.EQ.NNEW) THEN
        INCR=2
      ELSE
        INCR=1
      END IF
      NVAL=NCELL*(NNEW/(NOLD*INCR))
C
C  For full sample, allocate the space if not already allocated.
C  NVAL is the number of values that need to be computed and
C  stored.
C
      IF(IV.EQ.1.OR.IVLIST(1).GT.1) THEN
        J1=IVLIST(4)+N
        J2=J1+NOLD
        J=J2+NNEW
        NUSED=NOLD+NNEW+NVAL
      ELSE
        J1=IVLIST(4)
        J2=IVLIST(4)+N
        J=J2+NNEW
        NUSED=NNEW+NVAL
      END IF
      N=N+NUSED
      IF(DID(1).EQ.0.) THEN
        IF(IVLIST(5).EQ.0) THEN
          CALL ROOMD(NUSED)
        END IF
        IF(IV.EQ.1.OR.IVLIST(1).GT.1) THEN
          JOLD=DXPNT(IOLD)
          DO 6 I=1,NOLD
          DX(J1)=DX(JOLD)
          J1=J1+1
          JOLD=JOLD+1
    6     CONTINUE
        END IF
        JNEW=DXPNT(INEW)
        DO 8 I=1,NNEW
        DX(J2)=DX(JNEW)
        J2=J2+1
        JNEW=JNEW+1
    8   CONTINUE
      END IF
C
C  NNEWC represents the length of the vector of values to be
C  stored for each imputation cell.  NC is the number of cells
C  of the modified variable that are imputed from the same
C  imputation cell.
C
 
      NNEWC=NVAL/NCELL
      NC=NOLD/(NCELL*2)
      JOLD=DXPNT(IOLD)
      DO 37 ICELL=1,NCELL
      JNEW=DXPNT(INEW)+(ICELL-1)*NNEW/(2*NCELL)
      JNEW2=J2+(ICELL-1)*NNEW/(2*NCELL)
      DO 35 NEWC=1,NNEWC
      JOLDT=JOLD
      JNEWT=JNEW
      JNEWT2=JNEW2
      TV=0.D0
      TN=0.D0
      DO 14 I=1,NC
      IF(DABS(TV-MISSNG).GT..1D-6) THEN
        IF(DABS(DX(JNEWT)-MISSNG).GT..1D-6) THEN
          TV=TV+DX(JNEWT)
        ELSE
          TV=MISSNG
        END IF
      END IF
      IF(DABS(TN-MISSNG).GT..1D-6) THEN
        IF(DABS(DX(JOLDT)-MISSNG).GT..1D-6) THEN
          TN=TN+DX(JOLDT)
        ELSE
          TN=MISSNG
        END IF
      END IF
C
C  This section restores the values for the replicate to the full
C  sample values for observed cases, for IREP > NREP1.
C
      IF(NREP2.GT.0.AND.IREP.GT.NREP1) THEN
        DX(JNEWT)=DX(JNEWT2)
        IF(INCR.EQ.2) THEN
          DX(JNEWT+1)=DX(JNEWT2+1)
        END IF
        JNEWT2=JNEWT2+INCR*NNEWC
      END IF
      JNEWT=JNEWT+INCR*NNEWC
      JOLDT=JOLDT+1
   14 CONTINUE
C
C  Compute the mean within the imputation cell.
C
      IF(DABS(TV-MISSNG).GT..1D-6) THEN
        IF(DABS(TN-MISSNG).GT..1D-6) THEN
          IF(TN.EQ.0.) THEN
            TV=MISSNG
          ELSE
            TV=TV/TN
          END IF
        ELSE
          TV=MISSNG
        END IF
      END IF
C
C  For the full sample, simply store the mean.
C
      IF(DID(1).EQ.0.) THEN
        DX(J)=TV
      ELSE
C
C  For other replicates, subtract the full sample mean for the
C  imputation cell from the mean for this replicate, then
C  adjust each of the corresponding cells.
C
        IF(DABS(TV-MISSNG).GT..1D-6) THEN
          IF(DABS(DX(J)-MISSNG).GT..1D-6) THEN
            TV=TV-DX(J)
          ELSE
            TV=MISSNG
          END IF
        END IF
C
C  For replicates up through NREP1, multiply mean adjustment by
C  numbers of cases in this replicate.  For IREP > NREP1, multiply
C  by full-sample N.
C
        IF(IREP.LE.NREP1) THEN
          JOLDT=JOLD+NOLD/2
        ELSE
          JOLDT=J1+NOLD/2
        END IF
        JNEWT=JNEW+NNEW/2
        JNEWT2=JNEW2+NNEW/2
        DO 18 I=1,NC
C
C  At this point, restore full sample (imputed) values for missing
C  cases if IREP > NREP1.
C
        IF(IREP.GT.NREP1) THEN
          DX(JNEWT)=DX(JNEWT2)
          IF(INCR.EQ.2) THEN
            DX(JNEWT+1)=DX(JNEWT2+1)
          END IF
          JNEWT2=JNEWT2+INCR*NNEWC
        END IF
        IF(DX(JOLDT).NE.0.) THEN
          IF(DABS(DX(JNEWT)-MISSNG).GT..1D-6) THEN
            IF(DABS(TV-MISSNG).GT..1D-6) THEN
              DX(JNEWT)=DX(JNEWT)+DX(JOLDT)*TV
            ELSE
              DX(JNEWT)=MISSNG
            END IF
          END IF
        END IF
        JNEWT=JNEWT+INCR*NNEWC
        JOLDT=JOLDT+1
   18   CONTINUE
      END IF
      J=J+1
      JNEW=JNEW+INCR
      JNEW2=JNEW2+INCR
   35 CONTINUE
      JOLD=JOLD+NC
      J1=J1+NC
   37 CONTINUE
      INEW=INEW+1
      IF(IVLIST(1).GT.1)IOLD=IOLD+1
   40 CONTINUE
      IF(DID(1).EQ.0.) THEN
        IF(IVLIST(5).EQ.0) THEN
          WRITE(13)ITRANS,N
          CALL UNFOUT(13,DX(IVLIST(4)),N)
        END IF
      END IF
C
C  If IVLIST(5)=0, have been reusing temporary storage.  Setting
C  NXPTD=NXPTDS frees up temporary space.
C
      IF(IVLIST(5).EQ.0) THEN
        NXPTD=NXPTDS
      END IF
      RETURN
   98 CONTINUE
      WRITE(U6,201)
   99 CONTINUE
      IERROR=1
      RETURN
      END
C
      SUBROUTINE SCRCOL(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
      INTEGER MATSIZ
      EXTERNAL MATSIZ
      DOUBLE PRECISION MISSNG
      DATA MISSNG/-98765.432109D0/
C
  200 FORMAT(' SIPPC_ROWCOL: WRONG NUMBER OF VARIABLES')
  201 FORMAT(' SIPPC_ROWCOL: UNEXPECTED DIMENSIONS')
  202 FORMAT(' SIPPC_ROWCOL: DISAGREEING SIZES')
C
      IF(IFIRST.EQ.1) THEN
C
C  Check that 3-4 old variables specified, 1 modify or new variable.
C
C  First old variable - weighted counts
C  Second old variable - controls
C  Third old variable -  unweighted counts
C  Fourth old variable or constants - scale values.
C
        IF(((IVLIST(1).NE.3.OR.IVLIST(5).EQ.0).AND.
     .     (IVLIST(1).NE.4.OR.IVLIST(5).NE.0)).OR.
     .     (IVLIST(2)+IVLIST(3).NE.1)) THEN
          WRITE(U6,200)
          GO TO 99
        END IF
        ITOP=IVLIST(1)+IVLIST(2)+IVLIST(3)
      ELSE
        ITOP=1
      END IF
C
C  Determine whether subroutine has been called for a single number of
C  rows or whether more than one rotation group is present
C
 
      NROT=1
      NROW=1
      DO 2 I=1,ITOP
      J=DIMPNT(I)+1
      JJ=DIMX(J-1)
      K=0
      DO 1 IJ=1,JJ
      IF(DIMX(J).GT.1) THEN
        K=K+1
        IF(K.EQ.1) THEN
          IF(I.EQ.1) THEN
            NROW=DIMX(J)
          ELSE
            IF(DIMX(J).NE.NROW) THEN
              WRITE(U6,202)
              GO TO 99
            END IF
          END IF
        ELSE IF(K.EQ.2) THEN
          IF(I.EQ.1) THEN
            NROT=DIMX(J)
          ELSE IF(DIMX(J).NE.NROT) THEN
            WRITE(U6,202)
            GO TO 99
          END IF
        ELSE
          WRITE(U6,201)
          GO TO 99
        END IF
      END IF
      J=J+1
    1 CONTINUE
    2 CONTINUE
C
C  Allocate space for constants
C  If scale values have been specified as constants, then move
C  them to new space and establish an additional space of NROW
C  as scratch.  If the scale values are in an OLD variable,
C  establish temporary storage of NROW
C
      IF(IFIRST.EQ.1) THEN
        J=IVLIST(4)
        IF(IVLIST(5).GT.0) THEN
          IVLIST(4)=NXPTD
          IF(IVLIST(5).NE.NROW) THEN
            WRITE(U6,202)
            GO TO 99
          END IF
          JJ=NXPTD
          K=2*NROW
          CALL ROOMD(K)
          DO 3 K=1,NROW
          DX(JJ)=DX(J)
          J=J+1
          JJ=JJ+1
    3     CONTINUE
        END IF
      END IF
      IF(IVLIST(5).GT.0) THEN
        ISSCAL=IVLIST(4)+NROW
      ELSE
        NXPTDS=NXPTD
        ISSCAL=NXPTDS
        CALL ROOMD(NROW)
      END IF
      INEW=IVLIST(1)+1
      DO 90 IROT=1,NROT
      IF(IVLIST(5).GT.0) THEN
        DO 4 K=IVLIST(4),IVLIST(4)+NROW-1
        DX(K+NROW)=DX(K)
    4   CONTINUE
      ELSE
        J=DXPNT(4)
        DO 6 K=1,NROW
        DX(K+ISSCAL-1)=DX(J)
        J=J+1
    6   CONTINUE
      END IF
      ISTALL=DXPNT(1)+NROW*(IROT-1)
      ISCONT=DXPNT(2)+NROW*(IROT-1)
      ISUNWT=DXPNT(3)+NROW*(IROT-1)
C
      ISCOL=DXPNT(INEW)+NROW*(IROT-1)
      DO 8 K=1,NROW
      DX(ISCOL+K-1)=0.
    8 CONTINUE
C
      DO 80 IROW=1,NROW
      IF(DX(ISCOL+IROW-1).EQ.0.) THEN
        T=DX(ISTALL+IROW-1)
        TC=DX(ISCONT+IROW-1)
        IUNWT=DX(ISUNWT+IROW-1)+.5D-1
   10   CONTINUE
        IF(T.GT.0.) THEN
          R=TC/T
        ELSE
          R=0.
        END IF
        IF(R.LE..6700D+0.OR.R.GE.2.D0.OR.IUNWT.LT.35) THEN
          IROWC=0
          SVNOW=DX(ISSCAL+IROW-1)
          DO 12 I=1,NROW
          SVD=DABS(DX(ISSCAL+I-1)-SVNOW)
          IF(SVD.GT..1D-06) THEN
            IF(IROWC.EQ.0) THEN
              IROWC=I
              SVDIFF=SVD
            ELSE IF(SVD.LT.SVDIFF) THEN
              IROWC=I
              SVDIFF=SVD
            END IF
          END IF
   12     CONTINUE
          IF(IROWC.NE.0) THEN
            SVC=DX(ISSCAL+IROWC-1)
            SVSUM=0.
            T=0.
            TC=0.
            DIUNWT=0.
            DO 14 I=1,NROW
            IF(DABS(DX(ISSCAL+I-1)-SVNOW).LT..1D-06.OR.
     .         DABS(DX(ISSCAL+I-1)-SVC).LT..1D-06) THEN
              T=T+DX(ISTALL+I-1)
              TC=TC+DX(ISCONT+I-1)
              DIUNWT=DIUNWT+DX(ISUNWT+I-1)
              SVSUM=SVSUM+DX(ISUNWT+I-1)*DX(ISSCAL+I-1)
            END IF
   14       CONTINUE
            IUNWT=DIUNWT+.5D-1
            IF(DIUNWT.GT.0.) THEN
              SVNEW=SVSUM/DIUNWT
            ELSE
              SVNEW=SVNOW
            END IF
            DO 16 I=1,NROW
            IF(DABS(DX(ISSCAL+I-1)-SVNOW).LT..1D-06.OR.
     .         DABS(DX(ISSCAL+I-1)-SVC).LT..1D-06) THEN
              DX(ISSCAL+I-1)=SVNEW
              DX(ISCOL+I-1)=IROW+(IROT-1)*NROW
            END IF
   16       CONTINUE
            GO TO 10
          END IF
        END IF
      END IF
   80 CONTINUE
   90 CONTINUE
C
C
C  If IVLIST(5)=0, have been reusing temporary storage.  Setting
C  NXPTD=NXPTDS frees up temporary space.
C
      IF(IVLIST(5).EQ.0) THEN
        NXPTD=NXPTDS
      END IF
      RETURN
   99 CONTINUE
      IERROR=1
      RETURN
      END
C
      SUBROUTINE SCCCOL(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
      INTEGER MATSIZ
      EXTERNAL MATSIZ
      DOUBLE PRECISION MISSNG
      INTEGER IPAIR(2,3)
      DATA ((IPAIR(I,J),I=1,2),J=1,3)/1,3,2,5,4,6/
      DATA MISSNG/-98765.432109D0/
  200 FORMAT(' SIPPC_CLMCOL: WRONG NUMBER OF VARIABLES')
  201 FORMAT(' SIPPC_CLMCOL: UNEXPECTED DIMENSIONS')
  202 FORMAT(' SIPPC_CLMCOL: DISAGREEING SIZES')
C
      IF(IFIRST.EQ.1) THEN
C
C  Check that 3 old variables specified, 1 modify or new variable.
C
C  First old variable - weighted counts
C  Second old variable - controls
C  Third old variable -  unweighted counts
C
        IF(IVLIST(1).NE.3.OR.IVLIST(2)+IVLIST(3).NE.1) THEN
          WRITE(U6,200)
          GO TO 99
        END IF
        ITOP=IVLIST(1)+IVLIST(2)+IVLIST(3)
      ELSE
        ITOP=1
      END IF
C
C  Determine whether subroutine has been called for a single number of
C  columns or whether more than one rotation group is present
C
      NROT=1
      DO 2 I=1,ITOP
      J=DIMPNT(I)+1
      JJ=DIMX(J-1)
      K=0
      DO 1 IJ=1,JJ
      IF(DIMX(J).GT.1) THEN
        K=K+1
        IF(K.EQ.1) THEN
          IF(DIMX(J).NE.6) THEN
            WRITE(U6,202)
            GO TO 99
          END IF
        ELSE IF(K.EQ.2) THEN
          IF(I.EQ.1) THEN
            NROT=DIMX(J)
          ELSE IF(DIMX(J).NE.NROT) THEN
            WRITE(U6,202)
            GO TO 99
          END IF
        ELSE
          WRITE(U6,201)
          GO TO 99
        END IF
      END IF
      J=J+1
    1 CONTINUE
    2 CONTINUE
C
      INEW=IVLIST(1)+1
      DO 90 IROT=1,NROT
      ISTALL=DXPNT(1)+6*(IROT-1)
      ISCONT=DXPNT(2)+6*(IROT-1)
      ISUNWT=DXPNT(3)+6*(IROT-1)
C
      ISCOL=DXPNT(INEW)+6*(IROT-1)
      DO 8 K=1,6
      DX(ISCOL+K-1)=0.
    8 CONTINUE
C
      DO 20 IP=1,3
      DO 15 IK=1,2
      I=IPAIR(IK,IP)
      IF(DX(ISCOL+I-1).EQ.0.) THEN
        T=DX(ISTALL+I-1)
        TC=DX(ISCONT+I-1)
        IUNWT=DX(ISUNWT+I-1)+.5D-1
        IF(T.GT.0.) THEN
          R=TC/T
        ELSE
          R=0.
        END IF
        IF(R.LE..6700D+0.OR.R.GE.2.D0.OR.IUNWT.LT.35) THEN
          DX(ISCOL+I-1)=IP+6*(IROT-1)
          IF(IK.EQ.1) THEN
            I=IPAIR(2,IP)
          ELSE
            I=IPAIR(1,IP)
          END IF
          DX(ISCOL+I-1)=IP+6*(IROT-1)
        END IF
      END IF
   15 CONTINUE
   20 CONTINUE
   90 CONTINUE
C
      RETURN
   99 CONTINUE
      IERROR=1
      RETURN
      END
C
      SUBROUTINE SCRAKE(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
      INTEGER MATSIZ
      EXTERNAL MATSIZ
      DOUBLE PRECISION MISSNG
      DATA MISSNG/-98765.432109D0/
  200 FORMAT(' SIPPC_RAKE: WRONG NUMBER OF VARIABLES')
  201 FORMAT(' SIPPC_RAKE: UNEXPECTED DIMENSIONS')
  202 FORMAT(' SIPPC_RAKE: DISAGREEING SIZES')
C
      IF(IFIRST.EQ.1) THEN
C
C  Check that 3 old variables specified, at least one
C  modify variable and a total of 3 modify or new variables.
C
C  First old variable - row controls
C  Second old variable - column controls
C  Third old variable - collapsing for rows
C  Fourth old variable -  collapsing for columns
C  First modify variable - Sample counts to be raked
C  Second modify/first new - Row factors
C  Third modify/second new - Column factors
C
        IF(IVLIST(1).NE.4.OR.IVLIST(2)+IVLIST(3).NE.3) THEN
          WRITE(U6,200)
          GO TO 99
        END IF
        IF(IVLIST(2).NE.1.AND.IVLIST(2).NE.3) THEN
          WRITE(U6,200)
          GO TO 99
        END IF
        ITOP=IVLIST(1)+IVLIST(2)+IVLIST(3)
      ELSE
        ITOP=1
      END IF
C
C  Determine whether subroutine has been called for a single number of
C  columns or whether more than one rotation group is present
C
      NROT=1
      NROW=1
      DO 2 I=1,ITOP
      J=DIMPNT(I)+1
      JJ=DIMX(J-1)
      K=0
      DO 1 IJ=1,JJ
      IF(DIMX(J).GT.1) THEN
        K=K+1
        IF(K.EQ.1) THEN
          IF(I.EQ.1) THEN
            NROW=DIMX(J)
          ELSE IF(I.EQ.3.OR.I.EQ.5.OR.I.EQ.6) THEN
            IF(DIMX(J).NE.NROW) THEN
              WRITE(U6,202)
              GO TO 99
            END IF
          ELSE
            IF(DIMX(J).NE.6) THEN
              WRITE(U6,201)
              GO TO 99
            END IF
          END IF
        ELSE IF(K.EQ.2) THEN
          IF(I.EQ.1) THEN
            NROT=DIMX(J)
          ELSE IF(I.EQ.5) THEN
            IF(DIMX(J).NE.6) THEN
              WRITE(U6,201)
              GO TO 99
            END IF
          ELSE IF(DIMX(J).NE.NROT) THEN
            WRITE(U6,202)
            GO TO 99
          END IF
        ELSE IF(K.EQ.3) THEN
          IF(I.EQ.5) THEN
            IF(DIMX(J).NE.NROT) THEN
              WRITE(U6,202)
              GO TO 99
            END IF
          ELSE
            WRITE(U6,201)
            GO TO 99
          END IF
        ELSE
          WRITE(U6,201)
          GO TO 99
        END IF
      END IF
      J=J+1
    1 CONTINUE
    2 CONTINUE
C
C  Allocate space for constants
C
      IF(IFIRST.EQ.1) THEN
        J=IVLIST(4)
        IVLIST(4)=NXPTD
        JJ=NXPTD
        K=2+NROT+NROW
        CALL ROOMD(K)
        IF(IVLIST(5).GT.0) THEN
          DO 3 K=1,IVLIST(5)
          DX(JJ)=DX(J)
          J=J+1
          JJ=JJ+1
    3     CONTINUE
        END IF
        IF(IVLIST(5).EQ.0) THEN
          DX(IVLIST(4))=2500.D0
        END IF
        IF(IVLIST(5).LT.2) THEN
          DX(IVLIST(4)+1)=21.D0
        END IF
        DO 4 K=1,NROT
        KK=IVLIST(4)+K+1
        DX(KK)=0.
    4   CONTINUE
        IVLIST(5)=2+NROT+NROW
      END IF
C
      MXITER=DX(IVLIST(4)+1)+.1D-1
      ISSCRT=IVLIST(4)+2+NROT
      DO 90 IROT=1,NROT
      ISRCNT=DXPNT(1)+NROW*(IROT-1)
      ISCCNT=DXPNT(2)+6*(IROT-1)
      ISRCOL=DXPNT(3)+NROW*(IROT-1)
      ISCCOL=DXPNT(4)+6*(IROT-1)
      ISTALL=DXPNT(5)+NROW*6*(IROT-1)
      ISRFCT=DXPNT(6)+NROW*(IROT-1)
      ISCFCT=DXPNT(7)+6*(IROT-1)
      ISITER=IVLIST(4)+1+IROT
 
      CALL SCRAK2(NROW,DX(ISRCNT),DX(ISCCNT),DX(ISRCOL),DX(ISCCOL),
     . DX(ISTALL),DX(ISRFCT),DX(ISCFCT),MXITER,DX(IVLIST(4)),DX(ISITER),
     . DX(IVLIST(4)+2+NROT))
C
   90 CONTINUE
C
      RETURN
   99 CONTINUE
      IERROR=1
      RETURN
      END
C
      SUBROUTINE SCRAK2(NROW,RCONT,CCONT,RCOL,CCOL,TABLE,RFACT,CFACT,
     .  MXITER,DEV,DITER,DWORK)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NROW,MXITER
      DOUBLE PRECISION RCONT(NROW),CCONT(6),RCOL(NROW),CCOL(6),
     . TABLE(NROW,6),RFACT(NROW),CFACT(6),DEV,DITER,DWORK(NROW)
      NWITER=DITER+.05D0
      DO 1 I=1,NROW
      RFACT(I)=1.D0
    1 CONTINUE
      DO 2 I=1,6
      CFACT(I)=1.D0
    2 CONTINUE
      IF(NWITER.GT.0) THEN
        ITOP=NWITER
      ELSE
        ITOP=MXITER
      END IF
      DO 90 ITER=1,ITOP,2
      DO 20 IR=1,NROW
      IF(RCOL(IR).GT.0.) THEN
        IF(IR.GT.1) THEN
          DO 4 I=1,IR-1
          IF(DABS(RCOL(IR)-RCOL(I)).LT..1D-02)GO TO 20
    4     CONTINUE
        END IF
        CTOT=0.
        TTOT=0.
        DO 8 I=IR,NROW
        IF(DABS(RCOL(IR)-RCOL(I)).LT..1D-02) THEN
          CTOT=CTOT+RCONT(I)
          DO 6 K=1,6
          TTOT=TTOT+TABLE(I,K)
    6     CONTINUE
        END IF
    8   CONTINUE
        IF(TTOT.GT.0.) THEN
          CTOT=CTOT/TTOT
          DO 12 I=IR,NROW
          IF(DABS(RCOL(IR)-RCOL(I)).LT..1D-02) THEN
            DO 10 K=1,6
            TABLE(I,K)=CTOT*TABLE(I,K)
   10       CONTINUE
            RFACT(I)=CTOT*RFACT(I)
          END IF
   12     CONTINUE
        END IF
      ELSE
        CTOT=0.
        TTOT=0.
        CTOT=CTOT+RCONT(IR)
        DO 14 K=1,6
        TTOT=TTOT+TABLE(IR,K)
   14   CONTINUE
        IF(TTOT.GT.0.) THEN
          CTOT=CTOT/TTOT
          DO 16 K=1,6
          TABLE(IR,K)=CTOT*TABLE(IR,K)
   16     CONTINUE
          RFACT(IR)=CTOT*RFACT(IR)
        END IF
      END IF
   20 CONTINUE
      IF(ITER.EQ.ITOP) GO TO 90
      IF(NWITER.EQ.0.AND.ITER.GE.3) THEN
        DO 40 IR=1,6
        IF(CCOL(IR).GT.0.) THEN
          IF(IR.GT.1) THEN
            DO 24 I=1,IR-1
            IF(DABS(CCOL(IR)-CCOL(I)).LT..1D-02)GO TO 40
   24       CONTINUE
          END IF
          CTOT=0.
          TTOT=0.
          DO 28 I=IR,6
          IF(DABS(CCOL(IR)-CCOL(I)).LT..1D-02) THEN
            CTOT=CTOT+CCONT(I)
            DO 26 K=1,NROW
            TTOT=TTOT+TABLE(K,I)
   26       CONTINUE
          END IF
   28     CONTINUE
          IF(DABS(CTOT-TTOT).GT.DEV) GO TO 42
        ELSE
          TTOT=0.
          DO 34 K=1,NROW
          TTOT=TTOT+TABLE(K,IR)
   34     CONTINUE
          IF(DABS(CCONT(IR)-TTOT).GT.DEV) GO TO 42
        END IF
   40   CONTINUE
        DITER=ITER
        GO TO 92
      END IF
   42 CONTINUE
      DO 60 IR=1,6
      IF(CCOL(IR).GT.0.) THEN
        IF(IR.GT.1) THEN
          DO 44 I=1,IR-1
          IF(DABS(CCOL(IR)-CCOL(I)).LT..1D-02)GO TO 60
   44     CONTINUE
        END IF
        CTOT=0.
        TTOT=0.
        DO 48 I=IR,6
        IF(DABS(CCOL(IR)-CCOL(I)).LT..1D-02) THEN
          CTOT=CTOT+CCONT(I)
          DO 46 K=1,NROW
          TTOT=TTOT+TABLE(K,I)
   46     CONTINUE
        END IF
   48   CONTINUE
        IF(TTOT.GT.0.) THEN
          CTOT=CTOT/TTOT
          DO 52 I=IR,6
          IF(DABS(CCOL(IR)-CCOL(I)).LT..1D-02) THEN
            DO 50 K=1,NROW
            TABLE(K,I)=CTOT*TABLE(K,I)
   50       CONTINUE
            CFACT(I)=CTOT*CFACT(I)
          END IF
   52     CONTINUE
        END IF
      ELSE
        TTOT=0.
        DO 54 K=1,NROW
        TTOT=TTOT+TABLE(K,IR)
   54   CONTINUE
        IF(TTOT.GT.0.) THEN
          CTOT=CCONT(IR)/TTOT
          DO 56 K=1,NROW
          TABLE(K,IR)=CTOT*TABLE(K,IR)
   56     CONTINUE
          CFACT(IR)=CTOT*CFACT(IR)
        END IF
      END IF
   60 CONTINUE
   90 CONTINUE
   92 CONTINUE
      RETURN
      END
      SUBROUTINE CPSCOL(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
  100 FORMAT(' CPSCOL: UNEXPECTED SPECIFICATION')
      IF(DID(1).EQ.0.) THEN
        IF(IVLIST(1).NE.2.OR.IVLIST(2)+IVLIST(3).NE.1)GO TO 99
        ITOP=3
      ELSE
        ITOP=1
      END IF
      NSEX=1
      DO 10 I=1,ITOP
      J=DIMPNT(I)+1
      JJ=DIMX(J-1)
      K=0
      DO 7 IJ=1,JJ
      IF(DIMX(J).GT.1) THEN
        K=K+1
        IF(K.EQ.1) THEN
          IF(I.EQ.1) THEN
            NCELL=DIMX(J)
          ELSE
            IF(DIMX(J).NE.NCELL)GO TO 99
          END IF
        ELSE IF(K.EQ.2) THEN
          IF(DIMX(J).NE.2)GO TO 99
          IF(I.EQ.1)NSEX=2
        ELSE
          GO TO 99
        END IF
      END IF
      J=J+1
    7 CONTINUE
      IF(I.GT.1) THEN
        IF(K.GT.2)GO TO 99
        IF((NSEX.EQ.1.AND.K.EQ.2).OR.(NSEX.EQ.2.AND.K.EQ.1))GO TO 99
      END IF
   10 CONTINUE
      IF(IVLIST(4).GT.0.AND.IVLIST(5).EQ.2) THEN
        BOUNDL=DX(IVLIST(4))
        BOUNDH=DX(IVLIST(4)+1)
      ELSE
        BOUNDL=.6D0
        BOUNDH=2.0D0
      END IF
      CALL CPSCL2(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3)),NCELL,NSEX,
     .  BOUNDL,BOUNDH)
      RETURN
   99 CONTINUE
      WRITE(U6,100)
      IERROR=1
      RETURN
      END
      SUBROUTINE CPSCL2(H,CH,FH,NCELL,NSEX,BOUNDL,BOUNDH)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NCELL,NSEX
      DOUBLE PRECISION H(NCELL,NSEX),CH(NCELL,NSEX),FH(NCELL,NSEX)
C
C  Subroutine to determine CPS collapsing, following rules in
C  December 22, 1992 draft memorandum.
C
C  H - matrix of estimated CPS Hispanic totals
C  CH - matrix of controls
C  FH - matrix created by CPSCOL to contain collapsing instructions to
C       be passed to COLLAPSE
C
      IC=0
C
C  Loop to 80 is over sex, which is never collapsed.
C
      DO 80 J=1,NSEX
C
C  First fill in 0's consistent with no collapsing.
C
      DO 2 I=1,NCELL
      FH(I,J)=0.
    2 CONTINUE
C
C  Now work backwards from the oldest age group
C
      I=NCELL
    4 CONTINUE
C
C  If the cell does not need collapsing, loop either back to 4 to check
C  additional younger ages or to 8 instead, without checking cell 1 yet.
C
      IF(H(I,J).GT.0) THEN
        R=CH(I,J)/H(I,J)
        IF(R.GE.BOUNDL.AND.R.LE.BOUNDH) THEN
          IF(I.GE.3) THEN
            I=I-1
            GO TO 4
          ELSE
            GO TO 8
          END IF
        END IF
      END IF
C
C  Come here if need collapsing.  Collapsed downward by age until the
C  conditions are met.
C
      T=H(I,J)
      TC=CH(I,J)
      IC=IC+1
      FH(I,J)=IC
      DO 6 II=I-1,1,-1
      FH(II,J)=IC
      T=T+H(II,J)
      TC=TC+CH(II,J)
      IF(T.GT.0.) THEN
C
C  If the conditions are met, either go back to 4 to check younger ages
C  or on to 8
C
        IF(TC/T.GE.BOUNDL.AND.TC/T.LE.BOUNDH) THEN
          IF(II.GE.3) THEN
            I=II-1
            GO TO 4
          ELSE
            GO TO 8
          END IF
        END IF
      END IF
    6 CONTINUE
C
C  If we get to here, we need to begin to collapse back upward, therefore
C  skip this step.
C
      GO TO 10
C
C  If all conditions are met down to the first cell, check it here.
C  If it is OK, we are done with Hispanics.
C
 
    8 CONTINUE
      IF(H(1,J).GT.0.) THEN
        R=CH(1,J)/H(1,J)
        IF(R.GE.BOUNDL.AND.R.LE.BOUNDH)GO TO 18
      END IF
C
C  We come to 10 if we need to collapse the first cell.
C  Collapse upward, keeping together cells already collapsed, although
C  possibly assigning them a new number in FH
C
   10 CONTINUE
      T=H(1,J)
      TC=CH(1,J)
      IC=IC+1
      FH(1,J)=IC
      I=2
   12 CONTINUE
      T=T+H(I,J)
      TC=TC+CH(I,J)
      FOLD=FH(I,J)
      FH(I,J)=IC
      IF(I.LT.NCELL) THEN
        II=I+1
        IF(DABS(FH(II,J)-FOLD).LT..1D0.AND.FH(II,J).GT.0.) THEN
          I=I+1
          GO TO 12
        END IF
      END IF
      IF(T.GT.0) THEN
        IF(TC/T.GE.BOUNDL.AND.TC/T.LE.BOUNDH) GO TO 18
      END IF
      IF(I.LT.NCELL) THEN
        I=I+1
        GO TO 12
      END IF
   18 CONTINUE
   80 CONTINUE
      RETURN
      END
C
      SUBROUTINE CMPCOL(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
  100 FORMAT(' CMPCOL: UNEXPECTED SPECIFICATION')
      IF(DID(1).EQ.0.) THEN
        IF(IVLIST(1).EQ.3) THEN
          IF(IVLIST(2)+IVLIST(3).NE.1.OR.IVLIST(5).NE.3)GO TO 99
          ITOP=3
        ELSE IF(IVLIST(1).EQ.6) THEN
          IF(IVLIST(2)+IVLIST(3).NE.2.OR.IVLIST(2).EQ.1.OR.
     .       IVLIST(3).EQ.1.OR.
     .      (IVLIST(5).NE.3.AND.IVLIST(5).NE.6))GO TO 99
          ITOP=6
        ELSE
          GO TO 99
        END IF
      ELSE
        ITOP=1
      END IF
      NSEX=1
      DO 10 I=1,ITOP
      J=DIMPNT(I)+1
      JJ=DIMX(J-1)
      K=0
      DO 7 IJ=1,JJ
      IF(DIMX(J).GT.1) THEN
        K=K+1
        IF(K.EQ.1) THEN
          IF(I.EQ.1) THEN
            NCELL=DIMX(J)
          ELSE
            IF(DIMX(J).NE.NCELL)GO TO 99
          END IF
        ELSE IF(K.EQ.2) THEN
          IF(DIMX(J).NE.2)GO TO 99
          IF(I.EQ.1)NSEX=2
        ELSE
          GO TO 99
        END IF
      END IF
      J=J+1
    7 CONTINUE
      IF(I.GT.1) THEN
        IF(K.GT.2)GO TO 99
        IF((NSEX.EQ.1.AND.K.EQ.2).OR.(NSEX.EQ.2.AND.K.EQ.1))GO TO 99
      END IF
   10 CONTINUE
      J=IVLIST(4)
      IF(IVLIST(1).EQ.3) THEN
        CALL CPSCL8(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3)),DX(DXPNT(4)),
     .    NCELL,NSEX,DX(J),DX(J+1),DX(J+2))
      ELSE IF(IVLIST(5).EQ.3) THEN
        CALL CPSCL9(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3)),DX(DXPNT(4)),
     .              DX(DXPNT(5)),DX(DXPNT(6)),DX(DXPNT(7)),DX(DXPNT(8)),
     .    NCELL,NSEX,DX(J),DX(J+1),DX(J+2),DX(J),DX(J+1),DX(J+2))
      ELSE
        CALL CPSCL9(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3)),DX(DXPNT(4)),
     .              DX(DXPNT(5)),DX(DXPNT(6)),DX(DXPNT(7)),DX(DXPNT(8)),
     .    NCELL,NSEX,DX(J),DX(J+1),DX(J+2),DX(J+3),DX(J+4),DX(J+5))
      END IF
      RETURN
   99 CONTINUE
      WRITE(U6,100)
      IERROR=1
      RETURN
      END
C
      SUBROUTINE CPSCL8(H,CH,UNH,FH,NCELL,NSEX,UNMIN,FLOW,FHIGH)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NCELL,NSEX
      DOUBLE PRECISION H(NCELL,NSEX),CH(NCELL,NSEX),UNH(NCELL,NSEX),
     .  FH(NCELL,NSEX),UNMIN,FLOW,FHIGH
C
C  Subroutine to determine CPS composite collapsing.
C
C  H - matrix of estimated CPS Hispanic totals
C  CH - matrix of controls
C  UNH - matrix of unweighted counts
C  FH - matrix created by CPSCOL to contain collapsing instructions to
C       be passed to COLLAPSE
C  MINIMM - minimum not to collapse
C  FLOW - minimum acceptable factor
C  FHIGH - maximum acceptable factor
C
      IC=0
C
C  Loop to 80 is over sex, which is never collapsed.
C
      DO 80 J=1,NSEX
C
C  First fill in 0's consistent with no collapsing.
C
      DO 2 I=1,NCELL
      FH(I,J)=0.
    2 CONTINUE
C
C  Now work backwards from the oldest age group
C
      I=NCELL
    4 CONTINUE
C
C  If the cell does not need collapsing, loop either back to 4 to check
C  additional younger ages or to 8 instead, without checking cell 1 yet.
C
      IF(H(I,J).GT.0.AND.UNH(I,J).GT.UNMIN-.5D0) THEN
        R=CH(I,J)/H(I,J)
        IF(R.GE.FLOW.AND.R.LE.FHIGH) THEN
          IF(I.GE.3) THEN
            I=I-1
            GO TO 4
          ELSE
            GO TO 8
          END IF
        END IF
      END IF
C
C  Come here if need collapsing.  Collapsed downward by age until the
C  conditions are met.
C
      T=H(I,J)
      TC=CH(I,J)
      TUN=UNH(I,J)
      IC=IC+1
      FH(I,J)=IC
      DO 6 II=I-1,1,-1
      FH(II,J)=IC
      T=T+H(II,J)
      TC=TC+CH(II,J)
      TUN=TUN+UNH(II,J)
      IF(T.GT.0..AND.TUN.GT.UNMIN-.5D0) THEN
C
C  If the conditions are met, either go back to 4 to check younger ages
C  or on to 8
C
        IF(TC/T.GE.FLOW.AND.TC/T.LE.FHIGH) THEN
          IF(II.GE.3) THEN
            I=II-1
            GO TO 4
          ELSE
            GO TO 8
          END IF
        END IF
      END IF
    6 CONTINUE
C
C  If we get to here, we need to begin to collapse back upward, therefore
C  skip this step.
C
      GO TO 10
C
C  If all conditions are met down to the first cell, check it here.
C  If it is OK, we are done with Hispanics.
C
 
    8 CONTINUE
      IF(H(1,J).GT.0.AND.UNH(1,J).GT.UNMIN-.5D0) THEN
        R=CH(1,J)/H(1,J)
        IF(R.GE.FLOW.AND.R.LE.FHIGH)GO TO 18
      END IF
C
C  We come to 10 if we need to collapse the first cell.
C  Collapse upward, keeping together cells already collapsed, although
C  possibly assigning them a new number in FH
C
   10 CONTINUE
      T=H(1,J)
      TC=CH(1,J)
      TUN=UNH(1,J)
      IC=IC+1
      FH(1,J)=IC
      I=2
   12 CONTINUE
      T=T+H(I,J)
      TC=TC+CH(I,J)
      TUN=TUN+UNH(I,J)
      FOLD=FH(I,J)
      FH(I,J)=IC
      IF(I.LT.NCELL) THEN
        II=I+1
        IF(DABS(FH(II,J)-FOLD).LT..1D0.AND.FH(II,J).GT.0.) THEN
          I=I+1
          GO TO 12
        END IF
      END IF
      IF(T.GT.0.AND.TUN.GT.UNMIN-.5D0) THEN
        IF(TC/T.GE.FLOW.AND.TC/T.LE.FHIGH) GO TO 18
      END IF
      IF(I.LT.NCELL) THEN
        I=I+1
        GO TO 12
      END IF
   18 CONTINUE
   80 CONTINUE
      RETURN
      END
C
      SUBROUTINE CPSCL9(P,CP,UNP,H,CH,UNH,FP,FH,NCELL,NSEX,UNMIN1,FLOW1,
     . FHIGH1,UNMIN2,FLOW2,FHIGH2)
C
C  Subroutine to determine revised CPS composite collapsing, first
C  looking for any collapsing for employed, which should be rare.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NCELL,NSEX
      DOUBLE PRECISION P(NCELL,NSEX),CP(NCELL,NSEX),UNP(NCELL,NSEX),
     .  H(NCELL,NSEX),CH(NCELL,NSEX),UNH(NCELL,NSEX),FP(NCELL,NSEX),
     .  FH(NCELL,NSEX),UNMIN1,FLOW1,FHIGH1,UNMIN2,FLOW2,FHIGH2
C
C  H - matrix of estimated CPS Hispanic totals
C  CH - matrix of controls
C  UNH - matrix of unweighted counts
C  FH - matrix created by CPSCOL to contain collapsing instructions to
C       be passed to COLLAPSE
C  MINIMM - minimum not to collapse
C  FLOW - minimum acceptable factor
C  FHIGH - maximum acceptable factor
C
      IC=0
C
C  Loop to 20 is over sex, which is never collapsed.
C
      DO 20 J=1,NSEX
C
C  First fill in 0's consistent with no collapsing.
C
      DO 2 I=1,NCELL
      FP(I,J)=0.
    2 CONTINUE
C
C  Now work backwards from the oldest age group
C
      I=NCELL
    4 CONTINUE
C
C  If the cell does not need collapsing, loop either back to 4 to check
C  additional younger ages or to 8 instead, without checking cell 1 yet.
C
      IF(P(I,J).GT.0.AND.UNP(I,J).GT.UNMIN1-.5D0) THEN
        R=CP(I,J)/P(I,J)
        IF(R.GE.FLOW1.AND.R.LE.FHIGH1) THEN
          IF(I.GE.3) THEN
            I=I-1
            GO TO 4
          ELSE
            GO TO 8
          END IF
        END IF
      END IF
C
C  Come here if need collapsing.  Collapsed downward by age until the
C  conditions are met.
C
      T=P(I,J)
      TC=CP(I,J)
      TUN=UNP(I,J)
      IC=IC+1
      FP(I,J)=IC
      DO 6 II=I-1,1,-1
      FP(II,J)=IC
      T=T+P(II,J)
      TC=TC+CP(II,J)
      TUN=TUN+UNP(II,J)
      IF(T.GT.0..AND.TUN.GT.UNMIN1-.5D0) THEN
C
C  If the conditions are met, either go back to 4 to check younger ages
C  or on to 8
C
        IF(TC/T.GE.FLOW1.AND.TC/T.LE.FHIGH1) THEN
          IF(II.GE.3) THEN
            I=II-1
            GO TO 4
          ELSE
            GO TO 8
          END IF
        END IF
      END IF
    6 CONTINUE
C
C  If we get to here, we need to begin to collapse back upward, therefore
C  skip this step.
C
      GO TO 10
C
C  If all conditions are met down to the first cell, check it here.
C  If it is OK, we are done.
C
 
    8 CONTINUE
      IF(P(1,J).GT.0.AND.UNP(1,J).GT.UNMIN1-.5D0) THEN
        R=CP(1,J)/P(1,J)
        IF(R.GE.FLOW1.AND.R.LE.FHIGH1)GO TO 18
      END IF
C
C  We come to 10 if we need to collapse the first cell.
C  Collapse upward, keeping together cells already collapsed, although
C  possibly assigning them a new number in FH.
C
   10 CONTINUE
      T=P(1,J)
      TC=CP(1,J)
      TUN=UNP(1,J)
      IC=IC+1
      FP(1,J)=IC
      I=2
   12 CONTINUE
      T=T+P(I,J)
      TC=TC+CP(I,J)
      TUN=TUN+UNP(I,J)
      FOLD=FP(I,J)
      FP(I,J)=IC
      IF(I.LT.NCELL) THEN
        II=I+1
        IF(DABS(FP(II,J)-FOLD).LT..1D0.AND.FP(II,J).GT.0.) THEN
          I=I+1
          GO TO 12
        END IF
      END IF
      IF(T.GT.0.AND.TUN.GT.UNMIN1-.5D0) THEN
        IF(TC/T.GE.FLOW1.AND.TC/T.LE.FHIGH1) GO TO 18
      END IF
      IF(I.LT.NCELL) THEN
        I=I+1
        GO TO 12
      END IF
   18 CONTINUE
   20 CONTINUE
C
      DO 50 J=1,NSEX
C
C  First fill FH with the results from FP
C
      DO 22 I=1,NCELL
      FH(I,J)=FP(I,J)
   22 CONTINUE
C
C  Now work backwards from the oldest age group
C
      I=NCELL
   34 CONTINUE
C
C  If the cell does not need collapsing, loop either back to 4 to check
C  additional younger ages or to 8 instead, without checking cell 1 yet.
C
      IF(H(I,J).GT.0.AND.UNH(I,J).GT.UNMIN2-.5D0.AND.FH(I,J).EQ.0.) THEN
        R=CH(I,J)/H(I,J)
        IF(R.GE.FLOW2.AND.R.LE.FHIGH2) THEN
          IF(I.GE.3) THEN
            I=I-1
            GO TO 34
          ELSE
            GO TO 38
          END IF
        END IF
      END IF
C
C  Come here if need collapsing.  Collapsed downward by age until the
C  conditions are met.
C
      T=H(I,J)
      TC=CH(I,J)
      TUN=UNH(I,J)
      IC=IC+1
      FH(I,J)=IC
      DO 36 II=I-1,1,-1
      FH(II,J)=IC
      T=T+H(II,J)
      TC=TC+CH(II,J)
      TUN=TUN+UNH(II,J)
      IF(T.GT.0..AND.TUN.GT.UNMIN2-.5D0) THEN
C
C  If the conditions are met, either go back to 4 to check younger ages
C  or on to 8
C
        K=0
        IF(FP(II,J).EQ.0) THEN
          K=1
        ELSE IF(II.EQ.1) THEN
          K=1
        ELSE IF(FP(II,J).NE.FP(II-1,J)) THEN
          K=1
        END IF
        IF(TC/T.GE.FLOW2.AND.TC/T.LE.FHIGH2.AND.K.EQ.1) THEN
          IF(II.GE.3) THEN
            I=II-1
            GO TO 34
          ELSE
            GO TO 38
          END IF
        END IF
      END IF
   36 CONTINUE
C
C  If we get to here, we need to begin to collapse back upward, therefore
C  skip this step.
C
      GO TO 40
C
C  If all conditions are met down to the first cell, check it here.
C  If it is OK, we are done.
C
 
   38 CONTINUE
      IF(H(1,J).GT.0.AND.UNH(1,J).GT.UNMIN2-.5D0.AND.FH(1,J).EQ.0.) THEN
        R=CH(1,J)/H(1,J)
        IF(R.GE.FLOW2.AND.R.LE.FHIGH2)GO TO 48
      END IF
C
C  We come to 40 if we need to collapse the first cell.
C  Collapse upward, keeping together cells already collapsed, although
C  possibly assigning them a new number in FH
C
   40 CONTINUE
      T=H(1,J)
      TC=CH(1,J)
      TUN=UNH(1,J)
      IC=IC+1
      FH(1,J)=IC
      I=2
   42 CONTINUE
      T=T+H(I,J)
      TC=TC+CH(I,J)
      TUN=TUN+UNH(I,J)
      FOLD=FH(I,J)
      FH(I,J)=IC
      IF(I.LT.NCELL) THEN
        II=I+1
        IF(DABS(FH(II,J)-FOLD).LT..1D0.AND.FH(II,J).GT.0.) THEN
          I=I+1
          GO TO 42
        END IF
      END IF
      IF(T.GT.0.AND.TUN.GT.UNMIN2-.5D0) THEN
        IF(TC/T.GE.FLOW2.AND.TC/T.LE.FHIGH2) GO TO 48
      END IF
      IF(I.LT.NCELL) THEN
        I=I+1
        GO TO 42
      END IF
   48 CONTINUE
   50 CONTINUE
      RETURN
      END
C
      SUBROUTINE CPSCHL(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
  100 FORMAT(' CPSCHILDCOL: UNEXPECTED SPECIFICATION')
      IF(IFIRST.EQ.1) THEN
        IF(IVLIST(1).NE.2.OR.IVLIST(2)+IVLIST(3).NE.1)GO TO 99
        DO 10 I=1,3
        J=DIMPNT(I)+1
        JJ=DIMX(J-1)
        K=0
        DO 7 IJ=1,JJ
        IF(DIMX(J).GT.1) THEN
          K=K+1
          IF(K.EQ.1) THEN
            IF(DIMX(J).NE.4)GO TO 99
          ELSE IF(K.EQ.2) THEN
            IF(DIMX(J).NE.2)GO TO 99
          ELSE
            GO TO 99
          END IF
        END IF
        J=J+1
    7   CONTINUE
        IF(K.NE.2)GO TO 99
   10   CONTINUE
      END IF
      CALL CPSCL3(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3)))
      RETURN
   99 CONTINUE
      WRITE(U6,100)
      IERROR=1
      RETURN
      END
      SUBROUTINE CPSCL3(H,CH,FH)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION H(4,2),CH(4,2),FH(4,2)
C
C  Subroutine to determine CPS collapsing for Hispanic and
C  Other Races children, following rules in
C  December 22, 1992 draft memorandum.
C
C  H - matrix of estimated CPS Hispanic totals
C  CH - matrix of controls
C  FH - matrix created by CPSCOL to contain collapsing instructions to
C       be passed to COLLAPSE
C
C  Fill in initial collapsing by sex of 14- and 15-year olds.
C  Use 100, 101, etc., to fill collapsing matrix, to allow later
C  GLUEing of these collapsing flags with those for adults.
C
      DO 2 J=1,2
      FH(1,J)=0.
      FH(2,J)=0.
      FH(3,J)=1.D2
      FH(4,J)=1.01D2
    2 CONTINUE
      TC=CH(4,1)+CH(4,2)
      T=H(4,1)+H(4,2)
      IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
C
C  Collapsing for 15-year olds
C
        FH(4,1)=1.D2
        FH(4,2)=1.D2
        TC=TC+CH(3,1)+CH(3,2)
        T=T+H(3,1)+H(3,2)
        IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
          FH(2,1)=1.D2
          FH(2,2)=1.D2
          TC=TC+CH(2,1)+CH(2,2)
          T=T+H(2,1)+H(2,2)
          IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
            FH(1,1)=1.D2
            FH(1,2)=1.D2
          END IF
        END IF
      ELSE
C
C  Collapsing for 14-year olds
C
        TC=CH(3,1)+CH(3,2)
        T=H(3,1)+H(3,2)
        IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
          FH(2,1)=1.D2
          FH(2,2)=1.D2
          TC=TC+CH(2,1)+CH(2,2)
          T=T+H(2,1)+H(2,2)
          IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
            FH(1,1)=1.D2
            FH(1,2)=1.D2
            TC=TC+CH(1,1)+CH(1,2)
            T=T+H(1,1)+H(1,2)
            IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
              FH(4,1)=1.D2
              FH(4,2)=1.D2
            END IF
          END IF
        END IF
      END IF
C
C  If not already collapsed, check collapsing for 6-13 year olds
C
      DO 20 IALTER=1,2
      I=3-IALTER
      DO 15 J=1,2
      IF(FH(I,J).LE.0.) THEN
        TC=CH(I,J)
        T=H(I,J)
        IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
C
C  If the cell fails, first check to see if the cell
C  for the opposite age is already collapsed
C  (possible for i=1, if i=2 already collapsed with
C  i=3).  If not already collapsed, collapse cells (i,j) and
C  (ialter,j).
C
          IF(FH(IALTER,J).LE.0.D0) THEN
            FH(I,J)=1.01D2+DBLE(FLOAT(2*I+J))
            FH(IALTER,J)=FH(I,J)
            TC=TC+CH(IALTER,J)
            T=T+H(IALTER,J)
C
C  Now check if further collapsing of entire 0-13 group
C  is required.
C
            IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
              JALTER=3-J
              FH(1,JALTER)=FH(I,J)
              FH(2,JALTER)=FH(I,J)
              TC=TC+CH(1,JALTER)+CH(2,JALTER)
              T=T+H(1,JALTER)+H(2,JALTER)
C
C  Check if 0-13 now needs to be collapsed with 14 or 14-15
C
              IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
                FH(1,1)=1.D2
                FH(2,1)=1.D2
                FH(1,2)=1.D2
                FH(2,2)=1.D2
C
C  If 0-14 collapsed, do final check to see whether should
C  now collapse with 15
C
                IF(DABS(FH(4,1)-FH(3,1)).GT..1D-6) THEN
                  TC=TC+CH(3,1)+CH(3,2)
                  T=T+H(3,1)+H(3,2)
                  IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
                    FH(4,1)=1.D2
                    FH(4,2)=1.D2
                  END IF
                END IF
              END IF
            END IF
          ELSE
C
C  Consider case of i=1 where i=2 is already collapsed.
C  First, attempt collapse of 0-5 across sex.
C
            FH(1,1)=1.02D2
            FH(1,2)=1.02D2
            TC=CH(1,1)+CH(1,2)
            T=H(1,1)+H(1,2)
            IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
              FH(1,1)=1.D2
              FH(1,2)=1.D2
C
C  The only question: do we still have to consider a
C  collapse with age 15?
C
              IF(DABS(FH(4,1)-FH(3,1)).GT..1D-6) THEN
                TC=CH(1,1)+CH(2,1)+CH(3,1)
     .             +CH(1,2)+CH(2,2)+CH(3,2)
                T=H(1,1)+H(2,1)+H(3,1)
     .           +H(1,2)+H(2,2)+H(3,2)
                IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
                  FH(4,1)=1.D2
                  FH(4,2)=1.D2
                END IF
              END IF
            END IF
          END IF
        END IF
      END IF
   15 CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE OCPSCH(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
  100 FORMAT(' CPSCHILDCOL: UNEXPECTED SPECIFICATION')
      IF(IFIRST.EQ.1) THEN
        IF(IVLIST(1).NE.2.OR.IVLIST(2)+IVLIST(3).NE.1)GO TO 99
        DO 10 I=1,3
        J=DIMPNT(I)+1
        JJ=DIMX(J-1)
        K=0
        DO 7 IJ=1,JJ
        IF(DIMX(J).GT.1) THEN
          K=K+1
          IF(K.EQ.1) THEN
            IF(DIMX(J).NE.4)GO TO 99
          ELSE IF(K.EQ.2) THEN
            IF(DIMX(J).NE.2)GO TO 99
          ELSE
            GO TO 99
          END IF
        END IF
        J=J+1
    7   CONTINUE
        IF(K.NE.2)GO TO 99
   10   CONTINUE
      END IF
      IF(IVLIST(5).GE.1) THEN
        FLOW=DX(IVLIST(4))
        IF(IVLIST(5).GE.2) THEN
          FHIGH=DX(IVLIST(4)+1)
        ELSE
          FHIGH=2.D0
        END IF
      ELSE
        FLOW=.6D0
        FHIGH=2.D0
      END IF
      CALL CPSCL7(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3)),FLOW,FHIGH)
      RETURN
   99 CONTINUE
      WRITE(U6,100)
      IERROR=1
      RETURN
      END
      SUBROUTINE CPSCL7(H,CH,FH,FLOW,FHIGH)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION H(4,2),CH(4,2),FH(4,2),FLOW,FHIGH
C
C  Subroutine to determine CPS collapsing for Hispanic and
C  Other Races children, for use with 1993 March Supplement,
C  and possibly other historic CPS data files.
C
C  H - matrix of estimated CPS Hispanic totals
C  CH - matrix of controls
C  FH - matrix created by CPSCOL to contain collapsing instructions to
C       be passed to COLLAPSE
C
C  Fill in initial collapsing by sex of 14- and 15-year olds.
C  Use 100, 101, etc., to fill collapsing matrix, to allow later
C  GLUEing of these collapsing flags with those for adults.
C
      DO 2 J=1,2
      FH(1,J)=0.
      FH(2,J)=0.
      FH(3,J)=1.D2
      FH(4,J)=1.01D2
    2 CONTINUE
      TC=CH(4,1)+CH(4,2)
      T=H(4,1)+H(4,2)
      IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN
C
C  Collapsing for 15-year olds
C
        FH(4,1)=1.D2
        FH(4,2)=1.D2
        TC=TC+CH(3,1)+CH(3,2)
        T=T+H(3,1)+H(3,2)
        IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN
          FH(2,1)=1.D2
          FH(2,2)=1.D2
          TC=TC+CH(2,1)+CH(2,2)
          T=T+H(2,1)+H(2,2)
          IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN
            FH(1,1)=1.D2
            FH(1,2)=1.D2
          END IF
        END IF
      ELSE
C
C  Collapsing for 14-year olds, which collapses up to 15 first
C
        TC=CH(3,1)+CH(3,2)
        T=H(3,1)+H(3,2)
        IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN
          FH(3,1)=1.01D2
          FH(3,2)=1.01D2
          TC=TC+CH(4,1)+CH(4,2)
          T=T+H(4,1)+H(4,2)
          IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN
            FH(2,1)=1.01D2
            FH(2,2)=1.01D2
            TC=TC+CH(2,1)+CH(2,2)
            T=T+H(2,1)+H(2,2)
            IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN
              FH(1,1)=1.01D2
              FH(1,2)=1.01D2
            END IF
          END IF
        END IF
      END IF
C
C  If not already collapsed, check collapsing for 6-13 year olds
C
      DO 20 IALTER=1,2
      I=3-IALTER
      DO 15 J=1,2
      IF(FH(I,J).LE.0.) THEN
        TC=CH(I,J)
        T=H(I,J)
        IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN
C
C  If the cell fails, first check to see if the cell
C  for the opposite age is already collapsed
C  (possible for i=1, if i=2 already collapsed with
C  i=3).  If not already collapsed, collapse cells (i,j) and
C  (ialter,j).
C
          IF(FH(IALTER,J).LE.0.D0) THEN
            FH(I,J)=1.01D2+DBLE(FLOAT(2*I+J))
            FH(IALTER,J)=FH(I,J)
            TC=TC+CH(IALTER,J)
            T=T+H(IALTER,J)
C
C  Now check if further collapsing of entire 0-13 group
C  is required.
C
            IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN
              JALTER=3-J
              FH(1,JALTER)=FH(I,J)
              FH(2,JALTER)=FH(I,J)
              TC=TC+CH(1,JALTER)+CH(2,JALTER)
              T=T+H(1,JALTER)+H(2,JALTER)
C
C  Check if 0-13 now needs to be collapsed with 14 or 14-15
C
              IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN
                FH(1,1)=1.D2
                FH(2,1)=1.D2
                FH(1,2)=1.D2
                FH(2,2)=1.D2
C
C  If 0-14 collapsed, do final check to see whether should
C  now collapse with 15
C
                IF(DABS(FH(4,1)-FH(3,1)).GT..1D-6) THEN
                  TC=TC+CH(3,1)+CH(3,2)
                  T=T+H(3,1)+H(3,2)
                  IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN
                    FH(4,1)=1.D2
                    FH(4,2)=1.D2
                  END IF
                END IF
              END IF
            END IF
          ELSE
C
C  Consider case of i=1 where i=2 is already collapsed.
C  First, attempt collapse of 0-5 across sex.
C
            FH(1,1)=1.02D2
            FH(1,2)=1.02D2
            TC=CH(1,1)+CH(1,2)
            T=H(1,1)+H(1,2)
            IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN
              FH(1,1)=1.D2
              FH(1,2)=1.D2
C
C  The only question: do we still have to consider a
C  collapse with age 15?
C
              IF(DABS(FH(4,1)-FH(3,1)).GT..1D-6) THEN
                TC=CH(1,1)+CH(2,1)+CH(3,1)
     .             +CH(1,2)+CH(2,2)+CH(3,2)
                T=H(1,1)+H(2,1)+H(3,1)
     .           +H(1,2)+H(2,2)+H(3,2)
                IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN
                  FH(4,1)=1.D2
                  FH(4,2)=1.D2
                END IF
              END IF
            END IF
          END IF
        END IF
      END IF
   15 CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE NCPSCH(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
  100 FORMAT(' CPSCHILDCOL: UNEXPECTED SPECIFICATION')
      IF(IFIRST.EQ.1) THEN
        IF(IVLIST(1).NE.2.OR.IVLIST(2)+IVLIST(3).NE.1)GO TO 99
        DO 10 I=1,3
        J=DIMPNT(I)+1
        JJ=DIMX(J-1)
        K=0
        DO 7 IJ=1,JJ
        IF(DIMX(J).GT.1) THEN
          K=K+1
          IF(K.EQ.1) THEN
            IF(DIMX(J).NE.4)GO TO 99
          ELSE IF(K.EQ.2) THEN
            IF(DIMX(J).NE.2)GO TO 99
          ELSE
            GO TO 99
          END IF
        END IF
        J=J+1
    7   CONTINUE
        IF(K.NE.2)GO TO 99
   10   CONTINUE
      END IF
      CALL CPSCL5(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3)))
      RETURN
   99 CONTINUE
      WRITE(U6,100)
      IERROR=1
      RETURN
      END
      SUBROUTINE CPSCL5(H,CH,FH)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION H(4,2),CH(4,2),FH(4,2)
C
C  Subroutine to determine CPS collapsing for Hispanic and
C  Other Races children, for use starting in January, 1994
C  Children age 15 are always collapsed into a single cell,
C     but not collapsed further.
C
C  H - matrix of estimated CPS Hispanic (or other races) totals
C  CH - matrix of controls
C  FH - matrix created by CPSCOL to contain collapsing instructions to
C       be passed to COLLAPSE
C
C  Fill in initial collapsing by sex of 14- and 15-year olds.
C  Use 100, 101, etc., to fill collapsing matrix, to allow later
C  GLUEing of these collapsing flags with those for adults.
C  Collapsing of age 15 is accomplished by filling in 101.
C
      DO 2 J=1,2
      FH(1,J)=0.
      FH(2,J)=0.
      FH(3,J)=1.D2
      FH(4,J)=1.01D2
    2 CONTINUE
C
C  Collapsing for 14-year olds
C
      TC=CH(3,1)+CH(3,2)
      T=H(3,1)+H(3,2)
      IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
C
C  If 14-year olds require collapsing, collapse first with 13-year
C  olds, collapsed across sex.
C
        FH(2,1)=1.D2
        FH(2,2)=1.D2
C
C  Check whether the combined 6-13/14 cell requires collapsing
C
        TC=TC+CH(2,1)+CH(2,2)
        T=T+H(2,1)+H(2,2)
        IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
C
C  0-14 become collapsed into a single cell here.  No further
C  checks are performed.
C
          FH(1,1)=1.D2
          FH(1,2)=1.D2
        END IF
      END IF
C
C  If not already collapsed, check collapsing for 6-13 year olds
C  Two situations are checked:
C     IALTER =1   I=2 (Thus, the 6-13 group is the first checked.)
C     IALTER =2   I=1
C
      DO 20 IALTER=1,2
      I=3-IALTER
      DO 15 J=1,2
C
C  Checks are performed in this loop only if the cell is not already
C  collapsed.
C
      IF(FH(I,J).LE.0.) THEN
        TC=CH(I,J)
        T=H(I,J)
        IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
C
C  If the cell fails, first check to see if the cell for the
C  opposite age is already collapsed
C  (possible for i=1, if i=2 is already collapsed with
C  i=3, a case handled below).
C  If not already collapsed, collapse cells (i,j) and (ialter,j).
C
          IF(FH(IALTER,J).LE.0.D0) THEN
            FH(I,J)=1.01D2+DBLE(FLOAT(2*I+J))
            FH(IALTER,J)=FH(I,J)
            TC=TC+CH(IALTER,J)
            T=T+H(IALTER,J)
C
C  Now check if the 0-13 cell for the one sex passes, else further
C  collapsing of entire 0-13 group is required.
C
            IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
C
C  JALTER is the proverbial "opposite sex"
C
              JALTER=3-J
              FH(1,JALTER)=FH(I,J)
              FH(2,JALTER)=FH(I,J)
              TC=TC+CH(1,JALTER)+CH(2,JALTER)
              T=T+H(1,JALTER)+H(2,JALTER)
C
C  Check if the single 0-13 cell now needs to be collapsed with 14.
C
              IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
                FH(1,1)=1.D2
                FH(2,1)=1.D2
                FH(1,2)=1.D2
                FH(2,2)=1.D2
              END IF
            END IF
          ELSE
C
C  Consider case of i=1 where i=2 is already collapsed with age 14.
C  First, attempt collapse of 0-5 across sex.
C
            FH(1,1)=1.02D2
            FH(1,2)=1.02D2
            TC=CH(1,1)+CH(1,2)
            T=H(1,1)+H(1,2)
            IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
C
C  If the 0-5 cell requires further collapsing in this case (6-14
C  already collapsed), 0-14 becomes collapsed into a single cell.
C
              FH(1,1)=1.D2
              FH(1,2)=1.D2
            END IF
          END IF
        END IF
      END IF
   15 CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE NPSCHL(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
  100 FORMAT(' NPSCHILDCOL: UNEXPECTED SPECIFICATION')
      IF(IFIRST.EQ.1) THEN
        IF(IVLIST(1).NE.2.OR.IVLIST(2)+IVLIST(3).NE.1)GO TO 99
        DO 10 I=1,3
        J=DIMPNT(I)+1
        JJ=DIMX(J-1)
        K=0
        DO 7 IJ=1,JJ
        IF(DIMX(J).GT.1) THEN
          K=K+1
          IF(K.EQ.1) THEN
            IF(DIMX(J).NE.4)GO TO 99
          ELSE IF(K.EQ.2) THEN
            IF(DIMX(J).NE.2)GO TO 99
          ELSE
            GO TO 99
          END IF
        END IF
        J=J+1
    7   CONTINUE
        IF(K.NE.2)GO TO 99
   10   CONTINUE
      END IF
      CALL CPSCL6(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3)))
      RETURN
   99 CONTINUE
      WRITE(U6,100)
      IERROR=1
      RETURN
      END
      SUBROUTINE CPSCL6(H,CH,FH)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION H(4,2),CH(4,2),FH(4,2)
C
C  Subroutine to determine CPS collapsing for Hispanic and
C  Other Races children, following rules in
C  December 22, 1992 draft memorandum.
C
C  H - matrix of estimated CPS Hispanic totals
C  CH - matrix of controls
C  FH - matrix created by CPSCOL to contain collapsing instructions to
C       be passed to COLLAPSE
C
C  Fill in initial collapsing by sex of 14- and 15-year olds.
C  Use 100, 101, etc., to fill collapsing matrix, to allow later
C  GLUEing of these collapsing flags with those for adults.
C
      FH(3,1)=1.D2
      FH(4,1)=1.D2
      FH(3,2)=1.03D2
      FH(4,2)=1.03D2
C
C  For the New Parallel Survey (MLS), never collapse across sex.
C  Therefore, the primary loop is over sex (index J).
C
      DO 20 J=1,2
      FH(1,J)=0.
      FH(2,J)=0.
C
C  First, check if the 14+15 year old cell needs collapsing.
C
      TC=CH(3,J)+CH(4,J)
      T=H(3,J)+H(4,J)
      IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
C
C  Collapsing for 14/15-year olds
C
        FH(2,J)=FH(4,J)
        TC=TC+CH(2,J)
        T=T+H(2,J)
C
C  Check if the 6-15 cell stands - if not, collapse with 0-6 and
C  do no further checks.
C
        IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
          FH(1,J)=FH(4,J)
        END IF
      ELSE
C
C  Collapsing for 6-13-year olds
C
        TC=CH(2,J)
        T=H(2,J)
        IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
          FH(2,J)=FH(4,J)+1.D0
          FH(1,J)=FH(2,J)
          TC=TC+CH(1,J)
          T=T+H(1,J)
          IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
            FH(2,J)=FH(4,J)
            FH(1,J)=FH(4,J)
          END IF
        END IF
      END IF
C
C  If not already collapsed, check collapsing for 0-5 year olds
C
      IF(FH(1,J).LE.0.) THEN
        TC=CH(1,J)
        T=H(1,J)
        IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
C
C
C  If 0-5 needs collapsing, then if 6-13 is not already collapsed,
C  collapse there first.
C
          IF(FH(2,J).LE.0.) THEN
            FH(1,J)=FH(4,J)+2.D0
            FH(2,J)=FH(1,J)
            TC=TC+CH(2,J)
            T=T+H(2,J)
            IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN
              FH(1,J)=FH(4,J)
              FH(2,J)=FH(3,J)
            END IF
C
C  If 0-5 needs collapsing, but 6-15 has already been collapsed, then
C  they all become one cell.
C
          ELSE
            FH(1,J)=FH(2,J)
          END IF
        END IF
      END IF
   20 CONTINUE
      RETURN
      END
C
      SUBROUTINE CPSNIC(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
  100 FORMAT(' CPSNICOL: UNEXPECTED SPECIFICATION')
      IF(IFIRST.EQ.1) THEN
        IF(IVLIST(1).NE.2.OR.IVLIST(2)+IVLIST(3).NE.1)GO TO 99
        ITOP=3
      ELSE
        ITOP=1
      END IF
      DO 10 I=1,ITOP
      J=DIMPNT(I)+1
      JJ=DIMX(J-1)
      K=0
      IF(I.EQ.1) THEN
        NCELL=1
      ELSE
        NCELL2=1
      END IF
      DO 7 IJ=1,JJ
      IF(DIMX(J).GT.1) THEN
        K=K+1
        IF(IFIRST.EQ.1) THEN
          IF(K.EQ.1) THEN
            IF(DIMX(J).NE.2)GO TO 99
          ELSE IF(K.EQ.2) THEN
            IF(I.EQ.1) THEN
              IF(DIMX(J).NE.2)GO TO 99
            ELSE
              NCELL2=DIMX(J)
            END IF
          ELSE IF(I.EQ.1) THEN
            NCELL=DIMX(J)*NCELL
          ELSE
            NCELL2=DIMX(J)*NCELL2
          END IF
        ELSE IF(K.GE.3) THEN
          NCELL=DIMX(J)*NCELL
        END IF
      END IF
      J=J+1
    7 CONTINUE
      IF(IFIRST.EQ.1) THEN
        IF(I.EQ.1) THEN
          IF(K.EQ.1)GO TO 99
        ELSE
          IF(NCELL.EQ.1.AND.K.NE.1)GO TO 99
          IF(NCELL.GT.1.AND.K.LT.2)GO TO 99
          IF(NCELL2.NE.NCELL)GO TO 99
        END IF
      END IF
   10 CONTINUE
      CALL CPSCL4(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3)),NCELL)
      RETURN
   99 CONTINUE
      WRITE(U6,100)
      IERROR=1
      RETURN
      END
      SUBROUTINE CPSCL4(W,UNW,F,NCELL)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION W(2,2,*),UNW(2,*),F(2,*)
      LOGICAL NICOLP
C
C  Subroutine to determine CPS collapsing for noninterview
C  adjustment
C
      DO 10 J=1,NCELL
      F(1,J)=0.
      F(2,J)=0.
      NICOLP=.FALSE.
      DO 5 I=1,2
      IF(W(2,I,J).GT.0.AND.W(2,I,J).GE.W(1,I,J))NICOLP=.TRUE.
      IF(UNW(I,J).LT.49.5D0)NICOLP=.TRUE.
    5 CONTINUE
      IF(NICOLP) THEN
        F(1,J)=J
        F(2,J)=J
      END IF
   10 CONTINUE
      RETURN
      END
C
      SUBROUTINE SCNCOL(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
      INTEGER MATSIZ
      EXTERNAL MATSIZ
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
  100 FORMAT(' SCNCOL: UNEXPECTED SPECIFICATION')
C
C  Subroutine for SIPPC_NICOL
C  First old variable: weighted matrix 2 x ncell of interviewed/
C                      noninterviewed households
C  Second old variable: unweighted matrix of ncell counts of
C                      interviewed hh
C  Third old variable: scale values (if no constants)
C  Constants:          scale values (if only 2 old variables)
C  New or modified variable: collapsing matrix.
C
      IF(DID(1).EQ.0.) THEN
        IF(IVLIST(4).NE.0) THEN
          IF(IVLIST(1).NE.2.OR.IVLIST(2)+IVLIST(3).NE.1) GO TO 99
        ELSE
          IF(IVLIST(1).NE.3.OR.IVLIST(2)+IVLIST(3).NE.1) GO TO 99
        END IF
      END IF
      NCELL=MATSIZ(DIMX(DIMPNT(1)),MTYPE(1),MTRAN(1))/2
C
C  On first call, check consistency of dimensions.
C
      IF(DID(1).EQ.0.) THEN
        KK=DIMX(DIMPNT(1))
C
C  Insure that first dimension of first old variable is 2
C
        DO 2 I=1,KK
        IP=DIMX(DIMPNT(I)+I)
        IF(IP.EQ.2)GO TO 3
        IF(IP.NE.1)GO TO 99
    2   CONTINUE
    3   CONTINUE
C
C  Check consistency with other arrays.
C
        DO 10 J=2,IVLIST(1)+1
        IF(MATSIZ(DIMX(DIMPNT(J)),MTYPE(J),MTRAN(J)).NE.NCELL)
     .    GO TO 99
        KK=DIMX(DIMPNT(J))
        IP=1
        DO 5 I=1,KK
        IP2=DIMX(DIMPNT(J)+I)
        IP=IP*IP2
        IF(IP.EQ.NCELL)GO TO 10
    5   CONTINUE
        GO TO 99
   10   CONTINUE
C
C  If constants have been provided, array should have been set aside
C  as twice NCELL
C
        IF(IVLIST(4).NE.0) THEN
          IF(IVLIST(5).NE.2*NCELL)GO TO 99
        END IF
      END IF
      IF(IVLIST(5).EQ.0) THEN
        NXPTDS=NXPTD
        CALL ROOMD(NCELL)
        IVLIST(4)=NXPTDS
        CALL SCNCL2(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3)),DX(DXPNT(4)),
     .    DX(NXPTDS),NCELL)
        NXPTD=NXPTDS
        IVLIST(4)=0
      ELSE
        CALL SCNCL2(DX(DXPNT(1)),DX(DXPNT(2)),DX(IVLIST(4)),
     .    DX(DXPNT(3)),DX(IVLIST(4)+NCELL),NCELL)
      END IF
      RETURN
   99 CONTINUE
      WRITE(U6,100)
      IERROR=1
      RETURN
      END
C
      SUBROUTINE SCNCL2(W,UNWTIN,SVAL,F,SCR,NCELL)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION W(2,NCELL),UNWTIN(NCELL)
      DOUBLE PRECISION F(NCELL)
      DOUBLE PRECISION SVAL(NCELL),SCR(NCELL)
C
      DOUBLE PRECISION MISSNG
      DATA MISSNG/-98765.432109D0/
C
C  Subroutine to determine SIPP NI collapsing, based on scale values
C  and criteria of 30 unweighted interview cases in each cell.
C
C  W - matrix of estimated SIPP totals interview * ncell
C  UNWTIN - unweighted matrix of interviewed households
C  SVAL - ncell scale values
C  F - matrix created by SCNCOL to contain collapsing instructions to
C      be passed to COLLAPSE
C  SCR - working matrix of scale values
C  NCELL - number of cells
C
      IC=0
C
C  First fill in 0's consistent with no collapsing, and copy
C  SVAL into SCR
C
      DO 2 I=1,NCELL
      F(I)=0.
      IF(DABS(SVAL(I)-MISSNG).LE..1D-06) THEN
        SCR(I)=0.
      ELSE
        SCR(I)=SVAL(I)
      END IF
    2 CONTINUE
C
C  Next, establish collapsing if already implied by scale values.  If
C  all cells have unique scale values, no collapsing will occur here.
C
      DO 8 I=1,NCELL-1
      IF(F(I).GT.0.)GO TO 8
      DO 5 II=I+1,NCELL
      IF(DABS(SCR(I)-SCR(II)).LT..1D-02) THEN
        IF(F(I).EQ.0) THEN
          IC=IC+1
          F(I)=IC
        END IF
        F(II)=F(I)
      END IF
    5 CONTINUE
    8 CONTINUE
C
C  There is a major loop to process the cells in increasing order
C  of scale value, returning to 10 each time to find the next cell,
C  after continuing to collapse the current case until the conditions
C  are met before proceeding to the next i.
C
      SVLAST=-1.D0
   10 CONTINUE
      I=0
      DO 12 II=1,NCELL
      IF(SCR(II).GT.SVLAST+.1D-2) THEN
        IF(I.EQ.0) THEN
          I=II
        ELSE
          IF(SCR(II).LT.SCR(I)-.1D-2) THEN
            I=II
          END IF
        END IF
      END IF
   12 CONTINUE
      IF(I.EQ.0) THEN
        GO TO 80
      ELSE
        SVLAST=SCR(I)
      END IF
C
C  If the cell has not been previously collapsed, check whether
C  it meets both conditions by itself.
C
      IF(F(I).EQ.0) THEN
C       IF(W(2,I).GT.0.) THEN
          IF(UNWTIN(I).GE.29.95D0.AND.W(2,I).LE.W(1,I))GO TO 10
C       END IF
      END IF
C
C  Return point if more collapsing is necessary
C
   15 CONTINUE
C
C  First find the index, K, of the closest matching scale value,
C  while summing up the current values to check whether more
C  collapsing is necessary.
C
      K=0
      TOT1=0.
      TOT2=0.
      TOTUN=0.
      DO 20 II=1,NCELL
      IF(DABS(SCR(II)-SCR(I)).GT..1D-02) THEN
        IF(K.EQ.0) THEN
          K=II
        ELSE
          IF(DABS(SCR(II)-SCR(I)).LT.
     .          DABS(SCR(K)-SCR(I))) THEN
            K=II
          ELSE IF(DABS(DABS(SCR(II)-SCR(I))
     .                -DABS(SCR(K) -SCR(I))).LT..1D-2) THEN
            IF(UNWTIN(II).LT.UNWTIN(K)) THEN
              K=II
            END IF
          END IF
        END IF
      ELSE
        TOTUN=TOTUN+UNWTIN(II)
        TOT1=TOT1+W(1,II)
        TOT2=TOT2+W(2,II)
      END IF
   20 CONTINUE
      IF(K.EQ.0)GO TO 80
C     IF(TOT2.GT.0.) THEN
        IF(TOTUN.GE.29.95D0.AND.TOT1.GE.TOT2)GO TO 10
C     END IF
C
C COMPUTE THE NEW SCALE VALUE
C
C     TOTUN=0.
C     TOT1=0.
      TCELL=0.
      TSUM3=0.
      IC=IC+1
      DO 25 II=1,NCELL
      IF(DABS(SCR(II)-SCR(I)).LT..1D-02.OR.
     .   DABS(SCR(II)-SCR(K)).LT..1D-02) THEN
C       TOTUN=TOTUN+UNWTIN(II)
C       TOT1=TOT1+UNWTIN(II)*SCR(II)
        TCELL=TCELL+SCR(II)
        TSUM3=TSUM3+1.D0
        F(II)=IC
      END IF
   25 CONTINUE
C     IF(TOTUN.GT.0) THEN
C       SCR(I)=TOT1/TOTUN
C     ELSE
        SCR(I)=TCELL/TSUM3
C     END IF
C
C  Apply the new scale values and return to 15 to check whether
C  this collapsing was enough or more is needed
C
      DO 30 II=1,NCELL
      IF(DABS(F(II)-F(I)).LT..1D-02) THEN
        SCR(II)=SCR(I)
      END IF
   30 CONTINUE
      GO TO 15
C
C  Restore the scratch array to 0's
C
   80 CONTINUE
C
      DO 82 I=1,NCELL
      SCR(I)=0.
   82 CONTINUE
      RETURN
      END
C
      SUBROUTINE SIPCOL(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
      INTEGER MATSIZ
      EXTERNAL MATSIZ
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
  100 FORMAT(' SIPCOL: UNEXPECTED SPECIFICATION')
      IF(DID(1).EQ.0.) THEN
        IF(IVLIST(1).NE.3.OR.IVLIST(2)+IVLIST(3).NE.1.OR.
     .    IVLIST(4).EQ.0) GO TO 99
      END IF
      DO 1 NCELL=1,IVLIST(5)
      IF(DABS(DX(IVLIST(4)+NCELL-1)).LT..1D0) GO TO 2
    1 CONTINUE
      GO TO 99
    2 CONTINUE
      NCELL=NCELL-1
      IF(NCELL.LE.1)GO TO 99
      IF(NCELL*2.GT.IVLIST(5))GO TO 99
      NROT=MATSIZ(DIMX(DIMPNT(1)),MTYPE(1),MTRAN(1))/NCELL
      IF(DID(1).EQ.0.) THEN
        DO 10 J=1,4
        IF(MATSIZ(DIMX(DIMPNT(J)),MTYPE(J),MTRAN(J)).NE.NROT*NCELL)
     .    GO TO 99
        KK=DIMX(DIMPNT(J))+.05D0
        IP=1
        DO 5 I=1,KK
        IP2=DIMX(DIMPNT(J)+I)+.05D0
        IP=IP*IP2
        IF(IP.EQ.NCELL)GO TO 10
    5   CONTINUE
        GO TO 99
   10   CONTINUE
      END IF
      CALL SIPCL2(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3)),DX(DXPNT(4)),
     . DX(IVLIST(4)),DX(IVLIST(4)+NCELL),NCELL,NROT)
      RETURN
   99 CONTINUE
      WRITE(U6,100)
      IERROR=1
      RETURN
      END
      SUBROUTINE SIPCL2(E,C,UN,F,SVAL,SCR,NCELL,NROT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION E(NCELL,NROT),C(NCELL,NROT),UN(NCELL,NROT)
      DOUBLE PRECISION F(NCELL,NROT)
      DOUBLE PRECISION SVAL(NCELL),SCR(NCELL)
C
C  Subroutine to determine SIPP collapsing, based on scale values and
C  criteria of 35 in each cell.
C
C  E - matrix of estimated SIPP totals
C  C - matrix of controls
C  UN - matrix of unweighted counts
C  F - matrix created by SIPCOL to contain collapsing instructions to
C       be passed to COLLAPSE
C
      IC=0
C
C  Loop to 80 is over rotation, which is never collapsed.
C
      DO 80 J=1,NROT
C
C  First fill in 0's consistent with no collapsing, and copy
C  SVAL into SCR
C
      DO 2 I=1,NCELL
      F(I,J)=0.
      SCR(I)=SVAL(I)
    2 CONTINUE
C
C  Next, establish collapsing if already implied by scale values
C
      DO 8 I=1,NCELL-1
      IF(F(I,J).GT.0.)GO TO 10
      DO 5 II=I+1,NCELL
      IF(DABS(SCR(I)-SCR(II)).LT..1D-02) THEN
        IF(F(I,J).EQ.0) THEN
          IC=IC+1
          F(I,J)=IC
        END IF
        F(II,J)=F(I,J)
      END IF
    5 CONTINUE
    8 CONTINUE
C
C  There is a major loop to process the cells in increasing order
C  of scale value, returning to 10 each time to find the next cell,
C  after continuing to collapse the current case until the conditions
C  are met before proceeding to the next i.
C
      SVLAST=0.
   10 CONTINUE
      I=0
      DO 12 II=1,NCELL
      IF(SCR(II).GT.SVLAST+.1D-2) THEN
        IF(I.EQ.0) THEN
          I=II
        ELSE
          IF(SCR(II).LT.SCR(I)-.1D-2) THEN
            I=II
          END IF
        END IF
      END IF
   12 CONTINUE
      IF(I.EQ.0) THEN
        GO TO 80
      ELSE
        SVLAST=SCR(I)
      END IF
C
C  If the cell has not been previously collapsed, check whether
C  it meets both conditions by itself.
C
      IF(F(I,J).EQ.0) THEN
        IF(E(I,J).GT.0.) THEN
          IF(UN(I,J).GE.35.AND.C(I,J)/E(I,J).LT.2.D0.AND.
     .       C(I,J)/E(I,J).GT..67D0) GO TO 10
        END IF
      END IF
C
C  Return point if more collapsing is necessary
C
   15 CONTINUE
C
C  First find the index, K, of the closest matching scale value,
C  while summing up the current values to check whether more
C  collapsing is necessary.
C
      K=0
      TOT1=0.
      TOT2=0.
      TOTUN=0.
      DO 20 II=1,NCELL
      IF(DABS(SCR(II)-SCR(I)).GT..1D-02) THEN
        IF(K.EQ.0) THEN
          K=II
        ELSE
          IF(DABS(SCR(II)-SCR(I)).LT.
     .          DABS(SCR(K)-SCR(I))) THEN
            K=II
          END IF
        END IF
      ELSE
        TOTUN=TOTUN+UN(II,J)
        TOT1=TOT1+C(II,J)
        TOT2=TOT2+E(II,J)
      END IF
   20 CONTINUE
      IF(K.EQ.0)GO TO 80
      IF(TOT2.GT.0.) THEN
        IF(TOTUN.GE.34.95D0.AND.TOT1/TOT2.GT..67D0.AND.
     .     TOT1/TOT2.LT.2.D0) GO TO 10
      END IF
C
C COMPUTE THE NEW SCALE VALUE
C
      TOTUN=0.
      TOT1=0.
      IC=IC+1
      DO 25 II=1,NCELL
      IF(DABS(SCR(II)-SCR(I)).LT..1D-02.OR.
     .   DABS(SCR(II)-SCR(K)).LT..1D-02) THEN
        TOTUN=TOTUN+UN(II,J)
        TOT1=TOT1+UN(II,J)*SCR(II)
        F(II,J)=IC
      END IF
   25 CONTINUE
      SCR(I)=TOT1/TOTUN
C
C  Apply the new scale values and return to 15 to check whether
C  this collapsing was enough or more is needed
C
      DO 30 II=1,NCELL
      IF(DABS(F(II,J)-F(I,J)).LT..1D-02) THEN
        SCR(II)=SCR(I)
      END IF
   30 CONTINUE
      GO TO 15
   80 CONTINUE
C
C  Restore the scratch array to 0's
C
      DO 82 I=1,NCELL
      SCR(I)=0.
   82 CONTINUE
      RETURN
      END
C
      SUBROUTINE GRIDSC(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
      DOUBLE PRECISION PM(6),B(3)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
  201 FORMAT(1X,' SEARCH NOT DONE')
      IF(IVLIST(1).NE.1.OR.IVLIST(2).NE.1.OR.IVLIST(3).NE.0) THEN
        IERROR=1
        RETURN
      END IF
      Y1=DX(DXPNT(1))
      Y2=DX(DXPNT(1)+1)
      Y3=DX(DXPNT(1)+2)
      X1=DX(DXPNT(2))
      X2=DX(DXPNT(2)+1)
      X3=DX(DXPNT(2)+2)
      YM=(Y1+Y2+Y3)/3.D0
      XM=(X1+X2+X3)/3.D0
      XC1=X1-XM
      XC2=X2-XM
      XC3=X3-XM
      PM(1)=3.D0
      PM(2)=0.D0
      PM(3)=XC1**2+XC2**2+XC3**2
      PM(4)=PM(3)
      PM(5)=XC1**3+XC2**3+XC3**3
      PM(6)=XC1**4+XC2**4+XC3**4
      CALL DPPTRF('U',3,PM,INFO)
      IF(INFO.NE.0) THEN
        WRITE(U6,201)
        IERROR=2
        RETURN
      END IF
      B(1)=0.
      B(2)=XC1*(Y1-YM)+XC2*(Y2-YM)+XC3*(Y3-YM)
      B(3)=XC1*XC1*(Y1-YM)+XC2*XC2*(Y2-YM)+XC3*XC3*(Y3-YM)
      CALL DPPTRS('U',3,1,PM,B,3,INFO)
      ISTEP=0
      R=X3-X1
      IF(B(3).LT.0) THEN
        XBEST=-.5D0*B(2)/B(3)+XM
        IF(XBEST.GE.X1.AND.XBEST.LE.X3) THEN
          DX(DXPNT(2)+1)=XBEST
          XMISS=DABS(X2-XBEST)
          IF(.1D0*R.LT.XMISS) THEN
            XMISS=.1D0*R
          END IF
          IF(XMISS.GT.XBEST) THEN
            DX(DXPNT(2))=0.D0
          ELSE
            DX(DXPNT(2))=XBEST-XMISS
          END IF
          DX(DXPNT(2)+2)=XBEST+XMISS
          ISTEP=1
        END IF
      END IF
      IF(ISTEP.EQ.0) THEN
        IF(Y1.GT.Y3) THEN
          IF(X1.LE.0.) THEN
            DX(DXPNT(2)+1)=.125D0*X2
            DX(DXPNT(2)+2)=.25*X2
          ELSE IF(X1-R.LE.0.) THEN
            DX(DXPNT(2))=0.
            DX(DXPNT(2)+1)=X1
            DX(DXPNT(2)+2)=X2
          ELSE
            DX(DXPNT(2))=X1-R
            DX(DXPNT(2)+1)=X1
          END IF
        ELSE
          DX(DXPNT(2)+1)=X3
          DX(DXPNT(2)+2)=X3+R
        END IF
      END IF
      RETURN
      END
      SUBROUTINE XMEDN(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*),
     . MTYPE(*),MTRAN(*),IX(*),IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      CHARACTER*128 STRING(*)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER MATSIZ
      EXTERNAL MATSIZ
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
  201 FORMAT(1X,' XMEDN ERROR')
      IF(IFIRST.EQ.1) THEN
        NCELL=IVLIST(5)
        IF(IVLIST(1).NE.1.OR.IVLIST(2)+IVLIST(3).NE.1) GO TO 99
        IF(NCELL.LT.2)GO TO 99
        IF(DIMX(DIMPNT(1)).EQ.0) GO TO 99
        IF(DIMX(DIMPNT(1)+1).NE.NCELL) GO TO 99
        DO 1 I=1,NCELL-1
        IF(DX(IVLIST(4)+I-1).GE.DX(IVLIST(4)+I))GO TO 99
    1   CONTINUE
      ELSE
        NCELL=DIMX(DIMPNT(1)+1)
      END IF
      I=MATSIZ(DIMX(DIMPNT(1)),MTYPE(1),MTRAN(1))
      NROW=I/NCELL
      IF(IFIRST.EQ.1) THEN
        IF(NROW*NCELL.NE.I)GO TO 99
        IF(MATSIZ(DIMX(DIMPNT(2)),MTYPE(2),MTRAN(2)).NE.NROW)GO TO 99
        I=NCELL+4*NROW
        IVLIST(5)=I
        K=IVLIST(4)
        KK=NXPTD
        IVLIST(4)=NXPTD
        CALL ROOMD(I)
        DO 2 I=1,NCELL
        DX(KK)=DX(K)
        K=K+1
        KK=KK+1
    2   CONTINUE
      END IF
      K=IVLIST(4)+NCELL
      CALL XMEDN2(DID(1),DX(DXPNT(1)),DX(DXPNT(2)),DX(IVLIST(4)),DX(K),
     .  NCELL,NROW,IX,IVLIST(7))
      RETURN
   99 CONTINUE
      WRITE(U6,201)
      IERROR=1
      RETURN
      END
      SUBROUTINE XMEDN2(DFLAG,DA,DMED,DINTRV,DSV,NCELL,NROW,IX,IV7)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION DA(NCELL,NROW),DMED(NROW),DINTRV(NROW)
      DOUBLE PRECISION DSV(4,NROW)
      DOUBLE PRECISION MISSNG
      INTEGER IX(3)
      DATA MISSNG/-98765.432109D0/
      IF(IV7.EQ.0) THEN
        PERCNL=.5D0
      ELSE
        IF(IX(1).GE.1.AND.IX(1).LE.99) THEN
          PERCNL=DBLE(FLOAT(IX(1)))/1.D2
        ELSE
          PERCNL=.5D0
        END IF
      END IF
      IF(DFLAG.EQ.0.) THEN
        DO 10 IR=1,NROW
        SM=0.D0
        DMED(IR)=MISSNG
        DSV(1,IR)=MISSNG
        DO 1 I=1,NCELL
        SM=SM+DA(I,IR)
    1   CONTINUE
        IF(SM.LE.0.)GO TO 10
        CSUM=0.
        CUT=SM*PERCNL
        DO 5 I=1,NCELL-1
        CSUM=CSUM+DA(I,IR)
        IF(CSUM.GE.CUT) THEN
          DMED(IR)=DINTRV(I+1)
     .       -(CSUM-CUT)*(DINTRV(I+1)-DINTRV(I))/DA(I,IR)
          DSV(1,IR)=DMED(IR)
          DSV(3,IR)=I
          DSV(4,IR)=(CSUM-CUT)/DA(I,IR)
          IW=0
          IF(IV7.EQ.0) THEN
            IW=1
          ELSE IF(IX(2).EQ.-1.AND.IX(3).EQ.-1) THEN
            IW=1
          END IF
          IF(IW.EQ.1) THEN
            IW=NCELL/8
            K1=I-IW
            K2=I+IW
          ELSE
            IF(IX(2).GE.1) THEN
              K1=I-IX(2)
            ELSE
              K1=I
            END IF
            IF(IX(3).GE.1) THEN
              K2=I+IX(3)
            ELSE
              K2=I
            END IF
          END IF
          IF(K1.LE.0)K1=1
          IF(K2.GE.NCELL)K2=NCELL-1
          CSUM=0.
          DO 4 K=K1,K2
          CSUM=CSUM+DA(K,IR)
    4     CONTINUE
          DSV(2,IR)=SM*(DINTRV(K2+1)-DINTRV(K1))/CSUM
          GO TO 10
        END IF
    5   CONTINUE
   10   CONTINUE
      ELSE
        DO 20 IR=1,NROW
        DMED(IR)=MISSNG
        IF(DABS(DSV(1,IR)-MISSNG).GT..1D-6) THEN
          SM=0.
          DO 11 I=1,NCELL
          SM=SM+DA(I,IR)
   11     CONTINUE
          IF(SM.LE.0.)GO TO 20
          K=DSV(3,IR)+.5D-1
          CSUM=0.
          DO 12 I=1,K
          CSUM=CSUM+DA(I,IR)
   12     CONTINUE
          CUT=(DSV(4,IR)*(CSUM-DA(K,IR))+(1.D0-DSV(4,IR))*CSUM)/SM
          DMED(IR)=DSV(1,IR)-(CUT-PERCNL)*DSV(2,IR)
        END IF
   20   CONTINUE
      END IF
      RETURN
      END
C
      SUBROUTINE MSOLVE(IKEY,DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MTYPE,MTRAN,IX,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MTYPE(*),
     .  MTRAN(*),IX(*),IERROR
      DOUBLE PRECISION DID(NID),DX(*)
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER ILIST(3),ISIZE(3)
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
      INTEGER MATSIZ
      EXTERNAL MATSIZ
      DOUBLE PRECISION MISSNG
      DATA MISSNG/-98765.432109D0/
C
  100 FORMAT(' INAPPROPRIATE MIXING OF MODIFY AND NEW')
  101 FORMAT(' INAPPROPRIATE LEADING DIMENSION FOR PACKED MATRIX:',I6)
  102 FORMAT(' MISMATCH OF LIST LENGTHS')
  103 FORMAT(' INAPPROPRIATE CALL WITH CONSTANTS')
  104 FORMAT(' MODIFIED OR NEW VARIABLES REQUIRED')
  105 FORMAT(' MATCH ON SIZE REQUIRED',2I6)
  107 FORMAT(' MISMATCHING ARRAY DIMENSIONS')
  108 FORMAT(' INAPPROPRIATE VARIABLE TYPE FOR NEW/MODIFY')
  111 FORMAT(' SPECIFIED DIMENSION DOES NOT MATCH MATRIX')
C
C
C  IKEY  =  -38  minvert
C        =  -39  msolve
C        =  -40  mmultiply, mmultiplym
C        =  -41  msymmult, msymmultm
C        =  -42  mtrace
C        =  -43  mdiag
C
C  IV23 is sum of new and MODIFY variables (only one will be >0)
C
      IV23=IVLIST(2)+IVLIST(3)
C
C  Checks for full sample, number and type of variables:
C
      IF(DID(1).EQ.0.) THEN
C
C  Check that MODIFY and new variables don't appear together, but that
C  one type does
C
        IF(IVLIST(2).GT.0.AND.IVLIST(3).GT.0)GO TO 90
        IF(IV23.EQ.0)GO TO 94
C
C  Checks for MSOLVE, MMULTIPLY, which involve 2 operators
C
        IF(IKEY.LE.-39.OR.IKEY.EQ.-40) THEN
          IF(IVLIST(4).GT.0) THEN
C
C  If CONSTANTS are given, then #OLD must=1 and IV23 must=1
C
            IF(IVLIST(1).NE.1.OR.IV23.NE.1)GO TO 93
          ELSE
C
C  If no CONSTANTS, then:
C    1) if #OLD = 1, then #new must be 0
C    2) #OLD must be 1 or more
C    3) if #OLD > 1, then #OLD must = #new/MODIFY + 1
C
            IF((IVLIST(1).EQ.1.AND.IVLIST(3).GT.0).OR.IVLIST(1).EQ.0.OR.
     .         (IVLIST(1).GT.1.AND.IVLIST(1).NE.IV23+1)) GO TO 92
          END IF
C
C  Checks for MINVERT, MTRACE, and MDIAG, which involve
C  1 operator
C
        ELSE
          IF(IVLIST(4).GT.0) THEN
C
C  If CONSTANTS are given, then
C      1) #OLD must=0
C      2) #new/MODIFY must=1
C
            IF(IVLIST(1).NE.0.OR.IV23.NE.1)GO TO 93
          ELSE
C
C  If no CONSTANTS, then:
C     1) if #OLD >0, #OLD = #new/MODIFY
C     2) if #OLD =0, #new=0
C
            IF((IVLIST(1).GT.0.AND.IVLIST(1).NE.IV23).OR.
     .         (IVLIST(1).EQ.0.AND.IVLIST(3).GT.0)) GO TO 92
          END IF
        END IF
      END IF
C
C  End of full sample checks for number/type of variables
C
C  INEW - index for outcome variable
C  IOLD1 - index for first operator variable
C  IOLD2 - index for second operator variable
C
      INEW=IVLIST(1)+1
C
C  For MSOLVE, MMULTIPLYM
C
      IF(IKEY.EQ.-39.OR.IKEY.EQ.-40) THEN
C
C  IOLD2 is always the first old variable
C
        IOLD2=1
C
C  If CONSTANTS, set IOLD1=0
C
        IF(IVLIST(4).GT.0) THEN
          IOLD1=0
        ELSE
C
C  If no CONSTANTS, IOLD1=2, regardless of whether this is an OLD,
C  MODIFY, or new variable.
C
          IOLD1=2
        END IF
C
C  For MINVERT, MSYMMULT, MTRACE, MDIAG:
C
      ELSE
        IOLD2=0
C
C  If CONSTANTS, set IOLD1=0
C
        IF(IVLIST(4).GT.0) THEN
          IOLD1=0
        ELSE
          IOLD1=1
        END IF
      END IF
    5 CONTINUE
C
C  Check for return
C
      IF(INEW.GT.IVLIST(1)+IV23) RETURN
C
C  Build a list in ILIST of variables whose size is required
C  JOLD1 - cell index for first operator
C  JOLD2 - cell index for "second" operator, if present
C          (actually, "second" operator is really primary/first
C           matrix in MSOLVE, MMULTIPLY)
C  JNEW - cell index for output
C  NPUSE - number of times "second" operator should be used in
C          looping through columns of "first" operator; >1 only
C          for MSOLVE, MMULTIPLYM; =1 otherwise.
C
      ILIST(1)=IOLD1
      IF(IOLD1.EQ.0) THEN
        JOLD1=IVLIST(4)
      ELSE
        JOLD1=DXPNT(IOLD1)
      END IF
      JNEW=DXPNT(INEW)
C
C  For MSOLVE, MMULTIPLY,
C  set values for the primary matrix (1st old variable)
C
      IF(IKEY.EQ.-39.OR.IKEY.EQ.-40) THEN
        ILIST(2)=IOLD2
        NILIST=2
        JOLD2=DXPNT(IOLD2)
        IF((MTYPE(IOLD2).EQ.2.OR.MTYPE(IOLD2).EQ.8).AND.
     .      MTRAN(IOLD2).EQ.0)GO TO 98
      ELSE
C
C  For MINVERT, MSYMMULT, MTRACE, and MDIAG
C
        NILIST=1
        JOLD2=0
      END IF
C
C  For full sample, MSOLVE, MMULTIPLY, MSYMMULT, and MDIAG,
C  add new variable to ILIST
C
 
      IF(DID(1).EQ.0..OR.IKEY.EQ.-39.OR.IKEY.EQ.-40.OR.IKEY.EQ.-41.OR.
     .  IKEY.EQ.-43) THEN
        NILIST=NILIST+1
        ILIST(NILIST)=INEW
      END IF
C
C  Loop to determine lengths
C
      DO 10 I=1,NILIST
      J=ILIST(I)
C
C  J=0 present for CONSTANTS, in which case set ISIZE to the number
C  of constants.
C
      IF(J.EQ.0) THEN
        ISIZE(I)=IVLIST(5)
      ELSE
        ISIZE(I)=MATSIZ(DIMX(DIMPNT(J)),MTYPE(J),MTRAN(J))
      END IF
   10 CONTINUE
C
C  For MSOLVE, MMULTIPLY
C  adjust lengths of array for MISSING or CROSSED REAL
C
      IF(IKEY.EQ.-39.OR.IKEY.EQ.-40) THEN
        IF(IOLD1.GT.0) THEN
          IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND.
     .        MTRAN(IOLD1).EQ.0) THEN
            ISIZE(1)=ISIZE(1)/2
          END IF
        END IF
      END IF
      IROW1=0
      ICOL1=0
      IROW2=0
      ICOL2=0
C
C  Establish the dimensions, if any OPTIONS  nrow1= etc. given
C
      IF(IVLIST(7).GT.0) THEN
        IF(IKEY.EQ.-39.OR.IKEY.EQ.-40) THEN
C
C  First consider case where direct information about IOLD2 is
C  specified, i.e., IROW1, ICOL1, or IROW2
C
          IF(IX(1).GT.0.OR.IX(2).GT.0.OR.IX(3).GT.0) THEN
            IF(IFIRST.EQ.1) THEN
              IF(IKEY.EQ.-39) THEN
                IF(IX(1).GT.0.AND.IX(2).GT.0.AND.IX(1).NE.IX(2))
     .            GO TO 97
                IF(IX(1).GT.0.AND.IX(3).GT.0.AND.IX(1).NE.IX(3))
     .            GO TO 97
              END IF
              IF(IX(2).GT.0.AND.IX(3).GT.0.AND.IX(2).NE.IX(3))GO TO 97
              IF(IX(1).LT.0.OR.IX(2).LT.0.OR.IX(3).LT.0)GO TO 97
              IF(IX(1).GT.0) THEN
                IF(IX(2).GT.0) THEN
                  IF((IX(1)*IX(2))*(ISIZE(2)/(IX(1)*IX(2))).NE.ISIZE(2))
     .              GO TO 97
                ELSE IF(IX(3).GT.0) THEN
                  IF((IX(1)*IX(3))*(ISIZE(2)/(IX(1)*IX(3))).NE.ISIZE(2))
     .              GO TO 97
                ELSE
                  IF(IX(1)*(ISIZE(2)/IX(1)).NE.ISIZE(2))GO TO 97
                END IF
              ELSE IF(IX(2).GT.0) THEN
                IF(IX(2)*(ISIZE(2)/IX(2)).NE.ISIZE(2))GO TO 97
              ELSE
                IF(IX(3)*(ISIZE(2)/IX(3)).NE.ISIZE(2))GO TO 97
              END IF
            END IF
            IROW1=IX(1)
            IF(IX(2).GT.0) THEN
              ICOL1=IX(2)
            ELSE
              ICOL1=IX(3)
            END IF
C
C  If IKEY=-39, can determine all values
C
            IF(IKEY.EQ.-39) THEN
              IF(IROW1.GT.0) THEN
                ICOL1=IROW1
              ELSE
                IROW1=ICOL1
              END IF
            END IF
C
C  Fill in missing column from row information (IKEY=-40 only)
C
            IF(ICOL1.EQ.0) THEN
              IF(IROW1.EQ.ISIZE(2)) THEN
                ICOL1=1
              ELSE IF(IROW1.EQ.1) THEN
                ICOL1=DIMX(DIMPNT(IOLD2)+1)
              ELSE
                J=1
                DO 11 I=1,DIMX(DIMPNT(IOLD2))
                J=J*DIMX(DIMPNT(IOLD2)+I)
                IF(J.EQ.IROW1)GO TO 12
   11           CONTINUE
                GO TO 97
   12           CONTINUE
                ICOL1=DIMX(DIMPNT(IOLD2)+I+1)
              END IF
C
C  Fill in missing row from column information/dimensions
C  (IKEY=-40 only)
C
            ELSE IF(IROW1.EQ.0) THEN
              IF(DIMX(DIMPNT(IOLD2)).EQ.0) THEN
                IROW1=1
              ELSE IF(ICOL1.EQ.ISIZE(2)) THEN
                IROW1=1
              ELSE
                IROW1=DIMX(DIMPNT(IOLD2)+1)
              END IF
            END IF
            IF(IFIRST.EQ.1) THEN
              IF(IROW1*ICOL1*(ISIZE(2)/(IROW1*ICOL1)).NE.ISIZE(2))
     .          GO TO 97
            END IF
          END IF
C
C  Next, consider the case where some information about IOLD1
C  is given, i.e, ICOL1, IROW2, or ICOL2
C
          IF(IX(2).GT.0.OR.IX(3).GT.0.OR.IX(4).GT.0) THEN
            IF(IFIRST.EQ.1) THEN
C
C  (Note this first check already done above)
C
C             IF(IX(2).GT.0.AND.IX(3).GT.0.AND.IX(2).NE.IX(3))GO TO 97
C
              IF(IX(2).LT.0.OR.IX(3).LT.0.OR.IX(4).LT.0)GO TO 97
              IF(IX(4).GT.0) THEN
                IF(IX(2).GT.0) THEN
                  IF((IX(4)*IX(2))*(ISIZE(1)/(IX(4)*IX(2))).NE.ISIZE(1))
     .              GO TO 97
                ELSE IF(IX(3).GT.0) THEN
                  IF((IX(4)*IX(3))*(ISIZE(1)/(IX(4)*IX(3))).NE.ISIZE(1))
     .              GO TO 97
                ELSE
                  IF(IX(4)*(ISIZE(1)/IX(4)).NE.ISIZE(1))GO TO 97
                END IF
              ELSE IF(IX(2).GT.0) THEN
                IF(IX(2)*(ISIZE(1)/IX(2)).NE.ISIZE(1))GO TO 97
              ELSE
                IF(IX(3)*(ISIZE(1)/IX(3)).NE.ISIZE(1))GO TO 97
              END IF
            END IF
            ICOL2=IX(4)
            IF(IX(2).GT.0) THEN
              IROW2=IX(2)
            ELSE
              IROW2=IX(3)
            END IF
C
C  Fill in missing column from row information
C
            IF(ICOL2.EQ.0) THEN
              IF(IROW2.EQ.ISIZE(1)) THEN
                ICOL2=1
              ELSE IF(IOLD1.EQ.0) THEN
                ICOL2=ISIZE(1)/IROW2
              ELSE IF(IROW2.EQ.1) THEN
                ICOL2=DIMX(DIMPNT(IOLD1)+1)
              ELSE
                J=1
                DO 13 I=1,DIMX(DIMPNT(IOLD1))
                J=J*DIMX(DIMPNT(IOLD1)+I)
                IF(J.EQ.IROW2)GO TO 14
   13           CONTINUE
                GO TO 97
   14           CONTINUE
                ICOL2=DIMX(DIMPNT(IOLD1)+I+1)
              END IF
C
C  In this case, we know that IROW1, ICOL1, and IROW2 have
C  all been established.  Consequently, check if the value of ICOL2
C  just computed "works" in terms of ISIZE(3) - else consider
C  inner product (when IROW1=1) or other reason for ICOL2=1
C
              NPUSE=(ISIZE(1)/(IROW2*ICOL2))/(ISIZE(2)/(IROW1*ICOL1))
              IF(NPUSE*IROW1*(ISIZE(1)/IROW2).NE.ISIZE(3)) THEN
                NPUSE=(ISIZE(1)/IROW2)/(ISIZE(2)/(IROW1*ICOL1))
                IF(NPUSE*IROW1*(ISIZE(1)/IROW2).NE.ISIZE(3)) THEN
                  GO TO 97
                ELSE
                  ICOL2=1
                END IF
              END IF
C
C  Fill in missing row information
C
            ELSE IF(IROW2.EQ.0) THEN
              IF(ICOL2.EQ.ISIZE(1)) THEN
                IROW2=1
              ELSE IF(IOLD1.EQ.0) THEN
                IROW2=ISIZE(1)/ICOL2
              ELSE
                IROW2=DIMX(DIMPNT(IOLD1)+1)
              END IF
            END IF
            IF(IFIRST.EQ.1) THEN
              IF(IROW2*ICOL2*(ISIZE(1)/(IROW2*ICOL2)).NE.ISIZE(1))
     .          GO TO 97
            END IF
          END IF
C
C  By this point, have established dimensions of one or both
C  matrices.  If one is missing, fill in the other here.
C
          IF(IROW1.EQ.0) THEN
            ICOL1=IROW2
            IF(IKEY.EQ.-39) THEN
              IROW1=ICOL1
            ELSE IF(DIMX(DIMPNT(IOLD2)).EQ.0) THEN
              IROW1=1
            ELSE IF(ICOL1.EQ.ISIZE(2)) THEN
              IROW1=1
            ELSE
              IROW1=DIMX(DIMPNT(IOLD2)+1)
            END IF
            IF(IFIRST.EQ.1) THEN
              IF(IROW1*ICOL1*(ISIZE(2)/(IROW1*ICOL1)).NE.ISIZE(2))
     .          GO TO 97
              IF(IKEY.EQ.-39) THEN
                IF(IROW1.NE.ICOL1)GO TO 97
              END IF
            END IF
          ELSE IF(IROW2.EQ.0) THEN
            IROW2=ICOL1
            IF(IROW2.EQ.ISIZE(1)) THEN
              ICOL2=1
            ELSE IF(IOLD1.EQ.0) THEN
              ICOL2=ISIZE(1)/IROW2
            ELSE IF(IROW2.EQ.1) THEN
              ICOL2=DIMX(DIMPNT(IOLD1)+1)
            ELSE
              J=1
              DO 15 I=1,DIMX(DIMPNT(IOLD1))
              J=J*DIMX(DIMPNT(IOLD1)+I)
              IF(J.EQ.IROW2)GO TO 16
   15         CONTINUE
              GO TO 97
   16         CONTINUE
              ICOL2=DIMX(DIMPNT(IOLD1)+I+1)
            END IF
C
C  Again, if ICOL2 is last to be established, verify that this
C  value "works" rather than ICOL2=1.
C
            NPUSE=(ISIZE(1)/(IROW2*ICOL2))/(ISIZE(2)/(IROW1*ICOL1))
            IF(NPUSE*IROW1*(ISIZE(1)/IROW2).NE.ISIZE(3)) THEN
              NPUSE=(ISIZE(1)/IROW2)/(ISIZE(2)/(IROW1*ICOL1))
              IF(NPUSE*IROW1*(ISIZE(1)/IROW2).NE.ISIZE(3)) THEN
                GO TO 97
              ELSE
                ICOL2=1
              END IF
            END IF
            IF(IFIRST.EQ.1) THEN
              IF(IROW2*ICOL2*(ISIZE(1)/(IROW2*ICOL2)).NE.ISIZE(1))
     .          GO TO 97
            END IF
          END IF
          NPUSE=(ISIZE(1)/(IROW2*ICOL2))/(ISIZE(2)/(IROW1*ICOL1))
          IF(NPUSE*IROW1*(ISIZE(1)/IROW2).NE.ISIZE(3))GO TO 97
C
C  Establish dimensions for MINVERT, etc., when dimensions specified
C
        ELSE
C
C  Under all conditions, establish the preliminary dimensions of
C  the matrix indexed by IOLD1
C
C  BEGIN TRANSPLANTED CODE.
C
      IF(IOLD1.EQ.0) THEN
        IROW2=0
        ICOL2=0
        IF(IVLIST(7).GT.0) THEN
          IF(IKEY.EQ.-39.OR.IKEY.EQ.-40) THEN
            IF(IX(3).GT.0) THEN
              IROW2=IX(3)
            END IF
            IF(IX(4).GT.0) THEN
              ICOL2=IX(4)
            END IF
          ELSE
            IF(IX(1).GT.0) THEN
              IROW2=IX(1)
            ELSE IF(IX(3).GT.0) THEN
              IROW2=IX(3)
            END IF
            IF(IX(2).GT.0) THEN
              ICOL2=IX(2)
            ELSE IF(IX(4).GT.0) THEN
              ICOL2=IX(4)
            END IF
          END IF
          IF(IFIRST.EQ.1.AND.IROW2.GT.0) THEN
            IF(IROW2*(ISIZE(1)/IROW2).NE.ISIZE(1))GO TO 911
          END IF
          IF(IFIRST.EQ.1.AND.ICOL2.GT.0) THEN
            IF(ICOL2*(ISIZE(1)/ICOL2).NE.ISIZE(1))GO TO 911
          END IF
        END IF
        IF(IROW2.EQ.0) THEN
          IF(IOLD1.EQ.0) THEN
            IF(ICOL2.EQ.ISIZE(1)) THEN
              IROW2=1
            ELSE
              ICOL2=1
              IROW2=ISIZE(1)
            END IF
          ELSE IF(DIMX(DIMPNT(IOLD1)).EQ.0) THEN
            IROW2=1
          ELSE IF(IVLIST(7).GT.0) THEN
            IROW2=DIMX(DIMPNT(IOLD1)+1)
          END IF
        END IF
        IF(ICOL2.EQ.0) THEN
          IF(IOLD1.EQ.0) THEN
            IF(IROW2.EQ.1) THEN
              ICOL2=ISIZE(1)
            ELSE
              ICOL2=1
              IROW2=ISIZE(1)
            END IF
          ELSE IF(DIMX(DIMPNT(IOLD1)).LE.1) THEN
            ICOL2=1
          ELSE
            ICOL2=DIMX(DIMPNT(IOLD1)+2)
          END IF
        END IF
        IF((ISIZE(1)/(IROW2*ICOL2))*IROW2*ICOL2.NE.ISIZE(1))GO TO 97
      END IF
C
C  END OF TRANSPLANTED CODE
C
          IROW2=1
        END IF
      ELSE
C
C  Establish dimensions for MSOLVE, MMULTIPLY, when no dimensions
C  specified
C
        IF(IKEY.EQ.-39.OR.IKEY.EQ.-40) THEN
          IF(DIMX(DIMPNT(IOLD2)).EQ.0) THEN
            IROW1=1
            ICOL1=1
          ELSE IF(DIMX(DIMPNT(IOLD2)).EQ.1) THEN
            IF(IKEY.EQ.-39)GO TO 97
            IROW1=DIMX(DIMPNT(IOLD2)+1)
            ICOL1=1
          ELSE
            IROW1=DIMX(DIMPNT(IOLD2)+1)
            ICOL1=DIMX(DIMPNT(IOLD2)+2)
          END IF
          IF(IOLD1.EQ.0) THEN
            IROW2=ISIZE(1)
            ICOL2=1
          ELSE IF(DIMX(DIMPNT(IOLD1)).EQ.0) THEN
            IROW2=ISIZE(1)
            ICOL2=1
          ELSE IF(DIMX(DIMPNT(IOLD1)).EQ.1) THEN
            IROW2=ISIZE(1)
            ICOL2=1
          ELSE
            IROW2=DIMX(DIMPNT(IOLD1)+1)
            ICOL2=DIMX(DIMPNT(IOLD1)+2)
          END IF
          MATCH=1
C
C  Regular product
C
          IF(IKEY.EQ.-40) THEN
            IF(IROW2.NE.ICOL1)MATCH=0
            IF(IROW1*ISIZE(1)/IROW2.NE.ISIZE(3))MATCH=0
            NPUSE=(ISIZE(3)*ICOL1)/(ICOL2*ISIZE(2))
            IF(NPUSE*(ICOL2*ISIZE(2))/ICOL1.NE.ISIZE(3))MATCH=0
          END IF
          MATCH2=1
C
C  Outer product
C
          IF(IKEY.EQ.-40) THEN
            IF(IROW1*ISIZE(1).NE.ISIZE(3))MATCH2=0
            NPUSE2=ISIZE(3)/(IROW2*ISIZE(2))
            IF(NPUSE2*(IROW2*ISIZE(2)).NE.ISIZE(3))MATCH2=0
          END IF
          MATCH3=1
C
C  Inner product
C
          IF(IKEY.EQ.-40) THEN
            IF(IROW1.NE.IROW2)MATCH3=0
            IF(ISIZE(1)/IROW2.NE.ISIZE(3))MATCH3=0
            NPUSE3=(ISIZE(3)*IROW1)/(ISIZE(2))
            IF(NPUSE3*(ISIZE(2))/IROW1.NE.ISIZE(3))MATCH3=0
          END IF
          IF(MATCH.EQ.1) THEN
            IF(MATCH2.EQ.1.OR.MATCH3.EQ.1)GO TO 97
          ELSE IF(MATCH2.EQ.1) THEN
            IF(MATCH3.EQ.1)GO TO 97
            ICOL1=1
            ICOL2=IROW2
            IROW2=1
            NPUSE=NPUSE2
          ELSE IF(MATCH3.EQ.1) THEN
            ICOL1=IROW1
            IROW1=1
            ICOL2=1
            NPUSE=NPUSE3
          ELSE
            GO TO 97
          END IF
C
C  Establish dimensions for MINVERT, etc., when no dimensions specified
C
        ELSE
          ICOL1=1
        END IF
      END IF
C
C  Temporarily set INCR to 0, to be recomputed below
C
C     INCR=0
C
C  For PPACK, PUNPACK, and PDIAG, redefine IEDGE on the basis of matrix
C  size.
C
      IF(IKEY.EQ.-31.OR.IKEY.EQ.-32.OR.IKEY.EQ.-34) THEN
        IF( ((IKEY.EQ.-31.OR.IKEY.EQ.-32).AND.ISIZE(1).GT.ISIZE(2))
     .   .OR.(IKEY.EQ.-34.AND.ISIZE(2).GT.ISIZE(1))) THEN
          IF(DIMX(DIMPNT(INEW)).EQ.0) THEN
            IEDGE=1
          ELSE
            IEDGE=DIMX(DIMPNT(INEW)+1)
          END IF
          ILEN=DSQRT(2.D0*DBLE(FLOAT(IEDGE)))
C
C  Redefinition of INCR here.
C
          IF(IKEY.EQ.-31.OR.IKEY.EQ.-32) THEN
            INCR=ILEN*ILEN
          ELSE
            INCR=ILEN
          END IF
        END IF
      END IF
C     ILEN=DSQRT(2.D0*DBLE(FLOAT(IEDGE)))
C
C  Full sample checks for sizes and dimensions of matrices
C
      IF(IFIRST.EQ.1.AND.IKEY.NE.-40) THEN
C
C  For PINVERT, PSOLVE, PMULTIPYM, and PSYMMULTP,
C  check that size of first operator matches size of target, unless
C  REAL with MISSING or CROSSED REAL are involved.
C
        IF((IKEY.LE.-25.AND.IKEY.GE.-27).OR.IKEY.EQ.-30) THEN
          IF(ISIZE(NILIST).NE.ISIZE(1)) GO TO 95
C
C  For PMULTIPLYP, check that output size reflects a square matrix of
C  correct size
C
        ELSE IF(IKEY.EQ.-28) THEN
          IF(ILEN*ILEN*ISIZE(1).NE.IEDGE*ISIZE(NILIST))GO TO 95
C
C  Check dimensions for PSYMMULTM
C
        ELSE IF(IKEY.EQ.-29) THEN
          IF(IEDGE2*ISIZE(1).NE.ICOL2*ILEN*ISIZE(NILIST))GO TO 97
C
C  Check dimensions for PPACK, PUNPACK
C
        ELSE IF(IKEY.EQ.-31.OR.IKEY.EQ.-32) THEN
          IF(ISIZE(1).GT.ISIZE(2)) THEN
            IF(IEDGE*ISIZE(1).NE.ILEN*ILEN*ISIZE(2))GO TO 97
          ELSE
            IF(ILEN*ILEN*ISIZE(1).NE.IEDGE*ISIZE(2))GO TO 97
          END IF
C
C  Check dimensions for PTRACE
C
        ELSE IF(IKEY.EQ.-33) THEN
          IF(ISIZE(1).NE.IEDGE*ISIZE(2))GO TO 95
C
C  Check dimensions for PDIAG
C
        ELSE IF(IKEY.EQ.-34) THEN
          IF(ISIZE(1).GT.ISIZE(2)) THEN
            IF(ILEN*ISIZE(1).NE.IEDGE*ISIZE(2)) GO TO 95
          ELSE
            IF(IEDGE*ISIZE(1).NE.ILEN*ISIZE(2)) GO TO 95
          END IF
        END IF
        IF(MTYPE(INEW).EQ.2.OR.MTYPE(INEW).EQ.8)GO TO 98
C
C  Check that IEDGE is a valid value for a packed matrix
C
        IF(ILEN*(ILEN+1).NE.2*IEDGE)GO TO 91
C
C  Check that the dimensions of the matrices appear appropriate
C
        IF(ILEN.GT.1) THEN
C
C  For PSOLVE, PMULTIPLYM, PMULTIPLYP, and PSYMMULTM
C
          IF(IKEY.LE.-26.AND.IKEY.GE.-29) THEN
            IF(IKEY.EQ.-28) THEN
              IF(IEDGE*(ISIZE(1)/IEDGE).NE.ISIZE(1))GO TO 97
            ELSE
              IF(ILEN*(ISIZE(1)/ILEN).NE.ISIZE(1))GO TO 97
            END IF
            J=1
            DO 22 I=DIMPNT(INEW)+1,DIMPNT(INEW)+DIMX(DIMPNT(INEW))
            J=J*DIMX(I)
            IF(IKEY.EQ.-29) THEN
              IF(J.EQ.IEDGE2) THEN
                GO TO 23
              ELSE IF(J.GT.IEDGE2) THEN
                GO TO 97
              END IF
            ELSE
              IF(J.EQ.ILEN) THEN
                IF(IKEY.EQ.-28) THEN
                  IF(ITEMP.EQ.0) THEN
                    ITEMP=1
                    J=1
                  ELSE
                    GO TO 23
                  END IF
                ELSE
                  GO TO 23
                END IF
              ELSE IF(J.GT.ILEN) THEN
                GO TO 97
              END IF
            END IF
   22       CONTINUE
            GO TO 97
   23       CONTINUE
            IF(IOLD1.GT.0) THEN
              J=1
              DO 24 I=DIMPNT(IOLD1)+1,DIMPNT(IOLD1)+DIMX(DIMPNT(IOLD1))
              IF(I.EQ.DIMPNT(IOLD1)+1) THEN
                IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND.
     .              MTRAN(IOLD1).EQ.0) GO TO 24
              END IF
              J=J*DIMX(I)
              IF(IKEY.EQ.-28) THEN
                IF(J.EQ.IEDGE) THEN
                  GO TO 25
                ELSE IF(J.GT.IEDGE) THEN
                  GO TO 97
                END IF
              ELSE
                IF(J.EQ.ILEN) THEN
                  GO TO 25
                ELSE IF(J.GT.ILEN) THEN
                  GO TO 97
                END IF
              END IF
   24         CONTINUE
              GO TO 97
   25         CONTINUE
            END IF
          ELSE IF(IKEY.EQ.-30) THEN
C
C  For PSYMMULTP
C
            IF(IEDGE*(ISIZE(1)/IEDGE).NE.ISIZE(1))GO TO 97
            J=1
            DO 27 I=DIMPNT(INEW)+1,DIMPNT(INEW)+DIMX(DIMPNT(INEW))
            J=J*DIMX(I)
            IF(J.EQ.IEDGE) THEN
              GO TO 28
            ELSE IF(J.GT.IEDGE) THEN
              GO TO 97
            END IF
   27       CONTINUE
            GO TO 97
   28       CONTINUE
            IF(IOLD1.GT.0) THEN
              J=1
              DO 29 I=DIMPNT(IOLD1)+1,DIMPNT(IOLD1)+DIMX(DIMPNT(IOLD1))
              IF(I.EQ.DIMPNT(IOLD1)+1) THEN
                IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND.
     .              MTRAN(IOLD1).EQ.0) GO TO 29
              END IF
              J=J*DIMX(I)
              IF(J.EQ.IEDGE) THEN
                GO TO 30
              ELSE IF(J.GT.IEDGE) THEN
                GO TO 97
              END IF
   29         CONTINUE
              GO TO 97
   30         CONTINUE
            END IF
          END IF
        END IF
      END IF
C
C  End of full sample checks for sizes and dimensions of matrices.
C
C  If INCR has not been previously determined, compute it here
C  Generally, INCR determines the number of cells of the first
C  operator to be operated on by the second
C
      IF(IKEY.EQ.-40) THEN
        INCR=ISIZE(1)/(ISIZE(2)/(IROW1*ICOL1))
        IEDGE=IROW1*ICOL1
      END IF
C
C  Determine NPUSE here
C
      IF(IKEY.LE.-26.AND.IKEY.GE.-30) THEN
        IF(IKEY.EQ.-26.OR.IKEY.EQ.-27.OR.IKEY.EQ.-29) THEN
          NPUSE=INCR/(ILEN*ICOL2)
        ELSE
          NPUSE=INCR/IEDGE
        END IF
        IF(IFIRST.EQ.1) THEN
          IF(INCR.NE.(INCR/NPUSE)*NPUSE)GO TO 95
        END IF
      ELSE IF(IKEY.NE.-40) THEN
        NPUSE=1
      END IF
C
C  JINCR - increment for JOLD1
C  JINCR2 - increment for JNEW
C
      IF((IKEY.LE.-25.AND.IKEY.GE.-27).OR.IKEY.EQ.-30) THEN
        JINCR2=INCR/NPUSE
      ELSE IF(IKEY.EQ.-28) THEN
        JINCR2=ILEN*ILEN
      ELSE IF(IKEY.EQ.-29) THEN
        JINCR2=IEDGE2
      ELSE IF(IKEY.EQ.-31.OR.IKEY.EQ.-32) THEN
        IF(ISIZE(1).GT.ISIZE(2)) THEN
          JINCR2=IEDGE
        ELSE
          JINCR2=ILEN*ILEN
        END IF
      ELSE IF(IKEY.EQ.-33) THEN
        JINCR2=1
      ELSE IF(IKEY.EQ.-34) THEN
        IF(ISIZE(1).GT.ISIZE(2)) THEN
          JINCR2=ILEN
        ELSE
          JINCR2=IEDGE
        END IF
      ELSE IF(IKEY.EQ.-40) THEN
        JINCR2=IROW1*ICOL2
      END IF
      IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND.MTRAN(IOLD1).EQ.0)
     .    THEN
        JINCR=2
      ELSE
        JINCR=1
      END IF
C
      INCRN=INCR/NPUSE
      DO 80 I=1,ISIZE(1),INCR
      DO 79 IPUSE=1,NPUSE
      INFO=0
      IF(IKEY.LE.-26.AND.IKEY.GE.-30) THEN
        DO 32 J=1,IEDGE
        IF(DABS(DX(JOLD2+J-1)-MISSNG).LE..1D-06)INFO=-1
   32   CONTINUE
      END IF
      IF(INFO.EQ.0) THEN
        JOLD1T=JOLD1
        DO 34 J=1,INCRN
        IF(DABS(DX(JOLD1T)-MISSNG).LE..1D-06)INFO=-1
        JOLD1T=JOLD1T+JINCR
   34   CONTINUE
      END IF
      IF(INFO.EQ.0) THEN
        IF(IKEY.EQ.-39.OR.IKEY.EQ.-40) THEN
          NXPTDS=NXPTD
          IF(JNEW.EQ.JOLD1.OR.JINCR.NE.1) THEN
            CALL ROOMD(INCRN)
            JNEWT=NXPTDS
            JOLD1T=JOLD1
            DO 36 J=1,INCRN
            DX(JNEWT)=DX(JOLD1T)
            JNEWT=JNEWT+1
            JOLD1T=JOLD1T+JINCR
   36       CONTINUE
            JOLD1T=NXPTDS
          ELSE
            JOLD1T=JOLD1
          END IF
          IF(IKEY.EQ.-40) THEN
            CALL DGEMM('N','N',IROW1,ICOL2,ICOL1,1.D0,DX(JOLD2),IROW1,
     .        DX(JOLD1T),IROW2,0.D0,DX(JNEW),IROW1)
            NXPTD=NXPTDS
          END IF
          IF(IKEY.EQ.-26) THEN
            IF(IPUSE.EQ.1) THEN
              CALL DPPTRF('U',ILEN,DX(JOLD2),INFO)
            END IF
          ELSE IF(IKEY.NE.-40) THEN
            CALL DPPTRF('U',ILEN,DX(JNEW),INFO)
          END IF
          IF(INFO.EQ.0) THEN
            IF(IKEY.EQ.-26) THEN
              CALL DPPTRS('U',ILEN,ICOL2,DX(JOLD2),DX(JNEW),ILEN,INFO)
            ELSE IF(IKEY.NE.-40) THEN
              CALL DPPTRI('U',ILEN,DX(JNEW),INFO)
            END IF
          END IF
        ELSE IF(IKEY.LE.-27.AND.IKEY.GE.-30) THEN
          NXPTDS=NXPTD
          IF(JNEW.EQ.JOLD1.OR.JINCR.EQ.2) THEN
            CALL ROOMD(INCRN)
            JNEWT=NXPTDS
            JOLD1T=JOLD1
            DO 42 J=1,INCRN
            DX(JNEWT)=DX(JOLD1T)
            JNEWT=JNEWT+1
            JOLD1T=JOLD1T+JINCR
   42       CONTINUE
            JOLD1T=NXPTDS
          ELSE
            JOLD1T=JOLD1
          END IF
          IF(IKEY.EQ.-27) THEN
            CALL DSPMM('U','N',ILEN,ICOL2,1.D0,DX(JOLD2),DX(JOLD1T),
     .         ILEN,0.0D0,DX(JNEW),ILEN)
          ELSE IF(IKEY.EQ.-28) THEN
            CALL DSPMP('U',ILEN,1.D0,DX(JOLD2),DX(JOLD1T),0.0D0,
     .         DX(JNEW),ILEN)
          ELSE
            ITEMP=NXPTD
            IF(IKEY.EQ.-29) THEN
              J=ILEN*ICOL2+ICOL2*ICOL2
            ELSE
              J=2*ILEN*ILEN
            END IF
            CALL ROOMD(J)
            JNEWT=JNEW
            IF(IKEY.EQ.-29) THEN
              CALL DSPMM('U','N',ILEN,ICOL2,1.D0,DX(JOLD2),DX(JOLD1T),
     .           ILEN,0.0D0,DX(ITEMP),ILEN)
              ITEMP2=ITEMP+ILEN*ICOL2
              CALL DGEMM('T','N',ICOL2,ICOL2,ILEN,1.0D0,DX(JOLD1T),
     .           ILEN,DX(ITEMP),ILEN,0.0D0,DX(ITEMP2),ICOL2)
              ILEN2=ICOL2
            ELSE
              CALL DSPMP('U',ILEN,1.D0,DX(JOLD2),DX(JOLD1T),0.0D0,
     .           DX(ITEMP),ILEN)
              ITEMP2=ITEMP+ILEN*ILEN
              CALL DSPMM('U','N',ILEN,ILEN,1.D0,DX(JOLD1T),DX(ITEMP),
     .           ILEN,0.0D0,DX(ITEMP2),ILEN)
              ILEN2=ILEN
            END IF
            DO 46 J1=1,ILEN2
            DO 44 J2=1,J1
            DX(JNEWT)=DX(ITEMP2)
            ITEMP2=ITEMP2+1
            JNEWT=JNEWT+1
   44       CONTINUE
            ITEMP2=ITEMP2+ILEN2-J1
   46       CONTINUE
          END IF
          NXPTD=NXPTDS
        ELSE IF(IKEY.EQ.-31.OR.IKEY.EQ.-32) THEN
          JNEWT=JNEW
          ITEMP=JOLD1
          IF(ISIZE(1).GT.ISIZE(2)) THEN
            DO 48 J1=1,ILEN
            DO 47 J2=1,J1
            DX(JNEWT)=DX(ITEMP)
            ITEMP=ITEMP+1
            JNEWT=JNEWT+1
   47       CONTINUE
            ITEMP=ITEMP+ILEN-J1
   48       CONTINUE
          ELSE
            DO 54 J1=1,ILEN
            DO 52 J2=1,J1
            DX(JNEWT)=DX(ITEMP)
            ITEMP=ITEMP+1
            JNEWT=JNEWT+1
   52       CONTINUE
            JNEWT=JNEWT+ILEN-J1
   54       CONTINUE
            IF(ILEN.GT.1) THEN
              JNEWT=JNEW+1
              DO 58 J1=1,ILEN
              ITEMP=JOLD1+(J1*(J1+1))/2+J1-1
              DO 56 J2=J1+1,ILEN
              DX(JNEWT)=DX(ITEMP)
              JNEWT=JNEWT+1
              ITEMP=ITEMP+J2
   56         CONTINUE
              JNEWT=JNEWT+J1+1
   58         CONTINUE
            END IF
          END IF
        ELSE IF(IKEY.EQ.-33) THEN
          DX(JNEW)=DX(JOLD1)
          IF(ILEN.GT.1) THEN
            ITEMP=JOLD1+2
            DO 62 J1=2,ILEN
            DX(JNEW)=DX(JNEW)+DX(ITEMP)
            ITEMP=ITEMP+J1+1
   62       CONTINUE
          END IF
        ELSE IF(IKEY.EQ.-34) THEN
          JNEWT=JNEW
          ITEMP=JOLD1
          IF(ISIZE(1).GT.ISIZE(2)) THEN
            DO 64 J1=1,ILEN
            DX(JNEWT)=DX(ITEMP)
            JNEWT=JNEWT+1
            ITEMP=ITEMP+J1+1
   64       CONTINUE
          ELSE
            DX(JNEWT)=DX(ITEMP)
            JNEWT=JNEWT+1
            ITEMP=ITEMP+1
            IF(ILEN.GT.1) THEN
              DO 68 J1=2,ILEN
              DO 66 J2=1,J1-1
              DX(JNEWT)=0.D0
              JNEWT=JNEWT+1
   66         CONTINUE
              DX(JNEWT)=DX(ITEMP)
              ITEMP=ITEMP+1
              JNEWT=JNEWT+1
   68         CONTINUE
            END IF
          END IF
        END IF
      END IF
      IF(INFO.NE.0) THEN
        JNEWT=JNEW
        DO 78 J=1,JINCR2
        DX(JNEWT)=MISSNG
        JNEWT=JNEWT+1
   78   CONTINUE
      END IF
      JNEW=JNEW+JINCR2
      JOLD1=JOLD1+INCRN*JINCR
   79 CONTINUE
      IF(JOLD2.GT.0)JOLD2=JOLD2+IEDGE
   80 CONTINUE
C
C  Increment IOLD1, INEW
C
      IOLD1=IOLD1+1
      INEW=INEW+1
      GO TO 5
   90 CONTINUE
      WRITE(U6,100)
      GO TO 99
   91 CONTINUE
      WRITE(U6,101)IEDGE
      GO TO 99
   92 CONTINUE
      WRITE(U6,102)
      GO TO 99
   93 CONTINUE
      WRITE(U6,103)
      GO TO 99
   94 CONTINUE
      WRITE(U6,104)
      GO TO 99
   95 CONTINUE
      WRITE(U6,105)ISIZE(1),ISIZE(NILIST)
      GO TO 99
   97 CONTINUE
      WRITE(U6,107)
      GO TO 99
   98 CONTINUE
      WRITE(U6,108)
      GO TO 99
  911 CONTINUE
      WRITE(U6,111)
   99 CONTINUE
      IERROR=1
      RETURN
C
C  End of SUBROUTINE MSOLVE
C
      END
C
C
      SUBROUTINE PBDIAG(IKEY,DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MTYPE,MTRAN,IX,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),
     . MTYPE(*),MTRAN(*),IX(*),IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
      INTEGER MATSIZ
      EXTERNAL MATSIZ
      DOUBLE PRECISION MISSNG
      DATA MISSNG/-98765.432109D0/
  100 FORMAT(' INAPPROPRIATE MIXING OF MODIFY AND NEW')
  101 FORMAT(' INAPPROPRIATE LEADING DIMENSION FOR PACKED MATRIX')
  102 FORMAT(' PBDIAG: SPECIFIED OPTION IGNORED')
  103 FORMAT(' INAPPROPRIATE CALL WITH CONSTANTS')
  104 FORMAT(' MODIFIED OR NEW VARIABLES REQUIRED')
  105 FORMAT(' MATCH ON SIZE REQUIRED',2I6)
  107 FORMAT(' MISMATCHING ARRAY DIMENSIONS')
  108 FORMAT(' INAPPROPRIATE VARIABLE TYPE FOR NEW/MODIFY')
  109 FORMAT(' ONLY ONE NEW/MODIFY VARIABLE ALLOWED')
  111 FORMAT(' OLD VARIABLE(S) REQUIRED')
C
C  IKEY  =  -44  pbmultiplym
C        =  -45  pbmultiplyp
C        =  -46  pbsymmultm
C        =  -47  pbsymmultp
C        =  -48  pbdiag
C
C  IV23 is sum of new and MODIFY variables (only one will be >0)
C
      IV23=IVLIST(2)+IVLIST(3)
C
C  Checks for full sample, number and type of variables:
C
      IF(IFIRST.EQ.1) THEN
C
C  Check that MODIFY and new variables don't appear together, but that
C  one type does
C
        IF(IVLIST(2).GT.0.AND.IVLIST(3).GT.0)GO TO 90
        IF(IV23.EQ.0)GO TO 94
        DO 1 I=IVLIST(1)+1,IVLIST(1)+IV23
        IF((MTYPE(I).EQ.2.OR.MTYPE(I).EQ.8).AND.MTRAN(I).EQ.0)
     .    GO TO 98
    1   CONTINUE
C
C  At least one old variable must be present
C
        IF(IVLIST(1).EQ.0)GO TO 911
C
C  Check for PBMULTIPLYM, PBMULTIPLYP, PBSYMMULTM, and PBSYMMULTP,
C  which involve 2 operators
C
        IF(IKEY.GE.-47) THEN
C
C  Only one target variable must be present
C
          IF(IV23.NE.1)GO TO 99
C
C  Check for PBDIAG, which does not accept constants
C
        ELSE
          IF(IVLIST(4).GT.0)GO TO 93
          IF(IVLIST(1).GT.1.AND.IV23.GT.1)GO TO 97
          IF(IVLIST(7).NE.0) THEN
            WRITE(U6,102)
            IERROR=2
          END IF
        END IF
      END IF
C
C  End of full sample checks for number/type of variables
C
C  IPACKV will denote the single packed matrix in unblocked form
C
      IF(IKEY.EQ.-48) THEN
        IF(IVLIST(1).GT.1) THEN
          IPACKV=IVLIST(1)+1
        ELSE IF(IV23.GT.1) THEN
          IPACKV=1
        ELSE
          ISIZE1=MATSIZ(DIMX(DIMPNT(1)),MTYPE(1),MTRAN(1))
          ISIZE2=MATSIZ(DIMX(DIMPNT(2)),MTYPE(2),MTRAN(2))
          IF(ISIZE1.GT.ISIZE2) THEN
            IPACKV=1
          ELSE IF(ISIZE2.GT.ISIZE1) THEN
            IPACKV=2
          ELSE
            GO TO 97
          END IF
        END IF
C
C  Full sample checks for dimensions of target variable
C
        IF(IFIRST.EQ.1) THEN
          IF(DIMX(DIMPNT(IPACKV)).EQ.0)GO TO 91
        END IF
        IEDGE=DIMX(DIMPNT(IPACKV)+1)
        ILEN=DSQRT(2.D0*DBLE(FLOAT(IEDGE)))
        ISIZE2=MATSIZ(DIMX(DIMPNT(IPACKV)),MTYPE(IPACKV),MTRAN(IPACKV))
        NITER=ISIZE2/IEDGE
        IF(IFIRST.EQ.1) THEN
          IF((ILEN*(ILEN+1))/2.NE.IEDGE)GO TO 91
        END IF
C
C  If IPACKV > 1, then subroutine is to pack blocked matrices into
C  IPACKV
C
        IF(IPACKV.GT.1) THEN
          JNEW=DXPNT(IPACKV)
          DO 20 ITER=1,NITER
          ILENC=0
          DO 18 J=1,IVLIST(1)
          IF((MTYPE(J).EQ.2.OR.MTYPE(J).EQ.8).AND.MTRAN(J).EQ.0) THEN
            JINCR=2
          ELSE
            JINCR=1
          END IF
          ISIZE1=MATSIZ(DIMX(DIMPNT(J)),MTYPE(J),MTRAN(J))/JINCR
          IF(DIMX(DIMPNT(J)).GT.0) THEN
            IF(JINCR.EQ.1) THEN
              IEDGE1=DIMX(DIMPNT(J)+1)
            ELSE
              IF(DIMX(DIMPNT(J)).GT.1) THEN
                IEDGE1=DIMX(DIMPNT(J)+2)
              ELSE
                IEDGE1=1
              END IF
            END IF
            ILEN1=DSQRT(2.D0*DBLE(FLOAT(IEDGE1)))
          ELSE
            IEDGE1=1
            ILEN1=1
          END IF
          IF(IFIRST.EQ.1.AND.ITER.EQ.1) THEN
            IF((ILEN1*(ILEN1+1))/2.NE.IEDGE1)GO TO 91
            IF((ISIZE1/(IEDGE1*NITER))*NITER.NE.ISIZE1/IEDGE1)GO TO 91
          END IF
          JOLD1=DXPNT(J)+JINCR*((ISIZE1/NITER)*(ITER-1))
          NK=ISIZE1/(IEDGE1*NITER)
          IF(ILENC+NK*ILEN1.GT.ILEN)GO TO 91
          DO 16 K=1,NK
          DO 14 KK=1,ILEN1
          IF(ILENC.GT.0) THEN
            DO 8 I=1,ILENC
            DX(JNEW)=0.
            JNEW=JNEW+1
    8       CONTINUE
          END IF
          DO 10 I=1,KK
          DX(JNEW)=DX(JOLD1)
          JNEW=JNEW+1
          JOLD1=JOLD1+JINCR
   10     CONTINUE
   14     CONTINUE
          ILENC=ILENC+ILEN1
   16     CONTINUE
   18     CONTINUE
          IF(ILENC.NE.ILEN)GO TO 91
   20     CONTINUE
        ELSE
C
C  If IPACKV=1, then subroutine is to unpack the full matrix into
C  a series of matrices.
C
          JOLD1=DXPNT(1)
          IF((MTYPE(1).EQ.2.OR.MTYPE(1).EQ.8).AND.MTRAN(1).EQ.0) THEN
            JINCR=2
          ELSE
            JINCR=1
          END IF
          DO 40 ITER=1,NITER
          ILENC=0
          DO 38 J=2,IV23+1
          ISIZE1=MATSIZ(DIMX(DIMPNT(J)),MTYPE(J),MTRAN(J))/JINCR
          IF(DIMX(DIMPNT(J)).GT.0) THEN
            IF(JINCR.EQ.1) THEN
              IEDGE1=DIMX(DIMPNT(J)+1)
            ELSE
              IF(DIMX(DIMPNT(J)).GT.1) THEN
                IEDGE1=DIMX(DIMPNT(J)+2)
              ELSE
                IEDGE1=1
              END IF
            END IF
            ILEN1=DSQRT(2.D0*DBLE(FLOAT(IEDGE1)))
          ELSE
            IEDGE1=1
            ILEN1=1
          END IF
          IF(DID(1).EQ.0.AND.ITER.EQ.1) THEN
            IF((ILEN1*(ILEN1+1))/2.NE.IEDGE1)GO TO 91
            IF((ISIZE1/(IEDGE1*NITER))*NITER.NE.ISIZE1/IEDGE1)GO TO 91
          END IF
          JNEW=DXPNT(J)+(ISIZE1/NITER)*(ITER-1)
          NK=ISIZE1/(IEDGE1*NITER)
          IF(ILENC+NK*ILEN1.GT.ILEN)GO TO 91
          DO 36 K=1,NK
          DO 34 KK=1,ILEN1
          JOLD1=JOLD1+JINCR*ILENC
          DO 28 I=1,KK
          DX(JNEW)=DX(JOLD1)
          JNEW=JNEW+1
          JOLD1=JOLD1+JINCR
   28     CONTINUE
   34     CONTINUE
          ILENC=ILENC+ILEN1
   36     CONTINUE
   38     CONTINUE
          IF(ILENC.NE.ILEN)GO TO 91
   40     CONTINUE
        END IF
      ELSE
        IF(IKEY.EQ.-44) THEN
          IOUT=IVLIST(1)+IV23
          IF(DIMX(DIMPNT(IOUT)).EQ.0) GO TO 97
          ILEN1=DIMX(DIMPNT(IOUT)+1)
        END IF
      END IF
      RETURN
   90 CONTINUE
      WRITE(U6,100)
      GO TO 999
   91 CONTINUE
      WRITE(U6,101)
      GO TO 999
   93 CONTINUE
      WRITE(U6,103)
      GO TO 999
   94 CONTINUE
      WRITE(U6,104)
      GO TO 999
   97 CONTINUE
      WRITE(U6,107)
      GO TO 999
   98 CONTINUE
      WRITE(U6,108)
      GO TO 999
   99 CONTINUE
      WRITE(U6,109)
      GO TO 99
  911 CONTINUE
      WRITE(U6,111)
  999 CONTINUE
      IERROR=1
      RETURN
C
C  End of SUBROUTINE PBDIAG
C
      END
C
      SUBROUTINE PEIGEN(IKEY,DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MTYPE,MTRAN,IX,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MTYPE(*),
     .  MTRAN(*),IX(*),IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER ILIST(3),ISIZE(3)
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
      INTEGER MATSIZ
      EXTERNAL MATSIZ
      DOUBLE PRECISION MISSNG
      DATA MISSNG/-98765.432109D0/
  100 FORMAT(' INAPPROPRIATE MIXING OF MODIFY AND NEW')
  101 FORMAT(' INAPPROPRIATE LEADING DIMENSION FOR PACKED MATRIX:',I6)
  102 FORMAT(' MISMATCH OF LIST LENGTHS')
  103 FORMAT(' INAPPROPRIATE CALL WITH CONSTANTS')
  104 FORMAT(' MODIFIED OR NEW VARIABLES REQUIRED')
  105 FORMAT(' MATCH ON SIZE REQUIRED',2I6)
  107 FORMAT(' MISMATCHING ARRAY DIMENSIONS')
  108 FORMAT(' INAPPROPRIATE VARIABLE TYPE FOR NEW/MODIFY')
C
C  IKEY  =  -35  peigenvector
C        =  -36  peigenvalue
C        =  -37  psqrt
C
C  IV23 is sum of new and MODIFY variables (only one will be >0)
C
      IV23=IVLIST(2)+IVLIST(3)
C
C  Checks for full sample, number and type of variables:
C
      IF(IFIRST.EQ.1) THEN
C
C  Check that MODIFY and new variables don't appear together, but that
C  one type does
C
        IF(IVLIST(2).GT.0.AND.IVLIST(3).GT.0)GO TO 90
        IF(IV23.EQ.0)GO TO 94
        IF(IVLIST(4).GT.0)GO TO 93
C
C  Check for PEIGENVECTOR,which produces paired outputs
C
        IF(IKEY.EQ.-35) THEN
          IF(2*IVLIST(1).NE.IV23) GO TO 92
C
C  Check for PEIGENVALUE, PSQRT
C
        ELSE
          IF(IVLIST(1).NE.IV23.AND.
     .      (IKEY.NE.-37.OR.IVLIST(1).NE.0.OR.IVLIST(2).EQ.0))GO TO 92
        END IF
      END IF
C
C  End of full sample checks for number of variables
C
C  INEW - index for first outcome variable
C  IOLD - index for packed matrix variable
C
      INEW=IVLIST(1)+1
      IOLD=1
    5 CONTINUE
C
C  Check for return
C
      IF(INEW.GT.IVLIST(1)+IV23) RETURN
C
C  Build a list in ILIST of variables whose size is required
C  JOLD - cell index for old operator
C  JNEW1 - cell index for first output
C  JNEW2 - cell index for second output (EIGENVECTOR)
C  IEDGE - leading edge of packed matrix
C
      ILIST(1)=IOLD
      JOLD=DXPNT(IOLD)
      JNEW1=DXPNT(INEW)
      IF(IKEY.EQ.-35) THEN
        JNEW2=DXPNT(INEW+1)
      ELSE
        JNEW2=0
      END IF
      NILIST=1
      IF((MTYPE(IOLD).EQ.2.OR.MTYPE(IOLD).EQ.8).AND.
     .    MTRAN(IOLD).EQ.0)GO TO 98
      IF(DIMX(DIMPNT(IOLD)).EQ.0) THEN
        IEDGE=1
      ELSE
        IEDGE=DIMX(DIMPNT(IOLD)+1)
      END IF
C
C  For full sample, add new variable(s) to ILIST
C
      IF(DID(1).EQ.0.) THEN
        ILIST(2)=INEW
        IF(IKEY.EQ.-35) THEN
          NILIST=3
          ILIST(3)=INEW+1
        ELSE
          NILIST=2
        END IF
      END IF
C
C  Loop to determine lengths
C
      DO 10 I=1,NILIST
      J=ILIST(I)
      ISIZE(I)=MATSIZ(DIMX(DIMPNT(J)),MTYPE(J),MTRAN(J))
   10 CONTINUE
      ILEN=DSQRT(2.D0*DBLE(FLOAT(IEDGE)))
C
C  Establish temporary storage - 3*ILEN in all cases, plus
C  ILEN*(ILEN+1) for PSQRT
C
      NXPTDS=NXPTD
      IF(IKEY.EQ.-37) THEN
        I=ILEN*(ILEN+4)
      ELSE
        I=3*ILEN
      END IF
      CALL ROOMD(I)
C
C  Full sample checks for sizes and dimensions of matrices
C
      IF(IFIRST.EQ.1) THEN
        IF(MTYPE(INEW).EQ.2.OR.MTYPE(INEW).EQ.8)GO TO 98
C
C  Check that IEDGE is a valid value for a packed matrix
C
        IF(ILEN*(ILEN+1).NE.2*IEDGE)GO TO 91
C
C  For PSQRT, check that size of first operator matches size of target.
C
        IF(IKEY.EQ.-37) THEN
          IF(ISIZE(NILIST).NE.ISIZE(1)) GO TO 95
C
C  For PEIGENVALUE and PEIGENVECTOR, check that size of (first) output
C  matrix reflects space for eigenvalues.
C
        ELSE
          IF(ILEN*ISIZE(1).NE.IEDGE*ISIZE(2))GO TO 97
C
C  Check dimension of second output matrix for PEIGENVECTOR.
C
          IF(IKEY.EQ.-35) THEN
            IF(IEDGE*ISIZE(3).NE.ILEN*ILEN*ISIZE(1))GO TO 97
          END IF
        END IF
      END IF
C
C  End of full sample checks for sizes and dimensions of matrices.
C
C
C  IEDGE - increment for JOLD
C  JINCR1 - increment for JNEW1
C  JINCR2 - increment for JNEW2
C
      JINCR2=0
      IF(IKEY.EQ.-37) THEN
        JINCR1=IEDGE
      ELSE
        JINCR1=ILEN
        IF(IKEY.EQ.-35) THEN
          JINCR2=ILEN*ILEN
        END IF
      END IF
      DO 80 I=1,ISIZE(1),IEDGE
      INFO=0
      DO 22 J=1,IEDGE
      IF(DABS(DX(JOLD+J-1)-MISSNG).LE..1D-06)INFO=-1
   22 CONTINUE
      IF(INFO.EQ.0) THEN
        IF(IKEY.EQ.-35) THEN
          CALL DSPEV('V','U',ILEN,DX(JOLD),DX(JNEW1),DX(JNEW2),ILEN,
     .      DX(NXPTDS),INFO)
        ELSE IF(IKEY.EQ.-36) THEN
          CALL DSPEV('N','U',ILEN,DX(JOLD),DX(JNEW1),DX(JNEW1),ILEN,
     .      DX(NXPTDS),INFO)
C         rad=dsqrt((dx(jold)-dx(jold+2))**2+4.d0*dx(jold+1)*dx(jold+1))
C         dx(jnew1)=(dx(jold)+dx(jold+2)+rad)/2.d0
C         dx(jnew1+1)=(dx(jold)+dx(jold+2)-rad)/2.d0
        ELSE
          K=NXPTDS+3*ILEN
          KK=K+ILEN
          CALL DSPEV('V','U',ILEN,DX(JOLD),DX(K),DX(KK),ILEN,
     .      DX(NXPTDS),INFO)
          IF(INFO.EQ.0) THEN
            DO 24 J=1,ILEN
            IF(DX(K+J-1).GT.0) THEN
              DX(K+J-1)=DSQRT(DX(K+J-1))
            ELSE IF(DX(K+J-1).LT.0) THEN
              INFO=-1
            END IF
   24       CONTINUE
          END IF
          IF(INFO.EQ.0) THEN
            DO 25 J=1,IEDGE
            DX(JNEW1+J-1)=0.
   25       CONTINUE
            KK=KK-1
            DO 40 L=1,ILEN
            CMULT=DX(K)
            II=JNEW1
            DO 35 J=1,ILEN
            DO 30 JJ=1,J
            DX(II)=DX(II)+CMULT*DX(KK+J)*DX(KK+JJ)
            II=II+1
   30       CONTINUE
   35       CONTINUE
            K=K+1
            KK=KK+ILEN
   40       CONTINUE
          END IF
        END IF
      END IF
      IF(INFO.NE.0) THEN
        JNEWT=JNEW1
        DO 78 J=1,JINCR1
        DX(JNEWT)=MISSNG
        JNEWT=JNEWT+1
   78   CONTINUE
        IF(IKEY.EQ.-37) THEN
          JNEWT=JNEW2
          DO 79 J=1,JINCR2
          DX(JNEWT)=MISSNG
          JNEWT=JNEWT+1
   79     CONTINUE
        END IF
      END IF
      JNEW1=JNEW1+JINCR1
      JNEW2=JNEW2+JINCR2
      JOLD=JOLD+IEDGE
   80 CONTINUE
C
C  Increment IOLD, INEW
C
      IOLD=IOLD+1
      IF(IKEY.EQ.-35) THEN
        INEW=INEW+2
      ELSE
        INEW=INEW+1
      END IF
      NXPTD=NXPTDS
      GO TO 5
   90 CONTINUE
      WRITE(U6,100)
      GO TO 99
   91 CONTINUE
      WRITE(U6,101)IEDGE
      GO TO 99
   92 CONTINUE
      WRITE(U6,102)
      GO TO 99
   93 CONTINUE
      WRITE(U6,103)
      GO TO 99
   94 CONTINUE
      WRITE(U6,104)
      GO TO 99
   95 CONTINUE
      WRITE(U6,105)ISIZE(1),ISIZE(NILIST)
      GO TO 99
   97 CONTINUE
      WRITE(U6,107)
      GO TO 99
   98 CONTINUE
      WRITE(U6,108)
   99 CONTINUE
      IERROR=1
C
C  End of SUBROUTINE PEIGEN
C
      RETURN
      END
      SUBROUTINE PSOLVE(IKEY,DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,
     .  DX,MTYPE,MTRAN,IX,IERROR)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),
     . MTYPE(*),MTRAN(*),IX(*),IERROR
      DOUBLE PRECISION DID(NID),DX(*)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER ILIST(3),ISIZE(3)
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
      INTEGER MATSIZ
      EXTERNAL MATSIZ
      DOUBLE PRECISION MISSNG
      DATA MISSNG/-98765.432109D0/
  100 FORMAT(' INAPPROPRIATE MIXING OF MODIFY AND NEW')
  101 FORMAT(' INAPPROPRIATE LEADING DIMENSION FOR PACKED MATRIX:',I6)
  102 FORMAT(' MISMATCH OF LIST LENGTHS')
  103 FORMAT(' INAPPROPRIATE CALL WITH CONSTANTS')
  104 FORMAT(' MODIFIED OR NEW VARIABLES REQUIRED')
  105 FORMAT(' MATCH ON SIZE REQUIRED',2I6)
  107 FORMAT(' MISMATCHING ARRAY DIMENSIONS')
  108 FORMAT(' INAPPROPRIATE VARIABLE TYPE FOR NEW/MODIFY')
  111 FORMAT(' SPECIFIED DIMENSION DOES NOT MATCH MATRIX')
C
C  IKEY  =  -25  pinvert
C        =  -26  psolve
C        =  -27  pmultiplym
C        =  -28  pmultiplyp
C        =  -29  psymmultm
C        =  -30  psymmultp
C        =  -31  ppack
C        =  -32  punpack
C        =  -33  ptrace
C        =  -34  pdiag
C
C  IV23 is sum of new and MODIFY variables (only one will be >0)
C
      IV23=IVLIST(2)+IVLIST(3)
C
C  Checks for full sample, number and type of variables:
C
      IF(DID(1).EQ.0.) THEN
C
C  Check that MODIFY and new variables don't appear together, but that
C  one type does
C
        IF(IVLIST(2).GT.0.AND.IVLIST(3).GT.0)GO TO 90
        IF(IV23.EQ.0)GO TO 94
C
C  Checks for PSOLVE, PMULTIPLYM, PMULTIPLYP, PSYMMULTM, and PSYMMULTP,
C  which involve 2 operators
C
        IF(IKEY.LE.-26.AND.IKEY.GE.-30) THEN
          IF(IVLIST(4).GT.0) THEN
C
C  If CONSTANTS are given, then #OLD must=1 and IV23 must=1
C
            IF(IVLIST(1).NE.1.OR.IV23.NE.1)GO TO 93
          ELSE
C
C  If no CONSTANTS, then:
C    1) if #OLD = 1, then #new must be 0
C    2) #OLD must be 1 or more
C    3) if #OLD > 1, then #OLD must = #new/MODIFY + 1
C
            IF((IVLIST(1).EQ.1.AND.IVLIST(3).GT.0).OR.IVLIST(1).EQ.0.OR.
     .         (IVLIST(1).GT.1.AND.IVLIST(1).NE.IV23+1)) GO TO 92
          END IF
C
C  Checks for PINVERT, PPACK, PUNPACK, PTRACE, PDIAG, which involve
C  1 operator
C
        ELSE
          IF(IVLIST(4).GT.0) THEN
C
C  If CONSTANTS are given, then
C      1) #OLD must=0
C      2) #new/MODIFY must=1
C
            IF(IVLIST(1).NE.0.OR.IV23.NE.1)GO TO 93
          ELSE
C
C  If no CONSTANTS, then:
C     1) if #OLD >0, #OLD = #new/MODIFY
C     2) if #OLD =0, #new=0
C
            IF((IVLIST(1).GT.0.AND.IVLIST(1).NE.IV23).OR.
     .         (IVLIST(1).EQ.0.AND.IVLIST(3).GT.0)) GO TO 92
          END IF
        END IF
      END IF
C
C  End of full sample checks for number/type of variables
C
C  INEW - index for outcome variable
C  IOLD1 - index for first operator variable
C  IOLD2 - index for second operator variable
C
      INEW=IVLIST(1)+1
C
C  For PSOLVE, PMULTIPLYM, PMULTIPLYP, PSYMMULTM, and PSYMMULTP
C
      IF(IKEY.LE.-26.AND.IKEY.GE.-30) THEN
C
C  IOLD2 is always the first old variable
C
       IOLD2=1
C
C  If CONSTANTS, set IOLD1=0
C
        IF(IVLIST(4).GT.0) THEN
          IOLD1=0
        ELSE
C
C  If no CONSTANTS, IOLD1=2, regardless of whether this is an old, MODIFY,
C  or new variable.
C
          IOLD1=2
        END IF
C
C  For PINVERT, PPACK, PUNPACK, PTRACE, PDIAG:
C
      ELSE
        IOLD2=0
C
C  If CONSTANTS, set IOLD1=0
C
        IF(IVLIST(4).GT.0) THEN
          IOLD1=0
        ELSE
          IOLD1=1
        END IF
      END IF
    5 CONTINUE
C
C  Check for return
C
      IF(INEW.GT.IVLIST(1)+IV23) RETURN
C
C  Build a list in ILIST of variables whose size is required
C  JOLD1 - cell index for first operator
C  JOLD2 - cell index for "second" operator, if present
C          (actually, "second" operator is really primary packed
C           matrix in PSOLVE, PMULTIPLYM, etc.)
C  JNEW - cell index for output
C  IEDGE - leading edge of packed matrix
C  NPUSE - number of times "second" operator should be used in
C          looping through columns of "first" operator; >1 only
C          for PSOLVE, PMULTIPLYM, PSYMMMULTM; =1 otherwise.
C
      ILIST(1)=IOLD1
      IF(IOLD1.EQ.0) THEN
        JOLD1=IVLIST(4)
      ELSE
        JOLD1=DXPNT(IOLD1)
      END IF
      JNEW=DXPNT(INEW)
C
C  For PSOLVE, PMULTIPLYM, PMULTIPLYP, PSYMMULTM, and PSYMMULTP
C  set values for the packed matrix (1st old variable)
C
      IF(IKEY.LE.-26.AND.IKEY.GE.-30) THEN
        ILIST(2)=IOLD2
        NILIST=2
        JOLD2=DXPNT(IOLD2)
        IF((MTYPE(IOLD2).EQ.2.OR.MTYPE(IOLD2).EQ.8).AND.
     .      MTRAN(IOLD2).EQ.0)GO TO 98
        IF(DIMX(DIMPNT(IOLD2)).EQ.0) THEN
          IEDGE=1
        ELSE IF(IVLIST(7).GT.0) THEN
          IF(IX(3).GT.0) THEN
            IEDGE=IX(3)
          ELSE
            IEDGE=DIMX(DIMPNT(IOLD2)+1)
          END IF
        ELSE
          IEDGE=DIMX(DIMPNT(IOLD2)+1)
        END IF
C
C  For PSOLVE, PMULTIPLYM, PSYMMULTM, obtain column dimension of
C  M matrix, represented by IOLD1
C
        IF(IKEY.EQ.-26.OR.IKEY.EQ.-27.OR.IKEY.EQ.-29) THEN
          IF(IOLD1.EQ.0) THEN
            ILEN=DSQRT(2.D0*DBLE(FLOAT(IEDGE)))
            ICOL2=IVLIST(5)/ILEN
            IF(IVLIST(7).GT.0) THEN
              IF(IX(4).GT.0) THEN
                IF(IFIRST.EQ.1) THEN
                  IF(ICOL2.NE.(ICOL2/IX(4))*IX(4))GO TO 911
                END IF
                ICOL2=IX(4)
              END IF
            END IF
          ELSE
            IF(DIMX(DIMPNT(IOLD1)).LE.1) THEN
              ICOL2=1
            ELSE
              ICOL2=DIMX(DIMPNT(IOLD1)+2)
              IF(IVLIST(7).GT.0) THEN
                IF(IX(4).GT.0) THEN
                  IF(IFIRST.EQ.1) THEN
                    IF(ICOL2.NE.(ICOL2/IX(4))*IX(4))GO TO 911
                  END IF
                  ICOL2=IX(4)
                END IF
              END IF
            END IF
          END IF
C
C  IEDGE2 - edge of output matrix for PSYMMULTM
C
          IF(IKEY.EQ.-29) THEN
            IEDGE2=(ICOL2*(ICOL2+1))/2
          END IF
        END IF
C
C  Temporarily set INCR to 0, to be recomputed below
C
        INCR=0
      ELSE
C
C  For PINVERT, PPACK, PUNPACK, PTRACE, PDIAG:
C
        NILIST=1
        JOLD2=0
        IF(IOLD1.EQ.0) THEN
          IEDGE=IVLIST(5)
        ELSE
          IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD2).EQ.8).AND.
     .        MTRAN(IOLD1).EQ.0)GO TO 98
          IF(DIMX(DIMPNT(IOLD1)).EQ.0) THEN
            IEDGE=1
          ELSE
            IEDGE=DIMX(DIMPNT(IOLD1)+1)
          END IF
        END IF
        INCR=IEDGE
      END IF
C
C  For full sample, PPACK, PUNPACK, and PDIAG, add new variable to ILIST
C
      IF(DID(1).EQ.0..OR.IKEY.EQ.-31.OR.IKEY.EQ.-32.OR.IKEY.EQ.-34)
     .     THEN
        NILIST=NILIST+1
        ILIST(NILIST)=INEW
      END IF
C
C  Loop to determine lengths
C
      DO 10 I=1,NILIST
      J=ILIST(I)
C
C  J=0 present for CONSTANTS, in which case set ISIZE to the number
C  of constants.
C
      IF(J.EQ.0) THEN
        ISIZE(I)=IVLIST(5)
      ELSE
        ISIZE(I)=MATSIZ(DIMX(DIMPNT(J)),MTYPE(J),MTRAN(J))
      END IF
   10 CONTINUE
C
C  For PSOLVE, PMULTIPLYM, PMULTIPLYP, PSYMMULTM, and PSYMMULTP:
C  adjust lengths of array for MISSING or CROSSED REAL
C
      IF(IKEY.LE.-26.AND.IKEY.GE.-30) THEN
        IF(IOLD1.GT.0) THEN
          IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND.
     .        MTRAN(IOLD1).EQ.0) THEN
            ISIZE(1)=ISIZE(1)/2
          END IF
        END IF
      END IF
C
C  For PPACK, PUNPACK, and PDIAG, redefine IEDGE on the basis of matrix
C  size.
C
      IF(IKEY.EQ.-31.OR.IKEY.EQ.-32.OR.IKEY.EQ.-34) THEN
        IF( ((IKEY.EQ.-31.OR.IKEY.EQ.-32).AND.ISIZE(1).GT.ISIZE(2))
     .   .OR.(IKEY.EQ.-34.AND.ISIZE(2).GT.ISIZE(1))) THEN
          IF(DIMX(DIMPNT(INEW)).EQ.0) THEN
            IEDGE=1
          ELSE
            IEDGE=DIMX(DIMPNT(INEW)+1)
          END IF
          ILEN=DSQRT(2.D0*DBLE(FLOAT(IEDGE)))
C
C  Redefinition of INCR here.
C
          IF(IKEY.EQ.-31.OR.IKEY.EQ.-32) THEN
            INCR=ILEN*ILEN
          ELSE
            INCR=ILEN
          END IF
        END IF
      END IF
      ILEN=DSQRT(2.D0*DBLE(FLOAT(IEDGE)))
C
C  Full sample checks for sizes and dimensions of matrices
C
      IF(IFIRST.EQ.1) THEN
C
C  For PINVERT, PSOLVE, PMULTIPYM, and PSYMMULTP,
C  check that size of first operator matches size of target, unless
C  REAL with MISSING or CROSSED REAL are involved.
C
        IF((IKEY.LE.-25.AND.IKEY.GE.-27).OR.IKEY.EQ.-30) THEN
          IF(ISIZE(NILIST).NE.ISIZE(1)) GO TO 95
C
C  For PMULTIPLYP, check that output size reflects a square matrix of
C  correct size
C
        ELSE IF(IKEY.EQ.-28) THEN
          IF(ILEN*ILEN*ISIZE(1).NE.IEDGE*ISIZE(NILIST))GO TO 95
C
C  Check dimensions for PSYMMULTM
C
        ELSE IF(IKEY.EQ.-29) THEN
          IF(IEDGE2*ISIZE(1).NE.ICOL2*ILEN*ISIZE(NILIST))GO TO 97
C
C  Check dimensions for PPACK, PUNPACK
C
        ELSE IF(IKEY.EQ.-31.OR.IKEY.EQ.-32) THEN
          IF(ISIZE(1).GT.ISIZE(2)) THEN
            IF(IEDGE*ISIZE(1).NE.ILEN*ILEN*ISIZE(2))GO TO 97
          ELSE
            IF(ILEN*ILEN*ISIZE(1).NE.IEDGE*ISIZE(2))GO TO 97
          END IF
C
C  Check dimensions for PTRACE
C
        ELSE IF(IKEY.EQ.-33) THEN
          IF(ISIZE(1).NE.IEDGE*ISIZE(2))GO TO 95
C
C  Check dimensions for PDIAG
C
        ELSE IF(IKEY.EQ.-34) THEN
          IF(ISIZE(1).GT.ISIZE(2)) THEN
            IF(ILEN*ISIZE(1).NE.IEDGE*ISIZE(2)) GO TO 95
          ELSE
            IF(IEDGE*ISIZE(1).NE.ILEN*ISIZE(2)) GO TO 95
          END IF
        END IF
        IF(MTYPE(INEW).EQ.2.OR.MTYPE(INEW).EQ.8)GO TO 98
C
C  Check that IEDGE is a valid value for a packed matrix
C
        IF(ILEN*(ILEN+1).NE.2*IEDGE)GO TO 91
C
C  Check that the dimensions of the matrices appear appropriate
C
        IF(ILEN.GT.1) THEN
C
C  For PSOLVE, PMULTIPLYM, PMULTIPLYP, and PSYMMULTM
C
          IF(IKEY.LE.-26.AND.IKEY.GE.-29) THEN
            IF(IKEY.EQ.-28) THEN
              IF(IEDGE*(ISIZE(1)/IEDGE).NE.ISIZE(1))GO TO 97
            ELSE
              IF(ILEN*(ISIZE(1)/ILEN).NE.ISIZE(1))GO TO 97
            END IF
            J=1
            IF(DIMX(DIMPNT(INEW)).GT.0.AND.ICOL2.NE.1) THEN
              DO 12 I=DIMPNT(INEW)+1,DIMPNT(INEW)+DIMX(DIMPNT(INEW))
              J=J*DIMX(I)
              IF(IKEY.EQ.-29) THEN
                IF(J.EQ.IEDGE2) THEN
                  GO TO 13
                ELSE IF(J.GT.IEDGE2) THEN
                  GO TO 97
                END IF
              ELSE
                IF(J.EQ.ILEN) THEN
                  IF(IKEY.EQ.-28) THEN
                    IF(ITEMP.EQ.0) THEN
                      ITEMP=1
                      J=1
                    ELSE
                      GO TO 13
                    END IF
                  ELSE
                    GO TO 13
                  END IF
                ELSE IF(J.GT.ILEN) THEN
                  GO TO 97
                END IF
              END IF
   12         CONTINUE
              GO TO 97
   13         CONTINUE
            END IF
            IF(IOLD1.GT.0) THEN
              J=1
              DO 14 I=DIMPNT(IOLD1)+1,DIMPNT(IOLD1)+DIMX(DIMPNT(IOLD1))
              IF(I.EQ.DIMPNT(IOLD1)+1) THEN
                IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND.
     .              MTRAN(IOLD1).EQ.0) GO TO 14
              END IF
              J=J*DIMX(I)
              IF(IKEY.EQ.-28) THEN
                IF(J.EQ.IEDGE) THEN
                  GO TO 15
                ELSE IF(J.GT.IEDGE) THEN
                  GO TO 97
                END IF
              ELSE
                IF(J.EQ.ILEN) THEN
                  GO TO 15
                ELSE IF(J.GT.ILEN) THEN
                  GO TO 97
                END IF
              END IF
   14         CONTINUE
              GO TO 97
   15         CONTINUE
            END IF
          ELSE IF(IKEY.EQ.-30) THEN
C
C  For PSYMMULTP
C
            IF(IEDGE*(ISIZE(1)/IEDGE).NE.ISIZE(1))GO TO 97
            J=1
            DO 17 I=DIMPNT(INEW)+1,DIMPNT(INEW)+DIMX(DIMPNT(INEW))
            J=J*DIMX(I)
            IF(J.EQ.IEDGE) THEN
              GO TO 18
            ELSE IF(J.GT.IEDGE) THEN
              GO TO 97
            END IF
   17       CONTINUE
            GO TO 97
   18       CONTINUE
            IF(IOLD1.GT.0) THEN
              J=1
              DO 19 I=DIMPNT(IOLD1)+1,DIMPNT(IOLD1)+DIMX(DIMPNT(IOLD1))
              IF(I.EQ.DIMPNT(IOLD1)+1) THEN
                IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND.
     .              MTRAN(IOLD1).EQ.0) GO TO 19
              END IF
              J=J*DIMX(I)
              IF(J.EQ.IEDGE) THEN
                GO TO 20
              ELSE IF(J.GT.IEDGE) THEN
                GO TO 97
              END IF
   19         CONTINUE
              GO TO 97
   20         CONTINUE
            END IF
          END IF
        END IF
      END IF
C
C  End of full sample checks for sizes and dimensions of matrices.
C
C  If INCR has not been previously determined, compute it here
C  Generally, INCR determines the number of cells of the first
C  operator to be operated on by the second
C
      IF(INCR.EQ.0)INCR=ISIZE(1)/(ISIZE(2)/IEDGE)
C
C  Determine NPUSE here
C
      IF(IKEY.LE.-26.AND.IKEY.GE.-30) THEN
        IF(IKEY.EQ.-26.OR.IKEY.EQ.-27.OR.IKEY.EQ.-29) THEN
          NPUSE=INCR/(ILEN*ICOL2)
C
C  At this point, allow alternative ICOL2=1 if that works.
C
          IF(NPUSE.EQ.0) THEN
            IF(IVLIST(7).EQ.0) THEN
              ICOL2=1
              NPUSE=INCR/ILEN
            ELSE IF(IX(4).EQ.0) THEN
              ICOL2=1
              NPUSE=INCR/ILEN
            END IF
          END IF
        ELSE
          NPUSE=INCR/IEDGE
        END IF
        IF(IFIRST.EQ.1) THEN
          IF(INCR.NE.(INCR/NPUSE)*NPUSE)GO TO 95
        END IF
      ELSE
        NPUSE=1
      END IF
C
C  JINCR - increment for JOLD1
C  JINCR2 - increment for JNEW
C
      IF((IKEY.LE.-25.AND.IKEY.GE.-27).OR.IKEY.EQ.-30) THEN
        JINCR2=INCR/NPUSE
      ELSE IF(IKEY.EQ.-28) THEN
        JINCR2=ILEN*ILEN
      ELSE IF(IKEY.EQ.-29) THEN
        JINCR2=IEDGE2
      ELSE IF(IKEY.EQ.-31.OR.IKEY.EQ.-32) THEN
        IF(ISIZE(1).GT.ISIZE(2)) THEN
          JINCR2=IEDGE
        ELSE
          JINCR2=ILEN*ILEN
        END IF
      ELSE IF(IKEY.EQ.-33) THEN
        JINCR2=1
      ELSE IF(IKEY.EQ.-34) THEN
        IF(ISIZE(1).GT.ISIZE(2)) THEN
          JINCR2=ILEN
        ELSE
          JINCR2=IEDGE
        END IF
      END IF
      IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND.MTRAN(IOLD1).EQ.0)
     .    THEN
        JINCR=2
      ELSE
        JINCR=1
      END IF
C
      INCRN=INCR/NPUSE
      DO 80 I=1,ISIZE(1),INCR
      DO 79 IPUSE=1,NPUSE
      INFO=0
      IF(IKEY.LE.-26.AND.IKEY.GE.-30) THEN
        DO 22 J=1,IEDGE
        IF(DABS(DX(JOLD2+J-1)-MISSNG).LE..1D-06)INFO=-1
   22   CONTINUE
      END IF
      IF(INFO.EQ.0) THEN
        JOLD1T=JOLD1
        DO 24 J=1,INCRN
        IF(DABS(DX(JOLD1T)-MISSNG).LE..1D-06)INFO=-1
        JOLD1T=JOLD1T+JINCR
   24   CONTINUE
      END IF
      IF(INFO.EQ.0) THEN
        IF(IKEY.EQ.-25.OR.IKEY.EQ.-26) THEN
          IF(JNEW.NE.JOLD1) THEN
            JNEWT=JNEW
            JOLD1T=JOLD1
            DO 26 J=1,INCRN
            DX(JNEWT)=DX(JOLD1T)
            JNEWT=JNEWT+1
            JOLD1T=JOLD1T+JINCR
   26       CONTINUE
          END IF
          IF(IKEY.EQ.-26) THEN
            IF(IPUSE.EQ.1) THEN
              CALL DPPTRF('U',ILEN,DX(JOLD2),INFO)
            END IF
          ELSE
            CALL DPPTRF('U',ILEN,DX(JNEW),INFO)
          END IF
          IF(INFO.EQ.0) THEN
            IF(IKEY.EQ.-26) THEN
              CALL DPPTRS('U',ILEN,ICOL2,DX(JOLD2),DX(JNEW),ILEN,INFO)
            ELSE
              CALL DPPTRI('U',ILEN,DX(JNEW),INFO)
            END IF
          END IF
        ELSE IF(IKEY.LE.-27.AND.IKEY.GE.-30) THEN
          NXPTDS=NXPTD
          IF(JNEW.EQ.JOLD1.OR.JINCR.EQ.2) THEN
            CALL ROOMD(INCRN)
            JNEWT=NXPTDS
            JOLD1T=JOLD1
            DO 32 J=1,INCRN
            DX(JNEWT)=DX(JOLD1T)
            JNEWT=JNEWT+1
            JOLD1T=JOLD1T+JINCR
   32       CONTINUE
            JOLD1T=NXPTDS
          ELSE
            JOLD1T=JOLD1
          END IF
          IF(IKEY.EQ.-27) THEN
            CALL DSPMM('U','N',ILEN,ICOL2,1.D0,DX(JOLD2),DX(JOLD1T),
     .         ILEN,0.0D0,DX(JNEW),ILEN)
          ELSE IF(IKEY.EQ.-28) THEN
            CALL DSPMP('U',ILEN,1.D0,DX(JOLD2),DX(JOLD1T),0.0D0,
     .         DX(JNEW),ILEN)
          ELSE
            ITEMP=NXPTD
            IF(IKEY.EQ.-29) THEN
              J=ILEN*ICOL2+ICOL2*ICOL2
            ELSE
              J=2*ILEN*ILEN
            END IF
            CALL ROOMD(J)
            JNEWT=JNEW
            IF(IKEY.EQ.-29) THEN
              CALL DSPMM('U','N',ILEN,ICOL2,1.D0,DX(JOLD2),DX(JOLD1T),
     .           ILEN,0.0D0,DX(ITEMP),ILEN)
              ITEMP2=ITEMP+ILEN*ICOL2
              CALL DGEMM('T','N',ICOL2,ICOL2,ILEN,1.0D0,DX(JOLD1T),
     .           ILEN,DX(ITEMP),ILEN,0.0D0,DX(ITEMP2),ICOL2)
              ILEN2=ICOL2
            ELSE
              CALL DSPMP('U',ILEN,1.D0,DX(JOLD2),DX(JOLD1T),0.0D0,
     .           DX(ITEMP),ILEN)
              ITEMP2=ITEMP+ILEN*ILEN
              CALL DSPMM('U','N',ILEN,ILEN,1.D0,DX(JOLD1T),DX(ITEMP),
     .           ILEN,0.0D0,DX(ITEMP2),ILEN)
              ILEN2=ILEN
            END IF
            DO 36 J1=1,ILEN2
            DO 34 J2=1,J1
            DX(JNEWT)=DX(ITEMP2)
            ITEMP2=ITEMP2+1
            JNEWT=JNEWT+1
   34       CONTINUE
            ITEMP2=ITEMP2+ILEN2-J1
   36       CONTINUE
          END IF
          NXPTD=NXPTDS
        ELSE IF(IKEY.EQ.-31.OR.IKEY.EQ.-32) THEN
          JNEWT=JNEW
          ITEMP=JOLD1
          IF(ISIZE(1).GT.ISIZE(2)) THEN
            DO 48 J1=1,ILEN
            DO 46 J2=1,J1
            DX(JNEWT)=DX(ITEMP)
            ITEMP=ITEMP+1
            JNEWT=JNEWT+1
   46       CONTINUE
            ITEMP=ITEMP+ILEN-J1
   48       CONTINUE
          ELSE
            DO 54 J1=1,ILEN
            DO 52 J2=1,J1
            DX(JNEWT)=DX(ITEMP)
            ITEMP=ITEMP+1
            JNEWT=JNEWT+1
   52       CONTINUE
            JNEWT=JNEWT+ILEN-J1
   54       CONTINUE
            IF(ILEN.GT.1) THEN
              JNEWT=JNEW+1
              DO 58 J1=1,ILEN
              ITEMP=JOLD1+(J1*(J1+1))/2+J1-1
              DO 56 J2=J1+1,ILEN
              DX(JNEWT)=DX(ITEMP)
              JNEWT=JNEWT+1
              ITEMP=ITEMP+J2
   56         CONTINUE
              JNEWT=JNEWT+J1+1
   58         CONTINUE
            END IF
          END IF
        ELSE IF(IKEY.EQ.-33) THEN
          DX(JNEW)=DX(JOLD1)
          IF(ILEN.GT.1) THEN
            ITEMP=JOLD1+2
            DO 62 J1=2,ILEN
            DX(JNEW)=DX(JNEW)+DX(ITEMP)
            ITEMP=ITEMP+J1+1
   62       CONTINUE
          END IF
        ELSE IF(IKEY.EQ.-34) THEN
          JNEWT=JNEW
          ITEMP=JOLD1
          IF(ISIZE(1).GT.ISIZE(2)) THEN
            DO 64 J1=1,ILEN
            DX(JNEWT)=DX(ITEMP)
            JNEWT=JNEWT+1
            ITEMP=ITEMP+J1+1
   64       CONTINUE
          ELSE
            DX(JNEWT)=DX(ITEMP)
            JNEWT=JNEWT+1
            ITEMP=ITEMP+1
            IF(ILEN.GT.1) THEN
              DO 68 J1=2,ILEN
              DO 66 J2=1,J1-1
              DX(JNEWT)=0.D0
              JNEWT=JNEWT+1
   66         CONTINUE
              DX(JNEWT)=DX(ITEMP)
              ITEMP=ITEMP+1
              JNEWT=JNEWT+1
   68         CONTINUE
            END IF
          END IF
        END IF
      END IF
      IF(INFO.NE.0) THEN
        JNEWT=JNEW
        DO 78 J=1,JINCR2
        DX(JNEWT)=MISSNG
        JNEWT=JNEWT+1
   78   CONTINUE
      END IF
      JNEW=JNEW+JINCR2
      JOLD1=JOLD1+INCRN*JINCR
   79 CONTINUE
      IF(JOLD2.GT.0)JOLD2=JOLD2+IEDGE
   80 CONTINUE
C
C  Increment IOLD1, INEW
C
      IOLD1=IOLD1+1
      INEW=INEW+1
      GO TO 5
   90 CONTINUE
      WRITE(U6,100)
      GO TO 99
   91 CONTINUE
      WRITE(U6,101)IEDGE
      GO TO 99
   92 CONTINUE
      WRITE(U6,102)
      GO TO 99
   93 CONTINUE
      WRITE(U6,103)
      GO TO 99
   94 CONTINUE
      WRITE(U6,104)
      GO TO 99
   95 CONTINUE
      WRITE(U6,105)ISIZE(1),ISIZE(NILIST)
      GO TO 99
   97 CONTINUE
      WRITE(U6,107)
      GO TO 99
   98 CONTINUE
      WRITE(U6,108)
      GO TO 99
  911 CONTINUE
      WRITE(U6,111)
   99 CONTINUE
      IERROR=1
      RETURN
C
C  End of SUBROUTINE PSOLVE
C
      END
C
      SUBROUTINE HADAMG
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MAXIDS=10)
      PARAMETER (IXFLLD=5)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP,
     . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO,
     . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS,
     . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT,
     . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS,
     . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO,
     . NLEVEL,NRNSET,NRANGE,NHADAM,SDHADM,SDOUTP,SDVID,SDVPIN,IREPL,
     . IREPH,IFILE,SDRFW,IPASS,METHOD,NFILES,SDROUT,NROUT,NMAX,IXFILL
      INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS,
     . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN,
     . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,SDHADM,SDOUTP,SDVID,
     . SDVPIN,SDRFW,SDROUT,IXFILL(IXFLLD)
C
      INTEGER IRPOLY(3)
C
  202 FORMAT(' HADAMARD SIZE NOT OFFERED')
C
      IF(NHADAM.EQ.0) THEN
        SDHADM=0
        RETURN
      END IF
      SDHADM=NXPTD
      I=NHADAM*NHADAM
      CALL ROOMD(I)
      K=NHADAM
   22 CONTINUE
      IF(K.EQ.2*(K/2).AND.K.NE.0) THEN
        K=K/2
        GO TO 22
      END IF
      IF(K.EQ.1) THEN
        DX(SDHADM)=1.D0
        DX(SDHADM+1)=1.D0
        DX(SDHADM+2)=1.D0
        DX(SDHADM+3)=-1.D0
        K=2
      ELSE
C
C  Unable to provide replicates for 92, 116, 156, 172, or 184
C
        IF(NHADAM/K.LT.4.OR.K.GT.50.OR.K.EQ.23.OR.K.EQ.29.OR.
     .                 K.EQ.39.OR.K.EQ.43) THEN
          WRITE(U6,202)
          GO TO 99
        END IF
C
C  Special rule for multiples of 48, to preserve method used in
C  1987 replicate variances, based on 4k = p + 1 for k=12
C
        IF(K.EQ.3) THEN
          IF(NHADAM/K.GE.16)K=12
C
C  Special rule for multiples of 72, to furnish an initial row of
C  1's through 4k = p + 1
C
        ELSE IF(K.EQ.9) THEN
          IF(NHADAM/K.GE.8)K=18
C
C  Special rule for multiples of 104, to furnish an initial row of
C  1's through 4k = p + 1
C
        ELSE IF(K.EQ.13) THEN
          IF(NHADAM/K.GE.8)K=26
C
C  Special rule for multiples of 152, to furnish an initial row of
C  1's through 4k = p + 1
C
        ELSE IF(K.EQ.19) THEN
          IF(NHADAM/K.GE.8)K=38
        END IF
        IF(K.NE.7.AND.K.NE.13.AND.K.NE.25) THEN
C
C  For 36, 76, 124, 148, 184, or 196, must use 4k = 2 (p + 1)
C
          IF(K.EQ.9.OR.K.EQ.19.OR.K.EQ.31.OR.K.EQ.37.OR.K.EQ.46.OR.
     .       K.EQ.49) THEN
            I=4*K*K
            SDVPIN=NXPTD
            CALL ROOMD(I)
            IPRIME=2*K-1
          ELSE
C
C  In most cases, using 4k = p + 1
C
            SDVPIN=SDHADM
            IPRIME=4*K-1
          END IF
          ISD=NXPTD
          CALL ROOMD(IPRIME)
          I=IPRIME+1
          CALL METHD1(DX(SDVPIN),I,DX(ISD))
          NXPTD=ISD
C
C  For 52, 100, and 200, using 4k = 2 ( p**2 + 1)
C
        ELSE IF(K.EQ.13.OR.K.EQ.25) THEN
          SDVPIN=NXPTD
          I=4*K*K
          CALL ROOMD(I)
          IF(K.EQ.13) THEN
            IPRIME=5
            IRPOLY(2)=1
            IRPOLY(1)=2
          ELSE
            IPRIME=7
            IRPOLY(2)=3
            IRPOLY(1)=1
          END IF
          I=2*K-1
          ISD=NXPTD
          CALL ROOMD(I)
          I=K*2
          CALL METHD2(IPRIME,DX(SDVPIN),I,DX(ISD),IRPOLY)
          NXPTD=ISD
C
C  For 28, using 4k = p**3 + 1
C
        ELSE
          IPRIME=3
          I=4*K-1
          ISD=NXPTD
          CALL ROOMD(I)
          IRPOLY(3)=0
          IRPOLY(2)=2
          IRPOLY(1)=1
          I=4*K
          CALL METHD3(IPRIME,DX(SDHADM),I,DX(ISD),IRPOLY)
          NXPTD=ISD
        END IF
        IF(K.EQ.9.OR.K.EQ.13.OR.K.EQ.19.OR.K.EQ.25.OR.
     .     K.EQ.31.OR.K.EQ.37.OR.K.EQ.49) THEN
          IPRIME=K*2
          IW=4*K
          L=SDVPIN
          J1=SDHADM
          DO 25 J=1,IPRIME
          DO 24 I=1,IPRIME
          IF(I.EQ.J) THEN
            DX(J1)=1.D0
            DX(J1+1)=-1.D0
            DX(J1+IW)=-1.D0
            DX(J1+IW+1)=-1.D0
          ELSE IF(DX(L).GT.0.) THEN
            DX(J1)=1.D0
            DX(J1+1)=1.D0
            DX(J1+IW)=1.D0
            DX(J1+IW+1)=-1.D0
          ELSE
            DX(J1)=-1.D0
            DX(J1+1)=-1.D0
            DX(J1+IW)=-1.D0
            DX(J1+IW+1)=1.D0
          END IF
          L=L+1
          J1=J1+2
   24     CONTINUE
          J1=J1+IW
   25     CONTINUE
          NXPTD=SDVPIN
        END IF
        K=K*4
      END IF
   27 CONTINUE
      IF(K.LT.NHADAM) THEN
        CALL DDBLE(DX(SDHADM),K)
        GO TO 27
      END IF
      RETURN
   99 CONTINUE
      CALL FSTOP
      END
      SUBROUTINE DDBLE(DX,N)
      DOUBLE PRECISION DX(*)
      J1=2*N*N+1
      J2=J1+N
      K=1
      DO 10 I=1,N
      DO 5 J=1,N
      DX(J1)=DX(K)
      DX(J2)=-DX(K)
      J1=J1+1
      J2=J2+1
      K=K+1
    5 CONTINUE
      J1=J1+N
      J2=J2+N
   10 CONTINUE
      J1=1
      J2=N+1
      K=2*N*N+1
      DO 20 I=1,N
      DO 15 J=1,N
      DX(J1)=DX(K)
      DX(J2)=DX(K)
      J1=J1+1
      J2=J2+1
      K=K+1
   15 CONTINUE
      J1=J1+N
      J2=J2+N
      K=K+N
   20 CONTINUE
      N=2*N
      RETURN
      END
      SUBROUTINE METHD1(DX,K,D)
      DOUBLE PRECISION DX(K,K),D(*)
C
C  GENERATION OF HADAMARD MATRIX OF ORDER K=4T,
C  WHERE K=IPRIME+1, WITH IPRIME A PRIME NUMBER
C  FOR EXAMPLE, IPRIME=47 IS USED TO GENERATE THE
C  HADAMARD MATRIX OF ORDER 48
C
C
C  FIRST, FIND ALL PERFECT SQUARES, MOD IPRIME
C  D(I+1) WILL CONTAIN 1 IF I IS A PERFECT SQUARE, -1 OTHERWISE
C
      IPRIME=K-1
      DO 1 I=1,IPRIME
      D(I)=-1.D0
    1 CONTINUE
      DO 10 J=0,IPRIME-1
      IC=J*J
      IC=MOD(IC,IPRIME)
      D(IC+1)=1.D0
   10 CONTINUE
C
C  NEXT, PLACE 1'S IN THE FIRST ROWS AND COLUMNS OF DX
C  PLACE -1 ALONG THE REST OF THE MAIN DIAGONAL
C
      DX(1,1)=1.D0
      DO 20 I=2,K
      DX(I,1)=1.D0
      DX(1,I)=1.D0
      DX(I,I)=-1.D0
   20 CONTINUE
C
C  NEXT, COMPLETE DX BY ASSIGNING +1 IF J-I IS A PERFECT
C  SQUARE, -1 OTHERWISE
C
      DO 30 I=2,K
      DO 29 J=2,K
      IF(I.NE.J) THEN
        L=MOD(J-I+IPRIME,IPRIME)
        DX(I,J)=D(L+1)
      END IF
   29 CONTINUE
   30 CONTINUE
      RETURN
      END
      SUBROUTINE METHD2(IPRIME,DX,KX,D,IRPOLY)
      INTEGER A(2),B(2),C(2),IRPOLY(2)
      DOUBLE PRECISION DX(KX,KX),D(*)
      IP2=IPRIME*IPRIME
      DO 1 I=1,IP2
    1 D(I)=-1.D0
      DO 10 J=0,IPRIME-1
      A(2)=J
      DO 9 I=0,IPRIME-1
      A(1)=I
      CALL MULT2(IPRIME,A,A,C,IRPOLY)
      INDEX=IPRIME*C(2)+C(1)+1
      D(INDEX)=1.D0
    9 CONTINUE
   10 CONTINUE
      DX(1,1)=1.D0
      DO 12 I=2,KX
      DX(I,I)=-1.D0
      DX(I,1)=1.D0
      DX(1,I)=1.D0
   12 CONTINUE
      DO 20 J=0,IPRIME-1
      A(2)=J
      DO 19 I=0,IPRIME-1
      A(1)=I
      DO 18 L=J,IPRIME-1
      B(2)=L
      DO 17 K=0,IPRIME-1
      IF(L.EQ.J.AND.K.LE.I) GO TO 17
      B(1)=K
      C(2)=MOD(A(2)-B(2)+IPRIME,IPRIME)
      C(1)=MOD(A(1)-B(1)+IPRIME,IPRIME)
      INDEX=IPRIME*C(2)+C(1)+1
      I1=A(1)+IPRIME*A(2)+2
      I2=B(1)+IPRIME*B(2)+2
      DX(I1,I2)=D(INDEX)
      DX(I2,I1)=D(INDEX)
   17 CONTINUE
   18 CONTINUE
   19 CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE MULT2(IPRIME,A,B,C,IRPOLY)
      INTEGER A(2),B(2),C(2),IRPOLY(2),C3
      C(1)=MOD(A(1)*B(1),IPRIME)
      C(2)=MOD(A(1)*B(2)+A(2)*B(1),IPRIME)
      C3=MOD(A(2)*B(2),IPRIME)
      IF(C3.EQ.0)RETURN
      C(2)=MOD(IRPOLY(2)*(IPRIME-C3)+C(2),IPRIME)
      C(1)=MOD(IRPOLY(1)*(IPRIME-C3)+C(1),IPRIME)
      RETURN
      END
      SUBROUTINE METHD3(IPRIME,DX,KX,D,IRPOLY)
      INTEGER A(3),B(3),C(3),IRPOLY(3)
      DOUBLE PRECISION DX(KX,KX),D(*)
      IP2=IPRIME*IPRIME
      IP3=IPRIME*IP2
      DO 1 I=1,IP3
    1 D(I)=-1.D0
      DO 11 K=0,IPRIME-1
      A(3)=K
      DO 10 J=0,IPRIME-1
      A(2)=J
      DO 9 I=0,IPRIME-1
      A(1)=I
      CALL MULT3(IPRIME,A,A,C,IRPOLY)
      INDEX=IP2*C(3)+IPRIME*C(2)+C(1)+1
      D(INDEX)=1.D0
    9 CONTINUE
   10 CONTINUE
   11 CONTINUE
      DX(1,1)=1.D0
      DO 12 I=2,KX
      DX(I,I)=-1.D0
      DX(I,1)=1.D0
      DX(1,I)=1.D0
   12 CONTINUE
      DO 21 K=0,IPRIME-1
      A(3)=K
      DO 20 J=0,IPRIME-1
      A(2)=J
      DO 19 I=0,IPRIME-1
      A(1)=I
      DO 18 K1=0,IPRIME-1
      B(3)=K1
      DO 17 J1=0,IPRIME-1
      B(2)=J1
      DO 16 II=0,IPRIME-1
      IF(K.EQ.K1.AND.J.EQ.J1.AND.II.EQ.I)GO TO 16
      B(1)=II
      C(3)=MOD(A(3)-B(3)+IPRIME,IPRIME)
      C(2)=MOD(A(2)-B(2)+IPRIME,IPRIME)
      C(1)=MOD(A(1)-B(1)+IPRIME,IPRIME)
      INDEX=IP2*C(3)+IPRIME*C(2)+C(1)+1
      I1=A(1)+IPRIME*A(2)+IP2*A(3)+2
      I2=B(1)+IPRIME*B(2)+IP2*B(3)+2
      DX(I1,I2)=D(INDEX)
   16 CONTINUE
   17 CONTINUE
   18 CONTINUE
   19 CONTINUE
   20 CONTINUE
   21 CONTINUE
      RETURN
      END
      SUBROUTINE MULT3(IPRIME,A,B,C,IRPOLY)
      INTEGER A(3),B(3),C(3),IRPOLY(3),C4,C5
      C(1)=MOD(A(1)*B(1),IPRIME)
      C(2)=MOD(A(1)*B(2)+A(2)*B(1),IPRIME)
      C(3)=MOD(A(1)*B(3)+A(2)*B(2)+A(3)*B(1),IPRIME)
      C4=MOD(A(2)*B(3)+A(3)*B(2),IPRIME)
      C5=MOD(A(3)*B(3),IPRIME)
      IF(C5.EQ.0.AND.C4.EQ.0)RETURN
      C4=MOD(IRPOLY(3)*(IPRIME-C5)+C4,IPRIME)
      C(3)=MOD(IRPOLY(2)*(IPRIME-C5)+C(3),IPRIME)
      C(2)=MOD(IRPOLY(1)*(IPRIME-C5)+C(2),IPRIME)
      IF(C4.EQ.0)RETURN
      C(3)=MOD(IRPOLY(3)*(IPRIME-C4)+C(3),IPRIME)
      C(2)=MOD(IRPOLY(2)*(IPRIME-C4)+C(2),IPRIME)
      C(1)=MOD(IRPOLY(1)*(IPRIME-C4)+C(1),IPRIME)
      RETURN
      END
      SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
C
C     constant times a vector plus a vector.
C     uses unrolled loops for increments equal to one.
C     jack dongarra, linpack, 3/11/78.
C
      DOUBLE PRECISION DX(1),DY(1),DA
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      IF(N.LE.0)RETURN
      IF (DA .EQ. 0.0D0) RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        code for unequal increments or equal increments
C          not equal to 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DY(IY) = DY(IY) + DA*DX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        code for both increments equal to 1
C
C
C        clean-up loop
C
   20 M = MOD(N,4)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DY(I) = DY(I) + DA*DX(I)
   30 CONTINUE
      IF( N .LT. 4 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,4
        DY(I) = DY(I) + DA*DX(I)
        DY(I + 1) = DY(I + 1) + DA*DX(I + 1)
        DY(I + 2) = DY(I + 2) + DA*DX(I + 2)
        DY(I + 3) = DY(I + 3) + DA*DX(I + 3)
   50 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
C
C     forms the dot product of two vectors.
C     uses unrolled loops for increments equal to one.
C     jack dongarra, linpack, 3/11/78.
C
      DOUBLE PRECISION DX(*),DY(*),DTEMP
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      DDOT = 0.0D0
      DTEMP = 0.0D0
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        code for unequal increments or equal increments
C          not equal to 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DTEMP = DTEMP + DX(IX)*DY(IY)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      DDOT = DTEMP
      RETURN
C
C        code for both increments equal to 1
C
C
C        clean-up loop
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DTEMP = DTEMP + DX(I)*DY(I)
   30 CONTINUE
      IF( N .LT. 5 ) GO TO 60
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) +
     *   DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4)
   50 CONTINUE
   60 DDOT = DTEMP
      RETURN
      END
      SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
     $                   BETA, C, LDC )
C     .. Scalar Arguments ..
      CHARACTER*1        TRANSA, TRANSB
      INTEGER            M, N, K, LDA, LDB, LDC
      DOUBLE PRECISION   ALPHA, BETA
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * )
C     ..
C
C  Purpose
C  =======
C
C  DGEMM  performs one of the matrix-matrix operations
C
C     C := alpha*op( A )*op( B ) + beta*C,
C
C  where  op( X ) is one of
C
C     op( X ) = X   or   op( X ) = X',
C
C  alpha and beta are scalars, and A, B and C are matrices, with op( A )
C  an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.
C
C  Parameters
C  ==========
C
C  TRANSA - CHARACTER*1.
C           On entry, TRANSA specifies the form of op( A ) to be used in
C           the matrix multiplication as follows:
C
C              TRANSA = 'N' or 'n',  op( A ) = A.
C
C              TRANSA = 'T' or 't',  op( A ) = A'.
C
C              TRANSA = 'C' or 'c',  op( A ) = A'.
C
C           Unchanged on exit.
C
C  TRANSB - CHARACTER*1.
C           On entry, TRANSB specifies the form of op( B ) to be used in
C           the matrix multiplication as follows:
C
C              TRANSB = 'N' or 'n',  op( B ) = B.
C
C              TRANSB = 'T' or 't',  op( B ) = B'.
C
C              TRANSB = 'C' or 'c',  op( B ) = B'.
C
C           Unchanged on exit.
C
C  M      - INTEGER.
C           On entry,  M  specifies  the number  of rows  of the  matrix
C           op( A )  and of the  matrix  C.  M  must  be at least  zero.
C           Unchanged on exit.
C
C  N      - INTEGER.
C           On entry,  N  specifies the number  of columns of the matrix
C           op( B ) and the number of columns of the matrix C. N must be
C           at least zero.
C           Unchanged on exit.
C
C  K      - INTEGER.
C           On entry,  K  specifies  the number of columns of the matrix
C           op( A ) and the number of rows of the matrix op( B ). K must
C           be at least  zero.
C           Unchanged on exit.
C
C  ALPHA  - DOUBLE PRECISION.
C           On entry, ALPHA specifies the scalar alpha.
C           Unchanged on exit.
C
C  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
C           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
C           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
C           part of the array  A  must contain the matrix  A,  otherwise
C           the leading  k by m  part of the array  A  must contain  the
C           matrix A.
C           Unchanged on exit.
C
C  LDA    - INTEGER.
C           On entry, LDA specifies the first dimension of A as declared
C           in the calling (sub) program. When  TRANSA = 'N' or 'n' then
C           LDA must be at least  max( 1, m ), otherwise  LDA must be at
C           least  max( 1, k ).
C           Unchanged on exit.
C
C  B      - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
C           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
C           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
C           part of the array  B  must contain the matrix  B,  otherwise
C           the leading  n by k  part of the array  B  must contain  the
C           matrix B.
C           Unchanged on exit.
C
C  LDB    - INTEGER.
C           On entry, LDB specifies the first dimension of B as declared
C           in the calling (sub) program. When  TRANSB = 'N' or 'n' then
C           LDB must be at least  max( 1, k ), otherwise  LDB must be at
C           least  max( 1, n ).
C           Unchanged on exit.
C
C  BETA   - DOUBLE PRECISION.
C           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
C           supplied as zero then C need not be set on input.
C           Unchanged on exit.
C
C  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
C           Before entry, the leading  m by n  part of the array  C must
C           contain the matrix  C,  except when  beta  is zero, in which
C           case C need not be set on entry.
C           On exit, the array  C  is overwritten by the  m by n  matrix
C           ( alpha*op( A )*op( B ) + beta*C ).
C
C  LDC    - INTEGER.
C           On entry, LDC specifies the first dimension of C as declared
C           in  the  calling  (sub)  program.   LDC  must  be  at  least
C           max( 1, m ).
C           Unchanged on exit.
C
C
C  Level 3 Blas routine.
C
C  -- Written on 8-February-1989.
C     Jack Dongarra, Argonne National Laboratory.
C     Iain Duff, AERE Harwell.
C     Jeremy Du Croz, Numerical Algorithms Group Ltd.
C     Sven Hammarling, Numerical Algorithms Group Ltd.
C
C
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     .. Local Scalars ..
      LOGICAL            NOTA, NOTB
      INTEGER            I, INFO, J, L, NCOLA, NROWA, NROWB
      DOUBLE PRECISION   TEMP
C     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Executable Statements ..
C
C     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
C     transposed and set  NROWA, NCOLA and  NROWB  as the number of rows
C     and  columns of  A  and the  number of  rows  of  B  respectively.
C
      NOTA  = LSAME( TRANSA, 'N' )
      NOTB  = LSAME( TRANSB, 'N' )
      IF( NOTA )THEN
         NROWA = M
         NCOLA = K
      ELSE
         NROWA = K
         NCOLA = M
      END IF
      IF( NOTB )THEN
         NROWB = K
      ELSE
         NROWB = N
      END IF
C
C     Test the input parameters.
C
      INFO = 0
      IF(      ( .NOT.NOTA                 ).AND.
     $         ( .NOT.LSAME( TRANSA, 'C' ) ).AND.
     $         ( .NOT.LSAME( TRANSA, 'T' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.NOTB                 ).AND.
     $         ( .NOT.LSAME( TRANSB, 'C' ) ).AND.
     $         ( .NOT.LSAME( TRANSB, 'T' ) )      )THEN
         INFO = 2
      ELSE IF( M  .LT.0               )THEN
         INFO = 3
      ELSE IF( N  .LT.0               )THEN
         INFO = 4
      ELSE IF( K  .LT.0               )THEN
         INFO = 5
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 8
      ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN
         INFO = 10
      ELSE IF( LDC.LT.MAX( 1, M     ) )THEN
         INFO = 13
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DGEMM ', INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
     $    ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
C
C     And if  alpha.eq.zero.
C
      IF( ALPHA.EQ.ZERO )THEN
         IF( BETA.EQ.ZERO )THEN
            DO 20, J = 1, N
               DO 10, I = 1, M
                  C( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               DO 30, I = 1, M
                  C( I, J ) = BETA*C( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         RETURN
      END IF
C
C     Start the operations.
C
      IF( NOTB )THEN
         IF( NOTA )THEN
C
C           Form  C := alpha*A*B + beta*C.
C
            DO 90, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 50, I = 1, M
                     C( I, J ) = ZERO
   50             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 60, I = 1, M
                     C( I, J ) = BETA*C( I, J )
   60             CONTINUE
               END IF
               DO 80, L = 1, K
                  IF( B( L, J ).NE.ZERO )THEN
                     TEMP = ALPHA*B( L, J )
                     DO 70, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
   70                CONTINUE
                  END IF
   80          CONTINUE
   90       CONTINUE
         ELSE
C
C           Form  C := alpha*A'*B + beta*C
C
            DO 120, J = 1, N
               DO 110, I = 1, M
                  TEMP = ZERO
                  DO 100, L = 1, K
                     TEMP = TEMP + A( L, I )*B( L, J )
  100             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  110          CONTINUE
  120       CONTINUE
         END IF
      ELSE
         IF( NOTA )THEN
C
C           Form  C := alpha*A*B' + beta*C
C
            DO 170, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 130, I = 1, M
                     C( I, J ) = ZERO
  130             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 140, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  140             CONTINUE
               END IF
               DO 160, L = 1, K
                  IF( B( J, L ).NE.ZERO )THEN
                     TEMP = ALPHA*B( J, L )
                     DO 150, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  150                CONTINUE
                  END IF
  160          CONTINUE
  170       CONTINUE
         ELSE
C
C           Form  C := alpha*A'*B' + beta*C
C
            DO 200, J = 1, N
               DO 190, I = 1, M
                  TEMP = ZERO
                  DO 180, L = 1, K
                     TEMP = TEMP + A( L, I )*B( J, L )
  180             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  190          CONTINUE
  200       CONTINUE
         END IF
      END IF
C
      RETURN
C
C     End of DGEMM .
C
      END
      SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
     $                   BETA, Y, INCY )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA, BETA
      INTEGER            INCX, INCY, LDA, M, N
      CHARACTER*1        TRANS
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * ), Y( * )
C     ..
C
C  Purpose
C  =======
C
C  DGEMV  performs one of the matrix-vector operations
C
C     y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y,
C
C  where alpha and beta are scalars, x and y are vectors and A is an
C  m by n matrix.
C
C  Parameters
C  ==========
C
C  TRANS  - CHARACTER*1.
C           On entry, TRANS specifies the operation to be performed as
C           follows:
C
C              TRANS = 'N' or 'n'   y := alpha*A*x + beta*y.
C
C              TRANS = 'T' or 't'   y := alpha*A'*x + beta*y.
C
C              TRANS = 'C' or 'c'   y := alpha*A'*x + beta*y.
C
C           Unchanged on exit.
C
C  M      - INTEGER.
C           On entry, M specifies the number of rows of the matrix A.
C           M must be at least zero.
C           Unchanged on exit.
C
C  N      - INTEGER.
C           On entry, N specifies the number of columns of the matrix A.
C           N must be at least zero.
C           Unchanged on exit.
C
C  ALPHA  - DOUBLE PRECISION.
C           On entry, ALPHA specifies the scalar alpha.
C           Unchanged on exit.
C
C  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
C           Before entry, the leading m by n part of the array A must
C           contain the matrix of coefficients.
C           Unchanged on exit.
C
C  LDA    - INTEGER.
C           On entry, LDA specifies the first dimension of A as declared
C           in the calling (sub) program. LDA must be at least
C           max( 1, m ).
C           Unchanged on exit.
C
C  X      - DOUBLE PRECISION array of DIMENSION at least
C           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
C           and at least
C           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
C           Before entry, the incremented array X must contain the
C           vector x.
C           Unchanged on exit.
C
C  INCX   - INTEGER.
C           On entry, INCX specifies the increment for the elements of
C           X. INCX must not be zero.
C           Unchanged on exit.
C
C  BETA   - DOUBLE PRECISION.
C           On entry, BETA specifies the scalar beta. When BETA is
C           supplied as zero then Y need not be set on input.
C           Unchanged on exit.
C
C  Y      - DOUBLE PRECISION array of DIMENSION at least
C           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
C           and at least
C           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
C           Before entry with BETA non-zero, the incremented array Y
C           must contain the vector y. On exit, Y is overwritten by the
C           updated vector y.
C
C  INCY   - INTEGER.
C           On entry, INCY specifies the increment for the elements of
C           Y. INCY must not be zero.
C           Unchanged on exit.
C
C
C  Level 2 Blas routine.
C
C  -- Written on 22-October-1986.
C     Jack Dongarra, Argonne National Lab.
C     Jeremy Du Croz, Nag Central Office.
C     Sven Hammarling, Nag Central Office.
C     Richard Hanson, Sandia National Labs.
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      IF     ( .NOT.LSAME( TRANS, 'N' ).AND.
     $         .NOT.LSAME( TRANS, 'T' ).AND.
     $         .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 1
      ELSE IF( M.LT.0 )THEN
         INFO = 2
      ELSE IF( N.LT.0 )THEN
         INFO = 3
      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
         INFO = 6
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 8
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DGEMV ', INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
     $    ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
C
C     Set  LENX  and  LENY, the lengths of the vectors x and y, and set
C     up the start points in  X  and  Y.
C
      IF( LSAME( TRANS, 'N' ) )THEN
         LENX = N
         LENY = M
      ELSE
         LENX = M
         LENY = N
      END IF
      IF( INCX.GT.0 )THEN
         KX = 1
      ELSE
         KX = 1 - ( LENX - 1 )*INCX
      END IF
      IF( INCY.GT.0 )THEN
         KY = 1
      ELSE
         KY = 1 - ( LENY - 1 )*INCY
      END IF
C
C     Start the operations. In this version the elements of A are
C     accessed sequentially with one pass through A.
C
C     First form  y := beta*y.
C
      IF( BETA.NE.ONE )THEN
         IF( INCY.EQ.1 )THEN
            IF( BETA.EQ.ZERO )THEN
               DO 10, I = 1, LENY
                  Y( I ) = ZERO
   10          CONTINUE
            ELSE
               DO 20, I = 1, LENY
                  Y( I ) = BETA*Y( I )
   20          CONTINUE
            END IF
         ELSE
            IY = KY
            IF( BETA.EQ.ZERO )THEN
               DO 30, I = 1, LENY
                  Y( IY ) = ZERO
                  IY      = IY   + INCY
   30          CONTINUE
            ELSE
               DO 40, I = 1, LENY
                  Y( IY ) = BETA*Y( IY )
                  IY      = IY           + INCY
   40          CONTINUE
            END IF
         END IF
      END IF
      IF( ALPHA.EQ.ZERO )
     $   RETURN
      IF( LSAME( TRANS, 'N' ) )THEN
C
C        Form  y := alpha*A*x + y.
C
         JX = KX
         IF( INCY.EQ.1 )THEN
            DO 60, J = 1, N
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  DO 50, I = 1, M
                     Y( I ) = Y( I ) + TEMP*A( I, J )
   50             CONTINUE
               END IF
               JX = JX + INCX
   60       CONTINUE
         ELSE
            DO 80, J = 1, N
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  IY   = KY
                  DO 70, I = 1, M
                     Y( IY ) = Y( IY ) + TEMP*A( I, J )
                     IY      = IY      + INCY
   70             CONTINUE
               END IF
               JX = JX + INCX
   80       CONTINUE
         END IF
      ELSE
C
C        Form  y := alpha*A'*x + y.
C
         JY = KY
         IF( INCX.EQ.1 )THEN
            DO 100, J = 1, N
               TEMP = ZERO
               DO 90, I = 1, M
                  TEMP = TEMP + A( I, J )*X( I )
   90          CONTINUE
               Y( JY ) = Y( JY ) + ALPHA*TEMP
               JY      = JY      + INCY
  100       CONTINUE
         ELSE
            DO 120, J = 1, N
               TEMP = ZERO
               IX   = KX
               DO 110, I = 1, M
                  TEMP = TEMP + A( I, J )*X( IX )
                  IX   = IX   + INCX
  110          CONTINUE
               Y( JY ) = Y( JY ) + ALPHA*TEMP
               JY      = JY      + INCY
  120       CONTINUE
         END IF
      END IF
C
      RETURN
C
C     End of DGEMV .
C
      END
      SUBROUTINE DGER  ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA
      INTEGER            INCX, INCY, LDA, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * ), Y( * )
C     ..
C
C  Purpose
C  =======
C
C  DGER   performs the rank 1 operation
C
C     A := alpha*x*y' + A,
C
C  where alpha is a scalar, x is an m element vector, y is an n element
C  vector and A is an m by n matrix.
C
C  Parameters
C  ==========
C
C  M      - INTEGER.
C           On entry, M specifies the number of rows of the matrix A.
C           M must be at least zero.
C           Unchanged on exit.
C
C  N      - INTEGER.
C           On entry, N specifies the number of columns of the matrix A.
C           N must be at least zero.
C           Unchanged on exit.
C
C  ALPHA  - DOUBLE PRECISION.
C           On entry, ALPHA specifies the scalar alpha.
C           Unchanged on exit.
C
C  X      - DOUBLE PRECISION array of dimension at least
C           ( 1 + ( m - 1 )*abs( INCX ) ).
C           Before entry, the incremented array X must contain the m
C           element vector x.
C           Unchanged on exit.
C
C  INCX   - INTEGER.
C           On entry, INCX specifies the increment for the elements of
C           X. INCX must not be zero.
C           Unchanged on exit.
C
C  Y      - DOUBLE PRECISION array of dimension at least
C           ( 1 + ( n - 1 )*abs( INCY ) ).
C           Before entry, the incremented array Y must contain the n
C           element vector y.
C           Unchanged on exit.
C
C  INCY   - INTEGER.
C           On entry, INCY specifies the increment for the elements of
C           Y. INCY must not be zero.
C           Unchanged on exit.
C
C  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
C           Before entry, the leading m by n part of the array A must
C           contain the matrix of coefficients. On exit, A is
C           overwritten by the updated matrix.
C
C  LDA    - INTEGER.
C           On entry, LDA specifies the first dimension of A as declared
C           in the calling (sub) program. LDA must be at least
C           max( 1, m ).
C           Unchanged on exit.
C
C
C  Level 2 Blas routine.
C
C  -- Written on 22-October-1986.
C     Jack Dongarra, Argonne National Lab.
C     Jeremy Du Croz, Nag Central Office.
C     Sven Hammarling, Nag Central Office.
C     Richard Hanson, Sandia National Labs.
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
C     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JY, KX
C     .. External Subroutines ..
      EXTERNAL           XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      IF     ( M.LT.0 )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 5
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 7
      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DGER  ', INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
     $   RETURN
C
C     Start the operations. In this version the elements of A are
C     accessed sequentially with one pass through A.
C
      IF( INCY.GT.0 )THEN
         JY = 1
      ELSE
         JY = 1 - ( N - 1 )*INCY
      END IF
      IF( INCX.EQ.1 )THEN
         DO 20, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               DO 10, I = 1, M
                  A( I, J ) = A( I, J ) + X( I )*TEMP
   10          CONTINUE
            END IF
            JY = JY + INCY
   20    CONTINUE
      ELSE
         IF( INCX.GT.0 )THEN
            KX = 1
         ELSE
            KX = 1 - ( M - 1 )*INCX
         END IF
         DO 40, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               IX   = KX
               DO 30, I = 1, M
                  A( I, J ) = A( I, J ) + X( IX )*TEMP
                  IX        = IX        + INCX
   30          CONTINUE
            END IF
            JY = JY + INCY
   40    CONTINUE
      END IF
C
      RETURN
C
C     End of DGER  .
C
      END
      DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX)
      INTEGER I, INCX, IX, J, N, NEXT
      DOUBLE PRECISION   DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE
      DATA   ZERO, ONE /0.0D0, 1.0D0/
C
C     euclidean norm of the n-vector stored in dx() with storage
C     increment incx .
C     if    n .le. 0 return with result = 0.
C     if n .ge. 1 then incx must be .ge. 1
C
C           c.l.lawson, 1978 jan 08
C     modified to correct problem with negative increment, 8/21/90.
C     modified to correct failure to update ix, 1/25/92.
C
C     four phase method     using two built-in constants that are
C     hopefully applicable to all machines.
C         cutlo = maximum of  dsqrt(u/eps)  over all known machines.
C         cuthi = minimum of  dsqrt(v)      over all known machines.
C     where
C         eps = smallest no. such that eps + 1. .gt. 1.
C         u   = smallest positive no.   (underflow limit)
C         v   = largest  no.            (overflow  limit)
C
C     brief outline of algorithm..
C
C     phase 1    scans zero components.
C     move to phase 2 when a component is nonzero and .le. cutlo
C     move to phase 3 when a component is .gt. cutlo
C     move to phase 4 when a component is .ge. cuthi/m
C     where m = n for x() real and m = 2*n for complex.
C
C     values for cutlo and cuthi..
C     from the environmental parameters listed in the imsl converter
C     document the limiting values are as follows..
C     cutlo, s.p.   u/eps = 2**(-102) for  honeywell.  close seconds are
C                   univac and dec at 2**(-103)
C                   thus cutlo = 2**(-51) = 4.44089e-16
C     cuthi, s.p.   v = 2**127 for univac, honeywell, and dec.
C                   thus cuthi = 2**(63.5) = 1.30438e19
C     cutlo, d.p.   u/eps = 2**(-67) for honeywell and dec.
C                   thus cutlo = 2**(-33.5) = 8.23181d-11
C     cuthi, d.p.   same as s.p.  cuthi = 1.30438d19
C     data cutlo, cuthi / 8.232d-11,  1.304d19 /
C     data cutlo, cuthi / 4.441e-16,  1.304e19 /
      DATA CUTLO, CUTHI / 8.232D-11,  1.304D19 /
C
      IF(N .GT. 0) GO TO 10
         DNRM2  = ZERO
         GO TO 300
C
   10 ASSIGN 30 TO NEXT
      SUM = ZERO
      I = 1
      IF( INCX .LT. 0 )I = (-N+1)*INCX + 1
      IX = 1
C                                                 BEGIN MAIN LOOP
   20    GO TO NEXT,(30, 50, 70, 110)
   30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
      ASSIGN 50 TO NEXT
      XMAX = ZERO
C
C                        PHASE 1.  SUM IS ZERO
C
   50 IF( DX(I) .EQ. ZERO) GO TO 200
      IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
C
C                                PREPARE FOR PHASE 2.
      ASSIGN 70 TO NEXT
      GO TO 105
C
C                                PREPARE FOR PHASE 4.
C
  100 CONTINUE
      IX = J
      ASSIGN 110 TO NEXT
      SUM = (SUM / DX(I)) / DX(I)
  105 XMAX = DABS(DX(I))
      GO TO 115
C
C                   PHASE 2.  SUM IS SMALL.
C                             SCALE TO AVOID DESTRUCTIVE UNDERFLOW.
C
   70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75
C
C                     COMMON CODE FOR PHASES 2 AND 4.
C                     IN PHASE 4 SUM IS LARGE.  SCALE TO AVOID OVERFLOW.
C
  110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115
         SUM = ONE + SUM * (XMAX / DX(I))**2
         XMAX = DABS(DX(I))
         GO TO 200
C
  115 SUM = SUM + (DX(I)/XMAX)**2
      GO TO 200
C
C
C                  PREPARE FOR PHASE 3.
C
   75 SUM = (SUM * XMAX) * XMAX
C
C
C     FOR REAL OR D.P. SET HITEST = CUTHI/N
C     FOR COMPLEX      SET HITEST = CUTHI/(2*N)
C
   85 HITEST = CUTHI/FLOAT( N )
C
C                   PHASE 3.  SUM IS MID-RANGE.  NO SCALING.
C
      DO 95 J = IX,N
      IF(DABS(DX(I)) .GE. HITEST) GO TO 100
         SUM = SUM + DX(I)**2
         I = I + INCX
   95 CONTINUE
      DNRM2 = DSQRT( SUM )
      GO TO 300
C
  200 CONTINUE
      IX = IX + 1
      I = I + INCX
      IF( IX .LE. N ) GO TO 20
C
C              END OF MAIN LOOP.
C
C              COMPUTE SQUARE ROOT AND ADJUST FOR SCALING.
C
      DNRM2 = XMAX * DSQRT(SUM)
  300 CONTINUE
      RETURN
      END
      SUBROUTINE  DSCAL(N,DA,DX,INCX)
C
C     scales a vector by a constant.
C     uses unrolled loops for increment equal to one.
C     jack dongarra, linpack, 3/11/78.
C     modified to correct problem with negative increment, 8/21/90.
C
      DOUBLE PRECISION DA,DX(*)
      INTEGER I,INCX,IX,M,MP1,N
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GO TO 20
C
C        code for increment not equal to 1
C
      IX = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      DO 10 I = 1,N
        DX(IX) = DA*DX(IX)
        IX = IX + INCX
   10 CONTINUE
      RETURN
C
C        code for increment equal to 1
C
C
C        clean-up loop
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DX(I) = DA*DX(I)
   30 CONTINUE
      IF( N .LT. 5 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        DX(I) = DA*DX(I)
        DX(I + 1) = DA*DX(I + 1)
        DX(I + 2) = DA*DX(I + 2)
        DX(I + 3) = DA*DX(I + 3)
        DX(I + 4) = DA*DX(I + 4)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE DSPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA, BETA
      INTEGER            INCX, INCY, N
      CHARACTER*1        UPLO
C     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), X( * ), Y( * )
C     ..
C
C  Purpose
C  =======
C
C  DSPMV  performs the matrix-vector operation
C
C     y := alpha*A*x + beta*y,
C
C  where alpha and beta are scalars, x and y are n element vectors and
C  A is an n by n symmetric matrix, supplied in packed form.
C
C  Parameters
C  ==========
C
C  UPLO   - CHARACTER*1.
C           On entry, UPLO specifies whether the upper or lower
C           triangular part of the matrix A is supplied in the packed
C           array AP as follows:
C
C              UPLO = 'U' or 'u'   The upper triangular part of A is
C                                  supplied in AP.
C
C              UPLO = 'L' or 'l'   The lower triangular part of A is
C                                  supplied in AP.
C
C           Unchanged on exit.
C
C  N      - INTEGER.
C           On entry, N specifies the order of the matrix A.
C           N must be at least zero.
C           Unchanged on exit.
C
C  ALPHA  - DOUBLE PRECISION.
C           On entry, ALPHA specifies the scalar alpha.
C           Unchanged on exit.
C
C  AP     - DOUBLE PRECISION array of DIMENSION at least
C           ( ( n*( n + 1 ) )/2 ).
C           Before entry with UPLO = 'U' or 'u', the array AP must
C           contain the upper triangular part of the symmetric matrix
C           packed sequentially, column by column, so that AP( 1 )
C           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
C           and a( 2, 2 ) respectively, and so on.
C           Before entry with UPLO = 'L' or 'l', the array AP must
C           contain the lower triangular part of the symmetric matrix
C           packed sequentially, column by column, so that AP( 1 )
C           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
C           and a( 3, 1 ) respectively, and so on.
C           Unchanged on exit.
C
C  X      - DOUBLE PRECISION array of dimension at least
C           ( 1 + ( n - 1 )*abs( INCX ) ).
C           Before entry, the incremented array X must contain the n
C           element vector x.
C           Unchanged on exit.
C
C  INCX   - INTEGER.
C           On entry, INCX specifies the increment for the elements of
C           X. INCX must not be zero.
C           Unchanged on exit.
C
C  BETA   - DOUBLE PRECISION.
C           On entry, BETA specifies the scalar beta. When BETA is
C           supplied as zero then Y need not be set on input.
C           Unchanged on exit.
C
C  Y      - DOUBLE PRECISION array of dimension at least
C           ( 1 + ( n - 1 )*abs( INCY ) ).
C           Before entry, the incremented array Y must contain the n
C           element vector y. On exit, Y is overwritten by the updated
C           vector y.
C
C  INCY   - INTEGER.
C           On entry, INCY specifies the increment for the elements of
C           Y. INCY must not be zero.
C           Unchanged on exit.
C
C
C  Level 2 Blas routine.
C
C  -- Written on 22-October-1986.
C     Jack Dongarra, Argonne National Lab.
C     Jeremy Du Croz, Nag Central Office.
C     Sven Hammarling, Nag Central Office.
C     Richard Hanson, Sandia National Labs.
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     .. Local Scalars ..
      DOUBLE PRECISION   TEMP1, TEMP2
      INTEGER            I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           XERBLA
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      IF     ( .NOT.LSAME( UPLO, 'U' ).AND.
     $         .NOT.LSAME( UPLO, 'L' )      )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 6
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DSPMV ', INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
C
C     Set up the start points in  X  and  Y.
C
      IF( INCX.GT.0 )THEN
         KX = 1
      ELSE
         KX = 1 - ( N - 1 )*INCX
      END IF
      IF( INCY.GT.0 )THEN
         KY = 1
      ELSE
         KY = 1 - ( N - 1 )*INCY
      END IF
C
C     Start the operations. In this version the elements of the array AP
C     are accessed sequentially with one pass through AP.
C
C     First form  y := beta*y.
C
      IF( BETA.NE.ONE )THEN
         IF( INCY.EQ.1 )THEN
            IF( BETA.EQ.ZERO )THEN
               DO 10, I = 1, N
                  Y( I ) = ZERO
   10          CONTINUE
            ELSE
               DO 20, I = 1, N
                  Y( I ) = BETA*Y( I )
   20          CONTINUE
            END IF
         ELSE
            IY = KY
            IF( BETA.EQ.ZERO )THEN
               DO 30, I = 1, N
                  Y( IY ) = ZERO
                  IY      = IY   + INCY
   30          CONTINUE
            ELSE
               DO 40, I = 1, N
                  Y( IY ) = BETA*Y( IY )
                  IY      = IY           + INCY
   40          CONTINUE
            END IF
         END IF
      END IF
      IF( ALPHA.EQ.ZERO )
     $   RETURN
      KK = 1
      IF( LSAME( UPLO, 'U' ) )THEN
C
C        Form  y  when AP contains the upper triangle.
C
         IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
            DO 60, J = 1, N
               TEMP1 = ALPHA*X( J )
               TEMP2 = ZERO
               K     = KK
               DO 50, I = 1, J - 1
                  Y( I ) = Y( I ) + TEMP1*AP( K )
                  TEMP2  = TEMP2  + AP( K )*X( I )
                  K      = K      + 1
   50          CONTINUE
               Y( J ) = Y( J ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2
               KK     = KK     + J
   60       CONTINUE
         ELSE
            JX = KX
            JY = KY
            DO 80, J = 1, N
               TEMP1 = ALPHA*X( JX )
               TEMP2 = ZERO
               IX    = KX
               IY    = KY
               DO 70, K = KK, KK + J - 2
                  Y( IY ) = Y( IY ) + TEMP1*AP( K )
                  TEMP2   = TEMP2   + AP( K )*X( IX )
                  IX      = IX      + INCX
                  IY      = IY      + INCY
   70          CONTINUE
               Y( JY ) = Y( JY ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2
               JX      = JX      + INCX
               JY      = JY      + INCY
               KK      = KK      + J
   80       CONTINUE
         END IF
      ELSE
C
C        Form  y  when AP contains the lower triangle.
C
         IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
            DO 100, J = 1, N
               TEMP1  = ALPHA*X( J )
               TEMP2  = ZERO
               Y( J ) = Y( J )       + TEMP1*AP( KK )
               K      = KK           + 1
               DO 90, I = J + 1, N
                  Y( I ) = Y( I ) + TEMP1*AP( K )
                  TEMP2  = TEMP2  + AP( K )*X( I )
                  K      = K      + 1
   90          CONTINUE
               Y( J ) = Y( J ) + ALPHA*TEMP2
               KK     = KK     + ( N - J + 1 )
  100       CONTINUE
         ELSE
            JX = KX
            JY = KY
            DO 120, J = 1, N
               TEMP1   = ALPHA*X( JX )
               TEMP2   = ZERO
               Y( JY ) = Y( JY )       + TEMP1*AP( KK )
               IX      = JX
               IY      = JY
               DO 110, K = KK + 1, KK + N - J
                  IX      = IX      + INCX
                  IY      = IY      + INCY
                  Y( IY ) = Y( IY ) + TEMP1*AP( K )
                  TEMP2   = TEMP2   + AP( K )*X( IX )
  110          CONTINUE
               Y( JY ) = Y( JY ) + ALPHA*TEMP2
               JX      = JX      + INCX
               JY      = JY      + INCY
               KK      = KK      + ( N - J + 1 )
  120       CONTINUE
         END IF
      END IF
C
      RETURN
C
C     End of DSPMV .
C
      END
      SUBROUTINE DSPR  ( UPLO, N, ALPHA, X, INCX, AP )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA
      INTEGER            INCX, N
      CHARACTER*1        UPLO
C     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), X( * )
C     ..
C
C  Purpose
C  =======
C
C  DSPR    performs the symmetric rank 1 operation
C
C     A := alpha*x*x' + A,
C
C  where alpha is a real scalar, x is an n element vector and A is an
C  n by n symmetric matrix, supplied in packed form.
C
C  Parameters
C  ==========
C
C  UPLO   - CHARACTER*1.
C           On entry, UPLO specifies whether the upper or lower
C           triangular part of the matrix A is supplied in the packed
C           array AP as follows:
C
C              UPLO = 'U' or 'u'   The upper triangular part of A is
C                                  supplied in AP.
C
C              UPLO = 'L' or 'l'   The lower triangular part of A is
C                                  supplied in AP.
C
C           Unchanged on exit.
C
C  N      - INTEGER.
C           On entry, N specifies the order of the matrix A.
C           N must be at least zero.
C           Unchanged on exit.
C
C  ALPHA  - DOUBLE PRECISION.
C           On entry, ALPHA specifies the scalar alpha.
C           Unchanged on exit.
C
C  X      - DOUBLE PRECISION array of dimension at least
C           ( 1 + ( n - 1 )*abs( INCX ) ).
C           Before entry, the incremented array X must contain the n
C           element vector x.
C           Unchanged on exit.
C
C  INCX   - INTEGER.
C           On entry, INCX specifies the increment for the elements of
C           X. INCX must not be zero.
C           Unchanged on exit.
C
C  AP     - DOUBLE PRECISION array of DIMENSION at least
C           ( ( n*( n + 1 ) )/2 ).
C           Before entry with  UPLO = 'U' or 'u', the array AP must
C           contain the upper triangular part of the symmetric matrix
C           packed sequentially, column by column, so that AP( 1 )
C           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
C           and a( 2, 2 ) respectively, and so on. On exit, the array
C           AP is overwritten by the upper triangular part of the
C           updated matrix.
C           Before entry with UPLO = 'L' or 'l', the array AP must
C           contain the lower triangular part of the symmetric matrix
C           packed sequentially, column by column, so that AP( 1 )
C           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
C           and a( 3, 1 ) respectively, and so on. On exit, the array
C           AP is overwritten by the lower triangular part of the
C           updated matrix.
C
C
C  Level 2 Blas routine.
C
C  -- Written on 22-October-1986.
C     Jack Dongarra, Argonne National Lab.
C     Jeremy Du Croz, Nag Central Office.
C     Sven Hammarling, Nag Central Office.
C     Richard Hanson, Sandia National Labs.
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
C     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JX, K, KK, KX
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           XERBLA
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      IF     ( .NOT.LSAME( UPLO, 'U' ).AND.
     $         .NOT.LSAME( UPLO, 'L' )      )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 5
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DSPR  ', INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
     $   RETURN
C
C     Set the start point in X if the increment is not unity.
C
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
C
C     Start the operations. In this version the elements of the array AP
C     are accessed sequentially with one pass through AP.
C
      KK = 1
      IF( LSAME( UPLO, 'U' ) )THEN
C
C        Form  A  when upper triangle is stored in AP.
C
         IF( INCX.EQ.1 )THEN
            DO 20, J = 1, N
               IF( X( J ).NE.ZERO )THEN
                  TEMP = ALPHA*X( J )
                  K    = KK
                  DO 10, I = 1, J
                     AP( K ) = AP( K ) + X( I )*TEMP
                     K       = K       + 1
   10             CONTINUE
               END IF
               KK = KK + J
   20       CONTINUE
         ELSE
            JX = KX
            DO 40, J = 1, N
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  IX   = KX
                  DO 30, K = KK, KK + J - 1
                     AP( K ) = AP( K ) + X( IX )*TEMP
                     IX      = IX      + INCX
   30             CONTINUE
               END IF
               JX = JX + INCX
               KK = KK + J
   40       CONTINUE
         END IF
      ELSE
C
C        Form  A  when lower triangle is stored in AP.
C
         IF( INCX.EQ.1 )THEN
            DO 60, J = 1, N
               IF( X( J ).NE.ZERO )THEN
                  TEMP = ALPHA*X( J )
                  K    = KK
                  DO 50, I = J, N
                     AP( K ) = AP( K ) + X( I )*TEMP
                     K       = K       + 1
   50             CONTINUE
               END IF
               KK = KK + N - J + 1
   60       CONTINUE
         ELSE
            JX = KX
            DO 80, J = 1, N
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  IX   = JX
                  DO 70, K = KK, KK + N - J
                     AP( K ) = AP( K ) + X( IX )*TEMP
                     IX      = IX      + INCX
   70             CONTINUE
               END IF
               JX = JX + INCX
               KK = KK + N - J + 1
   80       CONTINUE
         END IF
      END IF
C
      RETURN
C
C     End of DSPR  .
C
      END
C
      SUBROUTINE DSPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA
      INTEGER            INCX, INCY, N
      CHARACTER*1        UPLO
C     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), X( * ), Y( * )
C     ..
C
C  Purpose
C  =======
C
C  DSPR2  performs the symmetric rank 2 operation
C
C     A := alpha*x*y' + alpha*y*x' + A,
C
C  where alpha is a scalar, x and y are n element vectors and A is an
C  n by n symmetric matrix, supplied in packed form.
C
C  Parameters
C  ==========
C
C  UPLO   - CHARACTER*1.
C           On entry, UPLO specifies whether the upper or lower
C           triangular part of the matrix A is supplied in the packed
C           array AP as follows:
C
C              UPLO = 'U' or 'u'   The upper triangular part of A is
C                                  supplied in AP.
C
C              UPLO = 'L' or 'l'   The lower triangular part of A is
C                                  supplied in AP.
C
C           Unchanged on exit.
C
C  N      - INTEGER.
C           On entry, N specifies the order of the matrix A.
C           N must be at least zero.
C           Unchanged on exit.
C
C  ALPHA  - DOUBLE PRECISION.
C           On entry, ALPHA specifies the scalar alpha.
C           Unchanged on exit.
C
C  X      - DOUBLE PRECISION array of dimension at least
C           ( 1 + ( n - 1 )*abs( INCX ) ).
C           Before entry, the incremented array X must contain the n
C           element vector x.
C           Unchanged on exit.
C
C  INCX   - INTEGER.
C           On entry, INCX specifies the increment for the elements of
C           X. INCX must not be zero.
C           Unchanged on exit.
C
C  Y      - DOUBLE PRECISION array of dimension at least
C           ( 1 + ( n - 1 )*abs( INCY ) ).
C           Before entry, the incremented array Y must contain the n
C           element vector y.
C           Unchanged on exit.
C
C  INCY   - INTEGER.
C           On entry, INCY specifies the increment for the elements of
C           Y. INCY must not be zero.
C           Unchanged on exit.
C
C  AP     - DOUBLE PRECISION array of DIMENSION at least
C           ( ( n*( n + 1 ) )/2 ).
C           Before entry with  UPLO = 'U' or 'u', the array AP must
C           contain the upper triangular part of the symmetric matrix
C           packed sequentially, column by column, so that AP( 1 )
C           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
C           and a( 2, 2 ) respectively, and so on. On exit, the array
C           AP is overwritten by the upper triangular part of the
C           updated matrix.
C           Before entry with UPLO = 'L' or 'l', the array AP must
C           contain the lower triangular part of the symmetric matrix
C           packed sequentially, column by column, so that AP( 1 )
C           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
C           and a( 3, 1 ) respectively, and so on. On exit, the array
C           AP is overwritten by the lower triangular part of the
C           updated matrix.
C
C
C  Level 2 Blas routine.
C
C  -- Written on 22-October-1986.
C     Jack Dongarra, Argonne National Lab.
C     Jeremy Du Croz, Nag Central Office.
C     Sven Hammarling, Nag Central Office.
C     Richard Hanson, Sandia National Labs.
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
C     .. Local Scalars ..
      DOUBLE PRECISION   TEMP1, TEMP2
      INTEGER            I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           XERBLA
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      IF     ( .NOT.LSAME( UPLO, 'U' ).AND.
     $         .NOT.LSAME( UPLO, 'L' )      )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 5
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 7
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DSPR2 ', INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
     $   RETURN
C
C     Set up the start points in X and Y if the increments are not both
C     unity.
C
      IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN
         IF( INCX.GT.0 )THEN
            KX = 1
         ELSE
            KX = 1 - ( N - 1 )*INCX
         END IF
         IF( INCY.GT.0 )THEN
            KY = 1
         ELSE
            KY = 1 - ( N - 1 )*INCY
         END IF
         JX = KX
         JY = KY
      END IF
C
C     Start the operations. In this version the elements of the array AP
C     are accessed sequentially with one pass through AP.
C
      KK = 1
      IF( LSAME( UPLO, 'U' ) )THEN
C
C        Form  A  when upper triangle is stored in AP.
C
         IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
            DO 20, J = 1, N
               IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN
                  TEMP1 = ALPHA*Y( J )
                  TEMP2 = ALPHA*X( J )
                  K     = KK
                  DO 10, I = 1, J
                     AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2
                     K       = K       + 1
   10             CONTINUE
               END IF
               KK = KK + J
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN
                  TEMP1 = ALPHA*Y( JY )
                  TEMP2 = ALPHA*X( JX )
                  IX    = KX
                  IY    = KY
                  DO 30, K = KK, KK + J - 1
                     AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2
                     IX      = IX      + INCX
                     IY      = IY      + INCY
   30             CONTINUE
               END IF
               JX = JX + INCX
               JY = JY + INCY
               KK = KK + J
   40       CONTINUE
         END IF
      ELSE
C
C        Form  A  when lower triangle is stored in AP.
C
         IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
            DO 60, J = 1, N
               IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN
                  TEMP1 = ALPHA*Y( J )
                  TEMP2 = ALPHA*X( J )
                  K     = KK
                  DO 50, I = J, N
                     AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2
                     K       = K       + 1
   50             CONTINUE
               END IF
               KK = KK + N - J + 1
   60       CONTINUE
         ELSE
            DO 80, J = 1, N
               IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN
                  TEMP1 = ALPHA*Y( JY )
                  TEMP2 = ALPHA*X( JX )
                  IX    = JX
                  IY    = JY
                  DO 70, K = KK, KK + N - J
                     AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2
                     IX      = IX      + INCX
                     IY      = IY      + INCY
   70             CONTINUE
               END IF
               JX = JX + INCX
               JY = JY + INCY
               KK = KK + N - J + 1
   80       CONTINUE
         END IF
      END IF
C
      RETURN
C
C     End of DSPR2 .
C
      END
      SUBROUTINE  DSWAP (N,DX,INCX,DY,INCY)
C
C     interchanges two vectors.
C     uses unrolled loops for increments equal one.
C     jack dongarra, linpack, 3/11/78.
C
      DOUBLE PRECISION DX(1),DY(1),DTEMP
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C       code for unequal increments or equal increments not equal
C         to 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DTEMP = DX(IX)
        DX(IX) = DY(IY)
        DY(IY) = DTEMP
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C       code for both increments equal to 1
C
C
C       clean-up loop
C
   20 M = MOD(N,3)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DTEMP = DX(I)
        DX(I) = DY(I)
        DY(I) = DTEMP
   30 CONTINUE
      IF( N .LT. 3 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,3
        DTEMP = DX(I)
        DX(I) = DY(I)
        DY(I) = DTEMP
        DTEMP = DX(I + 1)
        DX(I + 1) = DY(I + 1)
        DY(I + 1) = DTEMP
        DTEMP = DX(I + 2)
        DX(I + 2) = DY(I + 2)
        DY(I + 2) = DTEMP
   50 CONTINUE
      RETURN
      END
      SUBROUTINE DTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
C     .. Scalar Arguments ..
      INTEGER            INCX, N
      CHARACTER*1        DIAG, TRANS, UPLO
C     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), X( * )
C     ..
C
C  Purpose
C  =======
C
C  DTPMV  performs one of the matrix-vector operations
C
C     x := A*x,   or   x := A'*x,
C
C  where x is an n element vector and  A is an n by n unit, or non-unit,
C  upper or lower triangular matrix, supplied in packed form.
C
C  Parameters
C  ==========
C
C  UPLO   - CHARACTER*1.
C           On entry, UPLO specifies whether the matrix is an upper or
C           lower triangular matrix as follows:
C
C              UPLO = 'U' or 'u'   A is an upper triangular matrix.
C
C              UPLO = 'L' or 'l'   A is a lower triangular matrix.
C
C           Unchanged on exit.
C
C  TRANS  - CHARACTER*1.
C           On entry, TRANS specifies the operation to be performed as
C           follows:
C
C              TRANS = 'N' or 'n'   x := A*x.
C
C              TRANS = 'T' or 't'   x := A'*x.
C
C              TRANS = 'C' or 'c'   x := A'*x.
C
C           Unchanged on exit.
C
C  DIAG   - CHARACTER*1.
C           On entry, DIAG specifies whether or not A is unit
C           triangular as follows:
C
C              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
C
C              DIAG = 'N' or 'n'   A is not assumed to be unit
C                                  triangular.
C
C           Unchanged on exit.
C
C  N      - INTEGER.
C           On entry, N specifies the order of the matrix A.
C           N must be at least zero.
C           Unchanged on exit.
C
C  AP     - DOUBLE PRECISION array of DIMENSION at least
C           ( ( n*( n + 1 ) )/2 ).
C           Before entry with  UPLO = 'U' or 'u', the array AP must
C           contain the upper triangular matrix packed sequentially,
C           column by column, so that AP( 1 ) contains a( 1, 1 ),
C           AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
C           respectively, and so on.
C           Before entry with UPLO = 'L' or 'l', the array AP must
C           contain the lower triangular matrix packed sequentially,
C           column by column, so that AP( 1 ) contains a( 1, 1 ),
C           AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
C           respectively, and so on.
C           Note that when  DIAG = 'U' or 'u', the diagonal elements of
C           A are not referenced, but are assumed to be unity.
C           Unchanged on exit.
C
C  X      - DOUBLE PRECISION array of dimension at least
C           ( 1 + ( n - 1 )*abs( INCX ) ).
C           Before entry, the incremented array X must contain the n
C           element vector x. On exit, X is overwritten with the
C           tranformed vector x.
C
C  INCX   - INTEGER.
C           On entry, INCX specifies the increment for the elements of
C           X. INCX must not be zero.
C           Unchanged on exit.
C
C
C  Level 2 Blas routine.
C
C  -- Written on 22-October-1986.
C     Jack Dongarra, Argonne National Lab.
C     Jeremy Du Croz, Nag Central Office.
C     Sven Hammarling, Nag Central Office.
C     Richard Hanson, Sandia National Labs.
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
C     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JX, K, KK, KX
      LOGICAL            NOUNIT
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           XERBLA
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      IF     ( .NOT.LSAME( UPLO , 'U' ).AND.
     $         .NOT.LSAME( UPLO , 'L' )      )THEN
         INFO = 1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.
     $         .NOT.LSAME( TRANS, 'T' ).AND.
     $         .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 2
      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
     $         .NOT.LSAME( DIAG , 'N' )      )THEN
         INFO = 3
      ELSE IF( N.LT.0 )THEN
         INFO = 4
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 7
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTPMV ', INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
      NOUNIT = LSAME( DIAG, 'N' )
C
C     Set up the start point in X if the increment is not unity. This
C     will be  ( N - 1 )*INCX  too small for descending loops.
C
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
C
C     Start the operations. In this version the elements of AP are
C     accessed sequentially with one pass through AP.
C
      IF( LSAME( TRANS, 'N' ) )THEN
C
C        Form  x:= A*x.
C
         IF( LSAME( UPLO, 'U' ) )THEN
            KK =1
            IF( INCX.EQ.1 )THEN
               DO 20, J = 1, N
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     K    = KK
                     DO 10, I = 1, J - 1
                        X( I ) = X( I ) + TEMP*AP( K )
                        K      = K      + 1
   10                CONTINUE
                     IF( NOUNIT )
     $                  X( J ) = X( J )*AP( KK + J - 1 )
                  END IF
                  KK = KK + J
   20          CONTINUE
            ELSE
               JX = KX
               DO 40, J = 1, N
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     DO 30, K = KK, KK + J - 2
                        X( IX ) = X( IX ) + TEMP*AP( K )
                        IX      = IX      + INCX
   30                CONTINUE
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )*AP( KK + J - 1 )
                  END IF
                  JX = JX + INCX
                  KK = KK + J
   40          CONTINUE
            END IF
         ELSE
            KK = ( N*( N + 1 ) )/2
            IF( INCX.EQ.1 )THEN
               DO 60, J = N, 1, -1
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     K    = KK
                     DO 50, I = N, J + 1, -1
                        X( I ) = X( I ) + TEMP*AP( K )
                        K      = K      - 1
   50                CONTINUE
                     IF( NOUNIT )
     $                  X( J ) = X( J )*AP( KK - N + J )
                  END IF
                  KK = KK - ( N - J + 1 )
   60          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 80, J = N, 1, -1
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1
                        X( IX ) = X( IX ) + TEMP*AP( K )
                        IX      = IX      - INCX
   70                CONTINUE
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )*AP( KK - N + J )
                  END IF
                  JX = JX - INCX
                  KK = KK - ( N - J + 1 )
   80          CONTINUE
            END IF
         END IF
      ELSE
C
C        Form  x := A'*x.
C
         IF( LSAME( UPLO, 'U' ) )THEN
            KK = ( N*( N + 1 ) )/2
            IF( INCX.EQ.1 )THEN
               DO 100, J = N, 1, -1
                  TEMP = X( J )
                  IF( NOUNIT )
     $               TEMP = TEMP*AP( KK )
                  K = KK - 1
                  DO 90, I = J - 1, 1, -1
                     TEMP = TEMP + AP( K )*X( I )
                     K    = K    - 1
   90             CONTINUE
                  X( J ) = TEMP
                  KK     = KK   - J
  100          CONTINUE
            ELSE
               JX = KX + ( N - 1 )*INCX
               DO 120, J = N, 1, -1
                  TEMP = X( JX )
                  IX   = JX
                  IF( NOUNIT )
     $               TEMP = TEMP*AP( KK )
                  DO 110, K = KK - 1, KK - J + 1, -1
                     IX   = IX   - INCX
                     TEMP = TEMP + AP( K )*X( IX )
  110             CONTINUE
                  X( JX ) = TEMP
                  JX      = JX   - INCX
                  KK      = KK   - J
  120          CONTINUE
            END IF
         ELSE
            KK = 1
            IF( INCX.EQ.1 )THEN
               DO 140, J = 1, N
                  TEMP = X( J )
                  IF( NOUNIT )
     $               TEMP = TEMP*AP( KK )
                  K = KK + 1
                  DO 130, I = J + 1, N
                     TEMP = TEMP + AP( K )*X( I )
                     K    = K    + 1
  130             CONTINUE
                  X( J ) = TEMP
                  KK     = KK   + ( N - J + 1 )
  140          CONTINUE
            ELSE
               JX = KX
               DO 160, J = 1, N
                  TEMP = X( JX )
                  IX   = JX
                  IF( NOUNIT )
     $               TEMP = TEMP*AP( KK )
                  DO 150, K = KK + 1, KK + N - J
                     IX   = IX   + INCX
                     TEMP = TEMP + AP( K )*X( IX )
  150             CONTINUE
                  X( JX ) = TEMP
                  JX      = JX   + INCX
                  KK      = KK   + ( N - J + 1 )
  160          CONTINUE
            END IF
         END IF
      END IF
C
      RETURN
C
C     End of DTPMV .
C
      END
      SUBROUTINE DTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX )
C     .. Scalar Arguments ..
      INTEGER            INCX, N
      CHARACTER*1        DIAG, TRANS, UPLO
C     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), X( * )
C     ..
C
C  Purpose
C  =======
C
C  DTPSV  solves one of the systems of equations
C
C     A*x = b,   or   A'*x = b,
C
C  where b and x are n element vectors and A is an n by n unit, or
C  non-unit, upper or lower triangular matrix, supplied in packed form.
C
C  No test for singularity or near-singularity is included in this
C  routine. Such tests must be performed before calling this routine.
C
C  Parameters
C  ==========
C
C  UPLO   - CHARACTER*1.
C           On entry, UPLO specifies whether the matrix is an upper or
C           lower triangular matrix as follows:
C
C              UPLO = 'U' or 'u'   A is an upper triangular matrix.
C
C              UPLO = 'L' or 'l'   A is a lower triangular matrix.
C
C           Unchanged on exit.
C
C  TRANS  - CHARACTER*1.
C           On entry, TRANS specifies the equations to be solved as
C           follows:
C
C              TRANS = 'N' or 'n'   A*x = b.
C
C              TRANS = 'T' or 't'   A'*x = b.
C
C              TRANS = 'C' or 'c'   A'*x = b.
C
C           Unchanged on exit.
C
C  DIAG   - CHARACTER*1.
C           On entry, DIAG specifies whether or not A is unit
C           triangular as follows:
C
C              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
C
C              DIAG = 'N' or 'n'   A is not assumed to be unit
C                                  triangular.
C
C           Unchanged on exit.
C
C  N      - INTEGER.
C           On entry, N specifies the order of the matrix A.
C           N must be at least zero.
C           Unchanged on exit.
C
C  AP     - DOUBLE PRECISION array of DIMENSION at least
C           ( ( n*( n + 1 ) )/2 ).
C           Before entry with  UPLO = 'U' or 'u', the array AP must
C           contain the upper triangular matrix packed sequentially,
C           column by column, so that AP( 1 ) contains a( 1, 1 ),
C           AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
C           respectively, and so on.
C           Before entry with UPLO = 'L' or 'l', the array AP must
C           contain the lower triangular matrix packed sequentially,
C           column by column, so that AP( 1 ) contains a( 1, 1 ),
C           AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
C           respectively, and so on.
C           Note that when  DIAG = 'U' or 'u', the diagonal elements of
C           A are not referenced, but are assumed to be unity.
C           Unchanged on exit.
C
C  X      - DOUBLE PRECISION array of dimension at least
C           ( 1 + ( n - 1 )*abs( INCX ) ).
C           Before entry, the incremented array X must contain the n
C           element right-hand side vector b. On exit, X is overwritten
C           with the solution vector x.
C
C  INCX   - INTEGER.
C           On entry, INCX specifies the increment for the elements of
C           X. INCX must not be zero.
C           Unchanged on exit.
C
C
C  Level 2 Blas routine.
C
C  -- Written on 22-October-1986.
C     Jack Dongarra, Argonne National Lab.
C     Jeremy Du Croz, Nag Central Office.
C     Sven Hammarling, Nag Central Office.
C     Richard Hanson, Sandia National Labs.
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
C     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JX, K, KK, KX
      LOGICAL            NOUNIT
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           XERBLA
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      IF     ( .NOT.LSAME( UPLO , 'U' ).AND.
     $         .NOT.LSAME( UPLO , 'L' )      )THEN
         INFO = 1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.
     $         .NOT.LSAME( TRANS, 'T' ).AND.
     $         .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 2
      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
     $         .NOT.LSAME( DIAG , 'N' )      )THEN
         INFO = 3
      ELSE IF( N.LT.0 )THEN
         INFO = 4
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 7
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTPSV ', INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
      NOUNIT = LSAME( DIAG, 'N' )
C
C     Set up the start point in X if the increment is not unity. This
C     will be  ( N - 1 )*INCX  too small for descending loops.
C
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
C
C     Start the operations. In this version the elements of AP are
C     accessed sequentially with one pass through AP.
C
      IF( LSAME( TRANS, 'N' ) )THEN
C
C        Form  x := inv( A )*x.
C
         IF( LSAME( UPLO, 'U' ) )THEN
            KK = ( N*( N + 1 ) )/2
            IF( INCX.EQ.1 )THEN
               DO 20, J = N, 1, -1
                  IF( X( J ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( J ) = X( J )/AP( KK )
                     TEMP = X( J )
                     K    = KK     - 1
                     DO 10, I = J - 1, 1, -1
                        X( I ) = X( I ) - TEMP*AP( K )
                        K      = K      - 1
   10                CONTINUE
                  END IF
                  KK = KK - J
   20          CONTINUE
            ELSE
               JX = KX + ( N - 1 )*INCX
               DO 40, J = N, 1, -1
                  IF( X( JX ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )/AP( KK )
                     TEMP = X( JX )
                     IX   = JX
                     DO 30, K = KK - 1, KK - J + 1, -1
                        IX      = IX      - INCX
                        X( IX ) = X( IX ) - TEMP*AP( K )
   30                CONTINUE
                  END IF
                  JX = JX - INCX
                  KK = KK - J
   40          CONTINUE
            END IF
         ELSE
            KK = 1
            IF( INCX.EQ.1 )THEN
               DO 60, J = 1, N
                  IF( X( J ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( J ) = X( J )/AP( KK )
                     TEMP = X( J )
                     K    = KK     + 1
                     DO 50, I = J + 1, N
                        X( I ) = X( I ) - TEMP*AP( K )
                        K      = K      + 1
   50                CONTINUE
                  END IF
                  KK = KK + ( N - J + 1 )
   60          CONTINUE
            ELSE
               JX = KX
               DO 80, J = 1, N
                  IF( X( JX ).NE.ZERO )THEN
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )/AP( KK )
                     TEMP = X( JX )
                     IX   = JX
                     DO 70, K = KK + 1, KK + N - J
                        IX      = IX      + INCX
                        X( IX ) = X( IX ) - TEMP*AP( K )
   70                CONTINUE
                  END IF
                  JX = JX + INCX
                  KK = KK + ( N - J + 1 )
   80          CONTINUE
            END IF
         END IF
      ELSE
C
C        Form  x := inv( A' )*x.
C
         IF( LSAME( UPLO, 'U' ) )THEN
            KK = 1
            IF( INCX.EQ.1 )THEN
               DO 100, J = 1, N
                  TEMP = X( J )
                  K    = KK
                  DO 90, I = 1, J - 1
                     TEMP = TEMP - AP( K )*X( I )
                     K    = K    + 1
   90             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/AP( KK + J - 1 )
                  X( J ) = TEMP
                  KK     = KK   + J
  100          CONTINUE
            ELSE
               JX = KX
               DO 120, J = 1, N
                  TEMP = X( JX )
                  IX   = KX
                  DO 110, K = KK, KK + J - 2
                     TEMP = TEMP - AP( K )*X( IX )
                     IX   = IX   + INCX
  110             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/AP( KK + J - 1 )
                  X( JX ) = TEMP
                  JX      = JX   + INCX
                  KK      = KK   + J
  120          CONTINUE
            END IF
         ELSE
            KK = ( N*( N + 1 ) )/2
            IF( INCX.EQ.1 )THEN
               DO 140, J = N, 1, -1
                  TEMP = X( J )
                  K = KK
                  DO 130, I = N, J + 1, -1
                     TEMP = TEMP - AP( K )*X( I )
                     K    = K    - 1
  130             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/AP( KK - N + J )
                  X( J ) = TEMP
                  KK     = KK   - ( N - J + 1 )
  140          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 160, J = N, 1, -1
                  TEMP = X( JX )
                  IX   = KX
                  DO 150, K = KK, KK - ( N - ( J + 1 ) ), -1
                     TEMP = TEMP - AP( K )*X( IX )
                     IX   = IX   - INCX
  150             CONTINUE
                  IF( NOUNIT )
     $               TEMP = TEMP/AP( KK - N + J )
                  X( JX ) = TEMP
                  JX      = JX   - INCX
                  KK      = KK   - (N - J + 1 )
  160          CONTINUE
            END IF
         END IF
      END IF
C
      RETURN
C
C     End of DTPSV .
C
      END
      SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
     $                   B, LDB )
C     .. Scalar Arguments ..
      CHARACTER*1        SIDE, UPLO, TRANSA, DIAG
      INTEGER            M, N, LDA, LDB
      DOUBLE PRECISION   ALPHA
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
C     ..
C
C  Purpose
C  =======
C
C  DTRMM  performs one of the matrix-matrix operations
C
C     B := alpha*op( A )*B,   or   B := alpha*B*op( A ),
C
C  where  alpha  is a scalar,  B  is an m by n matrix,  A  is a unit, or
C  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
C
C     op( A ) = A   or   op( A ) = A'.
C
C  Parameters
C  ==========
C
C  SIDE   - CHARACTER*1.
C           On entry,  SIDE specifies whether  op( A ) multiplies B from
C           the left or right as follows:
C
C              SIDE = 'L' or 'l'   B := alpha*op( A )*B.
C
C              SIDE = 'R' or 'r'   B := alpha*B*op( A ).
C
C           Unchanged on exit.
C
C  UPLO   - CHARACTER*1.
C           On entry, UPLO specifies whether the matrix A is an upper or
C           lower triangular matrix as follows:
C
C              UPLO = 'U' or 'u'   A is an upper triangular matrix.
C
C              UPLO = 'L' or 'l'   A is a lower triangular matrix.
C
C           Unchanged on exit.
C
C  TRANSA - CHARACTER*1.
C           On entry, TRANSA specifies the form of op( A ) to be used in
C           the matrix multiplication as follows:
C
C              TRANSA = 'N' or 'n'   op( A ) = A.
C
C              TRANSA = 'T' or 't'   op( A ) = A'.
C
C              TRANSA = 'C' or 'c'   op( A ) = A'.
C
C           Unchanged on exit.
C
C  DIAG   - CHARACTER*1.
C           On entry, DIAG specifies whether or not A is unit triangular
C           as follows:
C
C              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
C
C              DIAG = 'N' or 'n'   A is not assumed to be unit
C                                  triangular.
C
C           Unchanged on exit.
C
C  M      - INTEGER.
C           On entry, M specifies the number of rows of B. M must be at
C           least zero.
C           Unchanged on exit.
C
C  N      - INTEGER.
C           On entry, N specifies the number of columns of B.  N must be
C           at least zero.
C           Unchanged on exit.
C
C  ALPHA  - DOUBLE PRECISION.
C           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
C           zero then  A is not referenced and  B need not be set before
C           entry.
C           Unchanged on exit.
C
C  A      - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
C           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
C           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
C           upper triangular part of the array  A must contain the upper
C           triangular matrix  and the strictly lower triangular part of
C           A is not referenced.
C           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
C           lower triangular part of the array  A must contain the lower
C           triangular matrix  and the strictly upper triangular part of
C           A is not referenced.
C           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
C           A  are not referenced either,  but are assumed to be  unity.
C           Unchanged on exit.
C
C  LDA    - INTEGER.
C           On entry, LDA specifies the first dimension of A as declared
C           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
C           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
C           then LDA must be at least max( 1, n ).
C           Unchanged on exit.
C
C  B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
C           Before entry,  the leading  m by n part of the array  B must
C           contain the matrix  B,  and  on exit  is overwritten  by the
C           transformed matrix.
C
C  LDB    - INTEGER.
C           On entry, LDB specifies the first dimension of B as declared
C           in  the  calling  (sub)  program.   LDB  must  be  at  least
C           max( 1, m ).
C           Unchanged on exit.
C
C
C  Level 3 Blas routine.
C
C  -- Written on 8-February-1989.
C     Jack Dongarra, Argonne National Laboratory.
C     Iain Duff, AERE Harwell.
C     Jeremy Du Croz, Numerical Algorithms Group Ltd.
C     Sven Hammarling, Numerical Algorithms Group Ltd.
C
C
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     .. Local Scalars ..
      LOGICAL            LSIDE, NOUNIT, UPPER
      INTEGER            I, INFO, J, K, NROWA
      DOUBLE PRECISION   TEMP
C     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      LSIDE  = LSAME( SIDE  , 'L' )
      IF( LSIDE )THEN
         NROWA = M
      ELSE
         NROWA = N
      END IF
      NOUNIT = LSAME( DIAG  , 'N' )
      UPPER  = LSAME( UPLO  , 'U' )
C
      INFO   = 0
      IF(      ( .NOT.LSIDE                ).AND.
     $         ( .NOT.LSAME( SIDE  , 'R' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.UPPER                ).AND.
     $         ( .NOT.LSAME( UPLO  , 'L' ) )      )THEN
         INFO = 2
      ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND.
     $         ( .NOT.LSAME( TRANSA, 'T' ) ).AND.
     $         ( .NOT.LSAME( TRANSA, 'C' ) )      )THEN
         INFO = 3
      ELSE IF( ( .NOT.LSAME( DIAG  , 'U' ) ).AND.
     $         ( .NOT.LSAME( DIAG  , 'N' ) )      )THEN
         INFO = 4
      ELSE IF( M  .LT.0               )THEN
         INFO = 5
      ELSE IF( N  .LT.0               )THEN
         INFO = 6
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 9
      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTRMM ', INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
C     And when  alpha.eq.zero.
C
      IF( ALPHA.EQ.ZERO )THEN
         DO 20, J = 1, N
            DO 10, I = 1, M
               B( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
         RETURN
      END IF
C
C     Start the operations.
C
      IF( LSIDE )THEN
         IF( LSAME( TRANSA, 'N' ) )THEN
C
C           Form  B := alpha*A*B.
C
            IF( UPPER )THEN
               DO 50, J = 1, N
                  DO 40, K = 1, M
                     IF( B( K, J ).NE.ZERO )THEN
                        TEMP = ALPHA*B( K, J )
                        DO 30, I = 1, K - 1
                           B( I, J ) = B( I, J ) + TEMP*A( I, K )
   30                   CONTINUE
                        IF( NOUNIT )
     $                     TEMP = TEMP*A( K, K )
                        B( K, J ) = TEMP
                     END IF
   40             CONTINUE
   50          CONTINUE
            ELSE
               DO 80, J = 1, N
                  DO 70 K = M, 1, -1
                     IF( B( K, J ).NE.ZERO )THEN
                        TEMP      = ALPHA*B( K, J )
                        B( K, J ) = TEMP
                        IF( NOUNIT )
     $                     B( K, J ) = B( K, J )*A( K, K )
                        DO 60, I = K + 1, M
                           B( I, J ) = B( I, J ) + TEMP*A( I, K )
   60                   CONTINUE
                     END IF
   70             CONTINUE
   80          CONTINUE
            END IF
         ELSE
C
C           Form  B := alpha*B*A'.
C
            IF( UPPER )THEN
               DO 110, J = 1, N
                  DO 100, I = M, 1, -1
                     TEMP = B( I, J )
                     IF( NOUNIT )
     $                  TEMP = TEMP*A( I, I )
                     DO 90, K = 1, I - 1
                        TEMP = TEMP + A( K, I )*B( K, J )
   90                CONTINUE
                     B( I, J ) = ALPHA*TEMP
  100             CONTINUE
  110          CONTINUE
            ELSE
               DO 140, J = 1, N
                  DO 130, I = 1, M
                     TEMP = B( I, J )
                     IF( NOUNIT )
     $                  TEMP = TEMP*A( I, I )
                     DO 120, K = I + 1, M
                        TEMP = TEMP + A( K, I )*B( K, J )
  120                CONTINUE
                     B( I, J ) = ALPHA*TEMP
  130             CONTINUE
  140          CONTINUE
            END IF
         END IF
      ELSE
         IF( LSAME( TRANSA, 'N' ) )THEN
C
C           Form  B := alpha*B*A.
C
            IF( UPPER )THEN
               DO 180, J = N, 1, -1
                  TEMP = ALPHA
                  IF( NOUNIT )
     $               TEMP = TEMP*A( J, J )
                  DO 150, I = 1, M
                     B( I, J ) = TEMP*B( I, J )
  150             CONTINUE
                  DO 170, K = 1, J - 1
                     IF( A( K, J ).NE.ZERO )THEN
                        TEMP = ALPHA*A( K, J )
                        DO 160, I = 1, M
                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
  160                   CONTINUE
                     END IF
  170             CONTINUE
  180          CONTINUE
            ELSE
               DO 220, J = 1, N
                  TEMP = ALPHA
                  IF( NOUNIT )
     $               TEMP = TEMP*A( J, J )
                  DO 190, I = 1, M
                     B( I, J ) = TEMP*B( I, J )
  190             CONTINUE
                  DO 210, K = J + 1, N
                     IF( A( K, J ).NE.ZERO )THEN
                        TEMP = ALPHA*A( K, J )
                        DO 200, I = 1, M
                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
  200                   CONTINUE
                     END IF
  210             CONTINUE
  220          CONTINUE
            END IF
         ELSE
C
C           Form  B := alpha*B*A'.
C
            IF( UPPER )THEN
               DO 260, K = 1, N
                  DO 240, J = 1, K - 1
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = ALPHA*A( J, K )
                        DO 230, I = 1, M
                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
  230                   CONTINUE
                     END IF
  240             CONTINUE
                  TEMP = ALPHA
                  IF( NOUNIT )
     $               TEMP = TEMP*A( K, K )
                  IF( TEMP.NE.ONE )THEN
                     DO 250, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  250                CONTINUE
                  END IF
  260          CONTINUE
            ELSE
               DO 300, K = N, 1, -1
                  DO 280, J = K + 1, N
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = ALPHA*A( J, K )
                        DO 270, I = 1, M
                           B( I, J ) = B( I, J ) + TEMP*B( I, K )
  270                   CONTINUE
                     END IF
  280             CONTINUE
                  TEMP = ALPHA
                  IF( NOUNIT )
     $               TEMP = TEMP*A( K, K )
                  IF( TEMP.NE.ONE )THEN
                     DO 290, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  290                CONTINUE
                  END IF
  300          CONTINUE
            END IF
         END IF
      END IF
C
      RETURN
C
C     End of DTRMM .
C
      END
      SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
C     .. Scalar Arguments ..
      INTEGER            INCX, LDA, N
      CHARACTER*1        DIAG, TRANS, UPLO
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * )
C     ..
C
C  Purpose
C  =======
C
C  DTRMV  performs one of the matrix-vector operations
C
C     x := A*x,   or   x := A'*x,
C
C  where x is an n element vector and  A is an n by n unit, or non-unit,
C  upper or lower triangular matrix.
C
C  Parameters
C  ==========
C
C  UPLO   - CHARACTER*1.
C           On entry, UPLO specifies whether the matrix is an upper or
C           lower triangular matrix as follows:
C
C              UPLO = 'U' or 'u'   A is an upper triangular matrix.
C
C              UPLO = 'L' or 'l'   A is a lower triangular matrix.
C
C           Unchanged on exit.
C
C  TRANS  - CHARACTER*1.
C           On entry, TRANS specifies the operation to be performed as
C           follows:
C
C              TRANS = 'N' or 'n'   x := A*x.
C
C              TRANS = 'T' or 't'   x := A'*x.
C
C              TRANS = 'C' or 'c'   x := A'*x.
C
C           Unchanged on exit.
C
C  DIAG   - CHARACTER*1.
C           On entry, DIAG specifies whether or not A is unit
C           triangular as follows:
C
C              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
C
C              DIAG = 'N' or 'n'   A is not assumed to be unit
C                                  triangular.
C
C           Unchanged on exit.
C
C  N      - INTEGER.
C           On entry, N specifies the order of the matrix A.
C           N must be at least zero.
C           Unchanged on exit.
C
C  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
C           Before entry with  UPLO = 'U' or 'u', the leading n by n
C           upper triangular part of the array A must contain the upper
C           triangular matrix and the strictly lower triangular part of
C           A is not referenced.
C           Before entry with UPLO = 'L' or 'l', the leading n by n
C           lower triangular part of the array A must contain the lower
C           triangular matrix and the strictly upper triangular part of
C           A is not referenced.
C           Note that when  DIAG = 'U' or 'u', the diagonal elements of
C           A are not referenced either, but are assumed to be unity.
C           Unchanged on exit.
C
C  LDA    - INTEGER.
C           On entry, LDA specifies the first dimension of A as declared
C           in the calling (sub) program. LDA must be at least
C           max( 1, n ).
C           Unchanged on exit.
C
C  X      - DOUBLE PRECISION array of dimension at least
C           ( 1 + ( n - 1 )*abs( INCX ) ).
C           Before entry, the incremented array X must contain the n
C           element vector x. On exit, X is overwritten with the
C           tranformed vector x.
C
C  INCX   - INTEGER.
C           On entry, INCX specifies the increment for the elements of
C           X. INCX must not be zero.
C           Unchanged on exit.
C
C
C  Level 2 Blas routine.
C
C  -- Written on 22-October-1986.
C     Jack Dongarra, Argonne National Lab.
C     Jeremy Du Croz, Nag Central Office.
C     Sven Hammarling, Nag Central Office.
C     Richard Hanson, Sandia National Labs.
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
C     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JX, KX
      LOGICAL            NOUNIT
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      IF     ( .NOT.LSAME( UPLO , 'U' ).AND.
     $         .NOT.LSAME( UPLO , 'L' )      )THEN
         INFO = 1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.
     $         .NOT.LSAME( TRANS, 'T' ).AND.
     $         .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 2
      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
     $         .NOT.LSAME( DIAG , 'N' )      )THEN
         INFO = 3
      ELSE IF( N.LT.0 )THEN
         INFO = 4
      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
         INFO = 6
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 8
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTRMV ', INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
      NOUNIT = LSAME( DIAG, 'N' )
C
C     Set up the start point in X if the increment is not unity. This
C     will be  ( N - 1 )*INCX  too small for descending loops.
C
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
C
C     Start the operations. In this version the elements of A are
C     accessed sequentially with one pass through A.
C
      IF( LSAME( TRANS, 'N' ) )THEN
C
C        Form  x := A*x.
C
         IF( LSAME( UPLO, 'U' ) )THEN
            IF( INCX.EQ.1 )THEN
               DO 20, J = 1, N
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     DO 10, I = 1, J - 1
                        X( I ) = X( I ) + TEMP*A( I, J )
   10                CONTINUE
                     IF( NOUNIT )
     $                  X( J ) = X( J )*A( J, J )
                  END IF
   20          CONTINUE
            ELSE
               JX = KX
               DO 40, J = 1, N
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     DO 30, I = 1, J - 1
                        X( IX ) = X( IX ) + TEMP*A( I, J )
                        IX      = IX      + INCX
   30                CONTINUE
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )*A( J, J )
                  END IF
                  JX = JX + INCX
   40          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 60, J = N, 1, -1
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     DO 50, I = N, J + 1, -1
                        X( I ) = X( I ) + TEMP*A( I, J )
   50                CONTINUE
                     IF( NOUNIT )
     $                  X( J ) = X( J )*A( J, J )
                  END IF
   60          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 80, J = N, 1, -1
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     DO 70, I = N, J + 1, -1
                        X( IX ) = X( IX ) + TEMP*A( I, J )
                        IX      = IX      - INCX
   70                CONTINUE
                     IF( NOUNIT )
     $                  X( JX ) = X( JX )*A( J, J )
                  END IF
                  JX = JX - INCX
   80          CONTINUE
            END IF
         END IF
      ELSE
C
C        Form  x := A'*x.
C
         IF( LSAME( UPLO, 'U' ) )THEN
            IF( INCX.EQ.1 )THEN
               DO 100, J = N, 1, -1
                  TEMP = X( J )
                  IF( NOUNIT )
     $               TEMP = TEMP*A( J, J )
                  DO 90, I = J - 1, 1, -1
                     TEMP = TEMP + A( I, J )*X( I )
   90             CONTINUE
                  X( J ) = TEMP
  100          CONTINUE
            ELSE
               JX = KX + ( N - 1 )*INCX
               DO 120, J = N, 1, -1
                  TEMP = X( JX )
                  IX   = JX
                  IF( NOUNIT )
     $               TEMP = TEMP*A( J, J )
                  DO 110, I = J - 1, 1, -1
                     IX   = IX   - INCX
                     TEMP = TEMP + A( I, J )*X( IX )
  110             CONTINUE
                  X( JX ) = TEMP
                  JX      = JX   - INCX
  120          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 140, J = 1, N
                  TEMP = X( J )
                  IF( NOUNIT )
     $               TEMP = TEMP*A( J, J )
                  DO 130, I = J + 1, N
                     TEMP = TEMP + A( I, J )*X( I )
  130             CONTINUE
                  X( J ) = TEMP
  140          CONTINUE
            ELSE
               JX = KX
               DO 160, J = 1, N
                  TEMP = X( JX )
                  IX   = JX
                  IF( NOUNIT )
     $               TEMP = TEMP*A( J, J )
                  DO 150, I = J + 1, N
                     IX   = IX   + INCX
                     TEMP = TEMP + A( I, J )*X( IX )
  150             CONTINUE
                  X( JX ) = TEMP
                  JX      = JX   + INCX
  160          CONTINUE
            END IF
         END IF
      END IF
C
      RETURN
C
C     End of DTRMV .
C
      END
      SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
     $                   B, LDB )
C     .. Scalar Arguments ..
      CHARACTER*1        SIDE, UPLO, TRANSA, DIAG
      INTEGER            M, N, LDA, LDB
      DOUBLE PRECISION   ALPHA
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
C     ..
C
C  Purpose
C  =======
C
C  DTRSM  solves one of the matrix equations
C
C     op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,
C
C  where alpha is a scalar, X and B are m by n matrices, A is a unit, or
C  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
C
C     op( A ) = A   or   op( A ) = A'.
C
C  The matrix X is overwritten on B.
C
C  Parameters
C  ==========
C
C  SIDE   - CHARACTER*1.
C           On entry, SIDE specifies whether op( A ) appears on the left
C           or right of X as follows:
C
C              SIDE = 'L' or 'l'   op( A )*X = alpha*B.
C
C              SIDE = 'R' or 'r'   X*op( A ) = alpha*B.
C
C           Unchanged on exit.
C
C  UPLO   - CHARACTER*1.
C           On entry, UPLO specifies whether the matrix A is an upper or
C           lower triangular matrix as follows:
C
C              UPLO = 'U' or 'u'   A is an upper triangular matrix.
C
C              UPLO = 'L' or 'l'   A is a lower triangular matrix.
C
C           Unchanged on exit.
C
C  TRANSA - CHARACTER*1.
C           On entry, TRANSA specifies the form of op( A ) to be used in
C           the matrix multiplication as follows:
C
C              TRANSA = 'N' or 'n'   op( A ) = A.
C
C              TRANSA = 'T' or 't'   op( A ) = A'.
C
C              TRANSA = 'C' or 'c'   op( A ) = A'.
C
C           Unchanged on exit.
C
C  DIAG   - CHARACTER*1.
C           On entry, DIAG specifies whether or not A is unit triangular
C           as follows:
C
C              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
C
C              DIAG = 'N' or 'n'   A is not assumed to be unit
C                                  triangular.
C
C           Unchanged on exit.
C
C  M      - INTEGER.
C           On entry, M specifies the number of rows of B. M must be at
C           least zero.
C           Unchanged on exit.
C
C  N      - INTEGER.
C           On entry, N specifies the number of columns of B.  N must be
C           at least zero.
C           Unchanged on exit.
C
C  ALPHA  - DOUBLE PRECISION.
C           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
C           zero then  A is not referenced and  B need not be set before
C           entry.
C           Unchanged on exit.
C
C  A      - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
C           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
C           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
C           upper triangular part of the array  A must contain the upper
C           triangular matrix  and the strictly lower triangular part of
C           A is not referenced.
C           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
C           lower triangular part of the array  A must contain the lower
C           triangular matrix  and the strictly upper triangular part of
C           A is not referenced.
C           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
C           A  are not referenced either,  but are assumed to be  unity.
C           Unchanged on exit.
C
C  LDA    - INTEGER.
C           On entry, LDA specifies the first dimension of A as declared
C           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
C           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
C           then LDA must be at least max( 1, n ).
C           Unchanged on exit.
C
C  B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
C           Before entry,  the leading  m by n part of the array  B must
C           contain  the  right-hand  side  matrix  B,  and  on exit  is
C           overwritten by the solution matrix  X.
C
C  LDB    - INTEGER.
C           On entry, LDB specifies the first dimension of B as declared
C           in  the  calling  (sub)  program.   LDB  must  be  at  least
C           max( 1, m ).
C           Unchanged on exit.
C
C
C  Level 3 Blas routine.
C
C
C  -- Written on 8-February-1989.
C     Jack Dongarra, Argonne National Laboratory.
C     Iain Duff, AERE Harwell.
C     Jeremy Du Croz, Numerical Algorithms Group Ltd.
C     Sven Hammarling, Numerical Algorithms Group Ltd.
C
C
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     .. Local Scalars ..
      LOGICAL            LSIDE, NOUNIT, UPPER
      INTEGER            I, INFO, J, K, NROWA
      DOUBLE PRECISION   TEMP
C     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      LSIDE  = LSAME( SIDE  , 'L' )
      IF( LSIDE )THEN
         NROWA = M
      ELSE
         NROWA = N
      END IF
      NOUNIT = LSAME( DIAG  , 'N' )
      UPPER  = LSAME( UPLO  , 'U' )
C
      INFO   = 0
      IF(      ( .NOT.LSIDE                ).AND.
     $         ( .NOT.LSAME( SIDE  , 'R' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.UPPER                ).AND.
     $         ( .NOT.LSAME( UPLO  , 'L' ) )      )THEN
         INFO = 2
      ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND.
     $         ( .NOT.LSAME( TRANSA, 'T' ) ).AND.
     $         ( .NOT.LSAME( TRANSA, 'C' ) )      )THEN
         INFO = 3
      ELSE IF( ( .NOT.LSAME( DIAG  , 'U' ) ).AND.
     $         ( .NOT.LSAME( DIAG  , 'N' ) )      )THEN
         INFO = 4
      ELSE IF( M  .LT.0               )THEN
         INFO = 5
      ELSE IF( N  .LT.0               )THEN
         INFO = 6
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 9
      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTRSM ', INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
C     And when  alpha.eq.zero.
C
      IF( ALPHA.EQ.ZERO )THEN
         DO 20, J = 1, N
            DO 10, I = 1, M
               B( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
         RETURN
      END IF
C
C     Start the operations.
C
      IF( LSIDE )THEN
         IF( LSAME( TRANSA, 'N' ) )THEN
C
C           Form  B := alpha*inv( A )*B.
C
            IF( UPPER )THEN
               DO 60, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 30, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   30                CONTINUE
                  END IF
                  DO 50, K = M, 1, -1
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT )
     $                     B( K, J ) = B( K, J )/A( K, K )
                        DO 40, I = 1, K - 1
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   40                   CONTINUE
                     END IF
   50             CONTINUE
   60          CONTINUE
            ELSE
               DO 100, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 70, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   70                CONTINUE
                  END IF
                  DO 90 K = 1, M
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT )
     $                     B( K, J ) = B( K, J )/A( K, K )
                        DO 80, I = K + 1, M
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   80                   CONTINUE
                     END IF
   90             CONTINUE
  100          CONTINUE
            END IF
         ELSE
C
C           Form  B := alpha*inv( A' )*B.
C
            IF( UPPER )THEN
               DO 130, J = 1, N
                  DO 120, I = 1, M
                     TEMP = ALPHA*B( I, J )
                     DO 110, K = 1, I - 1
                        TEMP = TEMP - A( K, I )*B( K, J )
  110                CONTINUE
                     IF( NOUNIT )
     $                  TEMP = TEMP/A( I, I )
                     B( I, J ) = TEMP
  120             CONTINUE
  130          CONTINUE
            ELSE
               DO 160, J = 1, N
                  DO 150, I = M, 1, -1
                     TEMP = ALPHA*B( I, J )
                     DO 140, K = I + 1, M
                        TEMP = TEMP - A( K, I )*B( K, J )
  140                CONTINUE
                     IF( NOUNIT )
     $                  TEMP = TEMP/A( I, I )
                     B( I, J ) = TEMP
  150             CONTINUE
  160          CONTINUE
            END IF
         END IF
      ELSE
         IF( LSAME( TRANSA, 'N' ) )THEN
C
C           Form  B := alpha*B*inv( A ).
C
            IF( UPPER )THEN
               DO 210, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 170, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  170                CONTINUE
                  END IF
                  DO 190, K = 1, J - 1
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 180, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  180                   CONTINUE
                     END IF
  190             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 200, I = 1, M
                        B( I, J ) = TEMP*B( I, J )
  200                CONTINUE
                  END IF
  210          CONTINUE
            ELSE
               DO 260, J = N, 1, -1
                  IF( ALPHA.NE.ONE )THEN
                     DO 220, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  220                CONTINUE
                  END IF
                  DO 240, K = J + 1, N
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 230, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  230                   CONTINUE
                     END IF
  240             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 250, I = 1, M
                       B( I, J ) = TEMP*B( I, J )
  250                CONTINUE
                  END IF
  260          CONTINUE
            END IF
         ELSE
C
C           Form  B := alpha*B*inv( A' ).
C
            IF( UPPER )THEN
               DO 310, K = N, 1, -1
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( K, K )
                     DO 270, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  270                CONTINUE
                  END IF
                  DO 290, J = 1, K - 1
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = A( J, K )
                        DO 280, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  280                   CONTINUE
                     END IF
  290             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 300, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  300                CONTINUE
                  END IF
  310          CONTINUE
            ELSE
               DO 360, K = 1, N
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( K, K )
                     DO 320, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  320                CONTINUE
                  END IF
                  DO 340, J = K + 1, N
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = A( J, K )
                        DO 330, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  330                   CONTINUE
                     END IF
  340             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 350, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  350                CONTINUE
                  END IF
  360          CONTINUE
            END IF
         END IF
      END IF
C
      RETURN
C
C     End of DTRSM .
C
      END
      INTEGER FUNCTION IDAMAX(N,DX,INCX)
C
C     finds the index of element having max. absolute value.
C     jack dongarra, linpack, 3/11/78.
C     modified to correct problem with negative increment, 8/21/90.
C
      DOUBLE PRECISION DX(1),DMAX
      INTEGER I,INCX,IX,N
C
      IDAMAX = 0
      IF( N .LT. 1 ) RETURN
      IDAMAX = 1
      IF(N.EQ.1)RETURN
      IF(INCX.EQ.1)GO TO 20
C
C        code for increment not equal to 1
C
      IX = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      DMAX = DABS(DX(IX))
      IX = IX + INCX
      DO 10 I = 2,N
         IF(DABS(DX(IX)).LE.DMAX) GO TO 5
         IDAMAX = I
         DMAX = DABS(DX(IX))
    5    IX = IX + INCX
   10 CONTINUE
      RETURN
C
C        code for increment equal to 1
C
   20 DMAX = DABS(DX(1))
      DO 30 I = 2,N
         IF(DABS(DX(I)).LE.DMAX) GO TO 30
         IDAMAX = I
         DMAX = DABS(DX(I))
   30 CONTINUE
      RETURN
      END
      LOGICAL          FUNCTION LSAME( CA, CB )
C
C  -- LAPACK auxiliary routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
C
C  Modified by Bob Fay May 11, 1993 to enable ICHAR call
C
C     CHARACTER          CA, CB
C
      CHARACTER          CA, CB, CZ
C     ..
C
C  Purpose
C  =======
C
C  LSAME returns .TRUE. if CA is the same letter as CB regardless of
C  case.
C
C  Arguments
C  =========
C
C  CA      (input) CHARACTER*1
C  CB      (input) CHARACTER*1
C          CA and CB specify the single characters to be compared.
C
C     .. Intrinsic Functions ..
      INTRINSIC          ICHAR
C     ..
C     .. Local Scalars ..
      INTEGER            INTA, INTB, ZCODE
C     ..
C
C  Added by Bob Fay May 11, 1993
C
      DATA CZ/'Z'/
C
C     .. Executable Statements ..
C
C     Test if the characters are equal
C
      LSAME = CA.EQ.CB
      IF( LSAME )
     $   RETURN
C
C     Now test for equivalence if both characters are alphabetic.
C
      ZCODE = ICHAR( CZ )
C
C     Use 'Z' rather than 'A' so that ASCII can be detected on Prime
C     machines, on which ICHAR returns a value with bit 8 set.
C     ICHAR('A') on Prime machines returns 193 which is the same as
C     ICHAR('A') on an EBCDIC machine.
C
      INTA = ICHAR( CA )
      INTB = ICHAR( CB )
C
      IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN
C
C        ASCII is assumed - ZCODE is the ASCII code of either lower or
C        upper case 'Z'.
C
         IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32
         IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32
C
      ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN
C
C        EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
C        upper case 'Z'.
C
         IF( INTA.GE.129 .AND. INTA.LE.137 .OR.
     $       INTA.GE.145 .AND. INTA.LE.153 .OR.
     $       INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64
         IF( INTB.GE.129 .AND. INTB.LE.137 .OR.
     $       INTB.GE.145 .AND. INTB.LE.153 .OR.
     $       INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64
C
      ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN
C
C        ASCII is assumed, on Prime machines - ZCODE is the ASCII code
C        plus 128 of either lower or upper case 'Z'.
C
         IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32
         IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32
      END IF
      LSAME = INTA.EQ.INTB
C
C     RETURN
C
C     End of LSAME
C
      END
      SUBROUTINE XERBLA( SRNAME, INFO )
C
C  -- LAPACK auxiliary routine (preliminary version) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER*6        SRNAME
      INTEGER            INFO
C     ..
C
C  Purpose
C  =======
C
C  XERBLA  is an error handler for the LAPACK routines.
C  It is called by an LAPACK routine if an input parameter has an
C  invalid value.  A message is printed and execution stops.
C
C  Installers may consider modifying the STOP statement in order to
C  call system-specific exception-handling facilities.
C
C  Arguments
C  =========
C
C  SRNAME  (input) CHARACTER*6
C          The name of the routine which called XERBLA.
C
C  INFO    (input) INTEGER
C          The position of the invalid parameter in the parameter list
C          of the calling routine.
C
C
      WRITE( *, FMT = 9999 )SRNAME, INFO
C
      STOP
C
 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ',
     $      'an illegal value' )
C
C     End of XERBLA
C
      END
      SUBROUTINE DSPMM ( UPLO, TRANSB, M, N, ALPHA, AP, B, LDB, BETA, C,
     .                   LDC )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA, BETA
      INTEGER            M, N, LDB, LDC
      CHARACTER*1        UPLO, TRANSB
C     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), B( LDB, * ), C( LDC, * )
C     ..
C
C  Purpose
C  =======
C
C  DSPMM  performs one of the matrix-matrix operations
C
C     C := alpha*A*op( B ) + beta*C,
C
C  where  op( B ) is one of
C
C     op( B ) = B   or   op( B ) = B',
C
C  where alpha and beta are scalars, B and C are matrices, and
C  A is an n by n symmetric matrix, supplied in packed form.
C
C  Parameters
C  ==========
C
C  UPLO   - CHARACTER*1.
C           On entry, UPLO specifies whether the upper or lower
C           triangular part of the matrix A is supplied in the packed
C           array AP as follows:
C
C              UPLO = 'U' or 'u'   The upper triangular part of A is
C                                  supplied in AP.
C
C              UPLO = 'L' or 'l'   The lower triangular part of A is
C                                  supplied in AP.
C
C           Unchanged on exit.
C
C  TRANSB - CHARACTER*1.
C           On entry, TRANSB specifies the form of op( B ) to be used in
C           the matrix multiplication as follows:
C
C              TRANSB = 'N' or 'n',  op( B ) = B.
C
C              TRANSB = 'T' or 't',  op( B ) = B'.
C
C              TRANSB = 'C' or 'c',  op( B ) = B'.
C
C           Unchanged on exit.
C
C  M      - INTEGER.
C           On entry, M specifies the order of the matrix A and
C           the number of rows of op( B ).
C           M must be at least zero.
C           Unchanged on exit.
C
C  N      - INTEGER
C           On entry, N specifies the number of columns of the matrix
C           op( B ) and the number of columns of the matrix C.
C           N must be at least zero.
C           Unchanged on exit.
C
C  ALPHA  - DOUBLE PRECISION.
C           On entry, ALPHA specifies the scalar alpha.
C           Unchanged on exit.
C
C  AP     - DOUBLE PRECISION array of DIMENSION at least
C           ( ( m*( m + 1 ) )/2 ).
C           Before entry with UPLO = 'U' or 'u', the array AP must
C           contain the upper triangular part of the symmetric matrix
C           packed sequentially, column by column, so that AP( 1 )
C           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
C           and a( 2, 2 ) respectively, and so on.
C           Before entry with UPLO = 'L' or 'l', the array AP must
C           contain the lower triangular part of the symmetric matrix
C           packed sequentially, column by column, so that AP( 1 )
C           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
C           and a( 3, 1 ) respectively, and so on.
C           Unchanged on exit.
C
C  B      - DOUBLE PRECISION array of DIMENSION ( LDB, kb), where
C           kb is n when  TRANSB = 'N' or 'n', and is m otherwise.
C           Before entry with  TRANSB = 'N' or 'n', the leading
C           m by n part of the array B must contain the matrix B,
C           otherwise, the leading n by m part of the array B must
C           contain the matrix B.
C           Unchanged on exit.
C
C  LDB    - INTEGER.
C           On entry, LDB specifies the first dimension of the array B
C           as declared in the calling (sub) program.
C           When  TRANSB = 'N' or 'n' then LDB must be at least
C           max( 1, m ), otherwise  LDB must be at least  max( 1, n).
C           Unchanged on exit.
C
C  BETA   - DOUBLE PRECISION.
C           On entry, BETA specifies the scalar beta. When BETA is
C           supplied as zero then C need not be set on input.
C           Unchanged on exit.
C
C  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
C           Before entry, the leading  m by n  part of the array  C must
C           contain the matrix  C,  except when  beta  is zero, in which
C           case C need not be set on entry.
C           On exit, the array  C  is overwritten by the  m by n  matrix
C           ( alpha*A*op( B ) + beta*C ).
C
C  LDC    - INTEGER.
C           On entry, LDC specifies the first dimension of C as declared
C           in  the  calling  (sub)  program.   LDC  must  be  at  least
C           max( 1, m ).
C           Unchanged on exit.
C
C
C
C
C  Modified version of DSPMV, a Level 2 Blas routine.
C
C
C
C  -- DSPMV was written on 22-October-1986.
C     Jack Dongarra, Argonne National Lab.
C     Jeremy Du Croz, Nag Central Office.
C     Sven Hammarling, Nag Central Office.
C     Richard Hanson, Sandia National Labs.
C
C  Modified on 4-August-1993.
C     Bob Fay, U.S. Bureau of the Census
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     .. Local Scalars ..
      LOGICAL            NOTB
      DOUBLE PRECISION   TEMP1, TEMP2
      INTEGER            I, INFO, J, K, KK, L, NROWB
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           XERBLA
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      NOTB  =  LSAME( TRANSB, 'N' )
      IF( NOTB )THEN
         NROWB = M
      ELSE
         NROWB = N
      END IF
      INFO = 0
      IF     ( .NOT.LSAME( UPLO, 'U' ).AND.
     $         .NOT.LSAME( UPLO, 'L' )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.NOTB                ).AND.
     .         ( .NOT.LSAME( TRANSB, 'C') ).AND.
     .         ( .NOT.LSAME( TRANSB, 'T') )      )THEN
         INFO = 2
      ELSE IF( M  .LT.0               )THEN
         INFO = 3
      ELSE IF( N  .LT.0               )THEN
         INFO = 4
      ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN
         INFO = 8
      ELSE IF( LDC.LT.MAX( 1, M     ) )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DSPMM ', INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
C
C     And if  alpha.eq.zero.
C
      IF( ALPHA.EQ.ZERO )THEN
         IF( BETA.EQ.ZERO )THEN
            DO 20, J = 1, N
               DO 10, I = 1, M
                  C( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               DO 30, I = 1, M
                  C( I, J ) = BETA*C( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         RETURN
      END IF
C
C     Start the operations. The elements of the array AP are accessed
C     sequentially with one pass through AP for each column of C.
C
      IF( LSAME( UPLO, 'U' ) )THEN
C
C     Form  C  when AP contains the upper triangle.
C
         IF( NOTB )THEN
C
C           Form  C := alpha*A*B + beta*C
C
            DO 90, J = 1, N
               KK = 1
               IF( BETA.EQ.ZERO )THEN
                  DO 50, I = 1, M
                     C( I, J ) = ZERO
   50             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 60, I = 1, M
                     C( I, J ) = BETA*C( I, J )
   60             CONTINUE
               END IF
               DO 80, L = 1, M
                  TEMP1 = ALPHA*B( L, J )
                  TEMP2 = ZERO
                  K     = KK
                  DO 70, I = 1, L - 1
                     C( I, J ) = C( I, J ) + TEMP1*AP( K )
                     TEMP2  = TEMP2  + AP( K )*B( I, J )
                     K      = K      + 1
   70             CONTINUE
                  C( L, J ) = C( L, J ) + TEMP1*AP( KK + L - 1 )
     .                     + ALPHA*TEMP2
                  KK     = KK     + L
   80          CONTINUE
   90       CONTINUE
         ELSE
C
C           Form  C := alpha*A*B' + beta*C
C
            DO 140, J = 1, N
               KK = 1
               IF( BETA.EQ.ZERO )THEN
                  DO 100, I = 1, M
                     C( I, J ) = ZERO
  100             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 110, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  110             CONTINUE
               END IF
               DO 130, L = 1, M
                  TEMP1 = ALPHA*B( J, L )
                  TEMP2 = ZERO
                  K     = KK
                  DO 120, I = 1, L - 1
                     C( I, J ) = C( I, J ) + TEMP1*AP( K )
                     TEMP2  = TEMP2  + AP( K )*B( J, I )
                     K      = K      + 1
  120             CONTINUE
                  C( L, J ) = C( L, J ) + TEMP1*AP( KK + L - 1 )
     .                     + ALPHA*TEMP2
                  KK     = KK     + L
  130          CONTINUE
  140       CONTINUE
         END IF
      ELSE
C
C        Form  C  when AP contains the lower triangle.
C
         IF( NOTB )THEN
C
C           Form  C := alpha*A*B + beta*C
C
            DO 190, J = 1, N
               KK = 1
               IF( BETA.EQ.ZERO )THEN
                  DO 150, I = 1, M
                     C( I, J ) = ZERO
  150             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 160, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  160             CONTINUE
               END IF
               DO 180, L = 1, M
                  TEMP1 = ALPHA*B( L, J )
                  TEMP2 = ZERO
                  C( L, J ) = C( L, J )   + TEMP1*AP(KK)
                  K         = KK          + 1
                  DO 170, I = L + 1, N
                     C( I, J ) = C( I, J ) + TEMP1*AP( K )
                     TEMP2  = TEMP2  + AP( K )*B( I, J )
                     K      = K      + 1
  170             CONTINUE
                  C( L, J ) = C( L, J ) + ALPHA*TEMP2
                  KK     = KK     + ( M - L + 1 )
  180          CONTINUE
  190       CONTINUE
         ELSE
C
C           Form  C := alpha*A*B' + beta*C
C
            DO 240, J = 1, N
               KK = 1
               IF( BETA.EQ.ZERO )THEN
                  DO 200, I = 1, M
                     C( I, J ) = ZERO
  200             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 210, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  210             CONTINUE
               END IF
               DO 230, L = 1, M
                  TEMP1 = ALPHA*B( J, L )
                  TEMP2 = ZERO
                  C( L, J ) = C( L, J )   + TEMP1*AP(KK)
                  K         = KK          + 1
                  DO 220, I = L + 1, N
                     C( I, J ) = C( I, J ) + TEMP1*AP( K )
                     TEMP2  = TEMP2  + AP( K )*B( J, I )
                     K      = K      + 1
  220             CONTINUE
                  C( L, J ) = C( L, J ) + ALPHA*TEMP2
                  KK     = KK     + ( M - L + 1 )
  230          CONTINUE
  240       CONTINUE
         END IF
      END IF
C
      RETURN
C
C     End of DSPMM .
C
      END
C
      SUBROUTINE DSPMP ( UPLO, N, ALPHA, AP, BP, BETA, C, LDC )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA, BETA
      INTEGER            N, LDC
      CHARACTER*1        UPLO
C     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), BP( * ), C( LDC, * )
C     ..
C
C  Purpose
C  =======
C
C  DSPMP  performs the matrix-matrix operation
C
C     C := alpha*A*B + beta*C,
C
C  where alpha and beta are scalars, C is a matrix, and
C  A and B are  n by n symmetric matrices, supplied in packed form.
C
C  Parameters
C  ==========
C
C  UPLO   - CHARACTER*1.
C           On entry, UPLO specifies whether the upper or lower
C           triangular parts of the matrices A and B are supplied
C           in the packed arrays AP and BP as follows:
C
C              UPLO = 'U' or 'u'   The upper triangular parts of A
C                                  and B are supplied in AP, BP
C
C              UPLO = 'L' or 'l'   The lower triangular parts of A
C                                  and B are supplied in AP, BP
C
C           Unchanged on exit.
C
C  N      - INTEGER.
C           On entry, N specifies the order of the matrices A and B.
C           N must be at least zero.
C           Unchanged on exit.
C
C  ALPHA  - DOUBLE PRECISION.
C           On entry, ALPHA specifies the scalar alpha.
C           Unchanged on exit.
C
C  AP     - DOUBLE PRECISION array of DIMENSION at least
C           ( ( n*( n + 1 ) )/2 ).
C           Before entry with UPLO = 'U' or 'u', the array AP must
C           contain the upper triangular part of the symmetric matrix
C           packed sequentially, column by column, so that AP( 1 )
C           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
C           and a( 2, 2 ) respectively, and so on.
C           Before entry with UPLO = 'L' or 'l', the array AP must
C           contain the lower triangular part of the symmetric matrix
C           packed sequentially, column by column, so that AP( 1 )
C           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
C           and a( 3, 1 ) respectively, and so on.
C           Unchanged on exit.
C
C  BP     - DOUBLE PRECISION array of DIMENSION at least
C           ( ( n*( n + 1 ) )/2 ).
C           Before entry with UPLO = 'U' or 'u', the array BP must
C           contain the upper triangular part of the symmetric matrix
C           packed sequentially, column by column, so that BP( 1 )
C           contains b( 1, 1 ), BP( 2 ) and BP( 3 ) contain b( 1, 2 )
C           and b( 2, 2 ) respectively, and so on.
C           Before entry with UPLO = 'L' or 'l', the array BP must
C           contain the lower triangular part of the symmetric matrix
C           packed sequentially, column by column, so that BP( 1 )
C           contains b( 1, 1 ), BP( 2 ) and BP( 3 ) contain b( 2, 1 )
C           and b( 3, 1 ) respectively, and so on.
C           Unchanged on exit.
C
C  BETA   - DOUBLE PRECISION.
C           On entry, BETA specifies the scalar beta. When BETA is
C           supplied as zero then C need not be set on input.
C           Unchanged on exit.
C
C  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
C           Before entry, the leading  n by n  part of the array  C must
C           contain the matrix  C,  except when  beta  is zero, in which
C           case C need not be set on entry.
C           On exit, the array  C  is overwritten by the  n by n  matrix
C           ( alpha*A*B + beta*C ).
C
C  LDC    - INTEGER.
C           On entry, LDC specifies the first dimension of C as declared
C           in  the  calling  (sub)  program.   LDC  must  be  at  least
C           max( 1, n ).
C           Unchanged on exit.
C
C
C
C
C  Modified version of DSPMV, a Level 2 Blas routine.
C
C
C
C  -- DSPMV was written on 22-October-1986.
C     Jack Dongarra, Argonne National Lab.
C     Jeremy Du Croz, Nag Central Office.
C     Sven Hammarling, Nag Central Office.
C     Richard Hanson, Sandia National Labs.
C
C  Modified on 4-August-1993.
C     Bob Fay, U.S. Bureau of the Census
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     .. Local Scalars ..
      DOUBLE PRECISION   TEMP1, TEMP2
      INTEGER            I, INFO, J, K, KB, KBB, KK, L
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           XERBLA
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      IF     ( .NOT.LSAME( UPLO, 'U' ).AND.
     $         .NOT.LSAME( UPLO, 'L' )      )THEN
         INFO = 1
      ELSE IF( N  .LT.0               )THEN
         INFO = 2
      ELSE IF( LDC.LT.MAX( 1, N     ) )THEN
         INFO = 8
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DSPMP ', INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
C
C     And if  alpha.eq.zero.
C
      IF( ALPHA.EQ.ZERO )THEN
         IF( BETA.EQ.ZERO )THEN
            DO 20, J = 1, N
               DO 10, I = 1, N
                  C( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               DO 30, I = 1, N
                  C( I, J ) = BETA*C( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         RETURN
      END IF
C
C     Start the operations. The elements of the array AP are accessed
C     sequentially with one pass through AP for each column of C.
C
      IF( LSAME( UPLO, 'U' ) )THEN
C
C     Form  C  when AP contains the upper triangle.
C
         DO 90, J = 1, N
            KK = 1
            KBB = ( J * (J-1))/2  + 1
            IF( BETA.EQ.ZERO )THEN
               DO 50, I = 1, N
                  C( I, J ) = ZERO
   50          CONTINUE
            ELSE IF( BETA.NE.ONE )THEN
               DO 60, I = 1, N
                  C( I, J ) = BETA*C( I, J )
   60          CONTINUE
            END IF
            DO 80, L = 1, N
               IF(L .LT. J)THEN
                 KB = KBB + L - 1
               ELSE
                 KB = (L * (L - 1))/2  + J
               END IF
               TEMP1 = ALPHA*BP( KB )
               KB = KBB
               TEMP2 = ZERO
               K     = KK
               DO 70, I = 1, L - 1
                  C( I, J ) = C( I, J ) + TEMP1*AP( K )
                  TEMP2  = TEMP2  + AP( K )*BP( KB )
                  K      = K      + 1
                  IF( I .LT. J)THEN
                     KB     = KB     + 1
                  ELSE
                     KB     = KB     + I
                  END IF
   70          CONTINUE
               C( L, J ) = C( L, J ) + TEMP1*AP( KK + L - 1 )
     .                     + ALPHA*TEMP2
               KK     = KK     + L
   80       CONTINUE
   90    CONTINUE
      ELSE
C
C        Form  C  when AP contains the lower triangle.
C
         DO 140, J = 1, N
            KK  = 1
            IF( BETA.EQ.ZERO )THEN
               DO 100, I = 1, N
                  C( I, J ) = ZERO
  100          CONTINUE
            ELSE IF( BETA.NE.ONE )THEN
               DO 110, I = 1, N
                  C( I, J ) = BETA*C( I, J )
  110          CONTINUE
            END IF
            DO 130, L = 1, N
               IF(L .LT. J) THEN
                  KB = ( (L-1) * ( 2*N - L + 2 ) ) /2 + J - L + 1
               ELSE
                  KB = ( (J-1) * ( 2*N - J + 2 ) ) /2 + L - J + 1
               END IF
               TEMP1 = ALPHA*BP( KB )
               TEMP2 = ZERO
               C( L, J ) = C( L, J )   + TEMP1*AP( KK )
               K         = KK          + 1
               IF(L+1 .LT. J) THEN
                  KB = ( L * ( 2*N - L + 1 ) ) /2 + J - L
               ELSE
                  KB = ( (J-1) * ( 2*N - J + 2 ) ) /2 + L - J + 2
               END IF
               DO 120, I = L + 1, N
                  C( I, J ) = C( I, J ) + TEMP1*AP( K )
                  TEMP2  = TEMP2  + AP( K )*BP( KB )
                  K      = K      + 1
                  IF( I .LT. J)THEN
                     KB = KB +  N - I
                  ELSE
                     KB = KB + 1
                  END IF
  120          CONTINUE
               C( L, J ) = C( L, J ) + ALPHA*TEMP2
               KK     = KK     + ( N - L + 1 )
  130       CONTINUE
  140    CONTINUE
      END IF
C
      RETURN
C
C     End of DSPMP .
C
      END
      SUBROUTINE DPPTRF( UPLO, N, AP, INFO )
C
C  -- LAPACK routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   AP( * )
C     ..
C
C  Purpose
C  =======
C
C  DPPTRF computes the Cholesky factorization of a real symmetric
C  positive definite matrix A stored in packed format.
C
C  The factorization has the form
C     A = U' * U ,  if UPLO = 'U', or
C     A = L  * L',  if UPLO = 'L',
C  where U is an upper triangular matrix and L is lower triangular.
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          Specifies whether the upper or lower triangular part of the
C          symmetric matrix A is stored:
C          = 'U':  Upper triangular
C          = 'L':  Lower triangular
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.
C
C  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
C          On entry, the upper or lower triangle of the symmetric matrix
C          A, packed columnwise in a linear array.  The j-th column of A
C          is stored in the array AP as follows:
C          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
C          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
C          See below for further details.
C
C          On exit, if INFO = 0, the triangular factor U or L from the
C          Cholesky factorization A = U'*U or A = L*L', in the same
C          storage format as A.
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -k, the k-th argument had an illegal value
C          > 0: if INFO = k, the leading minor of order k is not
C               positive definite, and the factorization could not be
C               completed.
C
C  Further Details
C  ======= =======
C
C  The packed storage scheme is illustrated by the following example
C  when N = 4, UPLO = 'U':
C
C  Two-dimensional storage of the symmetric matrix A:
C
C     a11 a12 a13 a14
C         a22 a23 a24
C             a33 a34     (aij = aji)
C                 a44
C
C  Packed storage of the upper triangle of A:
C
C  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
C
C  =====================================================================
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J, JC, JJ
      DOUBLE PRECISION   AJJ
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT
      EXTERNAL           LSAME, DDOT
C     ..
C     .. External Subroutines ..
      EXTERNAL           DSCAL, DSPR, DTPSV, XERBLA
C     ..
C     .. Intrinsic Functions ..
C     INTRINSIC          SQRT
C     .. changed by Bob Fay
      INTRINSIC          DSQRT
 
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPPTRF', -INFO )
         RETURN
      END IF
C
C     Quick return if possible
C
      IF( N.EQ.0 )
     $   RETURN
C
      IF( UPPER ) THEN
C
C        Compute the Cholesky factorization A = U'*U.
C
         JJ = 0
         DO 10 J = 1, N
            JC = JJ + 1
            JJ = JJ + J
C
C           Compute elements 1:J-1 of column J.
C
            IF( J.GT.1 )
     $         CALL DTPSV( 'Upper', 'Transpose', 'Non-unit', J-1, AP,
     $                     AP( JC ), 1 )
C
C           Compute U(J,J) and test for non-positive-definiteness.
C
            AJJ = AP( JJ ) - DDOT( J-1, AP( JC ), 1, AP( JC ), 1 )
            IF( AJJ.LE.ZERO ) THEN
               AP( JJ ) = AJJ
               GO TO 30
            END IF
            AP( JJ ) = DSQRT( AJJ )
   10    CONTINUE
      ELSE
C
C        Compute the Cholesky factorization A = LCL'.
C
         JJ = 1
         DO 20 J = 1, N
C
C           Compute L(J,J) and test for non-positive-definiteness.
C
            AJJ = AP( JJ )
            IF( AJJ.LE.ZERO ) THEN
               AP( JJ ) = AJJ
               GO TO 30
            END IF
            AJJ = DSQRT( AJJ )
            AP( JJ ) = AJJ
C
C           Compute elements J+1:N of column J and update the trailing
C           submatrix.
C
            IF( J.LT.N ) THEN
               CALL DSCAL( N-J, ONE / AJJ, AP( JJ+1 ), 1 )
               CALL DSPR( 'Lower', N-J, -ONE, AP( JJ+1 ), 1,
     $                    AP( JJ+N-J+1 ) )
               JJ = JJ + N - J + 1
            END IF
   20    CONTINUE
      END IF
      GO TO 40
C
   30 CONTINUE
      INFO = J
C
   40 CONTINUE
      RETURN
C
C     End of DPPTRF
C
      END
      SUBROUTINE DPPTRI( UPLO, N, AP, INFO )
C
C  -- LAPACK routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   AP( * )
C     ..
C
C  Purpose
C  =======
C
C  DPPTRI computes the inverse of a real symmetric positive definite
C  matrix A using the Cholesky factorization A = U'*U or A = L*L'
C  computed by DPPTRF.
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          Specifies whether the factor stored in AP is upper or lower
C          triangular.
C          = 'U':  Upper triangular
C          = 'L':  Lower triangular
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.
C
C  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
C          On entry, the triangular factor U or L from the Cholesky
C          factorization A = U'*U or A = L*L', packed columnwise as a
C          linear array.  The j-th column of U or L is stored in the
C          array AP as follows:
C          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
C          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
C
C          On exit, the upper or lower triangle of the (symmetric)
C          inverse of A, overwriting the input factor U or L.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0: if INFO = -k, the k-th argument had an illegal value
C          > 0: if INFO = k, the (k,k) element of the factor U or L is
C               zero, and the inverse could not be computed.
C
C  =====================================================================
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J, JC, JJ, JJN
      DOUBLE PRECISION   AJJ
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT
      EXTERNAL           LSAME, DDOT
C     ..
C     .. External Subroutines ..
      EXTERNAL           DSCAL, DSPR, DTPMV, DTPTRI, XERBLA
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPPTRI', -INFO )
         RETURN
      END IF
C
C     Quick return if possible
C
      IF( N.EQ.0 )
     $   RETURN
C
C     Invert the triangular Cholesky factor U or L.
C
      CALL DTPTRI( UPLO, 'Non-unit', N, AP, INFO )
      IF( INFO.GT.0 )
     $   RETURN
C
      IF( UPPER ) THEN
C
C        Compute the product inv(U) * inv(U)'.
C
         JJ = 0
         DO 10 J = 1, N
            JC = JJ + 1
            JJ = JJ + J
            IF( J.GT.1 )
     $         CALL DSPR( 'Upper', J-1, ONE, AP( JC ), 1, AP )
            AJJ = AP( JJ )
            CALL DSCAL( J, AJJ, AP( JC ), 1 )
   10    CONTINUE
C
      ELSE
C
C        Compute the product inv(L)' * inv(L).
C
         JJ = 1
         DO 20 J = 1, N
            JJN = JJ + N - J + 1
            AP( JJ ) = DDOT( N-J+1, AP( JJ ), 1, AP( JJ ), 1 )
            IF( J.LT.N )
     $         CALL DTPMV( 'Lower', 'Transpose', 'Non-unit', N-J,
     $                     AP( JJN ), AP( JJ+1 ), 1 )
            JJ = JJN
   20    CONTINUE
      END IF
C
      RETURN
C
C     End of DPPTRI
C
      END
      SUBROUTINE DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
C
C  -- LAPACK routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDB, N, NRHS
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), B( LDB, * )
C     ..
C
C  Purpose
C  =======
C
C  DPPTRS solves a system of linear equations A*X = B with a symmetric
C  positive definite matrix A in packed storage using the Cholesky
C  factorization A = U'*U or A = L*L' computed by DPPTRF.
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          Specifies whether the factor stored in A is upper or lower
C          triangular.
C          = 'U':  Upper triangular
C          = 'L':  Lower triangular
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.
C
C  NRHS    (input) INTEGER
C          The number of right hand sides, i.e., the number of columns
C          of the matrix B.  NRHS >= 0.
C
C  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
C          The triangular factor U or L from the Cholesky factorization
C          A = U'*U or A = L*L', packed columnwise in a linear array.
C          The j-th column of U or L is stored in the array AP as
C          follows:
C          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
C          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
C
C  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
C          On entry, the right hand side vectors B for the system of
C          linear equations.
C          On exit, the solution vectors, X.
C
C  LDB     (input) INTEGER
C          The leading dimension of the array B.  LDB >= max(1,N).
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0: if INFO = -k, the k-th argument had an illegal value
C
C  =====================================================================
C
C     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DTPSV, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPPTRS', -INFO )
         RETURN
      END IF
C
C     Quick return if possible
C
      IF( N.EQ.0 .OR. NRHS.EQ.0 )
     $   RETURN
C
      IF( UPPER ) THEN
C
C        Solve A*X = B where A = U'*U.
C
         DO 10 I = 1, NRHS
C
C           Solve U'*X = B, overwriting B with X.
C
            CALL DTPSV( 'Upper', 'Transpose', 'Non-unit', N, AP,
     $                  B( 1, I ), 1 )
C
C           Solve U*X = B, overwriting B with X.
C
            CALL DTPSV( 'Upper', 'No transpose', 'Non-unit', N, AP,
     $                  B( 1, I ), 1 )
   10    CONTINUE
      ELSE
C
C        Solve A*X = B where A = L*L'.
C
         DO 20 I = 1, NRHS
C
C           Solve L*Y = B, overwriting B with X.
C
            CALL DTPSV( 'Lower', 'No transpose', 'Non-unit', N, AP,
     $                  B( 1, I ), 1 )
C
C           Solve L'*X = Y, overwriting B with X.
C
            CALL DTPSV( 'Lower', 'Transpose', 'Non-unit', N, AP,
     $                  B( 1, I ), 1 )
   20    CONTINUE
      END IF
C
      RETURN
C
C     End of DPPTRS
C
      END
      SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO )
C
C  -- LAPACK routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          DIAG, UPLO
      INTEGER            INFO, N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   AP( * )
C     ..
C
C  Purpose
C  =======
C
C  DTPTRI computes the inverse of a real upper or lower triangular
C  matrix A stored in packed format.
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          Specifies whether the matrix A is upper or lower triangular.
C          = 'U':  Upper triangular
C          = 'L':  Lower triangular
C
C  DIAG    (input) CHARACTER*1
C          Specifies whether or not the matrix A is unit triangular.
C          = 'N':  Non-unit triangular
C          = 'U':  Unit triangular
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.
C
C  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
C
C          On entry, the upper or lower triangular matrix A, stored
C          columnwise in a linear array.  The j-th column of A is stored
C          in the array AP as follows:
C          if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
C          if UPLO = 'L',
C             AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
C          See below for further details.
C
C          On exit, the (triangular) inverse of the original matrix, in
C          the same packed storage format.
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          > 0: if INFO = k, A(k,k) is exactly zero.  The triangular
C               matrix is singular and its inverse can not be computed.
C          < 0: if INFO = -k, the k-th argument had an illegal value
C
C  Further Details
C  ===============
C
C  A triangular matrix A can be transferred to packed storage using one
C  of the following program segments:
C
C  UPLO = 'U':                      UPLO = 'L':
C
C        JC = 1                           JC = 1
C        DO 2 J = 1, N                    DO 2 J = 1, N
C           DO 1 I = 1, J                    DO 1 I = J, N
C              AP(JC+I-1) = A(I,J)              AP(JC+I-J) = A(I,J)
C      1    CONTINUE                    1    CONTINUE
C           JC = JC + J                      JC = JC + N - J + 1
C      2 CONTINUE                       2 CONTINUE
C
C  =====================================================================
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            NOUNIT, UPPER
      INTEGER            J, JC, JCLAST, JJ
      DOUBLE PRECISION   AJJ
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DSCAL, DTPMV, XERBLA
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOUNIT = LSAME( DIAG, 'N' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTPTRI', -INFO )
         RETURN
      END IF
C
C     Check for singularity if non-unit.
C
      IF( NOUNIT ) THEN
         IF( UPPER ) THEN
            JJ = 0
            DO 10 INFO = 1, N
               JJ = JJ + INFO
               IF( AP( JJ ).EQ.ZERO )
     $            RETURN
   10       CONTINUE
         ELSE
            JJ = 1
            DO 20 INFO = 1, N
               IF( AP( JJ ).EQ.ZERO )
     $            RETURN
               JJ = JJ + N - INFO + 1
   20       CONTINUE
         END IF
         INFO = 0
      END IF
C
      IF( UPPER ) THEN
C
C        Compute inverse of upper triangular matrix.
C
         JC = 1
         DO 30 J = 1, N
            IF( NOUNIT ) THEN
               AP( JC+J-1 ) = ONE / AP( JC+J-1 )
               AJJ = -AP( JC+J-1 )
            ELSE
               AJJ = -ONE
            END IF
C
C           Compute elements 1:j-1 of j-th column.
C
            CALL DTPMV( 'Upper', 'No transpose', DIAG, J-1, AP,
     $                  AP( JC ), 1 )
            CALL DSCAL( J-1, AJJ, AP( JC ), 1 )
            JC = JC + J
   30    CONTINUE
C
      ELSE
C
C        Compute inverse of lower triangular matrix.
C
         JC = N*( N+1 ) / 2
         DO 40 J = N, 1, -1
            IF( NOUNIT ) THEN
               AP( JC ) = ONE / AP( JC )
               AJJ = -AP( JC )
            ELSE
               AJJ = -ONE
            END IF
            IF( J.LT.N ) THEN
C
C              Compute elements j+1:n of j-th column.
C
               CALL DTPMV( 'Lower', 'No transpose', DIAG, N-J,
     $                     AP( JCLAST ), AP( JC+1 ), 1 )
               CALL DSCAL( N-J, AJJ, AP( JC+1 ), 1 )
            END IF
            JCLAST = JC
            JC = JC - N + J - 2
   40    CONTINUE
      END IF
C
      RETURN
C
C     End of DTPTRI
C
      END
       SUBROUTINE DLAE2( A, B, C, RT1, RT2 )
C
C  -- LAPACK auxiliary routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION   A, B, C, RT1, RT2
C     ..
C
C  Purpose
C  =======
C
C  DLAE2  computes the eigenvalues of a 2-by-2 symmetric matrix
C     [  A   B  ]
C     [  B   C  ].
C  On return, RT1 is the eigenvalue of larger absolute value, and RT2
C  is the eigenvalue of smaller absolute value.
C
C  Arguments
C  =========
C
C  A       (input) DOUBLE PRECISION
C          The (1,1) entry of the 2-by-2 matrix.
C
C  B       (input) DOUBLE PRECISION
C          The (1,2) and (2,1) entries of the 2-by-2 matrix.
C
C  C       (input) DOUBLE PRECISION
C          The (2,2) entry of the 2-by-2 matrix.
C
C  RT1     (output) DOUBLE PRECISION
C          The eigenvalue of larger absolute value.
C
C  RT2     (output) DOUBLE PRECISION
C          The eigenvalue of smaller absolute value.
C
C  Further Details
C  ===============
C
C  RT1 is accurate to a few ulps barring over/underflow.
C
C  RT2 may be inaccurate if there is massive cancellation in the
C  determinant A*C-B*B; higher precision or correctly rounded or
C  correctly truncated arithmetic would be needed to compute RT2
C  accurately in all cases.
C
C  Overflow is possible only if RT1 is within a factor of 5 of overflow.
C  Underflow is harmless if the input data is 0 or exceeds
C     underflow_threshold / macheps.
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D0 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      DOUBLE PRECISION   HALF
      PARAMETER          ( HALF = 0.5D0 )
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION   AB, ACMN, ACMX, ADF, DF, RT, SM, TB
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, SQRT
C     ..
C     .. Executable Statements ..
C
C     Compute the eigenvalues
C
      SM = A + C
      DF = A - C
      ADF = ABS( DF )
      TB = B + B
      AB = ABS( TB )
      IF( ABS( A ).GT.ABS( C ) ) THEN
         ACMX = A
         ACMN = C
      ELSE
         ACMX = C
         ACMN = A
      END IF
      IF( ADF.GT.AB ) THEN
         RT = ADF*SQRT( ONE+( AB / ADF )**2 )
      ELSE IF( ADF.LT.AB ) THEN
         RT = AB*SQRT( ONE+( ADF / AB )**2 )
      ELSE
C
C        Includes case AB=ADF=0
C
         RT = AB*SQRT( TWO )
      END IF
      IF( SM.LT.ZERO ) THEN
         RT1 = HALF*( SM-RT )
C
C        Order of execution important.
C        To get fully accurate smaller eigenvalue,
C        next line needs to be executed in higher precision.
C
         RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
      ELSE IF( SM.GT.ZERO ) THEN
         RT1 = HALF*( SM+RT )
C
C        Order of execution important.
C        To get fully accurate smaller eigenvalue,
C        next line needs to be executed in higher precision.
C
         RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
      ELSE
C
C        Includes case RT1 = RT2 = 0
C
         RT1 = HALF*RT
         RT2 = -HALF*RT
      END IF
      RETURN
C
C     End of DLAE2
C
      END
      SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
C
C  -- LAPACK auxiliary routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION   A, B, C, CS1, RT1, RT2, SN1
C     ..
C
C  Purpose
C  =======
C
C  DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix
C     [  A   B  ]
C     [  B   C  ].
C  On return, RT1 is the eigenvalue of larger absolute value, RT2 is the
C  eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right
C  eigenvector for RT1, giving the decomposition
C
C     [ CS1  SN1 ] [  A   B  ] [ CS1 -SN1 ]  =  [ RT1  0  ]
C     [-SN1  CS1 ] [  B   C  ] [ SN1  CS1 ]     [  0  RT2 ].
C
C  Arguments
C  =========
C
C  A       (input) DOUBLE PRECISION
C          The (1,1) entry of the 2-by-2 matrix.
C
C  B       (input) DOUBLE PRECISION
C          The (1,2) entry and the conjugate of the (2,1) entry of the
C          2-by-2 matrix.
C
C  C       (input) DOUBLE PRECISION
C          The (2,2) entry of the 2-by-2 matrix.
C
C  RT1     (output) DOUBLE PRECISION
C          The eigenvalue of larger absolute value.
C
C  RT2     (output) DOUBLE PRECISION
C          The eigenvalue of smaller absolute value.
C
C  CS1     (output) DOUBLE PRECISION
C  SN1     (output) DOUBLE PRECISION
C          The vector (CS1, SN1) is a unit right eigenvector for RT1.
C
C  Further Details
C  ===============
C
C  RT1 is accurate to a few ulps barring over/underflow.
C
C  RT2 may be inaccurate if there is massive cancellation in the
C  determinant A*C-B*B; higher precision or correctly rounded or
C  correctly truncated arithmetic would be needed to compute RT2
C  accurately in all cases.
C
C  CS1 and SN1 are accurate to a few ulps barring over/underflow.
C
C  Overflow is possible only if RT1 is within a factor of 5 of overflow.
C  Underflow is harmless if the input data is 0 or exceeds
C     underflow_threshold / macheps.
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D0 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      DOUBLE PRECISION   HALF
      PARAMETER          ( HALF = 0.5D0 )
C     ..
C     .. Local Scalars ..
      INTEGER            SGN1, SGN2
      DOUBLE PRECISION   AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM,
     $                   TB, TN
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, SQRT
C     ..
C     .. Executable Statements ..
C
C     Compute the eigenvalues
C
      SM = A + C
      DF = A - C
      ADF = ABS( DF )
      TB = B + B
      AB = ABS( TB )
      IF( ABS( A ).GT.ABS( C ) ) THEN
         ACMX = A
         ACMN = C
      ELSE
         ACMX = C
         ACMN = A
      END IF
      IF( ADF.GT.AB ) THEN
         RT = ADF*SQRT( ONE+( AB / ADF )**2 )
      ELSE IF( ADF.LT.AB ) THEN
         RT = AB*SQRT( ONE+( ADF / AB )**2 )
      ELSE
C
C        Includes case AB=ADF=0
C
         RT = AB*SQRT( TWO )
      END IF
      IF( SM.LT.ZERO ) THEN
         RT1 = HALF*( SM-RT )
         SGN1 = -1
C
C        Order of execution important.
C        To get fully accurate smaller eigenvalue,
C        next line needs to be executed in higher precision.
C
         RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
      ELSE IF( SM.GT.ZERO ) THEN
         RT1 = HALF*( SM+RT )
         SGN1 = 1
C
C        Order of execution important.
C        To get fully accurate smaller eigenvalue,
C        next line needs to be executed in higher precision.
C
         RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
      ELSE
C
C        Includes case RT1 = RT2 = 0
C
         RT1 = HALF*RT
         RT2 = -HALF*RT
         SGN1 = 1
      END IF
C
C     Compute the eigenvector
C
      IF( DF.GE.ZERO ) THEN
         CS = DF + RT
         SGN2 = 1
      ELSE
         CS = DF - RT
         SGN2 = -1
      END IF
      ACS = ABS( CS )
      IF( ACS.GT.AB ) THEN
         CT = -TB / CS
         SN1 = ONE / SQRT( ONE+CT*CT )
         CS1 = CT*SN1
      ELSE
         IF( AB.EQ.ZERO ) THEN
            CS1 = ONE
            SN1 = ZERO
         ELSE
            TN = -CS / TB
            CS1 = ONE / SQRT( ONE+TN*TN )
            SN1 = TN*CS1
         END IF
      END IF
      IF( SGN1.EQ.SGN2 ) THEN
         TN = CS1
         CS1 = -SN1
         SN1 = TN
      END IF
      RETURN
C
C     End of DLAEV2
C
      END
      DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
C
C  -- LAPACK auxiliary routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          CMACH
C     ..
C
C  Purpose
C  =======
C
C  DLAMCH determines double precision machine parameters.
C
C  Arguments
C  =========
C
C  CMACH   (input) CHARACTER*1
C          Specifies the value to be returned by DLAMCH:
C          = 'E' or 'e',   DLAMCH := eps
C          = 'S' or 's ,   DLAMCH := sfmin
C          = 'B' or 'b',   DLAMCH := base
C          = 'P' or 'p',   DLAMCH := eps*base
C          = 'N' or 'n',   DLAMCH := t
C          = 'R' or 'r',   DLAMCH := rnd
C          = 'M' or 'm',   DLAMCH := emin
C          = 'U' or 'u',   DLAMCH := rmin
C          = 'L' or 'l',   DLAMCH := emax
C          = 'O' or 'o',   DLAMCH := rmax
C
C          where
C
C          eps   = relative machine precision
C          sfmin = safe minimum, such that 1/sfmin does not overflow
C          base  = base of the machine
C          prec  = eps*base
C          t     = number of (base) digits in the mantissa
C          rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise
C          emin  = minimum exponent before (gradual) underflow
C          rmin  = underflow threshold - base**(emin-1)
C          emax  = largest exponent before overflow
C          rmax  = overflow threshold  - (base**emax)*(1-eps)
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            FIRST, LRND
      INTEGER            BETA, IMAX, IMIN, IT
      DOUBLE PRECISION   BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN,
     $                   RND, SFMIN, SMALL, T
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DLAMC2
C     ..
C     .. Save statement ..
      SAVE               FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN,
     $                   EMAX, RMAX, PREC
C     ..
C     .. Data statements ..
      DATA               FIRST / .TRUE. /
C     ..
C     .. Executable Statements ..
C
      IF( FIRST ) THEN
         FIRST = .FALSE.
         CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX )
         BASE = BETA
         T = IT
         IF( LRND ) THEN
            RND = ONE
            EPS = ( BASE**( 1-IT ) ) / 2
         ELSE
            RND = ZERO
            EPS = BASE**( 1-IT )
         END IF
         PREC = EPS*BASE
         EMIN = IMIN
         EMAX = IMAX
         SFMIN = RMIN
         SMALL = ONE / RMAX
         IF( SMALL.GE.SFMIN ) THEN
C
C           Use SMALL plus a bit, to avoid the possibility of rounding
C           causing overflow when computing  1/sfmin.
C
            SFMIN = SMALL*( ONE+EPS )
         END IF
      END IF
C
      IF( LSAME( CMACH, 'E' ) ) THEN
         RMACH = EPS
      ELSE IF( LSAME( CMACH, 'S' ) ) THEN
         RMACH = SFMIN
      ELSE IF( LSAME( CMACH, 'B' ) ) THEN
         RMACH = BASE
      ELSE IF( LSAME( CMACH, 'P' ) ) THEN
         RMACH = PREC
      ELSE IF( LSAME( CMACH, 'N' ) ) THEN
         RMACH = T
      ELSE IF( LSAME( CMACH, 'R' ) ) THEN
         RMACH = RND
      ELSE IF( LSAME( CMACH, 'M' ) ) THEN
         RMACH = EMIN
      ELSE IF( LSAME( CMACH, 'U' ) ) THEN
         RMACH = RMIN
      ELSE IF( LSAME( CMACH, 'L' ) ) THEN
         RMACH = EMAX
      ELSE IF( LSAME( CMACH, 'O' ) ) THEN
         RMACH = RMAX
      END IF
C
      DLAMCH = RMACH
      RETURN
C
C     End of DLAMCH
C
      END
C
C***********************************************************************
C
      SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 )
C
C  -- LAPACK auxiliary routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      LOGICAL            IEEE1, RND
      INTEGER            BETA, T
C     ..
C
C  Purpose
C  =======
C
C  DLAMC1 determines the machine parameters given by BETA, T, RND, and
C  IEEE1.
C
C  Arguments
C  =========
C
C  BETA    (output) INTEGER
C          The base of the machine.
C
C  T       (output) INTEGER
C          The number of ( BETA ) digits in the mantissa.
C
C  RND     (output) LOGICAL
C          Specifies whether proper rounding  ( RND = .TRUE. )  or
C          chopping  ( RND = .FALSE. )  occurs in addition. This may not
C          be a reliable guide to the way in which the machine performs
C          its arithmetic.
C
C  IEEE1   (output) LOGICAL
C          Specifies whether rounding appears to be done in the IEEE
C          'round to nearest' style.
C
C  Further Details
C  ===============
C
C  The routine is based on the routine  ENVRON  by Malcolm and
C  incorporates suggestions by Gentleman and Marovich. See
C
C     Malcolm M. A. (1972) Algorithms to reveal properties of
C        floating-point arithmetic. Comms. of the ACM, 15, 949-951.
C
C     Gentleman W. M. and Marovich S. B. (1974) More on algorithms
C        that reveal properties of floating point arithmetic units.
C        Comms. of the ACM, 17, 276-277.
C
C
C     .. Local Scalars ..
      LOGICAL            FIRST, LIEEE1, LRND
      INTEGER            LBETA, LT
      DOUBLE PRECISION   A, B, C, F, ONE, QTR, SAVEC, T1, T2
C     ..
C     .. External Functions ..
      DOUBLE PRECISION   DLAMC3
      EXTERNAL           DLAMC3
C     ..
C     .. Save statement ..
      SAVE               FIRST, LIEEE1, LBETA, LRND, LT
C     ..
C     .. Data statements ..
      DATA               FIRST / .TRUE. /
C     ..
C     .. Executable Statements ..
C
      IF( FIRST ) THEN
         FIRST = .FALSE.
         ONE = 1
C
C        LBETA,  LIEEE1,  LT and  LRND  are the  local values  of  BETA,
C        IEEE1, T and RND.
C
C        Throughout this routine  we use the function  DLAMC3  to ensure
C        that relevant values are  stored and not held in registers,  or
C        are not affected by optimizers.
C
C        Compute  a = 2.0**m  with the  smallest positive integer m such
C        that
C
C           fl( a + 1.0 ) = a.
C
         A = 1
         C = 1
C
C+       WHILE( C.EQ.ONE )LOOP
   10    CONTINUE
C
C  Change by Bob Fay, Dec. 1, 1993, for consistency with the change just
C  after statement 20 below. On the Microsoft PowerStation compiler, this
C  first change does not appear to make a difference. The original was:
C        IF( C.EQ.ONE ) THEN
C
          IF(DLAMC3( C, -ONE).EQ.0.) THEN
            A = 2*A
            C = DLAMC3( A, ONE )
            C = DLAMC3( C, -A )
            GO TO 10
         END IF
C+       END WHILE
C
C        Now compute  b = 2.0**m  with the smallest positive integer m
C        such that
C
C           fl( a + b ) .gt. a.
C
         B = 1
         C = DLAMC3( A, B )
C
C+       WHILE( C.EQ.A )LOOP
   20    CONTINUE
C
C  Change by Bob Fay, Dec. 1, 1993, to allow floating point optimization
C  for speed on the Microsoft PowerStation compiler.  The original version
C  resulted in LBETA=0 below, causing an infinite loop to 30.
C  The original was:
C        IF( C.EQ.A ) THEN
C
         IF( DLAMC3( C, -A).EQ.0. ) THEN
            B = 2*B
            C = DLAMC3( A, B )
            GO TO 20
         END IF
C+       END WHILE
C
C        Now compute the base.  a and c  are neighbouring floating point
C        numbers  in the  interval  ( beta**t, beta**( t + 1 ) )  and so
C        their difference is beta. Adding 0.25 to c is to ensure that it
C        is truncated to beta and not ( beta - 1 ).
C
         QTR = ONE / 4
         SAVEC = C
         C = DLAMC3( C, -A )
         LBETA = C + QTR
C
C        Now determine whether rounding or chopping occurs,  by adding a
C        bit  less  than  beta/2  and a  bit  more  than  beta/2  to  a.
C
         B = LBETA
         F = DLAMC3( B / 2, -B / 100 )
         C = DLAMC3( F, A )
         IF( C.EQ.A ) THEN
            LRND = .TRUE.
         ELSE
            LRND = .FALSE.
         END IF
         F = DLAMC3( B / 2, B / 100 )
         C = DLAMC3( F, A )
         IF( ( LRND ) .AND. ( C.EQ.A ) )
     $      LRND = .FALSE.
C
C        Try and decide whether rounding is done in the  IEEE  'round to
C        nearest' style. B/2 is half a unit in the last place of the two
C        numbers A and SAVEC. Furthermore, A is even, i.e. has last  bit
C        zero, and SAVEC is odd. Thus adding B/2 to A should not  change
C        A, but adding B/2 to SAVEC should change SAVEC.
C
         T1 = DLAMC3( B / 2, A )
         T2 = DLAMC3( B / 2, SAVEC )
         LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND
C
C        Now find  the  mantissa, t.  It should  be the  integer part of
C        log to the base beta of a,  however it is safer to determine  t
C        by powering.  So we find t as the smallest positive integer for
C        which
C
C           fl( beta**t + 1.0 ) = 1.0.
C
         LT = 0
         A = 1
         C = 1
C
C+       WHILE( C.EQ.ONE )LOOP
   30    CONTINUE
C
C  Change by Bob Fay, Dec. 1, 1993, for consistency with the change just
C  after statement 20 above. On the Microsoft PowerStation compiler, this
C  third change does not appear to make a difference. The original was:
C        IF( C.EQ.ONE ) THEN
C
         IF(DLAMC3( C, -ONE).EQ.0.) THEN
            LT = LT + 1
            A = A*LBETA
            C = DLAMC3( A, ONE )
            C = DLAMC3( C, -A )
            GO TO 30
         END IF
C+       END WHILE
C
      END IF
C
      BETA = LBETA
      T = LT
      RND = LRND
      IEEE1 = LIEEE1
      RETURN
C
C     End of DLAMC1
C
      END
C
C***********************************************************************
C
      SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
C
C  -- LAPACK auxiliary routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      LOGICAL            RND
      INTEGER            BETA, EMAX, EMIN, T
      DOUBLE PRECISION   EPS, RMAX, RMIN
C     ..
C
C  Purpose
C  =======
C
C  DLAMC2 determines the machine parameters specified in its argument
C  list.
C
C  Arguments
C  =========
C
C  BETA    (output) INTEGER
C          The base of the machine.
C
C  T       (output) INTEGER
C          The number of ( BETA ) digits in the mantissa.
C
C  RND     (output) LOGICAL
C          Specifies whether proper rounding  ( RND = .TRUE. )  or
C          chopping  ( RND = .FALSE. )  occurs in addition. This may not
C          be a reliable guide to the way in which the machine performs
C          its arithmetic.
C
C  EPS     (output) DOUBLE PRECISION
C          The smallest positive number such that
C
C             fl( 1.0 - EPS ) .LT. 1.0,
C
C          where fl denotes the computed value.
C
C  EMIN    (output) INTEGER
C          The minimum exponent before (gradual) underflow occurs.
C
C  RMIN    (output) DOUBLE PRECISION
C          The smallest normalized number for the machine, given by
C          BASE**( EMIN - 1 ), where  BASE  is the floating point value
C          of BETA.
C
C  EMAX    (output) INTEGER
C          The maximum exponent before overflow occurs.
C
C  RMAX    (output) DOUBLE PRECISION
C          The largest positive number for the machine, given by
C          BASE**EMAX * ( 1 - EPS ), where  BASE  is the floating point
C          value of BETA.
C
C  Further Details
C  ===============
C
C  The computation of  EPS  is based on a routine PARANOIA by
C  W. Kahan of the University of California at Berkeley.
C
C
C     .. Local Scalars ..
      LOGICAL            FIRST, IEEE, IWARN, LIEEE1, LRND
      INTEGER            GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,
     $                   NGNMIN, NGPMIN
      DOUBLE PRECISION   A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE,
     $                   SIXTH, SMALL, THIRD, TWO, ZERO
C     ..
C     .. External Functions ..
      DOUBLE PRECISION   DLAMC3
      EXTERNAL           DLAMC3
C     ..
C     .. External Subroutines ..
      EXTERNAL           DLAMC1, DLAMC4, DLAMC5
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
C     ..
C     .. Save statement ..
      SAVE               FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX,
     $                   LRMIN, LT
C     ..
C     .. Data statements ..
      DATA               FIRST / .TRUE. / , IWARN / .FALSE. /
C     ..
C     .. Executable Statements ..
C
      IF( FIRST ) THEN
         FIRST = .FALSE.
         ZERO = 0
         ONE = 1
         TWO = 2
C
C        LBETA, LT, LRND, LEPS, LEMIN and LRMIN  are the local values of
C        BETA, T, RND, EPS, EMIN and RMIN.
C
C        Throughout this routine  we use the function  DLAMC3  to ensure
C        that relevant values are stored  and not held in registers,  or
C        are not affected by optimizers.
C
C        DLAMC1 returns the parameters  LBETA, LT, LRND and LIEEE1.
C
         CALL DLAMC1( LBETA, LT, LRND, LIEEE1 )
C
C        Start to find EPS.
C
         B = LBETA
         A = B**( -LT )
         LEPS = A
C
C        Try some tricks to see whether or not this is the correct  EPS.
C
         B = TWO / 3
         HALF = ONE / 2
         SIXTH = DLAMC3( B, -HALF )
         THIRD = DLAMC3( SIXTH, SIXTH )
         B = DLAMC3( THIRD, -HALF )
         B = DLAMC3( B, SIXTH )
         B = ABS( B )
         IF( B.LT.LEPS )
     $      B = LEPS
C
         LEPS = 1
C
C+       WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
   10    CONTINUE
         IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN
            LEPS = B
            C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) )
            C = DLAMC3( HALF, -C )
            B = DLAMC3( HALF, C )
            C = DLAMC3( HALF, -B )
            B = DLAMC3( HALF, C )
            GO TO 10
         END IF
C+       END WHILE
C
         IF( A.LT.LEPS )
     $      LEPS = A
C
C        Computation of EPS complete.
C
C        Now find  EMIN.  Let A = + or - 1, and + or - (1 + BASE**(-3)).
C        Keep dividing  A by BETA until (gradual) underflow occurs. This
C        is detected when we cannot recover the previous A.
C
         RBASE = ONE / LBETA
         SMALL = ONE
         DO 20 I = 1, 3
            SMALL = DLAMC3( SMALL*RBASE, ZERO )
   20    CONTINUE
         A = DLAMC3( ONE, SMALL )
         CALL DLAMC4( NGPMIN, ONE, LBETA )
         CALL DLAMC4( NGNMIN, -ONE, LBETA )
         CALL DLAMC4( GPMIN, A, LBETA )
         CALL DLAMC4( GNMIN, -A, LBETA )
         IEEE = .FALSE.
C
         IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN
            IF( NGPMIN.EQ.GPMIN ) THEN
               LEMIN = NGPMIN
C            ( Non twos-complement machines, no gradual underflow;
C              e.g.,  VAX )
            ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN
               LEMIN = NGPMIN - 1 + LT
               IEEE = .TRUE.
C            ( Non twos-complement machines, with gradual underflow;
C              e.g., IEEE standard followers )
            ELSE
               LEMIN = MIN( NGPMIN, GPMIN )
C            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
C
         ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN
            IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN
               LEMIN = MAX( NGPMIN, NGNMIN )
C            ( Twos-complement machines, no gradual underflow;
C              e.g., CYBER 205 )
            ELSE
               LEMIN = MIN( NGPMIN, NGNMIN )
C            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
C
         ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND.
     $            ( GPMIN.EQ.GNMIN ) ) THEN
            IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN
               LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT
C            ( Twos-complement machines with gradual underflow;
C              no known machine )
            ELSE
               LEMIN = MIN( NGPMIN, NGNMIN )
C            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
C
         ELSE
            LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN )
C         ( A guess; no known machine )
            IWARN = .TRUE.
         END IF
C**
C Comment out this if block if EMIN is ok
         IF( IWARN ) THEN
            FIRST = .TRUE.
            WRITE( 6, FMT = 9999 )LEMIN
         END IF
C**
C
C        Assume IEEE arithmetic if we found denormalised  numbers above,
C        or if arithmetic seems to round in the  IEEE style,  determined
C        in routine DLAMC1. A true IEEE machine should have both  things
C        true; however, faulty machines may have one or the other.
C
         IEEE = IEEE .OR. LIEEE1
C
C        Compute  RMIN by successive division by  BETA. We could compute
C        RMIN as BASE**( EMIN - 1 ),  but some machines underflow during
C        this computation.
C
         LRMIN = 1
         DO 30 I = 1, 1 - LEMIN
            LRMIN = DLAMC3( LRMIN*RBASE, ZERO )
   30    CONTINUE
C
C        Finally, call DLAMC5 to compute EMAX and RMAX.
C
         CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX )
      END IF
C
      BETA = LBETA
      T = LT
      RND = LRND
      EPS = LEPS
      EMIN = LEMIN
      RMIN = LRMIN
      EMAX = LEMAX
      RMAX = LRMAX
C
      RETURN
C
 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-',
     $      '  EMIN = ', I8, /
     $      ' If, after inspection, the value EMIN looks',
     $      ' acceptable please comment out ',
     $      / ' the IF block as marked within the code of routine',
     $      ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / )
C
C     End of DLAMC2
C
      END
C
C***********************************************************************
C
      DOUBLE PRECISION FUNCTION DLAMC3( A, B )
C
C  -- LAPACK auxiliary routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION   A, B
C     ..
C
C  Purpose
C  =======
C
C  DLAMC3  is intended to force  A  and  B  to be stored prior to doing
C  the addition of  A  and  B ,  for use in situations where optimizers
C  might hold one of these in a register.
C
C  Arguments
C  =========
C
C  A, B    (input) DOUBLE PRECISION
C          The values A and B.
C
C
C     .. Executable Statements ..
C
      DLAMC3 = A + B
C
      RETURN
C
C     End of DLAMC3
C
      END
C
C***********************************************************************
C
      SUBROUTINE DLAMC4( EMIN, START, BASE )
C
C  -- LAPACK auxiliary routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      INTEGER            BASE, EMIN
      DOUBLE PRECISION   START
C     ..
C
C  Purpose
C  =======
C
C  DLAMC4 is a service routine for DLAMC2.
C
C  Arguments
C  =========
C
C  EMIN    (output) EMIN
C          The minimum exponent before (gradual) underflow, computed by
C          setting A = START and dividing by BASE until the previous A
C          can not be recovered.
C
C  START   (input) DOUBLE PRECISION
C          The starting point for determining EMIN.
C
C  BASE    (input) INTEGER
C          The base of the machine.
C
C
C     .. Local Scalars ..
      INTEGER            I
      DOUBLE PRECISION   A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
C     ..
C     .. External Functions ..
      DOUBLE PRECISION   DLAMC3
      EXTERNAL           DLAMC3
C     ..
C     .. Executable Statements ..
C
      A = START
      ONE = 1
      RBASE = ONE / BASE
      ZERO = 0
      EMIN = 1
      B1 = DLAMC3( A*RBASE, ZERO )
      C1 = A
      C2 = A
      D1 = A
      D2 = A
C+    WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
C    $       ( D1.EQ.A ).AND.( D2.EQ.A )      )LOOP
   10 CONTINUE
      IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND.
     $    ( D2.EQ.A ) ) THEN
         EMIN = EMIN - 1
         A = B1
         B1 = DLAMC3( A / BASE, ZERO )
         C1 = DLAMC3( B1*BASE, ZERO )
         D1 = ZERO
         DO 20 I = 1, BASE
            D1 = D1 + B1
   20    CONTINUE
         B2 = DLAMC3( A*RBASE, ZERO )
         C2 = DLAMC3( B2 / RBASE, ZERO )
         D2 = ZERO
         DO 30 I = 1, BASE
            D2 = D2 + B2
   30    CONTINUE
         GO TO 10
      END IF
C+    END WHILE
C
      RETURN
C
C     End of DLAMC4
C
      END
C
C***********************************************************************
C
      SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
C
C  -- LAPACK auxiliary routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      LOGICAL            IEEE
      INTEGER            BETA, EMAX, EMIN, P
      DOUBLE PRECISION   RMAX
C     ..
C
C  Purpose
C  =======
C
C  DLAMC5 attempts to compute RMAX, the largest machine floating-point
C  number, without overflow.  It assumes that EMAX + abs(EMIN) sum
C  approximately to a power of 2.  It will fail on machines where this
C  assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
C  EMAX = 28718).  It will also fail if the value supplied for EMIN is
C  too large (i.e. too close to zero), probably with overflow.
C
C  Arguments
C  =========
C
C  BETA    (input) INTEGER
C          The base of floating-point arithmetic.
C
C  P       (input) INTEGER
C          The number of base BETA digits in the mantissa of a
C          floating-point value.
C
C  EMIN    (input) INTEGER
C          The minimum exponent before (gradual) underflow.
C
C  IEEE    (input) LOGICAL
C          A logical flag specifying whether or not the arithmetic
C          system is thought to comply with the IEEE standard.
C
C  EMAX    (output) INTEGER
C          The largest exponent before overflow
C
C  RMAX    (output) DOUBLE PRECISION
C          The largest machine floating-point number.
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
C     ..
C     .. Local Scalars ..
      INTEGER            EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
      DOUBLE PRECISION   OLDY, RECBAS, Y, Z
C     ..
C     .. External Functions ..
      DOUBLE PRECISION   DLAMC3
      EXTERNAL           DLAMC3
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MOD
C     ..
C     .. Executable Statements ..
C
C     First compute LEXP and UEXP, two powers of 2 that bound
C     abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
C     approximately to the bound that is closest to abs(EMIN).
C     (EMAX is the exponent of the required number RMAX).
C
      LEXP = 1
      EXBITS = 1
   10 CONTINUE
      TRY = LEXP*2
      IF( TRY.LE.( -EMIN ) ) THEN
         LEXP = TRY
         EXBITS = EXBITS + 1
         GO TO 10
      END IF
      IF( LEXP.EQ.-EMIN ) THEN
         UEXP = LEXP
      ELSE
         UEXP = TRY
         EXBITS = EXBITS + 1
      END IF
C
C     Now -LEXP is less than or equal to EMIN, and -UEXP is greater
C     than or equal to EMIN. EXBITS is the number of bits needed to
C     store the exponent.
C
      IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN
         EXPSUM = 2*LEXP
      ELSE
         EXPSUM = 2*UEXP
      END IF
C
C     EXPSUM is the exponent range, approximately equal to
C     EMAX - EMIN + 1 .
C
      EMAX = EXPSUM + EMIN - 1
      NBITS = 1 + EXBITS + P
C
C     NBITS is the total number of bits needed to store a
C     floating-point number.
C
      IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN
C
C        Either there are an odd number of bits used to store a
C        floating-point number, which is unlikely, or some bits are
C        not used in the representation of numbers, which is possible,
C        (e.g. Cray machines) or the mantissa has an implicit bit,
C        (e.g. IEEE machines, Dec Vax machines), which is perhaps the
C        most likely. We have to assume the last alternative.
C        If this is true, then we need to reduce EMAX by one because
C        there must be some way of representing zero in an implicit-bit
C        system. On machines like Cray, we are reducing EMAX by one
C        unnecessarily.
C
         EMAX = EMAX - 1
      END IF
C
      IF( IEEE ) THEN
C
C        Assume we are on an IEEE machine which reserves one exponent
C        for infinity and NaN.
C
         EMAX = EMAX - 1
      END IF
C
C     Now create RMAX, the largest machine number, which should
C     be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
C
C     First compute 1.0 - BETA**(-P), being careful that the
C     result is less than 1.0 .
C
      RECBAS = ONE / BETA
      Z = BETA - ONE
      Y = ZERO
      DO 20 I = 1, P
         Z = Z*RECBAS
         IF( Y.LT.ONE )
     $      OLDY = Y
         Y = DLAMC3( Y, Z )
   20 CONTINUE
      IF( Y.GE.ONE )
     $   Y = OLDY
C
C     Now multiply by BETA**EMAX to get RMAX.
C
      DO 30 I = 1, EMAX
         Y = DLAMC3( Y*BETA, ZERO )
   30 CONTINUE
C
      RMAX = Y
      RETURN
C
C     End of DLAMC5
C
      END
      DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK )
C
C  -- LAPACK auxiliary routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          NORM, UPLO
      INTEGER            N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  DLANSP  returns the value of the one norm,  or the Frobenius norm, or
C  the  infinity norm,  or the  element of  largest absolute value  of a
C  real symmetric matrix A,  supplied in packed form.
C
C  Description
C  ===========
C
C  DLANSP returns the value
C
C     DLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'
C              (
C              ( norm1(A),         NORM = '1', 'O' or 'o'
C              (
C              ( normI(A),         NORM = 'I' or 'i'
C              (
C              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
C
C  where  norm1  denotes the  one norm of a matrix (maximum column sum),
C  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
C  normF  denotes the  Frobenius norm of a matrix (square root of sum of
C  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
C
C  Arguments
C  =========
C
C  NORM    (input) CHARACTER*1
C          Specifies the value to be returned in DLANSP as described
C          above.
C
C  UPLO    (input) CHARACTER*1
C          Specifies whether the upper or lower triangular part of the
C          symmetric matrix A is supplied.
C          = 'U':  Upper triangular part of A is supplied
C          = 'L':  Lower triangular part of A is supplied
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.  When N = 0, DLANSP is
C          set to zero.
C
C  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
C          The upper or lower triangle of the symmetric matrix A, packed
C          columnwise in a linear array.  The j-th column of A is stored
C          in the array AP as follows:
C          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
C          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
C
C  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK),
C          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
C          WORK is not referenced.
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, J, K
      DOUBLE PRECISION   ABSA, SCALE, SUM, VALUE
C     ..
C     .. External Subroutines ..
      EXTERNAL           DLASSQ
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
C     ..
C     .. Executable Statements ..
C
      IF( N.EQ.0 ) THEN
         VALUE = ZERO
      ELSE IF( LSAME( NORM, 'M' ) ) THEN
C
C        Find max(abs(A(i,j))).
C
         VALUE = ZERO
         IF( LSAME( UPLO, 'U' ) ) THEN
            K = 1
            DO 20 J = 1, N
               DO 10 I = K, K + J - 1
                  VALUE = MAX( VALUE, ABS( AP( I ) ) )
   10          CONTINUE
               K = K + J
   20       CONTINUE
         ELSE
            K = 1
            DO 40 J = 1, N
               DO 30 I = K, K + N - J
                  VALUE = MAX( VALUE, ABS( AP( I ) ) )
   30          CONTINUE
               K = K + N - J + 1
   40       CONTINUE
         END IF
      ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
     $         ( NORM.EQ.'1' ) ) THEN
C
C        Find normI(A) ( = norm1(A), since A is symmetric).
C
         VALUE = ZERO
         K = 1
         IF( LSAME( UPLO, 'U' ) ) THEN
            DO 60 J = 1, N
               SUM = ZERO
               DO 50 I = 1, J - 1
                  ABSA = ABS( AP( K ) )
                  SUM = SUM + ABSA
                  WORK( I ) = WORK( I ) + ABSA
                  K = K + 1
   50          CONTINUE
               WORK( J ) = SUM + ABS( AP( K ) )
               K = K + 1
   60       CONTINUE
            DO 70 I = 1, N
               VALUE = MAX( VALUE, WORK( I ) )
   70       CONTINUE
         ELSE
            DO 80 I = 1, N
               WORK( I ) = ZERO
   80       CONTINUE
            DO 100 J = 1, N
               SUM = WORK( J ) + ABS( AP( K ) )
               K = K + 1
               DO 90 I = J + 1, N
                  ABSA = ABS( AP( K ) )
                  SUM = SUM + ABSA
                  WORK( I ) = WORK( I ) + ABSA
                  K = K + 1
   90          CONTINUE
               VALUE = MAX( VALUE, SUM )
  100       CONTINUE
         END IF
      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
C
C        Find normF(A).
C
         SCALE = ZERO
         SUM = ONE
         K = 2
         IF( LSAME( UPLO, 'U' ) ) THEN
            DO 110 J = 2, N
               CALL DLASSQ( J-1, AP( K ), 1, SCALE, SUM )
               K = K + J
  110       CONTINUE
         ELSE
            DO 120 J = 1, N - 1
               CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM )
               K = K + N - J + 1
  120       CONTINUE
         END IF
         SUM = 2*SUM
         K = 1
         DO 130 I = 1, N
            IF( AP( K ).NE.ZERO ) THEN
               ABSA = ABS( AP( K ) )
               IF( SCALE.LT.ABSA ) THEN
                  SUM = ONE + SUM*( SCALE / ABSA )**2
                  SCALE = ABSA
               ELSE
                  SUM = SUM + ( ABSA / SCALE )**2
               END IF
            END IF
            IF( LSAME( UPLO, 'U' ) ) THEN
               K = K + I + 1
            ELSE
               K = K + N - I + 1
            END IF
  130    CONTINUE
         VALUE = SCALE*SQRT( SUM )
      END IF
C
      DLANSP = VALUE
      RETURN
C
C     End of DLANSP
C
      END
      DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
C
C  -- LAPACK auxiliary routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION   X, Y
C     ..
C
C  Purpose
C  =======
C
C  DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
C  overflow.
C
C  Arguments
C  =========
C
C  X       (input) DOUBLE PRECISION
C  Y       (input) DOUBLE PRECISION
C          X and Y specify the values x and y.
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION   W, XABS, YABS, Z
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
C     ..
C     .. Executable Statements ..
C
      XABS = ABS( X )
      YABS = ABS( Y )
      W = MAX( XABS, YABS )
      Z = MIN( XABS, YABS )
      IF( Z.EQ.ZERO ) THEN
         DLAPY2 = W
      ELSE
         DLAPY2 = W*SQRT( ONE+( Z / W )**2 )
      END IF
      RETURN
C
C     End of DLAPY2
C
      END
C
      SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
C
C  -- LAPACK auxiliary routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          SIDE
      INTEGER            INCV, LDC, M, N
      DOUBLE PRECISION   TAU
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   C( LDC, * ), V( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  DLARF applies a real elementary reflector H to a real m by n matrix
C  C, from either the left or the right. H is represented in the form
C
C        H = I - tau * v * v'
C
C  where tau is a real scalar and v is a real vector.
C
C  If tau = 0, then H is taken to be the unit matrix.
C
C  Arguments
C  =========
C
C  SIDE    (input) CHARACTER*1
C          = 'L': form  H * C
C          = 'R': form  C * H
C
C  M       (input) INTEGER
C          The number of rows of the matrix C.
C
C  N       (input) INTEGER
C          The number of columns of the matrix C.
C
C  V       (input) DOUBLE PRECISION array, dimension
C                     (1 + (M-1)*abs(INCV)) if SIDE = 'L'
C                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
C          The vector v in the representation of H. V is not used if
C          TAU = 0.
C
C  INCV    (input) INTEGER
C          The increment between elements of v. INCV <> 0.
C
C  TAU     (input) DOUBLE PRECISION
C          The value tau in the representation of H.
C
C  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C          On entry, the m by n matrix C.
C          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
C          or C * H if SIDE = 'R'.
C
C  LDC     (input) INTEGER
C          The leading dimension of the array C. LDC >= max(1,M).
C
C  WORK    (workspace) DOUBLE PRECISION array, dimension
C                         (N) if SIDE = 'L'
C                      or (M) if SIDE = 'R'
C
C  =====================================================================
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGEMV, DGER
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     ..
C     .. Executable Statements ..
C
      IF( LSAME( SIDE, 'L' ) ) THEN
C
C        Form  H * C
C
         IF( TAU.NE.ZERO ) THEN
C
C           w := C' * v
C
            CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO,
     $                  WORK, 1 )
C
C           C := C - v * w'
C
            CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC )
         END IF
      ELSE
C
C        Form  C * H
C
         IF( TAU.NE.ZERO ) THEN
C
C           w := C * v
C
            CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV,
     $                  ZERO, WORK, 1 )
C
C           C := C - w * v'
C
            CALL DGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC )
         END IF
      END IF
      RETURN
C
C     End of DLARF
C
      END
      SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
C
C  -- LAPACK auxiliary routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      INTEGER            INCX, N
      DOUBLE PRECISION   ALPHA, TAU
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   X( * )
C     ..
C
C  Purpose
C  =======
C
C  DLARFG generates a real elementary reflector H of order n, such
C  that
C
C        H * ( alpha ) = ( beta ),   H' * H = I.
C            (   x   )   (   0  )
C
C  where alpha and beta are scalars, and x is an (n-1)-element real
C  vector. H is represented in the form
C
C        H = I - tau * ( 1 ) * ( 1 v' ) ,
C                      ( v )
C
C  where tau is a real scalar and v is a real (n-1)-element
C  vector.
C
C  If the elements of x are all zero, then tau = 0 and H is taken to be
C  the unit matrix.
C
C  Otherwise  1 <= tau <= 2.
C
C  Arguments
C  =========
C
C  N       (input) INTEGER
C          The order of the elementary reflector.
C
C  ALPHA   (input/output) DOUBLE PRECISION
C          On entry, the value alpha.
C          On exit, it is overwritten with the value beta.
C
C  X       (input/output) DOUBLE PRECISION array, dimension
C                         (1+(N-2)*abs(INCX))
C          On entry, the vector x.
C          On exit, it is overwritten with the vector v.
C
C  INCX    (input) INTEGER
C          The increment between elements of X. INCX <> 0.
C
C  TAU     (output) DOUBLE PRECISION
C          The value tau.
C
C  =====================================================================
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            J, KNT
      DOUBLE PRECISION   BETA, RSAFMN, SAFMIN, XNORM
C     ..
C     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLAPY2, DNRM2
      EXTERNAL           DLAMCH, DLAPY2, DNRM2
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, SIGN
C     ..
C     .. External Subroutines ..
      EXTERNAL           DSCAL
C     ..
C     .. Executable Statements ..
C
      IF( N.LE.1 ) THEN
         TAU = ZERO
         RETURN
      END IF
C
      XNORM = DNRM2( N-1, X, INCX )
C
      IF( XNORM.EQ.ZERO ) THEN
C
C        H  =  I
C
         TAU = ZERO
      ELSE
C
C        general case
C
         BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
         SAFMIN = DLAMCH( 'S' )
         IF( ABS( BETA ).LT.SAFMIN ) THEN
C
C           XNORM, BETA may be inaccurate; scale X and recompute them
C
            RSAFMN = ONE / SAFMIN
            KNT = 0
   10       CONTINUE
            KNT = KNT + 1
            CALL DSCAL( N-1, RSAFMN, X, INCX )
            BETA = BETA*RSAFMN
            ALPHA = ALPHA*RSAFMN
            IF( ABS( BETA ).LT.SAFMIN )
     $         GO TO 10
C
C           New BETA is at most 1, at least SAFMIN
C
            XNORM = DNRM2( N-1, X, INCX )
            BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
            TAU = ( BETA-ALPHA ) / BETA
            CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
C
C           If ALPHA is subnormal, it may lose relative accuracy
C
            ALPHA = BETA
            DO 20 J = 1, KNT
               ALPHA = ALPHA*SAFMIN
   20       CONTINUE
         ELSE
            TAU = ( BETA-ALPHA ) / BETA
            CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
            ALPHA = BETA
         END IF
      END IF
C
      RETURN
C
C     End of DLARFG
C
      END
      SUBROUTINE DLARTG( F, G, CS, SN, R )
C
C  -- LAPACK auxiliary routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION   CS, F, G, R, SN
C     ..
C
C  Purpose
C  =======
C
C  DLARTG generate a plane rotation so that
C
C     [  CS  SN  ]  .  [ F ]  =  [ R ]   where CS**2 + SN**2 = 1.
C     [ -SN  CS  ]     [ G ]     [ 0 ]
C
C  This is a faster version of the BLAS1 routine DROTG, except for
C  the following differences:
C     F and G are unchanged on return.
C     If G=0, then CS=1 and SN=0.
C     If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
C        floating point operations (saves work in DBDSQR when
C        there are zeros on the diagonal).
C
C  Arguments
C  =========
C
C  F       (input) DOUBLE PRECISION
C          The first component of vector to be rotated.
C
C  G       (input) DOUBLE PRECISION
C          The second component of vector to be rotated.
C
C  CS      (output) DOUBLE PRECISION
C          The cosine of the rotation.
C
C  SN      (output) DOUBLE PRECISION
C          The sine of the rotation.
C
C  R       (output) DOUBLE PRECISION
C          The nonzero component of the rotated vector.
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION   T, TT
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, SQRT
C     ..
C     .. Executable Statements ..
C
      IF( F.EQ.ZERO ) THEN
         IF( G.EQ.ZERO ) THEN
            CS = ONE
            SN = ZERO
            R = ZERO
         ELSE
            CS = ZERO
            SN = ONE
            R = G
         END IF
      ELSE
         IF( ABS( F ).GT.ABS( G ) ) THEN
            T = G / F
            TT = SQRT( ONE+T*T )
            CS = ONE / TT
            SN = T*CS
            R = F*TT
         ELSE
            T = F / G
            TT = SQRT( ONE+T*T )
            SN = ONE / TT
            CS = T*SN
            R = G*TT
         END IF
      END IF
      RETURN
C
C     End of DLARTG
C
      END
      SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
C
C  -- LAPACK auxiliary routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          DIRECT, PIVOT, SIDE
      INTEGER            LDA, M, N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( * ), S( * )
C     ..
C
C  Purpose
C  =======
C
C  DLASR   performs the transformation
C
C     A := P*A,   when SIDE = 'L' or 'l'  (  Left-hand side )
C
C     A := A*P',  when SIDE = 'R' or 'r'  ( Right-hand side )
C
C  where A is an m by n real matrix and P is an orthogonal matrix,
C  consisting of a sequence of plane rotations determined by the
C  parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l'
C  and z = n when SIDE = 'R' or 'r' ):
C
C  When  DIRECT = 'F' or 'f'  ( Forward sequence ) then
C
C     P = P( z - 1 )*...*P( 2 )*P( 1 ),
C
C  and when DIRECT = 'B' or 'b'  ( Backward sequence ) then
C
C     P = P( 1 )*P( 2 )*...*P( z - 1 ),
C
C  where  P( k ) is a plane rotation matrix for the following planes:
C
C     when  PIVOT = 'V' or 'v'  ( Variable pivot ),
C        the plane ( k, k + 1 )
C
C     when  PIVOT = 'T' or 't'  ( Top pivot ),
C        the plane ( 1, k + 1 )
C
C     when  PIVOT = 'B' or 'b'  ( Bottom pivot ),
C        the plane ( k, z )
C
C  c( k ) and s( k )  must contain the  cosine and sine that define the
C  matrix  P( k ).  The two by two plane rotation part of the matrix
C  P( k ), R( k ), is assumed to be of the form
C
C     R( k ) = (  c( k )  s( k ) ).
C              ( -s( k )  c( k ) )
C
C  This version vectorises across rows of the array A when SIDE = 'L'.
C
C  Arguments
C  =========
C
C  SIDE    (input) CHARACTER*1
C          Specifies whether the plane rotation matrix P is applied to
C          A on the left or the right.
C          = 'L':  Left, compute A := P*A
C          = 'R':  Right, compute A:= A*P'
C
C  DIRECT  (input) CHARACTER*1
C          Specifies whether P is a forward or backward sequence of
C          plane rotations.
C          = 'F':  Forward, P = P( z - 1 )*...*P( 2 )*P( 1 )
C          = 'B':  Backward, P = P( 1 )*P( 2 )*...*P( z - 1 )
C
C  PIVOT   (input) CHARACTER*1
C          Specifies the plane for which P(k) is a plane rotation
C          matrix.
C          = 'V':  Variable pivot, the plane (k,k+1)
C          = 'T':  Top pivot, the plane (1,k+1)
C          = 'B':  Bottom pivot, the plane (k,z)
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  If m <= 1, an immediate
C          return is effected.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  If n <= 1, an
C          immediate return is effected.
C
C  C, S    (input) DOUBLE PRECISION arrays, dimension
C                  (M-1) if SIDE = 'L'
C                  (N-1) if SIDE = 'R'
C          c(k) and s(k) contain the cosine and sine that define the
C          matrix P(k).  The two by two plane rotation part of the
C          matrix P(k), R(k), is assumed to be of the form
C          R( k ) = (  c( k )  s( k ) ).
C                   ( -s( k )  c( k ) )
C
C  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C          The m by n matrix A.  On exit, A is overwritten by P*A if
C          SIDE = 'R' or by A*P' if SIDE = 'L'.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, INFO, J
      DOUBLE PRECISION   CTEMP, STEMP, TEMP
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters
C
      INFO = 0
      IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN
         INFO = 1
      ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT,
     $         'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN
         INFO = 2
      ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) )
     $          THEN
         INFO = 3
      ELSE IF( M.LT.0 ) THEN
         INFO = 4
      ELSE IF( N.LT.0 ) THEN
         INFO = 5
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLASR ', INFO )
         RETURN
      END IF
C
C     Quick return if possible
C
      IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
     $   RETURN
      IF( LSAME( SIDE, 'L' ) ) THEN
C
C        Form  P * A
C
         IF( LSAME( PIVOT, 'V' ) ) THEN
            IF( LSAME( DIRECT, 'F' ) ) THEN
               DO 20 J = 1, M - 1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 10 I = 1, N
                        TEMP = A( J+1, I )
                        A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
                        A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
   10                CONTINUE
                  END IF
   20          CONTINUE
            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
               DO 40 J = M - 1, 1, -1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 30 I = 1, N
                        TEMP = A( J+1, I )
                        A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
                        A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
   30                CONTINUE
                  END IF
   40          CONTINUE
            END IF
         ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
            IF( LSAME( DIRECT, 'F' ) ) THEN
               DO 60 J = 2, M
                  CTEMP = C( J-1 )
                  STEMP = S( J-1 )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 50 I = 1, N
                        TEMP = A( J, I )
                        A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
                        A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
   50                CONTINUE
                  END IF
   60          CONTINUE
            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
               DO 80 J = M, 2, -1
                  CTEMP = C( J-1 )
                  STEMP = S( J-1 )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 70 I = 1, N
                        TEMP = A( J, I )
                        A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
                        A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
   70                CONTINUE
                  END IF
   80          CONTINUE
            END IF
         ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
            IF( LSAME( DIRECT, 'F' ) ) THEN
               DO 100 J = 1, M - 1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 90 I = 1, N
                        TEMP = A( J, I )
                        A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
                        A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
   90                CONTINUE
                  END IF
  100          CONTINUE
            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
               DO 120 J = M - 1, 1, -1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 110 I = 1, N
                        TEMP = A( J, I )
                        A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
                        A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
  110                CONTINUE
                  END IF
  120          CONTINUE
            END IF
         END IF
      ELSE IF( LSAME( SIDE, 'R' ) ) THEN
C
C        Form A * P'
C
         IF( LSAME( PIVOT, 'V' ) ) THEN
            IF( LSAME( DIRECT, 'F' ) ) THEN
               DO 140 J = 1, N - 1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 130 I = 1, M
                        TEMP = A( I, J+1 )
                        A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
                        A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
  130                CONTINUE
                  END IF
  140          CONTINUE
            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
               DO 160 J = N - 1, 1, -1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 150 I = 1, M
                        TEMP = A( I, J+1 )
                        A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
                        A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
  150                CONTINUE
                  END IF
  160          CONTINUE
            END IF
         ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
            IF( LSAME( DIRECT, 'F' ) ) THEN
               DO 180 J = 2, N
                  CTEMP = C( J-1 )
                  STEMP = S( J-1 )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 170 I = 1, M
                        TEMP = A( I, J )
                        A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
                        A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
  170                CONTINUE
                  END IF
  180          CONTINUE
            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
               DO 200 J = N, 2, -1
                  CTEMP = C( J-1 )
                  STEMP = S( J-1 )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 190 I = 1, M
                        TEMP = A( I, J )
                        A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
                        A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
  190                CONTINUE
                  END IF
  200          CONTINUE
            END IF
         ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
            IF( LSAME( DIRECT, 'F' ) ) THEN
               DO 220 J = 1, N - 1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 210 I = 1, M
                        TEMP = A( I, J )
                        A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
                        A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
  210                CONTINUE
                  END IF
  220          CONTINUE
            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
               DO 240 J = N - 1, 1, -1
                  CTEMP = C( J )
                  STEMP = S( J )
                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
                     DO 230 I = 1, M
                        TEMP = A( I, J )
                        A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
                        A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
  230                CONTINUE
                  END IF
  240          CONTINUE
            END IF
         END IF
      END IF
C
      RETURN
C
C     End of DLASR
C
      END
      SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )
C
C  -- LAPACK auxiliary routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      INTEGER            INCX, N
      DOUBLE PRECISION   SCALE, SUMSQ
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   X( * )
C     ..
C
C  Purpose
C  =======
C
C  DLASSQ  returns the values  scl  and  smsq  such that
C
C     ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
C
C  where  x( i ) = X( 1 + ( i - 1 )*INCX ). The value of  sumsq  is
C  assumed to be non-negative and  scl  returns the value
C
C     scl = max( scale, abs( x( i ) ) ).
C
C  scale and sumsq must be supplied in SCALE and SUMSQ and
C  scl and smsq are overwritten on SCALE and SUMSQ respectively.
C
C  The routine makes only one pass through the vector x.
C
C  Arguments
C  =========
C
C  N       (input) INTEGER
C          The number of elements to be used from the vector X.
C
C  X       (input) DOUBLE PRECISION
C          The vector for which a scaled sum of squares is computed.
C             x( i )  = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
C
C  INCX    (input) INTEGER
C          The increment between successive values of the vector X.
C          INCX > 0.
C
C  SCALE   (input/output) DOUBLE PRECISION
C          On entry, the value  scale  in the equation above.
C          On exit, SCALE is overwritten with  scl , the scaling factor
C          for the sum of squares.
C
C  SUMSQ   (input/output) DOUBLE PRECISION
C          On entry, the value  sumsq  in the equation above.
C          On exit, SUMSQ is overwritten with  smsq , the basic sum of
C          squares from which  scl  has been factored out.
C
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            IX
      DOUBLE PRECISION   ABSXI
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS
C     ..
C     .. Executable Statements ..
C
      IF( N.GT.0 ) THEN
         DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
            IF( X( IX ).NE.ZERO ) THEN
               ABSXI = ABS( X( IX ) )
               IF( SCALE.LT.ABSXI ) THEN
                  SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2
                  SCALE = ABSXI
               ELSE
                  SUMSQ = SUMSQ + ( ABSXI / SCALE )**2
               END IF
            END IF
   10    CONTINUE
      END IF
      RETURN
C
C     End of DLASSQ
C
      END
      SUBROUTINE DLAZRO( M, N, ALPHA, BETA, A, LDA )
C
C  -- LAPACK auxiliary routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      INTEGER            LDA, M, N
      DOUBLE PRECISION   ALPHA, BETA
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
C     ..
C
C  Purpose
C  =======
C
C  DLAZRO initializes a 2-D array A to BETA on the diagonal and
C  ALPHA on the offdiagonals.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  N >= 0.
C
C  ALPHA   (input) DOUBLE PRECISION
C          The constant to which the offdiagonal elements are to be set.
C
C  BETA    (input) DOUBLE PRECISION
C          The constant to which the diagonal elements are to be set.
C
C  A       (output) DOUBLE PRECISION array, dimension (LDA,N)
C          On exit, the leading m by n submatrix of A is set such that
C             A(i,j) = ALPHA,  1 <= i <= m, 1 <= j <= n, i <> j
C             A(i,i) = BETA,   1 <= i <= min(m,n).
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C     .. Local Scalars ..
      INTEGER            I, J
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MIN
C     ..
C     .. Executable Statements ..
C
      DO 20 J = 1, N
         DO 10 I = 1, M
            A( I, J ) = ALPHA
   10    CONTINUE
   20 CONTINUE
C
      DO 30 I = 1, MIN( M, N )
         A( I, I ) = BETA
   30 CONTINUE
C
      RETURN
C
C     End of DLAZRO
C
      END
      SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
C
C  -- LAPACK routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDQ, N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  DOPGTR generates a real orthogonal matrix Q which is defined as the
C  product of n-1 elementary reflectors of order n, as returned by
C  DSPTRD using packed storage:
C
C  if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
C
C  if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          Specifies the storage scheme used in the previous call of
C          DSPTRD:
C          = 'U': Upper triangular packed storage;
C          = 'L': Lower triangular packed storage.
C
C  N       (input) INTEGER
C          The order of the matrix Q. N >= 0.
C
C  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
C          The vectors which define the elementary reflectors, as
C          returned by DSPTRD.
C
C  TAU     (input) DOUBLE PRECISION array, dimension (N-1)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by DSPTRD.
C
C  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
C          The n by n orthogonal matrix Q.
C
C  LDQ     (input) INTEGER
C          The leading dimension of the array Q. LDQ >= max(1,N).
C
C  WORK    (workspace) DOUBLE PRECISION array, dimension (N-1)
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -i, the i-th argument had an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, IINFO, IJ, J
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DORG2L, DORG2R, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DOPGTR', -INFO )
         RETURN
      END IF
C
C     Quick return if possible
C
      IF( N.EQ.0 )
     $   RETURN
C
      IF( UPPER ) THEN
C
C        Q was determined by a call to DSPTRD with UPLO = 'U'
C
C        Unpack the vectors which define the elementary reflectors and
C        set the last row and column of Q equal to those of the unit
C        matrix
C
         IJ = 2
         DO 20 J = 1, N - 1
            DO 10 I = 1, J - 1
               Q( I, J ) = AP( IJ )
               IJ = IJ + 1
   10       CONTINUE
            IJ = IJ + 2
            Q( N, J ) = ZERO
   20    CONTINUE
         DO 30 I = 1, N - 1
            Q( I, N ) = ZERO
   30    CONTINUE
         Q( N, N ) = ONE
C
C        Generate Q(1:n-1,1:n-1)
C
         CALL DORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
C
      ELSE
C
C        Q was determined by a call to DSPTRD with UPLO = 'L'.
C
C        Unpack the vectors which define the elementary reflectors and
C        set the first row and column of Q equal to those of the unit
C        matrix
C
         Q( 1, 1 ) = ONE
         DO 40 I = 2, N
            Q( I, 1 ) = ZERO
   40    CONTINUE
         IJ = 3
         DO 60 J = 2, N
            Q( 1, J ) = ZERO
            DO 50 I = J + 1, N
               Q( I, J ) = AP( IJ )
               IJ = IJ + 1
   50       CONTINUE
            IJ = IJ + 2
   60    CONTINUE
         IF( N.GT.1 ) THEN
C
C           Generate Q(2:n,2:n)
C
            CALL DORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
     $                   IINFO )
         END IF
      END IF
      RETURN
C
C     End of DOPGTR
C
      END
      SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO )
C
C  -- LAPACK routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, M, N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  DORG2L generates an m by n real matrix Q with orthonormal columns,
C  which is defined as the last n columns of a product of k elementary
C  reflectors of order m
C
C        Q  =  H(k) . . . H(2) H(1)
C
C  as returned by DGEQLF.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix Q. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix Q. M >= N >= 0.
C
C  K       (input) INTEGER
C          The number of elementary reflectors whose product defines the
C          matrix Q. N >= K >= 0.
C
C  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C          On entry, the (n-k+i)-th column must contain the vector which
C          defines the elementary reflector H(i), for i = 1,2,...,k, as
C          returned by DGEQLF in the last k columns of its array
C          argument A.
C          On exit, the m by n matrix Q.
C
C  LDA     (input) INTEGER
C          The first dimension of the array A. LDA >= max(1,M).
C
C  TAU     (input) DOUBLE PRECISION array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by DGEQLF.
C
C  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -i, the i-th argument has an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, II, J, L
C     ..
C     .. External Subroutines ..
      EXTERNAL           DLARF, DSCAL, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
         INFO = -2
      ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORG2L', -INFO )
         RETURN
      END IF
C
C     Quick return if possible
C
      IF( N.LE.0 )
     $   RETURN
C
C     Initialise columns 1:n-k to columns of the unit matrix
C
      DO 20 J = 1, N - K
         DO 10 L = 1, M
            A( L, J ) = ZERO
   10    CONTINUE
         A( M-N+J, J ) = ONE
   20 CONTINUE
C
      DO 40 I = 1, K
         II = N - K + I
C
C        Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
C
         A( M-N+II, II ) = ONE
         CALL DLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
     $               LDA, WORK )
         CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
         A( M-N+II, II ) = ONE - TAU( I )
C
C        Set A(m-k+i+1:m,n-k+i) to zero
C
         DO 30 L = M - N + II + 1, M
            A( L, II ) = ZERO
   30    CONTINUE
   40 CONTINUE
      RETURN
C
C     End of DORG2L
C
      END
      SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
C
C  -- LAPACK routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      INTEGER            INFO, K, LDA, M, N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
C     ..
C
C  Purpose
C  =======
C
C  DORG2R generates an m by n real matrix Q with orthonormal columns,
C  which is defined as the first n columns of a product of k elementary
C  reflectors of order m
C
C        Q  =  H(1) H(2) . . . H(k)
C
C  as returned by DGEQRF.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix Q. M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix Q. M >= N >= 0.
C
C  K       (input) INTEGER
C          The number of elementary reflectors whose product defines the
C          matrix Q. N >= K >= 0.
C
C  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C          On entry, the i-th column must contain the vector which
C          defines the elementary reflector H(i), for i = 1,2,...,k, as
C          returned by DGEQRF in the first k columns of its array
C          argument A.
C          On exit, the m-by-n matrix Q.
C
C  LDA     (input) INTEGER
C          The first dimension of the array A. LDA >= max(1,M).
C
C  TAU     (input) DOUBLE PRECISION array, dimension (K)
C          TAU(i) must contain the scalar factor of the elementary
C          reflector H(i), as returned by DGEQRF.
C
C  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -i, the i-th argument has an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, J, L
C     ..
C     .. External Subroutines ..
      EXTERNAL           DLARF, DSCAL, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     ..
C     .. Executable Statements ..
C
C     Test the input arguments
C
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
         INFO = -2
      ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DORG2R', -INFO )
         RETURN
      END IF
C
C     Quick return if possible
C
      IF( N.LE.0 )
     $   RETURN
C
C     Initialise columns k+1:n to columns of the unit matrix
C
      DO 20 J = K + 1, N
         DO 10 L = 1, M
            A( L, J ) = ZERO
   10    CONTINUE
         A( J, J ) = ONE
   20 CONTINUE
C
      DO 40 I = K, 1, -1
C
C        Apply H(i) to A(i:m,i:n) from the left
C
         IF( I.LT.N ) THEN
            A( I, I ) = ONE
            CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
     $                  A( I, I+1 ), LDA, WORK )
         END IF
         IF( I.LT.M )
     $      CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )
         A( I, I ) = ONE - TAU( I )
C
C        Set A(1:i-1,i) to zero
C
         DO 30 L = 1, I - 1
            A( L, I ) = ZERO
   30    CONTINUE
   40 CONTINUE
      RETURN
C
C     End of DORG2R
C
      END
      SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )
C
C  -- LAPACK driver routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          JOBZ, UPLO
      INTEGER            INFO, LDZ, N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), W( * ), WORK( * ), Z( LDZ, * )
C     ..
C
C  Purpose
C  =======
C
C  DSPEV  computes all eigenvalues and, optionally, eigenvectors of a
C  real symmetric matrix A in packed storage by calling the recommended
C  sequence of LAPACK routines.
C
C  Arguments
C  =========
C
C  JOBZ    (input) CHARACTER*1
C          Specifies whether or not to compute the eigenvectors:
C          = 'N':  Compute eigenvalues only.
C          = 'V':  Compute eigenvalues and eigenvectors.
C
C  UPLO    (input) CHARACTER*1
C          Specifies whether the upper or lower triangular part of the
C          symmetric matrix A is stored:
C          = 'U':  Upper triangular
C          = 'L':  Lower triangular
C
C  N       (input) INTEGER
C          The number of rows and columns of the matrix A.  N >= 0.
C
C  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
C          On entry, the upper or lower triangle of the symmetric matrix
C          A, packed columnwise in a linear array.  The j-th column of A
C          is stored in the array AP as follows:
C          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
C          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
C
C          On exit, AP is overwritten by values generated during the
C          reduction to tridiagonal form.  If UPLO = 'U', the diagonal
C          and first superdiagonal of the tridiagonal matrix T overwrite
C          the corresponding elements of A, and if UPLO = 'L', the
C          diagonal and first subdiagonal of T overwrite the
C          corresponding elements of A.
C
C  W       (output) DOUBLE PRECISION array, dimension (N)
C          On exit, if INFO = 0, W contains the eigenvalues in ascending
C          order.  If INFO > 0, the eigenvalues are correct for indices
C          1, 2, ..., INFO-1, but they are unordered and may not be the
C          smallest eigenvalues of the matrix.
C
C  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)
C          If JOBZ = 'V', then if INFO = 0 on exit, Z contains the
C          orthonormal eigenvectors of the matrix A.  If INFO > 0, Z
C          contains the eigenvectors associated with only the stored
C          eigenvalues.
C          If JOBZ = 'N', then Z is not referenced.
C
C  LDZ     (input) INTEGER
C          The leading dimension of the array Z.  LDZ >= 1, and if
C          JOBZ = 'V', LDZ >= max(1,N).
C
C  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
C
C  INFO    (output) INTEGER
C          = 0:  successful exit.
C          < 0:  if INFO = -i, the i-th argument had an illegal value.
C          > 0:  if INFO = +i, the algorithm terminated before finding
C                the i-th eigenvalue.
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            WANTZ
      INTEGER            IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE
      DOUBLE PRECISION   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
     $                   SMLNUM
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANSP
      EXTERNAL           LSAME, DLAMCH, DLANSP
C     ..
C     .. External Subroutines ..
      EXTERNAL           DOPGTR, DSCAL, DSPTRD, DSTEQR, DSTERF, XERBLA
C     ..
C     .. Intrinsic Functions ..
       INTRINSIC          SQRT
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      WANTZ = LSAME( JOBZ, 'V' )
C
      INFO = 0
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) )
     $          THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
         INFO = -7
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSPEV ', -INFO )
         RETURN
      END IF
C
C     Quick return if possible
C
      IF( N.EQ.0 )
     $   RETURN
C
      IF( N.EQ.1 ) THEN
         W( 1 ) = AP( 1 )
         IF( WANTZ )
     $      Z( 1, 1 ) = ONE
         RETURN
      END IF
C
C     Get machine constants.
C
 
      SAFMIN = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Precision' )
      SMLNUM = SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = SQRT( BIGNUM )
C
C     Scale matrix to allowable range, if necessary.
C
      ANRM = DLANSP( 'M', UPLO, N, AP, WORK )
      ISCALE = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
         ISCALE = 1
         SIGMA = RMIN / ANRM
      ELSE IF( ANRM.GT.RMAX ) THEN
         ISCALE = 1
         SIGMA = RMAX / ANRM
      END IF
      IF( ISCALE.EQ.1 ) THEN
         CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
      END IF
C
C     Call DSPTRD to reduce symmetric packed matrix to tridiagonal form.
C
      INDE = 1
      INDTAU = INDE + N
      CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO )
C
C     For eigenvalues only, call DSTERF.  For eigenvectors, first call
C     DOPGTR to generate the orthogonal matrix, then call DSTEQR.
C
      IF( .NOT.WANTZ ) THEN
         CALL DSTERF( N, W, WORK( INDE ), INFO )
      ELSE
         INDWRK = INDTAU + N
         CALL DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
     $                WORK( INDWRK ), IINFO )
         CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDTAU ),
     $                INFO )
      END IF
C
C     If matrix was scaled, then rescale eigenvalues appropriately.
C
      IF( ISCALE.EQ.1 ) THEN
         IF( INFO.EQ.0 ) THEN
            IMAX = N
         ELSE
            IMAX = INFO - 1
         END IF
         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
      END IF
C
      RETURN
C
C     End of DSPEV
C
      END
      SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO )
C
C  -- LAPACK routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   AP( * ), D( * ), E( * ), TAU( * )
C     ..
C
C  Purpose
C  =======
C
C  DSPTRD reduces a real symmetric matrix A stored in packed form to
C  symmetric tridiagonal form T by an orthogonal similarity
C  transformation: Q' * A * Q = T.
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          Specifies whether the upper or lower triangular part of the
C          symmetric matrix A is stored:
C          = 'U':  Upper triangular
C          = 'L':  Lower triangular
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.
C
C  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
C          On entry, the upper or lower triangle of the symmetric matrix
C          A, packed columnwise in a linear array.  The j-th column of A
C          is stored in the array AP as follows:
C          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
C          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
C          On exit, if UPLO = 'U', the diagonal and first superdiagonal
C          of A are overwritten by the corresponding elements of the
C          tridiagonal matrix T, and the elements above the first
C          superdiagonal, with the array TAU, represent the orthogonal
C          matrix Q as a product of elementary reflectors; if UPLO
C          = 'L', the diagonal and first subdiagonal of A are over-
C          written by the corresponding elements of the tridiagonal
C          matrix T, and the elements below the first subdiagonal, with
C          the array TAU, represent the orthogonal matrix Q as a product
C          of elementary reflectors. See Further Details.
C
C  D       (output) DOUBLE PRECISION array, dimension (N)
C          The diagonal elements of the tridiagonal matrix T:
C          D(i) = A(i,i).
C
C  E       (output) DOUBLE PRECISION array, dimension (N-1)
C          The off-diagonal elements of the tridiagonal matrix T:
C          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
C
C  TAU     (output) DOUBLE PRECISION array, dimension (N)
C          The scalar factors of the elementary reflectors (see Further
C          Details).
C
C  INFO    (output) INTEGER
C          = 0:  successful exit.
C          < 0:  if INFO = -i, the i-th argument had an illegal value.
C
C  Further Details
C  ===============
C
C  If UPLO = 'U', the matrix Q is represented as a product of elementary
C  reflectors
C
C     Q = H(n-1) . . . H(2) H(1).
C
C  Each H(i) has the form
C
C     H(i) = I - tau * v * v'
C
C  where tau is a real scalar, and v is a real vector with
C  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
C  overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
C
C  If UPLO = 'L', the matrix Q is represented as a product of elementary
C  reflectors
C
C     Q = H(1) H(2) . . . H(n-1).
C
C  Each H(i) has the form
C
C     H(i) = I - tau * v * v'
C
C  where tau is a real scalar, and v is a real vector with
C  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
C  overwriting A(i+2:n,i), and tau is stored in TAU(i).
C
C  =====================================================================
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO, HALF
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0,
     $                   HALF = 1.0D0 / 2.0D0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, I1, I1I1, II
      DOUBLE PRECISION   ALPHA, TAUI
C     ..
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DLARFG, DSPMV, DSPR2, XERBLA
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT
      EXTERNAL           LSAME, DDOT
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters
C
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSPTRD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible
C
      IF( N.LE.0 )
     $   RETURN
C
      IF( UPPER ) THEN
C
C        Reduce the upper triangle of A.
C        I1 is the index in AP of A(1,I+1).
C
         I1 = N*( N-1 ) / 2 + 1
         DO 10 I = N - 1, 1, -1
C
C           Generate elementary reflector H(i) = I - tau * v * v'
C           to annihilate A(1:i-1,i+1)
C
            CALL DLARFG( I, AP( I1+I-1 ), AP( I1 ), 1, TAUI )
            E( I ) = AP( I1+I-1 )
C
            IF( TAUI.NE.ZERO ) THEN
C
C              Apply H(i) from both sides to A(1:i,1:i)
C
               AP( I1+I-1 ) = ONE
C
C              Compute  y := tau * A * v  storing y in TAU(1:i)
C
               CALL DSPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU,
     $                     1 )
C
C              Compute  w := y - 1/2 * tau * (y'*v) * v
C
               ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, AP( I1 ), 1 )
               CALL DAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 )
C
C              Apply the transformation as a rank-2 update:
C                 A := A - v * w' - w * v'
C
               CALL DSPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP )
C
               AP( I1+I-1 ) = E( I )
            END IF
            D( I+1 ) = AP( I1+I )
            TAU( I ) = TAUI
            I1 = I1 - I
   10    CONTINUE
         D( 1 ) = AP( 1 )
      ELSE
C
C        Reduce the lower triangle of A. II is the index in AP of
C        A(i,i) and I1I1 is the index of A(i+1,i+1).
C
         II = 1
         DO 20 I = 1, N - 1
            I1I1 = II + N - I + 1
C
C           Generate elementary reflector H(i) = I - tau * v * v'
C           to annihilate A(i+2:n,i)
C
            CALL DLARFG( N-I, AP( II+1 ), AP( II+2 ), 1, TAUI )
            E( I ) = AP( II+1 )
C
            IF( TAUI.NE.ZERO ) THEN
C
C              Apply H(i) from both sides to A(i+1:n,i+1:n)
C
               AP( II+1 ) = ONE
C
C              Compute  y := tau * A * v  storing y in TAU(i+1:n)
C
               CALL DSPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1,
     $                     ZERO, TAU( I+1 ), 1 )
C
C              Compute  w := y - 1/2 * tau * (y'*v) * v
C
               ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I+1 ), 1, AP( II+1 ),
     $                 1 )
               CALL DAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I+1 ), 1 )
C
C              Apply the transformation as a rank-2 update:
C                 A := A - v * w' - w * v'
C
               CALL DSPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I+1 ),
     $                     1, AP( I1I1 ) )
C
               AP( II+1 ) = E( I )
            END IF
            D( I ) = AP( II )
            TAU( I ) = TAUI
            II = I1I1
   20    CONTINUE
         D( N ) = AP( II )
      END IF
      TAU( N ) = ZERO
C
      RETURN
C
C     End of DSPTRD
C
      END
      SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
C
C  -- LAPACK routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          COMPZ
      INTEGER            INFO, LDZ, N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), E( * ), WORK( * ), Z( LDZ, * )
C     ..
C
C  Purpose
C  =======
C
C  DSTEQR computes all eigenvalues and, optionally, eigenvectors of a
C  symmetric tridiagonal matrix using the implicit QL or QR method.
C  The eigenvectors of a full or band symmetric matrix can also be found
C  if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to
C  tridiagonal form.
C
C  Arguments
C  =========
C
C  COMPZ   (input) CHARACTER*1
C          Specifies whether eigenvectors are to be computed
C          as follows
C
C             COMPZ = 'N' or 'n'     Compute eigenvalues only.
C
C             COMPZ = 'V' or 'v'     Compute eigenvectors of original
C                                    symmetric matrix also.
C                                    Array Z contains the orthogonal
C                                    matrix used to reduce the original
C                                    matrix to tridiagonal form.
C
C             COMPZ = 'I' or 'i'     Compute eigenvectors of
C                                    tridiagonal matrix also.
C
C  N       (input) INTEGER
C          The number of rows and columns in the matrix.  N >= 0.
C
C  D       (input/output) DOUBLE PRECISION array, dimension (N)
C          On entry, D contains the diagonal elements of the
C          tridiagonal matrix.
C          On exit, D contains the eigenvalues, in ascending order.
C          If an error exit is made, the eigenvalues are correct
C          for indices 1,2,...,INFO-1, but they are unordered and
C          may not be the smallest eigenvalues of the matrix.
C
C  E       (input/output) DOUBLE PRECISION array, dimension (N)
C          On entry, E contains the subdiagonal elements of the
C          tridiagonal matrix in positions 1 through N-1.
C          E(N) is arbitrary.
C          On exit, E has been destroyed.
C
C  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
C          If  COMPZ = 'V' or 'v', then:
C          On entry, Z contains the orthogonal matrix used in the
C          reduction to tridiagonal form.
C          If  COMPZ = 'V' or 'v' or 'I' or 'i', then:
C          On exit, Z contains the orthonormal eigenvectors of the
C          symmetric tridiagonal (or full) matrix.  If an error exit
C          is made, Z contains the eigenvectors associated with the
C          stored eigenvalues.
C
C          If  COMPZ = 'N' or 'n', then Z is not referenced.
C
C  LDZ     (input) INTEGER
C          The leading dimension of the array Z.  If eigenvectors are
C          desired, then  LDZ >= max( 1, N ).  In any case,  LDZ >= 1.
C
C  WORK    (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
C          Workspace used in computing eigenvectors.
C          If  COMPZ = 'N' or 'n', then WORK is not referenced.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit.
C          < 0:  if INFO = -i, the i-th argument had an illegal value.
C          > 0:  if INFO = +i, the i-th eigenvalue has not converged
C                              after a total of  30*N  iterations.
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
      INTEGER            MAXIT
      PARAMETER          ( MAXIT = 30 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, ICOMPZ, II, J, JTOT, K, L, L1, LEND, LENDM1,
     $                   LENDP1, LM1, M, MM, MM1, NCONV, NM1, NMAXIT
      DOUBLE PRECISION   B, C, EPS, F, G, P, R, RT1, RT2, S, TST
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLAPY2
      EXTERNAL           LSAME, DLAMCH, DLAPY2
C     ..
C     .. External Subroutines ..
      EXTERNAL           DLAE2, DLAEV2, DLARTG, DLASR, DLAZRO, DSWAP,
     $                   XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SIGN
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
C
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ICOMPZ = 0
      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
         ICOMPZ = 1
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ICOMPZ = 2
      ELSE
         ICOMPZ = -1
      END IF
      IF( ICOMPZ.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
     $         N ) ) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSTEQR', -INFO )
         RETURN
      END IF
C
C     Quick return if possible
C
      IF( N.EQ.0 )
     $   RETURN
C
      IF( N.EQ.1 ) THEN
         IF( ICOMPZ.GT.0 )
     $      Z( 1, 1 ) = ONE
         RETURN
      END IF
C
C     Determine the unit roundoff for this environment.
C
      EPS = DLAMCH( 'E' )
C
C     Compute the eigenvalues and eigenvectors of the tridiagonal
C     matrix.
C
      IF( ICOMPZ.EQ.2 )
     $   CALL DLAZRO( N, N, ZERO, ONE, Z, LDZ )
C
      E( N ) = ZERO
      NMAXIT = N*MAXIT
      JTOT = 0
      NCONV = 0
C
C     Determine where the matrix splits and choose QL or QR iteration
C     for each block, according to whether top or bottom diagonal
C     element is smaller.
C
      L1 = 1
      NM1 = N - 1
C
   10 CONTINUE
      IF( L1.GT.N )
     $   GO TO 150
      IF( L1.LE.NM1 ) THEN
         DO 20 M = L1, NM1
            TST = ABS( E( M ) )
            IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) )
     $         GO TO 30
   20    CONTINUE
      END IF
      M = N
C
   30 CONTINUE
      L = L1
      LEND = M
      IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
         L = LEND
         LEND = L1
      END IF
      L1 = M + 1
C
      IF( LEND.GE.L ) THEN
C
C        QL Iteration
C
C        Look for small subdiagonal element.
C
   40    CONTINUE
         IF( L.NE.LEND ) THEN
            LENDM1 = LEND - 1
            DO 50 M = L, LENDM1
               TST = ABS( E( M ) )
               IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) )
     $            GO TO 60
   50       CONTINUE
         END IF
C
         M = LEND
C
   60    CONTINUE
         P = D( L )
         IF( M.EQ.L )
     $      GO TO 80
C
C        If remaining matrix is 2 by 2, use DLAE2 or DLAEV2
C        to compute its eigensystem.
C
         IF( M.EQ.L+1 ) THEN
            IF( ICOMPZ.GT.0 ) THEN
               CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
               WORK( L ) = C
               WORK( N-1+L ) = S
               CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ),
     $                     WORK( N-1+L ), Z( 1, L ), LDZ )
            ELSE
               CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
            END IF
            D( L ) = RT1
            D( L+1 ) = RT2
            NCONV = NCONV + 2
            L = L + 2
            IF( L.LE.LEND )
     $         GO TO 40
            GO TO 10
         END IF
C
         IF( JTOT.EQ.NMAXIT )
     $      GO TO 140
         JTOT = JTOT + 1
C
C        Form shift.
C
         G = ( D( L+1 )-P ) / ( TWO*E( L ) )
         R = DLAPY2( G, ONE )
         G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
C
         S = ONE
         C = ONE
         P = ZERO
C
C        Inner loop
C
         MM1 = M - 1
         DO 70 I = MM1, L, -1
            F = S*E( I )
            B = C*E( I )
            CALL DLARTG( G, F, C, S, R )
            E( I+1 ) = R
            G = D( I+1 ) - P
            R = ( D( I )-G )*S + TWO*C*B
            P = S*R
            D( I+1 ) = G + P
            G = C*R - B
C
C           If eigenvectors are desired, then save rotations.
C
            IF( ICOMPZ.GT.0 ) THEN
               WORK( I ) = C
               WORK( N-1+I ) = -S
            END IF
C
   70    CONTINUE
C
C        If eigenvectors are desired, then apply saved rotations.
C
         IF( ICOMPZ.GT.0 ) THEN
            MM = M - L + 1
            CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),
     $                  Z( 1, L ), LDZ )
         END IF
C
         D( L ) = D( L ) - P
         E( L ) = G
         E( M ) = ZERO
         GO TO 40
C
C        Eigenvalue found.
C
   80    CONTINUE
         D( L ) = P
         NCONV = NCONV + 1
C
         L = L + 1
         IF( L.LE.LEND )
     $      GO TO 40
         GO TO 10
C
      ELSE
C
C        QR Iteration
C
C        Look for small superdiagonal element.
C
   90    CONTINUE
         IF( L.NE.LEND ) THEN
            LENDP1 = LEND + 1
            DO 100 M = L, LENDP1, -1
               TST = ABS( E( M-1 ) )
               IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M-1 ) ) ) )
     $            GO TO 110
  100       CONTINUE
         END IF
C
         M = LEND
C
  110    CONTINUE
         P = D( L )
         IF( M.EQ.L )
     $      GO TO 130
C
C        If remaining matrix is 2 by 2, use DLAE2 or DLAEV2
C        to compute its eigensystem.
C
         IF( M.EQ.L-1 ) THEN
            IF( ICOMPZ.GT.0 ) THEN
               CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
               WORK( M ) = C
               WORK( N-1+M ) = S
               CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ),
     $                     WORK( N-1+M ), Z( 1, L-1 ), LDZ )
            ELSE
               CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
            END IF
            D( L-1 ) = RT1
            D( L ) = RT2
            NCONV = NCONV + 2
            L = L - 2
            IF( L.GE.LEND )
     $         GO TO 90
            GO TO 10
         END IF
C
         IF( JTOT.EQ.NMAXIT )
     $      GO TO 140
         JTOT = JTOT + 1
C
C        Form shift.
C
         G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
         R = DLAPY2( G, ONE )
         G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
C
         S = ONE
         C = ONE
         P = ZERO
C
C        Inner loop
C
         LM1 = L - 1
         DO 120 I = M, LM1
            F = S*E( I )
            B = C*E( I )
            CALL DLARTG( G, F, C, S, R )
            IF( I.NE.1 )
     $         E( I-1 ) = R
            G = D( I ) - P
            R = ( D( I+1 )-G )*S + TWO*C*B
            P = S*R
            D( I ) = G + P
            G = C*R - B
C
C           If eigenvectors are desired, then save rotations.
C
            IF( ICOMPZ.GT.0 ) THEN
               WORK( I ) = C
               WORK( N-1+I ) = S
            END IF
C
  120    CONTINUE
C
C        If eigenvectors are desired, then apply saved rotations.
C
         IF( ICOMPZ.GT.0 ) THEN
            MM = L - M + 1
            CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),
     $                  Z( 1, M ), LDZ )
         END IF
C
         D( L ) = D( L ) - P
         E( LM1 ) = G
         IF( M.NE.1 )
     $      E( M-1 ) = ZERO
         GO TO 90
C
C        Eigenvalue found.
C
  130    CONTINUE
         D( L ) = P
         NCONV = NCONV + 1
C
         L = L - 1
         IF( L.GE.LEND )
     $      GO TO 90
         GO TO 10
C
      END IF
C
C     Set error -- no convergence to an eigenvalue after a total
C     of N*MAXIT iterations.
C
  140 CONTINUE
      INFO = NCONV
      RETURN
C
C     Order eigenvalues and eigenvectors.
C
  150 CONTINUE
      DO 170 II = 2, N
         I = II - 1
         K = I
         P = D( I )
         DO 160 J = II, N
            IF( D( J ).LT.P ) THEN
               K = J
               P = D( J )
            END IF
  160    CONTINUE
         IF( K.NE.I ) THEN
            D( K ) = D( I )
            D( I ) = P
            IF( ICOMPZ.GT.0 )
     $         CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
         END IF
  170 CONTINUE
C
      RETURN
C
C     End of DSTEQR
C
      END
      SUBROUTINE DSTERF( N, D, E, INFO )
C
C  -- LAPACK routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      INTEGER            INFO, N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), E( * )
C     ..
C
C  Purpose
C  =======
C
C  DSTERF computes all eigenvalues of a symmetric tridiagonal matrix
C  using the Pal-Walker-Kahan variant of the QL or QR algorithm.
C
C  Arguments
C  =========
C
C  N       (input) INTEGER
C          The number of rows and columns in the matrix.  N >= 0.
C
C  D       (input/output) DOUBLE PRECISION array, dimension (N)
C          On entry, D contains the diagonal elements of the
C          tridiagonal matrix.
C          On exit, D contains the eigenvalues in ascending order.
C          If an error exit is made, the eigenvalues are correct
C          but unordered for indices 1,2,...,INFO-1.
C
C  E       (input/output) DOUBLE PRECISION array, dimension (N)
C          On entry, E contains the subdiagonal elements of the
C          tridiagonal matrix in positions 1 through N-1.
C          E(N) is arbitrary.
C          On exit, E has been destroyed.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit.
C          < 0:  if INFO = -i, the i-th argument had an illegal value.
C          > 0:  if INFO = +i, the i-th eigenvalue has not converged
C                after a total of  30*N  iterations.
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
      INTEGER            MAXIT
      PARAMETER          ( MAXIT = 30 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, II, J, JTOT, K, L, L1, LEND, LENDM1, LENDP1,
     $                   LM1, M, MM1, NCONV, NM1, NMAXIT
      DOUBLE PRECISION   ALPHA, BB, C, EPS, GAMMA, OLDC, OLDGAM, P, R,
     $                   RT1, RT2, RTE, S, SIGMA, TST
C     ..
C     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLAPY2
      EXTERNAL           DLAMCH, DLAPY2
C     ..
C     .. External Subroutines ..
      EXTERNAL           DLAE2, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, SIGN, SQRT
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
C
C     Quick return if possible
C
      IF( N.LT.0 ) THEN
         INFO = -1
         CALL XERBLA( 'DSTERF', -INFO )
         RETURN
      END IF
      IF( N.LE.1 )
     $   RETURN
C
C     Determine the unit roundoff for this environment.
C
      EPS = DLAMCH( 'E' )
C
C     Compute the eigenvalues of the tridiagonal matrix.
C
      DO 10 I = 1, N - 1
         E( I ) = E( I )**2
   10 CONTINUE
      E( N ) = ZERO
C
      NMAXIT = N*MAXIT
      SIGMA = ZERO
      JTOT = 0
      NCONV = 0
C
C     Determine where the matrix splits and choose QL or QR iteration
C     for each block, according to whether top or bottom diagonal
C     element is smaller.
C
      L1 = 1
      NM1 = N - 1
C
   20 CONTINUE
      IF( L1.GT.N )
     $   GO TO 160
      IF( L1.LE.NM1 ) THEN
         DO 30 M = L1, NM1
            TST = SQRT( ABS( E( M ) ) )
            IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) )
     $         GO TO 40
   30    CONTINUE
      END IF
      M = N
C
   40 CONTINUE
      L = L1
      LEND = M
      IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
         L = LEND
         LEND = L1
      END IF
      L1 = M + 1
C
      IF( LEND.GE.L ) THEN
C
C        QL Iteration
C
C        Look for small subdiagonal element.
C
   50    CONTINUE
         IF( L.NE.LEND ) THEN
            LENDM1 = LEND - 1
            DO 60 M = L, LENDM1
               TST = SQRT( ABS( E( M ) ) )
               IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) )
     $            GO TO 70
   60       CONTINUE
         END IF
C
         M = LEND
C
   70    CONTINUE
         P = D( L )
         IF( M.EQ.L )
     $      GO TO 90
C
C        If remaining matrix is 2 by 2, use DLAE2 to compute its
C        eigenvalues.
C
         IF( M.EQ.L+1 ) THEN
            RTE = SQRT( E( L ) )
            CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 )
            D( L ) = RT1
            D( L+1 ) = RT2
            NCONV = NCONV + 2
            L = L + 2
            IF( L.LE.LEND )
     $         GO TO 50
            GO TO 20
         END IF
C
         IF( JTOT.EQ.NMAXIT )
     $      GO TO 150
         JTOT = JTOT + 1
C
C        Form shift.
C
         RTE = SQRT( E( L ) )
         SIGMA = ( D( L+1 )-P ) / ( TWO*RTE )
         R = DLAPY2( SIGMA, ONE )
         SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
C
         C = ONE
         S = ZERO
         GAMMA = D( M ) - SIGMA
         P = GAMMA*GAMMA
C
C        Inner loop
C
         MM1 = M - 1
         DO 80 I = MM1, L, -1
            BB = E( I )
            R = P + BB
            E( I+1 ) = S*R
            OLDC = C
            C = P / R
            S = BB / R
            OLDGAM = GAMMA
            ALPHA = D( I )
            GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
            D( I+1 ) = OLDGAM + ( ALPHA-GAMMA )
            IF( C.NE.ZERO ) THEN
               P = ( GAMMA*GAMMA ) / C
            ELSE
               P = OLDC*BB
            END IF
   80    CONTINUE
C
         E( L ) = S*P
         D( L ) = SIGMA + GAMMA
         E( M ) = ZERO
         GO TO 50
C
C        Eigenvalue found.
C
   90    CONTINUE
         D( L ) = P
         NCONV = NCONV + 1
C
         L = L + 1
         IF( L.LE.LEND )
     $      GO TO 50
         GO TO 20
C
      ELSE
C
C        QR Iteration
C
C        Look for small superdiagonal element.
C
  100    CONTINUE
         IF( L.NE.LEND ) THEN
            LENDP1 = LEND + 1
            DO 110 M = L, LENDP1, -1
               TST = SQRT( ABS( E( M-1 ) ) )
               IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M-1 ) ) ) )
     $            GO TO 120
  110       CONTINUE
         END IF
C
         M = LEND
C
  120    CONTINUE
         P = D( L )
         IF( M.EQ.L )
     $      GO TO 140
C
C        If remaining matrix is 2 by 2, use DLAE2 to compute its
C        eigenvalues.
C
         IF( M.EQ.L-1 ) THEN
            RTE = SQRT( E( L-1 ) )
            CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 )
            D( L ) = RT1
            D( L-1 ) = RT2
            NCONV = NCONV + 2
            L = L - 2
            IF( L.GE.LEND )
     $         GO TO 100
            GO TO 20
         END IF
C
         IF( JTOT.EQ.NMAXIT )
     $      GO TO 150
         JTOT = JTOT + 1
C
C        Form shift.
C
         RTE = SQRT( E( L-1 ) )
         SIGMA = ( D( L-1 )-P ) / ( TWO*RTE )
         R = DLAPY2( SIGMA, ONE )
         SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
C
         C = ONE
         S = ZERO
         GAMMA = D( M ) - SIGMA
         P = GAMMA*GAMMA
C
C        Inner loop
C
         LM1 = L - 1
         DO 130 I = M, LM1
            BB = E( I )
            R = P + BB
            IF( I.NE.1 )
     $         E( I-1 ) = S*R
            OLDC = C
            C = P / R
            S = BB / R
            OLDGAM = GAMMA
            ALPHA = D( I+1 )
            GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
            D( I ) = OLDGAM + ( ALPHA-GAMMA )
            IF( C.NE.ZERO ) THEN
               P = ( GAMMA*GAMMA ) / C
            ELSE
               P = OLDC*BB
            END IF
  130    CONTINUE
C
         E( LM1 ) = S*P
         D( L ) = SIGMA + GAMMA
         IF( M.NE.1 )
     $      E( M-1 ) = ZERO
         GO TO 100
C
C        Eigenvalue found.
C
  140    CONTINUE
         D( L ) = P
         NCONV = NCONV + 1
C
         L = L - 1
         IF( L.GE.LEND )
     $      GO TO 100
         GO TO 20
C
      END IF
C
C     Set error -- no convergence to an eigenvalue after a total
C     of N*MAXIT iterations.
C
  150 CONTINUE
      INFO = NCONV
      RETURN
C
C     Sort eigenvalues in increasing order.
C
  160 CONTINUE
      DO 180 II = 2, N
         I = II - 1
         K = I
         P = D( I )
         DO 170 J = II, N
            IF( D( J ).LT.P ) THEN
               K = J
               P = D( J )
            END IF
  170    CONTINUE
         IF( K.NE.I ) THEN
            D( K ) = D( I )
            D( I ) = P
         END IF
  180 CONTINUE
C
      RETURN
C
C     End of DSTERF
C
      END
      SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO )
C
C  -- LAPACK routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     March 18, 1992
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
C     ..
C     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
C     ..
C
C  Purpose
C  =======
C
C  DGETF2 computes an LU factorization of a general m-by-n matrix A
C  using partial pivoting with row interchanges.
C
C  The factorization has the form
C     A = P * L * U
C  where P is a permutation matrix, L is lower triangular with unit
C  diagonal elements (lower trapezoidal if m > n), and U is upper
C  triangular (upper trapezoidal if m < n).
C
C  This is the right-looking Level 2 BLAS version of the algorithm.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  N >= 0.
C
C  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C          On entry, the m by n matrix to be factored.
C          On exit, the factors L and U from the factorization
C          A = P*L*U; the unit diagonal elements of L are not stored.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  IPIV    (output) INTEGER array, dimension (min(M,N))
C          The pivot indices; for 1 <= i <= min(M,N), row i of the
C          matrix was interchanged with row IPIV(i).
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -k, the k-th argument had an illegal value
C          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
C               has been completed, but the factor U is exactly
C               singular, and division by zero will occur if it is used
C               to solve a system of equations.
C
C  =====================================================================
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            J, JP
C     ..
C     .. External Functions ..
      INTEGER            IDAMAX
      EXTERNAL           IDAMAX
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGER, DSCAL, DSWAP, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETF2', -INFO )
         RETURN
      END IF
C
C     Quick return if possible
C
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
C
      DO 10 J = 1, MIN( M, N )
C
C        Find pivot and test for singularity.
C
         JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 )
         IPIV( J ) = JP
         IF( A( JP, J ).NE.ZERO ) THEN
C
C           Apply the interchange to columns 1:N.
C
            IF( JP.NE.J )
     $         CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
C
C           Compute elements J+1:M of J-th column.
C
            IF( J.LT.M )
     $         CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
C
         ELSE IF( INFO.EQ.0 ) THEN
C
            INFO = J
         END IF
C
         IF( J.LT.MIN( M, N ) ) THEN
C
C           Update trailing submatrix.
C
            CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA,
     $                 A( J+1, J+1 ), LDA )
         END IF
   10 CONTINUE
      RETURN
C
C     End of DGETF2
C
      END
C
      SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
C
C  -- LAPACK routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
C     ..
C     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
C     ..
C
C  Purpose
C  =======
C
C  DGETRF computes an LU factorization of a general m-by-n matrix A
C  using partial pivoting with row interchanges.
C
C  The factorization has the form
C     A = P * L * U
C  where P is a permutation matrix, L is lower triangular with unit
C  diagonal elements (lower trapezoidal if m > n), and U is upper
C  triangular (upper trapezoidal if m < n).
C
C  This is the right-looking Level 3 BLAS version of the algorithm.
C
C  Arguments
C  =========
C
C  M       (input) INTEGER
C          The number of rows of the matrix A.  M >= 0.
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.  N >= 0.
C
C  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C          On entry, the m by n matrix to be factored.
C          On exit, the factors L and U from the factorization
C          A = P*L*U; the unit diagonal elements of L are not stored.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,M).
C
C  IPIV    (output) INTEGER array, dimension (min(M,N))
C          The pivot indices; for 1 <= i <= min(M,N), row i of the
C          matrix was interchanged with row IPIV(i).
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -k, the k-th argument had an illegal value
C          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
C               has been completed, but the factor U is exactly
C               singular, and division by zero will occur if it is used
C               to solve a system of equations.
C
C  =====================================================================
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, IINFO, J, JB, NB
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGEMM, DGETF2, DLASWP, DTRSM, XERBLA
C     ..
C     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETRF', -INFO )
         RETURN
      END IF
C
C     Quick return if possible
C
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
C
C     Determine the block size for this environment.
C
      NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
C
C        Use unblocked code.
C
         CALL DGETF2( M, N, A, LDA, IPIV, INFO )
      ELSE
C
C        Use blocked code.
C
         DO 20 J = 1, MIN( M, N ), NB
            JB = MIN( MIN( M, N )-J+1, NB )
C
C           Factor diagonal and subdiagonal blocks and test for exact
C           singularity.
C
            CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
C
C           Adjust INFO and the pivot indices.
C
            IF( INFO.EQ.0 .AND. IINFO.GT.0 )
     $         INFO = IINFO + J - 1
            DO 10 I = J, MIN( M, J+JB-1 )
               IPIV( I ) = J - 1 + IPIV( I )
   10       CONTINUE
C
C           Apply interchanges to columns 1:J-1.
C
            CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
C
            IF( J+JB.LE.N ) THEN
C
C              Apply interchanges to columns J+JB:N.
C
               CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,
     $                      IPIV, 1 )
C
C              Compute block row of U.
C
               CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB,
     $                     N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ),
     $                     LDA )
               IF( J+JB.LE.M ) THEN
C
C                 Update trailing submatrix.
C
                  CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1,
     $                        N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,
     $                        A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),
     $                        LDA )
               END IF
            END IF
   20    CONTINUE
      END IF
      RETURN
C
C     End of DGETRF
C
      END
C
      SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
C
C  -- LAPACK routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, N
C     ..
C     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), WORK( LWORK )
C     ..
C
C  Purpose
C  =======
C
C  DGETRI computes the inverse of a matrix using the LU factorization
C  computed by DGETRF.
C
C  This method inverts U and then computes inv(A) by solving the system
C  inv(A)*L = inv(U) for inv(A).
C
C  Arguments
C  =========
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.
C
C  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C          On entry, the factors L and U from the factorization
C          A = P*L*U as computed by DGETRF.
C          On exit, if INFO = 0, the inverse of the original matrix A.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,N).
C
C  IPIV    (input) INTEGER array, dimension (N)
C          The pivot indices from DGETRF; for 1<=i<=N, row i of the
C          matrix was interchanged with row IPIV(i).
C
C  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK)
C          If INFO returns 0, then WORK(1) returns N*NB, the minimum
C          value of LWORK required to use the optimal blocksize.
C
C  LWORK   (input) INTEGER
C          The dimension of the array WORK.  LWORK >= max(1,N).
C          For optimal performance LWORK should be at least N*NB,
C          where NB is the optimal blocksize returned by ILAENV.
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0: if INFO = -k, the k-th argument had an illegal value
C          > 0: if INFO = k, U(k,k) is exactly zero; the matrix is
C               singular and its inverse could not be computed.
C
C  =====================================================================
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, IWS, J, JB, JJ, JP, LDWORK, NB, NBMIN, NN
C     ..
C     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      WORK( 1 ) = MAX( N, 1 )
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -3
      ELSE IF( LWORK.LT.N ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETRI', -INFO )
         RETURN
      END IF
C
C     Quick return if possible
C
      IF( N.EQ.0 )
     $   RETURN
C
C     Form inv(U).  If INFO > 0 from DTRTRI, then U is singular,
C     and the inverse is not computed.
C
      CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO )
      IF( INFO.GT.0 )
     $   RETURN
C
C     Determine the block size for this environment.
C
      NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 )
      NBMIN = 2
      LDWORK = N
      IF( NB.GT.1 .AND. NB.LT.N ) THEN
         IWS = MAX( LDWORK*NB, 1 )
         IF( LWORK.LT.IWS ) THEN
            NB = LWORK / LDWORK
            NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) )
         END IF
      ELSE
         IWS = N
      END IF
C
C     Solve the equation inv(A)*L = inv(U) for inv(A).
C
      IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN
C
C        Use unblocked code.
C
         DO 20 J = N, 1, -1
C
C           Copy current column of L to WORK and replace with zeros.
C
            DO 10 I = J + 1, N
               WORK( I ) = A( I, J )
               A( I, J ) = ZERO
   10       CONTINUE
C
C           Compute current column of inv(A).
C
            IF( J.LT.N )
     $         CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ),
     $                     LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 )
   20    CONTINUE
      ELSE
C
C        Use blocked code.
C
         NN = ( ( N-1 ) / NB )*NB + 1
         DO 50 J = NN, 1, -NB
            JB = MIN( NB, N-J+1 )
C
C           Copy current block column of L to WORK and replace with
C           zeros.
C
            DO 40 JJ = J, J + JB - 1
               DO 30 I = JJ + 1, N
                  WORK( I+( JJ-J )*LDWORK ) = A( I, JJ )
                  A( I, JJ ) = ZERO
   30          CONTINUE
   40       CONTINUE
C
C           Compute current block column of inv(A).
C
            IF( J+JB.LE.N )
     $         CALL DGEMM( 'No transpose', 'No transpose', N, JB,
     $                     N-J-JB+1, -ONE, A( 1, J+JB ), LDA,
     $                     WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA )
            CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB,
     $                  ONE, WORK( J ), LDWORK, A( 1, J ), LDA )
   50    CONTINUE
      END IF
C
C     Apply column interchanges.
C
      DO 60 J = N - 1, 1, -1
         JP = IPIV( J )
         IF( JP.NE.J )
     $      CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 )
   60 CONTINUE
C
      WORK( 1 ) = IWS
      RETURN
C
C     End of DGETRI
C
      END
C
      SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
C
C  -- LAPACK routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDB, N, NRHS
C     ..
C     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
C     ..
C
C  Purpose
C  =======
C
C  DGETRS solves a system of linear equations
C     A * X = B  or  A' * X = B
C  with a general n by n matrix A using the LU factorization computed
C  by DGETRF.
C
C  Arguments
C  =========
C
C  TRANS   (input) CHARACTER*1
C          Specifies the form of the system of equations.
C          = 'N':  A * X = B  (No transpose)
C          = 'T':  A'* X = B  (Transpose)
C          = 'C':  A'* X = B  (Conjugate transpose = Transpose)
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.
C
C  NRHS    (input) INTEGER
C          The number of right hand sides, i.e., the number of columns
C          of the matrix B.  NRHS >= 0.
C
C  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C          The factors L and U from the factorization A = P*L*U
C          as computed by DGETRF.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,N).
C
C  IPIV    (input) INTEGER array, dimension (N)
C          The pivot indices from DGETRF; for 1<=i<=N, row i of the
C          matrix was interchanged with row IPIV(i).
C
C  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
C          On entry, the right hand side vectors B for the system of
C          linear equations.
C          On exit, the solution vectors, X.
C
C  LDB     (input) INTEGER
C          The leading dimension of the array B.  LDB >= max(1,N).
C
C  INFO    (output) INTEGER
C          = 0:  successful exit
C          < 0: if INFO = -k, the k-th argument had an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            NOTRAN
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DLASWP, DTRSM, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
     $    LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETRS', -INFO )
         RETURN
      END IF
C
C     Quick return if possible
C
      IF( N.EQ.0 .OR. NRHS.EQ.0 )
     $   RETURN
C
      IF( NOTRAN ) THEN
C
C        Solve A * X = B.
C
C        Apply row interchanges to the right hand sides.
C
         CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
C
C        Solve L*X = B, overwriting B with X.
C
         CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,
     $               ONE, A, LDA, B, LDB )
C
C        Solve U*X = B, overwriting B with X.
C
         CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
     $               NRHS, ONE, A, LDA, B, LDB )
      ELSE
C
C        Solve A' * X = B.
C
C        Solve U'*X = B, overwriting B with X.
C
         CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS,
     $               ONE, A, LDA, B, LDB )
C
C        Solve L'*X = B, overwriting B with X.
C
         CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE,
     $               A, LDA, B, LDB )
C
C        Apply row interchanges to the solution vectors.
C
         CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
      END IF
C
      RETURN
C
C     End of DGETRS
C
      END
C
      SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )
C
C  -- LAPACK auxiliary routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      INTEGER            INCX, K1, K2, LDA, N
C     ..
C     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
C     ..
C
C  Purpose
C  =======
C
C  DLASWP performs a series of row interchanges on the matrix A.
C  One row interchange is initiated for each of rows K1 through K2 of A.
C
C  Arguments
C  =========
C
C  N       (input) INTEGER
C          The number of columns of the matrix A.
C
C  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C          On entry, the matrix of column dimension N to which the row
C          interchanges will be applied.
C          On exit, the permuted matrix.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.
C
C  K1      (input) INTEGER
C          The first element of IPIV for which a row interchange will
C          be done.
C
C  K2      (input) INTEGER
C          The last element of IPIV for which a row interchange will
C          be done.
C
C  IPIV    (input) INTEGER array, dimension (M*abs(INCX))
C          The vector of pivot indices.  Only the elements in positions
C          K1 through K2 of IPIV are accessed.
C          IPIV(K) = L implies rows K and L are to be interchanged.
C
C  INCX    (input) INTEGER
C          The increment between successive values of IPIV.  If IPIV
C          is negative, the pivots are applied in reverse order.
C
C
C     .. Local Scalars ..
      INTEGER            I, IP, IX
C     ..
C     .. External Subroutines ..
      EXTERNAL           DSWAP
C     ..
C     .. Executable Statements ..
C
C     Interchange row I with row IPIV(I) for each of rows K1 through K2.
C
      IF( INCX.EQ.0 )
     $   RETURN
      IF( INCX.GT.0 ) THEN
         IX = K1
      ELSE
         IX = 1 + ( 1-K2 )*INCX
      END IF
      IF( INCX.EQ.1 ) THEN
         DO 10 I = K1, K2
            IP = IPIV( I )
            IF( IP.NE.I )
     $         CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
   10    CONTINUE
      ELSE IF( INCX.GT.1 ) THEN
         DO 20 I = K1, K2
            IP = IPIV( IX )
            IF( IP.NE.I )
     $         CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
            IX = IX + INCX
   20    CONTINUE
      ELSE IF( INCX.LT.0 ) THEN
         DO 30 I = K2, K1, -1
            IP = IPIV( IX )
            IF( IP.NE.I )
     $         CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
            IX = IX + INCX
   30    CONTINUE
      END IF
C
      RETURN
C
C     End of DLASWP
C
      END
C
      SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
C
C  -- LAPACK routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          DIAG, UPLO
      INTEGER            INFO, LDA, N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
C     ..
C
C  Purpose
C  =======
C
C  DTRTI2 computes the inverse of a real upper or lower triangular
C  matrix.
C
C  This is the Level 2 BLAS version of the algorithm.
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          Specifies whether the matrix A is upper or lower triangular.
C          = 'U':  Upper triangular
C          = 'L':  Lower triangular
C
C  DIAG    (input) CHARACTER*1
C          Specifies whether or not the matrix A is unit triangular.
C          = 'N':  Non-unit triangular
C          = 'U':  Unit triangular
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.
C
C  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C          On entry, the triangular matrix A.  If UPLO = 'U', the
C          leading n by n upper triangular part of the array A contains
C          the upper triangular matrix, and the strictly lower
C          triangular part of A is not referenced.  If UPLO = 'L', the
C          leading n by n lower triangular part of the array A contains
C          the lower triangular matrix, and the strictly upper
C          triangular part of A is not referenced.  If DIAG = 'U', the
C          diagonal elements of A are also not referenced and are
C          assumed to be 1.
C
C          On exit, the (triangular) inverse of the original matrix, in
C          the same storage format.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,N).
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          < 0: if INFO = -k, the k-th argument had an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            NOUNIT, UPPER
      INTEGER            J
      DOUBLE PRECISION   AJJ
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DSCAL, DTRMV, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOUNIT = LSAME( DIAG, 'N' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTRTI2', -INFO )
         RETURN
      END IF
C
      IF( UPPER ) THEN
C
C        Compute inverse of upper triangular matrix.
C
         DO 10 J = 1, N
            IF( NOUNIT ) THEN
               A( J, J ) = ONE / A( J, J )
               AJJ = -A( J, J )
            ELSE
               AJJ = -ONE
            END IF
C
C           Compute elements 1:j-1 of j-th column.
C
            CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,
     $                  A( 1, J ), 1 )
            CALL DSCAL( J-1, AJJ, A( 1, J ), 1 )
   10    CONTINUE
      ELSE
C
C        Compute inverse of lower triangular matrix.
C
         DO 20 J = N, 1, -1
            IF( NOUNIT ) THEN
               A( J, J ) = ONE / A( J, J )
               AJJ = -A( J, J )
            ELSE
               AJJ = -ONE
            END IF
            IF( J.LT.N ) THEN
C
C              Compute elements j+1:n of j-th column.
C
               CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J,
     $                     A( J+1, J+1 ), LDA, A( J+1, J ), 1 )
               CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 )
            END IF
   20    CONTINUE
      END IF
C
      RETURN
C
C     End of DTRTI2
C
      END
C
      SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO )
C
C  -- LAPACK routine (version 1.0) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 29, 1992
C
C     .. Scalar Arguments ..
      CHARACTER          DIAG, UPLO
      INTEGER            INFO, LDA, N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
C     ..
C
C  Purpose
C  =======
C
C  DTRTRI computes the inverse of a real upper or lower triangular
C  matrix A.
C
C  This is the Level 3 BLAS version of the algorithm.
C
C  Arguments
C  =========
C
C  UPLO    (input) CHARACTER*1
C          Specifies whether the matrix A is upper or lower triangular.
C          = 'U':  Upper triangular
C          = 'L':  Lower triangular
C
C  DIAG    (input) CHARACTER*1
C          Specifies whether or not the matrix A is unit triangular.
C          = 'N':  Non-unit triangular
C          = 'U':  Unit triangular
C
C  N       (input) INTEGER
C          The order of the matrix A.  N >= 0.
C
C  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C
C          On entry, the triangular matrix A.  If UPLO = 'U', the
C          leading n by n upper triangular part of the array A contains
C          the upper triangular matrix, and the strictly lower
C          triangular part of A is not referenced.  If UPLO = 'L', the
C          leading n by n lower triangular part of the array A contains
C          the lower triangular matrix, and the strictly upper
C          triangular part of A is not referenced.  If DIAG = 'U', the
C          diagonal elements of A are also not referenced and are
C          assumed to be 1.
C
C          On exit, the (triangular) inverse of the original matrix, in
C          the same storage format.
C
C  LDA     (input) INTEGER
C          The leading dimension of the array A.  LDA >= max(1,N).
C
C  INFO    (output) INTEGER
C          = 0: successful exit
C          > 0: if INFO = k, A(k,k) is exactly zero.  The triangular
C               matrix is singular and its inverse can not be computed.
C          < 0: if INFO = -k, the k-th argument had an illegal value
C
C  =====================================================================
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Local Scalars ..
      LOGICAL            NOUNIT, UPPER
      INTEGER            J, JB, NB, NN
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
C     ..
C     .. External Subroutines ..
      EXTERNAL           DTRMM, DTRSM, DTRTI2, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
C     ..
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOUNIT = LSAME( DIAG, 'N' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTRTRI', -INFO )
         RETURN
      END IF
C
C     Quick return if possible
C
      IF( N.EQ.0 )
     $   RETURN
C
C     Check for singularity if non-unit.
C
      IF( NOUNIT ) THEN
         DO 10 INFO = 1, N
            IF( A( INFO, INFO ).EQ.ZERO )
     $         RETURN
   10    CONTINUE
         INFO = 0
      END IF
C
C     Determine the block size for this environment.
C
      NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.N ) THEN
C
C        Use unblocked code
C
         CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
      ELSE
C
C        Use blocked code
C
         IF( UPPER ) THEN
C
C           Compute inverse of upper triangular matrix
C
            DO 20 J = 1, N, NB
               JB = MIN( NB, N-J+1 )
C
C              Compute rows 1:j-1 of current block column
C
               CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1,
     $                     JB, ONE, A, LDA, A( 1, J ), LDA )
               CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1,
     $                     JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )
C
C              Compute inverse of current diagonal block
C
               CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO )
   20       CONTINUE
         ELSE
C
C           Compute inverse of lower triangular matrix
C
            NN = ( ( N-1 ) / NB )*NB + 1
            DO 30 J = NN, 1, -NB
               JB = MIN( NB, N-J+1 )
               IF( J+JB.LE.N ) THEN
C
C                 Compute rows j+jb:n of current block column
C
                  CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG,
     $                        N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,
     $                        A( J+JB, J ), LDA )
                  CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG,
     $                        N-J-JB+1, JB, -ONE, A( J, J ), LDA,
     $                        A( J+JB, J ), LDA )
               END IF
C
C              Compute inverse of current diagonal block
C
               CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )
   30       CONTINUE
         END IF
      END IF
C
      RETURN
C
C     End of DTRTRI
C
      END
C
      INTEGER          FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,
     $                 N4 )
C
C  -- LAPACK auxiliary routine (preliminary version) --
C     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
C     Courant Institute, Argonne National Lab, and Rice University
C     February 20, 1992
C
C     .. Scalar Arguments ..
      CHARACTER*( * )    NAME, OPTS
      INTEGER            ISPEC, N1, N2, N3, N4
C     ..
C
C  Purpose
C  =======
C
C  ILAENV is called from the LAPACK routines to choose problem-dependent
C  parameters for the local environment.  See ISPEC for a description of
C  the parameters.
C
C  This version provides a set of parameters which should give good,
C  but not optimal, performance on many of the currently available
C  computers.  Users are encouraged to modify this subroutine to set
C  the tuning parameters for their particular machine using the option
C  and problem size information in the arguments.
C
C  This routine will not function correctly if it is converted to all
C  lower case.  Converting it to all upper case is allowed.
C
C  Arguments
C  =========
C
C  ISPEC   (input) INTEGER
C          Specifies the parameter to be returned as the value of
C          ILAENV.
C          = 1: the optimal blocksize; if this value is 1, an unblocked
C               algorithm will give the best performance.
C          = 2: the minimum block size for which the block routine
C               should be used; if the usable block size is less than
C               this value, an unblocked routine should be used.
C          = 3: the crossover point (in a block routine, for N less
C               than this value, an unblocked routine should be used)
C          = 4: the number of shifts, used in the nonsymmetric
C               eigenvalue routines
C          = 5: the minimum column dimension for blocking to be used;
C               rectangular blocks must have dimension at least k by m,
C               where k is given by ILAENV(2,...) and m by ILAENV(5,...)
C          = 6: the crossover point for the SVD (when reducing an m by n
C               matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
C               this value, a QR factorization is used first to reduce
C               the matrix to a triangular form.)
C          = 7: the number of processors
C          = 8: the crossover point for the multishift QR and QZ methods
C               for nonsymmetric eigenvalue problems.
C
C  NAME    (input) CHARACTER*(*)
C          The name of the calling subroutine, in either upper case or
C          lower case.
C
C  OPTS    (input) CHARACTER*(*)
C          The character options to the subroutine NAME, concatenated
C          into a single character string.  For example, UPLO = 'U',
C          TRANS = 'T', and DIAG = 'N' for a triangular routine would
C          be specified as OPTS = 'UTN'.
C
C  N1      (input) INTEGER
C  N2      (input) INTEGER
C  N3      (input) INTEGER
C  N4      (input) INTEGER
C          Problem dimensions for the subroutine NAME; these may not all
C          be required.
C
C (ILAENV) (output) INTEGER
C          >= 0: the value of the parameter specified by ISPEC
C          < 0:  if ILAENV = -k, the k-th argument had an illegal value.
C
C  Further Details
C  ===============
C
C  The following conventions have been used when calling ILAENV from the
C  LAPACK routines:
C  1)  OPTS is a concatenation of all of the character options to
C      subroutine NAME, in the same order that they appear in the
C      argument list for NAME, even if they are not used in determining
C      the value of the parameter specified by ISPEC.
C  2)  The problem dimensions N1, N2, N3, N4 are specified in the order
C      that they appear in the argument list for NAME.  N1 is used
C      first, N2 second, and so on, and unused problem dimensions are
C      passed a value of -1.
C  3)  The parameter value returned by ILAENV is checked for validity in
C      the calling subroutine.  For example, ILAENV is used to retrieve
C      the optimal blocksize for STRTRI as follows:
C
C      NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
C      IF( NB.LE.1 ) NB = MAX( 1, N )
C
C  =====================================================================
C
C     .. Local Scalars ..
      LOGICAL            CNAME, SNAME
      CHARACTER*1        C1
C
C  Added by Bob Fay
C
      CHARACTER*1        CZ
C
      CHARACTER*2        C2, C4
      CHARACTER*3        C3
      CHARACTER*6        SUBNAM
      INTEGER            I, IC, IZ, NB, NBMIN, NX
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          CHAR, ICHAR, INT, MIN, REAL
C
C  Added by Bob Fay
C
      DATA CZ/'Z'/
C     ..
C     .. Executable Statements ..
C
      GO TO ( 100, 100, 100, 400, 500, 600, 700, 800 ) ISPEC
C
C     Invalid value for ISPEC
C
      ILAENV = -1
      RETURN
C
  100 CONTINUE
C
C     Convert NAME to upper case if the first character is lower case.
C
      ILAENV = 1
      SUBNAM = NAME
      IC = ICHAR( SUBNAM( 1:1 ) )
C
C     Change by Bob Fay
C
C     IZ = ICHAR( 'Z' )
C
      IZ = ICHAR ( CZ )
      IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN
C
C        ASCII character set
C
         IF( IC.GE.97 .AND. IC.LE.122 ) THEN
            SUBNAM( 1:1 ) = CHAR( IC-32 )
            DO 10 I = 2, 6
               IC = ICHAR( SUBNAM( I:I ) )
               IF( IC.GE.97 .AND. IC.LE.122 )
     $            SUBNAM( I:I ) = CHAR( IC-32 )
   10       CONTINUE
         END IF
C
      ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN
C
C        EBCDIC character set
C
         IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
     $       ( IC.GE.145 .AND. IC.LE.153 ) .OR.
     $       ( IC.GE.162 .AND. IC.LE.169 ) ) THEN
            SUBNAM( 1:1 ) = CHAR( IC+64 )
            DO 20 I = 2, 6
               IC = ICHAR( SUBNAM( I:I ) )
               IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
     $             ( IC.GE.145 .AND. IC.LE.153 ) .OR.
     $             ( IC.GE.162 .AND. IC.LE.169 ) )
     $            SUBNAM( I:I ) = CHAR( IC+64 )
   20       CONTINUE
         END IF
C
      ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN
C
C        Prime machines:  ASCII+128
C
         IF( IC.GE.225 .AND. IC.LE.250 ) THEN
            SUBNAM( 1:1 ) = CHAR( IC-32 )
            DO 30 I = 2, 6
               IC = ICHAR( SUBNAM( I:I ) )
               IF( IC.GE.225 .AND. IC.LE.250 )
     $            SUBNAM( I:I ) = CHAR( IC-32 )
   30       CONTINUE
         END IF
      END IF
C
      C1 = SUBNAM( 1:1 )
      SNAME = C1.EQ.'S' .OR. C1.EQ.'D'
      CNAME = C1.EQ.'C' .OR. C1.EQ.'Z'
      IF( .NOT.( CNAME .OR. SNAME ) )
     $   RETURN
      C2 = SUBNAM( 2:3 )
      C3 = SUBNAM( 4:6 )
      C4 = C3( 2:3 )
C
      GO TO ( 110, 200, 300 ) ISPEC
C
  110 CONTINUE
C
C     ISPEC = 1:  block size
C
C     In these examples, separate code is provided for setting NB for
C     real and complex.  We assume that NB will take the same value in
C     single or double precision.
C
      NB = 1
C
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
     $            C3.EQ.'QLF' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'PO' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NB = 1
         ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN
            NB = 64
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            NB = 64
         ELSE IF( C3.EQ.'TRD' ) THEN
            NB = 1
         ELSE IF( C3.EQ.'GST' ) THEN
            NB = 64
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         END IF
      ELSE IF( C2.EQ.'GB' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               IF( N4.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            ELSE
               IF( N4.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            END IF
         END IF
      ELSE IF( C2.EQ.'PB' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               IF( N2.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            ELSE
               IF( N2.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            END IF
         END IF
      ELSE IF( C2.EQ.'TR' ) THEN
         IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'LA' ) THEN
         IF( C3.EQ.'UUM' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN
         IF( C3.EQ.'EBZ' ) THEN
            NB = 1
         END IF
      END IF
      ILAENV = NB
      RETURN
C
  200 CONTINUE
C
C     ISPEC = 2:  minimum block size
C
      NBMIN = 2
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
     $       C3.EQ.'QLF' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NBMIN = 2
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRD' ) THEN
            NBMIN = 2
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         END IF
      END IF
      ILAENV = NBMIN
      RETURN
C
  300 CONTINUE
C
C     ISPEC = 3:  crossover point
C
      NX = 0
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
     $       C3.EQ.'QLF' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NX = 1
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRD' ) THEN
            NX = 1
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NX = 128
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
     $          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
     $          C4.EQ.'BR' ) THEN
               NX = 128
            END IF
         END IF
      END IF
      ILAENV = NX
      RETURN
C
  400 CONTINUE
C
C     ISPEC = 4:  number of shifts (used by xHSEQR)
C
      ILAENV = 6
      RETURN
C
  500 CONTINUE
C
C     ISPEC = 5:  minimum column dimension (not used)
C
      ILAENV = 2
      RETURN
C
  600 CONTINUE
C
C     ISPEC = 6:  crossover point for SVD (used by xGELSS and xGESVD)
C
      ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
      RETURN
C
  700 CONTINUE
C
C     ISPEC = 7:  number of processors (not used)
C
      ILAENV = 1
      RETURN
C
  800 CONTINUE
C
C     ISPEC = 8:  crossover point for multishift (used by xHSEQR)
C
      ILAENV = 50
      RETURN
C
C     End of ILAENV
C
      END
C
C  Start of M.FOR - MERGE step
C
      SUBROUTINE VMERGE
C
C  Note: Usage of storage and common blocks has been largely patterned
C        after the TRANSFORM step.
C
C  Several checks, e.g., matching number of variance IDs etc., are
C  built into the new syntax but not the old.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MTRANS=1500,MRANGS=20)
      PARAMETER (MTRSZI=MSIZEI+6*MRANGE-6*MRANGS+2*MRNSET+MRECOD+MVAR)
      PARAMETER (IXFLLD=49+3*MAXIDS)
      PARAMETER (NOPTNT=2,NOPTNV=9)
      PARAMETER (MAXSUB=500,MAXSBL=2000)
C
      INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL),
     .   U5LCSW
      COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
C
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STMBLK/IX,RANGE,RGROUP,RTYPE,RSTPNT,V1,V2,V3,MXSIZE,
     . IOUT,IOUTL
      DOUBLE PRECISION RANGE(2,MRANGS)
      INTEGER IX(MTRSZI),RGROUP(MRANGS),RTYPE(MRANGS),RSTPNT(MRECOD),
     . V1(MRECOD),V2(MRECOD),V3(MRECOD),MXSIZE(MVAR),IOUT(MVAR),
     . IOUTL(MVAR)
C
C  Usage in this subroutine:
C  V1     - Variable number (or block no. if V2=9)
C  V2     - Transformation code (used to indicate n(block) only)
C  V3     - Pointer to CLASS specification
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
      INTEGER VTMPSZ
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
      LOGICAL REFRSH,ALPCHK,ICHECK
      EXTERNAL REFRSH,ALPCHK,ICHECK
      INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID,
     . SDWRK,VKEEPF,ISTEPC,ISELEC,IOUTPT,IAS,IASLST,NCRVLB,NASVL,
     . IFLLVL,IXFILL(IXFLLD)
      COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,
     . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF,
     . IFLLVL,ISTEPC,ISELEC,IOUTPT,IAS,IASLST,NCRVLB,NASVL,IXFILL
C
      COMMON /VABLCK/AVERSN,ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT,
     . ATYPE,AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR,ANID,ANCRSS,ANCRVL,
     . AVNCRS,ANBYGR,ASDBID,ANRPTT,ASDCOF
      INTEGER  AVERSN,ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT,
     . ATYPE,AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR,ANID,ANCRSS,ANCRVL,
     . AVNCRS,ANBYGR,ASDBID,ANRPTT,ASDCOF
C
C
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
C
C  Usage in this subroutine:
C
C  BLVSTR  -  (Values from primary input saved to include in output
C              file.)  Beginning variable of block.
C  BLVSIZ  -  read from incoming file, used to compute block numbers
C             in MXSIZE.
C  BLNCLS  -  number of classes in block
C  BLCPNT  -  pointer for classes to CLPNT and CLTYPE
C  CLPNT   -  used as pointers to class variables
C
      INTEGER ITYPEF(3),IFILEF(3)
      LOGICAL LTEMP,ENDMRG
      DOUBLE PRECISION MISSNG
C
      CHARACTER*12 OPTNT(NOPTNT),OPTNV(NOPTNV)
      INTEGER INDXT(NOPTNT),INDXV(NOPTNV)
      INTEGER IVALT(NOPTNT),IVALV(NOPTNV)
      DATA OPTNT /    'ZEROFILL    ','MISSINGFILL '/
      DATA OPTNV /    'BYGROUP     ','CONSTANTS   ','REPLICATE   ',
     .                'CONSTANT    ','FULL        ','BYREPEAT    ',
     .                'REPEAT      ','IDCHECK     ','NOIDCHECK   '/
      DATA INDXV/3,3,3,3,3,3,3,4,4/
      DATA INDXT/1,1/
      DATA IVALT/0,1/
      DATA IVALV/1,2,3,2,1,4,4,1,0/
      DATA MISSNG/-98765.432109D0/
C
  200 FORMAT(/,5X,'WARNING: The SELECT variable is not associated with',
     . ' one or more blocks')
C
C  Initializations.
C    RCEIL(1) - maximum size of integer array, set to parameter value
C    NPASS    - index to variable arguments to copy
C               Each variable to be copied requires 2 levels of NPASS:
C               One for INCORPORATEd file and one for merged file.
C    NTRANS   - number of input VPLX files, including primary file
C    ENDMRG     set to true on end of file or when encountering
C               a command from another step.
C    ISOPTN   = 1 step options have been set
C
      RCEIL(1)=MTRSZI
      NPASS=0
      NTRANS=1
      ENDMRG=.FALSE.
      ISOPTN=0
      IFLLVL=0
C
C
C  IX(NTRANS*12-11) = Starting location in IX for options
C  IX(NTRANS*12-10) = Starting location in IX for values copied from
C                     block information arrays
C  IX(NTRANS*12-9)  = Number of blocks (from ANCLBL)
C  IX(NTRANS*12-8)  = Number of elements in class specifications for
C                     block (from ANCLBR)
C  IX(NTRANS*12-7)  = Number of variables (from ANVTOT)
C  IX(NTRANS*12-6)  = 2*Number of variables to move (counting block N)
C  IX(NTRANS*12-5)  = Starting value of NPASS
C  IX(NTRANS*12-4)  = Starting location for ID
C  IX(NTRANS*12-3)  = Starting location for DX
C
C  SICMUL - starting position in IX for multipliers showing for each
C           block the multiplying effect of the class variables.
C           TMOVE1 and TMOVE2 use SICMUL, in COMMON, under some
C           conditions.  Set the array up to full MCLBLK size here.
C
C  Error call if parameter MTRSZI is too small.
C
      SICMUL=1+12*MTRANS
      NXPTI=SICMUL+MCLBLK
      IF(NXPTI+12.GT.MTRSZI) THEN
        CALL FESTOP(130001)
      END IF
C
C  In preparation to call FNREAD, set flags to expect binary input and
C  output.
C
      ITYPEF(1)=2
      ITYPEF(2)=2
      ITYPEF(3)=0
      CALL CRDPRN(3)
      CALL KYFIND(IKEY,IPT)
      IF(IKEY.EQ.197) THEN
C                                  ! Set ISTEPC to identify step
        ISTEPC=1
C                                  ! MERGE
      ELSE
        ISTEPC=2
C                                  ! EXTRACT
      END IF
      CALL FNREAD(IPT,ITYPEF,IFILEF,1,IPOSSC)
      IF(IMERR1.GT.0) THEN
        CALL FSTOP
      END IF
C
C  Require that an output be specified.
C
      IF(IFILEF(2).EQ.0) THEN
        CALL FESTOP(130002)
      END IF
C
C  Call PREAMB to read the metadata on the primary input file,
C
      CALL PREAMB
C
C  SVTEMP is set in PREAMB to be the next available position, after
C  variable names associated with crossed variables have been stored
C  in VTEMP.  VTMPSZ stores the remaining working space in VTEMP.
C
      VTMPSZ=MVAR-SVTEMP+1
C
      NVIN=NVTOT
      IV=0
C
C  Store the number of the block for each variable in MXSIZE
C
      DO 8 ICLBLK=1,NCLBLK
      IF(BLVSIZ(ICLBLK).GT.0) THEN
        DO 6 I=1,BLVSIZ(ICLBLK)
        IV=IV+1
        MXSIZE(IV)=ICLBLK
    6   CONTINUE
      END IF
    8 CONTINUE
C
C  Allocate and initialize room for options (including FORTRAN file
C  number.)
C
      IX(NTRANS*12-11)=NXPTI
      I=NXPTI
      CALL ROOMI(10)
      IX(I)=12
      IX(I+1)=0
      IX(I+2)=0
      IX(I+3)=0
C
C
C  ** Copy values into upper end of arrays in the same manner as
C     PREAMD.
C
      ANVTOT=NVTOT
      ANVREG=NVREG
      ANCLSS=NCLASS
      ATSIZE=TSIZE
      ANCLBL=NCLBLK
      ANCLBR=NCLBAR
      ANCRVL=NCRVL
      ANVRID=NVARID
      ANBY=NBY
      CALL RCHECK(2,NVTOT,ANVTOT)
      ICLBLK=RCEIL(8)-ANCLBL+1
      ANID=NID
      ANIDTT=NIDTOT
      CALL RCHECK(8,NCLBLK,ANCLBL)
      CALL RCHECK(9,NCLBAR,ANCLBR)
      I=RCEIL(8)-ANCLBL+1
C
C  Copying of block arrays.
C
      DO 10 J=1,ANCLBL
      BLTYPE(I)=BLTYPE(J)
      BLXSTR(I)=BLXSTR(J)
      BLXINC(I)=BLXINC(J)
      BLXSIZ(I)=BLXSIZ(J)
      BLVSTR(I)=BLVSTR(J)
      BLVSIZ(I)=BLVSIZ(J)
      BLNCLS(I)=BLNCLS(J)
      BLCPNT(I)=BLCPNT(J)
      IX(SICMUL+I-1)=BLXSIZ(J)/BLXINC(J)
C
C  Adjust BLCPNT to point to actual entries in CLPNT, CLTYPE.
C  Note: BLXSTR, BLVSTR are not adjusted for high-end positioning
C        and thus give relative, not actual, positions
C
      IF(BLCPNT(I).GT.0) THEN
        BLCPNT(I)=BLCPNT(I)+RCEIL(9)-ANCLBR
      END IF
      I=I+1
   10 CONTINUE
C
      IF(ANCLBR.GT.0) THEN
C
C  Adjust CLPNT to point to actual positions of class variables.
C
        I=RCEIL(9)-ANCLBR+1
        DO 12 J=1,ANCLBR
        CLTYPE(I)=CLTYPE(J)
        CLPNT(I)=CLPNT(J)+RCEIL(2)-ANVTOT
        I=I+1
   12   CONTINUE
C
      END IF
      IF(ANVTOT.GT.0) THEN
        I=RCEIL(2)-ANVTOT+1
        DO 14 J=1,ANVTOT
        MTYPE(I)=MTYPE(J)
        MSIZE(I)=MSIZE(J)
        VNAME(I)=VNAME(J)
        IF(LPOINT(J).GT.0)LPOINT(I)=LPOINT(J)+RCEIL(7)-ANCRVL
C
C  Note: MXSIZE is adjusted to give actual block numbers.
C
        MXSIZE(I)=MXSIZE(J)+RCEIL(8)-ANCLBL
        I=I+1
   14   CONTINUE
      END IF
C
C  VMAPL contains pointers to the first ANVREG variables
C  These are relative positions; actual positions not determined
C  here.
C
      IF(ANVREG.GT.0) THEN
        I=RCEIL(2)-ANVTOT+1
        DO 16 J=1,ANVREG
        VMAPL(I)=VMAPL(J)
        I=I+1
   16   CONTINUE
      END IF
      IF(ANCRVL.GT.0) THEN
        I=RCEIL(7)-ANCRVL+1
        DO 17 J=1,ANCRVL
        LEVEL(I)=LEVEL(J)
        I=I+1
   17   CONTINUE
      END IF
C
C  ISELEC - class variable identified by SELECT
C  IOUTPT - class variable identified by OUTPUT class
C  IAS    - class variable identified by AS
C  IASLST - pointer in IX to list from AS
C  NASLST - number of elements in ASTLST list
C  NCRVLB - if labels are read with an AS statement, they will be
C           read after this point
C  NASVL  - number of labels read after as AS statement.
C
      ISELEC=0
      IOUTPT=0
      IAS=0
      IASLST=0
      NCRVLB=NCRVL
      NASVL=0
C
C  If new syntax
C
      IF(IPOSSC.GT.0) THEN
        TSWTCH=3
        CALL STBLNK(CARD,1,IPOSSC)
        IPOSSC=IPOSSC+1
        U5LCSW=1
C                                 ! Reset U5LCSW used by REFRSH
        NXPTIM=NXPTI
        CALL CMPAR1(IX,IPOSSC)
        CALL NMERGE(IX(NLINE+NLINE2+NXPTIM),IX(NXPTIM),IX(NLINE+NXPTIM))
        GO TO 64
      END IF
C
C  AS            195
C  SELECT          9
C  STEPOPTION 198-200
C  OPTION         36
C  INCORPORATE   196
C  OUTPUT CLASS  111
C
C
    1 CONTINUE
      LTEMP=REFRSH(IPT)
    2 CONTINUE
C
C  If no more instructions remain, conclude specification for the step.
C
      IF(U5END.GT.0)GO TO 62
C
      CALL KYFIND(IKEY,IPT)
      IF(IKEY.NE.9.AND.IKEY.NE.36.AND.IKEY.NE.111.AND.IKEY.NE.196.AND.
     .   IKEY.NE.195.AND.(IKEY.LT.198.OR.IKEY.GT.200)) GO TO 62
C
      IF(IKEY.EQ.196) THEN
        GO TO 27
      END IF
      CALL CRDPRN(1)
C
C  If encounter INCORPORATE, branch to complete processing of previous
C  input file.
C
C
C  If continuation line without keyword, read next record
C
      IF(IKEY.EQ.-1) THEN
        GO TO 1
      END IF
      IF(IKEY.EQ.9.OR.IKEY.EQ.111) THEN
C
C  SELECT (9) OUTPUT (111)
C
C
C  Determine class variable to use
C
C
C  Find level to select and edit for completeness
C
C  IBEYND = 1 if have read beyond 1st record
C
        IBEYND=0
C
C  Error messages if both SELECT and OUTPUT appear.
C
        IF(IKEY.EQ.9) THEN
          IF(ISELEC.GT.0) THEN
            CALL FESTOP(130003)
          ELSE IF(IOUTPT.GT.0) THEN
            CALL FESTOP(130004)
          END IF
        ELSE
          IF(IOUTPT.GT.0) THEN
            CALL FESTOP(130005)
          ELSE IF(ISELEC.GT.0) THEN
            CALL FESTOP(130019)
          END IF
        END IF
C
        IF(IPT.LE.0) THEN
          CALL NBFND2(IPT,IPOS)
          IF(IPT.EQ.1)IBEYND=1
          IF(IPOS.GT.0) THEN
            IPT=IPOS
          ELSE
            CALL FESTOP(130006)
          END IF
        END IF
        CALL CMATCH(CARD(IPT:256),IPT,256,'CLASS',5,IPOS,1)
        IF(IPOS.GT.0) THEN
          IPT=IPOS
        END IF
        MAXVN=RCEIL(2)-NVTOT-ANVTOT-2
C
C  Error message if not enough room for variable names.
C
        IF(MAXVN.LE.0) THEN
          K=ANVTOT+2
          CALL RCHECK(2,NVIN,K)
        END IF
        CALL VNFIND(IPT,VNAME(NVIN+1),MAXVN,N,IPOS,2,VNAME,NVIN)
        IF(IPT.EQ.1)IBEYND=1
        IF(N.EQ.0) THEN
          CALL FESTOP(130006)
        ELSE IF(N.GT.1) THEN
          CALL FESTOP(130007)
        ELSE
          IF(IPOS.EQ.0) THEN
            CALL FESTOP(130010)
          ELSE
            IPT=IPOS
          END IF
          CALL VNMTCH(VNAME(NVIN+1),VNAME,NVIN,K)
C
C  If the provided variable name does not match, accept only if
C  OUTPUT, if output class has not been previously identified by AS.
C
          IF(K.EQ.0) THEN
            IF(IKEY.EQ.9) THEN
              CALL FESTOP(130008)
            ELSE IF(IAS.GT.0) THEN
              CALL FESTOP(130020)
            ELSE
              CALL RINCR(2,NVIN,1)
              K=NVIN
              MTYPE(NVIN)=4
              IOUTPT=NVIN
              LABEL(NVIN)(1:12)=VNAME(NVIN)
              LABEL(NVIN)(13:24)='            '
            END IF
C
C  If variable has appeared, make sure it is a class variable, etc.
C
          ELSE
            IF(MTYPE(K).NE.4) THEN
              CALL FESTOP(130009)
            ELSE
              IF(IKEY.EQ.9) THEN
                ISELEC=K
              ELSE
                IF(IAS.GT.0) THEN
                  IF(IAS.NE.K) THEN
                    CALL FESTOP(130020)
                  END IF
                END IF
                IOUTPT=K
              END IF
            END IF
          END IF
        END IF
C
C  Search for "(ISVAL)"
C
        CALL NBFND2(IPT,IPOS)
        IF(IPT.EQ.1)IBEYND=1
        IF(IPOS.GT.0) THEN
          IPT=IPOS
        ELSE
          CALL FESTOP(130010)
        END IF
        IF(CARD(IPT:IPT).NE.'(') THEN
          CALL FESTOP(130010)
        ELSE
          IPOS=IPT+1
          CALL NBFND2(IPOS,IPT)
          IF(IPOS.EQ.1)IBEYND=1
          IF(IPT.LE.0) THEN
            CALL FESTOP(130011)
          END IF
        END IF
        CALL IFIND(CARD(IPT:256),IPT,256,IPOS,ISVAL)
        IF(IPOS.EQ.0) THEN
          CALL FPSTOP(130011,IPT)
        END IF
C
C  For SELECT, edit ISVAL.
C
        IF(IKEY.EQ.9) THEN
          IF(ISVAL.LT.0.OR.ISVAL.GT.MSIZE(ISELEC)) THEN
            CALL FPSTOP(130012,IPT)
          END IF
          NOUTPT=1
        ELSE
          IF(ISVAL.LE.0) THEN
            CALL FPSTOP(130011,IPT)
          END IF
          NOUTPT=ISVAL
          IF(IAS.GT.NVTOT)MSIZE(IAS)=NOUTPT
        END IF
        CALL NBFND2(IPOS,IPT)
        IF(IPOS.EQ.1)IBEYND=1
        IF(IPT.LE.0) THEN
          CALL FESTOP(130013)
        END IF
        IF(CARD(IPT:IPT).NE.')') THEN
          CALL FPSTOP(130013,IPT)
        END IF
        IPT=IPT+1
C
C  Store labels and other information for the new class in the
C  slot NVTOT+1 above the number of variables in the incoming file.
C  This positioning anticipates the later moving around of labels.
C
        IF(IKEY.EQ.111) THEN
          K=NVTOT+1
          MSIZE(K)=NOUTPT
C
C  Deliberately leave space of NOUTPT in LEVEL array.  Values of
C  LEVEL stored here will have to be moved later.
C
          LPOINT(K)=NCRVL+NOUTPT+1
          NCRVLB=NCRVL+2*NOUTPT
C
C  If levels have been read with a previous AS statement, move them.
C
          IF(NASVL.GT.0) THEN
            DO 19 I=1,NASVL
            LEVEL(NCRVLB+I)=LEVEL(NCRVL+I)
   19       CONTINUE
          END IF
C
          CALL NBFND2(IPT,IPOS)
          IF(IPT.EQ.1)IBEYND=1
          IPT=IPOS
          NCRVLS=NCRVL
          CALL RINCR(7,NCRVL,NOUTPT)
          DO 20 I=1,NOUTPT
          CALL RINCR(7,NCRVL,1)
          LEVEL(NCRVL)(1:12)='            '
          LEVEL(NCRVL)(13:24)=LEVEL(NCRVL)(1:12)
   20     CONTINUE
          IF(IPT.GT.1) THEN
            CALL LEVELR(IPT,IPOS,NL,LEVEL(NCRVLS+NOUTPT+1),NOUTPT)
          END IF
          IF(IPT.EQ.1)IBEYND=1
        END IF
        IF(U5END.EQ.1.OR.(ALPCHK(CARD(1:1)).AND.IBEYND.EQ.1))GO TO 2
        GO TO 1
C
      ELSE IF(IKEY.EQ.195) THEN
C
C  AS
C
C
C  IBEYND = 1 if have read beyond 1st record
C
        IBEYND=0
C
C  Determine if class name has been given
C
C  Read list of variables.
C
        IF(ISELEC.GT.0) THEN
          CALL FESTOP(130014)
        ELSE IF(IAS.GT.0) THEN
          CALL FESTOP(130021)
        END IF
        IF(IPT.LE.0) THEN
          CALL NBFND2(IPT,IPOS)
          IF(IPT.EQ.1)IBEYND=1
          IF(IPOS.GT.0) THEN
            IPT=IPOS
          ELSE
            CALL FESTOP(130015)
          END IF
        END IF
        MAXVN=RCEIL(2)-ANVTOT-NVTOT+2
        IF(MAXVN.LE.0) THEN
          K=ANVTOT+2
          CALL RCHECK(2,NVIN,ANVTOT)
        END IF
        CALL VNFIND(IPT,VNAME(NVIN+1),MAXVN,N,IPOS,2,VNAME,NVIN)
        IF(IPT.EQ.1)IBEYND=1
C
        IF(N.GT.1) THEN
          CALL FESTOP(130016)
        ELSE IF(N.EQ.1) THEN
          IPT=IPOS
          CALL VNMTCH(VNAME(NVIN+1),VNAME,NVIN,K)
C
C  Accept unmatching name only if OUTPUT has not already appeared.
C
          IF(K.EQ.0) THEN
            IF(IOUTPT.GT.0) THEN
              CALL FESTOP(130018)
            ELSE
              CALL RINCR(2,NVIN,1)
              MTYPE(NVIN)=4
              MSIZE(NVIN)=0
              IAS=NVIN
              LABEL(NVIN)(1:12)=VNAME(NVIN)
              LABEL(NVIN)(13:24)='            '
            END IF
          ELSE
            IF(MTYPE(K).NE.4) THEN
              CALL FESTOP(130009)
            ELSE
              IAS=K
              IF(IOUTPT.GT.0) THEN
                IF(K.NE.IOUTPT) THEN
                  CALL FESTOP(130017)
                END IF
              END IF
            END IF
          END IF
        END IF
        CALL NBFND2(IPT,IPOS)
        IF(IPT.EQ.1)IBEYND=1
        IF(IPOS.GT.0) THEN
          IPT=IPOS
        ELSE
          CALL FESTOP(130010)
        END IF
C
C  Read the disposition list.
C
        IF(CARD(IPT:IPT).NE.'(') THEN
          CALL FESTOP(130010)
        ELSE
          IPOS=IPT+1
          CALL NBFND2(IPOS,IPT)
          IF(IPOS.EQ.1)IBEYND=1
          IF(IPT.LE.0) THEN
            CALL FESTOP(130018)
          END IF
        END IF
        CALL RNSCAN(IPT,IPOS,RANGE,MRANGS,RTYPE,RGROUP,
     .        NR,3,LEVEL,1)
        IF(IPT.EQ.1) THEN
          IF(IPOS.EQ.0) THEN
            CALL FESTOP(130015)
          END IF
        ELSE IF(IPOS.EQ.0.OR.NR.LE.0) THEN
          CALL FESTOP(130022)
        END IF
        IPT=IPOS
        IASLST=NXPTI
        IASNOW=IASLST-1
        DO 24 I=1,NR
        IF(RTYPE(I).EQ.5) THEN
          CALL FESTOP(130023)
        ELSE
          IF(RTYPE(I).EQ.1.OR.RTYPE(I).EQ.3.OR.RTYPE(I).EQ.6) THEN
            ILOW=RANGE(1,I)+.1D-7
          ELSE
            ILOW=1
          END IF
          IF(RTYPE(I).EQ.1.OR.RTYPE(I).EQ.2) THEN
            IHIGH=RANGE(2,I)
          ELSE
            IF(ILOW.EQ.1) THEN
              IF(IAS.EQ.0) THEN
                CALL FESTOP(130024)
              ELSE
                IF(MSIZE(IAS).EQ.0) THEN
                  CALL FESTOP(130024)
                ELSE
                  IHIGH=MSIZE(IAS)
                END IF
              END IF
            ELSE
              IF(IOUTPT.GT.0) THEN
                IHIGH=NOUTPT
              ELSE
                CALL FESTOP(130024)
              END IF
            END IF
          END IF
          DO 22 J=ILOW,IHIGH
          CALL ROOMI(1)
          IASNOW=IASNOW+1
          IX(IASNOW)=J
   22     CONTINUE
        END IF
   24   CONTINUE
C
C  Note: NASLST is the length of the specification.
C        This will be checked for consistency later.
C
        NASLST=IASNOW-IASLST+1
C
C  Check for the presence of labels.
C
        CALL NBFND2(IPT,IPOS)
        IF(IPT.EQ.1)IBEYND=1
        IF(IPOS.GT.0) THEN
          IPT=IPOS
          CALL LEVELR(IPT,IPOS,NASVL,LEVEL(NCRVLB+1),NASLST)
          IF(IPT.EQ.1)IBEYND=1
        END IF
        IF(U5END.EQ.1.OR.(ALPCHK(CARD(1:1)).AND.IBEYND.EQ.1))GO TO 2
        GO TO 1
C
      ELSE IF(IKEY.GE.198.AND.IKEY.LE.200) THEN
C
C  STEPOPTION, STEP_OPTION
C
        IF(IKEY.EQ.198) THEN
          IF(IPT.LE.0) THEN
            CALL NBFND2(IPT,IPOS)
            IF(IPOS.GT.0) THEN
              IPT=IPOS
            ELSE
              CALL FESTOP(200070)
            END IF
          END IF
          CALL CMATCH(CARD(IPT:256),IPT,256,'OPTION',6,IPOS,1)
          IF(IPOS.GT.0) THEN
            IPT=IPOS
          ELSE
            CALL CMATCH(CARD(IPT:256),IPT,256,'OPTIONS',7,IPOS,1)
            IF(IPOS.GT.0) THEN
              IPT=IPOS
            ELSE
              CALL FESTOP(200070)
            END IF
          END IF
        END IF
        IF(ISOPTN.EQ.1.OR.NTRANS.GT.1) THEN
          CALL FESTOP(200069)
        END IF
        NXPTIS=NXPTI
        CALL ROOMI(1)
        IX(NXPTIS)=0
        ISOPTN=1
        CALL OPTNTR(NOPTNT,INDXT,IVALT,OPTNT,IPT,IPOS,IX(NXPTIS))
        IF(IX(NXPTIS).EQ.1) THEN
          IFLLVL=1
        END IF
        NXPTI=NXPTIS
      ELSE IF(IKEY.EQ.36) THEN
C
C  OPTION
C
        I=IX(NTRANS*12-11)
        CALL OPTNTR(NOPTNV,INDXV,IVALV,OPTNV,IPT,IPOS,IX(I))
      END IF
      IF(IPT.EQ.1) THEN
        GO TO 2
      ELSE
        GO TO 1
      END IF
C
C  The first section of code is executed at the beginning of a
C  new subroutine or at the end of the TRANSFORM specification.
C
   27 CONTINUE
      I=IX(NTRANS*12-11)
      IX(I+4)=ANIDTT
      IX(I+5)=ATSIZE
      IX(I+6)=ANRPTT
      IX(I+7)=ANVREG
      IX(I+8)=ANVRID
      IX(I+9)=ANBY
      IX(NTRANS*12-9)=ANCLBL
      IX(NTRANS*12-8)=ANCLBR
      IX(NTRANS*12-7)=ANVTOT
      IX(NTRANS*12-5)=NPASS+1
C
      IX(NTRANS*12-10)=NXPTI
      K=NXPTI
      IF(ISELEC.EQ.0) THEN
C
C  First, copy critical stored arrays into IX, unless ISELEC>0
C
        I=5*ANCLBL
        CALL ROOMI(I)
        I=RCEIL(8)-ANCLBL+1
        DO 28 J=1,ANCLBL
        IX(K)=BLXINC(I)
        IX(K+1)=BLNCLS(I)
        IX(K+2)=BLCPNT(I)
        IX(K+3)=IX(SICMUL+I-1)
        IX(K+4)=BLXSTR(I)
        I=I+1
        K=K+5
   28   CONTINUE
C
        IF(ANCLBR.GT.0) THEN
          I=2*ANCLBR
          CALL ROOMI(I)
          I=RCEIL(9)-ANCLBR+1
          DO 30 J=1,ANCLBR
          IX(K)=CLTYPE(I)
          IX(K+1)=CLPNT(I)
          I=I+1
          K=K+2
   30     CONTINUE
        END IF
C
        IF(ANVTOT.GT.0) THEN
          CALL ROOMI(ANVTOT)
          I=RCEIL(2)-ANVTOT+1
          DO 31 J=1,ANVTOT
          IX(K)=MSIZE(I)
          I=I+1
          K=K+1
   31     CONTINUE
        END IF
        IF(ANVREG.GT.0) THEN
          I=2*ANVREG
          CALL ROOMI(I)
          I=RCEIL(2)-ANVTOT+1
          DO 32 J=1,ANVREG
          IX(K)=VMAPL(I)
          IX(K+1)=MXSIZE(I)
          I=I+1
          K=K+2
   32     CONTINUE
        END IF
      END IF
C
      IF(NTRANS.EQ.1) THEN
        IF(ISELEC.GT.0) THEN
C
C  Adjust meta-data for SELECT
C
          ISIZE=MSIZE(ISELEC)
          IF(ISELEC.LT.NVTOT) THEN
C
C  First, adjust level, moving any labels above the selected variable
C  down by ISIZE
C
            IF(NCRVL.GT.ISIZE) THEN
              DO 33 LL=LPOINT(ISELEC),NCRVL-ISIZE
              LEVEL(LL)=LEVEL(LL+ISIZE)
   33         CONTINUE
            END IF
C
C  Reduce variable list for any variables above ISELEC
C
            DO 34 I=ISELEC+1,NVTOT
            MTYPE(I-1)=MTYPE(I)
            MSIZE(I-1)=MSIZE(I)
            VNAME(I-1)=VNAME(I)
            LABEL(I-1)=LABEL(I)
            IF(LPOINT(I).GT.0) THEN
              LPOINT(I-1)=LPOINT(I)-ISIZE
            ELSE
              LPOINT(I-1)=0
            END IF
   34       CONTINUE
          END IF
C
C  Adjust contents of CLPNT, etc.
C
          IWARN=0
          I=RCEIL(8)-ANCLBL+1
C
C  ISEL2 is variable number of selected class in upper copy
C
          ISEL2=ISELEC+RCEIL(2)-ANVTOT
          KK=0
          IST=1
          DO 38 J=1,ANCLBL
          BLXSTR(J)=IST
          BLCPNT(J)=KK+1
          IWARNB=1
          IF(BLNCLS(I).GT.0) THEN
            II=BLCPNT(I)
            DO 35 JJ=1,BLNCLS(I)
            IF(CLPNT(II).EQ.ISEL2) THEN
              IWARNB=0
            ELSE
              KK=KK+1
              IF(CLPNT(II).GT.ISEL2) THEN
                CLPNT(KK)=CLPNT(II)-RCEIL(2)+ANVTOT-1
              ELSE
                CLPNT(KK)=CLPNT(II)-RCEIL(2)+ANVTOT
              END IF
              CLTYPE(KK)=CLTYPE(II)
            END IF
            II=II+1
   35       CONTINUE
          END IF
          IF(IWARNB.EQ.1) THEN
            IWARN=1
          ELSE
            BLXSIZ(J)=BLXSIZ(J)/ISIZE
            BLNCLS(J)=BLNCLS(J)-1
            IF(BLNCLS(J).EQ.0) THEN
              BLCPNT(J)=0
            END IF
          END IF
          IX(SICMUL+J-1)=BLXSIZ(J)/BLXINC(J)
          IF(BLVSIZ(J).GT.0) THEN
            IST1=IST
            IF(BLTYPE(J).EQ.1) THEN
              IST1=IST1+1
            END IF
            LL=BLVSTR(J)
C
C  Recreate VMAPL
C
            DO 36 L=1,BLVSIZ(J)
            VMAPL(LL)=IST1
            IST1=IST1+MSIZE(LL)
            LL=LL+1
   36       CONTINUE
          END IF
          IST=IST+BLXSIZ(J)
          I=I+1
   38     CONTINUE
          IF(IWARN.EQ.1) THEN
            WRITE(U6,200)
          END IF
          NVTOT=NVTOT-1
          NCLASS=NCLASS-1
          TSIZE=IST-1
          NCLBAR=KK
          NCRVL=NCRVL-ISIZE
          ISELEC=ISEL2
        ELSE IF (IOUTPT.GT.0) THEN
C
C  Establish space to keep track of which output levels have been
C  assigned.
C
          ISOUTF=NXPTI
          CALL ROOMI(NOUTPT)
          DO 39 I=1,NOUTPT
          IX(ISOUTF+I-1)=0
   39     CONTINUE
C
C  Adjust meta-data for OUTPUT CLASS
C
          IF(IOUTPT.GT.NVTOT) THEN
C
C  If OUTPUT class is not in incoming file
 
C
C  IOUT2 will be the new position of the output class
C
            IOUT2=NVREG+NCLASS+1
C
C  First, adjust variable list.  Move up any labels associated with
C  BY variables, etc.  NCLABV will be the start of these labels, if
C  any.
C
            NCLABV=0
            IF(IOUT2.LE.NVTOT) THEN
              DO 40 I=IOUT2,NVTOT
              IF(NCLABV.EQ.0) THEN
                IF(LPOINT(I).GT.0) THEN
                  NCLABV=LPOINT(I)
                END IF
              END IF
   40         CONTINUE
              IF(NCLABV.GT.0) THEN
                DO 41 I=NCRVLS,NCLABV,-1
                LEVEL(I+NOUTPT)=LEVEL(I)
   41           CONTINUE
              END IF
              MTYPE(NVTOT+2)=MTYPE(NVTOT+1)
              MSIZE(NVTOT+2)=MSIZE(NVTOT+1)
              VNAME(NVTOT+2)=VNAME(NVTOT+1)
              LABEL(NVTOT+2)=LABEL(NVTOT+1)
              DO 42 I=NVTOT,IOUT2,-1
              MTYPE(I+1)=MTYPE(I)
              MSIZE(I+1)=MSIZE(I)
              VNAME(I+1)=VNAME(I)
              LABEL(I+1)=LABEL(I)
              IF(LPOINT(I).GT.0) THEN
                LPOINT(I+1)=LPOINT(I)+NOUTPT
              ELSE
                LPOINT(I+1)=0
              END IF
   42         CONTINUE
              MTYPE(IOUT2)=MTYPE(NVTOT+2)
              MSIZE(IOUT2)=MSIZE(NVTOT+2)
              VNAME(IOUT2)=VNAME(NVTOT+2)
              LABEL(IOUT2)=LABEL(NVTOT+2)
            END IF
            IF(NCLABV.EQ.0)NCLABV=NCRVLS+1
            LPOINT(IOUT2)=NCLABV
            DO 43 I=1,NOUTPT
            LEVEL(NCLABV)=LEVEL(NCRVLS+NOUTPT+I)
            NCLABV=NCLABV+1
   43       CONTINUE
C
C  Adjust contents of CLPNT, etc.
C
            I=RCEIL(8)-ANCLBL+1
            ISIZE=MSIZE(IOUT2)
            KK=0
            IST=1
            DO 46 J=1,ANCLBL
            BLXSTR(J)=IST
            BLCPNT(J)=KK+1
            IF(BLNCLS(I).GT.0) THEN
              II=BLCPNT(I)
              DO 44 JJ=1,BLNCLS(I)
              KK=KK+1
              CLPNT(KK)=CLPNT(II)-RCEIL(2)+ANVTOT
              CLTYPE(KK)=CLTYPE(II)
              II=II+1
   44         CONTINUE
            END IF
            KK=KK+1
            CLPNT(KK)=IOUT2
            CLTYPE(KK)=1
            BLXSIZ(J)=BLXSIZ(J)*ISIZE
            IX(SICMUL+J-1)=BLXSIZ(J)/BLXINC(J)
            BLNCLS(J)=BLNCLS(J)+1
            IF(BLVSIZ(J).GT.0) THEN
              IST1=IST
              IF(BLTYPE(J).EQ.1) THEN
                IST1=IST1+1
              END IF
              LL=BLVSTR(J)
C
C  Recreate VMAPL
C
              DO 45 L=1,BLVSIZ(J)
              VMAPL(LL)=IST1
              IST1=IST1+MSIZE(LL)
              LL=LL+1
   45         CONTINUE
            END IF
            IST=IST+BLXSIZ(J)
            I=I+1
   46       CONTINUE
            NVTOT=NVTOT+1
            NCLASS=NCLASS+1
            TSIZE=IST-1
            NCLBAR=KK
            NCRVL=NCRVLS+NOUTPT
          ELSE
C                  ! OUTPUT class is already present in incoming file
C
C  IOUT2 will be the new position of the output class.
C  In this case (OUTPUT class present in file) IOUT2 is pointing
C  to a class variable.
C
            ISIZE=MSIZE(IOUTPT)
            IOUT2=NVREG+NCLASS
            NCLABV=LPOINT(IOUT2)+MSIZE(IOUT2)
            LL=LPOINT(IOUTPT)+ISIZE
C
C  Move any labels for classes above IOUTPT down by ISIZE
C
            IF(LL.LT.NCLABV) THEN
              DO 47 I=LL,NCLABV-1
              LEVEL(I-ISIZE)=LEVEL(I)
   47         CONTINUE
            END IF
            IF(IOUT2.LT.NVTOT) THEN
C
C  Adjust any labels above the class labels.
C
              IF(NCLABV.LE.NCRVLS) THEN
C
C  If NOUTPT > ISIZE, must move remaining labels up
C
                IF(NOUTPT.GT.ISIZE) THEN
                  DO 461 I=NCRVLS,NCLABV,-1
                  LEVEL(I+NOUTPT-ISIZE)=LEVEL(I)
  461             CONTINUE
C
C  If NOUTPT < ISIZE, must move remaining labels down
C
                ELSE IF(NOUTPT.LT.ISIZE) THEN
                  DO 462 I=NCLABV,NCRVLS
                  LEVEL(I+NOUTPT-ISIZE)=LEVEL(I)
  462             CONTINUE
                END IF
              END IF
            END IF
            LL=NCLABV-ISIZE
C
C  Copy output labels for IOUTPT into place, which begins aT
C  NCLABV-ISIZE
C
            DO 48 I=1,NOUTPT
            LEVEL(LL)=LEVEL(NCRVLS+NOUTPT+I)
            LL=LL+1
   48       CONTINUE
            LPOINT(IOUTPT)=NCLABV-ISIZE
            IF(IOUTPT.LT.IOUT2) THEN
C
C  First, reduce variable list
C
              MTYPE(NVTOT+2)=MTYPE(IOUTPT)
              MSIZE(NVTOT+2)=NOUTPT
              VNAME(NVTOT+2)=VNAME(IOUTPT)
              LABEL(NVTOT+2)=LABEL(IOUTPT)
              LPOINT(NVTOT+2)=LPOINT(IOUTPT)
              DO 50 I=IOUTPT,IOUT2-1
              MTYPE(I)=MTYPE(I+1)
              MSIZE(I)=MSIZE(I+1)
              VNAME(I)=VNAME(I+1)
              LABEL(I)=LABEL(I+1)
C
C  Since the range of IOUTPT to IOUT2 should only contain class
C  variables, adjust LPOINT without checking if it is 0.
C
              LPOINT(I)=LPOINT(I+1)-ISIZE
   50         CONTINUE
              MTYPE(IOUT2)=MTYPE(NVTOT+2)
              MSIZE(IOUT2)=MSIZE(NVTOT+2)
              VNAME(IOUT2)=VNAME(NVTOT+2)
              LABEL(IOUT2)=LABEL(NVTOT+2)
              LPOINT(IOUT2)=LPOINT(NVTOT+2)
            ELSE
              MSIZE(IOUT2)=NOUTPT
            END IF
            IF(IOUT2.LT.NVTOT) THEN
              DO 505 I=IOUT2+1,NVTOT
              IF(LPOINT(I).GT.0) THEN
                LPOINT(I)=LPOINT(I)+NOUTPT-ISIZE
              END IF
  505         CONTINUE
            END IF
C
C  Adjust contents of CLPNT, etc.
C
            I=RCEIL(8)-ANCLBL+1
C
C  IOUTUP is variable number of selected class in upper copy
C
            IOUTUP=IOUTPT+RCEIL(2)-ANVTOT
            KK=0
            IST=1
            DO 54 J=1,ANCLBL
            BLXSTR(J)=IST
            BLCPNT(J)=KK+1
            IWARNB=1
            IF(BLNCLS(I).GT.0) THEN
              II=BLCPNT(I)
              DO 51 JJ=1,BLNCLS(I)
              IF(CLPNT(II).EQ.IOUTUP) THEN
                IF(CLTYPE(II).EQ.1) THEN
                  BLXSIZ(J)=(BLXSIZ(J)/MSIZE(IOUTUP))*MSIZE(IOUT2)
                ELSE
                  BLXSIZ(J)=(BLXSIZ(J)/(MSIZE(IOUTUP)+1))*MSIZE(IOUT2)
                END IF
                IWARNB=0
              ELSE
                KK=KK+1
                IF(CLPNT(II).GT.IOUTUP) THEN
                  CLPNT(KK)=CLPNT(II)-RCEIL(2)+ANVTOT-1
                ELSE
                  CLPNT(KK)=CLPNT(II)-RCEIL(2)+ANVTOT
                END IF
                CLTYPE(KK)=CLTYPE(II)
              END IF
              II=II+1
   51         CONTINUE
              KK=KK+1
              CLPNT(KK)=IOUT2
              CLTYPE(KK)=1
            END IF
            IF(IWARNB.EQ.1) THEN
              CALL FESTOP(130026)
            END IF
            IX(SICMUL+J-1)=BLXSIZ(J)/BLXINC(J)
            IF(BLVSIZ(J).GT.0) THEN
              IST1=IST
              IF(BLTYPE(J).EQ.1) THEN
                IST1=IST1+1
              END IF
              LL=BLVSTR(J)
C
C  Recreate VMAPL
C
              DO 52 L=1,BLVSIZ(J)
              VMAPL(LL)=IST1
              IST1=IST1+MSIZE(LL)
              LL=LL+1
   52         CONTINUE
            END IF
            IST=IST+BLXSIZ(J)
            I=I+1
   54       CONTINUE
            TSIZE=IST-1
            NCLBAR=KK
            NCRVL=NCRVLS+NOUTPT-ISIZE
          END IF
C
C  Update IOUTPT to be new position of output class
C
          IOUTPT=IOUT2
        ELSE
          CALL FESTOP(130027)
        END IF
C
C  Begin to plan out space for incoming and outgoing double data.
C
        NEXTD=NIDTOT+TSIZE+1
        IX(NTRANS*12-4)=NEXTD
        IX(NTRANS*12-3)=NEXTD+NIDTOT
        NEXTD=NEXTD+ANIDTT+ATSIZE
      ELSE
C
C  Plan space for NTRANS > 1
C
        IX(NTRANS*12-4)=NEXTD
        IX(NTRANS*12-3)=NEXTD+ANIDTT
        NEXTD=NEXTD+ANIDTT+ATSIZE
      END IF
C
      IF(IOUTPT.GT.0) THEN
C
C  If OUTPUT CLASS, then determine position in output class.
C
        K=RCEIL(2)-ANVTOT+1
        CALL VNMTCH(VNAME(IOUTPT),VNAME(K),ANVTOT,IOUTUP)
        IF(IOUTUP.GT.0) THEN
          IOUTUP=IOUTUP+K-1
        END IF
        IOUTCL=NXPTI
        NOUTCL=0
        IF(IASLST.GT.0) THEN
          IF(IOUTUP.GT.0) THEN
            IF(NASLST.NE.MSIZE(IOUTUP)) THEN
              CALL FESTOP(130028)
            END IF
            DO 55 I=1,NASLST
            IF(IX(I+IASLST-1).GT.0)NOUTCL=NOUTCL+1
   55       CONTINUE
            I=2*NOUTCL
            CALL ROOMI(I)
            L=IOUTCL
            DO 56 I=1,NASLST
            K=IX(IASLST+I-1)
            IF(K.GT.0) THEN
              IX(L)=I
              IX(L+NOUTCL)=K
              L=L+1
C
C  If a label was provided as part of an AS statement, copy it.
C
              IF(L-IOUTCL.LE.NASVL) THEN
                IL=LPOINT(IOUTPT)
                LEVEL(LPOINT(IOUTPT)+K-1)=LEVEL(NCRVLB+L-IOUTCL)
              END IF
              IF(K.GT.NOUTPT) THEN
                CALL FESTOP(130031)
              ELSE IF(IX(ISOUTF+K-1).GT.0) THEN
                CALL FESTOP(130032)
              ELSE
                IX(ISOUTF+K-1)=NTRANS
              END IF
            END IF
   56       CONTINUE
          ELSE
            IF(NASLST.NE.1) THEN
              CALL FESTOP(130029)
            END IF
            NOUTCL=1
            CALL ROOMI(2)
            K=IX(IASLST)
            IF(K.EQ.0) THEN
              CALL FESTOP(130033)
            ELSE IF(K.GT.NOUTPT) THEN
              CALL FESTOP(130031)
            ELSE IF(IX(ISOUTF+K-1).GT.0) THEN
              CALL FESTOP(130032)
            END IF
            IX(IOUTCL)=0
            IX(IOUTCL+1)=K
            IX(ISOUTF+K-1)=NTRANS
C
C  If label was provided as part of the AS list, then copy it.
C
              IF(NASVL.GT.0) THEN
                IL=LPOINT(IOUTPT)
                LEVEL(LPOINT(IOUTPT)+K-1)=LEVEL(NCRVLB+1)
              END IF
          END IF
        ELSE
C
C  An AS statement has not provided a list of outgoing class(es)
C
          IF(IOUTUP.GT.0) THEN
            NOUTCL=MSIZE(IOUTUP)
            I=2*NOUTCL
            CALL ROOMI(I)
            L=0
            DO 57 I=1,NOUTPT
            IF(IX(ISOUTF+I-1).EQ.0) THEN
              L=L+1
              IX(IOUTCL+L-1)=L
              IX(IOUTCL+NOUTCL+L-1)=I
              IX(ISOUTF+I-1)=NTRANS
              IF(L.EQ.NOUTCL)GO TO 58
            END IF
   57       CONTINUE
            CALL FESTOP(130034)
   58       CONTINUE
          ELSE
            NOUTCL=1
            CALL ROOMI(2)
            DO 59 I=1,NOUTPT
            IF(IX(ISOUTF+I-1).EQ.0) THEN
              IX(IOUTCL)=0
              IX(IOUTCL+1)=I
              IX(ISOUTF+I-1)=NTRANS
              GO TO 60
            END IF
   59       CONTINUE
            CALL FESTOP(130035)
   60       CONTINUE
          END IF
        END IF
C
C  If output class is on incoming file, update level labels, if
C  appropriate.
C
        IF(IOUTUP.GT.0) THEN
          JJ=LPOINT(IOUTUP)-1
          KK=LPOINT(IOUTPT)-1
          DO 61 I=1,NOUTCL
          J=IX(IOUTCL+I-1)
          K=IX(IOUTCL+NOUTCL+I-1)
          IF(LEVEL(KK+K)(1:12).EQ.'            '.AND.
     .       LEVEL(KK+K)(13:24).EQ.LEVEL(KK+K)(1:12)) THEN
            LEVEL(KK+K)=LEVEL(JJ+J)
          END IF
   61     CONTINUE
        END IF
      ELSE
        IOUTCL=NXPTI
        NOUTCL=1
        CALL ROOMI(2)
        IX(IOUTCL)=ISVAL
        IX(IOUTCL+1)=0
      END IF
      NPASSV=NPASS
      CALL MRGSET(IOUTUP,NPASS,IX(IOUTCL),NOUTCL)
 
C
C  If ENDMRG, begin to output.
C
      IF(ENDMRG) THEN
        GO TO 64
      END IF
C
C  INCORPORATE
C
C
      CALL CRDPRN(1)
      IF(IPT.LE.0) THEN
        IPT=20
        CALL NBFND2(IPT,IPOS)
        IF(IPOS.LE.0) THEN
          CALL FESTOP(130025)
        END IF
        IPT=IPOS
      END IF
      NLIST=0
      ILISTX=0
      CALL RINCR(12,NTRANS,1)
      IX(NTRANS*12-11)=NXPTI
      I=NXPTI
      CALL ROOMI(10)
      IX(I+1)=0
      IX(I+2)=0
C                 ! Default is NOIDCHECK with old syntax
      IX(I+3)=0
      ITYPEF(1)=2
      ITYPEF(2)=0
      CALL FNREAD(IPT,ITYPEF,IFILEF,2,IPOSSC)
      IF(IMERR1.GT.0) THEN
        CALL FSTOP
      END IF
      K=IFILEF(1)
      IX(IX(NTRANS*12-11))=K
      IF(K.EQ.0) THEN
        CALL FESTOP(130030)
      END IF
      CALL PREAMD(K)
      IF(AVERSN.EQ.9004) THEN
        ANID=ANVRID+ANBY
      ELSE
        ANID=ANIDTT
      END IF
      ICLBLK=RCEIL(8)-ANCLBL+1
      IV=RCEIL(2)-ANVTOT
      DO 632 J=1,ANCLBL
      IF(BLVSIZ(ICLBLK).GT.0) THEN
        DO 631 I=1,BLVSIZ(ICLBLK)
        IV=IV+1
        MXSIZE(IV)=ICLBLK
  631   CONTINUE
      END IF
      IX(SICMUL+ICLBLK-1)=BLXSIZ(ICLBLK)/BLXINC(ICLBLK)
      ICLBLK=ICLBLK+1
  632 CONTINUE
      IAS=0
      IASLST=0
      NASVL=0
      NCRVLB=NCRVL
C     IF(IPT.EQ.1) THEN
C       GO TO 2
C     ELSE
        GO TO 1
C     END IF
   62 CONTINUE
      ENDMRG=.TRUE.
      GO TO 27
   64 CONTINUE
C
C
C  IX(NTRANS*12-11) = Starting location in IX for options
C  IX(NTRANS*12-10) = Starting location in IX for values copied from
C                     block information arrays
C  IX(NTRANS*12-9)  = Number of blocks (from ANCLBL)
C  IX(NTRANS*12-8)  = Number of elements in class specifications for
C                     block (from ANCLBR)
C  IX(NTRANS*12-7)  = Number of variables (from ANVTOT)
C  IX(NTRANS*12-6)  = 2*Number of variables to move (counting block N's)
C  IX(NTRANS*12-5)  = Starting value of NPASS
C  IX(NTRANS*12-4)  = Starting location for ID
C  IX(NTRANS*12-3)  = Starting location for DX
C
C  SICMUL - starting position in IX for multipliers showing for
C           each block the multiplying effect of class variables.
C           TMOVE1 and TMOVE2 use SICMUL, in COMMON, to locate the
C           array.  Set the array up to full MCLBLK size here.
C
C  First, provide default labels for unspecified levels.
C
      IF(IOUTPT.GT.0) THEN
        I=LPOINT(IOUTPT)
        CALL LEVELD(LEVEL(I),NOUTPT)
      END IF
      CALL PREAMO
      NXPTD=1
      I=IX(NTRANS*12-3)+ATSIZE
      CALL ROOMD(I)
      IF(NBY.EQ.0)NBYGRP=1
      IF(IFLLVL.EQ.0) THEN
        FILLVL=0.
      ELSE
        FILLVL=MISSNG
      END IF
      DO 75 I=1,TSIZE
      DX(I+NIDTOT)=FILLVL
   75 CONTINUE
      DO 90 IBYGRP=1,NBYGRP
      DO 89 IREP=0,NRPTOT
      DO 88 ITRANS=1,NTRANS
      CALL VMREAD(IX(IX(ITRANS*12-11)),ITRANS,IREP,IBYGRP)
      IF(ITRANS.EQ.1) THEN
        J=IX(8)
        DO 65 I=1,NIDTOT
        DX(I)=DX(J)
        J=J+1
   65   CONTINUE
      END IF
      ANCLBL=IX(ITRANS*12-9)
      ANCLBR=IX(ITRANS*12-8)
      ANVTOT=IX(ITRANS*12-7)
      ANVREG=IX(IX(ITRANS*12-11)+7)
      IF(ISELEC.EQ.0) THEN
C
C  First, copy critical stored arrays into IX, unless ISELEC>0
C
        K=IX(ITRANS*12-10)
        I=RCEIL(8)-ANCLBL+1
        DO 66 J=1,ANCLBL
        BLXINC(I)=IX(K)
        BLNCLS(I)=IX(K+1)
        BLCPNT(I)=IX(K+2)
        IX(SICMUL+I-1)=IX(K+3)
        BLXSTR(I)=IX(K+4)
        I=I+1
        K=K+5
   66   CONTINUE
C
        IF(ANCLBR.GT.0) THEN
          I=RCEIL(9)-ANCLBR+1
          DO 68 J=1,ANCLBR
          CLTYPE(I)=IX(K)
          CLPNT(I)=IX(K+1)
          I=I+1
          K=K+2
   68     CONTINUE
        END IF
C
        IF(ANVTOT.GT.0) THEN
          I=RCEIL(2)-ANVTOT+1
          DO 70 J=1,ANVTOT
          MSIZE(I)=IX(K)
          I=I+1
          K=K+1
   70     CONTINUE
        END IF
        IF(ANVREG.GT.0) THEN
          I=RCEIL(2)-ANVTOT+1
          DO 71 J=1,ANVREG
          VMAPL(I)=IX(K)
          MXSIZE(I)=IX(K+1)
          I=I+1
          K=K+2
   71     CONTINUE
        END IF
      END IF
      DO 86 IPASS=IX(ITRANS*12-5),IX(ITRANS*12-5)+IX(ITRANS*12-6)-1,2
      ICLSS=V3(IPASS)
      IF(V2(IPASS).EQ.9) THEN
        ICLBLK=V1(IPASS)
      ELSE
        ICLBLK=MXSIZE(V1(IPASS))
      END IF
      ISN=BLXSTR(ICLBLK)
      INCN=BLXINC(ICLBLK)
      INC=INCN
C
C  For N of block, location has already been determined.
C  Otherwise, find location and increment of variable.
C
      IF(V2(IPASS).EQ.9) THEN
        IS=ISN+IX(ITRANS*12-3)-1
      ELSE
        IS=VMAPL(V1(IPASS))+IX(ITRANS*12-3)-1
      END IF
      IF(ICLSS.GT.0) THEN
        CALL TMOVE1(IS,INC,ISN,INCN,NXPTD,1,
     .    IX(ICLSS+2),IX(ICLSS),ICLBLK,V1(IPASS),V2(IPASS))
      ELSE
        CALL TMOVE1(IS,INC,ISN,INCN,NXPTD,1,IX,0,ICLBLK,V1(IPASS),
     .    V2(IPASS))
      END IF
      ICLSS=V3(IPASS+1)
      IF(V2(IPASS+1).EQ.9) THEN
        ICLBLK=V1(IPASS+1)
      ELSE
        ICLBLK=MXSIZE(V1(IPASS+1))
      END IF
      ISN=BLXSTR(ICLBLK)
      INCN=BLXINC(ICLBLK)
      INC=INCN
C
C  For N of block, location and increment has already been determined.
C  Otherwise, find location and increment of variable.
C
      IF(V2(IPASS+1).EQ.9) THEN
        IS=ISN+NIDTOT
      ELSE
        IS=VMAPL(V1(IPASS+1))+NIDTOT
      END IF
      IPASS1=IPASS+1
      CALL TMOVE2(IPASS1,IS,INC,NXPTD,1,ICLBLK)
   86 CONTINUE
   88 CONTINUE
      WRITE(11)(DX(I),I=1,NIDTOT)
      CALL UNFOUT(11,DX(NIDTOT+1),TSIZE)
   89 CONTINUE
   90 CONTINUE
      CLOSE(11)
      DO 92 ITRANS=1,NTRANS
      CLOSE(UNIT=IX(IX(ITRANS*12-11)))
   92 CONTINUE
      RETURN
C
C  Return to 27 to complete the processing of the last subroutine,
C  if any, before exiting the routine
C
      END
C
C
      SUBROUTINE MRGSET(IOUTUP,NPASS,IMCLSS,NOUTCL)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER IOUTUP,NOUTCL
      INTEGER IMCLSS(NOUTCL,2)
C
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
C
      PARAMETER (MTRANS=1500,MRANGS=20)
      PARAMETER (MTRSZI=MSIZEI+6*MRANGE-6*MRANGS+2*MRNSET+MRECOD+MVAR)
      PARAMETER (IXFLLD=49+3*MAXIDS)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,
     . BLVSIZ,BLNCLS,BLCPNT,CLTYPE,CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,
     . CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /VABLCK/AVERSN,ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT,
     . ATYPE,AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR,ANID,ANCRSS,ANCRVL,
     . AVNCRS,ANBYGR,ASDBID,ANRPTT,ASDCOF
      INTEGER  AVERSN,ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT,
     . ATYPE,AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR,ANID,ANCRSS,ANCRVL,
     . AVNCRS,ANBYGR,ASDBID,ANRPTT,ASDCOF
C
      INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID,
     . SDWRK,VKEEPF,ISTEPC,ISELEC,IOUTPT,IAS,IASLST,NCRVLB,NASVL,
     . IFLLVL,IXFILL(IXFLLD)
      COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,
     . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF,
     . IFLLVL,ISTEPC,ISELEC,IOUTPT,IAS,IASLST,NCRVLB,NASVL,IXFILL
C
      COMMON /STMBLK/IX,RANGE,RGROUP,RTYPE,RSTPNT,V1,V2,V3,MXSIZE,
     . IOUT,IOUTL
      DOUBLE PRECISION RANGE(2,MRANGS)
      INTEGER IX(MTRSZI),RGROUP(MRANGS),RTYPE(MRANGS),RSTPNT(MRECOD),
     . V1(MRECOD),V2(MRECOD),V3(MRECOD),MXSIZE(MVAR),IOUT(MVAR),
     . IOUTL(MVAR)
C
  200 FORMAT(/,' Mismatch on block:',8X,I6,/,
     .         ' Associated classes output:',I6,/,
     .         ' Associated classes input: ',I6)
  201 FORMAT(/,' Block:',I6,' in output file includes class:',A12,',',
     . /,' which is expected but not found on the input file')
  202 FORMAT(/,' Block:',I6,' class:',A12,', size mismatch')
  203 FORMAT(/,' Mismatch for ',A12)
  204 FORMAT(/,' Classes for output block:')
  205 FORMAT(3X,A12)
  206 FORMAT(/,' No classes for output block')
  207 FORMAT(/,' Classes for input block:')
  208 FORMAT(/,' No classes for input block')
  101 FORMAT(1X,I7,8X,I7)
C
C  All matrices from the file are read into the ends of the respective
C  allocated storage.  Many pointer arrays are adjusted to the resulting
C  positions.
C
C  Adjusted arrays:
C  BLCPNT  - pointer for class information
C  CLPNT   - pointer to class variables
C  CDMPNT  - pointer to dimension information
C  LPOINT  - pointer to level labels
C
C  Unadjusted arrays, giving only relative positions:
C  BLXSTR  - pointer to first cell of incoming data in X matrix
C  BLVSTR  - pointer to first variable
C  VMAPL   - pointer to starting location for variable
C
C
C  ANVTOT  - total number of variables on file
C  ANVREG  - number of variables, excluding class, variance id's,
C            BY variables, and weight variable
C  ANCLSS  - total number of class variables
C  ANVRID  - number of variance id's, excluding BY variables
C  ANBY    - number of BY variables
C  ANWGT   - 0 or 1 indicating unweighted vs. weighted analysis
C  ATYPE   - type of input used to create the file
C  AVROPT  - variance option
C  ATSIZE  - total size of matrix
C  ANCLBL  - total number of class blocks
C  ANCLBR  - total size of class block information arrays
C
C
C  Create matrix of starting positions and increments first.
C  Save NPASSV to find out how many new variables are created,
C  including N of block but excluding classes.
C
      NPASSV=NPASS
      NXPTIS=NXPTI
      JCLBLK=RCEIL(8)-ANCLBL+1
      ISTART=RCEIL(2)-ANVTOT+1+ANVREG
C                                      ! Start of incoming class
      DO 50 ICLBLK=1,NCLBLK
C
C  First, check if block has matching class specifications.
C
      IF(IOUTPT.GT.0) THEN
C                               ! OUTPUT CLASS
        IF(IOUTUP.GT.0) THEN
C                               ! OUTPUT CLASS present in incoming
          MCHTYP=1
C                               ! OUTPUT CLASS in both
          IF(BLNCLS(ICLBLK).NE.BLNCLS(JCLBLK)) THEN
            K=JCLBLK-RCEIL(8)+ANCLBL
            IMERR1=130101
C
C  Transfer to 55 to write out class variables in block
C
            GO TO 55
          END IF
          ILIM1=BLNCLS(ICLBLK)
        ELSE
C                               ! OUTPUT CLASS not present
          MCHTYP=2
C                               ! OUTPUT CLASS output only
          IF(BLNCLS(ICLBLK).NE.BLNCLS(JCLBLK)+1) THEN
            K=JCLBLK-RCEIL(8)+ANCLBL
            IMERR1=130102
            GO TO 55
          END IF
          ILIM1=BLNCLS(ICLBLK)-1
        END IF
      ELSE
C                               ! SELECT
C
        IF(BLNCLS(ICLBLK).NE.BLNCLS(JCLBLK)-1.AND.
     .     BLNCLS(ICLBLK).NE.BLNCLS(JCLBLK)) THEN
          K=JCLBLK-RCEIL(8)+ANCLBL
          IMERR1=130103
          GO TO 55
        END IF
        IF(BLNCLS(ICLBLK).EQ.BLNCLS(JCLBLK)-1) THEN
          MCHTYP=3
C                               ! SELECT CLASS in block
        ELSE
          MCHTYP=4
C                               ! SELECT CLASS not in block
        END IF
        ILIM1=BLNCLS(ICLBLK)
      END IF
C
      IF(ILIM1.EQ.0.AND.MCHTYP.NE.3) THEN
C                                          ! No classes output, and
        ICLSS1=0
C                                          ! class not selected
      ELSE
C                               ! Set up CLSCAN equivalent array
        ICLSS1=NXPTI
        ISIZE=1
        K=ICLSS1+5
        CALL ROOMI(5)
        ICLBAR=BLCPNT(ICLBLK)
        IF(ILIM1.GT.0) THEN
          DO 10 I=1,ILIM1
C                               ! loop over outgoing classes
          LL=CLPNT(ICLBAR)
          JL=BLCPNT(JCLBLK)
          CALL VNMTCH(VNAME(LL),VNAME(ISTART),ANCLSS,L)
          L=L+ISTART-1
C                               ! matching class in upper array
          IF(L.EQ.0) THEN
            WRITE(U6,201)ICLBLK,VNAME(LL)
            IMERR1=130104
            GO TO 55
          END IF
          DO 2 JCLBAR=BLCPNT(JCLBLK),BLCPNT(JCLBLK)+BLNCLS(JCLBLK)-1
          IF(L.EQ.CLPNT(JCLBAR)) GO TO 4
    2     CONTINUE
          WRITE(U6,201)ICLBLK,VNAME(LL)
C                                        ! Class not found in incoming
          IMERR1=130104
          GO TO 55
    4     CONTINUE
          IF(I.LT.ILIM1.OR.MCHTYP.NE.1) THEN
C                                                      ! Except for
            IF(CLTYPE(ICLBAR).NE.CLTYPE(JCLBAR)) THEN
C                                                      ! OUTPUT CLASS
              WRITE(U6,202)ICLBLK,VNAME(LL)
C                                                      ! CLTYPE, MSIZE,
              IMERR1=130105
C                                                      ! etc. must match
              GO TO 55
            END IF
            IF(MSIZE(LL).NE.MSIZE(L)) THEN
              WRITE(U6,202)ICLBLK,VNAME(LL)
              IMERR1=130106
              GO TO 55
            END IF
            IF(CLTYPE(JCLBAR).EQ.0) THEN
C                                                      ! Set up arrays
              ISIZE=ISIZE*(MSIZE(L)+1)
C                                                      ! as CLSCAN
              DO 6 J=0,MSIZE(L)
C                                                      ! equivalents
              CALL ROOMI(3)
              IX(K)=L
              IX(K+1)=J
              IX(K+2)=J+1
              K=K+3
    6         CONTINUE
            ELSE
              ISIZE=ISIZE*MSIZE(L)
              CALL ROOMI(3)
              IX(K)=L
              IX(K+1)=0
              IX(K+2)=0
              K=K+3
            END IF
          ELSE
C                                                      ! OUTPUT CLASS
            DO 8 J=1,NOUTCL
C                                                      ! in both
            CALL ROOMI(3)
            IX(K)=L
            IX(K+1)=IMCLSS(J,1)
            IX(K+2)=J
            K=K+3
    8       CONTINUE
            ISIZE=ISIZE*NOUTCL
          END IF
          ICLBAR=ICLBAR+1
   10     CONTINUE
        END IF
        IF(MCHTYP.EQ.3) THEN
C                                                      ! For SELECTED
          CALL ROOMI(3)
C                                                      ! CLASS
          IX(K)=ISELEC
          IX(K+1)=IMCLSS(1,1)
          IX(K+2)=1
          K=K+3
        END IF
        IX(ICLSS1)=(K-ICLSS1)/3-1
        IX(ICLSS1+1)=ISIZE
        IX(ICLSS1+2)=IX(ICLSS1)
        IX(ICLSS1+3)=0
        IX(ICLSS1+4)=0
      END IF
C
      IF(BLNCLS(ICLBLK).EQ.0) THEN
C                                                      ! For output
        ICLSS2=0
      ELSE
C                                                      ! Set up CLSCAN
        ICLSS2=NXPTI
C                                                      ! equivalent
        ISIZE=1
C                                                      ! array
        K=ICLSS2+5
        CALL ROOMI(5)
        ICLBAR=BLCPNT(ICLBLK)
        DO 20 I=1,BLNCLS(ICLBLK)
        LL=CLPNT(ICLBAR)
        IF(I.LT.BLNCLS(ICLBLK).OR.MCHTYP.GT.2) THEN
          IF(CLTYPE(ICLBAR).EQ.0) THEN
            ISIZE=ISIZE*(MSIZE(LL)+1)
            DO 16 J=0,MSIZE(LL)
            CALL ROOMI(3)
            IX(K)=LL
            IX(K+1)=J
            IX(K+2)=J+1
            K=K+3
   16       CONTINUE
          ELSE
            ISIZE=ISIZE*MSIZE(LL)
            CALL ROOMI(3)
            IX(K)=LL
            IX(K+1)=0
            IX(K+2)=0
            K=K+3
          END IF
        ELSE
C                            ! Array entries for matching OUTPUT CLASS
          DO 18 J=1,NOUTCL
          CALL ROOMI(3)
          IX(K)=LL
          IX(K+1)=IMCLSS(J,2)
          IX(K+2)=J
          K=K+3
   18     CONTINUE
          ISIZE=ISIZE*NOUTCL
        END IF
        ICLBAR=ICLBAR+1
   20   CONTINUE
        IX(ICLSS2)=(K-ICLSS2)/3-1
        IX(ICLSS2+1)=ISIZE
        IX(ICLSS2+2)=IX(ICLSS2)
        IX(ICLSS2+3)=0
        IX(ICLSS2+4)=0
      END IF
      IF(BLTYPE(ICLBLK).EQ.1.AND.BLTYPE(JCLBLK).EQ.1) THEN
C                                                          ! Copy N
        CALL RINCR(4,NPASS,2)
C                                                          ! of block
        V1(NPASS-1)=JCLBLK
        V2(NPASS-1)=9
        V3(NPASS-1)=ICLSS1
        V1(NPASS)=ICLBLK
        V2(NPASS)=9
        V3(NPASS)=ICLSS2
      END IF
      IF(BLVSIZ(ICLBLK).GT.0.AND.BLVSIZ(JCLBLK).GT.0) THEN
        DO 40 IVIN=BLVSTR(ICLBLK),BLVSTR(ICLBLK)+BLVSIZ(ICLBLK)-1
        K=RCEIL(2)-ANVTOT+BLVSTR(JCLBLK)
        CALL VNMTCH(VNAME(IVIN),VNAME(K),BLVSIZ(JCLBLK),L)
        IF(L.NE.0) THEN
C                                         ! Matching var
          L=K+L-1
          IF(NTRANS.GT.1) THEN
C                                         ! For INCORPORATEd files
            IF(MTYPE(IVIN).NE.MTYPE(L)) THEN
              WRITE(U6,203)VNAME(IVIN)
              IMERR1=130107
              GO TO 62
            ELSE IF(MSIZE(IVIN).NE.MSIZE(L)) THEN
              WRITE(U6,203)VNAME(IVIN)
              IMERR1=130108
              GO TO 62
            ELSE IF(MTYPE(IVIN).EQ.8.OR.MTYPE(IVIN).EQ.9.OR.
     .              MTYPE(IVIN).EQ.19) THEN
              I=CDMPNT(IVIN)
              IJ=CDMPNT(L)
              DO 24 II=I,I+CROSSD(I)
              IF(CROSSD(II).NE.CROSSD(IJ)) THEN
                WRITE(U6,203)VNAME(IVIN)
                IMERR1=130109
                GO TO 62
              END IF
              IJ=IJ+1
   24         CONTINUE
            END IF
          ELSE IF(MCHTYP.EQ.3.AND.IMCLSS(1,1).EQ.0) THEN
            IF(MTYPE(IVIN).GT.10.AND.MTYPE(IVIN).LE.20) THEN
              WRITE(U6,203)MTYPE(IVIN)
              IMERR1=130110
              GO TO 62
            END IF
          END IF
          CALL RINCR(4,NPASS,2)
          V1(NPASS-1)=L
          V2(NPASS-1)=0
          V3(NPASS-1)=ICLSS1
          V1(NPASS)=IVIN
          V2(NPASS)=0
          V3(NPASS)=ICLSS2
        END IF
   40   CONTINUE
      END IF
      JCLBLK=JCLBLK+1
   50 CONTINUE
      IX(NTRANS*12-6)=NPASS-NPASSV
      RETURN
C
C  For mismatching classes, write information
C
 
   55 CONTINUE
      WRITE(U6,200)ICLBLK,BLNCLS(ICLBLK),BLNCLS(JCLBLK)
      IF(BLNCLS(ICLBLK).EQ.0) THEN
        WRITE(U6,206)
      ELSE
        WRITE(U6,204)
        DO 57 ICLBAR=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1
        WRITE(U6,205)VNAME(CLPNT(ICLBAR))
   57   CONTINUE
      END IF
      IF(BLNCLS(JCLBLK).EQ.0) THEN
        WRITE(U6,208)
      ELSE
        WRITE(U6,207)
        DO 60 ICLBAR=BLCPNT(JCLBLK),BLCPNT(JCLBLK)+BLNCLS(JCLBLK)-1
        WRITE(U6,205)VNAME(CLPNT(ICLBAR))
   60   CONTINUE
      END IF
   62 CONTINUE
      IF(U5.GE.13.AND.U5.LE.17) THEN
        RETURN
      ELSE
        CALL FSTOP
      END IF
      END
C
      SUBROUTINE VMREAD(IXM,ITRANS,IREP,IBYGRP)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      INTEGER IXM(10),ITRANS
C
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
C
      PARAMETER (MTRANS=1500,MRANGS=20)
      PARAMETER (MTRSZI=MSIZEI+6*MRANGE-6*MRANGS+2*MRNSET+MRECOD+MVAR)
      PARAMETER (IXFLLD=49+3*MAXIDS)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,
     . BLVSIZ,BLNCLS,BLCPNT,CLTYPE,CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,
     . CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /VABLCK/AVERSN,ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT,
     . ATYPE,AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR,ANID,ANCRSS,ANCRVL,
     . AVNCRS,ANBYGR,ASDBID,ANRPTT,ASDCOF
      INTEGER  AVERSN,ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT,
     . ATYPE,AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR,ANID,ANCRSS,ANCRVL,
     . AVNCRS,ANBYGR,ASDBID,ANRPTT,ASDCOF
C
      INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID,
     . SDWRK,VKEEPF,ISTEPC,ISELEC,IOUTPT,IAS,IASLST,NCRVLB,NASVL,
     . IFLLVL,IXFILL(IXFLLD)
      COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,
     . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF,
     . ISTEPC,ISELEC,IOUTPT,IAS,IASLST,NCRVLB,NASVL,IFLLVL,IXFILL
C
      COMMON /STMBLK/IX,RANGE,RGROUP,RTYPE,RSTPNT,V1,V2,V3,MXSIZE,
     . IOUT,IOUTL
      DOUBLE PRECISION RANGE(2,MRANGS)
      INTEGER IX(MTRSZI),RGROUP(MRANGS),RTYPE(MRANGS),RSTPNT(MRECOD),
     . V1(MRECOD),V2(MRECOD),V3(MRECOD),MXSIZE(MVAR),IOUT(MVAR),
     . IOUTL(MVAR)
C
      LOGICAL ENDFLE
C
  201 FORMAT(' MISMATCH OF VARIANCE IDS - PRIMARY FILE:',3(/,5X,3F22.3))
  202 FORMAT(' VPLX FILE ASSIGNED TO UNIT',I3,' IDS:',3(/,5X,3F22.3))
  203 FORMAT(' MISMATCH OF BY IDS - PRIMARY FILE:',3(/,5X,3F22.3))
C
C  IXM(1) - FORTRAN unit
C  IXM(2) - 1 unit on end of file (not used)
C  IXM(3) - read option
C           0 = not given (i.e., default option)
C           1 = FULL
C           2 = CONSTANTS
C           3 = REPLICATE
C           4 = BYREPEAT
C  IXM(4) - ID checking option
C           0 = no checking
C           1 = check
C  IXM(5) - ANIDTT - length of ID on file
C  IXM(6) - ATSIZE - total size of matrix
C  IXM(7) - ANRPTT - number of replicates
C  IXM(8) - ANVREG - number of regular variables
C  IXM(9) - ANVRID - number of variance IDs
C  IXM(10)- ANBY   - number of BY variables
C
      IDSTRT=IX(12*ITRANS-4)
      IDXSTR=IX(12*ITRANS-3)
C
C  IREAD  - keeps track of read status
C         = 0 use previously read values
C         = 1 read from VPLX file
C
      IREAD=0
C
      IF(IREP.EQ.0.AND.IBYGRP.EQ.1.AND.IXM(3).EQ.2) THEN
C
C  If OPTION CONSTANT, read only if IFIRST
C
        IREAD=1
      ELSE IF(IXM(3).EQ.1) THEN
C
C  Under FULL, read only for full samples.
C
        IF(IREP.EQ.0) THEN
          IREAD=1
          IF(IBYGRP.GT.1.AND.IXM(7).GT.0) THEN
C
C         SPACE VPLX FILE TO NEXT BY GROUP HERE
C
            DO 2 I=1,IXM(7)
            READ(IXM(1),END=94)(DX(IDSTRT+J-1),J=1,IXM(5))
            CALL UNFIN(IXM(1),DX(IDXSTR),IXM(6),ENDFLE)
            IF(ENDFLE)GO TO 94
    2       CONTINUE
          END IF
        END IF
      ELSE IF(IXM(3).EQ.0.OR.IXM(3).EQ.3.OR.IXM(3).EQ.4) THEN
C
C  OPTION REPLICATE (default), or BYREPEAT - read for each replicate.
C
        IREAD=1
C
C  OPTION BYREPEAT - rewind file if replicate 0 of second or
C  later BY group.  PREAMD will allocate space for ids and coefficients:
C  free up the space.
C
        IF(IXM(3).EQ.4) THEN
          IF(IREP.EQ.0.AND.IBYGRP.GT.0) THEN
            REWIND(UNIT=IXM(1))
            NXPTD2=NXPTD
            CALL PREAMD(IXM(1))
            NXPTD=NXPTD2
          END IF
        END IF
      END IF
C
C
      IF(IREAD.EQ.1) THEN
C
C       READ VPLX FILE
C
        READ(IXM(1),END=94)(DX(IDSTRT+J-1),J=1,IXM(5))
        IF(IXM(4).EQ.1) THEN
C                                                     ! IDCHECK
          IF(IREP.GT.0.AND.(IXM(3).EQ.3.OR.IXM(3).EQ.4)) THEN
            DO 10 J=1,NVARID
            IF(DABS(DX(IDSTRT+J-1)-DX(IX(8)+J-1)).GT..1D-03) GO TO 11
   10       CONTINUE
            GO TO 12
   11       CONTINUE
            WRITE(U6,201)(DX(IX(8)+J-1),J=1,NVARID)
            WRITE(U6,202)IXM(1),(DX(IDSTRT+J-1),J=1,NVARID)
            CALL FESTOP(130201)
   12       CONTINUE
          END IF
        END IF
        IF(IXM(3).EQ.1.OR.IXM(3).EQ.3) THEN
          DO 15 J=1,NBY
          IF(DABS(DX(IDSTRT+IXM(9)+J-1)-DX(IX(8)+NVARID+J-1)).GT.
     .      .1D-03) GO TO 16
   15     CONTINUE
          GO TO 17
   16     CONTINUE
          WRITE(U6,203)(DX(IX(8)+NVARID+J-1),J=1,NBY)
          WRITE(U6,202)IXM(1),(DX(IDSTRT+IXM(9)+J-1),J=1,NBY)
          CALL FESTOP(130202)
   17     CONTINUE
        END IF
        CALL UNFIN(IXM(1),DX(IDXSTR),IXM(6),ENDFLE)
        IF(ENDFLE)GO TO 94
      END IF
      RETURN
   94 CONTINUE
      CALL FESTOP(130200)
      END
C
      SUBROUTINE NMERGE(IXM,LNMAP,LNECHO)
C
C  Note: Usage of storage and common blocks has been largely patterned
C        after the TRANSFORM step.
C
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (IXDIM=13)
      INTEGER IXM(IXDIM,*),LNMAP(*),LNECHO(*)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MTRANS=1500,MRANGS=20)
      PARAMETER (MTRSZI=MSIZEI+6*MRANGE-6*MRANGS+2*MRNSET+MRECOD+MVAR)
      PARAMETER (IXFLLD=49+3*MAXIDS)
      PARAMETER (NOPTNT=4,NOPTNV=10)
      PARAMETER (MAXFMT=20)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
C
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STMBLK/IX,RANGE,RGROUP,RTYPE,RSTPNT,V1,V2,V3,MXSIZE,
     . IOUT,IOUTL
      DOUBLE PRECISION RANGE(2,MRANGS)
      INTEGER IX(MTRSZI),RGROUP(MRANGS),RTYPE(MRANGS),RSTPNT(MRECOD),
     . V1(MRECOD),V2(MRECOD),V3(MRECOD),MXSIZE(MVAR),IOUT(MVAR),
     . IOUTL(MVAR)
C
C  Usage in this subroutine:
C  V1     - Variable number (or block no. if V2=9)
C  V2     - Transformation code (used to indicate n(block) only)
C  V3     - Pointer to CLASS specification
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
      INTEGER VTMPSZ
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
      CHARACTER*256 CARDWK,CARDSV,CARDIM
      COMMON /CMBLK2/CARDWK,CARDSV,CARDIM
C
      LOGICAL REFRSH,ALPCHK,ICHECK
      EXTERNAL REFRSH,ALPCHK,ICHECK
C
      INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID,
     . SDWRK,VKEEPF,ISTEPC,ISELEC,IOUTPT,IAS,IASLST,NCRVLB,NASVL,
     . IFLLVL,IXFILL(IXFLLD)
      COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,
     . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF,
     . IFLLVL,ISTEPC,ISELEC,IOUTPT,IAS,IASLST,NCRVLB,NASVL,IXFILL
C
      COMMON /VABLCK/AVERSN,ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT,
     . ATYPE,AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR,ANID,ANCRSS,ANCRVL,
     . AVNCRS,ANBYGR,ASDBID,ANRPTT,ASDCOF
      INTEGER  AVERSN,ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT,
     . ATYPE,AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR,ANID,ANCRSS,ANCRVL,
     . AVNCRS,ANBYGR,ASDBID,ANRPTT,ASDCOF
C
C
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
      INTEGER ITYPEF(3),IFILEF(3)
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
C  Usage in this subroutine:
C
C  BLVSTR  -  (Values from primary input saved to include in output
C              file.)  Beginning variable of block.
C  BLVSIZ  -  read from incoming file, used to compute block numbers
C             in MXSIZE.
C  BLNCLS  -  number of classes in block
C  BLCPNT  -  pointer for classes to CLPNT and CLTYPE
C  CLPNT   -  used as pointers to class variables
C
C
      LOGICAL ENDMRG
      CHARACTER*12 OPTNT(NOPTNT),OPTNV(NOPTNV)
      INTEGER INDXT(NOPTNT),INDXV(NOPTNV)
      INTEGER IVALT(NOPTNT),IVALV(NOPTNV)
      DATA OPTNT /    'ZEROFILL    ','MISSINGFILL ','ZERO        ',
     .                'MISSING     '/
      DATA OPTNV /    'BYGROUP     ','CONSTANTS   ','REPLICATE   ',
     .                'CONSTANT    ','FULL        ','BYREPEAT    ',
     .                'REPEAT      ','IDCHECK     ','NOIDCHECK   ',
     .                'FULLSAMPLE  '/
      DATA INDXV/3,3,3,3,3,3,3,4,4,3/
      DATA INDXT/1,1,1,1/
      DATA IVALT/0,1,0,1/
      DATA IVALV/1,2,3,2,1,4,4,1,0,1/
C
  100 FORMAT(/,' Note: Fortran unit',I3,' assigned to ',A40)
  101 FORMAT(/,' Note: Fortran unit',I3,' assigned to ',/,1X,A80)
  200 FORMAT(/,5X,'WARNING: The SELECT variable is not associated with',
     . ' one or more blocks')
  201 FORMAT(5X,'WARNING: Because this file lacks BY variables, BYREPE',
     .'AT is default')
  202 FORMAT(5X,'WARNING: Because this file lacks BY variables, CONSTA',
     .'NTS is default')
  203 FORMAT(' REPLICATES ON INCORPORATED FILE',I8,' VS. PRIMARY',I8)
  204 FORMAT(5X,'WARNING: Coefficients for variance calculation differ',
     . ' from primary.',/,14X,'Largest difference is',D14.6)
  205 FORMAT(/,' ERROR ON FILE ASSIGNED TO FORTRAN UNIT',I3,/)
C
C  Initializations.
C    NPASS    - index to variable arguments to copy
C               Each variable to be copied requires 2 levels of NPASS:
C               One for INCORPORATEd file and one for merged file.
C
      NPASS=0
C
C  VMERGE has already reserved space in IX
C    IX(1) - IX(12*MTRANS)  Space to indicate transformations (merge
C                           information)
C    IX(12*MTRANS+1) - IX(12*MTRANS+MCLBLK) - SICMUL=12*NTRANS+1 -
C            start of IX array with multipliers for blocks used by
C            TMOVE2
C
C  IX(NTRANS*12-11) = Starting location in IX for options
C  IX(NTRANS*12-10) = Starting location in IX for values copied from
C                     block information arrays
C  IX(NTRANS*12-9)  = Number of blocks (from ANCLBL)
C  IX(NTRANS*12-8)  = Number of elements in class specifications for
C                     block (from ANCLBR)
C  IX(NTRANS*12-7)  = Number of variables (from ANVTOT)
C  IX(NTRANS*12-6)  = 2*Number of variables to move (counting block N)
C  IX(NTRANS*12-5)  = Starting value of NPASS
C  IX(NTRANS*12-4)  = Starting location for ID
C  IX(NTRANS*12-3)  = Starting location for DX
C
C
      VTMPSZ=MVAR-SVTEMP+1
C                            ! Note: not used
C
C  ISELEC - class variable identified by SELECT
C  IOUTPT - class variable identified by OUTPUT class
C  IAS    - class variable identified by AS
C  IASLST - pointer in IX to list from AS
C  NASLST - number of elements in ASTLST list
C  NCRVLB - if labels are read with an AS statement, they will be
C           read after this point
C  NASVL  - number of labels read after as AS statement.
C
C     ISELEC=0
C     IOUTPT=0
C     IAS=0
C     IASLST=0
C     NCRVLB=NCRVL
C     NASVL=0
C
      U5ECSV=U5ECHO
      U5ECHO=0
      REWIND(14)
      U5=15
      ILINE=1
      READ(14)CARD
C
C  Most of the routine falls within a loop to 1 CONTINUE.  The loop
C  is over the statements identified and organized by CMPAR1.
C  The listing file has already been written to 13 (all as unformatted
C  character data of length 256).  For each statement, the contents
C  of CARD will be read from 14 and written to 15, which will then
C  be the input read by REFRSH, etc. and parsed in detail here and
C  in related routines.
C
      ENDMRG=.FALSE.
      DO 1 ISTATE=1,NSTATE
C
      REWIND(15)
      U5END=0
C
C  If starting position for this statement is beyond the current
C  position of 14, read necessary records.  Otherwise, restore
C  CARD from CARDSV
C
      IF(ILINE.LT.IXM(8,ISTATE)) THEN
        DO 3 I=ILINE+1,IXM(8,ISTATE)
        READ(14)CARD
    3   CONTINUE
        ILINE=IXM(8,ISTATE)
      ELSE IF(ISTATE.NE.1) THEN
        CARD=CARDSV
      END IF
C
C  LNCNTR is set to the current position in the overall file
C  here.  Calls to REFRSH increment LNCNTR as records are read
C  from 15.
C
      LNCNTR=IXM(8,ISTATE)
C
C  Construct the first line where parsing of the statement should
C  begin in CARDWK.  For safety, blank out any characters leading
C  up to the starting point.
C
      CARDWK=CARD
      I=IXM(9,ISTATE)-1
      CALL STBLNK(CARDWK,1,I)
C
C  If this is also the last line of the statement, blank out
C  anything following the ending ;
C
      IF(ILINE.EQ.IXM(3,ISTATE)) THEN
        K=IXM(4,ISTATE)+1
        CALL STBLNK(CARDWK,K,256)
      END IF
      WRITE(15)CARDWK
C
C  Read and process remaining lines.  In all cases, save the
C  current line from 14 in CARDSV
C
      IF(ILINE.LT.IXM(3,ISTATE)) THEN
        DO 4 I=ILINE+1,IXM(3,ISTATE)
        READ(14)CARD
        IF(I.EQ.IXM(3,ISTATE)) THEN
          CARDSV=CARD
          K=IXM(4,ISTATE)+1
          CARDWK=CARD
          CALL STBLNK(CARDWK,K,256)
          WRITE(15)CARDWK
        ELSE
          WRITE(15)CARD
        END IF
    4   CONTINUE
        ILINE=IXM(3,ISTATE)
      ELSE
        CARDSV=CARD
      END IF
      REWIND(15)
      READ(15)CARD
C
C  IPT is the starting position for parsing.  In many cases, it
C  is the position beyond a key word.
C
      IPT=IXM(9,ISTATE)
C
      IF(IXM(5,ISTATE).NE.16) THEN
C                                      ! inappropriate key word,
        IF(ISTEPC.EQ.1) THEN
C                                      ! unexpected arithmetic statement
          IMERR1=130036
C                                      ! etc.
        ELSE
          IMERR1=130037
        END IF
        ILINE=IXM(1,ISTATE)
        IMERR2=IXM(2,ISTATE)
        CALL CMPRNT(IXM,LNMAP)
      END IF
C
C  AS              8,6
C  SELECT          7,1
C  STEPOPTION      2,15
C  STEP            2,14
C  OPTION          2,11
C  INCORPORATE     8,7
C  OUTPUT CLASS    7,25
C  DROP            7,6
C  KEEP            2,7
C
      IGROUP=IXM(10,ISTATE)
      IKEY=IXM(11,ISTATE)
      IF(IGROUP.EQ.7.AND.(IKEY.EQ.1.OR.IKEY.EQ.25)) THEN
C
C  SELECT (7,1) OUTPUT (7,25)
C
C  Determine class variable to use
C  Find level to select and edit for completeness
C
C  Error messages if both SELECT and OUTPUT appear.
C
        IF(IKEY.EQ.1) THEN
C                                     ! SELECT
          IF(ISELEC.GT.0) THEN
C                                     ! previous SELECT
            IF(ISTEPC.EQ.1) THEN
              IMERR1=130003
            ELSE
              IMERR1=130038
            END IF
          ELSE IF(IOUTPT.GT.0) THEN
            IMERR1=130004
          END IF
        ELSE
C                                     ! OUTPUT
          IF(IOUTPT.GT.0) THEN
            IMERR1=130005
          ELSE IF(ISELEC.GT.0) THEN
            IMERR1=130019
          END IF
        END IF
        IF(IMERR1.GT.0) THEN
          ILINE=IXM(1,ISTATE)
          IMERR2=IXM(2,ISTATE)
          CALL CMPRNT(IXM,LNMAP)
        END IF
C
        CALL CMATCH(CARD(IPT:256),IPT,256,'CLASS',5,IPOS,1)
        IF(IPOS.GT.0) THEN
          CALL NBFND2(IPOS,IPT)
C                                       ! CLASS is optional
        END IF
C                                       ! (undocumented)
        MAXVN=RCEIL(2)-NVTOT-ANVTOT-2
        IF(MAXVN.LE.0) THEN
C                                       ! Error if not enough room
          K=ANVTOT+2
C                                       ! for variable names.
          CALL RCHECK(2,NVIN,K)
        END IF
        CALL VNFIND(IPT,VNAME(NVIN+1),MAXVN,N,IPOS,2,VNAME,NVIN)
        IF(N.EQ.0) THEN
          IMERR1=130006
          IMERR2=IPT
        ELSE IF(N.GT.1) THEN
C                                       ! Accept only one variable name
          IMERR1=130007
          IMERR2=IPOS
        END IF
        IF(IMERR1.GT.0) THEN
          ILINE=LNCNTR
          CALL CMPRNT(IXM,LNMAP)
        END IF
        CALL VNMTCH(VNAME(NVIN+1),VNAME,NVIN,K)
C
C  If the provided variable name does not match, accept only if
C  OUTPUT, if output class has not been previously identified by AS.
C
        IF(K.EQ.0) THEN
          IF(IKEY.EQ.1) THEN
C                                    ! SELECT
            IMERR1=130008
          ELSE IF(IAS.GT.0) THEN
C                                    ! If class variable already named
            IMERR1=130020
C                                    ! in AS statement, must agree
          ELSE
            CALL RINCR(2,NVIN,1)
C                                    ! Add new OUTPUT CLASS to end of
            K=NVIN
C                                    ! variable list
            MTYPE(NVIN)=4
            IOUTPT=NVIN
            LABEL(NVIN)(1:12)=VNAME(NVIN)
            LABEL(NVIN)(13:24)='            '
          END IF
C
C  If variable has appeared, make sure it is a class variable, etc.
C
        ELSE
          IF(MTYPE(K).NE.4) THEN
            IMERR1=130009
          ELSE
            IF(IKEY.EQ.1) THEN
C                                    ! SELECT
              ISELEC=K
            ELSE
              IF(IAS.GT.0.AND.IAS.NE.K) THEN
                IMERR1=130020
              END IF
              IOUTPT=K
            END IF
          END IF
        END IF
        IF(IMERR1.GT.0) THEN
          ILINE=LNCNTR
          IMERR2=IPT
          CALL CMPRNT(IXM,LNMAP)
        END IF
C
C  Search for "(ISVAL)"
C
        CALL NBFND2(IPOS,IPT)
        IF(CARD(IPT:IPT).NE.'(') THEN
          IMERR1=130010
        ELSE
          IPOS=IPT+1
          CALL NBFND2(IPOS,IPT)
          CALL IFIND(CARD(IPT:256),IPT,256,IPOS,ISVAL)
          IF(IPOS.EQ.0) THEN
            IMERR1=130011
          ELSE
C
C  For SELECT, edit ISVAL.
C
            IF(IKEY.EQ.1) THEN
C                                   ! SELECT
              IF(ISVAL.LT.0.OR.ISVAL.GT.MSIZE(ISELEC)) THEN
                IMERR1=130012
              END IF
              NOUTPT=1
            ELSE
C                                   ! OUTPUT CLASS
              IF(ISVAL.LE.0) THEN
                IMERR1=130011
              END IF
              NOUTPT=ISVAL
              IF(IAS.GT.NVTOT) THEN
C                                   ! If previous AS statement has
                MSIZE(IAS)=NOUTPT
C                                   ! named a new class variable
              END IF
C                                   ! store size here
            END IF
          END IF
        END IF
        IF(IMERR1.GT.0) THEN
          ILINE=LNCNTR
          IMERR2=IPT
          CALL CMPRNT(IXM,LNMAP)
        END IF
        CALL NBFND2(IPOS,IPT)
        IF(CARD(IPT:IPT).NE.')') THEN
          IMERR1=130013
          IMERR2=IPT
          ILINE=LNCNTR
          CALL CMPRNT(IXM,LNMAP)
        END IF
        IPOS=IPT+1
C
C  Store labels and other information for the new class in the
C  slot NVTOT+1 above the number of variables in the incoming file.
C  This positioning anticipates the later moving around of labels.
C
        IF(IKEY.EQ.25) THEN
C                                     ! OUTPUT
          K=NVTOT+1
          MSIZE(K)=NOUTPT
C
C  Deliberately leave space of NOUTPT in LEVEL array.  Values of
C  LEVEL stored here will have to be moved later.
C
          LPOINT(K)=NCRVL+NOUTPT+1
          NCRVLB=NCRVL+2*NOUTPT
          I=2*NOUTPT+NASVL
          CALL RCHECK(7,NCRVL,I)
C                                     ! Check for enough room for labels
C
C  If levels have been read with a previous AS statement, move them.
C
          IF(NASVL.GT.0) THEN
            DO 19 I=1,NASVL
            LEVEL(NCRVLB+I)=LEVEL(NCRVL+I)
   19       CONTINUE
          END IF
C
          CALL NBFND2(IPOS,IPT)
          NCRVLS=NCRVL
          CALL RINCR(7,NCRVL,NOUTPT)
          DO 20 I=1,NOUTPT
          CALL RINCR(7,NCRVL,1)
C                                                   ! LEVELD called
          LEVEL(NCRVL)(1:12)='            '
C                                                   ! from VMERGE
          LEVEL(NCRVL)(13:24)=LEVEL(NCRVL)(1:12)
C                                                   ! later for
   20     CONTINUE
C                                                   ! defaults
          IF(IPT.GT.1) THEN
            CALL LEVELR(IPT,IPOS,NL,
C                                                   ! For now, store
     .                  LEVEL(NCRVLS+NOUTPT+1),
C                                                   ! labels at
     .                  NOUTPT)
C                                                   ! NCRVLS+NOUTPT+1
          END IF
        END IF
        CALL NBFND2(IPOS,IPT)
        IF(CARD(IPT:IPT).NE.';') THEN
          IMERR1=130040
          IMERR2=IPT
          ILINE=LNCNTR
          CALL CMPRNT(IXM,LNMAP)
        END IF
C
      ELSE IF(IGROUP.EQ.8.AND.IKEY.EQ.6) THEN
C                                               ! AS (8,6)
C
C
C  Determine if class name has been given
C
C  Read list of variables.
C
        IF(ISELEC.GT.0) THEN
          IMERR1=130014
        ELSE IF(IAS.GT.0) THEN
          IMERR1=130021
        END IF
        IF(IMERR1.GT.0) THEN
          ILINE=LNCNTR
          IMERR2=IPT
          CALL CMPRNT(IXM,LNMAP)
        END IF
        MAXVN=RCEIL(2)-ANVTOT-NVTOT-2
        IF(MAXVN.LE.0) THEN
          K=ANVTOT+2
          CALL RCHECK(2,NVIN,ANVTOT)
        END IF
        CALL VNFIND(IPT,VNAME(NVIN+1),MAXVN,N,IPOS,2,VNAME,NVIN)
C
        IF(N.GT.1) THEN
          IMERR1=130016
        ELSE IF(N.EQ.1) THEN
          IPT=IPOS
          CALL VNMTCH(VNAME(NVIN+1),VNAME,NVIN,K)
C
C  Accept unmatching name only if OUTPUT has not already appeared.
C
          IF(K.EQ.0) THEN
            IF(IOUTPT.GT.0) THEN
              IMERR1=130018
            ELSE
              CALL RINCR(2,NVIN,1)
              MTYPE(NVIN)=4
              MSIZE(NVIN)=0
C                                       ! Size to be determined later
              IAS=NVIN
              LABEL(NVIN)(1:12)=VNAME(NVIN)
              LABEL(NVIN)(13:24)='            '
            END IF
          ELSE
            IF(MTYPE(K).NE.4) THEN
              IMERR1=130009
            ELSE
              IAS=K
              IF(IOUTPT.GT.0) THEN
                IF(K.NE.IOUTPT) THEN
                  IMERR1=130017
                END IF
              END IF
            END IF
          END IF
        END IF
        IF(IMERR1.GT.0) THEN
          ILINE=LNCNTR
          CALL CMPRNT(IXM,LNMAP)
        END IF
        CALL NBFND2(IPT,IPOS)
C
C  Read the disposition list.
C
        IF(CARD(IPT:IPT).NE.'(') THEN
          IMERR1=130010
          ILINE=LNCNTR
          IMERR2=IPT
          CALL CMPRNT(IXM,LNMAP)
        ELSE
          IPOS=IPT+1
          CALL NBFND2(IPOS,IPT)
        END IF
        CALL RNSCAN(IPT,IPOS,RANGE,MRANGS,RTYPE,RGROUP,
     .        NR,3,LEVEL,1)
        IF(IPOS.EQ.0.OR.NR.LE.0) THEN
          IMERR1=130022
          ILINE=LNCNTR
          CALL CMPRNT(IXM,LNMAP)
        END IF
        IPT=IPOS
C                                   ! IPOS set to 1 beyond ')' by RNSCAN
        IASLST=NXPTI
        IASNOW=IASLST-1
        DO 24 I=1,NR
        IF(RTYPE(I).EQ.5) THEN
C                                   ! 5 MISSING
          IMERR1=130023
        ELSE
          IF(RTYPE(I).EQ.1.OR.
C                                   ! 1 value1 - value2
     .       RTYPE(I).EQ.3.OR.
C                                   ! 3 value - HIGH
     .       RTYPE(I).EQ.6) THEN
C                                   ! 6 value - n
            ILOW=RANGE(1,I)+.1D-7
          ELSE
C                                   ! 2  LOW - value
            ILOW=1
C                                   ! 4  LOW - HIGH
          END IF
          IF(RTYPE(I).EQ.1.OR.RTYPE(I).EQ.2) THEN
            IHIGH=RANGE(2,I)
          ELSE
            IF(ILOW.EQ.1) THEN
              IF(MSIZE(IAS).EQ.0) THEN
C                                        ! When 1-HIGH, interpret as
                IMERR1=130024
C                                        ! determined by MSIZE(IAS)
              ELSE
                IHIGH=MSIZE(IAS)
              END IF
            ELSE
              IF(IOUTPT.GT.0) THEN
C                                        ! For other n-HIGH, interpret
                IHIGH=NOUTPT
C                                        ! HIGH as governed by size
              ELSE
C                                        ! of output class
                IMERR1=130024
              END IF
            END IF
          END IF
          IF(IMERR1.EQ.0) THEN
            DO 22 J=ILOW,IHIGH
C                                        ! Identify elements of range
            CALL ROOMI(1)
            IASNOW=IASNOW+1
            IX(IASNOW)=J
   22       CONTINUE
          END IF
        END IF
        IF(IMERR1.GT.0) THEN
          ILINE=LNCNTR
          CALL CMPRNT(IXM,LNMAP)
        END IF
   24   CONTINUE
C
C  Note: NASLST is the length of the specification.
C        This will be checked for consistency later.
C
        NASLST=IASNOW-IASLST+1
C
C  Check for the presence of labels.
C
        CALL NBFND2(IPT,IPOS)
        IF(CARD(IPOS:IPOS).NE.';') THEN
          IPT=IPOS
          CALL LEVELR(IPT,IPOS,NASVL,LEVEL(NCRVLB+1),NASLST)
          IF(IPOS.NE.0) THEN
            CALL NBFND2(IPOS,IPT)
            IF(CARD(IPT:IPT).NE.';') THEN
              IMERR1=130040
              IMERR2=IPT
            END IF
          ELSE
            IMERR1=130040
          END IF
          IF(IMERR1.GT.0) THEN
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
        END IF
C
      ELSE IF(IGROUP.EQ.2.AND.(IKEY.EQ.14.OR.IKEY.EQ.15)) THEN
C
C  STEP OPTION, STEPOPTION, STEP_OPTION
C
        IF(IKEY.EQ.14) THEN
C                                        ! STEP
          CALL NBFND2(IPT,IPOS)
          IPT=IPOS
          CALL CMATCH(CARD(IPT:256),IPT,256,'OPTION',6,IPOS,1)
          IF(IPOS.GT.0) THEN
            IPT=IPOS
          ELSE
            CALL CMATCH(CARD(IPT:256),IPT,256,'OPTIONS',7,IPOS,1)
            IF(IPOS.GT.0) THEN
              IPT=IPOS
            ELSE
              IMERR1=200070
              IMERR2=IPT
              ILINE=LNCNTR
              CALL CMPRNT(IXM,LNMAP)
            END IF
          END IF
        END IF
        IF(ISOPTN.EQ.1.OR.NTRANS.GT.1) THEN
C                                            ! STEP OPTION must be set
          IMERR1=130041
C                                            ! at beginning
          ILINE=LNCNTR
          CALL CMPRNT(IXM,LNMAP)
        END IF
        NXPTIS=NXPTI
        CALL ROOMI(1)
        IX(NXPTIS)=0
        ISOPTN=1
C                                       ! Flag that step options set
        CALL OPTNTR(NOPTNT,INDXT,IVALT,OPTNT,IPT,IPOS,IX(NXPTIS))
        IF(IX(NXPTIS).EQ.1) THEN
          IFLLVL=1
C                                       ! MISSINGFILL
        END IF
        NXPTI=NXPTIS
        CALL NBFND2(IPOS,IPT)
        IF(CARD(IPT:IPT).NE.';') THEN
          IMERR1=130040
          IMERR2=IPT
          ILINE=LNCNTR
          CALL CMPRNT(IXM,LNMAP)
        END IF
      ELSE IF(IGROUP.EQ.2.AND.IKEY.EQ.11) THEN
C                                               ! OPTION
        IF(NTRANS.EQ.1) THEN
          IMERR1=130042
          ILINE=IXM(1,ISTATE)
          IMERR2=IXM(2,ISTATE)
          CALL CMPRNT(IXM,LNMAP)
        END IF
        I=IX(NTRANS*12-11)
        CALL OPTNTR(NOPTNV,INDXV,IVALV,OPTNV,IPT,IPOS,IX(I))
        CALL NBFND2(IPOS,IPT)
        IF(CARD(IPT:IPT).NE.';') THEN
          IMERR1=130040
          IMERR2=IPT
          ILINE=LNCNTR
          CALL CMPRNT(IXM,LNMAP)
        END IF
      ELSE IF(IGROUP.NE.8.OR.IKEY.NE.7) THEN
C                                               ! If not INCORPORATE,
        IF(ISTEPC.EQ.1) THEN
C                                               ! error
          IMERR1=130036
C                                               ! FUTURE: add DROP, KEEP
        ELSE
          IMERR1=130037
        END IF
        ILINE=IXM(1,ISTATE)
        IMERR2=IXM(2,ISTATE)
        CALL CMPRNT(IXM,LNMAP)
      END IF
C
      IF(ISTATE.LT.NSTATE.AND.
C                                               ! End of loop unless at
     .  (IGROUP.NE.8.OR.IKEY.NE.7)) GO TO 1
C                                               ! last statement or
   64 CONTINUE
C                                               ! INCORPORATE
      I=IX(NTRANS*12-11)
C                                   ! This section completes processing
      IX(I+4)=ANIDTT
C                                   ! for a file (either IN= or
      IX(I+5)=ATSIZE
C                                   ! INCORPORATE)
      IX(I+6)=ANRPTT
      IX(I+7)=ANVREG
      IX(I+8)=ANVRID
      IX(I+9)=ANBY
      IX(NTRANS*12-9)=ANCLBL
      IX(NTRANS*12-8)=ANCLBR
      IX(NTRANS*12-7)=ANVTOT
      IX(NTRANS*12-5)=NPASS+1
C
      IX(NTRANS*12-10)=NXPTI
      K=NXPTI
      IF(ISELEC.EQ.0) THEN
C
C  First, copy critical stored arrays into IX, unless ISELEC>0
C
        I=5*ANCLBL
        CALL ROOMI(I)
        I=RCEIL(8)-ANCLBL+1
C                                   ! Information stored at upper
        DO 28 J=1,ANCLBL
C                                   ! end of arrays by PREAMD are
        IX(K)=BLXINC(I)
C                                   ! saved in IX
        IX(K+1)=BLNCLS(I)
        IX(K+2)=BLCPNT(I)
        IX(K+3)=IX(SICMUL+I-1)
        IX(K+4)=BLXSTR(I)
        I=I+1
        K=K+5
   28   CONTINUE
C
        IF(ANCLBR.GT.0) THEN
          I=2*ANCLBR
          CALL ROOMI(I)
          I=RCEIL(9)-ANCLBR+1
          DO 30 J=1,ANCLBR
          IX(K)=CLTYPE(I)
          IX(K+1)=CLPNT(I)
          I=I+1
          K=K+2
   30     CONTINUE
        END IF
C
        IF(ANVTOT.GT.0) THEN
          CALL ROOMI(ANVTOT)
          I=RCEIL(2)-ANVTOT+1
          DO 31 J=1,ANVTOT
          IX(K)=MSIZE(I)
          I=I+1
          K=K+1
   31     CONTINUE
        END IF
        IF(ANVREG.GT.0) THEN
          I=2*ANVREG
          CALL ROOMI(I)
          I=RCEIL(2)-ANVTOT+1
          DO 32 J=1,ANVREG
          IX(K)=VMAPL(I)
          IX(K+1)=MXSIZE(I)
          I=I+1
          K=K+2
   32     CONTINUE
        END IF
      END IF
C
      IF(NTRANS.EQ.1) THEN
C                                      ! For primary file (IN =)
        IF(ISELEC.GT.0) THEN
C
C  Adjust meta-data for SELECT
C
          ISIZE=MSIZE(ISELEC)
          IF(ISELEC.LT.NVTOT) THEN
C
C  First, adjust level, moving any labels above the selected variable
C  down by ISIZE
C
C           IF(NCRVL.GT.ISIZE) THEN   ! changed 7/1/98
C
            IF(NCRVL.GE.ISIZE+LPOINT(ISELEC)) THEN
              DO 33 LL=LPOINT(ISELEC),NCRVL-ISIZE
              LEVEL(LL)=LEVEL(LL+ISIZE)
   33         CONTINUE
            END IF
C
C  Reduce variable list for any variables above ISELEC
C
            DO 34 I=ISELEC+1,NVTOT
            MTYPE(I-1)=MTYPE(I)
            MSIZE(I-1)=MSIZE(I)
            VNAME(I-1)=VNAME(I)
            LABEL(I-1)=LABEL(I)
            IF(LPOINT(I).GT.0) THEN
              LPOINT(I-1)=LPOINT(I)-ISIZE
            ELSE
              LPOINT(I-1)=0
            END IF
   34       CONTINUE
          END IF
C
C  Adjust contents of CLPNT, etc.
C
          IWARN=0
          I=RCEIL(8)-ANCLBL+1
C                               ! location of block information in
 
C                               ! copy at upper end
C
C  ISEL2 is variable number of selected class in upper copy
C
          ISEL2=ISELEC+RCEIL(2)-ANVTOT
          KK=0
          IST=1
          DO 38 J=1,ANCLBL
          BLXSTR(J)=IST
          BLCPNT(J)=KK+1
          IWARNB=1
C                               ! selected class not yet found
          IF(BLNCLS(I).GT.0) THEN
            II=BLCPNT(I)
            DO 35 JJ=1,BLNCLS(I)
            IF(CLPNT(II).EQ.ISEL2) THEN
              IWARNB=0
C                               ! selected class found in block
            ELSE
              KK=KK+1
              IF(CLPNT(II).GT.ISEL2) THEN
                CLPNT(KK)=CLPNT(II)-RCEIL(2)+ANVTOT-1
              ELSE
                CLPNT(KK)=CLPNT(II)-RCEIL(2)+ANVTOT
              END IF
              CLTYPE(KK)=CLTYPE(II)
            END IF
            II=II+1
   35       CONTINUE
          END IF
          IF(IWARNB.EQ.1) THEN
            IWARN=1
C                                   ! class variable not found
          ELSE
            BLXSIZ(J)=BLXSIZ(J)/ISIZE
            BLNCLS(J)=BLNCLS(J)-1
            IF(BLNCLS(J).EQ.0) THEN
C                                   ! change BLPCNT if no remaining
              BLCPNT(J)=0
C                                   ! class variables
            END IF
          END IF
          IX(SICMUL+J-1)=BLXSIZ(J)/BLXINC(J)
          IF(BLVSIZ(J).GT.0) THEN
            IST1=IST
            IF(BLTYPE(J).EQ.1) THEN
              IST1=IST1+1
            END IF
            LL=BLVSTR(J)
C
C  Recreate VMAPL
C
            DO 36 L=1,BLVSIZ(J)
            VMAPL(LL)=IST1
            IST1=IST1+MSIZE(LL)
            LL=LL+1
   36       CONTINUE
          END IF
          IST=IST+BLXSIZ(J)
          I=I+1
   38     CONTINUE
          IF(IWARN.EQ.1) THEN
            WRITE(U6,200)
          END IF
          NVTOT=NVTOT-1
          NCLASS=NCLASS-1
          TSIZE=IST-1
          NCLBAR=KK
          NCRVL=NCRVL-ISIZE
          ISELEC=ISEL2
C                                      ! Change ISELEC to point to
 
C                                      ! upper value
        ELSE IF (IOUTPT.GT.0) THEN
C                                      ! OUTPUT CLASS
C
C  Establish space to keep track of which output levels have been
C  assigned.
C
          ISOUTF=NXPTI
C                                      ! IX(ISOUTF) - array of flags
          CALL ROOMI(NOUTPT)
C                                      ! for assigned levels
          DO 39 I=1,NOUTPT
          IX(ISOUTF+I-1)=0
   39     CONTINUE
C
C  Adjust meta-data for OUTPUT CLASS
C
          IF(IOUTPT.GT.NVTOT) THEN
C                                      ! OUTPUT CLASS is a new var
C
C  IOUT2 will be the new position of the output class
C
            IOUT2=NVREG+NCLASS+1
C
C  First, adjust variable list.  Move up any labels associated with
C  BY variables, etc.  NCLABV will be the start of these labels, if
C  any.
C
            NCLABV=0
            IF(IOUT2.LE.NVTOT) THEN
              DO 40 I=IOUT2,NVTOT
              IF(NCLABV.EQ.0) THEN
                IF(LPOINT(I).GT.0) THEN
                  NCLABV=LPOINT(I)
                END IF
              END IF
   40         CONTINUE
              IF(NCLABV.GT.0) THEN
                DO 41 I=NCRVLS,NCLABV,-1
                LEVEL(I+NOUTPT)=LEVEL(I)
   41           CONTINUE
              END IF
              MTYPE(NVTOT+2)=MTYPE(NVTOT+1)
C                                             ! Move MTYPE, etc. for
              MSIZE(NVTOT+2)=MSIZE(NVTOT+1)
C                                             ! new output var up by
              VNAME(NVTOT+2)=VNAME(NVTOT+1)
C                                             ! 1
              LABEL(NVTOT+2)=LABEL(NVTOT+1)
              DO 42 I=NVTOT,IOUT2,-1
C                                             ! Move existing var. up
              MTYPE(I+1)=MTYPE(I)
C                                             ! by 1
              MSIZE(I+1)=MSIZE(I)
              VNAME(I+1)=VNAME(I)
              LABEL(I+1)=LABEL(I)
              IF(LPOINT(I).GT.0) THEN
                LPOINT(I+1)=LPOINT(I)+NOUTPT
              ELSE
                LPOINT(I+1)=0
              END IF
   42         CONTINUE
              MTYPE(IOUT2)=MTYPE(NVTOT+2)
C                                             ! Insert for new var
              MSIZE(IOUT2)=MSIZE(NVTOT+2)
              VNAME(IOUT2)=VNAME(NVTOT+2)
              LABEL(IOUT2)=LABEL(NVTOT+2)
            END IF
            IF(NCLABV.EQ.0)NCLABV=NCRVLS+1
C                                             ! Adjust LPOINT
            LPOINT(IOUT2)=NCLABV
            DO 43 I=1,NOUTPT
            LEVEL(NCLABV)=LEVEL(NCRVLS+NOUTPT+I)
            NCLABV=NCLABV+1
   43       CONTINUE
C
C  Adjust contents of CLPNT, etc.
C
            I=RCEIL(8)-ANCLBL+1
            ISIZE=MSIZE(IOUT2)
            KK=0
            IST=1
            DO 46 J=1,ANCLBL
            BLXSTR(J)=IST
            BLCPNT(J)=KK+1
            IF(BLNCLS(I).GT.0) THEN
              II=BLCPNT(I)
              DO 44 JJ=1,BLNCLS(I)
              KK=KK+1
              CLPNT(KK)=CLPNT(II)-RCEIL(2)+ANVTOT
              CLTYPE(KK)=CLTYPE(II)
              II=II+1
   44         CONTINUE
            END IF
            KK=KK+1
            CLPNT(KK)=IOUT2
C                                     ! Add new class to end of list
            CLTYPE(KK)=1
C                                     ! for block
            BLXSIZ(J)=BLXSIZ(J)*ISIZE
            IX(SICMUL+J-1)=BLXSIZ(J)/BLXINC(J)
            BLNCLS(J)=BLNCLS(J)+1
            IF(BLVSIZ(J).GT.0) THEN
C                                     ! If reg. vars in block
              IST1=IST
              IF(BLTYPE(J).EQ.1) THEN
                IST1=IST1+1
              END IF
              LL=BLVSTR(J)
C
C  Recreate VMAPL
C
              DO 45 L=1,BLVSIZ(J)
              VMAPL(LL)=IST1
              IST1=IST1+MSIZE(LL)
              LL=LL+1
   45         CONTINUE
            END IF
            IST=IST+BLXSIZ(J)
            I=I+1
   46       CONTINUE
            NVTOT=NVTOT+1
            NCLASS=NCLASS+1
            TSIZE=IST-1
            NCLBAR=KK
            NCRVL=NCRVLS+NOUTPT
          ELSE
C
C  OUTPUT class is already present in incoming file
C
C
C  IOUT2 will be the new position of the output class.
C  In this case (OUTPUT class present in file) IOUT2 is pointing
C  to a class variable.  Put IOUT2 at the end of the class list.
C
            ISIZE=MSIZE(IOUTPT)
            IOUT2=NVREG+NCLASS
            NCLABV=LPOINT(IOUT2)+MSIZE(IOUT2)
            LL=LPOINT(IOUTPT)+ISIZE
C
C  Move any labels for classes above IOUTPT down by ISIZE
C
            IF(LL.LT.NCLABV) THEN
              DO 47 I=LL,NCLABV-1
              LEVEL(I-ISIZE)=LEVEL(I)
   47         CONTINUE
            END IF
            IF(IOUT2.LT.NVTOT.AND.NCLABV.LE.NCRVLS) THEN
C
C  Adjust any labels above the class labels.
C
C
C  If NOUTPT > ISIZE, must move remaining labels up
C
              IF(NOUTPT.GT.ISIZE) THEN
                DO 461 I=NCRVLS,NCLABV,-1
                LEVEL(I+NOUTPT-ISIZE)=LEVEL(I)
  461           CONTINUE
C
C  If NOUTPT < ISIZE, must move remaining labels down
C
              ELSE IF(NOUTPT.LT.ISIZE) THEN
                DO 462 I=NCLABV,NCRVLS
                LEVEL(I+NOUTPT-ISIZE)=LEVEL(I)
  462           CONTINUE
              END IF
            END IF
            LL=NCLABV-ISIZE
            LPOINT(IOUTPT)=LL
C
C  Copy output labels for IOUTPT into place, which begins at
C  NCLABV-ISIZE
C
            DO 48 I=1,NOUTPT
            LEVEL(LL)=LEVEL(NCRVLS+NOUTPT+I)
            LL=LL+1
   48       CONTINUE
            IF(IOUTPT.LT.IOUT2) THEN
C
C  First, reduce variable list
C
              MTYPE(NVTOT+2)=MTYPE(IOUTPT)
              MSIZE(NVTOT+2)=NOUTPT
              VNAME(NVTOT+2)=VNAME(IOUTPT)
              LABEL(NVTOT+2)=LABEL(IOUTPT)
              LPOINT(NVTOT+2)=LPOINT(IOUTPT)
              DO 50 I=IOUTPT,IOUT2-1
              MTYPE(I)=MTYPE(I+1)
              MSIZE(I)=MSIZE(I+1)
              VNAME(I)=VNAME(I+1)
              LABEL(I)=LABEL(I+1)
C
C  Since the range of IOUTPT to IOUT2 should only contain class
C  variables, adjust LPOINT without checking if it is 0.
C
              LPOINT(I)=LPOINT(I+1)-ISIZE
   50         CONTINUE
              MTYPE(IOUT2)=MTYPE(NVTOT+2)
              MSIZE(IOUT2)=MSIZE(NVTOT+2)
              VNAME(IOUT2)=VNAME(NVTOT+2)
              LABEL(IOUT2)=LABEL(NVTOT+2)
              LPOINT(IOUT2)=LPOINT(NVTOT+2)
            ELSE
C                                           ! If output class in place
              MSIZE(IOUT2)=NOUTPT
            END IF
            IF(IOUT2.LT.NVTOT) THEN
C                                           ! Adjust LPOINT for
              DO 505 I=IOUT2+1,NVTOT
C                                           ! other vars
              IF(LPOINT(I).GT.0) THEN
                LPOINT(I)=LPOINT(I)+NOUTPT-ISIZE
              END IF
  505         CONTINUE
            END IF
C
C  Adjust contents of CLPNT, etc.
C
            I=RCEIL(8)-ANCLBL+1
C
C  IOUTUP is variable number of selected class in upper copy
C
            IOUTUP=IOUTPT+RCEIL(2)-ANVTOT
            KK=0
            IST=1
            DO 54 J=1,ANCLBL
            BLXSTR(J)=IST
            BLCPNT(J)=KK+1
            IWARNB=1
            IF(BLNCLS(I).GT.0) THEN
              II=BLCPNT(I)
              DO 51 JJ=1,BLNCLS(I)
              IF(CLPNT(II).EQ.IOUTUP) THEN
                IF(CLTYPE(II).EQ.1) THEN
                  BLXSIZ(J)=(BLXSIZ(J)/MSIZE(IOUTUP))*MSIZE(IOUT2)
                ELSE
                  BLXSIZ(J)=(BLXSIZ(J)/(MSIZE(IOUTUP)+1))*MSIZE(IOUT2)
                END IF
                IWARNB=0
              ELSE
                KK=KK+1
                IF(CLPNT(II).GT.IOUTUP) THEN
                  CLPNT(KK)=CLPNT(II)-RCEIL(2)+ANVTOT-1
                ELSE
                  CLPNT(KK)=CLPNT(II)-RCEIL(2)+ANVTOT
                END IF
                CLTYPE(KK)=CLTYPE(II)
              END IF
              II=II+1
   51         CONTINUE
              KK=KK+1
              CLPNT(KK)=IOUT2
              CLTYPE(KK)=1
            END IF
            IF(IWARNB.EQ.1) THEN
C                                    ! Require presence of IOUT in
              IMERR1=130026
C                                    ! each block
              ILINE=LNCNTR
              CALL CMPRNT(IXM,LNMAP)
            END IF
            IX(SICMUL+J-1)=BLXSIZ(J)/BLXINC(J)
            IF(BLVSIZ(J).GT.0) THEN
              IST1=IST
              IF(BLTYPE(J).EQ.1) THEN
                IST1=IST1+1
              END IF
              LL=BLVSTR(J)
C
C  Recreate VMAPL
C
              DO 52 L=1,BLVSIZ(J)
              VMAPL(LL)=IST1
              IST1=IST1+MSIZE(LL)
              LL=LL+1
   52         CONTINUE
            END IF
            IST=IST+BLXSIZ(J)
            I=I+1
   54       CONTINUE
            TSIZE=IST-1
            NCLBAR=KK
            NCRVL=NCRVLS+NOUTPT-ISIZE
          END IF
C
C  Update IOUTPT to be new position of output class
C
          IOUTPT=IOUT2
        ELSE
          IMERR1=130027
          ILINE=LNCNTR
          CALL CMPRNT(IXM,LNMAP)
        END IF
C
C  Begin to plan out space for incoming and outgoing double data.
C
        NEXTD=NIDTOT+TSIZE+1
        IX(NTRANS*12-4)=NEXTD
        IX(NTRANS*12-3)=NEXTD+NIDTOT
        NEXTD=NEXTD+ANIDTT+ATSIZE
      ELSE
C                                  !  NTRANS > 1
C
C  Plan space for NTRANS > 1
C
        IX(NTRANS*12-4)=NEXTD
        IX(NTRANS*12-3)=NEXTD+ANIDTT
        NEXTD=NEXTD+ANIDTT+ATSIZE
C
C  IX(3) - read option
C          0 = not given (i.e., default option)
C          1 = FULL, FULLSAMPLE
C          2 = CONSTANTS
C          3 = REPLICATE
C          4 = BYREPEAT
C  IX(4) - ID checking option
C          0 = no checking
C          1 = check
C
        I=IX(NTRANS*12-11)
        IF(IX(I+2).EQ.0) THEN
          IF(ANRPTT.GT.0) THEN
            IF(NBY.GT.0.AND.ANBY.EQ.0) THEN
              IX(I+2)=4
              WRITE(U6,201)
            ELSE
              IX(I+2)=3
            END IF
          ELSE
C                      ! ANRPTT = 0
            IF(NBY.GT.0.AND.ANBY.EQ.0) THEN
              IX(I+2)=2
              WRITE(U6,202)
            ELSE
              IX(I+2)=1
            END IF
          END IF
        END IF
        IF(IX(I+2).EQ.3.OR.
C                                           ! 3 - replicate
     .     IX(I+2).EQ.4) THEN
C                                           ! 4 - byrepeat
          IF(NRPTOT.NE.ANRPTT) THEN
C                                           ! Check # replicates
            WRITE(U6,205)IX(I)
            WRITE(U6,203)ANRPTT,NRPTOT
            IMERR1=130043
          ELSE IF(NRPTOT.GT.0) THEN
C                                           ! Check coefficients
            DTEMP1=0.
            DTEMP2=0.
            DO 72 IREP=1,NRPTOT
            IF(DABS(DX(SDCOEF+IREP-1)-DX(ASDCOF+IREP-1)).GT.DTEMP1) THEN
              DTEMP1=DABS(DX(SDCOEF+IREP-1)-DX(ASDCOF+IREP-1))
            END IF
            IF(DABS(DX(SDCOEF+IREP-1)).GT.DTEMP2) THEN
              DTEMP2=DABS(DX(SDCOEF+IREP-1))
            END IF
   72       CONTINUE
            IF(DTEMP2.LE.0) THEN
              IF(DTEMP1.GT..1D-05) THEN
                WRITE(U6,204)DTEMP1
              END IF
            ELSE
              IF(DTEMP1/DTEMP2.GT..1D-06) THEN
                WRITE(U6,204)DTEMP1
              END IF
            END IF
          END IF
          IF(IMERR1.EQ.0) THEN
            IF(ANVRID.NE.NVARID.AND.IX(I+3).EQ.1) THEN
              IMERR1=130046
            END IF
          END IF
        END IF
        IF(IMERR1.EQ.0.AND.
C                                                    ! Check BY under
     .     (IX(I+2).EQ.1.OR.IX(I+2).EQ.3)) THEN
C                                                    ! FULL or REPLICATE
          IF(NBY.NE.ANBY.AND.IX(I+3).EQ.1) THEN
C                                                    ! Check same # BY
            IMERR1=130045
C                                                    ! for IDCHECK
          ELSE IF(NBYGRP.GT.1.AND.NBYGRP.NE.ANBYGR) THEN
            IMERR1=130044
          END IF
        END IF
        IF(IMERR1.GT.0) THEN
          IF(IMERR1.NE.130043) THEN
            WRITE(U6,205)IX(I)
          END IF
          ILINE=IXM(1,ISTATE)
          CALL CMPRNT(IXM,LNMAP)
        END IF
      END IF
C
      IF(IOUTPT.GT.0) THEN
C
C  If OUTPUT CLASS, then determine position in output class.
C
        K=RCEIL(2)-ANVTOT+1
        CALL VNMTCH(VNAME(IOUTPT),VNAME(K),ANVTOT,IOUTUP)
        IF(IOUTUP.GT.0) THEN
          IOUTUP=IOUTUP+K-1
        END IF
        IOUTCL=NXPTI
        NOUTCL=0
        IF(IASLST.GT.0) THEN
          IF(IOUTUP.GT.0) THEN
            IF(NASLST.NE.MSIZE(IOUTUP)) THEN
              IMERR1=130028
              ILINE=LNCNTR
              CALL CMPRNT(IXM,LNMAP)
            END IF
            DO 55 I=1,NASLST
            IF(IX(I+IASLST-1).GT.0)NOUTCL=NOUTCL+1
   55       CONTINUE
            I=2*NOUTCL
            CALL ROOMI(I)
            L=IOUTCL
            DO 56 I=1,NASLST
            K=IX(IASLST+I-1)
            IF(K.GT.0) THEN
              IX(L)=I
              IX(L+NOUTCL)=K
              L=L+1
C
C  If a label was provided as part of an AS statement, copy it.
C
              IF(L-IOUTCL.LE.NASVL) THEN
                IL=LPOINT(IOUTPT)
                LEVEL(LPOINT(IOUTPT)+K-1)=LEVEL(NCRVLB+L-IOUTCL)
              END IF
              IF(K.GT.NOUTPT) THEN
                IMERR1=130031
              ELSE IF(IX(ISOUTF+K-1).GT.0) THEN
                IMERR1=130032
              ELSE
                IX(ISOUTF+K-1)=NTRANS
              END IF
              IF(IMERR1.GT.0) THEN
                ILINE=LNCNTR
                CALL CMPRNT(IXM,LNMAP)
              END IF
            END IF
   56       CONTINUE
          ELSE
            IF(NASLST.NE.1) THEN
              IMERR1=130029
            END IF
            NOUTCL=1
            CALL ROOMI(2)
            K=IX(IASLST)
            IF(K.EQ.0) THEN
              IMERR1=130033
            ELSE IF(K.GT.NOUTPT) THEN
              IMERR1=130031
            ELSE IF(IX(ISOUTF+K-1).GT.0) THEN
              IMERR1=130032
            END IF
            IF(IMERR1.GT.0) THEN
              ILINE=LNCNTR
              CALL CMPRNT(IXM,LNMAP)
            END IF
            IX(IOUTCL)=0
            IX(IOUTCL+1)=K
            IX(ISOUTF+K-1)=NTRANS
C
C  If label was provided as part of the AS list, then copy it.
C
            IF(NASVL.GT.0) THEN
              IL=LPOINT(IOUTPT)
              LEVEL(LPOINT(IOUTPT)+K-1)=LEVEL(NCRVLB+1)
            END IF
          END IF
        ELSE
C
C  An AS statement has not provided a list of outgoing class(es)
C
          IF(IOUTUP.GT.0) THEN
            NOUTCL=MSIZE(IOUTUP)
            I=2*NOUTCL
            CALL ROOMI(I)
            L=0
            DO 57 I=1,NOUTPT
            IF(IX(ISOUTF+I-1).EQ.0) THEN
              L=L+1
              IX(IOUTCL+L-1)=L
              IX(IOUTCL+NOUTCL+L-1)=I
              IX(ISOUTF+I-1)=NTRANS
              IF(L.EQ.NOUTCL)GO TO 58
            END IF
   57       CONTINUE
            IMERR1=130034
   58       CONTINUE
          ELSE
            NOUTCL=1
            CALL ROOMI(2)
            DO 59 I=1,NOUTPT
            IF(IX(ISOUTF+I-1).EQ.0) THEN
              IX(IOUTCL)=0
              IX(IOUTCL+1)=I
              IX(ISOUTF+I-1)=NTRANS
              GO TO 60
            END IF
   59       CONTINUE
            IMERR1=130035
   60       CONTINUE
          END IF
          IF(IMERR1.GT.0) THEN
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
        END IF
C
C  If output class is on incoming file, update level labels, if
C  appropriate.
C
        IF(IOUTUP.GT.0) THEN
          JJ=LPOINT(IOUTUP)-1
          KK=LPOINT(IOUTPT)-1
          DO 61 I=1,NOUTCL
          J=IX(IOUTCL+I-1)
          K=IX(IOUTCL+NOUTCL+I-1)
          IF(LEVEL(KK+K)(1:12).EQ.'            '.AND.
     .       LEVEL(KK+K)(13:24).EQ.LEVEL(KK+K)(1:12)) THEN
            LEVEL(KK+K)=LEVEL(JJ+J)
          END IF
   61     CONTINUE
        END IF
      ELSE
        IOUTCL=NXPTI
        NOUTCL=1
        CALL ROOMI(2)
        IX(IOUTCL)=ISVAL
        IX(IOUTCL+1)=0
      END IF
      NPASSV=NPASS
      CALL MRGSET(IOUTUP,NPASS,IX(IOUTCL),NOUTCL)
 
C
C  INCORPORATE
C
      IF(IGROUP.NE.8.OR.IKEY.NE.7.OR.ENDMRG) GO TO 1
C                                                    ! Skip to end of loop
 
C                                                    ! unless incorporate
      IF(ISTEPC.EQ.2) THEN
C                                      ! Error if EXTRACT
        IMERR1=130039
        IMERR2=IPT
        ILINE=LNCNTR
        CALL CMPRNT(IXM,LNMAP)
      END IF
      NLIST=0
      ILISTX=0
      CALL RINCR(12,NTRANS,1)
      IX(NTRANS*12-11)=NXPTI
      I=NXPTI
      CALL ROOMI(10)
      IX(I+1)=0
      IX(I+2)=0
C                        ! No default on FULL etc.
      IX(I+3)=1
C                        ! Default is IDCHECK (new syntax)
      ITYPEF(1)=2
      ITYPEF(2)=0
      CALL FNREAD(IPT,ITYPEF,IFILEF,2,IPOSSC)
      IF(IMERR1.GT.0) THEN
        ILINE=LNCNTR
        CALL CMPRNT(IXM,LNMAP)
      END IF
      K=IFILEF(1)
      IX(IX(NTRANS*12-11))=K
      IF(K.EQ.0) THEN
        IMERR1=130030
        ILINE=LNCNTR
        CALL CMPRNT(IXM,LNMAP)
      END IF
      IF(U5ECSV.EQ.1) THEN
        CALL FNLGTH(J)
        IF(J.LE.40) THEN
          WRITE(U6,100)K,FNWRK(1:40)
        ELSE
          WRITE(U6,101)K,FNWRK
        END IF
      END IF
      CALL PREAMD(K)
      IF(AVERSN.EQ.9004) THEN
        ANID=ANVRID+ANBY
      ELSE
        ANID=ANIDTT
      END IF
      ICLBLK=RCEIL(8)-ANCLBL+1
      IV=RCEIL(2)-ANVTOT
      DO 632 J=1,ANCLBL
      IF(BLVSIZ(ICLBLK).GT.0) THEN
        DO 631 I=1,BLVSIZ(ICLBLK)
        IV=IV+1
        MXSIZE(IV)=ICLBLK
  631   CONTINUE
      END IF
      IX(SICMUL+ICLBLK-1)=BLXSIZ(ICLBLK)/BLXINC(ICLBLK)
      ICLBLK=ICLBLK+1
  632 CONTINUE
      IAS=0
      IASLST=0
      NASVL=0
      NCRVLB=NCRVL
      IF(ISTATE.EQ.NSTATE) THEN
C                                              ! If last statement
        ENDMRG=.TRUE.
C                                              ! is INCORPORATE, loop
        GO TO 64
C                                              ! back to 64 to process
      END IF
C                                              ! this last file.
    1 CONTINUE
      U5ECHO=U5ECSV
      REWIND(14)
      DO 92 ILINE2=1,NLINE2
      U5ECHO=LNECHO(ILINE2)
C     write(*,*)iline2,u5echo
      READ(13)CARDIM
      IF(ILINE2.EQ.1) THEN
        CALL CRDPRN(1)
      ELSE
        CALL CRDPRN(0)
      END IF
   92 CONTINUE
      REWIND(13)
      RETURN
      END
C
C
C  End of M.FOR
CC
C  CM.FOR - routines for new syntax.  These routines are generally
C           shared by several steps, including CREATE, REWEIGHT, and
C           TRANSFORM
C
      SUBROUTINE CMPAR1(IX,IPT)
C
      INTEGER IX(*),IPT
C
C  IX  - IX array passed to CMPAR1.  IX is not referenced through
C        a COMMON statement because of differences between CREATE
C        and TRANSFORM in the COMMON block definitions of IX.
C  IPT - provided by KEYFND, next nonblank position in CARD, if any.
C
C  CMPAR1 performs the initial processing in interpreting the
C  statements in the new syntax.  It:
C  a)  writes the initial input to unit 13, including metacommands
C      and other statements usually created by REFRSH,
C  b)  writes the statements to 14 that will be parsed,
C  c)  classifies the statements by type, and
C  d)  performs an analysis of the nesting of IF, WHILE, and DO.
C
      PARAMETER (MAXFMT=20)
      PARAMETER (MAXALT=5)
      PARAMETER (MAXSUB=500,MAXSBL=2000,MAXSNL=24)
      PARAMETER (MAXSBC=6000)
      PARAMETER (MSIZED=1000000)
C
      PARAMETER (IXDIM=13)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      INTEGER U5ALT(MAXALT),U5ASTT(MAXALT)
      CHARACTER *80 U5LINE(MAXALT)
      COMMON /A5BLCK/U5ALT,U5ASTT
      COMMON /U5LBLK/U5LINE
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
C
C  CMPFLG - set to 1 during initial reading of statements.
C           It is set to 1 in this routine and returned to 0 at the
C           end of the sequence of statements.  It signals REFRSH to
C           consider commands COMMENT, SCRATCH#, MACROWRITE,
C           ERRORFILE, MACROIMPLEMENT, MACROIMPLEMENTEND,
C           to end the specification for the step.
C           IGNORE, IGNORE OFF, LONGCOMMENT, LONGCOMMENT OFF, SET,
C           and ECHO may be interspersed in the commands.
C  U5ESAV - end-of-file status for active input unit at end of
C           statements for the step.
C           1 - active input unit was at end of file.
C           0 - not at end of file.
C  IALTSV - to save the depth of alternative input files used for
C           scratch file, first by unit 14, and then by others.
C  TSWTCH - 1 if TRANSFORM step
C           2 if CREATE step (or REWEIGHT, etc.)
C  NLINE  - number of lines written to unit 14
C  ILINE  - the current line
C  NSTATE - number of statements
C  ISTATE - the current statement
C  U5ECSV - the status of echo when new syntax encountered.
C
      CHARACTER*256 CARDWK,CARDSV,CARDIM
      COMMON /CMBLK2/CARDWK,CARDSV,CARDIM
      LOGICAL ALPCHK,DGTCHK,REFRSH
      EXTERNAL ALPCHK,DGTCHK,REFRSH
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
      CHARACTER*80 CARDIN
      CHARACTER*(MAXSNL) SUBNAM(MAXSUB)
      CHARACTER*12 SUBCSV(MAXSBC)
      COMMON /CINBLK/CARDIN,SUBNAM,SUBCSV
C
C
  202 FORMAT(' TOO MANY LEVELS, MAXIMUM=',I2)
C
C  Use of IX array:
C  IX(1,*) - Beginning line of statement
C  IX(2,*) - Beginning character
C  IX(3,*) - Ending line
C  IX(4,*) - Ending character
C  IX(5,*) - Statement type:
C        1 - Simple eq., single =
C        2 - Parallel eq. { } =
C        3 - Comment    * ;
C        4 - CALL subroutine
C        5 - IF
C        6 - ELSE IF, ELSEIF
C        7 - ELSE
C        8 - END IF, ENDIF
C        9 - DO
C       10 - END DO
C       11 - DECLARE
C       12 - WHILE
C       13 - END WHILE
C       14 - Compound equation with multiple =      Note: removed
C       15 - Compound set equation with multiple =  Note: removed
C       16 - key word statement
C
C  IX(6,*) - IF level
C          = 0 if not within IF block.
C
C  IX(7,*) - total nesting depth, considering IF, WHILE, DO
C
C  IX(8,*) - line of beginning character following initial
C            keyword.
C
C  IX(9,*) - beginning character following initial keyword.
C
C  The beginning character following the initial keyword is
C  defined according to the statement type.
C                          Beginning character after keyword
C        1 - Simple eq.           Initial character
C        2 - Parallel eq.                 "
C        3 - Comment  * ;                 "
C        4 - CALL                 Subroutine name
C        5 - IF                   Next nonblank character
C        6 - ELSE IF, ELSEIF              "
C        7 - ELSE                         "
C        8 - END IF, ENDIF                "
C        9 - DO                           "
C       10 - END DO                       "
C       11 - DECLARE                      "
C       12 - WHILE                        "
C       13 - END WHILE                    "
C       14 - Compound eq.         Initial character
C       15 - Compound set eq.             "
C       16 - Key word             Next nonblank character after
C                                 key word
C
C  IX(10,*)- IGROUP, grouping of key words
C            Note: also temporarily used for IF, ELSE IF, to location
C            pointers
C
C  IX(11,*)- IKEY, key word index
C            Note: also temporarily used for IF, ELSE IF, to location
C            pointers
C
C  IX(12,*)- Code for any associated NOTE: with statement
C
C  IX(13,*)- Additional information associated with NOTE: e.g., number
C            of variables
C
C
C  Use of units:
C  13 - copy of input, with indicated substitutions, INCLUDE, IGNORE,
C       etc., statements if any, etc.
C  14 - copy of input, saved in original form to match with
C       diagnostics, if any.  Parsing is of this file without the
C       additional statements included on unit 13.
C
C  Note: 13 and 14 are used by CMPAR1, but 15 - 17 are opened here
C  as well.
C
C  15 - used by NSETP1 etc. to store the lines of a single command
C  16 - used by RPOLSH as input
C  17 - used by NSETP1 etc. for set equations and other tasks
C
      CALL SCOPEN(13)
      CALL SCOPEN(14)
      CALL SCOPEN(15)
      CALL SCOPEN(16)
      CALL SCOPEN(17)
C
C  Both 13 and 14 mirror the input.  Unit 13 echoes the complete input,
C  including metacommands and indications of substitutions handled by
C  REFRSH.  The only records written to 14 are commands to be parsed.
C  An array is set up for each step pointing from each line of 14 back
C  to the corresponding line in 13.  The array begins at NXPTIB=NXPTI.
C  This space is not freed up by this routine but instead used by
C  subsequent routines.
C
C  Write commands to 13 and 14.
C
      CMPFLG=1
      NLINE=0
      NLINE2=1
      LNCNTR=0
      NXPTDS=NXPTD
C                         ! Save NXPTD, DX used to store U5ENOW
C
C  Note: write the last line of the primary step statement to 14 but
C  not to 13
C
      WRITE(14)CARD
      U5ECSV=U5ECHO
      U5ENOW=U5ECHO
      U5ECHO=0
      NXPTIB=NXPTI
      K=0
      CALL ROOMI(1)
      IX(NXPTIB)=1
C
    2 CONTINUE
      IF(REFRSH(IBASE)) THEN
C
C  Note: NLINE is updated by REFRSH for metacommands, etc.
C  In this loop, NLINE tracks records written to unit 13 and NLINE2
C  tracks records written to 14.  Later, however, NLINE tracks
C  records on 14.
C
        WRITE(13)CARDIM
        NLINE=NLINE+1
        CALL ROOMD(1)
        DX(NXPTD-1)=U5ENOW
        K=NLINE
        IAPOST=0
        DO 1 I=1,256
        IF(IAPOST.EQ.1) THEN
          IF(CARD(I:I).EQ.'''')IAPOST=0
        ELSE IF(IAPOST.EQ.2) THEN
          IF(CARD(I:I).EQ.'"')IAPOST=0
        ELSE IF(CARD(I:I).EQ.'''') THEN
          IAPOST=1
        ELSE IF(CARD(I:I).EQ.'"') THEN
          IAPOST=2
        ELSE IF(CARD(I:I).EQ.'!') THEN
          CALL STBLNK(CARD,I,256)
        END IF
    1   CONTINUE
        CALL NBFIND(CARD,1,256,IPOS)
        WRITE(14)CARD
        NLINE2=NLINE2+1
        CALL ROOMI(1)
        IX(NXPTI-1)=NLINE
        GO TO 2
      ELSE
C
C  Note: may arrive here if error in input according to REFRSH
C
        IF(IMERR1.GT.0) THEN
          U5=13
          CMPFLG=0
C
C  If IMERR2 has been set, save the value and reset IMERR2 to 0 to
C  use CRDPRN(0) to print the cards
C
          J=IMERR2
          IMERR2=0
          WRITE(13)CARDIM
          NLINE=NLINE+1
          REWIND(13)
          U5ECHO=1
          DO 3 I=1,NLINE
          READ(13)CARDIM
          CALL CRDPRN(0)
    3     CONTINUE
          IMERR2=J
          CALL FSTOP
        END IF
C
C  Arrive here if at end of step (with no input error).
C
C  Save end of file status on input (in block CMBLK1)
C
        U5ESAV=U5END
C
C  If not at end of file in input stream, save status
C
        IF(U5END.EQ.0) THEN
          IF(U5ALT(MAXALT).NE.0) THEN
            IF(U5ALT(MAXALT).NE.U5) THEN
              WRITE(U6,202)MAXALT
              CALL FESTOP(161040)
            END IF
          END IF
          DO 4 I=MAXALT,1,-1
          IF(U5ALT(I).NE.0) THEN
            U5ASTT(I)=1
            U5LINE(I)=CARDIN
            IF(I.LT.MAXALT) THEN
              U5ALT(I+1)=14
            END IF
            IALTSV=I+1
            GO TO 5
          END IF
    4     CONTINUE
    5     CONTINUE
        ELSE
          U5ASTT(1)=0
          U5END=0
        END IF
C
        REWIND(UNIT=13)
        REWIND(UNIT=14)
        U5=14
C
C  At this point, reset CMPFLG back to 0, for normal REFRSH
C  processing
C
        CMPFLG=0
      END IF
      IF(K.LT.NLINE) THEN
        DO 8 I=K+1,NLINE
        CALL ROOMD(1)
        DX(NXPTD-1)=U5ENOW
    8   CONTINUE
      END IF
      NXPTIE=NXPTI
      CALL ROOMI(NLINE)
      J=NXPTIE
      K=NXPTDS
      DO 7 I=1,NLINE
      IX(J)=DX(K)+.01
      J=J+1
      K=K+1
    7 CONTINUE
      NXPTD=NXPTDS
C
C  NLINE is now set = # lines on 14
C
      K=NLINE
      NLINE=NLINE2
      NLINE2=K
C
C  At this point, all the statements associated with step have been
C  written to unit 14.  Identify boundaries between statements and
C  ensure statements can clearly delineated.  NXPTIS will save
C  the beginning of the matrix.
C
      NXPTIS=NXPTI
      NSTATE=0
      ISTATE=0
      READ(14)CARD
C
C  If command(s) have been included on the same line with step
C
      IF(IPT.GT.0) THEN
        CALL NBFIND(CARD(IPT:256),IPT,256,IPOS)
      ELSE
        IPOS=0
      END IF
      IF(IPOS.GT.0) THEN
        ILINE=1
C
C  If commands begin after the primary step line.
C
      ELSE
        IF(NLINE.EQ.1) THEN
          RETURN
        ELSE
          READ(14)CARD
        END IF
        ILINE=2
        IBASE=1
C
C  Use NBFNDL to find next blank position.  NBFNDL will keep track of
C  ILINE.
C
        CALL NBFNDL(IBASE,IPOS)
        IF(IPOS.LE.0) THEN
C
C  RETURN here because no characters follow the statement initiating the
C  step.
C
          RETURN
        END IF
      END IF
C
C  An initial character of a statement has been identified at IPOS.
C
   10 CONTINUE
      CALL RCHECK(1,NXPTI,IXDIM)
      NSTATE=NSTATE+1
C
C  Flags/variables for initial check of statement syntax
C
C  IPAREN - depth of parentheses ( [
C  IAPOST - 0 not inside parentheses (normal status)
C           1 inside character string bound by ' '
C  IEQ    - number of = encountered.
C  ISET   - nesting of set notation { }
C  IVEC   - 0 not part of constant vector < > (normal status)
C           1 inside vector - nesting is not allowed
C
      IPAREN=0
      IAPOST=0
      IEQ=0
      ISET=0
      IVECT=0
C
      IX(NXPTI)=ILINE
      IX(NXPTI+1)=IPOS
      IX(NXPTI+2)=0
      IX(NXPTI+3)=0
      IX(NXPTI+11)=0
      IX(NXPTI+12)=0
C
C  Immediate recognition of COMMENT in form "*  ;"
C  Immediate recognition of "{  }="
C
      IF(CARD(IPOS:IPOS).EQ.'*') THEN
        ISTYPE=3
        IPOS=IPOS+1
      ELSE IF(CARD(IPOS:IPOS).EQ.'{') THEN
        ISTYPE=2
        IPOS=IPOS+1
        ISET=1
C
C  Otherwise, check for key words.  Encode ISTYLE as negative
C  initially to indicate potential keyword form, prior to
C  confirmation.  Exceptions are 6 for ELSEIF and 8 for ENDIF
C
      ELSE IF(ALPCHK(CARD(IPOS:IPOS))) THEN
        CALL KYCHK2(IPOS,IGROUP,IKEY,IPOS2)
        ISTYPE=0
        IF(IKEY.GT.0) THEN
          IF(IGROUP.EQ.1) THEN
            IF(IKEY.EQ.18) THEN
C
C  END
C
              ISTYPE=-8
            ELSE IF(IKEY.EQ.15) THEN
C
C  IF
C
              ISTYPE=-5
            ELSE IF(IKEY.EQ.16) THEN
C
C  ELSE
C
              ISTYPE=-6
            ELSE IF(IKEY.EQ.17) THEN
C
C  ELSEIF
C
              ISTYPE=6
            ELSE IF(IKEY.EQ.19) THEN
C
C  END IF
C
              ISTYPE=8
            ELSE
C
C  Other key words
C
              ISTYPE=-16
            END IF
C
          ELSE IF(IGROUP.EQ.2.OR.IGROUP.EQ.7.OR.
     .           (TSWTCH.EQ.3.AND.IGROUP.EQ.8))THEN
C                                                    ! Recognize MERGE
            ISTYPE=-16
          END IF
          IF(ISTYPE.EQ.-16) THEN
            IX(NXPTI+9)=IGROUP
            IX(NXPTI+10)=IKEY
          END IF
C
        ELSE
          CALL CMATCH(CARD(IPOS:256),IPOS,256,'CALL',4,IPOS2,1)
          IF(IPOS2.GT.0) THEN
            ISTYPE=-4
          ELSE
            CALL CMATCH(CARD(IPOS:256),IPOS,256,'DO',2,IPOS2,1)
            IF(IPOS2.GT.0) THEN
              ISTYPE=-9
            ELSE
              CALL CMATCH(CARD(IPOS:256),IPOS,256,'DECLARE',7,IPOS2,1)
              IF(IPOS2.GT.0) THEN
                ISTYPE=-11
              ELSE
                CALL CMATCH(CARD(IPOS:256),IPOS,256,'WHILE',5,IPOS2,1)
                IF(IPOS2.GT.0) THEN
                  ISTYPE=-12
                END IF
              END IF
            END IF
          END IF
          IX(NXPTI+9)=0
          IX(NXPTI+10)=0
        END IF
C
C  If initial key word, check consistency
C
        IF(ISTYPE.NE.0) THEN
          IPOS=IPOS2
          K=ILINE
          CALL NBFNDL(IPOS,IPOS2)
          IF(IPOS.EQ.1.AND.IAPOST.EQ.1) THEN
            ILINE=K
            IMERR1=161020
            CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
          END IF
          IF(IPOS2.EQ.0) THEN
            IMERR1=161001
            CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
          END IF
          IPOS=IPOS2
C
C  If key word is followed by =, treat as type 1
C
          IF(CARD(IPOS:IPOS).EQ.'=') THEN
            ISTYPE=1
C
C  ELSE ;
C
          ELSE IF(CARD(IPOS:IPOS).EQ.';') THEN
            IF(ISTYPE.EQ.-6) THEN
              ISTYPE=7
            ELSE IF(ISTYPE.EQ.-16) THEN
              ISTYPE=16
            ELSE IF(ISTYPE.NE.8) THEN
              IMERR1=161001
              IMERR2=IPOS
              CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
            END IF
          ELSE IF(CARD(IPOS:IPOS).EQ.'(') THEN
C
C  Assume IF ( is beginning of IF statement; WHILE ( and
C  ELSEIF ( similarly
C
            IF(ISTYPE.EQ.-5.OR.ISTYPE.EQ.-12) THEN
              ISTYPE=-ISTYPE
            ELSE IF(ISTYPE.EQ.-16.AND.IGROUP.EQ.2.AND.
     .          (IKEY.EQ.6.OR.IKEY.EQ.13)) THEN
              ISTYPE=16
            ELSE IF(ISTYPE.NE.6) THEN
              IMERR1=161002
              IMERR2=IPOS
              CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
            END IF
C
C  At this point, accept interpretation of CALL, IF, DO, DECLARE,
C  or WHILE
C
          ELSE IF(ISTYPE.EQ.-4.OR.ISTYPE.EQ.-5.OR.
     .            ISTYPE.EQ.-9.OR.ISTYPE.EQ.-11.OR.
     .            ISTYPE.EQ.-12.OR.ISTYPE.EQ.-16) THEN
            ISTYPE=-ISTYPE
C
C  ELSE or END
C
          ELSE IF(ISTYPE.EQ.-6.OR.ISTYPE.EQ.-8) THEN
            CALL CMATCH(CARD(IPOS:256),IPOS,256,'IF',2,IPOS2,1)
            IF(IPOS2.GT.0) THEN
              ISTYPE=-ISTYPE
              IPOS=IPOS2
              K=ILINE
              CALL NBFNDL(IPOS,IPOS2)
              IF(IPOS.EQ.1.AND.IAPOST.EQ.1) THEN
                ILINE=K
                IMERR1=161020
                CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
              END IF
              IF(ISTYPE.EQ.8) THEN
                IF(IPOS2.EQ.0) THEN
                  IMERR1=161001
                  CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
                ELSE
                  IPOS=IPOS2
                  IF(CARD(IPOS:IPOS).NE.';') THEN
                    IMERR1=161001
                    IMERR2=IPOS
                    CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
                  END IF
                END IF
              ELSE
                IPOS=IPOS2
              END IF
C
C  Check for END DO, END WHILE
C
            ELSE
              CALL CMATCH(CARD(IPOS:256),IPOS,256,'DO',2,IPOS2,1)
              IF(IPOS2.GT.0) THEN
                IF(ISTYPE.EQ.-8) THEN
                  ISTYPE=10
                  IPOS=IPOS2
                ELSE
                  IMERR1=161004
                  IMERR2=IPOS
                  CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
                END IF
              ELSE
                CALL CMATCH(CARD(IPOS:256),IPOS,256,'WHILE',5,IPOS2,1)
                IF(IPOS2.GT.0) THEN
                  IF(ISTYPE.EQ.-8) THEN
                    ISTYPE=13
                    IPOS=IPOS2
                  ELSE
                    IMERR1=161008
                    IMERR2=IPOS
                    CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
                  END IF
                END IF
              END IF
            END IF
          END IF
          IF(ISTYPE.LT.0) THEN
            IMERR1=161009
            CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
          END IF
        ELSE IF(ISTYPE.EQ.0) THEN
          ISTYPE=1
        END IF
      END IF
      IF(ISTYPE.LE.3.OR.ISTYPE.EQ.14.OR.ISTYPE.EQ.15) THEN
        IX(NXPTI+7)=IX(NXPTI)
        IX(NXPTI+8)=IX(NXPTI+1)
      ELSE
        IX(NXPTI+7)=ILINE
        IX(NXPTI+8)=IPOS
      END IF
      IX(NXPTI+4)=ISTYPE
C
C  Complete processing of END WHILE
C
      IF(ISTYPE.EQ.13) THEN
        K=ILINE
        CALL NBFNDL(IPOS,IPOS2)
        IF(IPOS.EQ.1.AND.IAPOST.EQ.1) THEN
          ILINE=K
          IMERR1=161020
          CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
        END IF
        IF(IPOS2.EQ.0) THEN
          IMERR1=161001
          CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
        ELSE
          IPOS=IPOS2
          IF(CARD(IPOS:IPOS).NE.';') THEN
            IMERR1=161001
            IMERR2=IPOS
            CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
          END IF
        END IF
      END IF
C
   12 CONTINUE
      K=ILINE
      CALL NBFNDL(IPOS,IPOS2)
      IF(IPOS.EQ.1.AND.IAPOST.EQ.1) THEN
        ILINE=K
        IMERR1=161020
        CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
      END IF
      IF(IPOS2.GT.0) THEN
        IPOS=IPOS2
C
C  Appearance of ';' indicates the end of all statements with the
C  single exception of a ';' within the first level of parentheses in
C  a CALL statement.
C
        IF(CARD(IPOS:IPOS).EQ.';'.AND.(IAPOST.EQ.0.OR.ISTYPE.EQ.3)) THEN
          IF(ISTYPE.NE.4.OR.IPAREN.NE.1) THEN
            IF(IPAREN.NE.0) THEN
              IMERR1=161007
              IMERR2=IPOS
              CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
            ELSE IF(ISET.NE.0) THEN
              IMERR1=161010
              IMERR2=IPOS
              CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
            ELSE IF(IVECT.NE.0.AND.ISTYPE.NE.5.AND.ISTYPE.NE.6) THEN
              IMERR1=161013
              IMERR2=IPOS
              CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
            ELSE IF(ISTYPE.EQ.1.OR.ISTYPE.EQ.2) THEN
              IF(IEQ.EQ.0) THEN
                IMERR1=161011
                IMERR2=IPOS
                CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
              ELSE IF(IEQ.GT.1) THEN
                IMERR1=161033
                CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
C               IF(ISTYPE.EQ.1) THEN
C                 IX(NXPTI+4)=14
C               ELSE
C                 IX(NXPTI+4)=15
C               END IF
              END IF
            END IF
            IX(NXPTI+2)=ILINE
            IX(NXPTI+3)=IPOS
            GO TO 14
          END IF
        ELSE IF(ISTYPE.NE.3) THEN
          IF(CARD(IPOS:IPOS).EQ.'''') THEN
            IF(CARD(IPOS+1:IPOS+1).EQ.'''') THEN
              IPOS=IPOS+1
            ELSE IF(IAPOST.EQ.1) THEN
              IAPOST=0
            ELSE
              IAPOST=1
            END IF
          ELSE IF(IAPOST.EQ.0) THEN
            IF(CARD(IPOS:IPOS).EQ.'('.OR.CARD(IPOS:IPOS).EQ.'[') THEN
              IPAREN=IPAREN+1
            ELSE IF(CARD(IPOS:IPOS).EQ.')'.OR.CARD(IPOS:IPOS).EQ.']')
     .            THEN
              IPAREN=IPAREN-1
              IF(IPAREN.LT.0) THEN
                IMERR1=161005
                IMERR2=IPOS
                CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
              END IF
            ELSE IF(CARD(IPOS:IPOS).EQ.'{') THEN
              ISET=ISET+1
            ELSE IF(CARD(IPOS:IPOS).EQ.'}') THEN
              ISET=ISET-1
              IF(ISET.LT.0) THEN
                IMERR1=161012
                IMERR2=IPOS
                CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
              END IF
            ELSE IF(CARD(IPOS:IPOS).EQ.'<'.AND.ISTYPE.NE.5.AND.
     .              ISTYPE.NE.6) THEN
              IVECT=IVECT+1
              IF(IVECT.GT.1) THEN
                IMERR1=161014
                IMERR2=IPOS
                CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
              END IF
            ELSE IF(CARD(IPOS:IPOS).EQ.'>'.AND.ISTYPE.NE.5.AND.
     .              ISTYPE.NE.6) THEN
              IVECT=IVECT-1
              IF(IVECT.LT.0) THEN
                IMERR1=161015
                IMERR2=IPOS
                CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
              END IF
            ELSE IF(CARD(IPOS:IPOS).EQ.'='.AND.
     .              CARD(IPOS+1:IPOS+1).NE.'='.AND.
     .              ISTYPE.NE.4.AND.
     .              ISTYPE.NE.5.AND.ISTYPE.NE.6) THEN
              IEQ=IEQ+1
C
C  At appearance of =, must have balance on parentheses etc.
C
              IF(IPAREN.NE.0) THEN
                IMERR1=161017
                IMERR2=IPOS
                CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
              ELSE IF(ISET.NE.0) THEN
                IMERR1=161018
                IMERR2=IPOS
                CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
              ELSE IF(IVECT.NE.0) THEN
                IMERR1=161019
                IMERR2=IPOS
                CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
              END IF
            END IF
          END IF
        END IF
        IPOS=IPOS+1
        GO TO 12
      ELSE
        IMERR1=161016
        CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
      END IF
   14 CONTINUE
      CALL ROOMI(IXDIM)
      IF(IPOS.GT.0) THEN
        IPOS2=IPOS+1
        K=ILINE
        CALL NBFNDL(IPOS2,IPOS)
        IF(IPOS.EQ.1.AND.IAPOST.EQ.1) THEN
          ILINE=K
          IMERR1=161020
          CALL CMPRNT(IX(NXPTIS),IX(NXPTIB))
        END IF
        IF(IPOS.GT.0)GO TO 10
      END IF
C
C  Ending point after identifying all statements.
C
C  Check of imbedding of IF, WHILE.  A stack is created to
C  store the previous effective statement.  IFDEEP keeps track
C  of the depth of IF statements.
C
      NXPTI2=NXPTI
      ISTACK=NXPTI2-2
      NSTACK=0
      K=NXPTIS
      IFDEEP=0
C
C  NSTAT1 - Used in call to CMPRIF
C
      NSTAT1=NSTATE+1
C
C  Reserve a stack space of size 2*NSTATE for checking of IF etc.
C  (This is much more than necessary but the space will be
C  returned after the check is complete.)
C
      I=2*NSTATE
      CALL ROOMI(I)
      DO 30 ISTATE=1,NSTATE
C
C  On appearance of IF, DO, or WHILE, increase the depth of the
C  stack by 1.
C
      IX(K+5)=IFDEEP
      IX(K+6)=NSTACK
      IF(IX(K+4).EQ.5.OR.IX(K+4).EQ.9.OR.IX(K+4).EQ.12) THEN
        NSTACK=NSTACK+1
        ISTACK=ISTACK+2
        IX(ISTACK)=ISTATE
        IX(ISTACK+1)=IX(K+4)
        ITDEEP=ITDEEP+1
        IF(IX(ISTACK+1).EQ.5) THEN
          IFDEEP=IFDEEP+1
        END IF
C
C  For END IF, END DO, and END WHILE, check that the statement
C  is properly paired with IF, DO, or WHILE in the stack.
C
C  END IF
C
      ELSE IF(IX(K+4).EQ.8) THEN
        IF(NSTACK.EQ.0) THEN
          IMERR1=161021
          CALL CMPRIF(IX(NXPTIS),IX(NXPTIB),1,NSTAT1,NSTAT1)
        ELSE
          IF(IX(ISTACK+1).EQ.5.OR.IX(ISTACK+1).EQ.6.OR.
     .       IX(ISTACK+1).EQ.7) THEN
            NSTACK=NSTACK-1
            IFDEEP=IFDEEP-1
            ISTACK=ISTACK-2
          ELSE
            IMERR1=161021
            CALL CMPRIF(IX(NXPTIS),IX(NXPTIB),1,1,1)
          END IF
        END IF
C
C  END DO
C
      ELSE IF(IX(K+4).EQ.10) THEN
        IF(NSTACK.EQ.0) THEN
          IMERR1=161022
          CALL CMPRIF(IX(NXPTIS),IX(NXPTIB),NSTAT1,1,NSTAT1)
        ELSE
          IF(IX(ISTACK+1).EQ.9) THEN
            NSTACK=NSTACK-1
            IFDEEP=IFDEEP-1
            ISTACK=ISTACK-2
          ELSE
            IMERR1=161022
            CALL CMPRIF(IX(NXPTIS),IX(NXPTIB),1,1,1)
          END IF
        END IF
C
C  END WHILE
C
      ELSE IF(IX(K+4).EQ.12) THEN
        IF(NSTACK.EQ.0) THEN
          IMERR1=161023
          CALL CMPRIF(IX(NXPTIS),IX(NXPTIB),NSTAT1,NSTAT1,1)
        ELSE
          IF(IX(ISTACK+1).EQ.13) THEN
            NSTACK=NSTACK-1
            IFDEEP=IFDEEP-1
            ISTACK=ISTACK-2
          ELSE
            IMERR1=161023
            CALL CMPRIF(IX(NXPTIS),IX(NXPTIB),1,1,1)
          END IF
        END IF
C
C  ELSE IF, ELSE
C
      ELSE IF(IX(K+4).EQ.6.OR.IX(K+4).EQ.7) THEN
        IF(NSTACK.EQ.0) THEN
          IMERR1=161024
          CALL CMPRIF(IX(NXPTIS),IX(NXPTIB),1,NSTAT1,NSTAT1)
        ELSE IF(IX(K+4).EQ.6) THEN
          IF(IX(ISTACK+1).EQ.5) THEN
            IX(ISTACK+1)=6
          ELSE IF(IX(ISTACK+1).EQ.7) THEN
            IMERR1=161025
            CALL CMPRIF(IX(NXPTIS),IX(NXPTIB),1,1,1)
          ELSE IF(IX(ISTACK+1).NE.6) THEN
            IMERR1=161024
            CALL CMPRIF(IX(NXPTIS),IX(NXPTIB),1,1,1)
          END IF
        ELSE
          IF(IX(ISTACK+1).EQ.5.OR.IX(ISTACK+1).EQ.6) THEN
            IX(ISTACK+1)=7
          ELSE IF(IX(ISTACK+1).EQ.7) THEN
            IMERR1=161026
            CALL CMPRIF(IX(NXPTIS),IX(NXPTIB),1,1,1)
          ELSE
            IMERR1=161024
            CALL CMPRIF(IX(NXPTIS),IX(NXPTIB),1,1,1)
          END IF
        END IF
      END IF
      K=K+IXDIM
   30 CONTINUE
C
C  If NSTACK isn't 0, there are open blocks.
C
      IF(NSTACK.GT.1) THEN
        IF(IX(ISTACK+1).EQ.5.OR.IX(ISTACK+1).EQ.6.OR.
     .     IX(ISTACK+1).EQ.7) THEN
          IMERR1=161027
        ELSE IF(IX(ISTACK+1).EQ.9) THEN
          IMERR1=161028
        ELSE IF(IX(ISTACK+1).EQ.12) THEN
          IMERR1=161029
        END IF
        ISTATE=NSTATE
        CALL CMPRIF(IX(NXPTIS),IX(NXPTIB),1,1,1)
      ELSE IF(NSTACK.EQ.1) THEN
        IF(IX(ISTACK+1).EQ.5.OR.IX(ISTACK+1).EQ.6.OR.
     .     IX(ISTACK+1).EQ.7) THEN
          IMERR1=161030
          CALL CMPRIF(IX(NXPTIS),IX(NXPTIB),1,NSTAT1,NSTAT1)
        ELSE IF(IX(ISTACK+1).EQ.9) THEN
          IMERR1=161031
          CALL CMPRIF(IX(NXPTIS),IX(NXPTIB),NSTAT1,1,NSTAT1)
        ELSE IF(IX(ISTACK+1).EQ.12) THEN
          IMERR1=161032
          CALL CMPRIF(IX(NXPTIS),IX(NXPTIB),NSTAT1,NSTAT,1)
        END IF
        ISTATE=NSTATE
      END IF
C
   90 CONTINUE
      U5ECHO=U5ECSV
      RETURN
      END
C
      SUBROUTINE NBFNDL(BASE,IPOS)
C
C  BASE - starting position in CARD to search.
C         It will be reset to 1 if additional lines have been read.
C  IPOS - next nonblank character (as numbered in calling program)
C         0 no more continuation lines.
C
C  Finds next nonblank character, IPOS is nonblank position
C  0 otherwise.
C
C  NBFNDL is specific to the search of command lines from unit 14.
C  It will initiate the reading of additional lines through REFRSH.
C
      INTEGER BASE,IPOS
C
C
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/ CARD
C
      IPOS=0
    5 CONTINUE
      IF(BASE.GT.256.OR.BASE.EQ.0) THEN
        IF(ILINE.GE.NLINE) GO TO 30
        READ(14)CARD
        ILINE=ILINE+1
        BASE=1
      END IF
   10 CONTINUE
      DO 20 IPT=BASE,256
      IF(CARD(IPT:IPT).NE.' ') THEN
        IPOS=IPT
        GO TO 30
      END IF
   20 CONTINUE
      BASE=0
      GO TO 5
   30 CONTINUE
      RETURN
      END
C
      SUBROUTINE CMPRNT(IX,LNMAP)
C
C  CMPRNT is designed to print stored commands from 13 if there
C  is a problem in the initial parsing of the statements.
C
C  It prints previous statements/lines and then skips a line to
C  isolate the current statement.
C
C  CMPRNT calls FSTOP; the calling program should have already
C  set IMERR1 to select the error message to follow the printing
C  of the statements.
C
      PARAMETER (IXDIM=13)
      DIMENSION IX(IXDIM,*),LNMAP(*)
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
C
C  NLINE  - number of lines written to unit 14
C  ILINE  - the current line
C  NSTATE - number of statements
C  ISTATE - the current statement
C
      CHARACTER*256 CARDWK,CARDSV,CARDIM
      COMMON /CMBLK2/CARDWK,CARDSV,CARDIM
C
      U5ECHO=1
      ISKIP=0
      IF(LNCNTR.GT.ILINE)ILINE=LNCNTR
      IF(ISTATE.EQ.0)ISTATE=NSTATE
      REWIND(14)
C
C  Under all circumstances, print the first line
C
      READ(13)CARDIM
      CALL CRDPRN(0)
C
      IF(ISTATE.GT.1) THEN
C
C  For ISTATE > 1, ending line of previous statement has
C  already been delimited.  Printing will show all previous
C  statements as a group and then offset the current statement
C  to emphasize that the problem is in the current statement.
C
        ISTAT1=ISTATE-1
        ILINE1=IX(3,ISTAT1)
        DO 2 I=2,LNMAP(ILINE1)
        READ(13)CARDIM
        IF(I.EQ.ILINE1) THEN
          IF(ILINE1.EQ.IX(1,ISTATE)) THEN
            CARDWK=CARDIM
            J=IX(4,ISTAT1)+1
            CALL STBLNK(CARDIM,J,256)
          END IF
        END IF
        CALL CRDPRN(2)
    2   CONTINUE
C
C  For ISTATE>1, the first line of the current statement is
C  printed here.
C
        IF(ILINE1.EQ.IX(1,ISTATE)) THEN
          CARDIM=CARDWK
          J=IX(4,ISTAT1)
          CALL STBLNK(CARDIM,1,J)
          CALL CRDPRN(1)
          ISKIP=1
        END IF
      ELSE
        ILINE1=1
      END IF
C
C  Print remaining lines, if any
C
      IF(ILINE1.LT.ILINE) THEN
        DO 4 I=LNMAP(ILINE1)+1,LNMAP(ILINE)
        READ(13)CARDIM
        CALL CRDPRN(2)
    4   CONTINUE
      END IF
      CALL FSTOP
      END
C
      SUBROUTINE CMPRIF(IXM,LNMAP,IFST,IDOST,IWHST)
C
C  IFST  - Starting statement to print level of IF
C  IDOST - Starting statement to print total imbedding for DO
C  IWHST - Starting statement to print total imbedding for WHILE
C
C  CMPRIF is designed to print stored commands from 13 if there
C  is a problem in the nesting of IF, DO, or WHILE.
c
C  It prints previous statements/lines and then skips a line to
C  isolate the current statement.
C
C  CMPRIF calls FSTOP; the calling program should have already
C  set IMERR1 to select the error message to follow the printing
C  of the statements.
C
      PARAMETER (IXDIM=13)
      DIMENSION IXM(IXDIM,*),LNMAP(*)
      INTEGER IFST,IDOST,IWHST
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
C
C  NLINE  - number of lines written to unit 14
C  ILINE  - the current line
C  NSTATE - number of statements
C  ISTATE - the current statement
C
      CHARACTER*256 CARDWK,CARDSV,CARDIM
      COMMON /CMBLK2/CARDWK,CARDSV,CARDIM
C
  201 FORMAT('<IF level:',I3,'>')
  202 FORMAT('<Total nesting:',I3,'>')
  203 FORMAT('<IF level:',I3,'  Total nesting:',I3,'>')
C
      U5ECHO=1
      IF(ISTATE.EQ.0)ISTATE=NSTATE
      REWIND(14)
      REWIND(13)
C
C  IL -  counter for current line
C  ISP - previous special statement printed
C
      ILINE1=IXM(3,ISTATE)
      IL=0
      ISP=0
      DO 30 IS=1,ISTATE
C
C  ISKIP - flag that indicates next record should be printed alone, with
C          skipped lines before and after.
C
      ISKIP=0
      IF(IXM(5,IS).GE.5.AND.IXM(5,IS).LE.8) THEN
        IF(IS.GE.IFST) THEN
          ISKIP=1
          IFORM=1
          IF(IS.GE.IDOST.OR.IS.GE.IWHST) THEN
            IFORM=3
          END IF
        END IF
      ELSE IF(IXM(5,IS).EQ.9.OR.IXM(5,IS).EQ.10) THEN
        IF(IS.GE.IDOST) THEN
          ISKIP=1
          IFORM=2
        END IF
      ELSE IF(IXM(5,IS).EQ.12.OR.IXM(5,IS).EQ.13) THEN
        IF(IS.GE.IWHST) THEN
          ISKIP=1
          IFORM=2
        END IF
      END IF
      IF(ISKIP.EQ.1.OR.IS.EQ.ISTATE) THEN
C
C  When encounter statement to be offset, first print any
C  intervening lines for statements that are not skipped.
C  Close out for IS=ISTATE
C
        IF(ISP+1.LT.IS.OR.IS.EQ.ISTATE) THEN
          ISP1=ISP+1
C
C  If a previous special case has been processed, part or all of the
C  next regular statement may be held in CARDWK
C
          IF(ISP.GT.0) THEN
            IF(IL.EQ.LNMAP(IXM(1,ISP1))) THEN
              CARDIM=CARDWK
              J=IXM(4,ISP)
              CALL STBLNK(CARDIM,1,J)
            ELSE
              READ(13)CARDIM
              IL=IL+1
            END IF
          ELSE
            READ(13)CARDIM
            IL=IL+1
          END IF
C
C  If the line contains information from the current special statement,
C  store in CARDWK and trim.
C
          IF(IL.EQ.LNMAP(IXM(1,IS))) THEN
            CARDWK=CARDIM
            J=IXM(2,IS)
            CALL STBLNK(CARDIM,J,256)
          END IF
          CALL CRDPRN(1)
C
C  IS1 - the last regular statement before the special statement.
C
          IS1=IS-1
   10     CONTINUE
          IF(IL.LT.LNMAP(IXM(1,IS))) THEN
            READ(13)CARDIM
            CARDWK=CARDIM
            IL=IL+1
            IF(IL.EQ.LNMAP(IXM(3,IS1))) THEN
              J=IXM(4,IS1)+1
              CALL STBLNK(CARDIM,J,256)
              CALL CRDPRN(2)
            ELSE IF(IL.LT.LNMAP(IXM(1,IS))) THEN
              CALL CRDPRN(2)
            END IF
            GO TO 10
          END IF
        END IF
C
C  Treatment of the special statement to be offset
C
        IF(IL.LT.LNMAP(IXM(1,IS))) THEN
          READ(13)CARDIM
          IL=IL+1
          CARDWK=CARDIM
        ELSE
          CARDIM=CARDWK
        END IF
        J=IXM(2,IS)-1
        IF(IL.GT.1.OR.IS.GT.1) THEN
          CALL STBLNK(CARDIM,1,J)
        END IF
        IF(IL.EQ.LNMAP(IXM(3,IS)).AND.IS.LT.ISTATE) THEN
          J=IS+1
          IF(IL.EQ.LNMAP(IXM(1,J))) THEN
C                                                     ! Blank out next
            J=IXM(4,IS)+1
C                                                     ! statement, but
            CALL STBLNK(CARDIM,J,256)
C                                                       ! not comment
          END IF
        END IF
        CALL CRDPRN(1)
        ISP=IS
   15   CONTINUE
        IF(IL.LT.LNMAP(IXM(3,IS))) THEN
          READ(13)CARDIM
          IL=IL+1
          IF(IL.EQ.LNMAP(IXM(3,IS))) THEN
            CARDWK=CARDIM
            J=IXM(4,IS)+1
            CALL STBLNK(CARDIM,J,256)
            CALL CRDPRN(2)
          ELSE IF(IL.LT.LNMAP(IXM(3,IS))) THEN
            CALL CRDPRN(2)
          END IF
          GO TO 15
        ELSE
          J=IXM(6,IS)
          IF(IXM(5,IS).EQ.5) THEN
            J=J+1
          END IF
          K=IXM(7,IS)
          IF(IXM(5,IS).EQ.5.OR.IXM(5,IS).EQ.9.OR.IXM(5,IS).EQ.12) THEN
            K=K+1
          END IF
          IF(IXM(2,IS).LE.45) THEN
            L=IXM(2,IS)
          ELSE
            L=45
          END IF
          CALL STBLNK(CARDIM,1,L)
          IF(IFORM.EQ.1) THEN
            WRITE(CARDIM(L:256),201)J
          ELSE IF(IFORM.EQ.2) THEN
            WRITE(CARDIM(L:256),202)K
          ELSE IF(IFORM.EQ.3) THEN
            WRITE(CARDIM(L:256),203)J,K
          END IF
          CALL CRDPRN(2)
        END IF
      END IF
   30 CONTINUE
      CALL FSTOP
      END
C
      SUBROUTINE RPOLSH(IX,IPT,LNEND,IPTEND,ISTTYP,VTMPSZ,NPOLSH,
     . MSDPTH,MSDPT2,NINSET,ISDPT2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C  IX     - IX array passed to CMPAR1.  IX is not referenced through
C           a COMMON statement because of differences between CREATE
C           and TRANSFORM in the COMMON block definitions of IX.
C  IPT    - provided by KEYFND, next nonblank position in CARD, if any.
C  LNEND  - ending line of expression
C  IPTEND - ending character (on ending line) of expression
C  ISTTYP - statement type
C  VTMPSZ - available storage in VTEMP
C  NPOLSH - number of records generated
C  MSDPTH - maximum depth of stack in items
C  MSDPT2 - maximum depth of stack in elements, counting separately the
C           elements of multiple-element sets { }
C  NINSET - passed by calling routine - the number of items expected
C           in a set
C  ISDPT2 - returned depth of stack at end of calculation - in terms
C           of number of elements
C
      PARAMETER (MAXALT=5)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
C
      PARAMETER (LNITEM=8,MXLSTK=1000,MXSTCK=2000)
C
      PARAMETER (NUMFUN=7)
C
      INTEGER IX(*),IPT,LNEND,IPTEND,NPOLSH
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
C
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
      INTEGER VTMPSZ
C
C  TSWTCH - 1 if TRANSFORM step
C           2 if CREATE step (or REWEIGHT, etc.)
C  NLINE  - number of lines written to unit 14
C  ILINE  - the current line
C  NSTATE - number of statements
C  ISTATE - the current statement
C
      CHARACTER*256 CARDWK,CARDSV,CARDIM
      COMMON /CMBLK2/CARDWK,CARDSV,CARDIM
      LOGICAL ALPCHK,DGTCHK,REFRSH
      EXTERNAL ALPCHK,DGTCHK,REFRSH
      CHARACTER *12 FUNCNM(NUMFUN)
C
      DATA FUNCNM/'SQRT        ','ABS         ','LOG         ',
     .            'EXP         ','INT         ','MISSING     ',
     .            'FULL_SAMPLE '/
C
      REWIND(16)
C
C     REWIND(17)
C
C  NPOLSH - number of items in reverse Polish expression
C  IAPOST - flag to indicate within parenthesis ' '
C  NPASS1 - number of lines written to output file in 1st pass
C  IPLVL  - current level of parenthesis
C  MPLVL  - maximum depth of parenthesis
C  ICHS   - flag to indicate that "-" should be treated as the
C           change sign function at this point.
C           Conditions:
C             beginning of expression
C             following ( or [
C             following logical operator .EQ. etc.
C
C  RPOLSH does not write fatal error messages but instead sets
C           the value of IMERR1 and returns
C
C  The primary output of RPOLSH is an array passed back in IX
C  Each row has 5 elements:
C  IX(NXPTIS)   = Code
C  IX(NXPTIS+1) = Record number on unit 16
C  IX(NXPTIS+2) = Number of characters
C  IX(NXPTIS+3) = Reference line for error message
C  IX(NXPTIS+4) = Reference character for error message
C
      NPOLSH=0
      IAPOST=0
      IPOS=IPT
      NXPTIS=NXPTI
      NPASS1=0
      IPLVL=0
      MPLVL=0
      ICHS=1
C
C  Beginning in NXPTI, build up an array with each term of the
C  expression.  Each term uses LNITEM(=8) elements.
C
C  IX(BASE)   - Codes for components (below)
C  IX(BASE+1) - Record number on unit 16
C  IX(BASE+2) - Number of characters
C  IX(BASE+3) - Priority level, initially based on depth of
C               parenthesis, but later changed to reflect the
C               order of operations
C  IX(BASE+4) - Position in stack, 0 if not yet in stack
C               (working element - repeatedly changed)
C  IX(BASE+5) - Depth of parenthesis
C  IX(BASE+6) - reference line for error message
C  IX(BASE+7) - reference character for error message
C
C  OR     1   1
C  AND    2   2
C  NOT    3   3 (implemented with PLACE and function)
C  LT     4   4
C  LE     5   4
C  EQ     6   4
C  NE     7   4
C  GT     8   4
C  GE     9   4
C  IN    10   4
C  CHS   11   5
C  +     12   5
C  -     13   5
C  *     14   6
C  /     15   6
C  **    16   7
C  place 17   8 (for function) 5 (for not)
C  =     18
C  ;     19
C  fn    20   (function, single argument)
C  var   21
C  con   22   (constant)
C  { ..  23
C  fn    24   applied to set
C  fn    25   (function of multiple arguments, e.g., IDCHANGE)
C  THEN  29
C  +X    30
C  (     31
C  [     32
C  )     33
C  ]     34
C
    1 CONTINUE
      IBASE=NXPTI
      CALL ROOMI(LNITEM)
      IX(IBASE)=0
      IX(IBASE+1)=0
      IX(IBASE+2)=0
      IX(IBASE+3)=IPLVL
      IX(IBASE+4)=0
      IX(IBASE+5)=IPLVL
      IX(IBASE+6)=LNCNTR
      IX(IBASE+7)=IPOS
      IF(CARD(IPOS:IPOS).EQ.'(') THEN
        ICHS=1
        IX(IBASE)=31
        IPLVL=IPLVL+1
        IF(IPLVL.GT.MPLVL) MPLVL=IPLVL
      ELSE IF(CARD(IPOS:IPOS).EQ.'[') THEN
        ICHS=1
        IX(IBASE)=32
        IPLVL=IPLVL+1
        IF(IPLVL.GT.MPLVL) MPLVL=IPLVL
      ELSE IF(CARD(IPOS:IPOS).EQ.')') THEN
        ICHS=0
        IX(IBASE)=33
        IPLVL=IPLVL-1
      ELSE IF(CARD(IPOS:IPOS).EQ.']') THEN
        ICHS=0
        IX(IBASE)=34
        IPLVL=IPLVL-1
      ELSE IF(CARD(IPOS:IPOS).EQ.'+') THEN
        IF(ICHS.EQ.1) THEN
          IX(IBASE)=30
          ICHS=0
        ELSE
          IX(IBASE)=12
          IX(IBASE+1)=5
        END IF
      ELSE IF(CARD(IPOS:IPOS).EQ.'-') THEN
        IF(ICHS.EQ.1) THEN
          IF(DGTCHK(CARD(IPOS+1:IPOS+1)).OR.CARD(IPOS+1:IPOS+1).EQ.'.')
     .        THEN
            CALL DFIND(IPOS,IPOS2,DVALUE,DVAL2,1)
            IF(IPOS2.LT.IPOS) THEN
              IMERR1=161102
              IMERR2=IPOS
              RETURN
            END IF
            J=IPOS2-IPOS
            CARDWK(1:J)=CARD(IPOS:IPOS2-1)
            NPASS1=NPASS1+1
            IX(IBASE+1)=NPASS1
            IX(IBASE+2)=J
            J=J+1
            CALL STBLNK(CARDWK,J,256)
            WRITE(16)CARDWK
            IX(IBASE)=22
            IPOS=IPOS2-1
          ELSE
            IX(IBASE)=20
            IX(IBASE+1)=2
            IX(IBASE+2)=IBASE
            IBASE=NXPTI
            CALL ROOMI(LNITEM)
            IX(IBASE)=17
            IX(IBASE+1)=5
            IX(IBASE+2)=IBASE-LNITEM
            IX(IBASE+3)=IPLVL
            IX(IBASE+4)=0
            IX(IBASE+5)=IPLVL
            IX(IBASE+6)=LNCNTR
            IX(IBASE+7)=IPOS
          END IF
          ICHS=0
        ELSE
          IX(IBASE)=13
          IX(IBASE+1)=5
        END IF
      ELSE IF(CARD(IPOS:IPOS).EQ.'*') THEN
        ICHS=0
        IF(CARD(IPOS+1:IPOS+1).EQ.'*') THEN
          IPOS=IPOS+1
          IX(IBASE)=16
          IX(IBASE+1)=7
C
C  Examine code for a**b**c
C
          IF(IBASE.GT.NXPTIS) THEN
            DO 23 I=IBASE-LNITEM,NXPTIS,-LNITEM
            IF(IX(I+5).LT.IPLVL) THEN
              GO TO 24
            ELSE IF(IX(I+5).EQ.IPLVL) THEN
              IF(IX(I).EQ.16) THEN
                IMERR1=161120
                IMERR2=IPOS
                RETURN
              ELSE IF(IX(I).LE.17) THEN
                GO TO 24
              END IF
            END IF
   23       CONTINUE
   24       CONTINUE
          END IF
        ELSE
          IX(IBASE)=14
          IX(IBASE+1)=6
        END IF
      ELSE IF(CARD(IPOS:IPOS).EQ.'/') THEN
        IF(CARD(IPOS+1:IPOS+1).EQ.'=') THEN
          IPOS=IPOS+1
          ICHS=1
          IX(IBASE)=7
          IX(IBASE+1)=4
        ELSE
          ICHS=0
          IX(IBASE)=15
          IX(IBASE+1)=6
        END IF
      ELSE IF(CARD(IPOS:IPOS).EQ.';') THEN
        ICHS=0
        IX(IBASE)=19
      ELSE IF(CARD(IPOS:IPOS).EQ.'=') THEN
        ICHS=1
        IF(CARD(IPOS+1:IPOS+1).EQ.'=') THEN
          IPOS=IPOS+1
          IX(IBASE)=6
          IX(IBASE+1)=4
        ELSE
          IX(IBASE)=18
        END IF
      ELSE IF(CARD(IPOS:IPOS).EQ.'.') THEN
        IPOS3=IPOS+1
        CALL CMATCH(CARD(IPOS3:256),IPOS3,256,'OR',2,IPOS2,1)
        IF(IPOS2.GT.IPOS) THEN
          IF(CARD(IPOS2:IPOS2).EQ.'.') THEN
            IPOS=IPOS2
            IX(IBASE)=1
            IX(IBASE+1)=1
          END IF
        ELSE
          CALL CMATCH(CARD(IPOS3:256),IPOS3,256,'AND',3,IPOS2,1)
          IF(IPOS2.GT.IPOS) THEN
            IF(CARD(IPOS2:IPOS2).EQ.'.') THEN
              IPOS=IPOS2
              IX(IBASE)=2
              IX(IBASE+1)=2
            END IF
          ELSE
            CALL CMATCH(CARD(IPOS3:256),IPOS3,256,'NOT',3,IPOS2,1)
            IF(IPOS2.GT.IPOS) THEN
              IF(CARD(IPOS2:IPOS2).EQ.'.') THEN
                IX(IBASE)=20
                IX(IBASE+1)=1
                IX(IBASE+2)=IBASE
                IBASE=NXPTI
                CALL ROOMI(LNITEM)
                IX(IBASE)=17
                IX(IBASE+1)=3
                IX(IBASE+2)=IBASE-LNITEM
                IX(IBASE+3)=IPLVL
                IX(IBASE+4)=0
                IX(IBASE+5)=IPLVL
                IX(IBASE+6)=LNCNTR
                IX(IBASE+7)=IPOS
                IPOS=IPOS2
              END IF
            ELSE
              CALL CMATCH(CARD(IPOS3:256),IPOS3,256,'LT',2,IPOS2,1)
              IF(IPOS2.GT.IPOS) THEN
                IF(CARD(IPOS2:IPOS2).EQ.'.') THEN
                  IPOS=IPOS2
                  IX(IBASE)=4
                  IX(IBASE+1)=4
                END IF
              ELSE
                CALL CMATCH(CARD(IPOS3:256),IPOS3,256,'LE',2,IPOS2,1)
                IF(IPOS2.GT.IPOS) THEN
                  IF(CARD(IPOS2:IPOS2).EQ.'.') THEN
                    IPOS=IPOS2
                    IX(IBASE)=5
                    IX(IBASE+1)=4
                  END IF
                ELSE
                  CALL CMATCH(CARD(IPOS3:256),IPOS3,256,'EQ',2,IPOS2,1)
                  IF(IPOS2.GT.IPOS) THEN
                    IF(CARD(IPOS2:IPOS2).EQ.'.') THEN
                      IPOS=IPOS2
                      IX(IBASE)=6
                      IX(IBASE+1)=4
                    END IF
                  ELSE
                    CALL CMATCH(CARD(IPOS3:256),IPOS3,256,'NE',2,IPOS2,
     .                1)
                    IF(IPOS2.GT.IPOS) THEN
                      IF(CARD(IPOS2:IPOS2).EQ.'.') THEN
                        IPOS=IPOS2
                        IX(IBASE)=7
                        IX(IBASE+1)=4
                      END IF
                    ELSE
                      CALL CMATCH(CARD(IPOS3:256),IPOS3,256,'GT',2,
     .                            IPOS2,1)
                      IF(IPOS2.GT.IPOS) THEN
                        IF(CARD(IPOS2:IPOS2).EQ.'.') THEN
                          IPOS=IPOS2
                          IX(IBASE)=8
                          IX(IBASE+1)=4
                        END IF
                      ELSE
                        CALL CMATCH(CARD(IPOS3:256),IPOS3,256,'GE',2,
     .                              IPOS2,1)
                        IF(IPOS2.GT.IPOS) THEN
                          IF(CARD(IPOS2:IPOS2).EQ.'.') THEN
                            IPOS=IPOS2
                            IX(IBASE)=9
                            IX(IBASE+1)=4
                          END IF
                        ELSE
                          CALL CMATCH(CARD(IPOS3:256),IPOS3,256,'IN',2,
     .                               IPOS2,1)
                          IF(IPOS2.GT.IPOS) THEN
                            IF(CARD(IPOS2:IPOS2).EQ.'.') THEN
                              IPOS=IPOS2
                              IX(IBASE)=10
                              IX(IBASE+1)=4
                            END IF
                          END IF
                        END IF
                      END IF
                    END IF
                  END IF
                END IF
              END IF
            END IF
          END IF
        END IF
        IF(IX(IBASE).GT.0) THEN
          ICHS=1
        END IF
      ELSE IF(CARD(IPOS:IPOS).EQ.'<') THEN
        ICHS=1
        IF(CARD(IPOS+1:IPOS+1).EQ.'=') THEN
          IPOS=IPOS+1
          IX(IBASE)=5
          IX(IBASE+1)=4
        ELSE
          IX(IBASE)=4
          IX(IBASE+1)=4
        END IF
      ELSE IF(CARD(IPOS:IPOS).EQ.'>') THEN
        ICHS=1
        IF(CARD(IPOS+1:IPOS+1).EQ.'=') THEN
          IPOS=IPOS+1
          IX(IBASE)=9
          IX(IBASE+1)=4
        ELSE
          IX(IBASE)=8
          IX(IBASE+1)=4
        END IF
      END IF
      IF(IX(IBASE).GT.0) THEN
        IPOS=IPOS+1
C
C  Do not store "(" "[" ")" or "]" or initial plus
C  (All information reflected in IX(IBASE+5) )
C
        IF(IX(IBASE).GE.30.AND.IX(IBASE).LE.34) THEN
          NXPTI=NXPTI-LNITEM
        END IF
      ELSE
C
        IF(ALPCHK(CARD(IPOS:IPOS))) THEN
          ICHS=0
C
          CALL VNFIND(IPOS,VTEMP(SVTEMP),VTMPSZ,I,IPOS2,3,VNAME,1)
          IF(I.EQ.1) THEN
            CALL VNMTCH(VTEMP(SVTEMP),FUNCNM,NUMFUN,J)
C           CALL CMATCH(VTEMP(SVTEMP),1,12,'SQRT',4,J,1)
            IF(J.GT.0) THEN
              IX(IBASE)=20
              IX(IBASE+1)=2+J
              IX(IBASE+2)=IBASE
              IBASE=NXPTI
              CALL ROOMI(LNITEM)
              IX(IBASE)=17
              IX(IBASE+1)=8
              IX(IBASE+2)=IBASE-LNITEM
              IX(IBASE+3)=IPLVL
              IX(IBASE+4)=0
              IX(IBASE+5)=IPLVL
              IX(IBASE+6)=LNCNTR
              IX(IBASE+7)=IPOS
              IPOS=IPOS2
            ELSE
              CALL CMATCH(VTEMP(SVTEMP),1,12,'IDCHANGE',8,J,1)
              IF(J.GT.0) THEN
                IX(IBASE)=25
                ICHS=0
                CALL NBFND2(IPOS2,IPT)
                IF(CARD(IPT:IPT).NE.'(') THEN
                  IMERR1=31037
                  RETURN
                END IF
                IPOS=IPT+1
                IPAREN=1
                IAPOST=0
                IX(IBASE+1)=NPASS1+1
                IX(IBASE+2)=0
    6           CONTINUE
                DO 8 J=IPOS,256
                IF(CARD(J:J).EQ.'''') THEN
                  IF(IAPOST.EQ.0) THEN
                    IAPOST=1
                  ELSE
                    IAPOST=0
                  END IF
                ELSE IF(IAPOST.EQ.0) THEN
                  IF(CARD(J:J).EQ.'(') THEN
                    IPAREN=IPAREN+1
                  ELSE IF(CARD(J:J).EQ.')') THEN
                    IPAREN=IPAREN-1
                    IF(IPAREN.EQ.0) THEN
                      GO TO 10
                    END IF
                  END IF
                END IF
    8           CONTINUE
                J=257-IPOS
                CARDWK(1:J)=CARD(IPOS:256)
                NPASS1=NPASS1+1
                IF(J.LT.256) THEN
                  J=J+1
                  CALL STBLNK(CARDWK,J,256)
                END IF
                IX(IBASE+2)=IX(IBASE+2)+256
                WRITE(16)CARDWK
                IPOS=257
                CALL NBFND2(IPOS,IPOS2)
                GO TO 6
   10           CONTINUE
                K=J-IPOS
                CARDWK(1:K)=CARD(IPOS:J-1)
                IX(IBASE+2)=IX(IBASE+2)+K
                IPOS=J+1
                K=K+1
                CALL STBLNK(CARDWK,K,256)
                NPASS1=NPASS1+1
                WRITE(16)CARDWK
              ELSE
C
C  Normal variable name
C
                J=IPOS2-IPOS
                CARDWK(1:J)=CARD(IPOS:IPOS2-1)
                NPASS1=NPASS1+1
                IX(IBASE+1)=NPASS1
                IX(IBASE+2)=J
                J=J+1
                CALL STBLNK(CARDWK,J,256)
                IX(IBASE)=21
C
C  If encounter THEN, handle initially as variable but eliminate later
C
                IF(J.EQ.5) THEN
                  IF(ISTTYP.EQ.5.OR.ISTTYP.EQ.6) THEN
                    CALL CMATCH(CARDWK(1:4),1,4,'THEN',4,J,1)
                    IF(J.GT.0) THEN
                      IX(IBASE)=29
                    END IF
                  END IF
C
C  If encounter REPW, REPF during CREATE or REWEIGHT, treat as set { }
C  Also treat any variable from a VPLX file during REWEIGHT this way.
C
                  IF(TSWTCH.EQ.2) THEN
                    CALL CMATCH(CARDWK(1:4),1,4,'REPW',4,J,1)
                    IF(J.GT.0) THEN
                      IX(IBASE)=23
                    END IF
                    CALL CMATCH(CARDWK(1:4),1,4,'REPF',4,J,1)
                    IF(J.GT.0) THEN
                      IX(IBASE)=23
                    END IF
                  END IF
                END IF
                IF(TSWTCH.EQ.2.AND.NVREG.GT.0) THEN
C                                               ! NVREG is set to 0 in
                  K=RCEIL(2)+1
C                                               ! SETUP1, except during
C                                               ! REWEIGHT
C
                  CALL VNMTCH(CARDWK(1:12),VNAME(K),NVREG,J)
                  IF(J.GT.0) THEN
C                                               ! Treat any variable
                    IX(IBASE)=23
C                                               ! from VPLX file as
                  END IF
C                                               ! { }
                END IF
C
C  Begin to look for array specification
C
                L=LNCNTR
                IF(LNCNTR.LT.LNEND.OR.
     .             (LNCNTR.EQ.LNEND.AND.IPOS2.LE.IPTEND)) THEN
                  CALL NBFND2(IPOS2,IPOS3)
                  IF(LNCNTR.LT.LNEND.OR.
     .               (LNCNTR.EQ.LNEND.AND.IPOS3.LE.IPTEND)) THEN
                    IF(CARD(IPOS3:IPOS3).EQ.'(') THEN
                      IF(TSWTCH.EQ.2) THEN
                        IMERR1=161118
                        IMERR2=IPOS3
                        RETURN
                      END IF
                      IF(LNCNTR.GT.L) THEN
                        WRITE(16)CARDWK
                        J=IPOS3-1
                        CALL STBLNK(CARDWK,1,J)
                        IPOS=IPOS3
                      END IF
                    ELSE
                      WRITE(16)CARDWK
                      IPOS=IPOS3
                    END IF
                  END IF
                ELSE
                  IPOS=IPOS2
                  WRITE(16)CARDWK
                END IF
              END IF
            END IF
          ELSE
            IMERR1=161100
            IMERR2=IPOS
            RETURN
          END IF
        ELSE IF(DGTCHK(CARD(IPOS:IPOS)).OR.CARD(IPOS:IPOS).EQ.'.') THEN
C
C  Number
C
          ICHS=0
          CALL DFIND(IPOS,IPOS2,DVALUE,DVAL2,1)
          IF(IPOS2.LT.IPOS) THEN
            IMERR1=161102
            IMERR2=IPOS
            RETURN
          END IF
          J=IPOS2-IPOS
          CARDWK(1:J)=CARD(IPOS:IPOS2-1)
          NPASS1=NPASS1+1
          IX(IBASE+1)=NPASS1
          IX(IBASE+2)=J
          J=J+1
          CALL STBLNK(CARDWK,J,256)
          WRITE(16)CARDWK
          IX(IBASE)=22
          IPOS=IPOS2
        ELSE IF(CARD(IPOS:IPOS).EQ.'{') THEN
C
C  { ... }
C
          ICHS=0
          ISET=1
          IX(IBASE)=23
          IAPOST=0
          IX(IBASE+1)=NPASS1+1
          IX(IBASE+2)=0
          IPOS=IPOS+1
   12     CONTINUE
          DO 14 J=IPOS,256
          IF(CARD(J:J).EQ.'''') THEN
            IF(IAPOST.EQ.0) THEN
              IAPOST=1
            ELSE
              IAPOST=0
            END IF
          ELSE IF(IAPOST.EQ.0) THEN
            IF(CARD(J:J).EQ.'{') THEN
              ISET=ISET+1
            ELSE IF(CARD(J:J).EQ.'}') THEN
              ISET=ISET-1
              IF(ISET.EQ.0) THEN
                GO TO 16
              END IF
            END IF
          END IF
   14     CONTINUE
          J=257-IPOS
          CARDWK(1:J)=CARD(IPOS:256)
          NPASS1=NPASS1+1
          IF(J.LT.256) THEN
            J=J+1
            CALL STBLNK(CARDWK,J,256)
          END IF
          IX(IBASE+2)=IX(IBASE+2)+256
          WRITE(16)CARDWK
          IPOS=257
          CALL NBFND2(IPOS,IPOS2)
          GO TO 12
   16     CONTINUE
          K=J-IPOS
          CARDWK(1:K)=CARD(IPOS:J-1)
          IX(IBASE+2)=IX(IBASE+2)+K
          IPOS=J+1
          K=K+1
          CALL STBLNK(CARDWK,K,256)
          NPASS1=NPASS1+1
          WRITE(16)CARDWK
        ELSE
          IMERR1=161117
          IMERR2=IPOS
          RETURN
        END IF
      END IF
C
C  Check to see if at end of expression
C
      IF(LNCNTR.LT.LNEND.OR.(LNCNTR.EQ.LNEND.AND.IPOS.LE.IPTEND)) THEN
        CALL NBFND2(IPOS,IPOS2)
        IF(LNCNTR.LT.LNEND.OR.(LNCNTR.EQ.LNEND.AND.IPOS2.LE.IPTEND))THEN
          IPOS=IPOS2
          GO TO 1
        END IF
      END IF
C
C  Remove final ";"
C
      IF(IX(IBASE).EQ.19) THEN
        NXPTI=NXPTI-LNITEM
      END IF
C
C  At this point, the expression has be decomposed into components
C  and represented in the matrix starting in IX(NXPTIS)
C
C  Remove an ending 'THEN' for IF and ELSEIF
C
      IF(ISTTYP.EQ.5.OR.ISTTYP.EQ.6) THEN
        DO 20 I=NXPTIS,NXPTI-LNITEM,LNITEM
        IF(I.LT.NXPTI-LNITEM) THEN
          IF(IX(I).EQ.29) THEN
            IX(I)=21
          END IF
        ELSE
          IF(IX(I).EQ.29) THEN
            NPASS1=NPASS1-1
            NXPTI=NXPTI-LNITEM
          END IF
        END IF
   20   CONTINUE
      END IF
      NITEM=(NXPTI-NXPTIS)/LNITEM
      REWIND(16)
C
C     write(*,*)nxptis,nxpti,npass1,lncntr,lnend
C     DO 92 I=NXPTIS,NXPTI-LNITEM,LNITEM
C     write(6,166)(ix(j),j=i,i+7)
C  92 continue
C
C     do 3 i=1,npass1
C     read(16)cardwk
C     write(*,*)cardwk(1:60)
C   3 continue
C     rewind(16)
C
C
C
C  Reflect the order of operations by setting priorities/levels
C  in IX(BASE+3).  IX(BASE+3) was initialized to the same content
C  as IX(BASE+5), which has the level of parentheses.
C
      NXPTI2=NXPTI
C
C  A stack of operators within each level of parenthesis is
C  built up.  Maximum = 3 * 8 operators.  This space is used only
C  down to the loop to statement 38.
C
      CALL ROOMI(24)
      NXPTI=NXPTI2
      MRLVL=MPLVL
C                                           ! MRLVL - max. recoded level
C
C  Loop over each level of parentheses.
C
      DO 38 IPLVL=0,MPLVL
C                                           ! IPLVL - level of paren
      IBASE=NXPTI2
C                                           ! IBASE - location in
      ILEVEL=1
C                                           !   operator stack
      IX(IBASE)=0
      IX(IBASE+1)=0
      IX(IBASE+2)=0
      IOPER=0
      DO 36 I=NXPTIS,NXPTI-LNITEM,LNITEM
C
C  Set IOPER to the lowest level operator at this level
C
      IF(IX(I+5).EQ.IPLVL) THEN
        IF(IX(I).LE.17) THEN
          IF(IOPER.EQ.0) THEN
            IOPER=IX(I+1)
          ELSE IF(IOPER.GT.IX(I+1)) THEN
            IOPER=IX(I+1)
          END IF
        END IF
      END IF
C
C  Store in IX(IBASE) the start of this level
C           IX(IBASE+1) the end of this level
C           IX(IBASE+2) code of operator
C
      IF(IX(IBASE).EQ.0) THEN
        IF(IX(I+5).GE.IPLVL) THEN
          IX(IBASE)=I
          IX(IBASE+1)=0
        END IF
      ELSE IF(I.EQ.NXPTI-LNITEM) THEN
        IX(IBASE+1)=I
C       write(*,*)ix(ibase+1)
C
C  When IX(I+5) drops below IPLVL, end was previous entry
C
      ELSE IF(IX(I+5).LT.IPLVL) THEN
        IX(IBASE+1)=I-LNITEM
C       write(*,*)ix(ibase+1),iplvl
      END IF
C
      IF(IX(IBASE).GT.0.AND.IX(IBASE+1).GT.0) THEN
        IF(IOPER.GT.0) THEN
C
C  Get to here if at least one operator at level IPLVL and expression
C  is contained in IX from IX(IBASE) to IX(IBASE+1)
C
          IX(IBASE+2)=IOPER
C
C  Recursive scanning of this level for priority for calculation
C  If lowest level is .OR., for example, break overall length into
C  segments between .OR. and look for higher level operators within
C  each segment.
C
   25     CONTINUE
          ISTART=IX(IBASE)
          IEND=IX(IBASE+1)
          IOPER=IX(IBASE+2)
C
C  OPERN will contain the next highest level operator found in the
C  segment, if any
C
          IOPERN=0
C         write(*,*)istart,iend,ilevel,ioper
          DO 27 I2=ISTART,IEND,LNITEM
          IF(ILEVEL.GE.2) THEN
            IX(I2+3)=IX(I2+3)+1
            IF(IX(I2+3).GT.MRLVL) THEN
              MRLVL=IX(I2+3)
            END IF
          END IF
C
C  Update OPERN, if appropriate
C
          IF(IX(I2+5).EQ.IPLVL) THEN
            IF(IX(I2).LE.17) THEN
              IF(IX(I2+1).GT.IOPER) THEN
                IF(IOPERN.EQ.0) THEN
                  IOPERN=IX(I2+1)
                ELSE IF(IOPERN.GT.IX(I2+1)) THEN
                  IOPERN=IX(I2+1)
                END IF
              ELSE IF(IX(I2+1).EQ.IOPER) THEN
C
C  End of segment between operators.
C
                IX(IBASE)=I2+LNITEM
                IF(IOPERN.EQ.0) THEN
C
C  If no higher operators were present in the segment, update the
C  range and process the next segment
C
                  IF(IX(IBASE+1).GE.IX(IBASE)) THEN
                    GO TO 25
C                                           ! Process next segment
                  END IF
                ELSE
C
C  If a higher order operator is found, enter the next level
C  recursively and begin scan at 25.
C
                  IF(I2-LNITEM.GT.ISTART) THEN
C                   write(*,*)'*',i2,istart,iopern
                    IBASE=IBASE+3
                    IX(IBASE)=ISTART
                    IX(IBASE+1)=I2-LNITEM
                    IX(IBASE+2)=IOPERN
                    ILEVEL=ILEVEL+1
                    GO TO 25
                  END IF
                END IF
              END IF
            END IF
          END IF
   27     CONTINUE
C
C  At end of string for current operator, mark as completed.
C
          IX(IBASE)=0
          IX(IBASE+1)=0
          IF(IOPERN.GT.0) THEN
C
C  If a higher order operator is found, enter the next level
C  recursively and begin scan at 5.
C
            IBASE=IBASE+3
            IX(IBASE)=ISTART
            IX(IBASE+1)=IEND
            IX(IBASE+2)=IOPERN
            ILEVEL=ILEVEL+1
            GO TO 25
          END IF
   30     CONTINUE
C
C  Have completed scan at level ILEVEL.  Drop down 1 or more levels
C  to find any not finished.
C
          ILEVEL=ILEVEL-1
          IBASE=IBASE-3
          IF(ILEVEL.GE.1) THEN
            IF(IX(IBASE).GT.0.AND.IX(IBASE+1).GE.IX(IBASE)) THEN
               GO TO 25
            ELSE IF(ILEVEL.GT.1) THEN
               GO TO 30
            END IF
          END IF
        END IF
        IF(IBASE.GE.NXPTI2) THEN
          IX(IBASE)=0
          IX(IBASE+1)=0
        ELSE
          IBASE=NXPTI2
C                                           ! Reinitialize to look for
          ILEVEL=1
C                                           ! next segment at IPLVL
          IX(IBASE)=0
          IX(IBASE+1)=0
          IX(IBASE+2)=0
          IOPER=0
        END IF
      END IF
   36 CONTINUE
C                                           ! End of loop over I
C                                           !   (encoded components)
   38 CONTINUE
C                                           ! End of loop over IPLVL
C
C     DO 19 I=NXPTIS,NXPTI-LNITEM,LNITEM
C     write(6,166)(ix(j),j=i,i+7)
C 166 format(1x,8i6)
C  19 continue
C
C  Arrangement of matrices in IX:
C  NXPTIS - points to beginning of initial item matrix
C  NXPTI2 - end of initial item matrix +1 (value of NXPTI after
C           initial item matrix has been filled)
C           It is used as the starting point of a stack with
C           the starting and ending position of the expression for
C           each level of IX(I+3) etc. for the matrix beginning at
C           IX(NXPTIS).  Space is allocated according to a generous
C           value for MXLSTK, but it may be the case that the highest
C           level of IX(i+3) may give the actual need (?).
C  NXPTI3 - start-1 of array to signal whether each element of the
C           active stack is a single value or a set.
C  ISTCKB - pointer to beginning of actual output from parsing.
C
C  Recursive evaluation by priorities in IX(I+3), incorporating
C  parentheses and order of operations.
C
C  ISTART - starting position in initial item matrix for this level
C  IEND   - ending position in initial item matrix for this level
C
C  ISTCKB - starting position of the final stack, with 5 items
C           for each element.  It is copied down to NXPTIS at the
C           end of the routine.
C
      I=2*MXLSTK
      CALL ROOMI(I)
      ILEVEL=0
      ILVLIX=NXPTI2
      NXPTI3=NXPTI-1
      CALL ROOMI(MXSTCK)
      ISTART=NXPTIS
      IEND=NXPTI2-LNITEM
C     write(*,*)istart,iend
      IX(ILVLIX)=ISTART
      IX(ILVLIX+1)=IEND
      ISTCKB=NXPTI
      MSDPTH=0
      ISDPTH=0
      MSDPT2=0
      ISDPT2=0
C
   40 CONTINUE
C
C  IOPER  = start in IX of next operator at current level
C  IELEM1 = start in IX of element preceding highest order
C           operator
C
      IOPER=0
      IELEM1=0
      JELEM1=0
      DO 48 I=ISTART,IEND,LNITEM
      IF(IX(I).LE.17) THEN
C
C  Find if operator is at ILEVEL and not yet incorporated into stack.
C
        IF(IX(I+3).EQ.ILEVEL.AND.IX(I+4).EQ.0) THEN
          IF(IOPER.EQ.0) THEN
            IOPER=I
            GO TO 49
          END IF
        END IF
      ELSE IF(IX(I+3).GE.ILEVEL) THEN
C
C  IELEM1 holds term before operator, whether or not in stack.
C
        IF(IOPER.EQ.0) THEN
          IF(IELEM1.EQ.0) THEN
            IELEM1=I
          END IF
        END IF
      END IF
C
   48 CONTINUE
   49 CONTINUE
C
C     write(*,*)ielem1,ioper
C
C  If no item is isolated, the parenthetical expression is
C  empty.  This is an error.
C
      IF(IELEM1.EQ.0) THEN
        IMERR1=161112
        IMERR2=IX(ISTART+7)
        LNCNTR=IX(ISTART+6)
        RETURN
      END IF
C
C  If no remaining operator is left, expect only one item.
C
      IF(IOPER.EQ.0) THEN
        IF(IX(IELEM1+4).EQ.0) THEN
          IF(IX(IELEM1+3).EQ.ILEVEL) THEN
            IF(IX(IELEM1).GE.20.AND.IX(IELEM1).LE.25) THEN
C
C  Single item is not yet in the stack.
C
              CALL ROOMI(5)
              ISDPTH=ISDPTH+1
              IF(IX(IELEM1).EQ.23) THEN
                ISDPT2=ISDPT2+NINSET
                IX(NXPTI3+ISDPTH)=1
              ELSE
                ISDPT2=ISDPT2+1
                IX(NXPTI3+ISDPTH)=0
              END IF
              IF(ISDPTH.GT.MSDPTH) THEN
                MSDPTH=ISDPTH
              END IF
              IF(ISDPT2.GT.MSDPT2) THEN
                MSDPT2=ISDPT2
              END IF
              IX(IELEM1+4)=ISDPTH
              IX(NXPTI-5)=IX(IELEM1)
              IX(NXPTI-4)=IX(IELEM1+1)
              IX(NXPTI-3)=IX(IELEM1+2)
              IX(NXPTI-2)=IX(IELEM1+6)
              IX(NXPTI-1)=IX(IELEM1+7)
            ELSE
              IMERR1=161119
              IMERR2=IX(IELEM1+7)
              LNCNTR=IX(IELEM1+6)
              RETURN
            END IF
          ELSE IF(IX(IELEM1+3).GT.ILEVEL) THEN
C
C  Item is an expression in parentheses, increment ILEVEL and
C  parse the parenthetical expression.
C
            ILEVEL=ILEVEL+1
            IF(ILEVEL.GT.MXLSTK) THEN
              IMERR1=161111
              RETURN
            END IF
            ILVLIX=ILVLIX+2
            ISTART=IELEM1
            DO 51 I=ISTART,IEND,LNITEM
            IF(IX(I+3).LT.ILEVEL) THEN
              GO TO 52
            END IF
   51       CONTINUE
            I=IEND+LNITEM
   52       CONTINUE
            IEND=I-LNITEM
C           WRITE(*,*)'26',ILVLIX,IEND
            IX(ILVLIX)=ISTART
            IX(ILVLIX+1)=IEND
            GO TO 40
          END IF
        END IF
C
C  Arrive here if have just placed an item in the stack or if stack
C  already contains the result for this level.
C
C  Check that result marked as entirely stored in stack.
C
        DO 55 I=ISTART,IEND,LNITEM
        IF(IX(I+4).NE.IX(IELEM1+4)) THEN
C         WRITE(*,*)ISTART,I,IEND,IX(I+4),IX(IELEM1+4)
          IMERR1=161113
          IMERR2=IX(I+7)
          LNCNTR=IX(I+6)
          RETURN
        END IF
   55   CONTINUE
        IF(ILEVEL.GT.0) THEN
          ILEVEL=ILEVEL-1
          ILVLIX=ILVLIX-2
          ISTART=IX(ILVLIX)
          IEND=IX(ILVLIX+1)
C         WRITE(*,*)'28',ILVLIX,IEND
        ELSE
          GO TO 75
        END IF
      ELSE
C
C  Operator is present.
C
        IF(IX(IELEM1+4).EQ.0) THEN
          IF(IX(IELEM1+3).EQ.ILEVEL) THEN
C                                              ! First item not in stack
C
            IF(IX(IELEM1).GE.20.AND.
     .        IX(IELEM1).LE.25) THEN
C                                              ! First item is simple
              CALL ROOMI(5)
              ISDPTH=ISDPTH+1
              IF(IX(IELEM1).EQ.23) THEN
                ISDPT2=ISDPT2+NINSET
                IX(NXPTI3+ISDPTH)=1
              ELSE
                ISDPT2=ISDPT2+1
                IX(NXPTI3+ISDPTH)=0
              END IF
              IF(ISDPTH.GT.MSDPTH) THEN
                MSDPTH=ISDPTH
              END IF
              IF(ISDPT2.GT.MSDPT2) THEN
                MSDPT2=ISDPT2
              END IF
              IX(IELEM1+4)=ISDPTH
              IX(NXPTI-5)=IX(IELEM1)
              IX(NXPTI-4)=IX(IELEM1+1)
              IX(NXPTI-3)=IX(IELEM1+2)
              IX(NXPTI-2)=IX(IELEM1+6)
              IX(NXPTI-1)=IX(IELEM1+7)
              IELEM2=IOPER+LNITEM
              IF(IELEM2.GT.IEND) THEN
C               write(*,*)ielem1,ioper,ielem2,iend
                IMERR1=161114
                IMERR2=IX(IELEM2+7)
                LNCNTR=IX(IELEM2+6)
                RETURN
              END IF
              IF(IX(IELEM2+4).GT.0) THEN
                IMERR1=161115
                IMERR2=IX(IELEM2+7)
                LNCNTR=IX(IELEM2+6)
                RETURN
              END IF
            ELSE
              IMERR1=161119
              IMERR2=IX(IELEM1+7)
              LNCNTR=IX(IELEM1+6)
              RETURN
            END IF
            IF(IX(IELEM2+3).EQ.ILEVEL) THEN
              IF(IX(IELEM2).GE.20.AND.IX(IELEM2).LE.25) THEN
C
C  Simple second item, place in stack
C
                CALL ROOMI(5)
                ISDPTH=ISDPTH+1
                IF(IX(IELEM2).EQ.23) THEN
                  ISDPT2=ISDPT2+NINSET
                  IX(NXPTI3+ISDPTH)=1
                ELSE
                  ISDPT2=ISDPT2+1
                  IX(NXPTI3+ISDPTH)=0
                END IF
                IF(ISDPTH.GT.MSDPTH) THEN
                  MSDPTH=ISDPTH
                END IF
                IF(ISDPT2.GT.MSDPT2) THEN
                  MSDPT2=ISDPT2
                END IF
                IX(IELEM2+4)=ISDPTH-1
                IX(NXPTI-5)=IX(IELEM2)
                IX(NXPTI-4)=IX(IELEM2+1)
                IX(NXPTI-3)=IX(IELEM2+2)
                IX(NXPTI-2)=IX(IELEM2+6)
                IX(NXPTI-1)=IX(IELEM2+7)
C               write(*,*)ix(nxpti-2),ix(nxpti-1)
C
C  Now place operator in stack
C
                CALL ROOMI(5)
                IX(NXPTI-5)=IX(IOPER)
                IF(IX(IOPER).GE.11.AND.IX(IOPER).LE.17) THEN
                  IF(IX(NXPTI3+ISDPTH-1).EQ.1) THEN
                    IF(IX(NXPTI3+ISDPTH).EQ.1) THEN
                      IX(NXPTI-5)=IX(NXPTI-5)+300
                      ISDPT2=ISDPT2-NINSET
                    ELSE
                      IX(NXPTI-5)=IX(NXPTI-5)+100
                      ISDPT2=ISDPT2-1
                    END IF
                  ELSE IF(IX(NXPTI3+ISDPTH).EQ.1) THEN
                    IX(NXPTI-5)=IX(NXPTI-5)+200
                    ISDPT2=ISDPT2-1
                    IX(NXPTI3+ISDPTH-1)=1
                  ELSE
                    ISDPT2=ISDPT2-1
                  END IF
                ELSE
                  ISDPT2=ISDPT2-1
                END IF
                ISDPTH=ISDPTH-1
                IX(NXPTI-4)=IX(IOPER+1)
                IX(NXPTI-3)=IX(IOPER+2)
                IX(NXPTI-2)=IX(IOPER+6)
                IX(NXPTI-1)=IX(IOPER+7)
                IX(IOPER+4)=ISDPTH
              ELSE
                IMERR1=161119
                IMERR2=IX(IELEM2+7)
                LNCNTR=IX(IELEM2+6)
                RETURN
              END IF
            ELSE
C
C  2nd item is an expression in parenthesis or involves a
C  higher-order operator.  Parse the expression.
C
              ILEVEL=ILEVEL+1
              IF(ILEVEL.GT.MXLSTK) THEN
                IMERR1=161111
                RETURN
              END IF
              ILVLIX=ILVLIX+2
              ISTART=IELEM2
              DO 60 I=ISTART,IEND,LNITEM
              IF(IX(I+3).LT.ILEVEL) THEN
                GO TO 61
              END IF
   60         CONTINUE
              I=IEND+LNITEM
   61         CONTINUE
              IEND=I-LNITEM
C             write(*,*)'32',ILVLIX,iend
              IX(ILVLIX)=ISTART
              IX(ILVLIX+1)=IEND
            END IF
          ELSE
C
C  1st item is an expression in parenthesis or involves a
C  higher-order operator.  Parse the expression.
C
            ILEVEL=ILEVEL+1
            IF(ILEVEL.GT.MXLSTK) THEN
              IMERR1=161111
              RETURN
            END IF
            ILVLIX=ILVLIX+2
            ISTART=IELEM1
            DO 63 I=ISTART,IEND,LNITEM
            IF(IX(I+3).LT.ILEVEL) THEN
              GO TO 64
            END IF
   63       CONTINUE
            I=IEND+LNITEM
   64       CONTINUE
            IEND=I-LNITEM
C
C           write(*,*) '34',ILVLIX,iend
C
            IX(ILVLIX)=ISTART
            IX(ILVLIX+1)=IEND
          END IF
        ELSE
C
C  First item is already in stack.
C
          IELEM2=IOPER+LNITEM
          IF(IELEM2.GT.IEND) THEN
C
C           write(*,*)ielem1,ielem2,iend
C     WRITE(u6,170)(IX(I),I=ISTCKB,NXPTI-1)
C
            IMERR1=161114
            IMERR2=IX(IELEM2+7)
            LNCNTR=IX(IELEM2+6)
            RETURN
          END IF
          IF(IX(IELEM2+4).EQ.0) THEN
            IF(IX(IELEM2+3).EQ.ILEVEL) THEN
              IF(IX(IELEM2).GE.20.AND.IX(IELEM2).LE.25) THEN
C
C  Simple second item, place in stack
C
                CALL ROOMI(5)
                ISDPTH=ISDPTH+1
                IF(IX(IELEM2).EQ.23) THEN
                  ISDPT2=ISDPT2+NINSET
                  IX(NXPTI3+ISDPTH)=1
                ELSE
                  ISDPT2=ISDPT2+1
                  IX(NXPTI3+ISDPTH)=0
                END IF
                IF(ISDPTH.GT.MSDPTH) THEN
                  MSDPTH=ISDPTH
                END IF
                IF(ISDPT2.GT.MSDPT2) THEN
                  MSDPT2=ISDPT2
                END IF
                IX(IELEM2+4)=ISDPTH-1
                IX(NXPTI-5)=IX(IELEM2)
                IX(NXPTI-4)=IX(IELEM2+1)
                IX(NXPTI-3)=IX(IELEM2+2)
                IX(NXPTI-2)=IX(IELEM2+6)
                IX(NXPTI-1)=IX(IELEM2+7)
C
C  Now place operator in stack
C
                CALL ROOMI(5)
                IX(NXPTI-5)=IX(IOPER)
                IF(IX(IOPER).GE.11.AND.IX(IOPER).LE.17) THEN
                  IF(IX(NXPTI3+ISDPTH-1).EQ.1) THEN
                    IF(IX(NXPTI3+ISDPTH).EQ.1) THEN
                      IX(NXPTI-5)=IX(NXPTI-5)+300
                      ISDPT2=ISDPT2-NINSET
                    ELSE
                      IX(NXPTI-5)=IX(NXPTI-5)+100
                      ISDPT2=ISDPT2-1
                    END IF
                  ELSE IF(IX(NXPTI3+ISDPTH).EQ.1) THEN
                    IX(NXPTI-5)=IX(NXPTI-5)+200
                    ISDPT2=ISDPT2-1
                    IX(NXPTI3+ISDPTH-1)=1
                  ELSE
                    ISDPT2=ISDPT2-1
                  END IF
                ELSE
                  ISDPT2=ISDPT2-1
                END IF
                ISDPTH=ISDPTH-1
                IX(NXPTI-4)=IX(IOPER+1)
                IX(NXPTI-3)=IX(IOPER+2)
                IX(NXPTI-2)=IX(IOPER+6)
                IX(NXPTI-1)=IX(IOPER+7)
                IX(IOPER+4)=ISDPTH
              ELSE
                IMERR1=191119
                IMERR2=IX(IELEM2+7)
                LNCNTR=IX(IELEM2+6)
                RETURN
              END IF
            ELSE
C
C  2nd item is an expression in parenthesis or involves a
C  higher-order operator.  Parse the expression.
C
              ILEVEL=ILEVEL+1
              IF(ILEVEL.GT.MXLSTK) THEN
                IMERR1=161111
                LNCNTR=IX(IELEM2+6)
                RETURN
              END IF
              ILVLIX=ILVLIX+2
              ISTART=IELEM2
              DO 66 I=ISTART,IEND,LNITEM
              IF(IX(I+3).LT.ILEVEL) THEN
                GO TO 67
              END IF
   66         CONTINUE
              I=IEND+LNITEM
   67         CONTINUE
              IEND=I-LNITEM
C             WRITE(*,*)'37',ILVLIX,IEND
              IX(ILVLIX)=ISTART
              IX(ILVLIX+1)=IEND
            END IF
          ELSE
C
C  Second item is also in stack.
C
C           WRITE(*,*)IX(IELEM1+4),IX(IELEM2+4)
C
            IF(IX(IELEM1+4)+1.NE.IX(IELEM2+4)) THEN
              IMERR1=161116
              IMERR2=IX(IELEM2+7)
              LNCNTR=IX(IELEM2+6)
              RETURN
            END IF
C
C  Reset stack level for items in the second element.
C
            DO 70 I=IELEM2,IEND,LNITEM
            IF(IX(I+4).EQ.IX(IELEM1+4)+1) THEN
              IX(I+4)=IX(I+4)-1
            ELSE
              GO TO 72
            END IF
   70       CONTINUE
   72       CONTINUE
C
C  Now place operator in stack
C
            CALL ROOMI(5)
            IX(NXPTI-5)=IX(IOPER)
            IF(IX(IOPER).GE.11.AND.IX(IOPER).LE.17) THEN
              IF(IX(NXPTI3+ISDPTH-1).EQ.1) THEN
                IF(IX(NXPTI3+ISDPTH).EQ.1) THEN
                  IX(NXPTI-5)=IX(NXPTI-5)+300
                  ISDPT2=ISDPT2-NINSET
                ELSE
                  IX(NXPTI-5)=IX(NXPTI-5)+100
                  ISDPT2=ISDPT2-1
                END IF
              ELSE IF(IX(NXPTI3+ISDPTH).EQ.1) THEN
                IX(NXPTI-5)=IX(NXPTI-5)+200
                ISDPT2=ISDPT2-1
                IX(NXPTI3+ISDPTH-1)=1
              ELSE
                ISDPT2=ISDPT2-1
              END IF
            ELSE
              ISDPT2=ISDPT2-1
            END IF
            IX(NXPTI-4)=IX(IOPER+1)
            IX(NXPTI-3)=IX(IOPER+2)
            IX(NXPTI-2)=IX(IOPER+6)
            IX(NXPTI-1)=IX(IOPER+7)
            IX(IOPER+4)=IX(IELEM1+4)
            ISDPTH=ISDPTH-1
          END IF
        END IF
      END IF
      GO TO 40
   75 CONTINUE
C
C     IREC16=0
C     IREC17=0
C     DO 60 I=ISTCKB,NXPTI-3,3
C     IF(IX(I).EQ.12.OR.IX(I).EQ.13) THEN
C       IF(IREC17.NE.IX(I+1)) THEN
C         IF(IREC17.GT.IX(I+1)) THEN
C           REWIND(17)
C           IREC16=0
C         END IF
C         DO 49 J=IREC17+1,IX(I+1)
C         READ(17)cardwk
C  49     CONTINUE
C       END IF
C       IREC17=IX(I+1)
C       IREC16=IREC16+1
C       WRITE(16)cardwk
C       IX(I+1)=IREC16
C     END IF
C  60 CONTINUE
C
   80 CONTINUE
      J=0
C
C  Replace each 17 by the actual function and readjust stack.
C
C     WRITE(u6,170)(IX(I),I=ISTCKB,NXPTI-1)
C
      DO 84 I=NXPTI-5,ISTCKB,-5
      IF(J.EQ.0) THEN
        IF(IX(I).EQ.17) THEN
          J=I
          K=20
        ELSE IF(IX(I).EQ.217) THEN
          J=I
          K=24
        END IF
      ELSE IF(IX(I).EQ.20.AND.IX(I+2).EQ.IX(J+2)) THEN
        IX(J)=K
        IX(J+1)=IX(I+1)
        IX(J+2)=IX(I+2)
        IX(J+3)=IX(I+3)
        IX(J+4)=IX(I+4)
        DO 82 J=I,NXPTI-6
        IX(J)=IX(J+5)
   82   CONTINUE
        NXPTI=NXPTI-5
        GO TO 80
      END IF
   84 CONTINUE
C
C     WRITE(u6,170)(IX(I),I=ISTCKB,NXPTI-1)
C
      NPOLSH=(NXPTI-ISTCKB)/5
C
C     IF(NPOLSH.GT.0)STOP
C
      J=NXPTIS
      DO 88 I=ISTCKB,NXPTI-1
      IX(J)=IX(I)
      J=J+1
   88 CONTINUE
      NXPTI=NXPTIS+5*NPOLSH
      REWIND(16)
C
C     REWIND(17)
C     do 63 i=1,npass1
C     read(16)cardwk
C     write(*,*)cardwk(1:60)
C  63 continue
C     rewind(16)
  170 format(1x,5i5)
C     write(*,*)msdpth,msdpt2,isdpth,isdpt2
C
      RETURN
      END
C
C  End of CM.FOR
C
C
C  CAN.FOR
C         - routines implimenting new syntax in CREATE step
C  NSETP1 is called from SETUP1.  In turn, NSETP1 calls other
C  subroutines in CAN.FOR and also in CBN.FOR specific to
C  parsing for CREATE
C
      SUBROUTINE NSETP1(IXM,LNMAP,LNECHO,ITYPEF,IFILEF)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (IXDIM=13)
      INTEGER IXM(IXDIM,*),LNMAP(*),LNECHO(*)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MIFLVL=7,IXFLLD=13-MIFLVL)
      PARAMETER (MAXFMT=20)
      PARAMETER (NOPTN1=3)
C
C  MVAR   represents the maximum number of incoming and created
C         variables, replicate factors and wts
C  MAXIDS is the maximum number of class variables
C  MRECOD is the maximum of variables transformed by CLASS, CAT
C         MISSING, SELECT, BY etc.
C  MRANGE is the maximum number of ranges
C  MRNSET is the maximum number of sets of ranges
C  MLEVEL is the maximum number of stored labels for levels
C  MCLBLK is the maximum number of class blocks
C  MCLBAR is the maximum number of cells of class block arrays
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1,
     . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX
C
      DOUBLE PRECISION RANGE(2,MRANGE)
      INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET),
     . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD),
     . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI)
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
      INTEGER VTMPSZ
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
      CHARACTER*256 CARDWK,CARDSV,CARDIM
      COMMON /CMBLK2/CARDWK,CARDSV,CARDIM
C
      PARAMETER (MAXSUB=500,MAXSBL=2000,MAXSNL=24)
      PARAMETER (MAXSBC=6000)
      PARAMETER (MAXALT=5)
      INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL),
     .   U5LCSW
      COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW
       LOGICAL REFRSH,ALPCHK,DGTCHK
      EXTERNAL REFRSH,ALPCHK,DGTCHK
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
C
C
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP,
     . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO,
     . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS,
     . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT,
     . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS,
     . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO,
     . NLEVEL,NRNSET,NRANGE,NHADAM,ISTEPC,IFLVL,IF1LST,IFLAST,NEWSYN,
     . IXFILL,SDSTCK,MSDPTH
      INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS,
     . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN,
     . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IFLAST(MIFLVL),
     . IXFILL(IXFLLD),SDSTCK,MSDPTH
C
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
C
C  Usage in this subroutine (CREATE):
C
C  BLVSTR  -  Pointer for block to VNKEEP, 0 if no definition
C             of block contents by a KEEP statement
C  BLVSIZ  -  number of variables for block in VNKEEP
C  BLNCLS  -  number of classes in block
C  BLCPNT  -  pointer for classes to CLTYPE
C  CLTYPE  -  used as pointers to class variables
C
      INTEGER ITYPEF(3),IFILEF(3)
      INTEGER INDX1(NOPTN1)
      INTEGER IVAL1(NOPTN1)
      CHARACTER*12 OPTNW1(NOPTN1)
      DATA OPTNW1 /    'NPRINT      ','OBS         ','NOBS        '/
      DATA INDX1/1,2,2/
      DATA IVAL1/0,0,0/
C
  100 FORMAT(/,' Note: Fortran unit',I3,' assigned to ',A40,/)
  101 FORMAT(/,' Note: Fortran unit',I3,' assigned to ',/,1X,A80,/)
  205 FORMAT(' UNRECOGNIZED VARIABLE NAME ',A12)
  220 FORMAT(5X,'WARNING: COUNT OF CAT, CLASS, ETC. OPERATIONS TO CAT OR
     . CROSSED VAR:',I4)
C 226 FORMAT(' *** KEY IGNORED - NO PREVIOUS VARIABLES')
  229 FORMAT(' DUPLICATION: ',A12)
C 232 FORMAT(/,1X,I7,' variables are specified')
C 241 FORMAT(5X,'Ignored for this step')
C 242 FORMAT(' WARNING:  Not generated here, but may have been generated
C    . earlier')
C 250 FORMAT(5X,'*** PRINT request',I5)
  253 FORMAT(' NOT A CLASS VARIABLE: ',A12)
C
      IFLVL=0
C                  ! if level, used by earlier version
      IVZERO=1
C                  ! =0 all variables defined, =1 (forced) initialize
C                  ! all variables (now used for new syntax)
      IFLOW=0
C                  ! index in INFRMT of beginning of current format
      IFHIGH=0
C                  ! index in INFRMT of end of current format
      IFOUTL=0
C                  ! index in INFRMT of beginning of current outformat
      IFOUTH=0
C                  ! index in INFRMT of end of current outformat
      IRCINP=0
C                  ! RECODE number of the INPUT statement
      IRCTIN=40
C                  ! RECODE type for primary file
C                  !(41=LINK, 42=LINK_MISSING)
      IRCOUT=0
C                  ! value of NRECOD for OUTPUT statement
      IUINPT=12
C                  ! Fortran unit number for input
      NVIN=0
C                  ! number of input variables, including recodes
      NRECOD=0
C                  ! recode index
      NRANGE=0
C                  ! range index
      NRNSET=0
C                  ! index to sets of ranges
      NLEVEL=0
C                  ! index to levels (of CAT, CLASS, etc.)
      NHADAM=0
C                  ! order of Hadamard matrix
      NKEEP=0
C                  ! number of variables in KEEP list (with BLOCK)
      VKEEPF=0
C                  ! distinguishes KEEP(=1)/DROP(=2)
      IREPF=0
C                  ! =1 when replicate factors
      IREPW=0
C                  ! =1 when replicate weights
      IREPNO=0
C                  ! variable identified as REPLICATE NUMBER
      IWGT=0
C                  ! variable identified as weight
      ISTRCD=0
C                  ! variable identified as STRATUM CODE
      ISTRNO=0
C                  ! variable identified as STRATUM NUMBER
      ISNDCD=0
C                  ! variable identified as SECOND-STAGE CODE
      ISNDNO=0
C                  ! variable identified as SECOND-STAGE NUMBER
      ICLUSC=0
C                  ! variable identified as CLUSTER CODE
      ICLUSN=0
C                  ! variable identified as CLUSTER NUMBER
      ICLCNT=0
C                  ! variable identified as CLUSTER COUNT
      SISTRS=0
C                  ! start of stratum sizes in IX
      SISNDS=0
C                  ! start of second-stage sizes in IX
      NISTRS=0
C                  ! number of strata
      NISNDS=0
C                  ! number of second-stage units
      NDCOEF=0
C                  ! number of COEFFICIENTS read
      SDFPC1=0
C                  ! start of 1st stage fpc's in DX
      NDFPC1=0
C                  ! number of 1st stage fpc's in DX
      SDFPC2=0
C                  ! start of 2nd stage fpc's in DX
      NDFPC2=0
C                  ! number of 2nd stage fpc's in DX
      NREPW=0
C                  ! Number of replicate weights
      NOWGTF=0
C                  ! Flag set to 1 if UNWEIGHTED statement encountered
      ICWARN=0
C                  ! count of logical operations on CAT, etc. - used in
C                  ! the old syntax but not yet reimplemented in the new
      IPREQ=0
C                  ! number of the current print request
      IOUTFV=0
C                  ! type of output file
      NCRSSD=0
C                  ! crossed dimensions
      NEWSYN=0
C                  ! Flag initialized to 0 until a BLOCK statement is
C                  ! encountered.  In the old version, this was set to 2
C                  ! if the old BLOCK syntax was employed.  (In the old
C                  ! BLOCK syntax, BLOCK appeared as a statement by
C                  ! itself and would be followed by CLASS and KEEP
C                  ! statements.)
C                  ! In this version, it is set to 2 when a SELECT, KEEP,
C                  ! or DROP statement appears by itself.  These
C                  ! statements will continue to be supported as long
C                  ! as no BLOCK statements are used.
C                  ! The old BLOCK syntax is not supported within the
C                  ! new syntax
C
      MSG241=0
C                  ! set =1 when BLOCK, SELECT, or DROP when not CREATE
      MSG226=0
      U5ECSV=U5ECHO
      U5ECHO=0
C
C  Contents of MTYPE, codes for transformations
C     1  =  real variable
C     2  =  real variable with missing checks
C     3  =  categorical variable
C     4  =  class variable, known dimension
C     5  =  by variable, known dimension
C     6  =  by variable, unknown dimension
C     7  =  select transformation (not variable type)
C     8  =  cross variable, real value
C     9  =  cross variable, categorical
C    10  =  copy (not variable type)
C    21  =  boolean                 "
C    22  =  boolean - no range      "
C    23  =  and (logical and)       "
C    24  =  or                      "
C    25  =  not                     "
C    26  =  add_ms                  "
C    27  =  subtract_ms             "
C    28  =  multiply_ms             "
C    29  =  divide_ms               "
C    30  =  add                     "
C    31  =  subtract                "
C    32  =  multiply                "
C    33  =  divide                  "
C    34  =  constants               "
C    35  =  if (else if)            "
C    36  =  go to                   "
C    40  =  initial read
C    41  =  input (link)
C    42  =  input with missing (link_missing)
C               v1        v2        v3        rstpnt
C             iuinpt    status   # input      # keys
C             1st v    start x   start fmt    # fmt
C             # print   #obs     file type       -
C             key x    match v   last key     var # of match v
C             note: either v2(irecod+1)>0 (input of all new variables)
C                   or rstpnt(irecod+2)>0 (input of list of variables)
C    43  =  add loop to replicate weights/factors
C               v1        v2        v3        rstpnt
C             1st rf/rw  # rf/rw   var
C    44  =  subtract loop to replicate weights/factors
C    45  =  multiply loop            "
C    46  =  divide   loop            "
C    47  =  output
C               v1        v2        v3        rstpnt
C            #output  point IX start fmt    # fmt
C
C  50-60 are during REWEIGHT only
C
C    50  =  add, 0 replicate,      using vplxin data
C               v1        v2        v3        rstpnt
C             1st op   target   vplxin v     #classes
C          for each class:
C               v1        v2        v3        rstpnt
C            class/cat           0 offset    increment
C
C    51  =  subtract, 0 replicate   using vplxin data
C    52  =  multiply, 0 replicate       "
C    53  =  divide, 0 replicate         "
C    54  =  add loop to replicate weights/factors, using vplxin
C               v1        v2        v3        rstpnt
C             1st rf/rw  # rf/rw  vplxin var  #classes
C          for each class:
C               v1        v2        v3        rstpnt
C            class/cat           0 offset    increment
C
C    55  =  subtract loop to replicate weights/factors, using vplxin
C    56  =  multiply loop            "                       "
C    57  =  divide   loop            "                       "
C
C    58  =  define repf based on var ids
C               v1        v2        v3       rstpnt
C            1st rf/rw  # rf/rw     wt      #var ids
C          for each id:
C               v1        v2        v3       rstpnt
C            variance id
C          for repw, v3 will give id of weight
C    60  =  check BY variables
C               v1        v2        v3       rstpnt
C                                           #BY vars
C          for each BY var:
C               v1        v2        v3       rstpnt
C              BY id                       loc in vid
C
C    61  =  define repf based on rows of Hadamard matrix and
C           coefficients
C               v1        v2        v3       rstpnt
C            1st rf/rw  # rf/rw     wt       #sets
C          for each set:
C               v1        v2        v3       rstpnt
C              row     coefficient
C          for repw, v3 will give id of weight
C
C    62  =  idchange to return 1 if change in variables
C               v1        v2        v3        rstpnt
C               0     idchange       0         # keys
C           for each key:
C                     match v    pointer to   var # of match v
C                                 last value
C
C    63 =   print
C    64     print in 2 columns (real only)
C               v1        v2        v3        rstpnt
C             # print   #obs     # list       # pointer to IX
C
C
C  ISTEPC - set in SETUP1,
C           1 = CREATE
C           2 = REWEIGHT
C           3 = REPGEN, CONVERT
C
      IF(ISTEPC.EQ.1) THEN
        IF(IFILEF(3).NE.0) THEN
          IOUTFV=ITYPEF(3)
        END IF
      ELSE
        IOUTFV=ITYPEF(2)
      END IF
C
      IF(ISTEPC.EQ.2) THEN
        IBYCHK=0
        VTMPSZ=MVAR-SVTEMP+1
      ELSE
        NCLASS=0
        NRPTOT=0
        NCLBLK=1
        NCLBAR=0
        BLCPNT(1)=0
        BLNCLS(1)=0
        BLVSTR(1)=0
        BLVSIZ(1)=0
        SVTEMP=1
        VTMPSZ=MVAR
        SDCOEF=0
        NBY=0
        VROPTN=0
      END IF
C
      REWIND(14)
      U5=15
      ILINE=1
      READ(14)CARD
C
C  Future plan: loop over different kinds of statements here
C  to display conflicts, similar to IF analysis.  A possible
C  example would be to identify a conflict between BLOCK and
C  SELECT, KEEP, DROP
C
C  Most of the routine falls within a loop to 1 CONTINUE.  The loop
C  is over the statements identified and organized by CMPAR1.
C  The listing file has already been written to 13 (all as unformatted
C  character data of length 256).  For each statement, the contents
C  of CARD will be read from 14 and written to 15, which will then
C  be the input read by REFRSH, etc. and parsed in detail here and
C  in related routines.
C
      DO 1 ISTATE=1,NSTATE
C
      REWIND(15)
      U5END=0
    2 CONTINUE
C
C  If starting position for this statement is beyond the current
C  position of 14, read necessary records.  Otherwise, restore
C  CARD from CARDSV
C
      IF(ILINE.LT.IXM(8,ISTATE)) THEN
        DO 3 I=ILINE+1,IXM(8,ISTATE)
        READ(14)CARD
    3   CONTINUE
        ILINE=IXM(8,ISTATE)
      ELSE IF(ISTATE.NE.1) THEN
        CARD=CARDSV
      END IF
C
C  LNCNTR is set to the current position in the overall file
C  here.  Calls to REFRSH increment LNCNTR as records are read
C  from 15.
C
      LNCNTR=IXM(8,ISTATE)
C
C  Construct the first line where parsing of the statement should
C  begin in CARDWK.  For safety, blank out any characters leading
C  up to the starting point.
C
      CARDWK=CARD
      I=IXM(9,ISTATE)-1
      CALL STBLNK(CARDWK,1,I)
C
C  If this is also the last line of the statement, blank out
C  anything following the ending ;
C
      IF(ILINE.EQ.IXM(3,ISTATE)) THEN
        K=IXM(4,ISTATE)+1
        CALL STBLNK(CARDWK,K,256)
      END IF
      WRITE(15)CARDWK
C
C  Read and process remaining lines.  In all cases, save the
C  current line from 14 in CARDSV
C
      IF(ILINE.LT.IXM(3,ISTATE)) THEN
        DO 4 I=ILINE+1,IXM(3,ISTATE)
        READ(14)CARD
        IF(I.EQ.IXM(3,ISTATE)) THEN
          CARDSV=CARD
          K=IXM(4,ISTATE)+1
          CARDWK=CARD
          CALL STBLNK(CARDWK,K,256)
          WRITE(15)CARDWK
        ELSE
          WRITE(15)CARD
        END IF
    4   CONTINUE
        ILINE=IXM(3,ISTATE)
      ELSE
        CARDSV=CARD
      END IF
      REWIND(15)
      READ(15)CARD
C
C  IPT is the starting position for parsing.  In many cases, it
C  is the position beyond a key word.
C
      IPT=IXM(9,ISTATE)
      IFLVL=IXM(6,ISTATE)
C                                      ! Depth of IF LEVEL
C
      IF(IXM(5,ISTATE).EQ.16) THEN
C
        IGROUP=IXM(10,ISTATE)
        IKEY=IXM(11,ISTATE)
C
C  Appearance of SELECT or DROP, or KEEP is incompatible with
C  block syntax.
C
        IF((IGROUP.EQ.2.AND.IKEY.EQ.7).OR.
     .     (IGROUP.EQ.7.AND.(IKEY.EQ.1.OR.IKEY.EQ.6))) THEN
          IF(NEWSYN.EQ.1) THEN
            IMERR1=30020
            CALL CMPRNT(IXM,LNMAP)
          ELSE IF(NEWSYN.EQ.0) THEN
            NEWSYN=2
          END IF
        END IF
C
C  FORMAT (2, 6), OUTFORMAT (2, 13)  (These are still supported
C  as separate statements but undocumented.)
C
        IF(IGROUP.EQ.2.AND.(IKEY.EQ.6.OR.IKEY.EQ.13)) THEN
          IF(IKEY.EQ.13) THEN
C                                                        ! OUTFORMAT
            IF(ISTEPC.EQ.1.AND.IOUTFV.EQ.0) THEN
C
C  Error if OUTFORMAT during CREATE without specified output file.
C
              IMERR1=30001
              CALL CMPRNT(IXM,LNMAP)
            END IF
            IFOUTH=IFHIGH
            CALL RINCR(11,IFOUTH,1)
            IFOUTL=IFOUTH
            K=IFOUTH
          ELSE IF(IKEY.EQ.6) THEN
C                                                        ! FORMAT
            IF(IFLOW.GT.0) THEN
C
C  Error if more than one FORMAT statement apparently matching an
C  INPUT statement.
C
              IMERR1=30003
              CALL CMPRNT(IXM,LNMAP)
            END IF
            IF(IFOUTH.GT.IFHIGH)IFHIGH=IFOUTH
            CALL RINCR(11,IFHIGH,1)
            IFLOW=IFHIGH
            K=IFHIGH
          END IF
          IF(CARD(IPT:IPT).NE.'(') THEN
            IMERR1=30002
            IMERR2=IPT
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
C
C  Copy the format, removing blanks and checking for the balance
C  of parentheses.
C
          CALL NSET1D(IKEY,IPT,K)
C                                        ! note: NSET1D accepts only
          IF(IMERR1.GT.0) THEN
C                                        ! ';' and '/' as ends
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
          IF(IKEY.EQ.6) THEN
            IFHIGH=K
          ELSE
            IFOUTH=K
          END IF
C
C  Except for CREATE, skip SELECT (7,1), DROP (7,6), KEEP (2, 7),
C  and BLOCK (7, 18)
C
        ELSE IF(ISTEPC.NE.1.AND.((IGROUP.EQ.2.AND.IKEY.EQ.7).OR.
     .        (IGROUP.EQ.7.AND.
     .          (IKEY.EQ.1.OR.IKEY.EQ.6.OR.IKEY.EQ.18)))) THEN
   62     CONTINUE
          IF(REFRSH(IPT)) GO TO 62
          MSG241=1
C
C  CLASS (2,1), CATEGORICAL (2,2), (CAT (2,2)), MISSING (2,3),
C
C  Not implemented in the new syntax: COPY, BOOLEAN, NOT
C
        ELSE IF(IGROUP.EQ.2.AND.IKEY.LE.3) THEN
          CALL NSET1B(IGROUP,IKEY,IPT,VTMPSZ,ICWRNT,IPOS)
          IF(IMERR1.GT.0) THEN
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
          IF(CARD(IPOS:IPOS).NE.';') THEN
            IMERR1=30048
            IMERR2=IPOS
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
C
C  INPUT
C
        ELSE IF(IGROUP.EQ.7.AND.IKEY.EQ.5) THEN
C
C  Check for previous INPUT unmatched with a corresponding FORMAT.
C
          IF(IRCINP.GT.0) THEN
            IMERR1=30030
            CALL CMPRNT(IXM,LNMAP)
          END IF
C
C  If the INPUT statement is within an IF block, set flag to zero
C  variables.  This is turned off for the new syntax because IVZERO=1
C  in the initializations.
C
C         IF(IFLVL.GT.0) THEN
C           IVZERO=1
C         END IF
C
          J=RCEIL(2)-NVIN
          K=NVIN+1
          CALL VNFIND(IPT,VNAME(K),J,NVINPT,IPOS,1,VNAME,MVAR)
          IF(NVINPT.EQ.0) THEN
            IMERR1=30031
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
          CALL RFADD(VNAME(K),NVINPT,J,1,IXM,ISTATE)
          IF(IMERR1.GT.0) THEN
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
C
C  IRCINP saves the RECODE number of the INPUT statement.
C
          IRCINP=NRECOD+1
          CALL RINCR(4,NRECOD,3)
          RCTYPE(IRCINP)=IRCTIN
          V1(IRCINP)=IUINPT
          V2(IRCINP)=0
          RSTPNT(IRCINP)=0
          RCTYPE(IRCINP+1)=0
          V2(IRCINP+1)=NXPTD
          V1(NRECOD)=0
          V2(NRECOD)=0
          V3(NRECOD)=ITYPEF(1)
          RSTPNT(NRECOD)=0
          RCTYPE(NRECOD)=0
          V3(IRCINP)=NVINPT
          V1(IRCINP+1)=NXPTI
          CALL ROOMI(NVINPT)
          CALL VNCHK2(VNAME(K),NVINPT,IXM,LNMAP)
C
C  Look for keyed link or options
C
   23     CONTINUE
          IF(IPOS.GT.0) THEN
            IF(CARD(IPOS:IPOS).EQ.'/') THEN
              IPOS=IPOS+1
              CALL NBFND2(IPOS,IPOS2)
              IPOS=IPOS2
              IF(IPOS.GT.0) THEN
                CALL CMATCH(CARD(IPOS:256),IPOS,256,'KEY',3,IPOS2,1)
                IF(IPOS2.GT.0) THEN
                  CALL NBFND2(IPOS2,IPOS)
C
C  Subsequent to finding KEY, read additional variables into VNAME after
C  end of INPUT list.
C
                  J=RCEIL(2)-NVIN-NVINPT-1
C                                                  ! space for new var
                  K=NVIN+NVINPT+1
                  CALL VNFIND(IPOS,VNAME(K),J,L,IPOS2,1,VNAME,MVAR)
                  IPOS=IPOS2
C
C  If variables are found after KEY
C
                  IF(L.GE.1) THEN
                    IF(NVIN.EQ.0) THEN
                      MSG226=1
                    ELSE
C
C  Check that the keyed variable was included on the input list.
C
                      RSTPNT(IRCINP)=L
                      DO 71 I=1,L
                      CALL VNMTCH(VNAME(K+I-1),VNAME(NVIN+1),NVINPT,J)
                      IF(J.EQ.0) THEN
                        IMERR1=30032
                        ILINE=LNCNTR
                        CALL CMPRNT(IXM,LNMAP)
                      END IF
C
C  Set up an entry for each KEY variable in the recode arrays.
C
                      CALL RINCR(4,NRECOD,1)
                      RCTYPE(NRECOD)=0
                      V1(NRECOD)=NXPTD+J-1
C
C  Set the type of the keyed variable to 49.
C
                      MTYPE(NVIN+J)=49
                      V3(NRECOD)=NXPTD+NVINPT+I-1
C
C  Find the previous definition of the keyed variable and stop if not
C  previously defined.
C
                      CALL VNMTCH(VNAME(K+I-1),VNAME,NVIN,V2(NRECOD))
                      RSTPNT(NRECOD)=V2(NRECOD)
                      IF(V2(NRECOD).EQ.0) THEN
                        IMERR1=30033
                        ILINE=LNCNTR
                        CALL CMPRNT(IXM,LNMAP)
                      END IF
   71                 CONTINUE
C
C  End of KEYed variables
C
                    END IF
C
C  Return to check for presence of /OPTION etc.
C
                  END IF
                  GO TO 23
                END IF
                CALL CMATCH(CARD(IPOS:256),IPOS,256,'INFLAG',6,IPOS2,1)
                IF(IPOS2.GT.0) THEN
                  CALL NBFND2(IPOS2,IPOS)
C
C  Subsequent to finding INFLAG, read additional variables into VNAME after
C  end of INPUT list.
C
                  J=RCEIL(2)-NVIN-NVINPT-1
C                                           ! space for new variables
                  K=NVIN+NVINPT+1
                  CALL VNFIND(IPOS,VNAME(K),J,L,IPOS2,1,VNAME,MVAR)
                  IPOS=IPOS2
                  IF(L.NE.1) THEN
C                                         ! /INFLAG must name a single
                    IMERR1=30037
C                                         ! variable
                    IMERR2=IPOS
                    ILINE=LNCNTR
                    CALL CMPRNT(IXM,LNMAP)
                  END IF
                  CALL VNMTCH(VNAME(K),VNAME(NVIN+1),NVINPT,J)
                  IF(J.GT.0) THEN
                    IMERR1=30038
C                                         ! /INFLAG variable must not
                    ILINE=LNCNTR
C                                         ! be part of input list
                    CALL CMPRNT(IXM,LNMAP)
                  END IF
                  CALL VNMTCH(VNAME(K),VNAME,NVIN,J)
                  IF(J.GT.0) THEN
C                                         ! variable exists
                    RSTPNT(IRCINP+2)=J
                    IF(MTYPE(J).NE.1) THEN
                      IMERR1=30039
C                                         ! /INFLAG variable must real
                      ILINE=LNCNTR
                      CALL CMPRNT(IXM,LNMAP)
                    END IF
                  ELSE
C                                                      ! new variable
                    CALL VNCHK2(VNAME(K),1,IXM,LNMAP)
                    RSTPNT(IRCINP+2)=RCEIL(2)
C                                                      ! save at
                    VNAME(RCEIL(2))=VNAME(K)
C                                                      ! RCEIL(2)
                    K=RCEIL(2)
                  END IF
C
C  Return to check for presence of /OPTION
C
                  GO TO 23
                END IF
C
C  Check for /OPTION /OPTIONS
C
                CALL CMATCH(CARD(IPOS:256),IPOS,256,'OPTION',6,
     .               IPOS2,1)
                IF(IPOS2.EQ.0) THEN
                  CALL CMATCH(CARD(IPOS:256),IPOS,256,'OPTIONS',7,
     .               IPOS2,1)
                END IF
                IF(IPOS2.GT.0) THEN
                  IPOS=IPOS2
                  CALL NBFND2(IPOS,IPOS2)
                  IPOS=IPOS2
                  IX(NXPTI)=0
                  IX(NXPTI+1)=0
                  CALL OPTNTR(NOPTN1,INDX1,IVAL1,OPTNW1,IPOS,IPOS2,
     .                      IX(NXPTI))
                  IF(IMERR1.GT.0) THEN
                    ILINE=LNCNTR
                    CALL CMPRNT(IXM,LNMAP)
                  END IF
                  V1(IRCINP+2)=IX(NXPTI)
                  V2(IRCINP+2)=IX(NXPTI+1)
                  IPOS=IPOS2
C
C  Return to 23 to check for / KEY
C
                  GO TO 23
                END IF
                CALL CMATCH(CARD(IPOS:256),IPOS,256,'FORMAT',6,IPOS2,1)
                IF(IPOS2.GT.0) THEN
                  CALL NBFND2(IPOS2,IPT)
                  IF(IFLOW.GT.0) THEN
C
C  Error if more than one FORMAT statement apparently matching an
C  INPUT statement.
C
                    IMERR1=30003
                    ILINE=LNCNTR
                    CALL CMPRNT(IXM,LNMAP)
                  END IF
                  IF(IFOUTH.GT.IFHIGH)IFHIGH=IFOUTH
                  CALL RINCR(11,IFHIGH,1)
                  IFLOW=IFHIGH
                  K=IFHIGH
                  IF(CARD(IPT:IPT).NE.'(') THEN
                    IMERR2=IPT
                    ILINE=LNCNTR
                    IMERR1=30002
                    CALL CMPRNT(IXM,LNMAP)
                  END IF
C
C  Copy the format, removing blanks and checking for the balance
C  of parentheses.
C
                  CALL NSET1D(IKEY,IPT,IFHIGH)
C                                               ! Note: NSET1D accepts
                  IF(IMERR1.GT.0) THEN
C                                               ! only ';' and '/' as
                    ILINE=LNCNTR
C                                               ! ends
                    CALL CMPRNT(IXM,LNMAP)
                  END IF
                  IPOS=IPT
                END IF
              END IF
              GO TO 23
            END IF
            IF(CARD(IPOS:IPOS).NE.';') THEN
              IMERR1=30034
              IMERR2=IPOS
              ILINE=LNCNTR
              CALL CMPRNT(IXM,LNMAP)
            END IF
          END IF
C
C  Set aside room in DX for incoming data and keys of previous record.
C
          L=NVINPT+RSTPNT(IRCINP)
          CALL ROOMD(L)
C
C  Until 97.04, V1(IRCINP+1) held the first variable name in the
C  input series.  V1(IRCINP+1) now points to an array in IX holding
C  the input variables.  The new approach allows OLD variables to
C  be included in an input list.
C
          KV=V1(IRCINP+1)-1
          K=NVIN
          DO 72 I=1,NVINPT
          KV=KV+1
          K=K+1
          IF(MTYPE(K).NE.49.AND.NVIN.GT.0) THEN
            CALL VNMTCH(VNAME(K),VNAME,NVIN,J)
            IF(J.NE.0) THEN
              IF(IRCTIN.EQ.42) THEN
                IF(MTYPE(J).NE.2) THEN
                  WRITE(U6,229)VNAME(K)
                  IMERR1=30080
                  ILINE=LNCNTR
                  CALL CMPRNT(IXM,LNMAP)
                ELSE
                  IX(KV)=J
                  GO TO 72
                END IF
              ELSE
                IF(MTYPE(J).NE.1.AND.MTYPE(J).LT.50) THEN
                  WRITE(U6,229)VNAME(K)
                  IMERR1=30081
                  ILINE=LNCNTR
                  CALL CMPRNT(IXM,LNMAP)
                ELSE
                  IX(KV)=J
                  GO TO 72
                END IF
              END IF
            END IF
          END IF
          IF(K.NE.NVIN+1) THEN
            MTYPE(NVIN+1)=MTYPE(K)
            VNAME(NVIN+1)=VNAME(K)
          END IF
          IF(MTYPE(NVIN+1).NE.49) THEN
            IF(IRCTIN.EQ.42) THEN
              MSIZE(NVIN+1)=2
              MXSIZE(NVIN+1)=2
              MTYPE(NVIN+1)=2
              MTSTRT(NVIN+1)=2
            END IF
          END IF
C
C  Note: VNCHK2 has already been called for the entire input list.
C
          CALL RINCR(2,NVIN,1)
          IX(KV)=NVIN
          LABEL(NVIN)(1:12)=VNAME(NVIN)
          LABEL(NVIN)(13:24)='            '
          CALL RFCHCK(1)
          IF(IMERR1.GT.0) THEN
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
   72     CONTINUE
          IF(K.NE.NVIN) THEN
            DO 22 I=NVIN+1,K
            MTYPE(I)=1
            MTSTRT(I)=1
   22       CONTINUE
          END IF
          IF(RSTPNT(IRCINP+2).GT.NVIN) THEN
            K=RSTPNT(IRCINP+2)
            CALL RINCR(2,NVIN,1)
            VNAME(NVIN)=VNAME(K)
            LABEL(NVIN)(1:12)=VNAME(NVIN)
            LABEL(NVIN)(13:24)='            '
            MTYPE(NVIN)=1
            MTSTRT(NVIN)=1
            RSTPNT(IRCINP+2)=NVIN
          END IF
C
C  PRINT
C
C    63 =   print
C               v1        v2        v3        rstpnt
C             # print   #obs     # list       # pointer to IX
C             # req
C
        ELSE IF(IGROUP.EQ.1.AND.IKEY.EQ.10) THEN
          CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,N,IPOS,1,VNAME,MVAR)
          CALL RFADD(VTEMP(SVTEMP),N,VTMPSZ,2,IXM,ISTATE)
          IF(N.EQ.0) THEN
            IMERR1=30040
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
          CALL RINCR(4,NRECOD,2)
          RCTYPE(NRECOD-1)=64
          IPREQ=IPREQ+1
          V1(NRECOD-1)=0
          V2(NRECOD-1)=0
          RSTPNT(NRECOD-1)=NXPTI
          V1(NRECOD)=IPREQ
          RCTYPE(NRECOD)=0
          V2(NRECOD)=0
          V3(NRECOD)=0
          RSTPNT(NRECOD)=0
          V3(NRECOD-1)=N
          CALL ROOMI(N)
C
C  Look for options
C
   73     CONTINUE
          IF(IPOS.GT.0) THEN
            CALL NBFND2(IPOS,IPOS2)
            IPOS=IPOS2
          END IF
          IF(IPOS.GT.0) THEN
            IF(CARD(IPOS:IPOS).EQ.'/') THEN
              IPOS=IPOS+1
              CALL NBFND2(IPOS,IPOS2)
              IPOS=IPOS2
              IF(IPOS2.GT.0) THEN
                CALL CMATCH(CARD(IPOS:256),IPOS,256,'OPTION',6,
     .              IPOS2,1)
                IF(IPOS2.EQ.0) THEN
                  CALL CMATCH(CARD(IPOS:256),IPOS,256,'OPTIONS',7,
     .               IPOS2,1)
                END IF
                IF(IPOS2.GT.0) THEN
                  IPOS=IPOS2
                  CALL NBFND2(IPOS,IPOS2)
                  IPOS=IPOS2
                END IF
                IX(NXPTI)=0
                IX(NXPTI+1)=0
                CALL OPTNTR(1,INDX1,IVAL1,OPTNW1,IPOS,IPOS2,
     .                      IX(NXPTI))
                IF(IMERR1.GT.0) THEN
                  ILINE=LNCNTR
                  CALL CMPRNT(IXM,LNMAP)
                END IF
                V1(NRECOD-1)=IX(NXPTI)
                IPOS=IPOS2
              END IF
              GO TO 73
            END IF
            IF(CARD(IPOS:IPOS).NE.';') THEN
              IMERR2=IPOS
              IMERR1=30047
              ILINE=LNCNTR
              CALL CMPRNT(IXM,LNMAP)
            END IF
          END IF
C
C  Build up list of variables in IX
C
          K=RSTPNT(NRECOD-1)
          DO 74 I=1,N
          CALL VNMTCH(VTEMP(SVTEMP+I-1),VNAME,NVIN,J)
          IF(J.EQ.0) THEN
            WRITE(U6,205)VTEMP(SVTEMP+I-1)
            IMERR1=30046
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
          IF(MTYPE(J).GT.1.AND.MTYPE(J).LT.49) THEN
            RCTYPE(NRECOD-1)=63
C                                                     ! Listing with MTYPE
          END IF
          IX(K)=J
          K=K+1
   74     CONTINUE
C
C  Future improvement:  fix this message.
C
C         IF(U5ECHO.EQ.1)WRITE(U6,250)IPREQ
C
C
C  Possible implementation of CROSS here.
C
C       ELSE IF(IGROUP.EQ.7.AND.IKEY.EQ.16) THEN
C         CALL NSET1C(IGROUP,IKEY,IPT,VTMPSZ,IBYCHK,IXM,ISTATE)
C         IF(IMERR1.GT.0) THEN
C           CALL CMPRNT(IXM,LNMAP)
C         END IF
C
C
C  BY (7, 2), REPLICATION (7,3) (REP) (7,7), UNWEIGHTED (7,4),
C  DROP(7,6), REPLICATE (7,8), WEIGHT (7,9), STRATUM (7,10),
C  CLUSTER (7,11), SECOND (7,12), COEFFICIENT (7,13),
C  FPC1 (7,14), FPC2(7,15), HADAMARD (7,26)
C  KEEP (2,7), LABEL (2,8), LEVEL (2,9), RENAME (2,10),
C
        ELSE IF((IGROUP.EQ.2.AND.(IKEY.GE.7.AND.IKEY.LE.10)).OR.
     .          (IGROUP.EQ.7.AND.((IKEY.GE.2.AND.IKEY.LE.4).OR.
     .          (IKEY.GE.6.AND.IKEY.LE.15).OR.IKEY.EQ.26))) THEN
          CALL NSET1A(IGROUP,IKEY,IPT,VTMPSZ,IPOS)
          IF(IMERR1.EQ.0) THEN
            IF(IPOS.EQ.0) THEN
              IMERR1=30048
            ELSE IF(CARD(IPOS:IPOS).NE.';') THEN
              IMERR2=IPOS
              IMERR1=30048
            END IF
          END IF
          IF(IMERR1.GT.0) THEN
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
C
C  OUTPUT
C
        ELSE IF(IGROUP.EQ.7.AND.IKEY.EQ.25) THEN
          IF(IRCOUT.GT.0) THEN
            IMERR1=30018
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          ELSE IF(ISTEPC.EQ.1.AND.IOUTFV.EQ.0) THEN
            IMERR1=30019
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
          J=MVAR-NKEEP
          CALL VNFIND(IPT,VNKEEP(NKEEP+1),J,N,IPOS,2,VNAME,NVIN)
          IF(N.LE.0) THEN
            IMERR1=30041
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
          J=MVAR-NKEEP-N
          CALL RFADD(VNKEEP(NKEEP+1),N,J,2,IXM,ISTATE)
          IF(IMERR1.GT.0) THEN
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
          CALL RINCR(4,NRECOD,1)
          V1(NRECOD)=N
          V2(NRECOD)=NXPTI
          CALL ROOMI(1)
C
C  Create indicators in a matrix in IX starting at NXPTI
C  1st element = unit number
C  Second element - output file format position.
C  Subsequent elements: variables in output list.
C
          IF(ISTEPC.EQ.1) THEN
            IX(NXPTI-1)=10
          ELSE
            IX(NXPTI-1)=11
          END IF
          CALL ROOMI(1)
          IX(NXPTI-1)=IOUTFV
          DO 61 I=1,N
          CALL ROOMI(1)
          CALL VNMTCH(VNKEEP(NKEEP+I),VNAME,NVIN,IX(NXPTI-1))
          IF(IX(NXPTI-1).EQ.0) THEN
            WRITE(U6,205)VNKEEP(NKEEP+I)
            IMERR1=30042
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
   61     CONTINUE
          IRCOUT=NRECOD
          RCTYPE(NRECOD)=47
          CALL NBFND2(IPOS,IPT)
          IF(IPT.GT.0) THEN
            IF(CARD(IPT:IPT).EQ.'/') THEN
              IPT=IPT+1
              CALL NBFND2(IPT,IPOS)
              CALL CMATCH(CARD(IPOS:256),IPOS,256,'OUTFORMAT',9,IPOS2,1)
              IF(IPOS2.EQ.0) THEN
                CALL CMATCH(CARD(IPOS:256),IPOS,256,'FORMAT',6,IPOS2,1)
              END IF
              IF(IPOS2.GT.0) THEN
                CALL NBFND2(IPOS2,IPT)
                IFOUTH=IFHIGH
                CALL RINCR(11,IFOUTH,1)
                IFOUTL=IFOUTH
                K=IFOUTH
                IF(CARD(IPT:IPT).NE.'(') THEN
                  IMERR1=30002
                  ILINE=LNCNTR
                  IMERR2=IPT
                  CALL CMPRNT(IXM,LNMAP)
                END IF
C
C  Copy the format, removing blanks and checking for the balance
C  of parentheses.
C
                CALL NSET1D(IKEY,IPT,IFOUTH)
C                                              ! NSET1D accepts only
                IF(IMERR1.GT.0) THEN
C                                              ! ';' and '/' as ends
                  ILINE=LNCNTR
                  CALL CMPRNT(IXM,LNMAP)
                END IF
                CALL NBFND2(IPT,IPOS)
                IPT=IPOS
                IF(CARD(IPT:IPT).NE.';') THEN
                  IMERR2=IPT
                  IMERR1=30007
                  ILINE=LNCNTR
                  CALL CMPRNT(IXM,LNMAP)
                END IF
              END IF
            END IF
            IF(CARD(IPT:IPT).NE.';') THEN
              IMERR2=IPT
              IMERR1=30048
C                                              ! Note: different error
              ILINE=LNCNTR
              CALL CMPRNT(IXM,LNMAP)
            END IF
          END IF
C
C  RGENERATE
C
        ELSE IF(IGROUP.EQ.7.AND.IKEY.EQ.28) THEN
          CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,K,IPOS,2,VNAME,NVIN)
          J=NRECOD
          IF(K.GT.0) THEN
            CALL RFADD(VTEMP(SVTEMP),K,VTMPSZ,2,IXM,ISTATE)
            IF(IMERR1.GT.0) THEN
              ILINE=LNCNTR
              CALL CMPRNT(IXM,LNMAP)
            END IF
            CALL NBFND2(IPOS,IPT)
          ELSE
            IMERR1=30036
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
          IF(CARD(IPOS:IPOS).NE.';') THEN
            IMERR2=IPT
            ILINE=LNCNTR
            IMERR1=30048
            CALL CMPRNT(IXM,LNMAP)
          END IF
C
C  Future: fix message
C
C         IF(J.EQ.NRECOD) THEN
C           IF(U5ECHO.EQ.1)WRITE(U6,242)
C         END IF
C
C  LINK (7,19), LINK_MISSING (7,20)
C
C  To maintain new DO loop to 1, copy code from end of loop here.
C  Future: may do initial scan of logic to find the mismatch in advance
C  simplifying some of the duplicate coding here.
C
        ELSE IF(IGROUP.EQ.7.AND.(IKEY.EQ.19.OR.IKEY.EQ.20)) THEN
          IF((IFLOW.EQ.0.AND.ITYPEF(1).EQ.1).OR.IRCINP.EQ.0) THEN
            IF(IFLOW.EQ.0.AND.ITYPEF(1).EQ.1) THEN
C                                                     ! Error message
              IF(IRCINP.EQ.0) THEN
C                                                     ! for unresolved
                IMERR1=30043
C                                                     ! specification
              ELSE
C                                                     ! for previous
                IMERR1=30044
C                                                     ! input
              END IF
            ELSE
              IMERR1=30045
            END IF
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
          V3(IRCINP+1)=IFLOW
          RSTPNT(IRCINP+1)=IFHIGH-IFLOW+1
          IFLOW=0
          IRCINP=0
          ITYPEF(1)=1
          ITYPEF(2)=0
          ITYPEF(3)=0
          CALL FNREAD(IPT,ITYPEF,IFILEF,2,IPOS)
          IF(IMERR1.GT.0) THEN
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
          IUINPT=IFILEF(1)
          IF(IKEY.EQ.19) THEN
            IRCTIN=41
          ELSE
            IRCTIN=42
          END IF
          IF(U5ECSV.EQ.1) THEN
            CALL FNLGTH(J)
            IF(J.LE.40) THEN
              WRITE(U6,100)IUINPT,FNWRK(1:40)
            ELSE
              WRITE(U6,101)IUINPT,FNWRK
            END IF
          END IF
          CALL NBFND2(IPOS,IPT)
          IF(CARD(IPT:IPT).NE.';') THEN
            IMERR2=IPT
            ILINE=LNCNTR
            IMERR1=30048
            CALL CMPRNT(IXM,LNMAP)
          END IF
C
C  BLOCK
C
        ELSE IF(IGROUP.EQ.7.AND.IKEY.EQ.18) THEN
          CALL RINCR(8,NCLBLK,1)
          BLCPNT(NCLBLK)=0
          BLNCLS(NCLBLK)=0
          BLVSTR(NCLBLK)=0
          BLVSIZ(NCLBLK)=0
C
          IPOS=IPT
          IF(NEWSYN.EQ.0) THEN
            NEWSYN=1
C
C  Correct any initial setup of blocks based on the appearance
C  of CLASS statements before the first BLOCK statement.
C  The coding here is probably more general than needed:
C  NCLBLK=2 is the only expected case here.
C
            NCLBAR=0
            IF(NCLBLK.GE.2) THEN
              DO 63 ICLBLK=1,NCLBLK-1
              BLCPNT(ICLBLK)=0
              BLNCLS(ICLBLK)=0
              BLVSTR(ICLBLK)=0
              BLVSIZ(ICLBLK)=0
   63         CONTINUE
            END IF
          ELSE IF(NEWSYN.EQ.2) THEN
            IMERR1=30020
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
          ICSPEC=0
   64     CONTINUE
          IF(CARD(IPOS:IPOS).EQ.'/') THEN
            IPOS2=IPOS+1
            CALL NBFND2(IPOS2,IPOS)
          END IF
          CALL CMATCH(CARD(IPOS:256),IPOS,256,'CLASS',5,IPOS2,1)
          IF(IPOS2.GT.0) THEN
            IF(ICSPEC.EQ.1) THEN
              IMERR1=30070
              IMERR2=IPOS
              ILINE=LNCNTR
              CALL CMPRNT(IXM,LNMAP)
            ELSE
              ICSPEC=1
            END IF
            IPOS=IPOS2
   66       CONTINUE
            IPT=IPOS
            CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,K,IPOS,2,VNAME,NVIN)
            IF(K.GT.0) THEN
              DO 67 I=1,K
              CALL VNMTCH(VTEMP(I+SVTEMP-1),VNAME,NVIN,J)
              IF(J.EQ.0) THEN
                WRITE(U6,205)VTEMP(I+SVTEMP-1)
                IMERR1=30071
                ILINE=LNCNTR
                CALL CMPRNT(IXM,LNMAP)
              ELSE
                IF(MTYPE(J).NE.4) THEN
                  WRITE(U6,253)VTEMP(I+SVTEMP-1)
                  IMERR1=30072
                  ILINE=LNCNTR
                  CALL CMPRNT(IXM,LNMAP)
                END IF
              END IF
              BLNCLS(NCLBLK)=BLNCLS(NCLBLK)+1
              CALL RINCR(9,NCLBAR,1)
              IF(BLCPNT(NCLBLK).EQ.0)BLCPNT(NCLBLK)=NCLBAR
              CLTYPE(NCLBAR)=J
   67         CONTINUE
            END IF
            IF(IPOS.GT.0) THEN
              IF(CARD(IPOS:IPOS).EQ.'*') THEN
                IPOS=IPOS+1
                GO TO 66
              END IF
            END IF
            GO TO 64
          ELSE
            CALL CMATCH(CARD(IPOS:256),IPOS,256,'SELECT',6,IPOS2,1)
            IF(IPOS2.GT.0) THEN
              CALL NBFND2(IPOS2,IPT)
              IGROUP=7
              IKEY=1
              CALL NSET1B(IGROUP,IKEY,IPT,VTMPSZ,ICWRNT,IPOS)
              IF(IMERR1.GT.0) THEN
                ILINE=LNCNTR
                CALL CMPRNT(IXM,LNMAP)
              END IF
              GO TO 64
            ELSE IF(CARD(IPOS:IPOS).NE.';') THEN
              CALL CMATCH(CARD(IPOS:256),IPOS,256,'KEEP',4,IPOS2,1)
              IGROUP=2
              IKEY=7
              IF(IPOS2.GT.0) THEN
                IPT=IPOS2
              ELSE
                IPT=IPOS
              END IF
              CALL NSET1A(IGROUP,IKEY,IPT,VTMPSZ,IPOS)
              IF(IMERR1.GT.0) THEN
C                                                      ! Will get error
                ILINE=LNCNTR
                CALL CMPRNT(IXM,LNMAP)
C                                                      ! condition with
              END IF
C                                                      ! no valid
              GO TO 64
C                                                      ! variables.
            END IF
          END IF
          IF(CARD(IPOS:IPOS).NE.';') THEN
            IMERR2=IPT
            ILINE=LNCNTR
            IMERR1=30026
            CALL CMPRNT(IXM,LNMAP)
          END IF
        ELSE IF(IGROUP.NE.8.OR.IKEY.NE.11) THEN
          IMERR1=30029
          ILINE=IXM(1,ISTATE)
          IMERR2=IXM(2,ISTATE)
          CALL CMPRNT(IXM,LNMAP)
        END IF
      ELSE IF(IXM(5,ISTATE).EQ.1.OR.IXM(5,ISTATE).EQ.2) THEN
C
C                                ! Arithmetic and set assignments
C
        IF(IXM(5,ISTATE).EQ.2) THEN
          IPT=IPT+1
C                                                  ! Move beyond {
        END IF
        CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,
     .              NINSET,IPOS,2,VNAME,NVIN)
        CALL RFADD(VTEMP(SVTEMP),NINSET,VTMPSZ,2,IXM,ISTATE)
        IF(IMERR1.GT.0) THEN
          ILINE=LNCNTR
          CALL CMPRNT(IXM,LNMAP)
        END IF
        ISVTMP=SVTEMP
        SVTEMP=SVTEMP+NINSET
        VTMPSZ=VTMPSZ-NINSET
        IF(NINSET.LE.0) THEN
C                                                  ! Error if no valid
          IF(IXM(5,ISTATE).EQ.1) THEN
C                                                  ! variables
            IMERR1=30100
          ELSE
            IMERR1=30103
          END IF
          ILINE=LNCNTR
          IMERR2=IPOS
          CALL CMPRNT(IXM,LNMAP)
        END IF
        CALL NBFND2(IPOS,IPOS2)
        IF(IXM(5,ISTATE).EQ.2) THEN
C                                                  ! Move beyond }
          IF(CARD(IPOS2:IPOS2).NE.'}') THEN
            IMERR1=30104
            IMERR2=IPOS2
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
          IPOS=IPOS2+1
          CALL NBFND2(IPOS,IPOS2)
        END IF
        IF(CARD(IPOS2:IPOS2).NE.'=') THEN
C                                                  ! Confirm =
          IMERR1=30102
          IMERR2=IPOS2
          ILINE=LNCNTR
          CALL CMPRNT(IXM,LNMAP)
        END IF
        IPOS=IPOS2+1
        CALL NBFND2(IPOS,IPOS2)
        NXPTIB=NXPTI
        CALL ROOMI(NINSET)
        DO 68 I=1,NINSET
        CALL VNMTCH(VTEMP(ISVTMP+I-1),VNAME,NVIN,IV)
        IF(IV.EQ.0) THEN
          CALL RINCR(2,NVIN,1)
          VNAME(NVIN)=VTEMP(ISVTMP+I-1)
          CALL RFCHCK(2)
          IF(IMERR1.GT.0) THEN
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
          IX(NXPTIB+I-1)=MTYPE(NVIN)
          NVIN=NVIN-1
        ELSE
          IX(NXPTIB+I-1)=MTYPE(IV)
        END IF
   68   CONTINUE
        NXPTIS=NXPTI
C                            ! NXPTIS is start of workspace passed from
C                            ! RPOLSH to NSET1E
C
C  Note: RPOLSH checks for a valid end of expression.
C
        CALL RPOLSH(IX,IPOS2,IXM(3,ISTATE),IXM(4,ISTATE),IXM(5,ISTATE),
     .              VTMPSZ,NPOLSH,MSDPT,MSDPT2,NINSET,ISDPT2)
        IF(MSDPT2.GT.MSDPTH) THEN
          MSDPTH=MSDPT2
        END IF
        IF(IMERR1.GT.0) THEN
          ILINE=LNCNTR
          CALL CMPRNT(IXM,LNMAP)
        END IF
        CALL NSET1E(IX(NXPTIS),NPOLSH,IX(NXPTIB),NINSET,IXM,IBYCHK)
        IF(IMERR1.GT.0) THEN
          ILINE=LNCNTR
          CALL CMPRNT(IXM,LNMAP)
        END IF
        CALL NBFND2(IPOS2,IPOS)
        SVTEMP=ISVTMP
        VTMPSZ=VTMPSZ+NINSET
        J=1
C                                                     ! J counts #
        DO 681 I=1,NINSET
C                                                     ! of recodes
        CALL VNMTCH(VTEMP(ISVTMP+I-1),VNAME,NVIN,IV)
        IF(IV.EQ.0) THEN
          CALL RINCR(2,NVIN,1)
          MTYPE(NVIN)=1
C                                                     ! reset mtype
          VNAME(NVIN)=VTEMP(ISVTMP+I-1)
          CALL VNCHK2(VNAME(NVIN),1,IXM,LNMAP)
          IV=NVIN
          LABEL(NVIN)(1:12)=VNAME(NVIN)
          LABEL(NVIN)(13:24)='            '
          CALL RFCHCK(1)
          IF(IMERR1.GT.0) THEN
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
        ELSE
          IF(MTYPE(IV).NE.1.AND.MTYPE(IV).NE.2.AND.MTYPE(IV).LT.50) THEN
            IMERR1=30101
            ILINE=LNCNTR
            CALL CMPRNT(IXM,LNMAP)
          END IF
        END IF
        IF(I.GT.1) THEN
          IF(IX(NXPTIB+I-1).LE.51.OR.
C                                                      ! Look for
     .       IX(NXPTIB+I-1).NE.IX(NXPTIB+I-2)+1) THEN
C                                                      ! series
            J=J+1
          END IF
        END IF
  681   CONTINUE
        IF(ISDPT2.EQ.1) THEN
          J=NINSET
        END IF
        CALL RINCR(4,NRECOD,J)
        J=0
        DO 69 I=1,NINSET
        CALL VNMTCH(VTEMP(ISVTMP+I-1),VNAME,NVIN,IV)
        IF(I.GT.1.AND.IX(NXPTIB+I-1).GT.51.AND.ISDPT2.EQ.NINSET) THEN
          IF(IX(NXPTIB+I-1).EQ.IX(NXPTIB+I-2)+1) THEN
            V2(NRECOD+1-J)=V2(NRECOD+1-J)+1
            GO TO 69
          END IF
        END IF
        J=J+1
        RSTPNT(NRECOD+1-J)=0
        V3(NRECOD+1-J)=0
        V2(NRECOD+1-J)=0
        V1(NRECOD+1-J)=IV
        IF(IX(NXPTIB+I-1).GE.51.AND.ISDPT2.EQ.NINSET) THEN
          V2(NRECOD+1-J)=1
          RCTYPE(NRECOD+1-J)=255
        ELSE IF(ISDPT2.EQ.NINSET.OR.I.EQ.1) THEN
          RCTYPE(NRECOD+1-J)=100
        ELSE IF(ISDPT2.EQ.1) THEN
          RCTYPE(NRECOD+1-J)=108
        END IF
   69   CONTINUE
        NXPTI=NXPTIB
      ELSE IF(IXM(5,ISTATE).EQ.5.OR.IXM(5,ISTATE).EQ.6) THEN
C                                                            ! IF
C                                                            ! ELSE IF
        NXPTIB=NXPTI
        CALL ROOMI(1)
        NXPTIS=NXPTI
        IF(IXM(5,ISTATE).EQ.5) THEN
          IXM(10,ISTATE)=NRECOD+1
C                                            ! Save beginning of IF
        ELSE
          CALL RINCR(4,NRECOD,1)
C                                            ! For ELSE IF, generate an
          RSTPNT(NRECOD)=0
C                                            ! unconditional GO TO
          V3(NRECOD)=0
C                                            ! instruction to close off
          V2(NRECOD)=0
C                                            ! the previous IF/ELSE IF,
          V1(NRECOD)=0
C                                            ! and store its location in
          RCTYPE(NRECOD)=36
C                                            ! IXM(10,*)
          IXM(10,ISTATE)=NRECOD
        END IF
        CALL RPOLSH(IX,IPT,IXM(3,ISTATE),IXM(4,ISTATE),IXM(5,ISTATE),
     .              VTMPSZ,NPOLSH,MSDPT,MSDPT2,1,ISDPT2)
        IF(MSDPT2.GT.MSDPTH) THEN
          MSDPTH=MSDPT2
        END IF
        IF(IMERR1.GT.0) THEN
          ILINE=LNCNTR
          CALL CMPRNT(IXM,LNMAP)
        END IF
        CALL NSET1E(IX(NXPTIS),NPOLSH,IX(NXPTIB),1,IXM,IBYCHK)
        IF(IMERR1.GT.0) THEN
          ILINE=LNCNTR
          CALL CMPRNT(IXM,LNMAP)
        END IF
        NXPTI=NXPTIB
        CALL RINCR(4,NRECOD,1)
C                                            ! For both IF and ELSE IF,
        IXM(11,ISTATE)=NRECOD
C                                            ! generate a conditional
        RSTPNT(NRECOD)=0
C                                            ! GO TO, depending on
        V3(NRECOD)=0
C                                            ! result in stack, and
        V2(NRECOD)=0
C                                            ! store its location in
        V1(NRECOD)=0
C                                            ! IXM(11,*)
        RCTYPE(NRECOD)=109
      ELSE IF(IXM(5,ISTATE).EQ.7) THEN
        CALL RINCR(4,NRECOD,1)
C                                            ! For ELSE, generate an
        RSTPNT(NRECOD)=0
C                                            ! unconditional GO TO
        V3(NRECOD)=0
C                                            ! instruction to close off
        V2(NRECOD)=0
C                                            ! the previous IF/ELSE IF,
        V1(NRECOD)=0
C                                            ! and store its location in
        RCTYPE(NRECOD)=36
C                                            ! IXM(10,*)
        IXM(10,ISTATE)=NRECOD
        IXM(11,ISTATE)=0
      ELSE IF(IXM(5,ISTATE).EQ.8) THEN
C
C  When encounter final END IF, close off any previous pointers
C
        J=NRECOD+1
        DO 53 I=ISTATE-1,1,-1
        IF(IXM(5,I).GE.5.AND.IXM(5,I).LE.7) THEN
          IF((IXM(5,I).EQ.5.AND.IXM(6,I).EQ.IXM(6,ISTATE)-1).OR.
     .       (IXM(5,I).GT.5.AND.IXM(6,I).EQ.IXM(6,ISTATE))) THEN
            IF(IXM(11,I).GT.0) THEN
              IRECOD=IXM(11,I)
C                                            ! IXM(11,*) holds location
              V3(IRECOD)=J
C                                            ! of conditional branch
            END IF
            IF(IXM(5,I).EQ.5) THEN
              GO TO 54
            END IF
            IF(IXM(10,I).GT.0) THEN
C                                            ! Use IXM(10,*) to set
              IRECOD=IXM(10,I)
C                                            ! unconditional branch to
              V3(IRECOD)=NRECOD+1
C                                            ! end of loop, and update
              J=IRECOD+1
C                                            ! J
            END IF
          END IF
        END IF
   53   CONTINUE
        I=1
   54   CONTINUE
      END IF
    1 CONTINUE
C
C       do 555 j=1,nrecod
C       write(*,*)rctype(j),v1(j),v3(j)
C 555   continue
C
      U5ECHO=U5ECSV
      REWIND(14)
      DO 92 ILINE2=1,NLINE2
      U5ECHO=LNECHO(ILINE2)
C     write(*,*)iline2,u5echo
      READ(13)CARDIM
      IF(ILINE2.EQ.1) THEN
        CALL CRDPRN(1)
      ELSE
        CALL CRDPRN(0)
      END IF
   92 CONTINUE
      REWIND(13)
C
C
      IF((IFLOW.EQ.0.AND.ITYPEF(1).EQ.1).OR.IRCINP.EQ.0) THEN
        IF(IFLOW.EQ.0.AND.ITYPEF(1).EQ.1) THEN
          IF(IRCINP.EQ.0) THEN
            IMERR1=30043
          ELSE
            IMERR1=30044
          END IF
        ELSE
          IMERR1=30045
        END IF
        ILINE=LNCNTR
        CALL FSTOP
      END IF
      V3(IRCINP+1)=IFLOW
      RSTPNT(IRCINP+1)=IFHIGH-IFLOW+1
      IF(ISTEPC.NE.1.OR.IOUTFV.GT.0) THEN
        IF(IRCOUT.LE.0) THEN
          IMERR1=30021
          CALL FSTOP
        ELSE IF(IOUTFV.LE.1.AND.IFOUTL.EQ.0) THEN
          IMERR1=30022
          CALL FSTOP
        END IF
        V3(IRCOUT)=IFOUTL
        RSTPNT(IRCOUT)=IFOUTH-IFOUTL+1
        IF(ISTEPC.NE.1.AND.NBY.GT.0.AND.IBYCHK.EQ.0) THEN
          IMERR1=30023
          CALL FSTOP
        END IF
      END IF
C
C  Future: improve this warning message.
 
      IF(ICWARN.GT.0.AND.U5ECHO.GT.0)WRITE(U6,220)ICWARN
      IF(NHADAM.GT.0) THEN
        J=RCEIL(2)-NVIN
        IF(NRECOD.GT.0) THEN
          DO 91 I=1,NRECOD
          IF(RCTYPE(I).EQ.61) GO TO 94
   91     CONTINUE
        END IF
        IF(IREPF.EQ.1) THEN
          VNAME(NVIN+1)='REPF        '
        ELSE
          VNAME(NVIN+1)='REPW        '
        END IF
        NVINPT=1
        CALL RFADD(VNAME(NVIN+1),NVINPT,J,2,IXM,0)
        IF(IMERR1.GT.0) THEN
          CALL CMPRNT(IXM,LNMAP)
        END IF
      END IF
C
C
   94 CONTINUE
C       do 55 j=1,nrecod
C       write(*,*)rctype(j),v1(j),v3(j)
C  55   continue
      RETURN
      END
C
      SUBROUTINE NSET1A(IGROUP,IKEY,IPT,VTMPSZ,IPOS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MIFLVL=7,IXFLLD=15-MIFLVL)
      PARAMETER (MAXFMT=20)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
      INTEGER VTMPSZ
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
      LOGICAL REFRSH,ALPCHK,DGTCHK
      EXTERNAL REFRSH,ALPCHK,DGTCHK
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
C
C       NVTOT   (NTOTV)
C       NVREG   (IOUTC1)
C       NVARID  (NID1)
C
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1,
     . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX
C
      DOUBLE PRECISION RANGE(2,MRANGE)
      INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET),
     . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD),
     . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI)
C
      COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP,
     . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO,
     . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS,
     . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT,
     . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS,
     . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO,
     . NLEVEL,NRNSET,NRANGE,NHADAM,ISTEPC,IFLVL,IF1LST,IFLAST,NEWSYN,
     . IXFILL
      INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS,
     . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN,
     . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IFLAST(MIFLVL),
     . IXFILL(IXFLLD)
C
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
C
  205 FORMAT(' UNRECOGNIZED VARIABLE NAME ',A12)
  209 FORMAT(' VARIABLE REQUIRED TO BE OF TYPE REAL - ',A12)
C
C  BY (7, 2), REPLICATION (7,3) (REP) (7,7), UNWEIGHTED (7,4),
C  DROP(7,6), REPLICATE (7,8), WEIGHT (7,9), STRATUM (7,10),
C  CLUSTER (7,11), SECOND (7,12), COEFFICIENT (7,13),
C  FPC1 (7,14), FPC2(7,15), HADAMARD (7,26)
C  KEEP (2,7), LABEL (2,8), LEVEL (2,9), RENAME (2,10),
C
C
C  BY (7,2)
C
      IF(IGROUP.EQ.7.AND.IKEY.EQ.2) THEN
        IF(NBY.GT.0.AND.ISTEPC.EQ.1) THEN
          IMERR1=30200
          RETURN
        END IF
        CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,I,IPOS,2,VNAME,NVIN)
        IF(I.LE.0) THEN
          IMERR1=30201
          RETURN
        END IF
        IPT=IPOS
        IF(ISTEPC.EQ.2) THEN
          IF(I.NE.NBY) THEN
            IMERR1=30202
            RETURN
          END IF
          J=RCEIL(2)+NVREG+NCLASS+NVARID
          IF(VFTYPE.GE.5.AND.VFTYPE.LE.12)J=J-1
        ELSE
          NBY=I
          CALL RCHECK(3,0,NBY)
        END IF
        DO 26 I=1,NBY
        CALL VNMTCH(VTEMP(I+SVTEMP-1),VNAME,NVIN,BYLIST(I))
        IF(BYLIST(I).EQ.0) THEN
          WRITE(U6,205)VTEMP(I+SVTEMP-1)
          IMERR1=30203
          RETURN
        END IF
        IF(ISTEPC.EQ.2) THEN
C                                                      ! For REWEIGHT,
          J=J+1
C                                                      ! check that
          CALL VNMTCH(VTEMP(I+SVTEMP-1),VNAME(J),1,K)
C                                                      ! BYLIST matches
          IF(K.NE.1) THEN
            IMERR1=30204
            RETURN
          END IF
        END IF
   26   CONTINUE
C
C  HADAMARD (7,26)
C
      ELSE IF(IGROUP.EQ.7.AND.IKEY.EQ.26) THEN
        CALL NBFND2(IPT,IPOS2)
        IF(IPOS2.EQ.0) THEN
          IMERR1=30205
          RETURN
        END IF
        IF(NHADAM.GT.0) THEN
          IMERR1=30206
          RETURN
        END IF
        CALL IFIND(CARD(IPOS2:256),IPOS2,256,IPT,NHADAM)
        IF(IPT.LE.0) THEN
          IMERR1=30207
C                                                      ! Error if no #
          RETURN
        END IF
C
C  REPLICATION (7,3) [REP] (7,7) METHOD,
C  REPLICATE (7,8) [REP] NUMBER, FACTORS, WEIGHTS, COUNT
C
      ELSE IF(IGROUP.EQ.7.AND.(IKEY.EQ.3.OR.IKEY.EQ.7.OR.
     .        IKEY.EQ.8)) THEN
        CALL NBFND2(IPT,IPOS2)
        IF(IPOS2.EQ.0) THEN
          IMERR1=30205
          RETURN
        ELSE IF(CARD(IPOS2:IPOS2).EQ.';') THEN
          IMERR1=30205
          RETURN
        END IF
        IPT=IPOS2
        IFLAG=0
        CALL CMATCH(CARD(IPT:256),IPT,256,'COUNT',5,IPOS2,1)
        IF(IPOS2.GT.0) THEN
          IF(ICLCNT.GT.0) THEN
            IMERR1=30207
            RETURN
          END IF
          CALL IFIND(CARD(IPOS2:256),IPOS2,256,IPT,ICLCNT)
          IF(IPT.LE.0) THEN
            IMERR1=30205
            IMERR2=IPOS2
          END IF
          GO TO 90
C                                              ! Final check for ';'
        END IF
        CALL CMATCH(CARD(IPT:256),IPT,256,'NUMBER',6,IPOS2,1)
        IF(IPOS2.GT.0) THEN
          IF(IREPNO.GT.0.OR.IREPF.GT.0.OR.IREPW.GT.0.OR.
     .       ISTRCD.GT.0.OR.ISTRNO.GT.0.OR.ISNDCD.GT.0.OR.
     .       ISNDNO.GT.0.OR.ICLUSC.GT.0.OR.ICLUSN.GT.0) THEN
            IMERR1=30207
            RETURN
          END IF
          IFLAG=1
          IREPNO=1
        ELSE
          CALL CMATCH(CARD(IPT:256),IPT,256,'FACTORS',7,IPOS2,1)
          IF(IPOS2.GT.0) THEN
            IF(IREPNO.GT.0.OR.IREPF.GT.0.OR.IREPW.GT.0.OR.
     .         ISTRCD.GT.0.OR.ISTRNO.GT.0.OR.ISNDCD.GT.0.OR.
     .         ISNDNO.GT.0.OR.ICLUSC.GT.0.OR.ICLUSN.GT.0) THEN
              IMERR1=30207
              RETURN
            END IF
            IFLAG=1
            IREPF=1
          ELSE
            CALL CMATCH(CARD(IPT:256),IPT,256,'WEIGHTS',7,IPOS2,1)
            IF(IPOS2.EQ.0) THEN
              CALL CMATCH(CARD(IPT:256),IPT,256,'WEIGHT',6,IPOS2,1)
            END IF
            IF(IPOS2.GT.0) THEN
              IF(IREPNO.GT.0.OR.IREPF.GT.0.OR.IREPW.GT.0.OR.
     .           ISTRCD.GT.0.OR.ISTRNO.GT.0.OR.ISNDCD.GT.0.OR.
     .           ISNDNO.GT.0.OR.ICLUSC.GT.0.OR.ICLUSN.GT.0) THEN
                IMERR1=30207
                RETURN
              END IF
              IFLAG=1
              IREPW=1
            END IF
          END IF
        END IF
C
C  IFLAG = 1 if NUMBER, FACTORS, or WEIGHT(S) is present.
C
        IF(IFLAG.EQ.1) THEN
          CALL VNFIND(IPOS2,VTEMP(SVTEMP),VTMPSZ,NREPW,IPT,2,VNAME,
     .      NVIN)
          IF(NREPW.LE.0) THEN
            IMERR1=30205
            RETURN
          END IF
          IF(IREPNO.EQ.1.AND.NREPW.GT.1) THEN
            IMERR1=30208
            RETURN
          END IF
          DO 28 I=1,NREPW
          CALL VNMTCH(VTEMP(I+SVTEMP-1),VNAME,MVAR,IV1)
          IF(IV1.LE.0) THEN
            WRITE(U6,205)VTEMP(I+SVTEMP-1)
            IMERR1=30209
            RETURN
          END IF
          IF(IREPNO.EQ.1) THEN
            IREPNO=IV1
            NREPW=0
            GO TO 90
          END IF
          IF(MTYPE(IV1).NE.1.OR.MXSIZE(IV1).NE.1) THEN
            WRITE(U6,209)VTEMP(I+SVTEMP-1)
            IMERR1=30210
            RETURN
          END IF
          MTYPE(IV1)=50+I
   28     CONTINUE
          GO TO 90
C                                                ! Final check for ';'
        END IF
        CALL CMATCH(CARD(IPT:256),IPT,256,'METHOD',
     .       6,IPOS2,1)
        IF(IPOS2.GT.0) THEN
C                                                ! Note that this code
          CALL NBFND2(IPOS2,IPT)
C                                                ! treats 'method'
          IF(IPT.EQ.0) THEN
C                                                ! as optional
            IMERR1=30205
            RETURN
          ELSE IF(CARD(IPT:IPT).EQ.';') THEN
            IMERR1=30205
            IMERR2=IPT
            RETURN
          END IF
          IF(VROPTN.GT.0) THEN
            IMERR1=30226
C                                                ! Note: if VROPTN>0
            RETURN
C                                                ! different error
          END IF
C                                                ! messages depending
        ELSE IF(VROPTN.GT.0) THEN
C                                                ! on whether METHOD
          IMERR1=30227
C                                                ! is present
          IMERR2=IPT
          RETURN
        END IF
        CALL CMATCH(CARD(IPT:256),IPT,256,'STRATIFIED',10,IPOS2,1)
        IF(IPOS2.GT.0) THEN
          CALL NBFND2(IPOS2,IPT)
          CALL CMATCH(CARD(IPT:256),IPT,256,'JACKKNIFE',9,IPOS2,1)
          IF(IPOS2.GT.0) THEN
            VROPTN=4
          ELSE
            CALL CMATCH(CARD(IPT:256),IPT,256,'RANDOM',6,IPOS2,1)
            IF(IPOS2.GT.0) THEN
              CALL NBFND2(IPOS2,IPT)
              CALL CMATCH(CARD(IPT:256),IPT,256,'GROUP',5,IPOS2,1)
              IF(IPOS2.GT.0) THEN
                VROPTN=8
              ELSE
                IMERR1=30224
                IMERR2=IPT
              END IF
            ELSE
              IMERR1=30224
              IMERR2=IPT
            END IF
          END IF
          IF(IMERR1.GT.0) THEN
            RETURN
          ELSE
            IPT=IPOS2
            GO TO 90
          END IF
        END IF
        CALL CMATCH(CARD(IPT:256),IPT,256,'GENERAL',7,IPOS2,1)
        IF(IPOS2.EQ.0) THEN
          CALL CMATCH(CARD(IPT:256),IPT,256,'GENERALIZED',11,IPOS2,1)
        END IF
        IF(IPOS2.GT.0) THEN
          CALL NBFND2(IPOS2,IPT)
          CALL CMATCH(CARD(IPT:256),IPT,256,'REPLICATION',11,IPOS2,1)
          IF(IPOS2.GT.0) THEN
            CALL NBFND2(IPOS2,IPT)
          END IF
          VROPTN=5
          GO TO 90
C                                                ! Final check for ';'
        END IF
        CALL CMATCH(CARD(IPT:256),IPT,256,'NONE',4,IPOS2,2)
        IF(IPOS2.GT.0) THEN
          VROPTN=6
          CALL NBFND2(IPOS2,IPT)
          GO TO 90
C                                                ! Final check for ';'
        END IF
        ISMPL=0
        CALL CMATCH(CARD(IPT:256),IPT,256,'SIMPLE',6,IPOS2,1)
        IF(IPOS2.GT.0) THEN
          CALL NBFND2(IPOS2,IPT)
          IF(IPT.EQ.0) THEN
            IMERR1=30205
            RETURN
          ELSE IF (CARD(IPT:IPT).EQ.';') THEN
            IMERR1=30205
            RETURN
          END IF
          ISMPL=1
        END IF
        CALL CMATCH(CARD(IPT:256),IPT,256,'JACKKNIFE',9,IPOS2,2)
        IF(IPOS2.GT.0) THEN
          CALL NBFND2(IPOS2,IPT)
          VROPTN=1
          GO TO 90
C                                                ! Final check for ';'
        END IF
        CALL CMATCH(CARD(IPT:256),IPT,256,'RANDOM',6,IPOS2,1)
        IF(IPOS2.GT.0) THEN
          CALL NBFND2(IPOS2,IPT)
          CALL CMATCH(CARD(IPT:256),IPT,256,'GROUP',5,IPOS2,1)
          IF(IPOS2.GT.0) THEN
            VROPTN=7
            CALL NBFND2(IPOS2,IPT)
            GO TO 90
C                                                ! Final check for ';'
          ELSE
            IMERR1=30224
            IMERR2=IPT
            RETURN
          END IF
        END IF
        CALL CMATCH(CARD(IPT:256),IPT,256,'REWEIGHTED',10,IPOS2,2)
        IF(IPOS2.GT.0) THEN
          IF(ISMPL.EQ.1) THEN
            IMERR1=30228
            IMERR2=IPOS2
            RETURN
          END IF
          CALL NBFND2(IPOS2,IPT)
          VROPTN=3
        END IF
        CALL CMATCH(CARD(IPT:256),IPT,256,'HALF',4,IPOS2,1)
        IF(IPOS2.GT.0) THEN
          CALL NBFND2(IPOS2,IPT)
          IF(IPT.GT.0) THEN
            IF(CARD(IPT:IPT).EQ.'-') THEN
              IPOS2=IPT+1
              CALL NBFND2(IPOS2,IPT)
            END IF
            IF(IPT.GT.0) THEN
              CALL CMATCH(CARD(IPT:256),IPT,256,'SAMPLE',6,IPOS2,2)
              CALL NBFND2(IPOS2,IPT)
            END IF
          END IF
          IF(VROPTN.EQ.0) THEN
            VROPTN=2
          END IF
        ELSE
          CALL CMATCH(CARD(IPT:256),IPT,256,'HALFSAMPLE',10,IPOS2,1)
          IF(IPOS2.GT.0) THEN
            CALL NBFND2(IPOS2,IPT)
            IF(VROPTN.EQ.0) THEN
              VROPTN=2
            END IF
          ELSE
            IMERR1=30211
            RETURN
          END IF
        END IF
C
C  UNWEIGHTED (7,4)
C
      ELSE IF(IGROUP.EQ.7.AND.IKEY.EQ.4) THEN
        IF(IWGT.NE.0) THEN
          IMERR1=30212
          RETURN
        END IF
        NOWGTF=1
C
C  DROP (7,6), KEEP (2,7)
C
      ELSE IF((IGROUP.EQ.7.AND.IKEY.EQ.6).OR.
     .        (IGROUP.EQ.2.AND.IKEY.EQ.7)) THEN
        IF(VKEEPF.NE.0) THEN
          IF((IKEY.EQ.6.AND.VKEEPF.EQ.1).OR.
     .       (IKEY.EQ.7.AND.VKEEPF.EQ.2)) THEN
            IMERR1=30213
            RETURN
          END IF
        ELSE IF(IKEY.EQ.6) THEN
          VKEEPF=2
C                                     ! DROP
        ELSE
          VKEEPF=1
C                                     ! KEEP
        END IF
        J=MVAR-NKEEP
        CALL VNFIND(IPT,VNKEEP(NKEEP+1),J,N,IPOS,2,VNAME,NVIN)
        IF(N.LE.0) THEN
          IMERR1=30214
          RETURN
        END IF
        IF(IKEY.EQ.7) THEN
          IF(BLVSTR(NCLBLK).EQ.0)BLVSTR(NCLBLK)=NKEEP+1
          BLVSIZ(NCLBLK)=BLVSIZ(NCLBLK)+N
        END IF
        NKEEP=NKEEP+N
        IPT=IPOS
C
C  LABEL (2,8), LABELS
C
      ELSE IF(IGROUP.EQ.2.AND.IKEY.EQ.8) THEN
        CALL RLABEL(IPT,VNAME,NVIN,VTEMP(SVTEMP),VTMPSZ,VTEMP,
     .    MTYPE,LPOINT,CDMPNT,CROSSD,LABEL,LEVEL,NLEVEL,MLEVEL,IPOS)
        IPT=IPOS
C
C  LEVEL (2,9), LEVELS
C
      ELSE IF(IGROUP.EQ.2.AND.IKEY.EQ.9) THEN
        CALL RLEVEL(IPT,VNAME,NVIN,VTEMP(SVTEMP),VTMPSZ,LPOINT,MSIZE,
     .    LEVEL,NLEVEL,MLEVEL,IPOS)
        IPT=IPOS
C
C  RENAME (2,10)
C
      ELSE IF(IGROUP.EQ.2.AND.IKEY.EQ.10) THEN
        CALL RENAMV(IPT,VNAME,NVIN,VTEMP(SVTEMP),VTMPSZ,VTEMP,
     .    VNKEEP,NKEEP,MTYPE,LPOINT,CDMPNT,CROSSD,LABEL,LEVEL,IPOS)
        IPT=IPOS
C
C  WEIGHT (7,9)
C
      ELSE IF(IGROUP.EQ.7.AND.IKEY.EQ.9) THEN
        IF(IWGT.NE.0.OR.NOWGTF.GT.0) THEN
          IMERR1=30215
          RETURN
        END IF
        CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,N,IPOS,2,VNAME,NVIN)
        IF(N.EQ.0) THEN
          IMERR1=30205
          RETURN
        ELSE IF(N.GT.1) THEN
          IMERR1=30208
          RETURN
        END IF
        CALL VNMTCH(VTEMP(SVTEMP),VNAME,NVIN,N)
        IF(N.LE.0) THEN
          WRITE(U6,205)VTEMP(SVTEMP)
          IMERR1=30209
          RETURN
        END IF
        IWGT=N
        IPT=IPOS
C
C  STRATUM (7,10) SIZE, STRATUM SIZES, STRATUM CODE, STRATUM NUMBER
C  SECOND (7,12) STAGE SIZE, SECOND STAGE SIZES, SECOND STAGE CODE,
C  SECOND STAGE NUMBER
C  SECOND-STAGE SIZE, SECOND-STAGE SIZES, SECOND-STAGE CODE,
C  SECOND-STAGE NUMBER
C  CLUSTER (7,11) CODE, CLUSTER NUMBER, CLUSTER COUNT
C
      ELSE IF(IGROUP.EQ.7.AND.(IKEY.GE.10.AND.IKEY.LE.12)) THEN
        IF(IKEY.EQ.27.AND.CARD(IPT:IPT).EQ.'-')IPT=IPT+1
        CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,N,IPOS,2,VNAME,NVIN)
        IF(N.EQ.0) THEN
          IMERR1=30205
          RETURN
        END IF
        IF((IKEY.EQ.10.AND.N.EQ.1).OR.
C                                                 ! STRATUM
     .     (IKEY.EQ.12.AND.N.EQ.2)) THEN
C                                                 ! SECOND (STAGE)
          CALL CMATCH(VTEMP(N+SVTEMP-1),1,12,'SIZE',4,IPOS2,2)
          IF(IPOS2.GT.0) THEN
            L=SIZED-NXPTD+1
            CALL DASCAN(IPOS,IPOS2,DX(NXPTD),L,N)
            IF(N.LE.0) THEN
              IMERR1=30205
              RETURN
            END IF
            IF(IKEY.EQ.10) THEN
              IF(SISTRS.GT.0) THEN
                IMERR1=30207
                RETURN
              ELSE
                SISTRS=NXPTI
                NISTRS=N
              END IF
            ELSE
              IF(SISNDS.GT.0) THEN
                IMERR1=30207
                RETURN
              ELSE
                SISNDS=NXPTI
                NISNDS=N
              END IF
            END IF
            J=NXPTI
            K=NXPTD
            CALL ROOMI(N)
            DO 30 I=1,N
            IX(J)=DX(K)+.05
            IF(IX(J).LE.0.) THEN
              IMERR1=30216
              RETURN
            END IF
            J=J+1
            K=K+1
   30       CONTINUE
            IPT=IPOS2
            GO TO 90
C                                                ! Final check for ';'
          END IF
        END IF
        CALL CMATCH(VTEMP(N+SVTEMP-1),1,12,'COUNT',5,IPOS2,2)
        IF(IPOS2.GT.0) THEN
          IF(ICLCNT.GT.0) THEN
            IMERR1=30207
            RETURN
          ELSE IF(IKEY.NE.11) THEN
            IMERR1=30217
            RETURN
          END IF
          CALL IFIND(CARD(IPOS:256),IPOS,256,IPT,ICLCNT)
          IF(IPT.LE.0) THEN
            IMERR1=30218
          END IF
          GO TO 90
C                                                ! Final check for ';'
        END IF
        IPT=IPOS
        CALL VNMTCH(VTEMP(N+SVTEMP-1),VNAME,NVIN,L)
        IF(L.LE.0) THEN
          IMERR1=30209
          WRITE(U6,205)VTEMP(N+SVTEMP-1)
          RETURN
        END IF
        IF(N.GT.1) THEN
          N=N-1
          CALL CMATCH(VTEMP(N+SVTEMP-1),1,12,'NUMBER',6,IPOS2,1)
          IF(IPOS2.GT.0) THEN
            IF(IKEY.EQ.10) THEN
              IF(ISTRNO.EQ.0.AND.ISTRCD.EQ.0.OR.IREPNO.GT.0) THEN
                ISTRNO=L
                GO TO 90
C                                                ! Final check for ';'
              END IF
            ELSE IF(IKEY.EQ.11) THEN
              IF(ICLUSN.EQ.0.AND.ICLUSC.EQ.0.OR.IREPNO.GT.0) THEN
                ICLUSN=L
                GO TO 90
C                                                ! Final check for ';'
              END IF
            ELSE
              IF(ISNDNO.EQ.0.AND.ISNDCD.EQ.0.OR.IREPNO.GT.0) THEN
                ISNDNO=L
                GO TO 90
C                                                ! Final check for ';'
              END IF
            END IF
            IMERR1=30207
            RETURN
          END IF
        END IF
        IF(IKEY.EQ.10) THEN
          IF(ISTRCD.EQ.0.AND.ISTRCD.EQ.0.OR.IREPNO.GT.0) THEN
            ISTRCD=L
            GO TO 90
C                                                ! Final check for ';'
          END IF
        ELSE IF(IKEY.EQ.11) THEN
          IF(ICLUSC.EQ.0.AND.ICLUSN.EQ.0.OR.IREPNO.GT.0) THEN
            ICLUSC=L
            GO TO 90
C                                                ! Final check for ';'
          END IF
        ELSE
          IF(ISNDCD.EQ.0.AND.ISNDNO.EQ.0.OR.IREPNO.GT.0) THEN
            ISNDCD=L
            GO TO 90
C                                                ! Final check for ';'
          END IF
        END IF
        IMERR1=30205
        RETURN
C
C  COEFFICIENTS (7,13), FPC1 (7,14), FPC2 (7,15)
C
      ELSE IF(IGROUP.EQ.7.AND.(IKEY.GE.13.AND.IKEY.LE.15)) THEN
        L=SIZED-NXPTD+1
        CALL DASCAN(IPT,IPOS2,DX(NXPTD),L,N)
        IF(N.LE.0) THEN
          IMERR1=30205
          RETURN
        END IF
        IPT=IPOS2
        IF(IKEY.EQ.13) THEN
C                                                ! COEFFICIENTS
          IF(ISTEPC.EQ.2) THEN
            IF(N.NE.NRPTOT) THEN
              IMERR1=30219
              RETURN
            END IF
            DO 41 I=1,N
            IF(DABS(DX(NXPTD+I-1)-DX(SDCOEF+I-1)).GT..1D-06) THEN
              IMERR1=30220
              RETURN
            END IF
   41       CONTINUE
          ELSE IF(SDCOEF.GT.0) THEN
            IMERR1=30221
            RETURN
          ELSE IF(SDFPC1.GT.0.OR.SDFPC2.GT.0) THEN
            IMERR1=30222
            RETURN
          ELSE
            SDCOEF=NXPTD
            NDCOEF=N
          END IF
        ELSE
C                                                ! FPC1, FPC2
          DO 42 I=1,N
          DX(NXPTD+I-1)=1.D0-DX(NXPTD+I-1)
   42     CONTINUE
          IF(IKEY.EQ.14) THEN
            IF(SDFPC1.GT.0) THEN
              IMERR1=30207
              RETURN
            ELSE IF(SDCOEF.GT.0.AND.ISTEPC.EQ.1) THEN
              IMERR1=30223
              RETURN
            ELSE
              SDFPC1=NXPTD
              NDFPC1=N
            END IF
          ELSE
            IF(SDFPC2.GT.0) THEN
              IMERR1=30207
              RETURN
            ELSE IF(SDCOEF.GT.0.AND.ISTEPC.EQ.1) THEN
              IMERR1=30223
              RETURN
            ELSE
              SDFPC2=NXPTD
              NDFPC2=N
            END IF
          END IF
        END IF
        IF(ISTEPC.EQ.1.OR.IKEY.NE.13) THEN
          CALL ROOMD(N)
        END IF
      END IF
   90 CONTINUE
      CALL NBFND2(IPT,IPOS)
C                                          ! Check for ending ';'
      RETURN
      END
C
      SUBROUTINE NSET1D(IKEY,IPT,K)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MAXFMT=20)
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
      LOGICAL REFRSH
      EXTERNAL REFRSH
C
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
C
      L=2
      IAPOST=0
      IPAREN=1
      IPOS=IPT+1
      INFRMT(K)(1:1)='('
      CALL STBLNK(INFRMT(K),2,128)
    5 CONTINUE
      DO 6 I=IPOS,256
C
C  Set IMERR2 to the current position in preparation for an error
C  call.  It is reset to 0 when the format has been successfully
C  scanned.
C
      IMERR2=I
      IF(CARD(I:I).EQ.'''') THEN
C
C  Expect apostrophe in format only for OUTFORMAT
C
        IF(IKEY.EQ.6) THEN
          IMERR1=30004
          ILINE=LNCNTR
          RETURN
        ELSE
          IF(IAPOST.EQ.0) THEN
            IAPOST=1
          ELSE
            IAPOST=0
          END IF
        END IF
      ELSE IF(IAPOST.EQ.0) THEN
        IF(CARD(I:I).EQ.' ') THEN
          GO TO 6
        ELSE IF(IPAREN.EQ.0) THEN
          IF(CARD(I:I).EQ.';'.OR.CARD(I:I).EQ.'/') THEN
C
C  Normal end of processing here.
C
            IMERR2=0
            IPT=I
            RETURN
          ELSE
            IMERR1=30007
            ILINE=LNCNTR
            RETURN
          END IF
        ELSE IF(CARD(I:I).EQ.'x') THEN
          CARD(I:I)='X'
        ELSE IF(CARD(I:I).EQ.'f') THEN
          CARD(I:I)='F'
        ELSE IF(CARD(I:I).EQ.'d') THEN
          CARD(I:I)='D'
        ELSE IF(CARD(I:I).EQ.'e') THEN
           CARD(I:I)='E'
        ELSE IF(CARD(I:I).EQ.'A'.OR.CARD(I:I).EQ.'a') THEN
          IMERR1=30005
          ILINE=LNCNTR
          RETURN
        ELSE IF(CARD(I:I).EQ.'I'.OR.CARD(I:I).EQ.'i') THEN
          IMERR1=30006
          ILINE=LNCNTR
          RETURN
        ELSE IF(CARD(I:I).EQ.' ') THEN
          GO TO 6
        ELSE IF(CARD(I:I).EQ.'(') THEN
          IPAREN=IPAREN+1
        ELSE IF(CARD(I:I).EQ.')') THEN
          IPAREN=IPAREN-1
        END IF
      END IF
      IF(L.GT.128) THEN
        L=1
        CALL RINCR(11,K,1)
        CALL STBLNK(INFRMT(K),1,128)
      END IF
      INFRMT(K)(L:L)=CARD(I:I)
      L=L+1
    6 CONTINUE
      IF(IAPOST.EQ.1) THEN
        IMERR1=30008
        IMERR2=0
        ILINE=LNCNTR
        RETURN
      ELSE IF(REFRSH(IPT)) THEN
        IPOS=1
        GO TO 5
      ELSE
        IMERR1=30009
        IMERR2=0
        ILINE=LNCNTR
        RETURN
      END IF
      END
C
      SUBROUTINE NSET1E(IXP,NPOLSH,IXTYPE,NINSET,IXM,IBYCHK)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C  IXPDIM is shared with RPOLSH, where it is hard-coded as 5 rather than
C  treated as an explicit parameter.
C
      PARAMETER (IXPDIM=5)
      PARAMETER (IXDIM=13)
      INTEGER IXP(IXPDIM,NPOLSH),IXTYPE(NINSET),IXM(IXDIM,*)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MIFLVL=7,IXFLLD=14-MIFLVL)
      PARAMETER (MAXFMT=20)
      PARAMETER (NOPTN1=3)
C
C  MVAR   represents the maximum number of incoming and created
C         variables, replicate factors and wts
C  MAXIDS is the maximum number of class variables
C  MRECOD is the maximum of variables transformed by CLASS, CAT
C         MISSING, SELECT, BY etc.
C  MRANGE is the maximum number of ranges
C  MRNSET is the maximum number of sets of ranges
C  MLEVEL is the maximum number of stored labels for levels
C  MCLBLK is the maximum number of class blocks
C  MCLBAR is the maximum number of cells of class block arrays
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      CHARACTER*160 FNWRK,LSTVPL
      CHARACTER*128 INFRMT(MAXFMT)
      COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1,
     . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX
C
      DOUBLE PRECISION RANGE(2,MRANGE)
      INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET),
     . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD),
     . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI)
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
      INTEGER VTMPSZ
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
      CHARACTER*256 CARDWK,CARDSV,CARDIM
      COMMON /CMBLK2/CARDWK,CARDSV,CARDIM
C
      PARAMETER (MAXSUB=500,MAXSBL=2000,MAXSNL=24)
      PARAMETER (MAXSBC=6000)
      PARAMETER (MAXALT=5)
      INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL),
     .   U5LCSW
      COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI,
     .   NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW
       LOGICAL REFRSH,ALPCHK,DGTCHK
      EXTERNAL REFRSH,ALPCHK,DGTCHK
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
C
C
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP,
     . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO,
     . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS,
     . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT,
     . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS,
     . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO,
     . NLEVEL,NRNSET,NRANGE,NHADAM,ISTEPC,IFLVL,IF1LST,IFLAST,NEWSYN,
     . MSDPTH,IXFILL
      INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS,
     . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN,
     . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IFLAST(MIFLVL),
     . IXFILL(IXFLLD)
C
      INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW,
     . OSCODE,NEWFNM
      COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE,
     .  ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM
      LOGICAL ICHECK
      EXTERNAL ICHECK
C
  244 FORMAT(' UNMATCHED CLASS: ',A12)
  245 FORMAT(' MUST BE CAT OR CLASS: ',A12)
  246 FORMAT(' SIZE MISMATCH: ',A12)
C
      VTMPSZ=MVAR-SVTEMP+1
      IPOLSH=1
    1 CONTINUE
C
C  Single variable
C
      IF(IXP(1,IPOLSH).EQ.21) THEN
        READ(16)CARD
        CALL VNMTCH(CARD(1:12),VNAME,NVIN,L)
        IF(L.EQ.0) THEN
          IMERR1=30108
          ILINE=IXP(4,IPOLSH)
          IMERR2=IXP(5,IPOLSH)
          RETURN
        ELSE
          CALL RINCR(4,NRECOD,1)
          RSTPNT(NRECOD)=0
          V3(NRECOD)=0
          V2(NRECOD)=0
          V1(NRECOD)=L
          IF(IPOLSH.EQ.1) THEN
            RCTYPE(NRECOD)=101
          ELSE
            IF(IXP(1,IPOLSH+1).GE.12.AND.IXP(1,IPOLSH+1).LE.16) THEN
              RCTYPE(NRECOD)=90+IXP(1,IPOLSH+1)
              IPOLSH=IPOLSH+1
            ELSE
              RCTYPE(NRECOD)=101
            END IF
          END IF
        END IF
      ELSE IF(IXP(1,IPOLSH).EQ.22) THEN
        CALL RINCR(4,NRECOD,1)
        RSTPNT(NRECOD)=0
        V3(NRECOD)=0
        V2(NRECOD)=0
        READ(16)CARD
        IPOS=1
        CALL DFIND(IPOS,IPOS2,DVALUE,DVAL2,1)
        V1(NRECOD)=NXPTD
        CALL ROOMD(1)
        DX(NXPTD-1)=DVALUE
        IF(IPOLSH.EQ.1) THEN
          RCTYPE(NRECOD)=111
        ELSE
          J=0
          IF(IXP(1,IPOLSH+1).GE.12.AND.IXP(1,IPOLSH+1).LE.16) THEN
            RCTYPE(NRECOD)=100+IXP(1,IPOLSH+1)
            IPOLSH=IPOLSH+1
            IF(IXP(1,IPOLSH).EQ.16) THEN
              IF(ICHECK(DVALUE,DVAL2)) THEN
                V1(NRECOD)=DVAL2
                IF(DVAL2.EQ.2.D0) THEN
                  RCTYPE(NRECOD)=119
                ELSE IF(DVALUE.GT.0.) THEN
                  RCTYPE(NRECOD)=117
                ELSE
                  RCTYPE(NRECOD)=118
                END IF
              ELSE
                RCTYPE(NRECOD)=116
              END IF
            END IF
          ELSE
            RCTYPE(NRECOD)=111
          END IF
        END IF
      ELSE IF(IXP(1,IPOLSH).EQ.23) THEN
C
C  {...}, which might have one of two interpretations:
C  as set or for .in. {  } construction.
C
        ISET=1
        IF(IPOLSH.LT.NPOLSH) THEN
          IF(IXP(1,IPOLSH+1).EQ.10) THEN
            ISET=0
          END IF
        END IF
        L=(IXP(3,IPOLSH)-1)/256+1
        REWIND(17)
        DO 4 I=1,L
        READ(16)CARD
        IF(I.EQ.L.AND.ISET.EQ.0) THEN
C
C  Insert a concluding ) for call to RNSCAN
C
          CALL LASTCR(ILAST)
          CARD(ILAST+1:ILAST+1)=')'
        END IF
        WRITE(17)CARD
    4   CONTINUE
        REWIND(17)
        U5=17
        READ(17)CARD
        IPOS=1
        CALL NBFND2(IPOS,IPT)
        IF(ISET.EQ.0) THEN
          CALL RINCR(4,NRECOD,1)
          V3(NRECOD)=0
          V2(NRECOD)=0
          CALL RCHECK(5,NRANGE,1)
          NRANG1=NRANGE+1
          CALL RINCR(6,NRNSET,1)
          RSTPNT(NRECOD)=NRNSET
          N1MAX=MRANGE-NRANGE
          RNGPNT(NRNSET)=NRANG1
          CALL RCHECK(7,NLEVEL,1)
          N1LEV=NLEVEL+1
          NL1MAX=MLEVEL-NLEVEL
          CALL RNSCAN(IPT,IPOS2,RANGE(1,NRANG1),N1MAX,RTYPE(NRANG1),
     .      RGROUP(NRANG1),NR,1,LEVEL(N1LEV),NL1MAX)
          NRNG(NRNSET)=NR
          CALL RINCR(5,NRANGE,NR)
          RCTYPE(NRECOD)=130
          V1(NRECOD)=0.
          IPOLSH=IPOLSH+1
        ELSE
          N=0
          IF(CARD(IPT:IPT).EQ.'*') THEN
            DO 5 I=1,NINSET
            CALL VNMTCH(VTEMP(SVTEMP+I-1-NINSET),VNAME,NVIN,L)
            IF(L.EQ.0) THEN
              IMERR1=30108
              ILINE=IXP(4,IPOLSH)
              IMERR2=IXP(5,IPOLSH)
              RETURN
            END IF
            CALL RINCR(4,NRECOD,1)
            RSTPNT(NRECOD)=0
            V3(NRECOD)=0
            V2(NRECOD)=0
            V1(NRECOD)=L
            RCTYPE(NRECOD)=101
            N=N+1
    5       CONTINUE
            IPT=IPT+1
          END IF
C
C  The control can return back to 6 to allow reading of a mixture of
C  variables and constants.
C
    6     CONTINUE
          CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,K,IPOS,2,VNAME,NVIN)
          CALL RFADD(VTEMP(SVTEMP),K,VTMPSZ,2,IXM,ISTATE)
          IF(K.GT.0) THEN
C                                                     ! { } contains
            DO 28 I=1,K
C                                                      ! variables
            CALL VNMTCH(VTEMP(SVTEMP+I-1),VNAME,NVIN,L)
            IF(L.EQ.0) THEN
              IF(ISTEPC.EQ.2) THEN
C                                                     ! If REWEIGHT
                KK=RCEIL(2)+1
                CALL VNMTCH(VTEMP(SVTEMP+I-1),VNAME(KK),NVREG,IV3)
                IF(IV3.GT.0) THEN
                  IF(K.NE.1.OR.N.NE.0) THEN
                    IMERR1=30107
                    RETURN
                  END IF
                  IF(IBYCHK.EQ.0.AND.NBY.GT.0) THEN
                    K=NBY+1
                    CALL RINCR(4,NRECOD,K)
                    J=NRECOD-K
C
C  If within an IF block, need to find top in order to place BY check
C  there.  Move intervening statements down.
C
                    IF(IXM(6,ISTATE).GT.0) THEN
                      DO 333 II=ISTATE,1,-1
                      IF(IXM(6,II).EQ.0) THEN
C                                                ! Find preceding
                        GO TO 334
C                                                ! statement at IF
                      END IF
C                                                ! level 0
  333                 CONTINUE
                      II=1
C                                                ! (Not expected)
  334                 CONTINUE
                      IF1LST=II
                      IF1LSN=IXM(10,IF1LST)
C                                                ! Start of matching
                      DO 44 KK=J,IF1LSN,-1
                      V1(KK+K)=V1(KK)
                      V2(KK+K)=V2(KK)
                      IF(RCTYPE(KK).EQ.36.OR.RCTYPE(KK).EQ.109) THEN
                        IF(V3(KK).GT.0) THEN
                          V3(KK+K)=V3(KK)+K
                        ELSE
                          V3(KK+K)=0
                        END IF
                      ELSE
                        V3(KK+K)=V3(KK)
                      END IF
                      RSTPNT(KK+K)=RSTPNT(KK)
                      RCTYPE(KK+K)=RCTYPE(KK)
   44                 CONTINUE
                      DO 39 II=IF1LST,ISTATE
                      IF(IXM(5,II).GE.5.AND.IXM(5,II).LE.7) THEN
                        IF(IXM(10,II).GT.0) THEN
                          IXM(10,II)=IXM(10,II)+K
                        END IF
                        IF(IXM(11,II).GT.0) THEN
                          IXM(11,II)=IXM(11,II)+K
                        END IF
                      END IF
   39                 CONTINUE
                      J=IF1LSN
                    ELSE
                      J=J+1
                    END IF
C
C  Placement of BY check
C
                    RCTYPE(J)=60
                    V1(J)=0
                    V2(J)=0
                    V3(J)=0
                    RSTPNT(J)=NBY
                    KK=RCEIL(2)+NVREG+NCLASS+NVARID
                    IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN
                      KK=KK-1
                    END IF
                    DO 46 K=1,NBY
                    KK=KK+1
                    CALL VNMTCH(VNAME(KK),VNAME,NVIN,BYLIST(K))
                    J=J+1
                    RCTYPE(J)=0
                    V1(J)=BYLIST(K)
                    V2(J)=0
                    V3(J)=0
                    RSTPNT(J)=K+NVARID
   46               CONTINUE
                    IBYCHK=1
                  END IF
                  CALL RINCR(4,NRECOD,1)
                  RSTPNT(NRECOD)=0
                  V3(NRECOD)=0
                  V2(NRECOD)=0
                  NRECSV=NRECOD
                  IV3=IV3+RCEIL(2)
                  V3(NRECSV)=IV3
                  K=MXSIZE(IV3)
                  RSTPNT(NRECOD)=BLNCLS(K)
                  IF(BLNCLS(K).GT.0) THEN
C                                                     ! Add instructions
                    INCX=BLXINC(K)
C                                                     ! to match on
                    ICLBAR=BLCPNT(K)
C                                                     ! class variables
                    DO 513 J=1,BLNCLS(K)
                    CALL RINCR(4,NRECOD,1)
                    RCTYPE(NRECOD)=0
                    V2(NRECOD)=0
                    IC=CLPNT(ICLBAR)+RCEIL(2)
                    CALL VNMTCH(VNAME(IC),VNAME,NVIN,JJ)
                    IF(JJ.EQ.0) THEN
                      WRITE(U6,244)VNAME(IC)
                      IMERR1=30108
                      RETURN
                    ELSE IF(MTYPE(JJ).NE.3.AND.MTYPE(JJ).NE.4) THEN
                      WRITE(U6,245)VNAME(JJ)
                      IMERR1=30105
                      RETURN
                    ELSE IF(MSIZE(JJ).NE.MSIZE(IC)) THEN
                      WRITE(U6,246)VNAME(JJ)
                      IMERR1=30106
                      RETURN
                    END IF
                    V1(NRECOD)=JJ
                    RSTPNT(NRECOD)=INCX
                    IF(CLTYPE(ICLBAR).EQ.1) THEN
                      V3(NRECOD)=0
                      INCX=INCX*MSIZE(JJ)
                    ELSE
                      V3(NRECOD)=1
                      INCX=INCX*(MSIZE(JJ)+1)
                    END IF
                    ICLBAR=ICLBAR+1
  513               CONTINUE
                  END IF
C                                          ! End of class specifications
                  K=BLNCLS(K)
                  DO 516 N=1,NINSET
                  IF(IXTYPE(N).LE.50) THEN
                    IF(N.EQ.1) THEN
                      RCTYPE(NRECSV)=250
                    ELSE
                      J=K+1
                      JJ=NRECOD
                      CALL RINCR(4,NRECOD,J)
                      DO 514 L=1,J
                      RCTYPE(JJ+L)=RCTYPE(NRECSV+L-1)
                      V1(JJ+L)=V1(NRECSV+L-1)
                      V2(JJ+L)=V2(NRECSV+L-1)
                      V3(JJ+L)=V3(NRECSV+L-1)
                      RSTPNT(JJ+L)=RSTPNT(NRECSV+L-1)
  514                 CONTINUE
                      RCTYPE(JJ+1)=250
                    END IF
                  ELSE
                    IF(N.EQ.1) THEN
                      RCTYPE(NRECSV)=254
                      V1(NRECSV)=IXTYPE(N)-50
                      V2(NRECSV)=1
                    ELSE IF(IXTYPE(N).EQ.IXTYPE(N-1)+1.AND.
     .                      IXTYPE(N).GT.51) THEN
                      V2(NRECOD-K)=V2(NRECOD-K)+1
                    ELSE
                      J=K+1
                      JJ=NRECOD
                      CALL RINCR(4,NRECOD,J)
                      DO 515 L=1,J
                      RCTYPE(JJ+L)=RCTYPE(NRECSV+L-1)
                      V1(JJ+L)=V1(NRECSV+L-1)
                      V2(JJ+L)=V2(NRECSV+L-1)
                      V3(JJ+L)=V3(NRECSV+L-1)
                      RSTPNT(JJ+L)=RSTPNT(NRECSV+L-1)
  515                 CONTINUE
                      RCTYPE(JJ+1)=254
                      V1(JJ+1)=IXTYPE(N)-50
                      V2(JJ+1)=1
                    END IF
                  END IF
  516             CONTINUE
                  N=NINSET
                  GO TO 31
C                                          ! Transfer to final check
                END IF
              END IF
              IMERR1=30108
C                                          ! Error message if not
              ILINE=IXP(4,IPOLSH)
C                                          ! matched
              IMERR2=IXP(5,IPOLSH)
              RETURN
            END IF
            N=N+1
C                                               ! Variable found
            IF(MTYPE(L).GT.51.AND.I.GT.1) THEN
C                                               ! Check whether should
              IF(MTYPE(L).EQ.MTYPEL+1) THEN
C                                               ! extend load of
                V2(NRECOD)=V2(NRECOD)+1
C                                               ! REPW* / REPF*
                MTYPEL=MTYPE(L)
                GO TO 28
              END IF
            END IF
            CALL RINCR(4,NRECOD,1)
C                                          ! If beyond N=1
            RSTPNT(NRECOD)=0
C                                          ! must increment NRECOD
            V3(NRECOD)=0
            V2(NRECOD)=0
            MTYPEL=MTYPE(L)
            IF(MTYPE(L).GT.50) THEN
C                                          ! Load of REPW* /REPF*
              RCTYPE(NRECOD)=256
              V1(NRECOD)=L
              V2(NRECOD)=1
            ELSE
              V1(NRECOD)=L
              RCTYPE(NRECOD)=101
            END IF
   28       CONTINUE
            IF(IPOS.GT.0) THEN
C                                          ! Check for further contents
              IPT=IPOS
C                                          ! (probably constants)
              GO TO 6
            END IF
          ELSE IF(U5END.EQ.0.AND.IPT.GT.0) THEN
C                                                 ! If no valid variable
            L=SIZED-NXPTD+1
C                                                 ! names, look for
            CALL DASCAN(IPT,IPOS,DX(NXPTD),L,K)
C                                                 ! constants
            IF(K.GT.0) THEN
              DO 30 I=1,K
              CALL RINCR(4,NRECOD,1)
              RSTPNT(NRECOD)=0
              V3(NRECOD)=0
              V2(NRECOD)=0
              V1(NRECOD)=NXPTD
              CALL ROOMD(1)
              RCTYPE(NRECOD)=111
              N=N+1
   30         CONTINUE
              CALL ROOMD(K)
              IF(IPOS.GT.0) THEN
                CALL NBFND2(IPOS,IPT)
                IF(IPT.GT.0) THEN
                  GO TO 6
                END IF
              END IF
            END IF
          END IF
   31     CONTINUE
          IF(N.NE.NINSET) THEN
C                                         ! Review applied to all { }
C           write(*,*)n,ninset            ! Check for right #
            IMERR1=30104
            ILINE=IXP(4,IPOLSH)
            IMERR2=IXP(5,IPOLSH)
            RETURN
          END IF
        END IF
        U5END=0
      ELSE
        CALL RINCR(4,NRECOD,1)
        RSTPNT(NRECOD)=0
        V3(NRECOD)=0
        V2(NRECOD)=0
        IF(IXP(1,IPOLSH).GE.1.AND.IXP(1,IPOLSH).LE.16) THEN
          RCTYPE(NRECOD)=120+IXP(1,IPOLSH)
        ELSE IF(IXP(1,IPOLSH).EQ.20) THEN
          RCTYPE(NRECOD)=140
          V1(NRECOD)=IXP(2,IPOLSH)
        ELSE IF(IXP(1,IPOLSH).EQ.24) THEN
          RCTYPE(NRECOD)=141
          V1(NRECOD)=IXP(2,IPOLSH)
          V2(NRECOD)=NINSET
        ELSE IF(IXP(1,IPOLSH).EQ.25) THEN
          L=(IXP(3,IPOLSH)-1)/256+1
          REWIND(17)
          DO 32 I=1,L
          READ(16)CARD
          WRITE(17)CARD
   32     CONTINUE
          REWIND(17)
          U5=17
          READ(17)CARD
          IPOS=1
          CALL VNFIND(IPOS,VTEMP(SVTEMP),VTMPSZ,N,IPOS,2,VNAME,NVIN)
          IF(N.GT.0) THEN
            RCTYPE(NRECOD)=142
            RSTPNT(NRECOD)=N
            V1(NRECOD)=0
            DO 34 I=1,N
            CALL VNMTCH(VTEMP(SVTEMP+I-1),VNAME,NVIN,L)
            IF(L.EQ.0) THEN
              IMERR1=30108
              ILINE=IXP(4,IPOLSH)
              IMERR2=IXP(5,IPOLSH)
              RETURN
            END IF
            CALL RINCR(4,NRECOD,1)
C           for each key:
C               0      match v    pointer to   var # of match v
C                                 last value
C
            RSTPNT(NRECOD)=L
            V3(NRECOD)=NXPTD
            V2(NRECOD)=L
            V1(NRECOD)=0
            CALL ROOMD(1)
            DX(NXPTD-1)=-98765.432109D0  ! 1/1/99 Store initial value
   34       CONTINUE
          END IF
          U5END=0
        ELSE IF(IXP(1,IPOLSH).GT.300) THEN
          RCTYPE(NRECOD)=IXP(1,IPOLSH)-90
          V2(NRECOD)=NINSET
        ELSE IF(IXP(1,IPOLSH).GT.200) THEN
          RCTYPE(NRECOD)=IXP(1,IPOLSH)
          V2(NRECOD)=NINSET
        ELSE IF(IXP(1,IPOLSH).GT.100) THEN
          RCTYPE(NRECOD)=IXP(1,IPOLSH)+90
          V2(NRECOD)=NINSET
        END IF
      END IF
C     write(*,*)rctype(nrecod),v1(nrecod)
      IPOLSH=IPOLSH+1
      IF(IPOLSH.LE.NPOLSH) GO TO 1
      U5=15
      RETURN
      END
C
      SUBROUTINE VNCHCK(VNAMEA,NVNAME)
      INTEGER NVNAME
      CHARACTER *12 VNAMEA(NVNAME)
      PARAMETER (NXLIST=24)
      CHARACTER *12 XLIST(NXLIST)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
      DATA (XLIST(I),I=1,NXLIST)/
     . 'AS          ','BLOCK       ','BY          ','CLASS       ',
     . 'FOR         ','IF          ','INTO        ','KEY         ',
     . 'MEAN        ','MEANS       ','N           ','OPTION      ',
     . 'OPTIONS     ','PERCENT     ','PERCENTS    ','PERCENT1    ',
     . 'PERCENT2    ','PROPORTION  ','PROPORTIONS ','PROPORTION1 ',
     . 'THEN        ','TOTAL       ','TOTALS      ','TOTAL1      '/
C
  200 FORMAT(' Variable name not allowed: ',A12)
C
      DO 10 I=1,NVNAME
      DO 5 J=1,NXLIST
      CALL CMATCH(VNAMEA(I),1,12,XLIST(J),12,IPOS,1)
      IF(IPOS.GT.0) THEN
        WRITE(U6,200)VNAMEA(I)
        IMERR1=160250
        RETURN
      END IF
    5 CONTINUE
   10 CONTINUE
      RETURN
      END
C
      SUBROUTINE VNCHK2(VNAMEA,NVNAME,IXM,LNMAP)
      PARAMETER (IXDIM=13)
      INTEGER IXM(IXDIM,*),LNMAP(*)
      INTEGER NVNAME
      CHARACTER *12 VNAMEA(NVNAME)
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MIFLVL=7,IXFLLD=13-MIFLVL)
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP,
     . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO,
     . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS,
     . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT,
     . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS,
     . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO,
     . NLEVEL,NRNSET,NRANGE,NHADAM,ISTEPC,IFLVL,IF1LST,IFLAST,NEWSYN,
     . IXFILL,SDSTCK,MSDPTH
      INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS,
     . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN,
     . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IFLAST(MIFLVL),
     . IXFILL(IXFLLD),SDSTCK,MSDPTH
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
C
  200 FORMAT(' Variable name on VPLX file: ',A12)
      CALL VNCHCK(VNAMEA,NVNAME)
      IF(IMERR1.GT.0) THEN
        CALL CMPRNT(IXM,LNMAP)
      END IF
      IF(ISTEPC.EQ.2.AND.NVREG.GT.0) THEN
        K=RCEIL(2)+1
        DO 10 I=1,NVNAME
        CALL VNMTCH(VNAMEA(I),VNAME(K),NVREG,IV3)
        IF(IV3.GT.0) THEN
          WRITE(U6,200)VNAMEA(I)
          IMERR1=160251
          CALL CMPRNT(IXM,LNMAP)
        END IF
   10   CONTINUE
      END IF
      RETURN
      END
 
C
C  End of CAN.for
C
      SUBROUTINE NSET1B(IGROUP,IKEY,IPT,VTMPSZ,ICWRNT,IPOS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MIFLVL=7,IXFLLD=15-MIFLVL)
      PARAMETER (MAXFMT=20)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
      INTEGER VTMPSZ
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
      LOGICAL REFRSH,ALPCHK,DGTCHK
      EXTERNAL REFRSH,ALPCHK,DGTCHK
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1,
     . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX
C
      DOUBLE PRECISION RANGE(2,MRANGE)
      INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET),
     . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD),
     . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI)
C
      COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP,
     . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO,
     . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS,
     . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT,
     . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS,
     . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO,
     . NLEVEL,NRNSET,NRANGE,NHADAM,ISTEPC,IFLVL,IF1LST,IFLAST,NEWSYN,
     . IXFILL
      INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS,
     . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN,
     . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IFLAST(MIFLVL),
     . IXFILL(IXFLLD)
C
  205 FORMAT(' UNRECOGNIZED VARIABLE NAME ',A12)
C 221 FORMAT(5X,'WARNING: OPERATIONS TO CAT OR CROSSED VAR')
C
C  Contents of MTYPE, codes for transformations
C     1  =  real variable
C     2  =  real variable with missing checks
C     3  =  categorical variable
C     4  =  class variable, known dimension
C     5  =  by variable, known dimension
C     6  =  by variable, unknown dimension
C     7  =  select transformation (not variable type)
C     8  =  cross variable, real value
C     9  =  cross variable, categorical
C    10  =  copy (not variable type)
C    21  =  boolean                 "
C    22  =  boolean - no range      "
C    23  =  and (logical and)       "
C    24  =  or                      "
C    25  =  not                     "
C    26  =  add_ms                  "
C    27  =  subtract_ms             "
C    28  =  multiply_ms             "
C    29  =  divide_ms               "
C    30  =  add                     "
C    31  =  subtract                "
C    32  =  multiply                "
C    33  =  divide                  "
C    34  =  constants               "
C    35  =  if (else if)            "
C    36  =  go to                   "
C    40  =  initial read
C    41  =  input (link)
C    42  =  input with missing (link_missing)
C               v1        v2        v3        rstpnt
C             iuinpt    status   # input      # keys
C             1st v    start x   start fmt    # fmt
C             # print   #obs
C             key x    match v   last key     var # of match v
C    43  =  add loop to replicate weights/factors
C               v1        v2        v3        rstpnt
C             1st rf/rw  # rf/rw   var
C    44  =  subtract loop to replicate weights/factors
C    45  =  multiply loop            "
C    46  =  divide   loop            "
C    47  =  output
C
C  50-60 are during REWEIGHT only
C
C    50  =  add, 0 replicate,      using vplxin data
C               v1        v2        v3        rstpnt
C             1st op   target   vplxin v     #classes
C          for each class:
C               v1        v2        v3        rstpnt
C            class/cat           0 offset    increment
C
C    51  =  subtract, 0 replicate   using vplxin data
C    52  =  multiply, 0 replicate       "
C    53  =  divide, 0 replicate         "
C    54  =  add loop to replicate weights/factors, using vplxin
C               v1        v2        v3        rstpnt
C             1st rf/rw  # rf/rw  vplxin var  #classes
C          for each class:
C               v1        v2        v3        rstpnt
C            class/cat           0 offset    increment
C
C    55  =  subtract loop to replicate weights/factors, using vplxin
C    56  =  multiply loop            "                       "
C    57  =  divide   loop            "                       "
C
C    58  =  define repf based on var ids
C               v1        v2        v3       rstpnt
C            1st rf/rw  # rf/rw     wt      #var ids
C          for each id:
C               v1        v2        v3       rstpnt
C            variance id
C          for repw, v3 will give id of weight
C    60  =  check BY variables
C               v1        v2        v3       rstpnt
C                                           #BY vars
C          for each BY var:
C               v1        v2        v3       rstpnt
C              BY id                       loc in vid
C
C    61  =  define repf based on rows of Hadamard matrix and
C           coefficients
C               v1        v2        v3       rstpnt
C            1st rf/rw  # rf/rw     wt       #sets
C          for each set:
C               v1        v2        v3       rstpnt
C              row     coefficient
C          for repw, v3 will give id of weight
C
      ICWRNT=0
      IRC=0
      CALL NBFND2(IPT,IPT2)
      IF(IGROUP.EQ.2) THEN
        IF(IKEY.EQ.1) THEN
          IRC=4
        ELSE IF(IKEY.EQ.2) THEN
          IRC=3
        ELSE IF(IKEY.EQ.3) THEN
C
C  MISSING
C
          IRC=2
        END IF
      ELSE IF(IGROUP.EQ.7) THEN
        IF(IKEY.EQ.1) THEN
C
C  SELECT
C
          IRC=7
        END IF
      END IF
      CALL VNFIND(IPT2,VTEMP(SVTEMP),VTMPSZ,N,IPOS,2,VNAME,NVIN)
      IF(N.LE.0) THEN
        IMERR2=IPOS
        IF(IGROUP.EQ.2) THEN
          IF(IKEY.EQ.1) THEN
C
C  CLASS
C
            IMERR1=30050
          ELSE IF(IKEY.EQ.2) THEN
C
C  CATEGORICAL/CAT
C
            IMERR1=30051
          ELSE IF(IKEY.EQ.3) THEN
C
C  MISSING
C
            IMERR1=30052
          END IF
        ELSE IF(IGROUP.EQ.7) THEN
          IF(IKEY.EQ.1) THEN
C
C  SELECT
C
            IMERR1=30053
          END IF
        END IF
        IMERR2=IPOS
        RETURN
      END IF
C
C  All cases should have a range specification in the new
C  syntax.
C
      CALL NBFND2(IPOS,IPOS2)
C
      IF(IRC.EQ.2.OR.IRC.EQ.7) THEN
C
C  In anticipation of error, set IMERR1 here, and then
C  reset to 0 if OK
C
        IF(IRC.EQ.2) THEN
          IMERR1=30055
        ELSE
          IMERR1=30054
        END IF
C
        IF(CARD(IPOS2:IPOS2).EQ.'.') THEN
C
C  Look for .IN. with SELECT and MISSING
C
          IPOS=IPOS2+1
          CALL NBFND2(IPOS,IPOS2)
          CALL CMATCH(CARD(IPOS2:256),IPOS2,256,'IN',2,IPOS,1)
          IF(IPOS.GT.0) THEN
            CALL NBFND2(IPOS,IPOS2)
            IF(CARD(IPOS2:IPOS2).EQ.'.') THEN
              IPOS=IPOS2+1
              CALL NBFND2(IPOS,IPOS2)
              IF(CARD(IPOS2:IPOS2).EQ.'{') THEN
                IPOS2=IPOS2+1
                CALL NBFND2(IPOS2,IPOS)
                IMERR1=0
C
C  IPOS will be the first nonblank position beyond '{'
C
              ELSE
                IMERR2=IPOS2
                RETURN
              END IF
            ELSE
              IMERR2=IPOS2
              RETURN
            END IF
          ELSE
            IMERR2=IPOS2
            RETURN
          END IF
        ELSE
          IMERR2=IPOS2
          RETURN
        END IF
      ELSE
C
C  For CLASS, CAT, expect ( / / /) syntax
C
        IF(CARD(IPOS2:IPOS2).NE.'(') THEN
          IMERR1=30056
          IMERR2=IPOS2
          RETURN
        END IF
        IPOS2=IPOS2+1
        CALL NBFND2(IPOS2,IPOS)
      END IF
      CALL RCHECK(5,NRANGE,1)
      NRANG1=NRANGE+1
      CALL RINCR(6,NRNSET,1)
      N1MAX=MRANGE-NRANGE
      RNGPNT(NRNSET)=NRANG1
      CALL RCHECK(7,NLEVEL,1)
      N1LEV=NLEVEL+1
      NL1MAX=MLEVEL-NLEVEL
      CALL RNSCAN(IPOS,IPOS2,RANGE(1,NRANG1),N1MAX,RTYPE(NRANG1),
     .    RGROUP(NRANG1),NR,1,LEVEL(N1LEV),NL1MAX)
      IPOS=IPOS2-1
      IF(IRC.EQ.2.OR.IRC.EQ.7) THEN
        IF(CARD(IPOS:IPOS).NE.'}') THEN
          IF(IRC.EQ.2) THEN
            IMERR1=30055
          ELSE
            IMERR1=30054
          END IF
          IMERR2=IPOS
          RETURN
        END IF
      ELSE
        IF(CARD(IPOS:IPOS).NE.')') THEN
          IMERR1=30056
          IMERR2=IPOS
          RETURN
        END IF
      END IF
C
      IF(NR.LE.0) THEN
        IF(IRC.EQ.2.OR.IRC.EQ.7) THEN
          IMERR1=30057
        ELSE
          IMERR1=30058
        END IF
        IMERR2=IPOS
        RETURN
      END IF
C
      IPOS2=IPOS+1
      CALL NBFND2(IPOS2,IPOS)
      NRNG(NRNSET)=NR
      CALL RINCR(5,NRANGE,NR)
C
C  For CAT and CLASS, set up labels.
C
      IF(IRC.EQ.3.OR.IRC.EQ.4) THEN
        CALL RINCR(7,NLEVEL,RGROUP(NRANGE))
        CALL LEVELR(IPOS,IPOS2,NL,LEVEL(N1LEV),RGROUP(NRANGE))
        IPOS=IPOS2
        IF(CARD(IPOS:IPOS).NE.';') THEN
          IMERR1=30067
          IMERR2=IPOS
          RETURN
        END IF
C
C  At this point, insure CAT and CLASS do not fall
C  within an IF block.  In the future, move these tests to
C  an initial review of the overall program flow to be carried
C  out in NSETP1
C
        IF(IFLVL.GT.0) THEN
          IMERR1=30059
          RETURN
        END IF
      END IF
C
C  IFOR  - marks appearance of 'FOR' or 'IF'
C  IINTO - marks appearance of 'INTO'
C
      CALL VNMTCH('FOR ',VTEMP(SVTEMP),N,IFOR)
      IF(IFOR.EQ.0) THEN
        CALL VNMTCH('IF ',VTEMP(SVTEMP),N,IFOR)
        IIF=IFOR
      ELSE
        IIF=0
      END IF
      CALL VNMTCH('INTO ',VTEMP(SVTEMP),N,IINTO)
C
C  Determine:
C  IS1 - the position in the list to begin reading the
C        variables
C  N1  - the ending position.
C
      IS1=1
      IF(IINTO.GT.0) THEN
        N1=IINTO-1
        I2=IINTO+1
        IF(IFOR.GT.0) THEN
          IF(IFOR.EQ.N-1) THEN
            IF(N1+IINTO+2.NE.N) THEN
              IMERR1=30060
            END IF
          ELSE
            IF(N1+IINTO+1.NE.IFOR) THEN
              IMERR1=30060
            ELSE IF(IFOR+N1.NE.N) THEN
              IF(IIF.GT.0) THEN
                IMERR1=30062
              ELSE
                IMERR1=30061
              END IF
            END IF
          END IF
        ELSE
          IF(N1+IINTO.NE.N) THEN
            IMERR1=30060
          END IF
        END IF
      ELSE IF(IFOR.EQ.1.AND.IRC.EQ.7) THEN
        IS1=2
        N1=N
        I2=2
      ELSE IF(IFOR.GT.0) THEN
        N1=IFOR-1
        I2=1
        IF(IFOR.NE.N-1) THEN
          IF(IFOR+N1.NE.N) THEN
            IF(IIF.GT.0) THEN
              IMERR1=30062
            ELSE
              IMERR1=30061
            END IF
          END IF
        END IF
      ELSE
        N1=N
        I2=1
      END IF
      IF(IMERR1.GT.0) THEN
        RETURN
      END IF
      IFOR=IFOR+1
C
      DO 18 I=IS1,N1
      CALL VNMTCH(VTEMP(I+SVTEMP-1),VNAME,NVIN,IV1)
      CALL VNMTCH(VTEMP(I2+SVTEMP-1),VNAME,NVIN,IV2)
      CALL VNMTCH(VTEMP(IFOR+SVTEMP-1),VNAME,NVIN,IV3)
      IF(IV1.EQ.0) THEN
        WRITE(U6,205)VTEMP(I+SVTEMP-1)
        IMERR1=30063
        RETURN
      END IF
      IF(IV3.EQ.0) THEN
        WRITE(U6,205)VTEMP(IFOR+SVTEMP-1)
        IMERR1=30063
        RETURN
      END IF
      IF(IFOR.LT.N)IFOR=IFOR+1
      IF(IV2.EQ.0) THEN
        CALL RINCR(2,NVIN,1)
        VNAME(NVIN)=VTEMP(I2+SVTEMP-1)
        CALL VNCHK2(VNAME(NVIN),1,IXM,LNMAP)
        LABEL(NVIN)(1:12)=VNAME(NVIN)
        LABEL(NVIN)(13:24)='            '
        IV2=NVIN
        CALL RFCHCK(1)
        IF(IMERR1.GT.0) THEN
          CALL CMPRNT(IXM,LNMAP)
        END IF
        IF(MTYPE(IV2).GE.50) THEN
          IMERR1=30064
          RETURN
        END IF
C
C  Future - move this checking to insure CLASS, CAT, and SELECT
C  are not used within an IF block to the general review to be
C  done in NSETP1.
C
        IF(IFLVL.GT.0) THEN
          IF(IKEY.EQ.10) THEN
            MTSTRT(NVIN)=2
            MTYPE(NVIN)=2
          ELSE
            IMERR1=30065
            RETURN
          END IF
        END IF
      END IF
      MTSAVE=MTYPE(IV2)
      MT1=MTYPE(IV1)
      IF(MT1.GE.50)MT1=1
      IF(MT1.EQ.3.OR.MT1.EQ.4.OR.MT1.EQ.8.OR.MT1.EQ.9) THEN
        ICWARN=ICWARN+1
        ICWRNT=ICWRNT+1
      END IF
C
      CALL RINCR(4,NRECOD,1)
      RSTPNT(NRECOD)=NRNSET
      RCTYPE(NRECOD)=IRC
      V1(NRECOD)=IV1
      V2(NRECOD)=IV2
      IF(IRC.EQ.7) THEN
        V3(NRECOD)=NCLBLK
      ELSE
        V3(NRECOD)=IV3
      END IF
      IF(IRC.EQ.2) THEN
        IF(MTYPE(IV1).EQ.1) THEN
          MSIZE(IV2)=2
          MTYPE(IV2)=2
        ELSE
          MSIZE(IV2)=MSIZE(IV1)
          MTYPE(IV2)=MTYPE(IV1)
        END IF
      ELSE IF(IRC.LE.4) THEN
        MSIZE(IV2)=RGROUP(NRANGE)
        LPOINT(IV2)=N1LEV
        MTYPE(IV2)=IRC
      END IF
C
C  Check that type not changed if inside IF block.
C
      IF(IFLVL.GT.0.AND.MTSAVE.NE.MTYPE(IV2)) THEN
        IMERR1=30066
        RETURN
      END IF
      IF(MXSIZE(IV2).LT.MSIZE(IV2))MXSIZE(IV2)=MSIZE(IV2)
      IF(IRC.EQ.4.AND.ISTEPC.EQ.1.AND.NEWSYN.NE.1) THEN
        BLNCLS(NCLBLK)=BLNCLS(NCLBLK)+1
        CALL RINCR(9,NCLBAR,1)
        IF(BLCPNT(NCLBLK).EQ.0)BLCPNT(NCLBLK)=NCLBAR
        CLTYPE(NCLBAR)=IV2
      END IF
      I2=I2+1
   18 CONTINUE
C
C  Future: handle warning messages.
C
C     IF(ICWRNT.GT.0.AND.U5ECHO.EQ.1)WRITE(U6,221)
C
      RETURN
      END
C
      SUBROUTINE NSET1C(IKEY,IPT,VTMPSZ,IBYCHK,IXM,ISTATE)
      PARAMETER (IXDIM=13)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSIZED=1000000)
      PARAMETER (MSIZEI=100000)
      PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500)
      PARAMETER (MCLBLK=200,MCLBAR=1000)
      PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10)
      PARAMETER (MIFLVL=7,IXFLLD=15-MIFLVL)
      PARAMETER (MAXFMT=20)
C
      DOUBLE PRECISION DX(MSIZED)
      COMMON /DBLOCK/DX
      INTEGER SIZED,RCEIL(13)
      COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL
C
      INTEGER U5,U6,U5END,U5ECHO
      COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3
C
      CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR)
      CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL)
      COMMON /VNBLCK/VNAME,VTEMP,VNKEEP
      COMMON /VLBLCK/LABEL,LEVEL
      INTEGER VTMPSZ
C
      CHARACTER*256 CARD
      COMMON /CRDBLK/CARD
C
      LOGICAL REFRSH,ALPCHK,DGTCHK
      EXTERNAL REFRSH,ALPCHK,DGTCHK
C
      COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT,
     . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP,
     . SDBYID,NRPTOT,SDCOEF,SVTEMP,
     . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE,
     . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT
      INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP
      INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK),
     . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK),
     . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR)
      INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD),
     .  CDMPNT(MVAR),LPOINT(MVAR)
C
      COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1,
     . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX
C
      DOUBLE PRECISION RANGE(2,MRANGE)
      INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET),
     . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD),
     . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI)
C
      COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP,
     . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO,
     . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS,
     . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT,
     . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS,
     . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO,
     . NLEVEL,NRNSET,NRANGE,NHADAM,ISTEPC,IFLVL,IF1LST,IFLAST,NEWSYN,
     . IXFILL
      INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS,
     . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN,
     . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IFLAST(MIFLVL),
     . IXFILL(IXFLLD)
C
      INTEGER SVTMP2
C
  200 FORMAT(' ERROR IN SPECIFICATION')
  205 FORMAT(' UNRECOGNIZED VARIABLE NAME ',A12)
  210 FORMAT(' BY missing or unbalanced numbers of variables')
  211 FORMAT(' THIS VARIABLE IS NOT OF TYPE CLASS OR CATEGORICAL - ',A12
     .)
  212 FORMAT(' VARIABLE OF INAPPROPRIATE TYPE - ',A12)
  222 FORMAT(5X,'FOR REAL, REAL WITH MISSING, OR CROSSED REAL ONLY')
  233 FORMAT(5X,'Not permitted within if block')
  237 FORMAT(' NOT ALLOWED ON REPLICATE WEIGHT/FACTOR')
  243 FORMAT(' VPLXIN VAR. MUST BE REAL OR DERIVED')
  244 FORMAT(' UNMATCHED CLASS: ',A12)
  245 FORMAT(' MUST BE CAT OR CLASS: ',A12)
  246 FORMAT(' SIZE MISMATCH: ',A12)
  248 FORMAT(' UNMATCHED BY VAR: ',A12)
  249 FORMAT(5X,'Link to BY variables here')
  250 FORMAT(/,5X,'WARNING: Link to BY variables moved to start of level
     . 1 IF BLOCK')
C
C  Contents of MTYPE, codes for transformations
C     1  =  real variable
C     2  =  real variable with missing checks
C     3  =  categorical variable
C     4  =  class variable, known dimension
C     5  =  by variable, known dimension
C     6  =  by variable, unknown dimension
C     7  =  select transformation (not variable type)
C     8  =  cross variable, real value
C     9  =  cross variable, categorical
C    10  =  copy (not variable type)
C    21  =  boolean                 "
C    22  =  boolean - no range      "
C    23  =  and (logical and)       "
C    24  =  or                      "
C    25  =  not                     "
C    26  =  add_ms                  "
C    27  =  subtract_ms             "
C    28  =  multiply_ms             "
C    29  =  divide_ms               "
C    30  =  add                     "
C    31  =  subtract                "
C    32  =  multiply                "
C    33  =  divide                  "
C    34  =  constants               "
C    35  =  if (else if)            "
C    36  =  go to                   "
C    40  =  initial read
C    41  =  input (link)
C    42  =  input with missing (link_missing)
C               v1        v2        v3        rstpnt
C             iuinpt    status   # input      # keys
C             1st v    start x   start fmt    # fmt
C             # print   #obs
C             key x    match v   last key     var # of match v
C    43  =  add loop to replicate weights/factors
C               v1        v2        v3        rstpnt
C             1st rf/rw  # rf/rw   var
C    44  =  subtract loop to replicate weights/factors
C    45  =  multiply loop            "
C    46  =  divide   loop            "
C    47  =  output
C
C  50-60 are during REWEIGHT only
C
C    50  =  add, 0 replicate,      using vplxin data
C               v1        v2        v3        rstpnt
C             1st op   target   vplxin v     #classes
C          for each class:
C               v1        v2        v3        rstpnt
C            class/cat           0 offset    increment
C
C    51  =  subtract, 0 replicate   using vplxin data
C    52  =  multiply, 0 replicate       "
C    53  =  divide, 0 replicate         "
C    54  =  add loop to replicate weights/factors, using vplxin
C               v1        v2        v3        rstpnt
C             1st rf/rw  # rf/rw  vplxin var  #classes
C          for each class:
C               v1        v2        v3        rstpnt
C            class/cat           0 offset    increment
C
C    55  =  subtract loop to replicate weights/factors, using vplxin
C    56  =  multiply loop            "                       "
C    57  =  divide   loop            "                       "
C
C    58  =  define repf based on var ids
C               v1        v2        v3       rstpnt
C            1st rf/rw  # rf/rw     wt      #var ids
C          for each id:
C               v1        v2        v3       rstpnt
C            variance id
C          for repw, v3 will give id of weight
C    60  =  check BY variables
C               v1        v2        v3       rstpnt
C                                           #BY vars
C          for each BY var:
C               v1        v2        v3       rstpnt
C              BY id                       loc in vid
C
C    61  =  define repf based on rows of Hadamard matrix and
C           coefficients
C               v1        v2        v3       rstpnt
C            1st rf/rw  # rf/rw     wt       #sets
C          for each set:
C               v1        v2        v3       rstpnt
C              row     coefficient
C          for repw, v3 will give id of weight
C
C
C    62  =  idchange to return 1 if change in variables
C               v1        v2        v3        rstpnt
C               0     idchange       0         # keys
C           for each key:
C               0     match v    pointer to   var # of match v
C                                 last value
C
      IRC=0
      CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,N,IPOS,2,VNAME,NVIN)
      IF(N.LE.0)GO TO 95
      CALL RFADD(VTEMP(SVTEMP),N,VTMPSZ,2,IXM,ISTATE)
      IF(IKEY.EQ.96) THEN
        IF(N.LE.1)GO TO 95
        CALL VNMTCH('ADD ',VTEMP(SVTEMP),1,IBY)
        IF(IBY.NE.0) THEN
          IRC=30
        ELSE
          CALL VNMTCH('SUBTRACT ',VTEMP(SVTEMP),1,IBY)
          IF(IBY.NE.0) THEN
            IRC=31
          ELSE
            CALL VNMTCH('MULTIPLY ',VTEMP(SVTEMP),1,IBY)
            IF(IBY.NE.0) THEN
              IRC=32
            ELSE
              CALL VNMTCH('DIVIDE ',VTEMP(SVTEMP),1,IBY)
              IF(IBY.NE.0) THEN
                IRC=33
              ELSE
                GO TO 95
              END IF
            END IF
          END IF
        END IF
        N=N-1
        K=SVTEMP
      ELSE
        K=SVTEMP-1
        IF(IKEY.GE.100.AND.IKEY.LE.103) THEN
          IRC=IKEY-74
        ELSE IF(IKEY.GE.69.AND.IKEY.LE.72) THEN
          IRC=IKEY-39
        ELSE IF(IKEY.EQ.93) THEN
          IRC=23
        ELSE IF(IKEY.EQ.94) THEN
          IRC=24
        ELSE IF(IKEY.EQ.32) THEN
          IRC=62
        END IF
      END IF
      SVTMP2=MVAR-N+1
      DO 32 I=1,N
      VTEMP(SVTMP2+I-1)=VTEMP(K+I)
   32 CONTINUE
      CALL VNMTCH('BY ',VTEMP(SVTMP2),N,IBY)
      IF(IBY.EQ.0) THEN
        IF(IRC.EQ.26.OR.IRC.EQ.30) THEN
          CALL VNMTCH('PLUS ',VTEMP(SVTMP2),N,IBY)
        ELSE IF(IRC.EQ.27.OR.IRC.EQ.31) THEN
          CALL VNMTCH('MINUS ',VTEMP(SVTMP2),N,IBY)
        ELSE IF(IKEY.EQ.93.OR.IKEY.EQ.94) THEN
          CALL VNMTCH('WITH ',VTEMP(SVTMP2),N,IBY)
        END IF
      END IF
      CALL VNMTCH('INTO ',VTEMP(SVTMP2),N,IINTO)
      IF(IRC.EQ.62) THEN
        IF(IINTO.NE.N-1.OR.IBY.GT.0)GO TO 95
      END IF
      N1=IBY-1
      NOUT=N1
      IF(IINTO.GT.0) THEN
        IF(IBY.EQ.0) THEN
          IF(IINTO.EQ.N-1.AND.(IRC.EQ.26.OR.IRC.EQ.28.OR.
     .       IKEY.EQ.93.OR.IKEY.EQ.94.OR.IRC.EQ.62.OR.
     .       IRC.EQ.30.OR.IRC.EQ.32)) THEN
            I2=N
            IF(IRC.EQ.62) THEN
              NOUT=1
            ELSE
              NOUT=IINTO-2
            END IF
            IBY=1
            I1INC=1
            I3INC=1
          ELSE
            WRITE(U6,210)
            GO TO 99
          END IF
        ELSE
          IF((IINTO-IBY.EQ.2.AND.N1.NE.N-IINTO).OR.
     .       (N1.EQ.1.AND.IINTO-IBY-1.NE.N-IINTO).OR.
     .       (N1.NE.1.AND.IINTO-IBY.NE.2.AND.
     .       (N1.NE.IINTO-IBY-1.OR.N1.NE.N-IINTO))) THEN
            WRITE(U6,210)
            GO TO 99
          END IF
          IF(N1.EQ.1) THEN
            I1INC=0
            NOUT=N-IINTO
          ELSE
            I1INC=1
          END IF
          IF(IINTO-IBY.EQ.2) THEN
            I3INC=0
          ELSE
            I3INC=1
          END IF
          I2=IINTO+1
        END IF
      ELSE
        IF(IBY.EQ.0.OR.(IBY.NE.N-1.AND.2*IBY.NE.N+1)) THEN
          WRITE(U6,210)
          GO TO 99
        END IF
        I1INC=1
        IF(IBY.EQ.N-1) THEN
          I3INC=0
        ELSE
          I3INC=1
        END IF
        I2=1
      END IF
      IBY=IBY+1
      I1=1
      IF(IFLVL.GT.0.AND.IKEY.EQ.31)GO TO 96
      NRECDL=0
      DO 52 I=1,NOUT
      IF((I.EQ.1.OR.I3INC.EQ.1).AND.IRC.NE.62) THEN
        CALL VNMTCH(VTEMP(IBY+SVTMP2-1),VNAME,NVIN,IV3)
        IF(IV3.EQ.0) THEN
          IF(ISTEPC.EQ.2.AND.IRC.GE.30.AND.IRC.LE.33) THEN
            K=RCEIL(2)+1
            CALL VNMTCH(VTEMP(IBY+SVTMP2-1),VNAME(K),NVREG,IV3)
            IF(IV3.GT.0) THEN
              IV3=IV3+RCEIL(2)
              IF(MTYPE(IV3).NE.1.AND.MTYPE(IV3).NE.11) THEN
                WRITE(U6,243)
                GO TO 99
              END IF
              IF(IBYCHK.EQ.0.AND.NBY.GT.0) THEN
                K=NBY+1
                CALL RINCR(4,NRECOD,K)
                J=NRECOD-K
                IF(IFLVL.GT.0) THEN
                  DO 44 KK=J,IF1LST,-1
                  V1(KK+K)=V1(KK)
                  V2(KK+K)=V2(KK)
                  IF(RCTYPE(KK).EQ.35.OR.RCTYPE(KK).EQ.36) THEN
                    IF(V3(KK).GT.0) THEN
                      V3(KK+K)=V3(KK)+K
                    ELSE IF(V3(KK).LT.0) THEN
                      V3(KK+K)=V3(KK)-K
                    ELSE
                      V3(KK+K)=0
                    END IF
                  ELSE
                    V3(KK+K)=V3(KK)
                  END IF
                  RSTPNT(KK+K)=RSTPNT(KK)
                  RCTYPE(KK+K)=RCTYPE(KK)
   44             CONTINUE
                  J=IF1LST
                  IF1LST=IF1LST+K
                  IF(U5ECHO.GT.0)WRITE(U6,250)
                  DO 45 KK=1,IFLVL
                  IF(IFLAST(KK).LT.0) THEN
                    IFLAST(KK)=IFLAST(KK)-K
                  ELSE IF(IFLAST(KK).GT.0) THEN
                    IFLAST(KK)=IFLAST(KK)+K
                  END IF
   45             CONTINUE
                ELSE
                  IF(U5ECHO.EQ.1)WRITE(U6,249)
                  J=J+1
                END IF
                RCTYPE(J)=60
                V1(J)=0
                V2(J)=0
                V3(J)=0
                RSTPNT(J)=NBY
                KK=RCEIL(2)+NVREG+NCLASS+NVARID
                IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN
                  KK=KK-1
                END IF
                DO 46 K=1,NBY
                KK=KK+1
                CALL VNMTCH(VNAME(KK),VNAME,NVIN,BYLIST(K))
                J=J+1
                RCTYPE(J)=0
                V1(J)=BYLIST(K)
                V2(J)=0
                V3(J)=0
                RSTPNT(J)=K+NVARID
                IF(BYLIST(K).EQ.0) THEN
                  WRITE(U6,248)VNAME(KK)
                  GO TO 99
                END IF
   46           CONTINUE
                IBYCHK=1
              END IF
            END IF
          END IF
          IF(IV3.EQ.0) THEN
            WRITE(U6,205)VTEMP(IBY+SVTMP2-1)
            GO TO 99
          END IF
        END IF
        IF(IKEY.EQ.31) THEN
          IF(MTYPE(IV3).NE.3.AND.MTYPE(IV3).NE.4) THEN
            WRITE(U6,211)VTEMP(IBY+SVTMP2-1)
            GO TO 99
          END IF
        END IF
      END IF
      IF(I.EQ.1.OR.I1INC.EQ.1) THEN
        CALL VNMTCH(VTEMP(I1+SVTMP2-1),VNAME,NVIN,IV1)
        IF(IV1.EQ.0) THEN
          WRITE(U6,205)VTEMP(I1+SVTMP2-1)
          GO TO 99
        END IF
      END IF
      CALL VNMTCH(VTEMP(I2+SVTMP2-1),VNAME,NVIN,IV2)
      IV2NEW=0
      IF(IV2.EQ.0) THEN
        CALL RINCR(2,NVIN,1)
        VNAME(NVIN)=VTEMP(I2+SVTMP2-1)
        CALL VNCHK2(VNAME(NVIN),1,IXM,LNMAP)
        LABEL(NVIN)(1:12)=VNAME(NVIN)
        LABEL(NVIN)(13:24)='            '
        IV2=NVIN
        CALL RFCHCK(1)
        IF(IMERR1.GT.0) THEN
          CALL CMPRNT(IXM,LNMAP)
        END IF
        IF(IFLVL.GT.0)IVZERO=1
        NRECDL=0
        IV2NEW=1
      ELSE IF(MTYPE(IV2).GE.50) THEN
        IF(IV3.GT.NVIN) THEN
          IF(IV1.NE.IV2) THEN
            WRITE(U6,237)
            GO TO 99
          END IF
          IF(NRECDL.GT.0) THEN
            IF(MTYPE(V1(NRECDL))+V2(NRECDL).EQ.MTYPE(IV1)) THEN
              V2(NRECDL)=V2(NRECDL)+1
              GO TO 515
            END IF
          END IF
          CALL RINCR(4,NRECOD,1)
          NRECDL=NRECOD
          V1(NRECOD)=IV1
          V2(NRECOD)=1
          V3(NRECOD)=IV3
        ELSE IF(I.GT.1.AND.IRC.GE.30.AND.IRC.LE.33.AND.IV1.EQ.IV2)
     .      THEN
          NRECDL=0
          IF(V3(NRECOD).EQ.IV3) THEN
            IF(RCTYPE(NRECOD).GE.30.AND.RCTYPE(NRECOD).LE.33) THEN
              IF(V1(NRECOD).EQ.V2(NRECOD).AND.
     .           MTYPE(V1(NRECOD))+1.EQ.MTYPE(IV1)) THEN
                RCTYPE(NRECOD)=RCTYPE(NRECOD)+13
                V2(NRECOD)=2
                GO TO 515
              END IF
            ELSE IF(RCTYPE(NRECOD).GE.43.AND.RCTYPE(NRECOD).LE.46) THEN
              IF(MTYPE(V1(NRECOD))+V2(NRECOD).EQ.MTYPE(IV1)) THEN
                V2(NRECOD)=V2(NRECOD)+1
                GO TO 515
              END IF
            END IF
          END IF
        ELSE
          NRECDL=0
        END IF
      END IF
      IF(IRC.EQ.62) THEN
        MTYPE(IV2)=1
        MSIZE(IV2)=1
        K=N-1
        CALL RINCR(4,NRECOD,K)
        K=K-1
        RCTYPE(NRECOD-K)=62
        V1(NRECOD-K)=0
        V2(NRECOD-K)=IV2
        V3(NRECOD-K)=0
        RSTPNT(NRECOD-K)=K
        NXPTDS=NXPTD
        CALL ROOMD(K)
        DO 47 KK=1,K
        CALL VNMTCH(VTEMP(KK+SVTMP2-1),VNAME,NVIN,IV1)
        IF(IV1.EQ.0) THEN
          WRITE(U6,205)VTEMP(KK+SVTMP2-1)
          GO TO 99
        END IF
        IF(MTYPE(IV1).NE.1)GO TO 95
        DX(NXPTDS)=-98765.432109D0
        RCTYPE(NRECOD-K+KK)=0
        V1(NRECOD-K+KK)=0
        V2(NRECOD-K+KK)=IV1
        V3(NRECOD-K+KK)=NXPTDS
        RSTPNT(NRECOD-K+KK)=IV1
        NXPTDS=NXPTDS+1
   47   CONTINUE
        GO TO 53
      END IF
      IF(NRECDL.EQ.0) THEN
        CALL RINCR(4,NRECOD,1)
      END IF
      IF(IKEY.EQ.31) THEN
        LPIV1=LPOINT(IV1)
        LPOINT(IV2)=NLEVEL+1
        IF(MTYPE(IV1).EQ.1.OR.MTYPE(IV1).EQ.2.OR.MTYPE(IV1).EQ.8.OR.
     .     MTYPE(IV1).GE.50) THEN
          IRC=8
        ELSE IF(MTYPE(IV1).EQ.3.OR.MTYPE(IV1).EQ.4.OR.
     .      MTYPE(IV1).EQ.9) THEN
          IRC=9
        ELSE
          WRITE(U6,212)VTEMP(IV1+SVTMP2-1)
          GO TO 99
        END IF
        ICDIV1=CDMPNT(IV1)
        CDMPNT(IV2)=NCRSSD+1
        IF(MTYPE(IV1).EQ.8.OR.MTYPE(IV1).EQ.9) THEN
          CALL RINCR(10,NCRSSD,1)
          CROSSD(NCRSSD)=CROSSD(ICDIV1)+1
          L=0
          K=ICDIV1+CROSSD(ICDIV1)+1
          K=CROSSD(K)
          DO 48 J=1,CROSSD(ICDIV1)
          CALL RINCR(10,NCRSSD,1)
          CROSSD(NCRSSD)=CROSSD(ICDIV1+J)
          L=L+CROSSD(NCRSSD)+1
          VTEMP(SVTEMP+J-1)=VTEMP(K)
          K=K+1
   48     CONTINUE
          KS=SVTEMP+CROSSD(ICDIV1)
          CALL RINCR(10,NCRSSD,1)
          K=LPIV1
          DO 49 J=1,L
          CALL RINCR(7,NLEVEL,1)
          LEVEL(NLEVEL)=LEVEL(K)
          K=K+1
   49     CONTINUE
        ELSE
          CROSSD(NCRSSD+1)=2
          CALL RINCR(7,NLEVEL,1)
          LEVEL(NLEVEL)=LABEL(IV1)
          IF(MTYPE(IV1).EQ.1.OR.MTYPE(IV1).EQ.2) THEN
            CROSSD(NCRSSD+2)=0
          ELSE
            CROSSD(NCRSSD+2)=MSIZE(IV1)
            K=LPIV1
            DO 50 J=1,MSIZE(IV1)
            CALL RINCR(7,NLEVEL,1)
            LEVEL(NLEVEL)=LEVEL(K)
            K=K+1
   50       CONTINUE
          END IF
          CALL RINCR(10,NCRSSD,3)
          VTEMP(SVTEMP)=VNAME(IV1)
          KS=SVTEMP+1
        END IF
        CROSSD(NCRSSD)=MSIZE(IV3)
        CALL RINCR(10,NCRSSD,1)
        CROSSD(NCRSSD)=SVTEMP
        VTEMP(KS)=VNAME(IV3)
        SVTEMP=KS+1
        CALL RCHECK(13,KS,1)
        CALL RINCR(7,NLEVEL,1)
        LEVEL(NLEVEL)=LABEL(IV3)
        K=LPOINT(IV3)
        DO 51 J=1,MSIZE(IV3)
        CALL RINCR(7,NLEVEL,1)
        LEVEL(NLEVEL)=LEVEL(K)
        K=K+1
   51   CONTINUE
        IF(IRC.EQ.9.OR.MTYPE(IV1).EQ.8.OR.MTYPE(IV1).EQ.2) THEN
          MSIZE(IV2)=MSIZE(IV1)*MSIZE(IV3)
        ELSE
          MSIZE(IV2)=2*MSIZE(IV3)
        END IF
        IF(MTYPE(IV1).EQ.3.OR.MTYPE(IV1).EQ.9) THEN
          MTYPE(IV2)=9
        ELSE
          MTYPE(IV2)=8
        END IF
      ELSE
        IF((MTYPE(IV1).NE.1.AND.MTYPE(IV1).NE.2.AND.MTYPE(IV1).NE.8
     .     .AND.MTYPE(IV1).LT.50).OR.
     .     (MTYPE(IV3).NE.1.AND.MTYPE(IV3).NE.2.AND.MTYPE(IV3).NE.8
     .     .AND.MTYPE(IV3).LT.50.AND.IV3.LE.NVIN)) THEN
          WRITE(U6,222)
          GO TO 99
        END IF
        IF(NRECDL.EQ.0) THEN
          MTSAVE=MTYPE(IV2)
          IF((IRC.NE.29.AND.(MTYPE(IV1).EQ.1.OR.MTYPE(IV1).GE.50).AND.
     .     (IV3.GT.NVIN.OR.MTYPE(IV3).EQ.1.OR.MTYPE(IV3).GE.50)).OR.
     .        IKEY.EQ.93.OR.IKEY.EQ.94.OR.(IRC.GE.30.AND.IRC.LE.33))
     .         THEN
            MSIZE(IV2)=1
            IF(MTYPE(IV2).LT.50)MTYPE(IV2)=1
          ELSE IF(MTYPE(IV1).EQ.8) THEN
            IF(MTYPE(IV2).GE.50)GO TO 98
            MTYPE(IV2)=8
            MSIZE(IV2)=MSIZE(IV1)
            CDMPNT(IV2)=CDMPNT(IV1)
            LPOINT(IV2)=LPOINT(IV1)
          ELSE
            IF(MTYPE(IV2).GE.50)GO TO 98
            MSIZE(IV2)=2
            MTYPE(IV2)=2
          END IF
          IF(IFLVL.GT.0.AND.MTSAVE.NE.MTYPE(IV2).AND.MTSAVE.LT.50.
     .       .AND.MTYPE(IV2).LT.50) THEN
            IF(IV2NEW.EQ.1) THEN
              IF(MTYPE(IV2).EQ.2) THEN
                MTSTRT(IV2)=2
              ELSE
                GO TO 96
              END IF
            END IF
          END IF
        END IF
      END IF
      IF(MXSIZE(IV2).LT.MSIZE(IV2))MXSIZE(IV2)=MSIZE(IV2)
      IF(NRECDL.EQ.0) THEN
        V1(NRECOD)=IV1
        V2(NRECOD)=IV2
        V3(NRECOD)=IV3
      END IF
      IF(IV3.LE.NVIN) THEN
        RCTYPE(NRECOD)=IRC
        RSTPNT(NRECOD)=0
      ELSE
        K=MXSIZE(IV3)
        IF(NRECDL.EQ.0) THEN
          RCTYPE(NRECOD)=IRC+20
        ELSE
          RCTYPE(NRECOD)=IRC+24
        END IF
        RSTPNT(NRECOD)=BLNCLS(K)
        IF(BLNCLS(K).GT.0) THEN
          INCX=BLXINC(K)
          ICLBAR=BLCPNT(K)
          DO 513 J=1,BLNCLS(K)
          CALL RINCR(4,NRECOD,1)
          RCTYPE(NRECOD)=0
          V2(NRECOD)=0
          IC=CLPNT(ICLBAR)+RCEIL(2)
          CALL VNMTCH(VNAME(IC),VNAME,NVIN,JJ)
          IF(JJ.EQ.0) THEN
            WRITE(U6,244)VNAME(IC)
            GO TO 99
          ELSE IF(MTYPE(JJ).NE.3.AND.MTYPE(JJ).NE.4) THEN
            WRITE(U6,245)VNAME(JJ)
            GO TO 99
          ELSE IF(MSIZE(JJ).NE.MSIZE(IC)) THEN
            WRITE(U6,246)VNAME(JJ)
            GO TO 99
          END IF
          V1(NRECOD)=JJ
          RSTPNT(NRECOD)=INCX
          IF(CLTYPE(ICLBAR).EQ.1) THEN
            V3(NRECOD)=0
            INCX=INCX*MSIZE(JJ)
          ELSE
            V3(NRECOD)=1
            INCX=INCX*(MSIZE(JJ)+1)
          END IF
          ICLBAR=ICLBAR+1
  513     CONTINUE
        END IF
      END IF
  515 CONTINUE
      IF(I2.EQ.N) THEN
        IF(I.EQ.1) THEN
          I1=I2
        END IF
      ELSE
        I2=I2+1
        I1=I1+I1INC
      END IF
      IBY=IBY+I3INC
   52 CONTINUE
   53 CONTINUE
      VTMPSZ=MVAR+1-SVTEMP
      RETURN
   95 CONTINUE
      WRITE(U6,200)
      GO TO 99
   96 CONTINUE
      WRITE(U6,233)
      GO TO 99
   98 CONTINUE
      WRITE(U6,237)
   99 CONTINUE
      CALL FSTOP
      END
