      PROGRAM FEAT2TRI
C
C *** Standard declarations and parameter settings
      IMPLICIT DOUBLE PRECISION(A,C-H,O-U,W-Z),LOGICAL(B)
      PARAMETER (NNARR=299,NNAB=21,NNWORK=1000000)
C
C *** NBLOCA=1 means that the stiffness matrix made up of only one block,
C     analogously NBLOCF stands for the right hand side.
      PARAMETER (NBLOCA=1,NBLOCF=1)
C
C *** Standard declaration for CHARACTER quantities in /CHAR/
      CHARACTER SUB*6,FMT*15,CPARAM*120

C *** CFILE needed as filename for input in XORSC
C     ARRDA and ARRDF are used only for messages
      CHARACTER CFILE*32,ARRDA*6,ARRDF*6
C
C *** Standard dimensioning for workspace concept
      DIMENSION VWORK(1),KWORK(1)
C
      DIMENSION KABAN(NBLOCA),KFN(NBLOCF)
C
C *** BCONA, BCONF - .TRUE. if the corresponding coefficients are constant
      DIMENSION BCONA(NBLOCA),BCONF(NBLOCF)
C
C
C *** ARRDA, ARRDF - Names of matrices and right hand sides (for messages only)
      DIMENSION ARRDA(NBLOCA),ARRDF(NBLOCF)
      DIMENSION BSNGLA(NBLOCA),BSNGLF(NBLOCF)
C
C *** Standard COMMON blocks
      COMMON          NWORK,IWORK,IWMAX,L(NNARR),DWORK(NNWORK)
      COMMON /ERRCTL/ IER,ICHECK
      COMMON /CHAR/   SUB,FMT(3),CPARAM
      COMMON /TRIAD/  NEL,NVT,NMT,NVE,NVEL,NBCT,NVBD
      COMMON /TRIAA/  LCORVG,LCORMG,LVERT,LMID,LADJ,LVEL,LMEL,LNPR,LMM,
     *                LVBD,LEBD,LBCT,LVBDP,LMBDP
      COMMON /OUTPUT/ M,MT,MKEYB,MTERM,MERR,MPROT,MSYS,MTRC,IRECL8
C
C *** EQUIVALENCE statement needed for DWORK concept
      EQUIVALENCE (DWORK(1),VWORK(1),KWORK(1))
C
C *** Parametrization of the domain
      EXTERNAL PARXQ,PARYQ,TMAXQ
C *** Coefficient of stiffness matrix, right hand side, exact solution
      EXTERNAL COEFFA,RHS,UE,UEX,UEY
C *** Control of refinement - here, regular refinement is used
      EXTERNAL S2DI0,S2DB0
C *** E001 - linear element on triangular mesh ; dummy program I000 
C *** needed in call of XIE017
      EXTERNAL E001,I000
      EXTERNAL ZVALUE
C
C *** Number of terms in stiffness matrix and right hand side
      DATA KABAN/5/,KFN/1/
C *** Coefficients are constant for the matrix, but not for the right hand side
      DATA BCONA/.TRUE./,BCONF/.FALSE./
C *** Names of matrix and vector (for messages only)
      DATA ARRDA/'DA    '/,ARRDF/'DF    '/
      DATA BSNGLA/.FALSE./,BSNGLF/.FALSE./
C
C
C
C *** Initialization
C *** Default names are used for output devices
C
      CALL ZINIT(NNWORK,'feat.msg',' ',' ',' ',' ') 

C
C *** Perform elementary checks only
      ICHECK=1

      MUNITT=55

      OPEN (MUNITT,FILE='#data/trigen2d.dat')

      READ(MUNITT,*)
      READ(MUNITT,*)
      READ(MUNITT,*)
      READ(MUNITT,*)
      READ(MUNITT,*)
      READ(MUNITT,*)
      READ(MUNITT,*)
      READ(MUNITT,*)
      READ(MUNITT,*)
      READ(MUNITT,*)
      READ(MUNITT,*)
      READ(MUNITT,*) ILEV
      
      CLOSE(MUNITT)
            
C
C *** Read in coarse grid from file 'TRIA.coarse', opened as unit 55

      IF (ILEV.eq.1) THEN
        CFILE='#tries/#tria1'
      ELSE IF (ILEV.eq.2) THEN
        CFILE='#tries/#tria2'
      ELSE IF (ILEV.eq.3) THEN
        CFILE='#tries/#tria3'
      ELSE IF (ILEV.eq.4) THEN
        CFILE='#tries/#tria4'
      ELSE IF (ILEV.eq.5) THEN
        CFILE='#tries/#tria5'
      ELSE IF (ILEV.eq.6) THEN
        CFILE='#tries/#tria6'
      ELSE IF (ILEV.eq.7) THEN
        CFILE='#tries/#tria7'
      ELSE IF (ILEV.eq.8) THEN
        CFILE='#tries/#tria8'
      ELSE IF (ILEV.eq.9) THEN
        CFILE='#tries/#tria9'
      ELSE IF (ILEV.eq.10) THEN
        CFILE='#tries/#tria10'
      ENDIF
C
C
      IFMT=1
      
      CALL XORS(MUNITT,CFILE,IFMT)
      IF (IER.NE.0) GOTO 99998
      
      CLOSE(MUNITT)
      
      CFILE='#adc/devgridrefout.tri'
      CALL XOWSC1(MUNITT,CFILE)
      CLOSE(MUNITT)

C

      GOTO 99999
99998 WRITE(MTERM,*) 'IER', IER
      WRITE(MTERM,*) 'IN SUBROUTINE ',SUB
99999 END
C
C
C
C
      BLOCK DATA ZVALUE
C
      IMPLICIT DOUBLE PRECISION (A,C-H,O-U,W-Z),LOGICAL(B)
      CHARACTER SUB*6,FMT*15,CPARAM*1
      PARAMETER (NNARR=299,NNLEV=9)
      COMMON /OUTPUT/ M,MT,MKEYB,MTERM,MERR,MPROT,MSYS,MTRC,IRECL8
      COMMON /ERRCTL/ IER,ICHECK
      COMMON /CHAR/   SUB,FMT(3),CPARAM(120)
      COMMON /TRIAD/  NEL,NVT,NMT,NVE,NVEL,NBCT,NVBD
      COMMON /TRIAA/  LCORVG,LCORMG,LVERT,LMID,LADJ,LVEL,LMEL,LNPR,LMM,
     *                LVBD,LEBD,LBCT,LVBDP,LMBDP
      COMMON /TABLE/  KTYPE(NNARR),KLEN(NNARR),KLEN8(NNARR),IFLAG
      COMMON /MACROD/ NMAEL,NMAVT,NMAEDG,NMAVE,NMAVEL,NMABCT,NMAVBD
      COMMON /MACROA/ LMACVG,LMACMG,LMAVT,LMAMID,LMAADJ,LMAVEL,LMAMEL,
     *                LMANPR,LMAMM,LMAVBD,LMAEBD,LMABCT,LMAVBP,LMAMBP,
     *                LMAVE
      COMMON /MGTRD/  KNEL(NNLEV),KNVT(NNLEV),KNMT(NNLEV),
     *                KNVEL(NNLEV),KNVBD(NNLEV)
      COMMON /MGTRA/  KLCVG(NNLEV),KLCMG(NNLEV),KLVERT(NNLEV),
     *                KLMID(NNLEV),KLADJ(NNLEV),KLVEL(NNLEV),
     *                KLMEL(NNLEV),KLNPR(NNLEV),KLMM(NNLEV),
     *                KLVBD(NNLEV),KLEBD(NNLEV),KLBCT(NNLEV),
     *                KLVBDP(NNLEV),KLMBDP(NNLEV)
C
      DATA M/2/,MT/2/,MKEYB/5/,MTERM/6/,IER/0/,ICHECK/1/
      DATA MERR/11/,MPROT/12/,MSYS/13/,MTRC/14/,IRECL8/512/
      DATA SUB/'MAIN  '/
      DATA FMT/'(3D25.16)','(5E16.7)','(6I12)'/
      DATA CPARAM/120*' '/
      DATA NEL/0/,NVT/0/,NMT/0/,NVE/0/,NBCT/0/,NVEL/0/,NVBD/0/
      DATA LCORVG/0/,LCORMG/0/,LVERT/0/,LMID/0/,LADJ/0/,LVEL/0/,LMEL/0/,
     *     LNPR/0/,LMM/0/,LVBD/0/,LEBD/0/,LBCT/0/,LVBDP/0/,LMBDP/0/
      DATA KTYPE/NNARR*0/,KLEN/NNARR*0/,KLEN8/NNARR*0/,IFLAG/0/
      DATA NMAEL/0/,NMAVT/0/,NMAEDG/0/,NMAVE/0/,NMAVEL/0/,NMABCT/0/,
     *     NMAVBD/0/
      DATA LMACVG/0/,LMACMG/0/,LMAVT/0/,LMAMID/0/,LMAADJ/0/,LMAVEL/0/,
     *     LMAMEL/0/,LMANPR/0/,LMAMM/0/,LMAVBD/0/,LMAEBD/0/,LMABCT/0/,
     *     LMAVBP/0/,LMAMBP/0/,LMAVE/0/
      DATA KNEL/NNLEV*0/,KNVT/NNLEV*0/,KNMT/NNLEV*0/,
     *          KNVEL/NNLEV*0/,KNVBD/NNLEV*0/
      DATA KLCVG/NNLEV*0/,KLCMG/NNLEV*0/,KLVERT/NNLEV*0/,
     *     KLMID/NNLEV*0/,KLADJ/NNLEV*0/,KLVEL/NNLEV*0/,
     *     KLMEL/NNLEV*0/,KLNPR/NNLEV*0/,KLMM/NNLEV*0/,
     *     KLVBD/NNLEV*0/,KLEBD/NNLEV*0/,KLBCT/NNLEV*0/,
     *     KLVBDP/NNLEV*0/,KLMBDP/NNLEV*0/
C
      END


      SUBROUTINE XOWSC1(MFILE,CFILE)
C
      IMPLICIT DOUBLE PRECISION (A,C-H,O-U,W-Z),LOGICAL(B)
      CHARACTER SUB*6,FMT*15,CPARAM*120
      CHARACTER CFILE*(*)
C
      PARAMETER (NNVE=4,NNARR=299)
      DIMENSION VWORK(1),KWORK(1)
      COMMON          NWORK,IWORK,IWMAX,L(NNARR),DWORK(1)
      COMMON /OUTPUT/ M,MT,MKEYB,MTERM,MERR,MPROT,MSYS,MTRC,IRECL8
      COMMON /ERRCTL/ IER,ICHECK
      COMMON /CHAR/   SUB,FMT(3),CPARAM
      COMMON /TRIAD/  NEL,NVT,NMT,NVE,NVEL,NBCT,NVBD
      COMMON /TRIAA/  LCORVG,LCORMG,LVERT,LMID,LADJ,LVEL,LMEL,LNPR,LMM,
     *                LVBD,LEBD,LBCT,LVBDP,LMBDP
      EQUIVALENCE (DWORK(1),VWORK(1),KWORK(1))
      SAVE /OUTPUT/,/ERRCTL/,/CHAR/,/TRIAD/,/TRIAA/,/ELEFIN/
C
      SUB='XOWSC1'
      IF (ICHECK.GE.997) CALL OTRC('XOWSC1 ','05/15/95')
      IER=0
C
C *** Open I/O-file
C
      CALL OF0(MFILE,CFILE,1)
      IF (IER.NE.0) GOTO 99999
C
      WRITE (MFILE,*) 'Coarse mesh'
      WRITE (MFILE,*) 'modified by trigen2d'
      WRITE (MFILE,*) NEL,NVT,NMT,NVE,NBCT
C
      CALL OWSC1(DWORK(L(LCORVG)),DWORK(L(LVBDP)),KWORK(L(LVBD)),
     *           KWORK(L(LVERT)),KWORK(L(LNPR)),KWORK(L(LMM)),MFILE)
      IF (IER.NE.0) GOTO 99999
C
      IF (LADJ.GT.0) THEN
       CALL ZDISP(0,LADJ,'KADJ  ')
       IF (IER.NE.0) GOTO 99999
      ENDIF
C
C
99999 END
C
C-----------------------------------------------------------------------
C
      SUBROUTINE OWSC1(DCORVG,DVBDP,KVBD,KVERT,KNPR,KMM,MFILE)
C
      IMPLICIT DOUBLE PRECISION (A,C-H,O-U,W-Z),LOGICAL(B)
      CHARACTER SUB*6,FMT*15,CPARAM*120
      PARAMETER (NNVE=4)
      DIMENSION DCORVG(2,*),DVBDP(*)
      DIMENSION KVERT(NNVE,*),KNPR(*),KMM(2,*),KVBD(*)
      COMMON /OUTPUT/ M,MT,MKEYB,MTERM,MERR,MPROT,MSYS,MTRC,IRECL8
      COMMON /ERRCTL/ IER,ICHECK
      COMMON /CHAR/   SUB,FMT(3),CPARAM
      COMMON /TRIAD/  NEL,NVT,NMT,NVE,NVEL,NBCT,NVBD
      SAVE /OUTPUT/,/ERRCTL/,/CHAR/,/TRIAD/
C
      SUB='OWSC1'
      IF (ICHECK.GE.997) CALL OTRC('OWSC1  ','05/15/95')
C
      DO 5 IVBD=1,NVBD
      DCORVG(1,KVBD(IVBD))=DVBDP(IVBD)
      DCORVG(2,KVBD(IVBD))=0D0
5     CONTINUE
C
      WRITE (MFILE,*) 'DCORVG'
      DO 10 IVT=1,NVT
10    WRITE (MFILE,*) DCORVG(1,IVT),DCORVG(2,IVT)
      WRITE (MFILE,*) 'KVERT'
      DO 20 IEL=1,NEL
20    WRITE (MFILE,*) KVERT(1,IEL),KVERT(2,IEL),
     *                KVERT(3,IEL),KVERT(4,IEL)
      WRITE (MFILE,*) 'KNPR'
      DO 30 IVT=1,NVT
30    WRITE (MFILE,*) KNPR(IVT)
      WRITE (MFILE,*) 'KMM'
      DO 40 IBCT=1,NBCT
40    WRITE (MFILE,*) KMM(1,IBCT),KMM(2,IBCT)
C
C
C
99999 END
C
C-----------------------------------------------------------------------
C
      SUBROUTINE SBC2P(DCORVG,DVBDP,KVBD,NVBD)
C
      IMPLICIT DOUBLE PRECISION (A,C-H,O-U,W-Z),LOGICAL(B)
      CHARACTER SUB*6,FMT*15,CPARAM*120
      DIMENSION DCORVG(2,*),DVBDP(*),KVBD(*)
      COMMON /OUTPUT/ M,MT,MKEYB,MTERM,MERR,MPROT,MSYS,MTRC,IRECL8
      COMMON /ERRCTL/ IER,ICHECK
      COMMON /CHAR/   SUB,FMT(3),CPARAM
      SAVE /OUTPUT/,/ERRCTL/,/CHAR/
C
      SUB='SBC2P'
      IF (ICHECK.GE.997) CALL OTRC('SBC2P ','05/15/95')
C
      DO 1 IVBD=1,NVBD
      DCORVG(1,KVBD(IVBD))=DVBDP(IVBD)
      DCORVG(2,KVBD(IVBD))=0D0
1     CONTINUE
C
99999 END


      SUBROUTINE ZDISP(ILONG,LNR,ARR)
C
      IMPLICIT DOUBLE PRECISION (A,C-H,O-U,W-Z),LOGICAL(B)
      CHARACTER SUB*6,FMT*15,CPARAM*120
      CHARACTER ARR*6
      DIMENSION KWORK(1)
C
      PARAMETER (NNARR=299)
      COMMON          NWORK,IWORK,IWMAX,L(NNARR),DWORK(1)
      COMMON /OUTPUT/ M,MT,MKEYB,MTERM,MERR,MPROT,MSYS,MTRC,IRECL8
      COMMON /CHAR/   SUB,FMT(3),CPARAM
      COMMON /ERRCTL/ IER,ICHECK
      COMMON /TABLE/  KTYPE(NNARR),KLEN(NNARR),KLEN8(NNARR),IFLAG
      EQUIVALENCE     (DWORK(1),KWORK(1))
      SAVE /OUTPUT/,/ERRCTL/,/CHAR/,/TABLE/
      DATA LNR1/0/
C
      IF (ICHECK.GE.998) CALL OTRC('ZDISP ','01/02/89')
      BMSG2=M.GE.2.OR.MT.GE.2
      IER=0
      CALL ZTYPE(LNR,ITYPE)
C
      IF (ITYPE.EQ.0) THEN
C ***  Warning  LNR not specified ***
       IF (BMSG2) THEN
        WRITE (CPARAM,'(A6)') ARR
        CALL OMSG(52,'ZDISP ')
       ENDIF
       GOTO 99999
      ENDIF
C
      IF (ITYPE.LT.0) THEN
C ***  Wrong value of LNR ***
       WRITE (CPARAM,'(I15,A6)') LNR,ARR
       CALL WERR(-104,'ZDISP ')
       GOTO 99999
      ENDIF
C
C *** There is nothing to do...
      IF (ILONG.EQ.KLEN(LNR)) GOTO 99999
C
      IF (IFLAG.NE.0) THEN
C
C *** Block 1
C *** Last call of ZNEW using ILONG=0
C
       IF (LNR.NE.IFLAG) THEN
C ***   Warning IFLAG<>LNR ***
        WRITE (CPARAM,'(A6,2I15)') ARR,LNR,IFLAG
        CALL OMSG(51,'ZDISP ')
C ***   Use IFLAG instead of the given LNR
        LNR=IFLAG
       ENDIF
C ***  Array LNR is the last array on DWORK
       L1=L(LNR)
C ***  Determine correct length corresponding to datatype
       JLONG=ILONG
       IF (ITYPE.GT.1) THEN
        JLONG=(JLONG+1)/2
        L1=(L1+1)/2
       ENDIF
       IF (JLONG.GT.KLEN8(LNR)) GOTO 300
       IWORK=L1+JLONG-1
       IWMAX=MAX(IWMAX,IWORK)
       IFLAG=0
C
      ELSE
C
C *** Block 2
C *** Last call of ZNEW using ILONG > 0
C
C ***  Determine correct length corresponding to datatype
       JLONG=ILONG
       IF (ITYPE.GT.1) JLONG=(JLONG+1)/2
C ***  Determine correct offset according to data type ***
       ID=KLEN8(LNR)-JLONG
C
       IF (ID.LT.0) GOTO 300
C
C ***  Adjust starting address corresponding to datatype REAL*8
       DO 210 IARR=1,NNARR
       IF (L(IARR).GE.1.AND.KTYPE(IARR).GT.1) L(IARR)=(L(IARR)+1)/2
210    CONTINUE
C
C ***  Find first element of the next array ***
       J0=L(LNR)+KLEN8(LNR)
C ***  Present array is the last array?
       IF (J0.EQ.IWORK+1) GOTO 240
C ***  Revise L ***
       DO 220 IARR=1,NNARR
       IF (L(IARR).GT.L(LNR)) L(IARR)=L(IARR)-ID
220    CONTINUE
C ***  Compress DWORK copying INTEGER*4 elements ***
C       J1=J0*2-1
C       CALL LCP3(KWORK(J1),KWORK(J1-2*ID),2*(IWORK-J0+1))
       DO 230 J1=J0*2-1,2*IWORK
230    KWORK(J1-2*ID)=KWORK(J1)
C
C ***  Determine new value of IWORK ***
240    IWORK=IWORK-ID
C
C ***  Adjust starting address corresponding to datatype
       DO 250 IARR=1,NNARR
       IF (L(IARR).GE.1.AND.KTYPE(IARR).GT.1) L(IARR)=2*L(IARR)-1
250    CONTINUE
C
      ENDIF
C
      KLEN(LNR)=ILONG
      IF (ILONG.EQ.0) THEN
C ***  Delete array LNR if ILONG=0 ***
       L(LNR)=0
       KTYPE(LNR)=0
       KLEN8(LNR)=0
       LNR1=LNR
       LNR=0
      ELSE
       KLEN8(LNR)=JLONG
      ENDIF
C
      IF (ILONG.EQ.0) THEN
       WRITE (CPARAM,'(A6,I15)') ARR,LNR1
       CALL OMSG(3,'ZDISP ')
      ELSE
       WRITE (CPARAM,'(A6,2I15)') ARR,LNR,ILONG
       CALL OMSG(4,'ZDISP ')
      ENDIF
      GOTO 99999
C
C *** Error *** Length > length of array LNR ***
300   WRITE (CPARAM,'(A6)') ARR
      CALL WERR(-105,'ZDISP ')
C
99999 END

      SUBROUTINE ZTYPE(LNR,LTYPE)
C
      PARAMETER (NNARR=299)
      COMMON /ERRCTL/ IER,ICHECK
      COMMON /TABLE/  KTYPE(NNARR),KLEN(NNARR),KLEN8(NNARR),IFLAG
      SAVE /TABLE/
C
      IF (ICHECK.EQ.999) CALL OTRC('ZTYPE ','01/02/89')
C
      IF (LNR.GT.0.AND.LNR.LE.NNARR) THEN
       LTYPE=KTYPE(LNR)
      ELSE IF (LNR.EQ.0) THEN
       LTYPE=0
      ELSE
       LTYPE=-1
      ENDIF
C
      END


      SUBROUTINE ZINIT(NNWORK,CMSG,CERR,CPRT,CSYS,CTRC)
C
      IMPLICIT DOUBLE PRECISION (A,C-H,O-U,W-Z),LOGICAL(B)
      CHARACTER SUB*6,FMT*15,CPARAM*120
      CHARACTER*(*) CMSG,CERR,CPRT,CSYS,CTRC,BLANK
      PARAMETER (NNARR=299)
      PARAMETER (BLANK=' ')
      COMMON          NWORK,IWORK,IWMAX,L(NNARR),DWORK(1)
      COMMON /OUTPUT/ M,MT,MKEYB,MTERM,MERR,MPROT,MSYS,MTRC,IRECL8
      COMMON /CHAR/   SUB,FMT(3),CPARAM
      SAVE /OUTPUT/,/CHAR/
      SAVE BFIRST
      DATA BFIRST/.TRUE./
C
C *** This step is performed only once
C
      IF (BFIRST) THEN
       NWORK=NNWORK
       IWORK=0
       IWMAX=0
       DO 10 IARR=1,NNARR
10     L(IARR)=0
       DTIMEH=-1D0
C       CALL ZTIME(DTIMEH)
C
      ELSE
C
       CLOSE (10)
       CLOSE (MERR)
       CLOSE (MPROT)
       CLOSE (MSYS)
       CLOSE (MTRC)
C
      ENDIF
C
      IF (MTRC.NE.MTERM.AND.MTRC.NE.MERR.AND.MTRC.NE.MPROT
     *    .AND.MTRC.NE.MSYS) THEN
       IF (CTRC(1:1).EQ.BLANK) THEN
        OPEN (MTRC,FILE='FEAT.TRC',ERR=100)
       ELSE
        OPEN (MTRC,FILE=CTRC,ERR=100)
       ENDIF
      ENDIF
C
      IF (MERR.NE.MTERM.AND.MERR.NE.MPROT) THEN
       IF (CERR(1:1).EQ.BLANK) THEN
        OPEN (MERR,FILE='FEAT.ERR',ERR=100)
       ELSE
        OPEN (MERR,FILE=CERR,ERR=100)
       ENDIF
      ENDIF
C
      IF (MSYS.NE.MTERM.AND.MSYS.NE.MERR.AND.MSYS.NE.MPROT) THEN
       IF (CSYS(1:1).EQ.BLANK) THEN
        OPEN (MSYS,FILE='FEAT.SYS',ERR=100)
       ELSE
        OPEN (MSYS,FILE=CSYS,ERR=100)
       ENDIF
      ENDIF
C
      IF (MPROT.NE.MTERM) THEN
       IF (CPRT(1:1).EQ.BLANK) THEN
        OPEN (MPROT,FILE='FEAT.PRT',ERR=100)
       ELSE
        OPEN (MPROT,FILE=CPRT,ERR=100)
       ENDIF
      ENDIF
C
      IF (CMSG(1:1).EQ.BLANK) THEN
       OPEN (10,FILE='FEAT.MSG',STATUS='OLD',ERR=100)
      ELSE
       OPEN (10,FILE=CMSG,STATUS='OLD',ERR=100)
      ENDIF
      WRITE (CPARAM,'(I15)') 9
      CALL OMSG(1,'ZINIT ')
      CALL OERR(1,'ZINIT ')
      CALL OTRC('ZINIT ','T')
C
      GOTO 99999
C
100   CALL OMSG(0,'ZINIT ')
      CALL OERR(0,'ZINIT ')
      CALL OTRC('ZINIT ','F')
      WRITE (MTERM,10000)
C
10000 FORMAT(' *** ZINIT  ***  ERROR DURING INITIALIZATION,',
     *                         ' NO MESSAGES DISPLAYED')
C
99999 BFIRST=.FALSE.
      END


      SUBROUTINE OTRC(SUB,VER)
C
      CHARACTER SUB*6,VER*8
      LOGICAL BTRC
      COMMON /OUTPUT/ M,MT,MKEYB,MTERM,MERR,MPROT,MSYS,MTRC,IRECL8
      SAVE /OUTPUT/
      SAVE BTRC
      DATA BTRC/.FALSE./
C
      IF (SUB(1:5).EQ.'ZINIT') THEN
       BTRC=VER(1:1).EQ.'T'
      ELSE IF (BTRC) THEN
       WRITE (MTRC,10000) SUB,VER
10000  FORMAT(' Name:  ',A,'   Version from:  ',A)
      ENDIF
C
      END

      SUBROUTINE OMSG(IMSG,SUB0)
C
      IMPLICIT DOUBLE PRECISION (A,C-H,O-U,W-Z),LOGICAL(B)
      CHARACTER SUB*6,FMT*15,CPARAM*120
      CHARACTER SUB0*6,A1*6,A2*6,A3*60,CFMT*140,CFMT0*140,CLAST*140
C
      PARAMETER (NNFMT=9,NNMSG=99)
      DIMENSION CFMT(NNFMT),IFMT(NNFMT),KMT(NNMSG),KM(NNMSG)
      COMMON /OUTPUT/ M,MT,MKEYB,MTERM,MERR,MPROT,MSYS,MTRC,IRECL8
      COMMON /CHAR/   SUB,FMT(3),CPARAM
      SAVE /OUTPUT/,/CHAR/
      SAVE IFMT,CFMT,KM,KMT,BMSG,CLAST,LASTF,LASTMS,LASTM,LASTMT,NMSG
      DATA IFMT/NNFMT*0/,BMSG/.FALSE./,LASTMS/0/
      DATA KM/NNMSG*-99/,KMT/NNMSG*-99/,NMSG/0/,LASTF/0/
C
C *** Initialization
      IF (SUB0.EQ.'ZINIT ') THEN
       BMSG=IMSG.EQ.1
       IF (BMSG) THEN
        READ (CPARAM,'(I15)') NFMT
        NMSG=MIN(NFMT,NNFMT)
        DO 2 JFMT=1,NMSG
        CFMT(JFMT)='('' ***'',A7,'' *** '','
        CFMT(JFMT)(140:140)=')'
2       READ (10,'(I5,2I2,I3,A)',ERR=99999)
     *        I,KM(JFMT),KMT(JFMT),IFMT(JFMT),CFMT(JFMT)(20:139)
        CLAST='('' ***'',A7,'' *** '','
        CLAST(140:140)=')'
C       
        DO 3 JFMT=NMSG+1,NNMSG
        READ (10,'(I5,2I2)',ERR=99999) IMSG0,M0,MT0
        IF (IMSG0.GT.NNMSG) THEN
         REWIND (10)
         GOTO 99999
        ENDIF
        KM(IMSG0)=M0
3       KMT(IMSG0)=MT0
C        
      ENDIF
C
      ELSE IF (BMSG) THEN
C
       IF (KM(IMSG).EQ.-99) GOTO 99999
       IF (IMSG.GT.6) THEN
        MOUT=MPROT
       ELSE
        MOUT=MSYS
       ENDIF
       BTERM=MT.GE.KMT(IMSG)
       BPROT=M.GE.KM(IMSG).AND.MOUT.GE.0
       IF (.NOT.BTERM.AND..NOT.BPROT) GOTO 99999
       IF (MOUT.EQ.MTERM) THEN
        BPROT=.FALSE.
        BTERM=.TRUE.
       ENDIF
C
       IF (IMSG.LE.NMSG) THEN
        IFMT0=IFMT(IMSG)
        CFMT0=CFMT(IMSG)
       ELSE IF (IMSG.EQ.LASTMS) THEN
        IFMT0=LASTF
        CFMT0=CLAST
       ELSE
        IF (LASTMS.GT.IMSG) REWIND (10)
1       READ (10,'(I5)',ERR=99999) LASTMS
        IF (LASTMS.LT.IMSG) GOTO 1
        BACKSPACE (10)
        READ (10,'(I5,2I2,I3,A)',ERR=99999)
     *        LASTMS,LASTM,LASTMT,LASTF,CLAST(20:139)
        IF (LASTMS.GT.IMSG) GOTO 99999
        IFMT0=LASTF
        CFMT0=CLAST
       ENDIF
C
       GOTO (10,20,30,40,50,60,70,80,90,100,110,120,130,140) IFMT0
       GOTO 99999

10     IF (BPROT) WRITE (MOUT,CFMT0) SUB0
       IF (BTERM) WRITE (MTERM,CFMT0) SUB0
       GOTO 99999

20     READ (CPARAM,'(A6,2I15)') A1,I1,I2
       IF (BPROT) WRITE (MOUT,CFMT0) SUB0,A1,I1,I2
       IF (BTERM) WRITE (MTERM,CFMT0) SUB0,A1,I1,I2
       GOTO 99999
C
30     READ (CPARAM,'(A6,I15)') A1,I1
       IF (BPROT) WRITE (MOUT,CFMT0) SUB0,A1,I1
       IF (BTERM) WRITE (MTERM,CFMT0) SUB0,A1,I1
       GOTO 99999
C
40     READ (CPARAM,'(A6)') A1
       IF (BPROT) WRITE (MOUT,CFMT0) SUB0,A1
       IF (BTERM) WRITE (MTERM,CFMT0) SUB0,A1
       GOTO 99999
C
50     READ (CPARAM,'(I15,A6)') I1,A1
       IF (BPROT) WRITE (MOUT,CFMT0) SUB0,I1,A1
       IF (BTERM) WRITE (MTERM,CFMT0) SUB0,I1,A1
       GOTO 99999
C
60     READ (CPARAM,'(A6,I15,A6,I15)') A1,I1,A2,I2
       IF (BPROT) WRITE (MOUT,CFMT0) SUB0,A1,I1,A2,I2
       IF (BTERM) WRITE (MTERM,CFMT0) SUB0,A1,I1,A2,I2
       GOTO 99999
C
70     CONTINUE
C       READ (CPARAM,'(A15,I15,A6)') A3,I1,A1
C       IF (BPROT) WRITE (MOUT,CFMT0) SUB0,A3,I1,A1
C       IF (BTERM) WRITE (MTERM,CFMT0) SUB0,A3,I1,A1
C       GOTO 99999
C
80     READ (CPARAM,'(I15)') I1
       IF (BPROT) WRITE (MOUT,CFMT0) SUB0,I1
       IF (BTERM) WRITE (MTERM,CFMT0) SUB0,I1
       GOTO 99999
C
90     READ (CPARAM,'(A60,2I15)') A3,I1,I2
       DO 91 IPOS=1,140
91     IF (CFMT0(IPOS:IPOS).EQ.'?') GOTO 92
92     WRITE (CFMT0(IPOS:IPOS+1),'(I2)') I2
       IF (BPROT) WRITE (MOUT,CFMT0) SUB0,A3(1:I2),I1
       IF (BTERM) WRITE (MTERM,CFMT0) SUB0,A3(1:I2),I1
       CFMT0(IPOS:IPOS+1)='??'
       GOTO 99999
C
100    READ (CPARAM,'(A60,2I15)') A3,I1,I2
       DO 101 IPOS=1,140
101    IF (CFMT0(IPOS:IPOS).EQ.'?') GOTO 102
102    WRITE (CFMT0(IPOS:IPOS+1),'(I2)') I2
       IF (BPROT) WRITE (MOUT,CFMT0) SUB0,I1,A3
       IF (BTERM) WRITE (MTERM,CFMT0) SUB0,I1,A3
       CFMT0(IPOS:IPOS+1)='??'
       GOTO 99999
C
110    READ (CPARAM,'(2I15)') I1,I2
       IF (BPROT) WRITE (MOUT,CFMT0) SUB0,I1,I2
       IF (BTERM) WRITE (MTERM,CFMT0) SUB0,I1,I2
       GOTO 99999
C
120    READ (CPARAM,'(I15,D25.16)') I1,D1
       IF (BPROT) WRITE (MOUT,CFMT0) SUB0,I1,D1
       IF (BTERM) WRITE (MTERM,CFMT0) SUB0,I1,D1
       GOTO 99999
C
130    READ (CPARAM,'(I15,2D25.16)') I1,D1,D2
       IF (BPROT) WRITE (MOUT,CFMT0) SUB0,I1,D1,D2
       IF (BTERM) WRITE (MTERM,CFMT0) SUB0,I1,D1,D2
       GOTO 99999
C
140    READ (CPARAM,'(D25.16)') D1
       IF (BPROT) WRITE (MOUT,CFMT0) SUB0,D1
       IF (BTERM) WRITE (MTERM,CFMT0) SUB0,D1
       GOTO 99999
C
      ENDIF
C
99999 END


      SUBROUTINE XORS(MFILE,CFILE,IFMT)
C
      IMPLICIT DOUBLE PRECISION (A,C-H,O-U,W-Z),LOGICAL(B)
      CHARACTER SUB*6,FMT*15,CPARAM*120,TMP*16
      CHARACTER CFILE*(*)
      PARAMETER (NNARR=299)
      DIMENSION VWORK(1),KWORK(1)
      COMMON          NWORK,IWORK,IWMAX,L(NNARR),DWORK(1)
      COMMON /OUTPUT/ M,MT,MKEYB,MTERM,MERR,MPROT,MSYS,MTRC,IRECL8
      COMMON /ERRCTL/ IER,ICHECK
      COMMON /CHAR/   SUB,FMT(3),CPARAM
      COMMON /TRIAD/  NEL,NVT,NMT,NVE,NVEL,NBCT,NVBD
      COMMON /TRIAA/  LCORVG,LCORMG,LVERT,LMID,LADJ,LVEL,LMEL,LNPR,LMM,
     *                LVBD,LEBD,LBCT,LVBDP,LMBDP
      EQUIVALENCE (DWORK(1),VWORK(1),KWORK(1))
      SAVE /OUTPUT/,/ERRCTL/,/CHAR/,/TRIAD/,/TRIAA/
C
      SUB='XORS'
      IF (ICHECK.GE.997) CALL OTRC('XORS  ','12/11/89')
      IER=0
C
C *** Open I/O-file
C
      CALL OF0(MFILE,CFILE,IFMT)
      IF (IER.NE.0) GOTO 99999
C
      IF (IFMT.EQ.1) THEN
       READ (MFILE,'(5I15)',ERR=99997,END=99997)
     *                                  LCM0,LMID0,LADJ0,LVEL0,LMEL0
       READ (MFILE,'(5I15)',ERR=99997,END=99997)
     *                         LVBD0,LEBD0,LBCT0,LVBDP0,LMBDP0
       READ (MFILE,'(7I15)',ERR=99997,END=99997)
     *                                  NEL,NVT,NMT,NVE,NVEL,NBCT,NVBD
      ELSE
       READ (MFILE,ERR=99997,END=99997) LCM0,LMID0,LADJ0,LVEL0,LMEL0
       READ (MFILE,ERR=99997,END=99997) LVBD0,LEBD0,LBCT0,LVBDP0,LMBDP0
       READ (MFILE,ERR=99997,END=99997) NEL,NVT,NMT,NVE,NVEL,NBCT,NVBD
      ENDIF
C
      TMP='DCORVG'
      CALL XORA(LCORVG,TMP,MFILE,CFILE,IFMT)
      IF (IER.NE.0) GOTO 99997
      IF (LCM0.GT.0) THEN
       TMP='DCORMG'
       CALL XORA(LCORMG,TMP,MFILE,CFILE,IFMT)
       IF (IER.NE.0) GOTO 99997
      ENDIF
      TMP='KVERT '
      CALL XORA(LVERT,TMP,MFILE,CFILE,IFMT)
      IF (IER.NE.0) GOTO 99997
      IF (LMID0.GT.0) THEN
       TMP='KMID  ' 
       CALL XORA(LMID,TMP,MFILE,CFILE,IFMT)
       IF (IER.NE.0) GOTO 99997
      ENDIF
      IF (LADJ0.GT.0) THEN
       TMP='KADJ  '
       CALL XORA(LADJ,TMP,MFILE,CFILE,IFMT)
       IF (IER.NE.0) GOTO 99997
      ENDIF
      IF (LVEL0.GT.0) THEN
       TMP='KVEL  '
       CALL XORA(LVEL,TMP,MFILE,CFILE,IFMT)
       IF (IER.NE.0) GOTO 99997
      ENDIF
      IF (LMEL0.GT.0) THEN
       TMP='KMEL  '
       CALL XORA(LMEL,TMP,MFILE,CFILE,IFMT)
       IF (IER.NE.0) GOTO 99997
      ENDIF
      IF (LVBD0.GT.0) THEN
       TMP='KVBD  '
       CALL XORA(LVBD,TMP,MFILE,CFILE,IFMT)
       IF (IER.NE.0) GOTO 99997
      ENDIF
      IF (LEBD0.GT.0) THEN
       TMP='KEBD  '
       CALL XORA(LEBD,TMP,MFILE,CFILE,IFMT)
       IF (IER.NE.0) GOTO 99997
      ENDIF
      IF (LBCT0.GT.0) THEN
       TMP='KBCT  '
       CALL XORA(LBCT,TMP,MFILE,CFILE,IFMT)
       IF (IER.NE.0) GOTO 99997
      ENDIF
      IF (LVBDP0.GT.0) THEN
       TMP='DVBDP '
       CALL XORA(LVBDP,TMP,MFILE,CFILE,IFMT)
       IF (IER.NE.0) GOTO 99997
      ENDIF
      IF (LMBDP0.GT.0) THEN
       TMP='DMBDP '
       CALL XORA(LMBDP,TMP,MFILE,CFILE,IFMT)
       IF (IER.NE.0) GOTO 99997
      ENDIF
      TMP='KNPR  '
      CALL XORA(LNPR,TMP,MFILE,CFILE,IFMT)
      IF (IER.NE.0) GOTO 99997
      TMP='KMM   '
      CALL XORA(LMM,TMP,MFILE,CFILE,IFMT)
      IF (IER.EQ.0) GOTO 99999
C
99997 WRITE (CPARAM,'(I15)') MFILE
      CALL WERR(-110,'XORS  ')
C
99999 END


      SUBROUTINE OERR(IER,SUB0)
C
      IMPLICIT DOUBLE PRECISION (A,C-H,O-U,W-Z),LOGICAL(B)
      CHARACTER SUB*6,FMT*15,CPARAM*120
      CHARACTER SUB0*6,A1*6,A2*6,A3*60,CFMT*140
C
      COMMON /OUTPUT/ M,MT,MKEYB,MTERM,MERR,MPROT,MSYS,MTRC,IRECL8
      COMMON /CHAR/   SUB,FMT(3),CPARAM
      SAVE /OUTPUT/,/CHAR/
      SAVE BERR
      DATA BERR/.FALSE./
C
C *** Initialization
      IF (SUB0.EQ.'ZINIT ') THEN 
       BERR=IER.EQ.1
C
      ELSE IF (BERR) THEN
C
       CFMT='('' ***'',A7,'' *** ERROR , IER = '',I4,2X'
       CFMT(140:140)=')'
1      READ (10,'(I5)',ERR=99999) IERR
       IF (IERR.NE.-IER) GOTO 1
       BACKSPACE (10)
       READ (10,'(I5,2I2,I3,A)',ERR=99999) IERR,M0,MT0,IFMT,CFMT(40:139)
       REWIND (10)
       IF (IERR.GT.-IER) GOTO 99999
C
       BTERM=MT.GE.MT0
       BERR0=M.GE.M0.AND.MERR.GE.0
       IF (.NOT.BTERM.AND..NOT.BERR0) GOTO 99999
       IF (MERR.EQ.MTERM) THEN
        BERR0=.FALSE.
        BTERM=.TRUE.
       ENDIF
C
C
       GOTO (10,20,30,40,50,60,70,80,90,100,110,120,130,140) IFMT
       GOTO 99999
C
10     IF (BERR0) WRITE (MERR,CFMT) SUB0,IER
       IF (BTERM) WRITE (MTERM,CFMT) SUB0,IER
       GOTO 99999
C
20     READ (CPARAM,'(A6,2I15)') A1,I1,I2
       IF (BERR0) WRITE (MERR,CFMT) SUB0,IER,A1,I1,I2
       IF (BTERM) WRITE (MTERM,CFMT) SUB0,IER,A1,I1,I2
       GOTO 99999
C
30     READ (CPARAM,'(A6,I15)') A1,I1
       IF (BERR0) WRITE (MERR,CFMT) SUB0,IER,A1,I1
       IF (BTERM) WRITE (MTERM,CFMT) SUB0,IER,A1,I1
       GOTO 99999
C
40     READ (CPARAM,'(A6)') A1
       IF (BERR0) WRITE (MERR,CFMT) SUB0,IER,A1
       IF (BTERM) WRITE (MTERM,CFMT) SUB0,IER,A1
       GOTO 99999
C
50     READ (CPARAM,'(I15,A6)') I1,A1
       IF (BERR0) WRITE (MERR,CFMT) SUB0,IER,I1,A1
       IF (BTERM) WRITE (MTERM,CFMT) SUB0,IER,I1,A1
       GOTO 99999
C
60     READ (CPARAM,'(A6,I15,A6,I15)') A1,I1,A2,I2
       IF (BERR0) WRITE (MERR,CFMT) SUB0,IER,A1,I1,A2,I2
       IF (BTERM) WRITE (MTERM,CFMT) SUB0,IER,A1,I1,A2,I2
       GOTO 99999
C
70     READ (CPARAM,'(A15,I15,A6)') A3,I1,A1
       IF (BERR0) WRITE (MERR,CFMT) SUB0,IER,A3,I1,A1
       IF (BTERM) WRITE (MTERM,CFMT) SUB0,IER,A3,I1,A1
       GOTO 99999
C
80     READ (CPARAM,'(I15)') I1
       IF (BERR0) WRITE (MERR,CFMT) SUB0,IER,I1
       IF (BTERM) WRITE (MTERM,CFMT) SUB0,IER,I1
       GOTO 99999
C
90     READ (CPARAM,'(A60,2I15)') A3,I1,I2
       DO 91 IPOS=1,140
91     IF (CFMT(IPOS:IPOS).EQ.'?') GOTO 92
92     WRITE (CFMT(IPOS:IPOS+1),'(I2)') I2
       IF (BERR0) WRITE (MERR,CFMT) SUB0,IER,A3,I1
       IF (BTERM) WRITE (MTERM,CFMT) SUB0,IER,A3,I1
       GOTO 99999
C
100    READ (CPARAM,'(A60,2I15)') A3,I1,I2
       DO 101 IPOS=1,140
101    IF (CFMT(IPOS:IPOS).EQ.'?') GOTO 102
102    WRITE (CFMT(IPOS:IPOS+1),'(I2)') I2
       IF (BERR0) WRITE (MERR,CFMT) SUB0,IER,I1,A3
       IF (BTERM) WRITE (MTERM,CFMT) SUB0,IER,I1,A3
       GOTO 99999
C
110    READ (CPARAM,'(2I15)') I1,I2
       IF (BERR0) WRITE (MERR,CFMT) SUB0,IER,I1,I2
       IF (BTERM) WRITE (MTERM,CFMT) SUB0,IER,I1,I2
       GOTO 99999
C
120    READ (CPARAM,'(I15,D25.16)') I1,D1
       IF (BERR0) WRITE (MERR,CFMT) SUB0,IER,I1,D1
       IF (BTERM) WRITE (MTERM,CFMT) SUB0,IER,I1,D1
       GOTO 99999
C
130    READ (CPARAM,'(I15,2D25.16)') I1,D1,D2
       IF (BERR0) WRITE (MERR,CFMT) SUB0,IER,I1,D1,D2
       IF (BTERM) WRITE (MTERM,CFMT) SUB0,IER,I1,D1,D2
       GOTO 99999
C
140    READ (CPARAM,'(D25.16)') D1
       IF (BERR0) WRITE (MERR,CFMT) SUB0,IER,D1
       IF (BTERM) WRITE (MTERM,CFMT) SUB0,IER,D1
       GOTO 99999
C
      ENDIF
C
99999 END


      SUBROUTINE OF0(MFILE,CFILE,IFMT)
C
      IMPLICIT DOUBLE PRECISION (A,C-H,O-U,W-Z),LOGICAL(B)
      CHARACTER SUB*6,FMT*15,CPARAM*120
      CHARACTER CFILE*(*),FM*11
      PARAMETER (NNARR=299)
      DIMENSION FM(0:1)
      COMMON /OUTPUT/ M,MT,MKEYB,MTERM,MERR,MPROT,MSYS,MTRC,IRECL8
      COMMON /ERRCTL/ IER,ICHECK
      COMMON /CHAR/   SUB,FMT(3),CPARAM
      SAVE /OUTPUT/,/ERRCTL/,/CHAR/,FM
      DATA FM/'UNFORMATTED','FORMATTED  '/
C
      IF (ICHECK.GE.997) CALL OTRC('OF0   ','12/11/89')
C
      IER=0
      BWARN=.FALSE.
C
      ILEN0=LEN(CFILE)
      IF (ILEN0.GT.60) THEN
       CALL WERR(-109,SUB)
       GOTO 99999
      ENDIF
      CPARAM(1:60)=CFILE
      ILEN=ILEN0
C
C *** Valid unit number ?
C
1     IRETRY=0
2     IF (MFILE.EQ.0) THEN
       CALL OMSG(9,SUB)
       READ (MKEYB,*) MFILE
       READ (MKEYB,'(A)') CPARAM(1:60)
       DO 3 ILEN=1,60
3      IF (CPARAM(ILEN:ILEN).EQ.' ') GOTO 4
4      ILEN=ILEN-1
      ENDIF
      ICLOSE=0
C
      IF ((MFILE.LE.15).OR.(MFILE.GT.80)) THEN
       WRITE (CPARAM,'(I15,A6)') MFILE,ARR
       CALL OMSG(30,SUB)
       IF (IRETRY.GT.3) THEN
        WRITE (CPARAM,'(I15)') MFILE
        CALL WERR(-110,SUB)
        GOTO 99999
       ELSE
        IRETRY=IRETRY+1
        MFILE=0
        GOTO 2
       ENDIF
      ENDIF
C
      INQUIRE(UNIT=MFILE,OPENED=BOPEN,NAMED=BNAMED,NAME=CPARAM(61:120))
      IF (ICHECK.GT.0.AND.BOPEN) THEN
       IF (BNAMED.AND.CPARAM(1:60).NE.CPARAM(61:120)) THEN
        BWARN=.TRUE.
        DO 5 ILEN1=61,120
5       IF (CPARAM(ILEN1:ILEN1).EQ.' ') GOTO 6
6       ILEN1=ILEN1-61
        CPARAM(1:60)=CPARAM(61:120)
        WRITE (CPARAM(61:120),'(2I15)') MFILE,ILEN1
        CALL OMSG(32,SUB)
       ELSE IF (.NOT.BNAMED.AND.CPARAM(1:7).NE.'SCRATCH') THEN
        BWARN=.TRUE.
        WRITE (CPARAM,'(I15)') MFILE
        CALL OMSG(33,SUB)
       ENDIF
       IF (BWARN) THEN
        BWARN=.FALSE.
        CALL OMSG(34,SUB)
        READ (MKEYB,*) ICORR
        CALL OMSG(35,SUB)
        READ (MKEYB,*) ICLOSE
        IF (ICLOSE.EQ.1) CLOSE (MFILE)
        IF (ICORR.EQ.1) THEN
         MFILE=0
         GOTO 1
        ENDIF
       ENDIF
      ENDIF
C
100   IF (.NOT.BOPEN.OR.ICLOSE.EQ.1) THEN
       IF (CPARAM(1:7).EQ.'SCRATCH') THEN
        OPEN(UNIT=MFILE,STATUS='SCRATCH',FORM=FM(IFMT),IOSTAT=ICHK)
        IF (ICHK.NE.0) THEN
         WRITE (CPARAM(61:120),'(2I15)') MFILE,ILEN
         CALL WERR(-112,SUB)
         GOTO 99999
        ENDIF
       ELSE
        IF (CPARAM(1:1).EQ.' ') GOTO 99998
        OPEN(UNIT=MFILE,FILE=CFILE,FORM=FM(IFMT),IOSTAT=ICHK)
        IF (ICHK.NE.0) GOTO 99998
       ENDIF
      ENDIF
C
      GOTO 99999
C
C
99998 WRITE (CPARAM(61:120),'(2I15)') MFILE,ILEN
      CALL OMSG(31,SUB)
      IF (IRETRY.GT.3) THEN
       WRITE (CPARAM(61:120),'(2I15)') MFILE,ILEN
       CALL WERR(-112,SUB)
       GOTO 99999
      ENDIF
      IRETRY=IRETRY+1
      CALL OMSG(9,SUB)
      READ(MKEYB,'(I15)') MFILE
      READ(MKEYB,'(A)') CPARAM(1:60)
      GOTO 100
C
99999 IF (ILEN.GT.ILEN0) CALL OMSG(36,SUB)
      CFILE=CPARAM(1:ILEN)
C
      END


      SUBROUTINE XORA(LNR,ARR,MFILE,CFILE,IFMT)
C
      IMPLICIT DOUBLE PRECISION (A,C-H,O-U,W-Z),LOGICAL(B)
      CHARACTER SUB*6,FMT*15,CPARAM*120
      CHARACTER ARR*6,CFILE*(*),CFORM*15
      PARAMETER (NNARR=299)
      DIMENSION VWORK(1),KWORK(1)
      COMMON          NWORK,IWORK,IWMAX,L(NNARR),DWORK(1)
      COMMON /OUTPUT/ M,MT,MKEYB,MTERM,MERR,MPROT,MSYS,MTRC,IRECL8
      COMMON /ERRCTL/ IER,ICHECK
      COMMON /CHAR/   SUB,FMT(3),CPARAM
      EQUIVALENCE (DWORK(1),VWORK(1),KWORK(1))
      SAVE /OUTPUT/,/ERRCTL/,/CHAR/
C
      SUB='XORA'
      IF (ICHECK.GE.997) CALL OTRC('XORA  ','12/11/89')
C
      IER=0
      BWARN=.FALSE.
      BFMT=IFMT.EQ.1
C
C *** Valid array number - 0 means that array does not yet exist
C
      IF ((LNR.LT.0).OR.(LNR.GT.NNARR)) THEN
       WRITE (CPARAM,'(A6)') ARR
       CALL WERR(-106,'XORA  ')
       GOTO 99999
      ENDIF
C
C *** Open I/O-file
C
      CALL OF0(MFILE,CFILE,IFMT)
      IF (IER.NE.0) GOTO 99999
C
      IF (BFMT) THEN
       READ (MFILE,'(2A15,2I15)',ERR=99997,END=99997)
     *       ARR,CFORM,ITYPE,ILEN
      ELSE
       READ (MFILE,ERR=99997,END=99997) ARR,ITYPE,ILEN,ILEN8,JRECL
      ENDIF
C
      IF ((ITYPE.LT.1).OR.(ITYPE.GT.3).OR.(ILEN.LT.1)) GOTO 99997
C
      IF (LNR.EQ.0) THEN
       CALL ZNEW(ILEN,-ITYPE,LNR,ARR)
       IF (IER.NE.0) GOTO 99999
      ELSE
       CALL ZTYPE(LNR,JTYPE)
       IF (ITYPE.NE.JTYPE) THEN
        WRITE (CPARAM,'(A6,I15)') ARR,MFILE
        CALL WERR(-113,'XORA  ')
        GOTO 99999
       ELSE
        CALL ZLEN(LNR,JLEN)
        IF (JLEN.LT.ILEN) THEN
         CALL ZDISP(0,LNR,ARR)
         CALL ZNEW(ILEN,-ITYPE,LNR,ARR)
         IF (IER.NE.0) GOTO 99999
        ENDIF
       ENDIF
      ENDIF
C
      L1=L(LNR)
      IF (BFMT) THEN
       GOTO (111,222,333),ITYPE
111    READ(MFILE,CFORM,ERR=99997,END=99997) (DWORK(L1+I),I=0,ILEN-1)
       GOTO 555
222    READ(MFILE,CFORM,ERR=99997,END=99997) (VWORK(L1+I),I=0,ILEN-1)
       GOTO 555
333    READ(MFILE,CFORM,ERR=99997,END=99997) (KWORK(L1+I),I=0,ILEN-1)
555    CONTINUE
      ELSE
       IF (ITYPE.GT.1) L1=(L1+1)/2
       CALL ORA0(DWORK(L1),ILEN8,MFILE,JRECL)
       IF (IER.NE.0) GOTO 99999
      ENDIF
C
      WRITE (CPARAM,'(A6,2I15)') ARR,LNR,MFILE
      CALL OMSG(7,'XORA  ')
      GOTO 99999
C
99997 WRITE (CPARAM,'(A6,2I15)') MFILE
      CALL WERR(-110,'XORA  ')
C
99999 END
C
C
C
      SUBROUTINE ORA0(DX,N,MFILE,IRECL8)
      IMPLICIT DOUBLE PRECISION (A,C-H,O-U,W-Z),LOGICAL(B)
      CHARACTER SUB*6,FMT*15,CPARAM*120
      DIMENSION DX(*)
      COMMON /CHAR/   SUB,FMT(3),CPARAM
      COMMON /ERRCTL/ IER,ICHECK
      SAVE /CHAR/,/ERRCTL/
C
      IF (ICHECK.EQ.999) CALL OTRC('ORA0  ','12/11/89')
C
      IREC=N/IRECL8
      DO 1 JREC=1,IREC
      J1=(JREC-1)*IRECL8
1     READ (MFILE,ERR=99998,END=99998) (DX(J1+I),I=1,IRECL8)
      IF (MOD(N,IRECL8).EQ.0) GOTO 99999
      J1=IREC*IRECL8
      READ (MFILE,ERR=99998,END=99998) (DX(J1+I),I=1,MOD(N,IRECL8))
      GOTO 99999
C
99998 WRITE (CPARAM,'(I15)') MFILE
      CALL WERR(-110,'ORA0  ')
C
99999 END

      SUBROUTINE ZLEN(LNR,LENGTH)
C
      PARAMETER (NNARR=299)
      COMMON /ERRCTL/ IER,ICHECK
      COMMON /TABLE/  KTYPE(NNARR),KLEN(NNARR),KLEN8(NNARR),IFLAG
      SAVE /TABLE/
C
      IF (ICHECK.EQ.999) CALL OTRC('ZLEN  ','01/02/89')
C
      IF (LNR.GT.0.AND.LNR.LE.NNARR) THEN
       LENGTH=KLEN(LNR)
      ELSE IF (LNR.EQ.0) THEN
       LENGTH=0
      ELSE
       LENGTH=-1
      ENDIF
C
      END


      SUBROUTINE ZNEW(ILONG,ITYPEA,LNR,ARR)
C
      IMPLICIT DOUBLE PRECISION (A,C-H,O-U,W-Z),LOGICAL(B)
      CHARACTER SUB*6,FMT*15,CPARAM*120
      CHARACTER ARR*6
      DIMENSION VWORK(1),KWORK(1)
C
      PARAMETER (NNARR=299)
      COMMON          NWORK,IWORK,IWMAX,L(NNARR),DWORK(1)
      COMMON /OUTPUT/ M,MT,MKEYB,MTERM,MERR,MPROT,MSYS,MTRC,IRECL8
      COMMON /CHAR/   SUB,FMT(3),CPARAM
      COMMON /ERRCTL/ IER,ICHECK
      COMMON /TABLE/  KTYPE(NNARR),KLEN(NNARR),KLEN8(NNARR),IFLAG
      EQUIVALENCE (DWORK(1),VWORK(1),KWORK(1))
      SAVE /OUTPUT/,/CHAR/,/ERRCTL/,/TABLE/
C
      IF (ICHECK.GE.998) CALL OTRC('ZNEW  ','01/02/89')
      IER=0
C
      IF (IWORK.GE.NWORK) THEN
C ***  Error *** No space on DWORK ***
C ***  Call ZDISP first
       WRITE (CPARAM,'(A6)') ARR
       CALL WERR(-100,'ZNEW  ')
       GOTO 99999
      ENDIF
C
      ITYPE=ITYPEA
C
      IF ((ABS(ITYPE).LT.1).OR.(ABS(ITYPE).GT.3)) THEN
C ***  Error *** Wrong value of ITYPE ***
       WRITE (CPARAM,'(I15,A6)') ITYPE,ARR
       CALL WERR(-101,'ZNEW  ')
       GOTO 99999
      ENDIF
C
C *** Only allocation of new array if ITYPE < 0 - No initialization ***
C
      BZINIT=ITYPE.GT.0
      ITYPE=ABS(ITYPE)
C
C *** Block 1 - Allocation
C
C *** Look for a free entry in L ***
      DO 110 LNR=1,NNARR
      IF (L(LNR).EQ.0) GOTO 120
110   CONTINUE
C *** Error *** already NNARR arrays allocated ***
      WRITE (CPARAM,'(A6)') ARR
      CALL WERR(-102,'ZNEW  ')
      GOTO 99999
C
120   IF (ILONG.GT.0) THEN
C
C *** Calculation of space needed for allocation ***
      JLONGD=ILONG
      IF (ITYPE.GT.1) JLONGD=(JLONGD+1)/2
      JREQ=IWORK+JLONGD
C
      IF (JREQ.GT.NWORK) THEN
C ***  Error *** NWORK must be increased by JREQ-NWORK ***
       WRITE (CPARAM,'(I15,A6)') JREQ-NWORK,ARR
       CALL WERR(-103,'ZNEW  ')
       GOTO 99999
      ENDIF
C
C *** Set new value for KTYPE , KLEN , L , IWORK, IWMAX ***
      KTYPE(LNR)=ITYPE
      KLEN(LNR)=ILONG
      KLEN8(LNR)=JLONGD
      L(LNR)=IWORK+1
      IF (ITYPE.GT.1) L(LNR)=2*L(LNR)-1
      IWORK=JREQ
      IWMAX=MAX(IWMAX,IWORK)
C
C *** No initialization of new array ***
      IF (.NOT.BZINIT) GOTO 99998
C
C *** Block 2 - Initialization of new array by 0
C               according to data type
C
      GOTO (210,220,230),ITYPE
C *** REAL*8 data ***
210   CALL LCL1(DWORK(L(LNR)),KLEN(LNR))
      GOTO 99998
C *** REAL*4 data ***
220   CALL LCL2(VWORK(L(LNR)),KLEN(LNR))
      GOTO 99998
C *** INTEGER*4 data ***
230   CALL LCL3(KWORK(L(LNR)),KLEN(LNR))
      GOTO 99998
C
      ELSE
C
C *** ILONG = 0 ***
C
C *** Calculate number of free elements on DWORK ***
      ILONG=NWORK-IWORK
      KLEN8(LNR)=ILONG
      KTYPE(LNR)=ITYPE
      L(LNR)=IWORK+1
      IF (ITYPE.GT.1) THEN
       ILONG=ILONG*2
       L(LNR)=2*L(LNR)-1
      ENDIF
      KLEN(LNR)=ILONG
C *** reserve remaining part of DWORK - no initialization ***
      IFLAG=LNR
      IWORK=NWORK
C
      ENDIF
C
99998 WRITE (CPARAM,'(A6,2I15)') ARR,LNR,ILONG
      IF (IFLAG.NE.0) THEN
       CALL OMSG(2,'ZNEW  ')
      ELSE
       CALL OMSG(1,'ZNEW  ')
      ENDIF
C
99999 END


      SUBROUTINE LCL1(DX,NX)
C
      IMPLICIT DOUBLE PRECISION (A,C-H,O-U,W-Z),LOGICAL(B)
      DIMENSION DX(*)
      COMMON /ERRCTL/ IER,ICHECK
      SAVE /ERRCTL/
C
      IF (ICHECK.GE.998) CALL OTRC('LCL1  ','01/02/89')
C
      DO 10 IX=1,NX
10    DX(IX)=0D0
C
      END

      SUBROUTINE LCL2(VX,NX)
C
      IMPLICIT DOUBLE PRECISION (A,C-H,O-U,W-Z),LOGICAL(B)
      DIMENSION VX(*)
      COMMON /ERRCTL/ IER,ICHECK
      SAVE /ERRCTL/
C
      IF (ICHECK.GE.998) CALL OTRC('LCL2  ','01/02/89')
C
      DO 10 IX=1,NX
10    VX(IX)=0.
C
      END

      SUBROUTINE LCL3(KX,NX)
C
      IMPLICIT DOUBLE PRECISION (A,C-H,O-U,W-Z),LOGICAL(B)
      DIMENSION KX(*)
      COMMON /ERRCTL/ IER,ICHECK
      SAVE /ERRCTL/
C
      IF (ICHECK.GE.998) CALL OTRC('LCL3  ','01/02/89')
C
      DO 10 IX=1,NX
10    KX(IX)=0
C
      END

      SUBROUTINE WERR(IER0,SUB0)
C
      IMPLICIT DOUBLE PRECISION (A,C-H,O-U,W-Z),LOGICAL(B)
      CHARACTER*6 SUB0
C
      COMMON /OUTPUT/ M,MT,MKEYB,MTERM,MERR,MPROT,MSYS,MTRC,IRECL8
      COMMON /ERRCTL/ IER,ICHECK
      SAVE /OUTPUT/,/ERRCTL/
C
      IER=IER0
      CALL OERR(IER,SUB0)
C
      END
      
