C     ztwdmf.f 2.1 9/4/91
C
C
C
      SUBROUTINE   WMSGTP
     I                   (WDMSFL,DSN,GNUM,
     O                    CLASS,RETCOD)
C
C     + + + PURPOSE + + +
C     get message file dataset parameter info from WDM file
C     (gets both PRM1 and PRM2 class info)
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     WDMSFL,DSN,GNUM,CLASS,RETCOD
C
C     + + + ARGUMENT DEFINITIONS + + +
C     WDMSFL - Fortran unit number for WDM file
C     DSN    - dataset number
C     GNUM   - question number to get
C     CLASS  - class of info (1- PRM1, 2- PRM2)
C     RETCOD - return code
C
C     + + + PARAMETERS + + +
      INCLUDE 'pmxfld.inc'
C
C     + + + COMMON BLOCKS + + +
      INCLUDE 'cfbuff.inc'
      INCLUDE 'cscren.inc'
      INCLUDE 'czoptn.inc'
      INCLUDE 'czhide.inc'
      INCLUDE 'zcntrl.inc'
      INCLUDE 'cclbak.inc'
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     I,I0,I1,I4,I8,I48,I80,J,K,DREC,DPOS,LIND,QWORD,
     $            ITMP,ITMP2,ID,ORDER,TLEN,OLEN,MLEN,GLEN,ILEN,LMXRSL,
     $            ICOL,IPOS,RDWRFG,DONFG,TXTFG,TPOS,IVAL(4),CONT,
     $            IIND,RIND,DIND,CIND,OIND,FIND,CONFG,OPWID,OPHIDE,
     $            LMXFLD
      REAL        LDEF
      CHARACTER*1 TBUFF(80),CBLNK(1),CNONE(4)
      CHARACTER*8 FDNAME(MXFLD),HIDFNM(MXFLD)
C
C     + + + EQUIVALENCES + + +
      EQUIVALENCE (RVAL,IVAL)
      REAL         RVAL(2)
C
C     + + + FUNCTIONS + + +
      INTEGER     WDRCGO, WMSPIV, WDPTCL, ZCHKST, CHRINT, ZLNTXT,
     1            LENSTR, CKNBLV, STRFND, WOPWDC
      REAL        CHRDEC
      DOUBLE PRECISION CHRDPR
C
C     + + + INTRINSICS + + +
      INTRINSIC   INDEX
C
C     + + + EXTERNALS + + +
      EXTERNAL    WDRCGO, WMSPIV, WDPTCL, ZCHKST, CHRINT, ZLNTXT, LENSTR
      EXTERNAL    WMSPIS, WMSBCS, WMSP2S, ZSCINI, CHRDEC, WMSCON, WOPWDC
      EXTERNAL    WMSFBC, WMSGTE, WDNXPS, WDNXDV, ZIPC, CHRDPR, CKNBLV
      EXTERNAL    WMSSKB, ZSTCMA, ZIPI, WMSSPS, WMSPOS, CARVAR, STRFND
      EXTERNAL    CHRCHR, WMSDLM, ZLJUST
C
C     + + + DATA INITIALIZATIONS + + +
      DATA I0,I1,I4,I8,I48,I80,RDWRFG/0,1,4,8,48,80,1/
      DATA CNONE/'n','o','n','e'/
C
C     + + + OUTPUT FORMATS + + +
 2000 FORMAT (80A1)
C
C     + + + END SPECIFICATIONS + + +
C
      TPOS = 1
      DONFG= 0
      TXTFG= 0
      CONFG= 0
      BLNK = ' '
      FTI  = 'I'
      FTR  = 'R'
      FTD  = 'D'
      FTC  = 'C'
      FTO  = 'O'
      FTF  = 'F'
      HELP = '?'
      NFLDS= 0
      IIND = 0
      RIND = 0
      DIND = 0
      CIND = 0
      OIND = 0
      FIND = 0
      CBLNK(1)= ' '
      NMHDRW  = 0
C     init callback IDs
      CBCHID = 0
      CBFLID = 0
      CBEXID = 0
C     set local version of max fields to remove
C     any chance of parameter MXFLD being modified
      LMXFLD= MXFLD
C     set local version of max response buffer length to remove
C     any chance of parameter MXRSLN being modified
      LMXRSL= MXRSLN
C
C     check existence of question
      CALL WMSFBC (WDMSFL,DSN,GNUM,
     O             DREC,DPOS,QWORD)
C
      IF (QWORD.EQ.0) THEN
C       bad question
        RETCOD= -40
      ELSE
C       ok question, get details
        RETCOD= 0
      END IF
C
      IF (RETCOD.EQ.0) THEN
C       initialize screen parameters
        IF (SPINIT.EQ.0) THEN
C         init response string
          CALL ZIPC (LMXRSL,BLNK,RSPSTR)
        END IF
        IF (ZWNFLG.EQ.0) THEN
C         init screen name
          ZSCNAM= ' '
        END IF
C       initialize screen
        CALL ZSCINI
        IF (HPINIT.EQ.0) THEN
C         init to no help (both general and specific)
          CALL ZSTCMA(1,0)
          GPTR= 0
          I= 64
          CALL ZIPI (I,I0,HPTR)
        ELSE
C         help set externally, turn it on
          CALL ZSTCMA(1,1)
        END IF
C       init to no boxes next to fields
        CALL ZIPI (LMXFLD,I0,OPBOX)
        CALL ZIPI (LMXFLD,I0,OPSET)
C       init option field conditionals
        CALL ZIPI (LMXFLD,I0,OPONOF)
        CALL ZIPI (MXCON,I0,ONFTFL)
        CALL ZIPI (MXCON,I0,ONFTVL)
C       no hidden fields
        NUMHID= 0
C       turn on 'oops'
        CALL ZSTCMA(8,1)
C       limits on
        CALL ZSTCMA(6,1)
C
 100    CONTINUE
C         get block control word
          LIND = WDRCGO(WDMSFL,DREC)
          QWORD= WIBUFF(DPOS,LIND)
          IF (QWORD.GT.0) THEN
C           get parameters
            CALL WMSBCS (QWORD,
     O                   CLASS,ID,ORDER,TLEN)
C
            IF (CLASS.EQ.5 .AND. ID.GE.3 .AND. ID.LE.7) THEN
              IF (ID.EQ.6) THEN
C               help for file class, change id to mimic PRM1 help
                ID= 15
              ELSE
C               set id to be ignored
                ID= 0
              END IF
            END IF
C
            IF (ID.GT.0) THEN
C             go to desired id
              GO TO (110,120,130,120,130,110,110,130,140,130,120,
     1               120,120,120,140,110,200,200,120,200,130,140,120),ID
C
 110          CONTINUE
C               get multiple records of text
                GLEN= 0
                MLEN= 0
                IF (ID.EQ.1 .OR. ID.EQ.16) THEN
C                 set I to current number of lines in menu
                  I= ZMNNLI
                ELSE
                  I   = 0
                END IF
 115            CONTINUE
C                 get records until end of id information
                  I= I+ 1
                  CALL WMSGTE (WDMSFL,TLEN,I80,
     M                         DREC,DPOS,GLEN,MLEN,
     O                         OLEN,TBUFF,CONT)
                  IF (ID.EQ.1) THEN
C                   screen text
                    TXTFG= 1
                    IF (OLEN.EQ.1) THEN
C                     blank line
                      ZMNTXT(I)= ' '
                      ZMNLEN(I)= 0
                    ELSE
                      WRITE (ZMNTXT(I),2000) (TBUFF(J),J=1,OLEN)
                      ZMNLEN(I)= OLEN
                    END IF
                  ELSE IF (ID.EQ.16 .AND.TXTFG.EQ.0) THEN
C                   header for PRM2 class
                    WRITE (ZMNTXT(I),2000) (TBUFF(J),J=1,OLEN)
                    ZMNLEN(I)= OLEN
                  ELSE IF (SPINIT.EQ.0) THEN
C                   valid or invalid responses, put in RSPSTR
                    IF (I.EQ.1) THEN
C                     first line of responses, init counters
                      K= TPOS
                      CCNT(ORDER)= 1
                      IF (FTYP(ORDER).EQ.FTC) THEN
C                       init default for character field
                        CDEF(CIND) = 0
                      END IF
                    END IF
                    IF (FTYP(ORDER).EQ.FTF) THEN
C                     file type data field, put all _VALID text in RSPSTR
                      CALL CHRCHR (TLEN,TBUFF,RSPSTR(K))
                    ELSE
C                     parse valid responses into RSPSTR
                      DO 118 J= 1,OLEN
                        IF (TBUFF(J).EQ.',') THEN
C                         delimiter found
                          K= TPOS+ (CCNT(ORDER)* FLEN(ORDER))
                          CCNT(ORDER)= CCNT(ORDER)+ 1
                        ELSE IF (TBUFF(J).NE.' ') THEN
                          RSPSTR(K)= TBUFF(J)
                          K= K+ 1
                        END IF
 118                  CONTINUE
                    END IF
                    IF (CONT.EQ.0) THEN
C                     all done with responses, update pointers
                      IF (FTYP(ORDER).NE.FTF) THEN
C                       length of responses is field length * no. responses
                        TLEN= FLEN(ORDER)*CCNT(ORDER)
                      END IF
                      IF (ID.EQ.6) THEN
C                       store position and length for valid response
                        FDVAL(ORDER)= WMSPIV(TPOS,TLEN)
                      ELSE IF (ID.EQ.7) THEN
C                       store position and length for invalid response
                        FDINV(ORDER)= WMSPIV(TPOS,TLEN)
                      END IF
                      TPOS= TPOS+ TLEN
                    END IF
                  END IF
                IF (CONT.EQ.1) GO TO 115
                IF ((ID.EQ.1 .AND. (CLASS.EQ.1 .OR. CLASS.EQ.5)) .OR.
     1              (ID.EQ.16 .AND. CLASS.EQ.2)) THEN
C                 save number of lines in menu
                  ZMNNLI= I
                  IF (CLASS.EQ.2) THEN
C                   save number of header rows
                    NMHDRW= ZMNNLI
                  END IF
                END IF
                GO TO 200
C
 120          CONTINUE
C               get one record of text
                GLEN= 0
                MLEN= 0
                CALL WMSGTE (WDMSFL,TLEN,I80,
     M                       DREC,DPOS,GLEN,MLEN,
     O                       OLEN,TBUFF,CONT)
                IF (ID.EQ.2) THEN
C                 new field, may need to fill in previous field (parm 1 only)
                  IF (NFLDS.GT.0 .AND. CLASS.EQ.1) THEN
C                   this is not the first field, check the previous one
                    I= SCOL(NFLDS)+ FLEN(NFLDS)- 1
                    IF (ZMNTXT(FLIN(NFLDS))(SCOL(NFLDS):I).EQ.' ') THEN
C                     nothing in field, should there be?
                      IF (FLEN(NFLDS).GE.4) THEN
C                       will use all of 'none' string
                        ILEN= 4
                      ELSE
C                       only use allowable width of field
                        ILEN= FLEN(NFLDS)
                      END IF
                      IF (FTYP(NFLDS).EQ.FTI .OR. FTYP(NFLDS).EQ.FTR
     1               .OR. FTYP(NFLDS).EQ.FTD) THEN
C                       numeric field, right justify 'none' in field
                        IF (ILEN.EQ.4) THEN
C                         push 'none' right side of field
                          IPOS= SCOL(NFLDS)+ FLEN(NFLDS)- 4
                        ELSE
C                         just start 'none' in 1st position of field
                          IPOS= SCOL(NFLDS)
                        END IF
                        CALL CHRCHR (ILEN,CNONE,
     O                               ZMNTX1(IPOS,FLIN(NFLDS)))
                      ELSE IF (FTYP(NFLDS).EQ.FTC .AND.
     1                         FDVAL(NFLDS).GT.0) THEN
C                       character w/valids, left justify 'none' in field
                        CALL CHRCHR (ILEN,CNONE,
     O                               ZMNTX1(SCOL(NFLDS),FLIN(NFLDS)))
                      END IF
                    END IF
                  END IF
C                 update related parms
                  NFLDS= ORDER
                  IF (OLEN.GT.8) THEN
C                   only use 1st 8 characters of field name
                    OLEN= 8
                  END IF
                  CALL CARVAR (OLEN,TBUFF,I8,FDNAME(ORDER))
                  FDFMT(ORDER) = FDNAME(ORDER)
                  J= INDEX(FDFMT(ORDER),'@')
                  IF (J.GT.0) THEN
C                   remove '@' from name for storage
                    FDFMT(ORDER)(J:J)= ' '
                  END IF
                  CALL ZLJUST(FDFMT(ORDER))
                  IF (CLASS.EQ.5) THEN
C                   file question being asked
                    FTYP(ORDER)= FTC
                  END IF
                  IF (SPINIT.EQ.0) THEN
C                   ok to init valid/invalid values
                    FDVAL(NFLDS) = 0
                    FDINV(NFLDS) = 0
                  END IF
                  FREC(NFLDS)  = 0
                  FSLOT(NFLDS) = 0
                  ASDSFG(NFLDS)= ' '
                  FPROT(NFLDS) = 0
                  HPTR(NFLDS)  = 0
                  IF (CLASS.EQ.1 .OR. CLASS.EQ.5) THEN
C                   PRM1 (or FILE) type, look for field id in screen text
                    CALL WMSSPS (ZMNNLI,OLEN,TBUFF,
     M                           ZMNTXT,FLIN(NFLDS),SCOL(NFLDS),
     M                           FLEN(NFLDS),RETCOD)
                  END IF
                ELSE IF (ID.EQ.4 .AND. SPINIT.EQ.0) THEN
C                 default value
                  IF (FTYP(ORDER).EQ.FTI) THEN
C                   integer
                    IDEF(IIND)= CHRINT(OLEN,TBUFF)
                    LDEF= IDEF(IIND)
                  ELSE IF (FTYP(ORDER).EQ.FTR) THEN
C                   real
                    RDEF(RIND)= CHRDEC(OLEN,TBUFF)
                    LDEF= RDEF(RIND)
                  ELSE IF (FTYP(ORDER).EQ.FTD) THEN
C                   double precision
                    DDEF(DIND)= CHRDPR(OLEN,TBUFF)
                    LDEF= DDEF(DIND)
                  ELSE IF (FTYP(ORDER).EQ.FTC .AND.
     $                     FDVAL(ORDER).GT.0) THEN
C                   character, determine order in valid string
                    IF (OLEN.LT.FLEN(ORDER)) THEN
C                     put in blanks
                      DO 122 J= OLEN+1,FLEN(ORDER)
                        TBUFF(J)= BLNK
 122                  CONTINUE
                    END IF
                    CALL WMSPIS (FDVAL(ORDER),
     O                           J,K)
                    CDEF(CIND)= ZCHKST(FLEN(ORDER),CCNT(ORDER),
     1                                  TBUFF,RSPSTR(J))
                  END IF
                  IF (OLEN.LE.FLEN(ORDER) .AND. CLASS.EQ.1) THEN
C                   room for default (parm 1 type screens only)
                    IF (FTYP(ORDER).EQ.FTI .OR. FTYP(ORDER).EQ.FTR .OR.
     1                  FTYP(ORDER).EQ.FTD) THEN
C                     put numeric default in screen text (right justified)
                      IF (LDEF.GT.-999.0) THEN
C                       valid default
                        IPOS= SCOL(ORDER)+ FLEN(ORDER)- OLEN
                        CALL CHRCHR (OLEN,TBUFF,
     O                               ZMNTX1(IPOS,FLIN(ORDER)))
                      ELSE
C                       put 'none' in field
                        IPOS= SCOL(ORDER)+ FLEN(ORDER)- I4
                        CALL CHRCHR (I4,CNONE,ZMNTX1(IPOS,FLIN(ORDER)))
                      END IF
                    ELSE IF (CDEF(CIND).GT.0 .OR.
     $                       FTYP(ORDER).EQ.FTF) THEN
C                     put character default in screen text (left justified)
                      CALL CHRCHR (OLEN,TBUFF,
     M                             ZMNTX1(SCOL(ORDER),FLIN(ORDER)))
                    END IF
                  ELSE IF (CLASS.EQ.1) THEN
C                   no room for default in screen text
                    WRITE(99,*) 'Not enough room for default of length',
     1                           OLEN,' in field',ORDER
                  END IF
                ELSE IF (ID.EQ.19 .AND. ZWNFLG.EQ.0) THEN
C                 window name for data screen,
C                 may need to fill in delimeters
                  CALL WMSDLM (ZSCNOP,I48,
     M                         TBUFF)
C                 now fill in screen name
                  OLEN= LENSTR(I48,TBUFF)
                  WRITE (ZSCNAM(1:OLEN),2000) (TBUFF(J),J=1,OLEN)
                ELSE IF (ID.EQ.23) THEN
C                 hide another field based on this option field's value
                  NUMHID= NUMHID+ 1
C                 store this field as the 'trigger' field for hiding
                  HIDTFL(NUMHID)= ORDER
                  IF (TBUFF(2).EQ.'N') THEN
C                   hide when this field is on
                    HIDVAL(NUMHID)= 1
                  ELSE
C                   hide when this field is off
                    HIDVAL(NUMHID)= 0
                  END IF
C                 find start of field name to hide
                  IPOS= CKNBLV(OLEN-3,TBUFF(4))+ 3
C                 now find its length
                  ILEN= STRFND(OLEN-IPOS+1,TBUFF(IPOS),I1,CBLNK)- 1
C                 store in temp buffer to determine field number later on
                  CALL CARVAR(ILEN,TBUFF(IPOS),I8,HIDFNM(NUMHID))
C                 now get row/column info
                  J= 0
 128              CONTINUE
C                   parse out each number (upper left r/c, lower right r/c)
                    J= J+ 1
                    IPOS= IPOS+ ILEN
C                   find start of number
                    I= CKNBLV(OLEN-IPOS+1,TBUFF(IPOS))
                    IPOS= IPOS+ I- 1
C                   find length of number
                    ILEN= STRFND(OLEN-IPOS+1,TBUFF(IPOS),I1,CBLNK)- 1
                    IF (ILEN.LE.0 .AND. J.EQ.4) THEN
C                     last number, no trailing blanks to find
                      ILEN= OLEN- IPOS+ 1
                    END IF
                    IVAL(J)= CHRINT(ILEN,TBUFF(IPOS))
                  IF (J.LT.4) GO TO 128
                  HIDBOX(NUMHID)= WOPWDC(IVAL(1),IVAL(2),
     I                                   IVAL(3),IVAL(4))
                END IF
                GO TO 200
C
 130          CONTINUE
C               get numeric parameters
                DO 135 I= 1,TLEN/4
                  CALL WDNXDV (WDMSFL,
     M                         DREC,DPOS,
     O                         IVAL(I))
 135            CONTINUE
                IF (ID.EQ.3) THEN
C                 integer parms for id 3
                  CALL WMSP2S (IVAL(1),
     O                         ITMP,ILEN,ITMP2,
     O                         FPROT(ORDER),ICOL)
                  IF (CLASS.EQ.2) THEN
C                   integer parms for PRM2 class, but not PRM1
                    FLEN(ORDER)= ILEN
                    SCOL(ORDER)= ICOL
                    IF (ITMP2.EQ.1) THEN
C                     ascending order for field
                      ASDSFG(ORDER)= 'A'
                    ELSE IF (ITMP2.EQ.2) THEN
C                    descending order for field
                     ASDSFG(ORDER)= 'D'
                    END IF
                  END IF
                  IF (ITMP.EQ.1) THEN
C                   integer
                    FTYP(ORDER)= FTI
                    IIND= IIND+ 1
                    IF (SPINIT.EQ.0) THEN
C                     init min/max/default
                      IMIN(IIND) = 0
                      IMAX(IIND) = 0
                      IDEF(IIND) = 0
                    END IF
                    APOS(ORDER)= IIND
                  ELSE IF (ITMP.EQ.2) THEN
C                   real
                    FTYP(ORDER)= FTR
                    RIND= RIND+ 1
                    IF (SPINIT.EQ.0) THEN
C                     init min/max/default
                      RMIN(RIND) = 0.0
                      RMAX(RIND) = 0.0
                      RDEF(RIND) = 0.0
                    END IF
                    APOS(ORDER)= RIND
                  ELSE IF (ITMP.EQ.3) THEN
C                   double precision
                    FTYP(ORDER)= FTD
                    DIND= DIND+ 1
                    IF (SPINIT.EQ.0) THEN
C                     init min/max/default
                      DMIN(DIND) = 0.0
                      DMAX(DIND) = 0.0
                      DDEF(DIND) = 0.0
                    END IF
                    APOS(ORDER)= DIND
                  ELSE IF (ITMP.EQ.4) THEN
C                   character
                    FTYP(ORDER)= FTC
                    CIND= CIND+ 1
                    APOS(ORDER)= CIND
                  ELSE IF (ITMP.EQ.5) THEN
C                   option type
                    FTYP(ORDER)= FTO
                    OIND= OIND+ 1
                    APOS(ORDER)= OIND
C                   restore field name to screen text (but not @ character)
                    I= SCOL(ORDER)+1
C                   determine length of field name
                    J= ZLNTXT(FDNAME(ORDER))
                    ZMNTXT(FLIN(ORDER))(I:I+J-2)= FDNAME(ORDER)(2:J)
C                   set initial 1st character to OFF value
                    ZMNTX1(SCOL(ORDER),FLIN(ORDER))= ' '
                  ELSE IF (ITMP.EQ.6) THEN
C                   file type
                    FTYP(ORDER) = FTF
                    FIND= FIND+ 1
                    APOS(ORDER) = FIND
                    ZFILUN(FIND)= 0
                  END IF
                ELSE IF (ID.EQ.5 .AND. SPINIT.EQ.0) THEN
C                 range of values
                  IF (FTYP(ORDER).EQ.FTI) THEN
C                   integer
                    IMIN(IIND)= IVAL(1)
                    IMAX(IIND)= IVAL(2)
                  ELSE IF (FTYP(ORDER).EQ.FTR) THEN
C                   real
                    RMIN(RIND)= RVAL(1)
                    RMAX(RIND)= RVAL(2)
                  ELSE IF (FTYP(ORDER).EQ.FTD) THEN
C                   double precision
                    DMIN(DIND)= RVAL(1)
                    DMAX(DIND)= RVAL(2)
                  END IF
                ELSE IF (ID.EQ.8 .AND. CLASS.EQ.1) THEN
C                 record and slot
                  CALL WMSPIS (IVAL(1),
     O                         FREC(ORDER),FSLOT(ORDER))
                ELSE IF (ID.EQ.8 .AND. CLASS.EQ.2) THEN
C                 number of values to pack on a record
C                 ZAROUT(NFLDS)= IVAL(1)
                ELSE IF (ID.EQ.10) THEN
C                 pcode and ucode
C                  CALL WMSPIS (IVAL(1),
C     O                         PCODE(ORDER),UCODE(ORDER))
                ELSE IF (ID.EQ.21) THEN
C                 integer parameters for option type field
                  CALL WMSPOS (IVAL(1),
     O                         OPSET(ORDER),OPSTNO(ORDER),OPDEF(ORDER),
     O                         OPWID,OPHIDE,OPBOX(ORDER))
                  IF (OPWID.GT.0) THEN
C                   use this as field length to highlight
                    IF (OPWID.GT.1) THEN
C                     determine actual length of field to highlight
                      FLEN(ORDER)= LENSTR(OPWID,ZMNTX1(SCOL(ORDER),
     1                                                 FLIN(ORDER)))
                    ELSE
C                     highlight length must be at least 1
                      FLEN(ORDER)= 1
                    END IF
                    IF (OPHIDE.GT.0) THEN
C                     hide field name
                      I= SCOL(ORDER)+1
                      J= ZLNTXT(FDNAME(ORDER))-1
                      ZMNTXT(FLIN(ORDER))(I:I+J-1)= ' '
                    END IF
                  END IF
                  IF (OPBOX(ORDER).EQ.1) THEN
C                   put box next to field, store starting line and column
                    OPBOX(ORDER)= WDPTCL(FLIN(ORDER),SCOL(ORDER))
                  END IF
                END IF
                GO TO 200
C
 140          CONTINUE
C               text info, store pointers (or flags), but not text
                IF (ID.EQ.22) THEN
C                 conditional for option type fields
                  CONFG= 1
                ELSE IF (HPINIT.EQ.0) THEN
C                 get help pointers, save rec and offset
                  IF (ID.EQ.9) THEN
C                   option help
                    HPTR(ORDER)= WDPTCL(DREC,DPOS)
                  ELSE
C                   general help for question
                    GPTR= WDPTCL(DREC,DPOS)
                  END IF
C                 help, turn on as available command
                  CALL ZSTCMA(1,1)
                END IF
C               skip to end of help
                CALL WMSSKB (WDMSFL,TLEN,
     M                       DREC,DPOS)
                GO TO 200
C
 200          CONTINUE
C
              IF (ID.EQ.17 .OR. ID.EQ.18 .OR. ID.EQ.20) THEN
C               table data info, skip over it
                CALL WMSSKB (WDMSFL,TLEN,
     M                       DREC,DPOS)
              END IF
C
            ELSE
C             skip over data
              CALL WMSSKB (WDMSFL,TLEN,
     M                     DREC,DPOS)
            END IF
C
C           move to next data position
            CALL WDNXPS (WDMSFL,RDWRFG,
     M                   DREC,DPOS,
     O                   LIND)
          ELSE
C           question terminator
            DONFG= 1
          END IF
        IF (DONFG.EQ.0) GO TO 100
C
        IF (CLASS.EQ.1) THEN
C         check last field for no value (parm 1 screens only)
          I= SCOL(NFLDS)+ FLEN(NFLDS)- 1
          IF (ZMNTXT(FLIN(NFLDS))(SCOL(NFLDS):I).EQ.' ') THEN
C           nothing in field, should there be?
            IF (FLEN(NFLDS).GE.4) THEN
C             will use all of 'none' string
              ILEN= 4
            ELSE
C             only use allowable width of field
              ILEN= FLEN(NFLDS)
            END IF
            IF (FTYP(NFLDS).EQ.FTI .OR. FTYP(NFLDS).EQ.FTR
     1     .OR. FTYP(NFLDS).EQ.FTD) THEN
C             numeric field, right justify 'none' in field
              IF (ILEN.EQ.4) THEN
C               push 'none' right side of field
                IPOS= SCOL(NFLDS)+ FLEN(NFLDS)- 4
              ELSE
C               just start 'none' in 1st position of field
                IPOS= SCOL(NFLDS)
              END IF
              CALL CHRCHR (ILEN,CNONE,
     O                     ZMNTX1(IPOS,FLIN(NFLDS)))
            ELSE IF (FTYP(NFLDS).EQ.FTC .AND.
     1               FDVAL(NFLDS).GT.0) THEN
C             character w/valids, left justify 'none' in field
              CALL CHRCHR (ILEN,CNONE,
     O                     ZMNTX1(SCOL(NFLDS),FLIN(NFLDS)))
            END IF
          END IF
        END IF
C
        IF (RETCOD.EQ.0) THEN
C         set some other parms
          CFLD  = 0
 300      CONTINUE
C           set current field, make sure not protected
            CFLD= CFLD+ 1
          IF (FPROT(CFLD).EQ.2 .AND. CFLD.LT.NFLDS) GO TO 300
          IF (NFLDS.GT.1 .AND. NFLDS.EQ.CFLD .AND.
     1                         FPROT(CFLD).EQ.2) THEN
C           all fields protected, make current first
            CFLD= 1
C           no 'Oops' allowed
            CALL ZSTCMA (8,0)
C           set flag to indicate all fields protected
            QFLAG= 1
          ELSE
C           not all fields protected
            QFLAG= 0
          END IF
          IF (CLASS.EQ.1 .OR. CLASS.EQ.5) THEN
C           PRM1 type
            ZHLLIN= FLIN(CFLD)
            ZDTYP = 3
          ELSE
C           PRM2 type
            IF (NMHDRW.EQ.0) THEN
C             no header lines from message file, set to any pre-existing lines
              NMHDRW= ZMNNLI
            END IF
            ZHLLIN= NMHDRW+ 1
            ZDTYP = 4
            CROW= 1
C           window on
            CALL ZSTCMA(9,1)
          END IF
C         conditionals for option fields?
          IF (CONFG.EQ.1) THEN
C           yes, need to run through them again now that we know about fields
            CALL WMSCON (WDMSFL,DSN,GNUM,NFLDS,FDNAME,MXCON,
     O                   OPONOF,ONFTFL,ONFTVL)
          END IF
          IF (NUMHID.GT.0) THEN
C           hidden fields exist, determine which fields they are
            DO 400 I= 1,NUMHID
C             look for hidden field among field names
              J= 0
 350          CONTINUE
                J= J+ 1
                IF (HIDFNM(I).EQ.FDNAME(J)) THEN
C                 found match
                  HIDFLD(I)= J
                  J= NFLDS
                END IF
              IF (J.LT.NFLDS) GO TO 350
 400        CONTINUE
          END IF
          ZHLCOL= SCOL(CFLD)
          ZHLLEN= FLEN(CFLD)
          ZCRLIN= ZHLLIN + 1
          ZCRCOL= ZHLCOL + 1
        END IF
C       always turn off parameter and help init flags
        SPINIT= 0
        HPINIT= 0
C       and screen name flag
        ZWNFLG= 0
      END IF
C
      RETURN
      END
C
C
C
      SUBROUTINE   WMSGTT
     I                   (WDMSFL,DSN,GNUM,INITFG,
     M                    OLEN,
     O                    OBUFF,CONT)
C
C     + + + PURPOSE + + +
C     get message file dataset text from WDM file
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     WDMSFL,DSN,GNUM,INITFG,OLEN,CONT
      CHARACTER*1 OBUFF(OLEN)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     WDMSFL - Fortran unit number for WDM file
C     DSN    - dataset number
C     GNUM   - question number to get
C     INITFG - flag indicating start a new question
C              0 - continue question, 1 - start new question
C     OLEN   - length of text
C     OBUFF  - output buffer of retrieved text
C     CONT   - continuation flag, 1 - more text to read
C                                 0 - end of text
C
C     + + + COMMON BLOCKS + + +
      INCLUDE 'cfbuff.inc'
      INCLUDE 'zcntrl.inc'
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     I,J,K,I48,LMAX,SREC,SPOS,QWORD,
     1            DREC,DIND,DPOS,CLASS,ID,ORDER,
     2            TLEN,GLEN,MLEN,DONFG,RDWRFG,SLEN
      CHARACTER*1 LBUFF(48)
C
C     + + + FUNCTIONS + + +
      INTEGER     WDRCGO, WDPTCL, LENSTR
C
C     + + + EXTERNALS + + +
      EXTERNAL    WDRCGO, WDPTCL, LENSTR, WMSBCS, WMSGTE, WMSFBC
      EXTERNAL    WMSSKB, WDNXPS, ZSTCMA, WMSDLM
C
C     + + + SAVES + + +
      SAVE   DREC,DPOS,GLEN,MLEN,TLEN
C
C     + + +  DATA INITIALIZATIONS + + +
      DATA I48,DPOS,GLEN,MLEN,RDWRFG/48,0,0,0,1/
C
C     + + + OUTPUT FORMATS + + +
 2000 FORMAT (48A1)
C
C     + + + END SPECIFICATIONS + + +
C
C     set maximum output length
      LMAX= OLEN
C
      IF (INITFG.EQ.1) THEN
C       new question, initialize counters
        DPOS = 0
        GLEN = 0
        MLEN = 0
C       init screen name
CJLK    ZSCNAM= ' '
C       get first block control word and its location
        CALL WMSFBC (WDMSFL,DSN,GNUM,
     O               DREC,DPOS,QWORD)
C
        DONFG= 0
C       loop through all blocks first time through
 10     CONTINUE
C         get block control word
          DIND = WDRCGO(WDMSFL,DREC)
          QWORD= WIBUFF(DPOS,DIND)
          IF (QWORD.GT.0) THEN
C           data exists, decode bcw
            CALL WMSBCS (QWORD,
     O                   CLASS,ID,ORDER,TLEN)
            IF (ID.EQ.1) THEN
C             first time through, save current rec/pos
              SREC= DREC
              SPOS= DPOS
              SLEN= TLEN
C             skip over data to look ahead for other directives
              CALL WMSSKB (WDMSFL,TLEN,
     M                     DREC,DPOS)
            ELSE IF (ID.EQ.2) THEN
C             help
              IF (HPINIT.EQ.0) THEN
C               not set externally, turn on as available command
                CALL ZSTCMA(1,1)
C               save help pointer
                GPTR= WDPTCL(DREC,DPOS)
              END IF
C             skip over help text
              CALL WMSSKB (WDMSFL,TLEN,
     M                     DREC,DPOS)
            ELSE IF (ID.EQ.19) THEN
C             screen name
              I= 0
              J= 0
              CALL WMSGTE (WDMSFL,TLEN,I48,
     M                     DREC,DPOS,I,J,
     O                     K,LBUFF,CONT)
              IF (ZWNFLG.EQ.0) THEN
C               fill in screen name
                ZSCNAM= ' '
C               may need to fill in delimeters
                CALL WMSDLM (ZSCNOP,I48,
     M                       LBUFF)
C               now fill in screen name
                K= LENSTR(I48,LBUFF)
                WRITE (ZSCNAM(1:K),2000) (LBUFF(I),I=1,K)
              END IF
            END IF
C           move to next data position
            CALL WDNXPS (WDMSFL,RDWRFG,
     M                   DREC,DPOS,
     O                   DIND)
          ELSE
C           at end of group
            DONFG= 1
          END IF
        IF (DONFG.EQ.0) GO TO 10
C
C       set rec/pos back to saved position
        DREC= SREC
        DPOS= SPOS
        TLEN= SLEN
      END IF
C
C     always read a record of text
      CALL WMSGTE (WDMSFL,TLEN,LMAX,
     M             DREC,DPOS,GLEN,MLEN,
     O             OLEN,OBUFF,CONT)
C     always reset screen name flag and help init flag
      ZWNFLG= 0
      HPINIT= 0
C
      RETURN
      END
C
C
C
      SUBROUTINE   WMSGTM
     I                   (WDMSFL,DSN,QNUM,
     O                    NUMB,WIDTH,CLEN,RETCOD)
C
C     + + + PURPOSE + + +
C     get message file dataset menu info from WDM file
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     WDMSFL,DSN,QNUM,NUMB,WIDTH,CLEN,RETCOD
C
C     + + + ARGUMENT DEFINITIONS + + +
C     WDMSFL - Fortran unit number for WDM file
C     DSN    - dataset number
C     QNUM   - question number to get
C     NUMB   - number option flag (0- no numbers, 1- numbers)
C     WIDTH  - column width
C     CLEN   - column length
C     RETCOD - return code
C
C     + + + COMMON BLOCKS + + +
      INCLUDE 'cfbuff.inc'
      INCLUDE 'cqrsp.inc'
      INCLUDE 'zcntrl.inc'
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     I,J,I0,I1,I48,I64,I80,DREC,DIND,DPOS,IPOS,LCLEN,SCRFG,
     1            CLASS,ID,ORDER,TLEN,GLEN,DONFG,QWORD,NCOL,
     2            IMENVL,RDWRFG,OLEN,MLEN,LLANS,CONT
      CHARACTER*1 TBUFF(80),BLNK,CEXC(1)
C
C     + + + FUNCTIONS + + +
      INTEGER     WDRCGO, WDPTCL, LENSTR, ZLNTXT, CKNBLV, STRFND
C
C     + + + INTRINSICS + + +
      INTRINSIC   MOD, INT
C
C     + + + EXTERNALS + + +
      EXTERNAL    WDRCGO, WDPTCL, LENSTR, ZLNTXT, CKNBLV, STRFND
      EXTERNAL    WMSMNS, WMSBCS, WMSSPS, WDNXPS, WMSGTE, WDNXDV, WMSFBC
      EXTERNAL    WMSSKB, ZCNTER, CHRCHR, ZSTCMA, QUPCAS, ZSCINI
      EXTERNAL    CHRDEL, ZIPC, ZIPI, WMSDLM, CARVAR
C
C     + + + OUTPUT FORMATS + + +
 2000 FORMAT (80A1)
C
C     + + + END SPECIFICATIONS + + +
C
      I0    = 0
      I1    = 1
      I48   = 48
      I64   = 64
      I80   = 80
      RDWRFG= 1
      SCRFG = 0
      DONFG = 0
      BLNK  = ' '
      CEXC(1)= '!'
      IF (HPINIT.EQ.0) THEN
C       assume no help available (both general and specific)
        GPTR  = 0
        CALL ZIPI (I64,I0,HPTR)
        CALL ZSTCMA(1,0)
      END IF
C     assume no centering
      ZCLEN = 0
      ZCWID = 0
C     init line, column, and length of menu options
      CALL ZIPI (I64,I0,ZOPLIN)
      CALL ZIPI (I64,I0,ZOPCOL)
      CALL ZIPI (I64,I0,ZOPLEN)
C
C     check existence of question
      CALL WMSFBC (WDMSFL,DSN,QNUM,
     O             DREC,DPOS,QWORD)
C
      IF (QWORD.EQ.0) THEN
C       bad question
        RETCOD= -40
      ELSE
C       ok question, get details
        RETCOD= 0
      END IF
C
      IF (RETCOD.EQ.0) THEN
        IF (RSINIT.EQ.0) THEN
C         initialize valid responses
          I= 480
          CALL ZIPC(I,BLNK,TANS)
        END IF
C       initialize screen
        CALL ZSCINI
        IF (ZWNFLG.EQ.0) THEN
C         init screen name
          ZSCNAM= ' '
        END IF
C       init commands
        DO 6 I= 6,11
C         make these commands unavailable (not valid for menu screen)
          CALL ZSTCMA(I,0)
 6      CONTINUE
C       also turn off down/up page commands
        I= 14
        CALL ZSTCMA (I,0)
        I= 15
        CALL ZSTCMA (I,0)
        IF (QUINIT.EQ.0) THEN
C         initialize question
          I= 64
          CALL ZIPC (I,BLNK,QUEST)
        ELSE
C         put previously set title in menu text
          ZMNLNI= ZMNNLI+ 1
          I= 78
          J= LENSTR(I,QUEST)
          WRITE (ZMNTXT(ZMNLNI),2000) (QUEST(I),I=1,J)
          ZMNLEN(ZMNLNI)= J
        END IF
 10     CONTINUE
C         get block control word
          DIND = WDRCGO(WDMSFL,DREC)
          QWORD= WIBUFF(DPOS,DIND)
          IF (QWORD.GT.0) THEN
C           get parameters
            CALL WMSBCS (QWORD,
     O                   CLASS,ID,ORDER,TLEN)
            IF (ID.EQ.2) THEN
C             move to data position and get integer word
              CALL WDNXDV (WDMSFL,
     M                     DREC,DPOS,
     O                     IMENVL)
C             split integer word into parameters
              CALL WMSMNS (IMENVL,
     O                     DANS,LLANS,NUMB,WIDTH,CLEN)
              IF (RSINIT.EQ.0) THEN
C               length of options not set, set it
                LANS= LLANS
              END IF
            ELSE IF (ID.EQ.1 .OR. ID.EQ.3 .OR.
     1               ID.EQ.4 .OR. ID.EQ.19) THEN
C             get character data and put in correct parameter
              GLEN= 0
              MLEN= 0
              CALL WMSGTE (WDMSFL,TLEN,I80,
     M                     DREC,DPOS,GLEN,MLEN,
     O                     OLEN,TBUFF,I)
              IF (ID.EQ.1 .AND. QUINIT.EQ.0) THEN
C               put title in menu text
                ZMNLNI= ZMNNLI+ 1
                WRITE (ZMNTXT(ZMNLNI),2000) (TBUFF(I),I=1,OLEN)
                ZMNLEN(ZMNLNI)= OLEN
              ELSE IF (ID.EQ.3 .AND. RSINIT.EQ.0) THEN
C               option
                IF (SCRFG.EQ.1) THEN
C                 'screen' method in use, look for option in screen text
CPRH               write (99,*)'OLEN,TBUFF',OLEN,(TBUFF(I),I=1,OLEN)
                  CALL WMSSPS (ZMNNLI,OLEN,TBUFF,
     M                         ZMNTXT,ZOPLIN(ORDER),ZOPCOL(ORDER),
     M                         ZOPLEN(ORDER),RETCOD)
                  IF (TBUFF(1).EQ.'@') THEN
C                   remove preceeding @ from option name
                    CALL CHRDEL (OLEN,I1,
     M                           TBUFF)
                    OLEN= OLEN- 1
                  END IF
                ELSE
C                 generate screen positions with original algorithm
                  ZOPLIN(ORDER)= MOD(ORDER-1,CLEN) + ZMNLNI+ 2 + ZCLEN
                  ZOPCOL(ORDER)= 1+ WIDTH*((ORDER-1)/CLEN) + ZCWID
                  IF (ZOPLIN(ORDER).GT.ZMNNLI) THEN
C                   more lines in menu
                    ZMNNLI= ZOPLIN(ORDER)
                  END IF
                END IF
                TLEN= ZOPCOL(ORDER)+ OLEN- 1
                IF (TLEN.GT.78) THEN
C                 out of space in screen buffer, need to cut it short
                  OLEN= OLEN- (TLEN-78)
                  TLEN= 78
                END IF
C               make sure nothing out there to overwrite
                I= CKNBLV(OLEN,ZMNTX1(ZOPCOL(ORDER),ZOPLIN(ORDER)))
                IF (I.GT.0) THEN
C                 some text out there, don't overwrite it
                  TLEN= TLEN- (OLEN-I+2)
                  OLEN= OLEN- (OLEN-I+2)
                END IF
                WRITE (ZMNTXT(ZOPLIN(ORDER))(ZOPCOL(ORDER):TLEN),2000)
     1                (TBUFF(I),I=1,OLEN)
                ZMNLEN(ZOPLIN(ORDER))= ZLNTXT(ZMNTXT(ZOPLIN(ORDER)))
CPRH       write (99,*) 'ORDER,TLEN,LINE,COL',
CPRH     1               ORDER,TLEN,ZOPLIN(ORDER),ZOPCOL(ORDER)
CPRH       write (99,*) ZMNTXT(ZOPLIN(ORDER))
                ZOPLEN(ORDER)= ZLNTXT(ZMNTXT(ZOPLIN(ORDER))
     1                               (ZOPCOL(ORDER):TLEN))
C               convert option to upper case
                CALL QUPCAS (OLEN,
     M                       TBUFF)
C               put option name in response buffer
                J= (ORDER-1)* LANS+ 1
                CALL CHRCHR (OLEN,TBUFF,TANS(J))
                NANS= ORDER
C               assume no help available
                HPTR(ORDER)= 0
              ELSE IF (ID.EQ.4) THEN
C               option description
                I= STRFND(LANS+2,ZMNTX1(ZOPCOL(ORDER),ZOPLIN(ORDER)),
     O                    I1,CEXC)
                IF (I.GT.0) THEN
C                 ! found in Screen text, start description here
                  J= ZOPCOL(ORDER)+ I- 1
                  ZMNTX1(J,ZOPLIN(ORDER))= ' '
C                 back up 1 extra space since option name has already
C                 been backed up one space to remove '@' character
                  J= J- 1
                ELSE
C                 start description at default position after option name
                  J= ZOPCOL(ORDER)+ LANS+ 1
                END IF
                IF (J.LT.78) THEN
C                 room to add (at least some of) the description
                  TLEN= J+ OLEN- 1
                  IF (TLEN.GT.78) THEN
C                   out of space in screen buffer, need to cut it short
                    OLEN= OLEN- (TLEN-78)
                    TLEN= 78
                  END IF
C                 make sure nothing out there to overwrite
                  I= CKNBLV(OLEN,ZMNTX1(J,ZOPLIN(ORDER)))
                  IF (I.GT.0) THEN
C                   some text out there, don't overwrite it
                    TLEN= TLEN- (OLEN-I+2)
                    OLEN= OLEN- (OLEN-I+2)
                  END IF
CPRH       write (99,*) 'J,TLEN,OLEN,I',J,TLEN,OLEN,I
CPRH       write (99,*) ZMNTXT(ZOPLIN(ORDER))
                  IF (OLEN.GT.0) THEN
C                   room to write some text
                    WRITE (ZMNTXT(ZOPLIN(ORDER))(J:TLEN),2000)
     1                    (TBUFF(I),I=1,OLEN)
                  END IF
                  ZMNLEN(ZOPLIN(ORDER))= ZLNTXT(ZMNTXT(ZOPLIN(ORDER)))
CPRH       write (99,*) 'ORDER,TLEN,LINE,COL',
CPRH     1               ORDER,TLEN,ZOPLIN(ORDER),ZOPCOL(ORDER)
CPRH       write (99,*) ZMNTXT(ZOPLIN(ORDER))
                  ZOPLEN(ORDER)= ZLNTXT(ZMNTXT(ZOPLIN(ORDER))
     1                                 (ZOPCOL(ORDER):TLEN))
                END IF
              ELSE IF (ID.EQ.19 .AND. ZWNFLG.EQ.0) THEN
C               window name for data screen
C               may need to fill in delimeters
                CALL WMSDLM (ZSCNOP,I48,
     M                       TBUFF)
C               now fill in screen name
                OLEN= LENSTR(I48,TBUFF)
                WRITE (ZSCNAM(1:OLEN),2000) (TBUFF(J),J=1,OLEN)
              END IF
            ELSE IF (ID.EQ.5 .OR .ID.EQ.6) THEN
C             help
              IF (HPINIT.EQ.0) THEN
C               not set externally, turn on as available command
                CALL ZSTCMA(1,1)
C               save rec and offset
                IF (ID.EQ.5) THEN
C                 option help
                  HPTR(ORDER)= WDPTCL(DREC,DPOS)
                ELSE
C                 general help for question
                  GPTR= WDPTCL(DREC,DPOS)
                END IF
              END IF
C             skip to end of help text
              CALL WMSSKB (WDMSFL,TLEN,
     M                     DREC,DPOS)
            ELSE IF (ID.EQ.21) THEN
C             Screen definition of menu
              IF (RSINIT.EQ.0) THEN
C               get multiple records of text
                GLEN= 0
                MLEN= 0
C               set I to current number of lines in menu
                I= ZMNNLI
 50             CONTINUE
C                 get records until end of id information
                  I= I+ 1
                  CALL WMSGTE (WDMSFL,TLEN,I80,
     M                         DREC,DPOS,GLEN,MLEN,
     O                         OLEN,TBUFF,CONT)
C                 put screen text into AIDE text buffer
                  IF (OLEN.EQ.1) THEN
C                   blank line
                    ZMNTXT(I)= ' '
                    ZMNLEN(I)= 0
                  ELSE
C                   put record into screen text buffer
                    J= 78
                    CALL CARVAR (OLEN,TBUFF,J,ZMNTXT(I))
CPRH                    WRITE (ZMNTXT(I),2000) (TBUFF(J),J=1,OLEN)
                    ZMNLEN(I)= OLEN
                  END IF
                IF (CONT.EQ.1) GO TO 50
C               indicate 'screen' method being used for menu
                SCRFG= 1
C               save number of lines in menu
                ZMNNLI= I
              ELSE
C               skip this data, move to next data position
                CALL WMSSKB (WDMSFL,TLEN,
     M                       DREC,DPOS)
              END IF
            END IF
C           move to next data position
            CALL WDNXPS (WDMSFL,RDWRFG,
     M                   DREC,DPOS,
     O                   DIND)
          ELSE
C           question terminator
            DONFG= 1
          END IF
        IF (DONFG.EQ.0) GO TO 10
C
C       set options here, if previously defined
        IF (RSINIT.EQ.1) THEN
C         options already defined, put in menu text
C         determine column length and width
          IF (NANS.LE.8) THEN
            WIDTH= 78
            CLEN = NANS
          ELSE
C           determin number of columns
            LCLEN= MOD(NANS,8)
            IF (LCLEN.NE.0) THEN
C             uneven column lengths
              NCOL= INT(NANS/8)+ 1
C             determine column lengths
              CLEN= 8
 100          CONTINUE
                LCLEN= LCLEN+ NCOL- 1
                IF (LCLEN.LT.CLEN) THEN
                  CLEN = CLEN- 1
                END IF
              IF (LCLEN.LT.CLEN-1) GO TO 100
            ELSE
C             even column lengths
              NCOL= NANS/8
              CLEN= 8
            END IF
            WIDTH = 78/NCOL
          END IF
          DO 200 I= 1,NANS
C           position responses in menu text
            ZOPLIN(I)= MOD(I-1,CLEN) + ZMNLNI+ 2 + ZCLEN
            ZOPCOL(I)= 1+ WIDTH*((I-1)/CLEN) + ZCWID
            IF (ZOPLIN(I).GT.ZMNNLI) THEN
C             more lines in menu
              ZMNNLI= ZOPLIN(I)
            END IF
            IPOS= (I-1)* LANS+ 1
            WRITE (ZMNTXT(ZOPLIN(I))(ZOPCOL(I):ZOPCOL(I)+LANS-1),2000)
     1            (TANS(J),J=IPOS,IPOS+LANS-1)
            ZMNLEN(ZOPLIN(I))= ZOPCOL(I)+ OLEN- 1
            TLEN  = ZOPCOL(I)+WIDTH-1
            IF (TLEN.GT.78) TLEN= 78
            ZOPLEN(I)= ZLNTXT(ZMNTXT(ZOPLIN(I))
     1                       (ZOPCOL(I):TLEN))
 200      CONTINUE
        END IF
C
CPRH      write (99,*) 'ZOPLIN',ZOPLIN
CPRH      write (99,*) 'ZOPCOL',ZOPCOL
CPRH      write (99,*) 'ZOPLEN',ZOPLEN
CPRH      write (99,*) 'ZB1N,ZHLLEN,ZMNNLI,ZMNLEN,ZHLLIN,ZHLCOL',
CPRH     1              ZB1N,ZHLLEN,ZMNNLI,ZMNLEN,ZHLLIN,ZHLCOL
CPRH      write (99,*) (ZMNTXT(I),I=1,10)
C       center menu
        CALL ZCNTER (ZB1N,ZHLLEN,
     M               ZMNNLI,ZMNTXT,ZMNLEN,ZHLLIN,ZHLCOL,
     O               ZCLEN,ZCWID)
CPRH      write (99,*) 'ZB1N,ZHLLEN,ZMNNLI,ZMNLEN,ZHLLIN,ZHLCOL',
CPRH     1              ZB1N,ZHLLEN,ZMNNLI,ZMNLEN,ZHLLIN,ZHLCOL
CPRH      write (99,*) (ZMNTXT(I),I=1,10)
C       reset screen name flag
        ZWNFLG= 0
      END IF
C
      RETURN
      END
C
C
C
      SUBROUTINE   WMSGTF
     I                   (WDMSFL,DSN,QNUM,
     O                    QFLG,FLNAME,STATF,ACCD,FMTD,TRECL)
C
C     + + + PURPOSE + + +
C     get message file dataset file info from WDM file
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER      WDMSFL,DSN,QNUM,QFLG,TRECL
      CHARACTER*64 FLNAME
      CHARACTER*7  STATF
      CHARACTER*10 ACCD
      CHARACTER*11 FMTD
C
C     + + + ARGUMENT DEFINITIONS + + +
C     WDMSFL - Fortran unit number for WDM file
C     DSN    - dataset number
C     QNUM   - question number to get
C     QFLG   - question flag (0- file name already specified,
C                             1- ask user for file name)
C     FLNAME - file name to be opened
C     STATF  - file status
C     ACCD   - file access type
C     FMTD   - file format
C     TRECL  - direct file record length
C
C     + + + COMMON BLOCKS + + +
      INCLUDE 'cfbuff.inc'
      INCLUDE 'zcntrl.inc'
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     I,I80,DREC,DIND,DPOS,CLASS,ID,ORDER,OLEN,
     2            TLEN,GLEN,DONFG,QWORD,MLEN,RDWRFG,RETCOD
      CHARACTER*1 TBUFF(80)
C
C     + + + FUNCTIONS + + +
      INTEGER     WDRCGO, WDPTCL
C
C     + + + EXTERNALS + + +
      EXTERNAL    WDRCGO, WDPTCL, WMSBCS, WMSGTE
      EXTERNAL    WDNXPS, WDNXDV, WMSFBC, WMSSKB
C
C     + + + OUTPUT FORMATS + + +
 2000 FORMAT (64A1)
C
C     + + + END SPECIFICATIONS + + +
C
      I80   = 80
      RDWRFG= 1
      DONFG = 0
      TRECL = 0
      IF (HPINIT.EQ.0) THEN
C       assume no help available
        GPTR = 0
      END IF
C     assume not a question
      QFLG  = 0
C     init output argument file parameters
      FLNAME= ' '
      STATF = 'OLD    '
      ACCD  = 'SEQUENTIAL'
      FMTD  = 'FORMATTED  '
      TRECL = 0
C
C     check existence of question
      CALL WMSFBC (WDMSFL,DSN,QNUM,
     O             DREC,DPOS,QWORD)
C
      IF (QWORD.EQ.0) THEN
C       bad question
        RETCOD= -40
      ELSE
C       ok question, get details
        RETCOD= 0
      END IF
C
      IF (RETCOD.EQ.0) THEN
C       get info till null reached
 10     CONTINUE
C         get block control word
          DIND = WDRCGO(WDMSFL,DREC)
          QWORD= WIBUFF(DPOS,DIND)
          IF (QWORD.GT.0) THEN
C           get parameters
            CALL WMSBCS (QWORD,
     O                   CLASS,ID,ORDER,TLEN)
            IF (ID.EQ.7) THEN
C             get record length from next data value
              CALL WDNXDV (WDMSFL,
     M                     DREC,DPOS,
     O                     TRECL)
            ELSE IF (ID.LE.5 .OR. ID.EQ.19) THEN
C             get character data and put in correct parameter
              GLEN= 0
              MLEN= 0
 50           CONTINUE
C               read records till end of id info
                CALL WMSGTE (WDMSFL,TLEN,I80,
     M                       DREC,DPOS,GLEN,MLEN,
     O                       OLEN,TBUFF,I)
                IF (ID.EQ.1) THEN
C                 question, will be asked later, turn on QFLG
                  QFLG= 1
                ELSE IF (ID.EQ.2 .AND. QFLG.EQ.0) THEN
C                 file name
                  WRITE (FLNAME,2000) (TBUFF(I),I=1,OLEN)
                ELSE IF (ID.EQ.3) THEN
C                 file status
                  WRITE (STATF,2000) (TBUFF(I),I=1,OLEN)
                ELSE IF (ID.EQ.4) THEN
C                 file access
                  WRITE (ACCD,2000) (TBUFF(I),I=1,OLEN)
                ELSE IF (ID.EQ.5) THEN
C                 file format
                  WRITE (FMTD,2000) (TBUFF(I),I=1,OLEN)
                END IF
              IF (I.EQ.1) GO TO 50
            ELSE IF (ID.EQ.6) THEN
C             help
              IF (HPINIT.EQ.0) THEN
C               not set externally, save rec and offset
                GPTR= WDPTCL(DREC,DPOS)
              END IF
C             skip to end of help text
              CALL WMSSKB (WDMSFL,TLEN,
     M                     DREC,DPOS)
            END IF
C           move to next data position
            CALL WDNXPS (WDMSFL,RDWRFG,
     M                   DREC,DPOS,
     O                   DIND)
          ELSE
C           question terminator
            DONFG= 1
          END IF
        IF (DONFG.EQ.0) GO TO 10
      END IF
C     always reset help init flag
      HPINIT= 0
C
      RETURN
      END
C
C
C
      SUBROUTINE   WMSGTX
     I                   (MESSFL,SCLU,SGRP,
     O                    LNFLDS,LSCOL,LFLEN,LFTYP,LAPOS,LIMIN,LIMAX,
     O                    LIDEF,LRMIN,LRMAX,LRDEF,LNMHDR,HDRBUF,RETCOD)
C
C     + + + PURPOSE + + +
C     Get selected information about a table dataset 2d parm screen.
C     * * * This routine is specific to the HSPF Expert System  * * *
C     * * * program and resides here to keep AIDE common blocks * * *
C     * * * within the same code group.                         * * *
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     MESSFL,SCLU,SGRP,LNFLDS,LSCOL(30),LFLEN(30),
     1            LAPOS(30),LIMIN(30),LIMAX(30),LIDEF(30),LNMHDR,RETCOD
      REAL        LRMIN(30),LRMAX(30),LRDEF(30)
      CHARACTER*1 LFTYP(30),HDRBUF(78,5)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     MESSFL - Fortran unit number for message file
C     SCLU   - cluster number on message file
C     SGRP   - group number in cluster of screen
C     LNFLDS - number of fields for this table
C     LSCOL  - integer array of starting columns for fields
C     LFLEN  - integer array of field lengths
C     LFTYP  - character array of field types (I,R,C)
C     LAPOS  - position in field type specific arrays of that type
C     LIMIN  - integer array of minimum values for integer fields
C     LIMAX  - integer array of maximum values for integer fields
C     LIDEF  - integer array of defaults for integer fields
C     LRMIN  - real array of minimum values for real fields
C     LRMAX  - real array of maximum values for real fields
C     LRDEF  - real array of defaults for real fields
C     LNMHDR - number of header rows
C     HDRBUF - character array of headers for tables
C     RETCOD - return code
C
C     + + + PARAMETERS + + +
      INCLUDE 'pmxfld.inc'
C
C     + + + COMMON BLOCKS + + +
      INCLUDE 'cscren.inc'
      INCLUDE 'zcntrl.inc'
C
C     + + + LOCAL VARIABLES + + +
      INTEGER   I,I78
C
C     + + + EXTERNALS + + +
      EXTERNAL   WMSGTP, CHRCHR
C
C     + + + END SPECIFICATIONS + + +
C
      I78= 78
C
      CALL WMSGTP (MESSFL,SCLU,SGRP,
     O             I,RETCOD)
C
      IF (NFLDS.GT.30) THEN
C       this should not happen for the purposes of this routine
        WRITE (99,*) 'BIG PROBLEM in WMSGTX: NFLDS > 30, NFLDS =',NFLDS
        LNFLDS= 30
      ELSE
C       use all available fields
        LNFLDS= NFLDS
      END IF
C
C     fill in argument values
      DO 100 I= 1,LNFLDS
        LSCOL(I)= SCOL(I)
        LFLEN(I)= FLEN(I)
        LFTYP(I)= FTYP(I)
        LAPOS(I)= APOS(I)
        LIMIN(I)= IMIN(I)
        LIMAX(I)= IMAX(I)
        LIDEF(I)= IDEF(I)
        LRMIN(I)= RMIN(I)
        LRMAX(I)= RMAX(I)
        LRDEF(I)= RDEF(I)
 100  CONTINUE
C
C     save number of header rows
      LNMHDR= NMHDRW
      DO 200 I= 1,NMHDRW
C       fill in headers
        CALL CHRCHR (I78,ZMNTX1(1,I),HDRBUF(1,I))
 200  CONTINUE
C
      RETURN
      END
C
C
C
      SUBROUTINE   WMSSPS
     I                   (ZMNNLI,FOLEN,FONAM,
     M                    ZMNTXT,LINE,COLUMN,LENGTH,RETCOD)
C
C     + + + PURPOSE + + +
C     Determine the position within the screen text buffer
C     of either a data field or menu option.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER      ZMNNLI,FOLEN,LINE,COLUMN,LENGTH,RETCOD
      CHARACTER*1  FONAM(FOLEN)
      CHARACTER*78 ZMNTXT(ZMNNLI)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     ZMNNLI - number of lines in screen text buffer
C     FOLEN  - length of field/option name
C     FONAM  - field/option name
C     ZMNTXT - screen text buffer
C     LINE   - line number in screen text buffer of field/option
C     COLUMN - starting column in screen text buffer of field/option
C     LENGTH - length of file/option
C     RETCOD - return code
C
C     + + + LOCAL VARIABLES + + +
      INTEGER      I,J,OLEN
      CHARACTER*78 TMPNAM
C
C     + + + INTRINSICS + + +
      INTRINSIC    INDEX
C
C     + + + EXTERNALS + + +
      EXTERNAL     CARVAR
C
C     + + + END SPECIFICATIONS + + +
C
C     put character array field/option name into character variable for search
      I= 78
      CALL CARVAR (FOLEN,FONAM,I,TMPNAM)
CPRH       write (99,*) 'LEN,TMPNAM',FOLEN,TMPNAM(1:FOLEN)
C
      OLEN= FOLEN
C     look for field/option name in screen text buffer
      I= 0
 100  CONTINUE
C       search line by line
        I= I+ 1
CPRH       write (99,*) 'ZMNTXT(I),I=',I
CPRH       write (99,*) ZMNTXT(I)
        J= INDEX(ZMNTXT(I),TMPNAM(1:FOLEN))
        IF (TMPNAM(1:1).NE.'@') THEN
C         field/option being searched for does not have an @ preceeding
          IF (J.GT.1) THEN
C           make sure screen buffer has preceeding @
            IF (ZMNTXT(I)(J-1:J-1).EQ.'@') THEN
C             option found w/appropriate @ preceeding,
C             back up one space to remove '@' from screen buffer
              J= J- 1
              OLEN= FOLEN+ 1
            ELSE
C             this is not a real match
              J= 0
            END IF
          ELSE
C           match found in 1st column, cant be a real match
            J= 0
          END IF
        END IF
        IF (J.GT.0) THEN
C         found the field
          LINE  = I
          COLUMN= J
          LENGTH= OLEN
          ZMNTXT(I)(J:J+OLEN-1)= ' '
          J= J+ OLEN
          IF (J.LT.79) THEN
C           don't look for end of field beyond width of screen buffer
 200        CONTINUE
C             look for end of field
              IF (ZMNTXT(I)(J:J).EQ.'.') THEN
C               still in field
                LENGTH= LENGTH+ 1
                ZMNTXT(I)(J:J)= ' '
              ELSE
C               end of field
                J= 79
              END IF
              J= J+ 1
            IF (J.LT.79) GO TO 200
          END IF
          I= ZMNNLI+ 1
        END IF
      IF (I.LT.ZMNNLI) GO TO 100
C
      IF (I.EQ.ZMNNLI) THEN
C       never found field, error
        RETCOD= 2
      END IF
C
      RETURN
      END
C
C
C
      SUBROUTINE   WMSCON
     I                   (WDMSFL,DSN,GNUM,NFLDS,FDNAME,MXCON,
     O                    OPONOF,ONFTFL,ONFTVL)
C
C     + + + PURPOSE + + +
C     Fill in arrays for option type field conditionals.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     WDMSFL,DSN,GNUM,NFLDS,MXCON,OPONOF(NFLDS),
     1            ONFTFL(MXCON),ONFTVL(MXCON)
      CHARACTER*8 FDNAME(NFLDS)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     WDMSFL - Fortran unit number for message file
C     DSN    - data-set (group) number on message file
C     GNUM   - group (cluster) number on message file
C     NFLDS  - number of fields on this screen
C     FDNAME - array of field names
C     MXCON  - maximum number of conditionals
C     OPONOF - array of pointers/counters for conditional arrays for each field
C     ONFTFL - array of target field numbers for conditionals
C     ONFTVL - values of target fields for conditionals
C
C     + + + PARAMETERS + + +
      INCLUDE 'pmxfld.inc'
C
C     + + + COMMON BLOCKS + + +
      INCLUDE 'cfbuff.inc'
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     I,J,L,I0,I1,I8,DREC,DPOS,QWORD,DONFG,LIND,CLASS,ID,
     $            ORDER,TLEN,RDWRFG,CONT,ILEN,GLEN,MLEN,OLEN,LMXFLD,
     $            POINTR,LORDER,ONCNT,OFFCNT,CFLD,IPOS,ONPTR,OFFPTR,
     $            LONTFL(MXFLD),LOFTFL(MXFLD),
     $            LONTVL(MXFLD),LOFTVL(MXFLD)
      CHARACTER*1 TBUFF(80),BLNK(1),CCOMMA(1)
      CHARACTER*8 CFDNAM
C
C     + + + FUNCTIONS + + +
      INTEGER     WDRCGO, STRFND, LENSTR, CKNBLV, WOPWDC
C
C     + + + INTRINSICS + + +
      INTRINSIC   INT
C
C     + + + EXTERNALS + + +
      EXTERNAL    WDRCGO, STRFND, LENSTR, CKNBLV, WOPWDC, CARVAR
      EXTERNAL    WMSFBC, WMSBCS, WMSSKB, WDNXPS, WMSGTE, ZIPI
C
C     + + + END SPECIFICATIONS + + +
C
      I0 = 0
      I1 = 1
      I8 = 8
      RDWRFG   = 1
      BLNK(1)  = ' '
      CCOMMA(1)= ','
C     set local version of max fields to remove
C     any chance of parameter MXFLD being modified
      LMXFLD= MXFLD
C
C     find start of screen info again
      CALL WMSFBC (WDMSFL,DSN,GNUM,
     O             DREC,DPOS,QWORD)
C
C     init local counters of ON and OFF conditions
      ONCNT = 0
      OFFCNT= 0
      POINTR= 1
C     init local arrays of target field numbers and their values
      CALL ZIPI (LMXFLD,I0,LONTFL)
      CALL ZIPI (LMXFLD,I0,LOFTFL)
      CALL ZIPI (LMXFLD,I0,LONTVL)
      CALL ZIPI (LMXFLD,I0,LOFTVL)
C
      LORDER= 0
      DONFG = 0
 100  CONTINUE
C       get block control word
        LIND = WDRCGO(WDMSFL,DREC)
        QWORD= WIBUFF(DPOS,LIND)
        IF (QWORD.GT.0) THEN
C         get parameters
          CALL WMSBCS (QWORD,
     O                 CLASS,ID,ORDER,TLEN)
          IF (ID.EQ.22) THEN
C           conditional information, process it
            IF (ORDER.NE.LORDER .AND. LORDER.NE.0 .AND.
     1          (ONCNT.GT.0 .OR. OFFCNT.GT.0)) THEN
C             conditionals for new field, clean up last fields arrays
              ONPTR = 0
              OFFPTR= 0
              IF (ONCNT.GT.0) THEN
C               on conditions exist,
C               need to loop through local target field numbers and values
                J= 0
                DO 110 I= 1,ONCNT,4
                  ONFTFL(POINTR+J)= WOPWDC(LONTFL(I),LONTFL(I+1),
     I                                     LONTFL(I+2),LONTFL(I+3))
                  ONFTVL(POINTR+J)= WOPWDC(LONTVL(I),LONTVL(I+1),
     I                                     LONTVL(I+2),LONTVL(I+3))
                  J= J+ 1
 110            CONTINUE
                ONPTR = POINTR
                POINTR= POINTR+ INT(ONCNT/4)+ 1
              END IF
              IF (OFFCNT.GT.0) THEN
C               off conditions exist,
C               need to loop through local target field numbers and values
                J= 0
                DO 120 I= 1,OFFCNT,4
                  ONFTFL(POINTR+J)= WOPWDC(LOFTFL(I),LOFTFL(I+1),
     I                                     LOFTFL(I+2),LOFTFL(I+3))
                  ONFTVL(POINTR+J)= WOPWDC(LOFTVL(I),LOFTVL(I+1),
     I                                     LOFTVL(I+2),LOFTVL(I+3))
                  J= J+ 1
 120            CONTINUE
                OFFPTR= POINTR
                POINTR= POINTR+ INT(OFFCNT/4)+ 1
              END IF
C             now calculate word of pointers and counts for previous field
              OPONOF(LORDER)= WOPWDC(ONPTR,ONCNT,OFFPTR,OFFCNT)
C             reset counters
              ONCNT = 0
              OFFCNT= 0
            END IF
            LORDER= ORDER
            GLEN= 0
            MLEN= 0
C           get multiple records of text
 130        CONTINUE
C             get records until end of id information
              ILEN= 80
              CALL WMSGTE (WDMSFL,TLEN,ILEN,
     M                     DREC,DPOS,GLEN,MLEN,
     O                     OLEN,TBUFF,CONT)
              IPOS= STRFND(OLEN,TBUFF,I1,BLNK)+ 1
 140          CONTINUE
C               find start of next conditional field
                I= CKNBLV(OLEN-IPOS+1,TBUFF(IPOS))
                IF (I.GT.0) THEN
C                 start of another conditional field found
                  IPOS= IPOS+ I- 1
C                 determine its length
                  ILEN= STRFND(OLEN-IPOS+1,TBUFF(IPOS),I1,CCOMMA)
                  IF (ILEN.EQ.0) THEN
C                   no comma found, last conditional name on this record
                    ILEN= OLEN- IPOS+ 1
                  ELSE
C                   comma found, dont include in string to search for
                    ILEN= ILEN- 1
                  END IF
                  L= LENSTR(ILEN,TBUFF(IPOS))
                  CALL CARVAR (L,TBUFF(IPOS),I8,CFDNAM)
C                 look for conditional field among field names
                  CFLD= 0
                  I= 0
 150              CONTINUE
                    I= I+ 1
                    IF (CFDNAM.EQ.FDNAME(I)) THEN
C                     found match
                      CFLD= I
                      I= NFLDS
                    END IF
                  IF (I.LT.NFLDS) GO TO 150
                  IF (CFLD.GT.0) THEN
C                   field found, put into local array
                    IF (TBUFF(3).EQ.'N') THEN
C                     if source field is ON condition,
                      ONCNT= ONCNT+ 1
                      LONTFL(ONCNT)= CFLD
C                     check position 5 of TBUFF for value of target field
                      IF (TBUFF(5).EQ.'N') THEN
C                       then turn target field ON
                        LONTVL(ONCNT)= 1
                      ELSE
C                       then turn target field OFF
                        LONTVL(ONCNT)= 0
                      END IF
                    ELSE
C                     if source field is OFF condition,
                      OFFCNT= OFFCNT+ 1
                      LOFTFL(OFFCNT)= CFLD
C                     check position 6 of TBUFF for value of target field
                      IF (TBUFF(6).EQ.'N') THEN
C                       then turn target field ON
                        LOFTVL(OFFCNT)= 1
                      ELSE
C                       then turn target field OFF
                        LOFTVL(OFFCNT)= 0
                      END IF
                    END IF
                  END IF
                  IPOS= IPOS+ ILEN+ 1
                ELSE
C                 no more conditional fields on record
                  IPOS= OLEN
                END IF
              IF (IPOS.LT.OLEN) GO TO 140
            IF (CONT.EQ.1) GO TO 130
          ELSE
C           move to next block of info
            CALL WMSSKB (WDMSFL,TLEN,
     M                   DREC,DPOS)
          END IF
C
C         move to next data position
          CALL WDNXPS (WDMSFL,RDWRFG,
     M                 DREC,DPOS,
     O                 LIND)
        ELSE
C         question terminator
          DONFG= 1
          IF (ONCNT.GT.0 .OR. OFFCNT.GT.0) THEN
C           clean up last fields arrays
            ONPTR = 0
            OFFPTR= 0
            IF (ONCNT.GT.0) THEN
C             on conditions exist,
C             need to loop through local target field numbers and values
              J= 0
              DO 160 I= 1,ONCNT,4
                ONFTFL(POINTR+J)= WOPWDC(LONTFL(I),LONTFL(I+1),
     I                                   LONTFL(I+2),LONTFL(I+3))
                ONFTVL(POINTR+J)= WOPWDC(LONTVL(I),LONTVL(I+1),
     I                                   LONTVL(I+2),LONTVL(I+3))
                J= J+ 1
 160          CONTINUE
              ONPTR = POINTR
              POINTR= POINTR+ INT(ONCNT/4)+ 1
            END IF
            IF (OFFCNT.GT.0) THEN
C             off conditions exist,
C             need to loop through local target field numbers and values
              J= 0
              DO 170 I= 1,OFFCNT,4
                ONFTFL(POINTR+J)= WOPWDC(LOFTFL(I),LOFTFL(I+1),
     I                                   LOFTFL(I+2),LOFTFL(I+3))
                ONFTVL(POINTR+J)= WOPWDC(LOFTVL(I),LOFTVL(I+1),
     I                                   LOFTVL(I+2),LOFTVL(I+3))
                J= J+ 1
 170          CONTINUE
              OFFPTR= POINTR
            END IF
C           now calculate word of pointers and counts for previous field
            OPONOF(LORDER)= WOPWDC(ONPTR,ONCNT,OFFPTR,OFFCNT)
          END IF
        END IF
      IF (DONFG.EQ.0) GO TO 100
C
      RETURN
      END
C
C
C
      SUBROUTINE   WMSDLM
     I                   (SCNOPT,ILEN,
     M                    TBUFF)
C
C     + + + PURPOSE + + +
C     Fill in delimeters in screen name with text
C     provided from application.
C
C     + + + DUMMY ARGUMENTS + + +
      INTEGER     ILEN
      CHARACTER*1 TBUFF(ILEN)
      CHARACTER*8 SCNOPT(6)
C
C     + + + ARGUMENT DEFINITIONS + + +
C     SCNOPT - text provided from application to fill in delimeters
C     ILEN   - length of string containing screen name
C     TBUFF  - screen name
C
C     + + + LOCAL VARIABLES + + +
      INTEGER     I,J,K,I1,CNUM,IPOS
      CHARACTER*1 CTMP(8),DELIM(1)
C
C     + + + FUNCTIONS + + +
      INTEGER     STRFND, ZLNTXT
C
C     + + + EXTERNALS + + +
      EXTERNAL    STRFND, ZLNTXT, CVARAR, CHRDEL, CHRINS
C
C     + + + END SPECIFICATIONS + + +
C
      I1  = 1
      DELIM(1)= '&'
C
C     look for delimeter within window name to be filled
      CNUM= 0
 10   CONTINUE
        K= STRFND(ILEN,TBUFF,I1,DELIM)
        IF (K .GT. 0) THEN
C         found delimeter, remove it
          CALL CHRDEL (ILEN,K,TBUFF)
          CNUM= CNUM+ 1
          J= ZLNTXT(SCNOPT(CNUM))
          IF (J .GT. 0) THEN
C           string to insert
            CALL CVARAR (J,SCNOPT(CNUM),J,CTMP)
            DO 20 I= 1,J
              IPOS= K+ I- 1
              IF (IPOS.LE.ILEN) THEN
C               theres room to insert character
                CALL CHRINS (ILEN,K+I-1,CTMP(I),TBUFF)
              END IF
 20         CONTINUE
          END IF
        END IF
      IF (K.GT.0 .AND. CNUM.LT.6) GO TO 10
C
      RETURN
      END
