text:
C     Last change:  ERB  30 Sep 2002    2:18 pm
      SUBROUTINE UPARARRAL(IN,IOUT,LINE,NP)
C
C-----VERSION 15SEPT1998 UPARARRAL
C     ******************************************************************
C     Setup array parameter definition for a package.
C     ******************************************************************
C
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
      INCLUDE 'param.inc'
      CHARACTER*(*) LINE
C     ------------------------------------------------------------------
C
C  If NP has not already been defined, decode PARAMETER definitions if
C  they exist
      IF(IN.GT.0) THEN
         NP=0
         LLOC=1
         CALL URWORD(LINE,LLOC,ISTART,ISTOP,1,N,R,IOUT,IN)
         IF(LINE(ISTART:ISTOP).EQ.'PARAMETER') THEN
            CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,NP,R,IOUT,IN)
            READ(IN,'(A)') LINE
         END IF
      END IF
C
C  Process the parameter information
      IF(NP.GT.0) THEN
         WRITE(IOUT,31) NP
   31    FORMAT(1X,I5,' Named Parameters     ')
      ELSE
         NP=0
         WRITE(IOUT,'(A)') ' No named parameters'
      END IF
C
      RETURN
      END
      SUBROUTINE UPARARRRP(IN,IOUT,NP,ILFLG,PTYP,ITERP,ITVP,INAMLOC)
C
C-----VERSION 20NOV2001 UPARARRRP
C     ******************************************************************
C     Read and store array parameter definition information
C     ******************************************************************
C     Modified 11/20/2001 to support parameter instances - ERB
C
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
      INCLUDE 'param.inc'
      CHARACTER*(*) PTYP
      CHARACTER*200 LINE
      CHARACTER*10 PN,CTMP1,CTMP2
C     ------------------------------------------------------------------
C
C     Read a parameter definition line and decode the parameter name,
C     type, and value
      READ(IN,'(A)') LINE
      LLOC=1
      CALL URWORD(LINE,LLOC,ISTART,ISTOP,0,N,R,IOUT,IN)
      PN=LINE(ISTART:ISTOP)
      CTMP1=PN
      CALL UPCASE(CTMP1)
      CALL URWORD(LINE,LLOC,ISTART,ISTOP,1,N,R,IOUT,IN)
      PTYP=LINE(ISTART:ISTOP)
      CALL URWORD(LINE,LLOC,ISTART,ISTOP,3,N,PV,IOUT,IN)
C
C     Look for the parameter name in the parameter list
      DO 10 NP=1,MXPAR
        CTMP2=PARNAM(NP)
        CALL UPCASE(CTMP2)
        IF(CTMP1.EQ.CTMP2) THEN
C
C         If found, determine if it is an illegal duplicate or if it was
C         predefined.
          IF(PARTYP(NP).NE.' ' .AND. IDEFPAR.EQ.0) THEN
C           Illegal duplicate
            WRITE(IOUT,110) CTMP1
  110       FORMAT(' Duplicate parameter name: ',A)
            CALL USTOP(' ')
          END IF
C         Parameter was predefined -- leave its value alone
C         (i.e. ignore PV).
          GO TO 100
        ELSE IF(PARNAM(NP).EQ.' ') THEN
C         Parameter was not found in the list, so it is a new
C         definition. Put values in the list.
          PARNAM(NP)=PN
          B(NP)=PV
          IPSUM=IPSUM+1
          GO TO 100
        END IF
10    CONTINUE
C     Too many parameters
      WRITE(IOUT,11)
   11 FORMAT(1X,'The number of parameters has exceeded the maximum')
      CALL USTOP(' ')
C
C     Parse the rest of the parameter definition.
  100 PARTYP(NP)=PTYP
      CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,NCLU,R,IOUT,IN)
C
      IF(ITERP.EQ.1) THEN
        NUMINST=0
        IF (ITVP.GT.0) THEN
C         CHECK FOR MULTIPLE INSTANCES
          CALL URWORD(LINE,LLOC,ISTART,ISTOP,1,N,R,IOUT,IN)
          IF (LINE(ISTART:ISTOP).EQ.'INSTANCES') THEN
            CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,NUMINST,R,IOUT,IN)
            IF (NUMINST.LT.1) THEN
              WRITE(IOUT,12) PARNAM(NP),PTYP
   12         FORMAT(/,1X,'*** ERROR: NUMINST SPECIFIED LESS THAN 1',
     &            ' FOR PARAMETER "',A,'"',/,12X,'OF TYPE "',A,
     &            '" -- STOP EXECUTION (UPARARRRP)')
              CALL USTOP(' ')
            ENDIF
          ENDIF
        ENDIF
C
        IPLOC(1,NP)=ICLSUM+1
        NI=MAX(1,NUMINST)
        ICLSUM=ICLSUM+NCLU*NI
        IPLOC(2,NP)=ICLSUM
        IPLOC(3,NP)=NUMINST
        IPLOC(4,NP)=INAMLOC
        INAMLOC=INAMLOC+NUMINST
C
        IF(IPLOC(2,NP).GT.MXCLST) THEN
          WRITE(IOUT,117) IPLOC(2,NP),MXCLST
  117     FORMAT(1X,I5,
     1   ' CLUSTERS WERE SPECIFIED, BUT THERE IS SPACE FOR ONLY',I5)
          WRITE(IOUT,*) NP,NCLU
          WRITE(IOUT,'(A)') PARNAM(NP)
          WRITE(IOUT,'(4I10)') IPLOC
          CALL USTOP(' ')
        END IF
        WRITE(IOUT,121) PARNAM(NP),PARTYP(NP),NCLU
  121   FORMAT(1X/,1X,'PARAMETER NAME:',A,'   TYPE:',A,'   CLUSTERS:',
     &         I4)
        WRITE(IOUT,122) PV
  122   FORMAT(1X,'Parameter value from package file is: ',1PG13.5)
        IF(B(NP).NE.PV) THEN
          WRITE(IOUT,123) B(NP)
  123     FORMAT(1X,'This value has been changed to:',7X,1PG13.5,
     &        ', as read from',/,' the Sensitivity Process file')
        END IF
        IF(NUMINST.GT.0) THEN
          WRITE(IOUT,124)NUMINST
  124      FORMAT(3X,'NUMBER OF INSTANCES: ',I4)
          IF((INAMLOC-1).GT.MXINST) THEN
            WRITE(IOUT,125)INAMLOC-1,MXINST
  125       FORMAT(1X,'EXCEEDED THE MAXIMUM NUMBER OF INSTANCES:'/
     &       1X,I5,' instances have been specified'/
     &       1X,'The maximum number of instances is',I5)
            CALL USTOP(' ')
          ENDIF
        ENDIF
      ELSE
        NUMINST=IPLOC(3,NP)
      ENDIF
      IACTIVE(NP)=0
C
      IF(NUMINST.EQ.0) THEN
        IB=0
      ELSE
        IB=1
      ENDIF
      I=IPLOC(1,NP)-1
      DO 210 INST=IB,NUMINST
        IF(NUMINST.GT.0) CALL UINSRP(INST,IN,IOUT,NP,ITERP)
C       Read clusters
        DO 200 KK=1,NCLU
          I=I+1
          READ(IN,'(A)') LINE
          IF(ITERP.EQ.1) THEN
            LLOC=1
            IF(ILFLG.NE.0) THEN
C             Read layer number for cluster
              CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,IPCLST(1,I),R,IOUT,
     &                    IN)
            ELSE
              IPCLST(1,I)=0
            END IF
C           Read multiplier and zone array names
            CALL URWORD(LINE,LLOC,IM1,IM2,0,N,R,IOUT,IN)
            CALL URWORD(LINE,LLOC,IZ1,IZ2,0,N,R,IOUT,IN)
C           Read zone numbers
            DO 30 J=5,14
              CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,IPCLST(J,I),R,-1,IN)
              IF(IPCLST(J,I).EQ.0) THEN
                IPCLST(4,I)=J-1
                GO TO 32
              END IF
   30       CONTINUE
            IPCLST(4,I)=14
   32       CONTINUE
            IF(ILFLG.NE.0) THEN
              WRITE(IOUT,36) IPCLST(1,I),LINE(IM1:IM2),LINE(IZ1:IZ2)
   36         FORMAT(16X,'LAYER: ',I3,'    MULTIPLIER ARRAY: ',A,
     2        '    ZONE ARRAY: ',A)
            ELSE
              WRITE(IOUT,37) LINE(IM1:IM2),LINE(IZ1:IZ2)
   37         FORMAT(16X,'MULTIPLIER ARRAY: ',A,'    ZONE ARRAY: ',A)
            END IF
C
C           Find the multiplier array number
            CTMP1=LINE(IM1:IM2)
            CALL UPCASE(CTMP1)
            IF(CTMP1.EQ.'NONE') THEN
              IPCLST(2,I)=0
            ELSE
              DO 40 J=1,MXMLT
                CTMP2=MLTNAM(J)
                CALL UPCASE(CTMP2)
                IF(CTMP1.EQ.CTMP2) GO TO 45
   40         CONTINUE
              WRITE(IOUT,'(A)') ' Multiplier array has not been defined'
              CALL USTOP(' ')
   45         IPCLST(2,I)=J
            END IF
C
C           Find the zone array number
            CTMP1=LINE(IZ1:IZ2)
            CALL UPCASE(CTMP1)
            IF(CTMP1.EQ.'ALL') THEN
              IPCLST(3,I)=0
            ELSE
              IF(IPCLST(4,I).EQ.4) THEN
                WRITE(IOUT,47)
   47           FORMAT(1X,
     1          'There were no zone values specified in the cluster',/
     2          1X,'At least one zone must be specified')
                CALL USTOP(' ')
              END IF
              WRITE(IOUT,48) (IPCLST(J,I),J=5,IPCLST(4,I))
   48         FORMAT(1X,'               ZONE VALUES:',10I5)
              DO 50 J=1,MXZON
                CTMP2=ZONNAM(J)
                CALL UPCASE(CTMP2)
                IF(CTMP1.EQ.CTMP2) GO TO 55
   50         CONTINUE
              WRITE(IOUT,'(A)') ' Zone array has not been defined'
              CALL USTOP(' ')
   55         IPCLST(3,I)=J
            END IF
          ENDIF
C
  200   CONTINUE
  210 CONTINUE
C
      RETURN
      END
      SUBROUTINE UPARARRSUB1(ZZ,NCOL,NROW,ILAY,PTYP,IOUT,ANAME,IPF,
     1           RMLT,IZON,NMLTAR,NZONAR)
C
C-----VERSION 26FEB1998 UPARARRSUB1
C     ******************************************************************
C     Substitute parameter-based values into a 2-D array based on a
C     parameter type.
C     ******************************************************************
C
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
      INCLUDE 'param.inc'
      DIMENSION ZZ(NCOL,NROW),RMLT(NCOL,NROW,NMLTAR),
     1          IZON(NCOL,NROW,NZONAR)
      CHARACTER*(*) PTYP
      CHARACTER*24 ANAME
C     ------------------------------------------------------------------
      INIT=1
      WRITE(IOUT,11) ANAME
   11 FORMAT(1X,/,1X,A,' is defined by the following parameters:')
C
C  Loop through each parameter.
      DO 100 IP=1,MXPAR
C  Stop looping if the end of the parameter list is found.
      IF(PARNAM(IP).EQ.' ') GO TO 200
C  Check for the specified parameter type.
      IF(PARTYP(IP).EQ.PTYP) THEN
C  Loop through each cluster definition for layers that match the
C  specified layer.
         II=IP
         CALL USUB2D(ZZ,NCOL,NROW,II,ILAY,INIT,RMLT,IZON,NMLTAR,
     1           NZONAR,NSUB)
         INIT=0
         IF(NSUB.GT.0) WRITE(IOUT,47) PARNAM(IP)
   47    FORMAT(1X,A)
      END IF
  100 CONTINUE
C
C  PRINT THE ARRAY.
  200 CALL ULAPRWC(ZZ,NCOL,NROW,ILAY,IOUT,IPF,ANAME)
C
      RETURN
      END
      SUBROUTINE UPARARRSUB2(ZZ,NCOL,NROW,ILAY,NP,IN,IOUT,PTYP,ANAME,
     1      PACK,IPF,RMLT,IZON,NMLTAR,NZONAR)
C
C-----VERSION 21NOV2001 UPARARRSUB2
C     ******************************************************************
C     Read a series of parameter names and substitute their values into
C     a 2-D array.
C     ******************************************************************
C     Modified 11/21/2001 to support parameter instances - ERB
C
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
      INCLUDE 'param.inc'
      DIMENSION ZZ(NCOL,NROW),RMLT(NCOL,NROW,NMLTAR),
     1          IZON(NCOL,NROW,NZONAR)
      CHARACTER*(*) PTYP,PACK
      CHARACTER*24 ANAME
      CHARACTER*200 LINE
      CHARACTER*10 CTMP1,CTMP2,CTMP3,CTMP4
C     ------------------------------------------------------------------
      INIT=1
C
C     Read each parameter name.
      DO 100 N=1,NP
        READ(IN,'(A)') LINE
        LLOC=1
        CALL URWORD(LINE,LLOC,ISTART,ISTOP,0,IDUM,RDUM,IOUT,IN)
        WRITE(IOUT,5) LINE(ISTART:ISTOP)
    5   FORMAT(' Parameter:  ',A)
        IF(LINE(ISTART:ISTOP).EQ.' ') THEN
          WRITE(IOUT,*) ' Blank parameter name in the ',PACK,' file.'
          CALL USTOP(' ')
        END IF
C
C       Loop through each parameter looking for the specified name.
        CTMP1=LINE(ISTART:ISTOP)
        CALL UPCASE(CTMP1)
        DO 10 IP=1,MXPAR
          CTMP2=PARNAM(IP)
          CALL UPCASE(CTMP2)
          IF(CTMP1.EQ.CTMP2) GO TO 20
C         Stop looping if the end of the parameter list is found.
          IF(PARNAM(IP).EQ.' ') GO TO 15
   10   CONTINUE
   15   WRITE(IOUT,16) PACK
   16   FORMAT(1X,'Error in ',A,' file:',/
     1      1X,'The above parameter must be defined prior to its use')
        CALL USTOP(' ')
C
   20   CONTINUE
C
        IF(PARTYP(IP).NE.PTYP) THEN
C         Print an error message if the parameter type does not match.
          WRITE(IOUT,83) PARNAM(IP),PARTYP(IP),PACK,PTYP
   83     FORMAT(1X,'Parameter type conflict:',/
     1           1X,'Named parameter:',A,' was defined as type:',A,/
     2           1X,'However, this parameter is used in the ',A,
     3             ' file, so it should be type:',A)
          CALL USTOP(' ')
        ENDIF
C
        NUMINST=IPLOC(3,IP)
        ILOC=IPLOC(4,IP)
        NI=1
C       If parameter is time-varying, read instance name
        IF(NUMINST.GT.0) THEN
          CALL URWORD(LINE,LLOC,ISTART,ISTOP,0,IDUM,RDUM,IOUT,IN)
          CTMP3=LINE(ISTART:ISTOP)
          IF(CTMP3.EQ.' ') THEN
            WRITE(IOUT,1000) PACK,PARNAM(IP)
 1000       FORMAT(/,1X,'Blank instance name in the ',A,
     &             ' file for parameter ',A)
            CALL USTOP(' ')
          ENDIF
          WRITE(IOUT,1010) CTMP3
 1010     FORMAT(3X,'Instance:  ',A)
          CALL UPCASE(CTMP3)
          DO 50 KI=1,NUMINST
            CTMP4=INAME(ILOC+KI-1)
            CALL UPCASE(CTMP4)
            IF(CTMP3.EQ.CTMP4) THEN
              NI=KI
              GOTO 55
            ENDIF
   50     CONTINUE
          WRITE(IOUT,1020) PACK,CTMP3,PARNAM(IP)
 1020     FORMAT(/,1X,'The ',A,' file specifies undefined instance "',
     &           A,'" for parameter ',A)
          CALL USTOP(' ')
   55     CONTINUE
        ENDIF
C
        IF (IACTIVE(IP).GT.0) THEN
          WRITE(IOUT,1030) PARNAM(IP)
 1030     FORMAT(/,1X,'*** ERROR: PARAMETER "',A,
     &        '" HAS ALREADY BEEN ACTIVATED THIS STRESS PERIOD',/,
     &        ' -- STOP EXECUTION (UPARARRSUB2)')
          CALL USTOP(' ')
        ENDIF
C
C       Activate the parameter and substitute.
        IACTIVE(IP)=NI
        II=IP
        CALL USUB2D(ZZ,NCOL,NROW,II,ILAY,INIT,RMLT,IZON,NMLTAR,
     1              NZONAR,NSUB)
        INIT=0
C
C       Get new value of print flag if it is there.
        CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,I,RDUM,-1,IN)
        IF(LINE(ISTART:ISTOP) .NE.'E' .AND.
     1     LINE(ISTART:ISTOP) .NE.' ') IPF=I
C
  100 CONTINUE
C
C     Check to see if entire array is a constant.
      TMP=ZZ(1,1)
      DO 300 I=1,NROW
        DO 290 J=1,NCOL
          IF(ZZ(J,I).NE.TMP) GO TO 400
  290   CONTINUE
  300 CONTINUE
      IF(ILAY.GT.0) WRITE(IOUT,302) ANAME,TMP,ILAY
  302 FORMAT(1X,A,' =',1P,G14.6,' FOR LAYER',I4)
      IF(ILAY.LE.0) WRITE(IOUT,303) ANAME,TMP
  303 FORMAT(1X,A,' =',1P,G14.6)
      RETURN
C
C     Print the array.
  400 IF(ILAY.GT.0) THEN
        WRITE(IOUT,494) ANAME,ILAY
  494   FORMAT(1X,//11X,A,' FOR LAYER',I4)
      ELSE IF(ILAY.EQ.0) THEN
        WRITE(IOUT,495) ANAME
  495   FORMAT(1X,//11X,A)
      ELSE
        WRITE(IOUT,496) ANAME
  496   FORMAT(1X,//11X,A,' FOR CROSS SECTION')
      END IF
      IF(IPF.GE.0) CALL ULAPRW(ZZ,ANAME,0,0,NCOL,NROW,0,IPF,IOUT)
      RETURN
      END
      SUBROUTINE UPARLSTAL(IN,IOUT,LINE,NP,MXL)
C
C-----VERSION 26FEB1998 UPARLSTAL
C     ******************************************************************
C     Setup list parameter definition for a package
C     ******************************************************************
C
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
      INCLUDE 'param.inc'
      CHARACTER*(*) LINE
C     ------------------------------------------------------------------
C
C  Decode PARAMETER definitions if they exist
      NP=0
      MXL=0
      LLOC=1
      CALL URWORD(LINE,LLOC,ISTART,ISTOP,1,N,R,IOUT,IN)
      IF(LINE(ISTART:ISTOP).EQ.'PARAMETER') THEN
         CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,NP,R,IOUT,IN)
         IF(NP.LT.0) NP=0
         CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,MXL,R,IOUT,IN)
         IF(MXL.LT.0) MXL=0
C
C
         WRITE(IOUT,31) NP,MXL
   31    FORMAT(1X,I5,' Named Parameters     ',I5,' List entries')
         READ(IN,'(A)') LINE
      ELSE
         WRITE(IOUT,'(A)') ' No named parameters'
      END IF
C
      RETURN
      END
      SUBROUTINE UPARLSTRP(LSTSUM,MXLST,IN,IOUT,NP,PACK,PTYPX,ITERP,
     &                     NUMINST,INAMLOC)
C
C-----VERSION 20011105 UPARLSTRP
C     ******************************************************************
C     Read and store list parameter definition information
C     ******************************************************************
C     Modified 11/5/2001 to support parameter instances - ERB
C
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
      INCLUDE 'param.inc'
      CHARACTER*(*) PACK,PTYPX
      CHARACTER*4 PTYP
      CHARACTER*10 PN,CTMP1,CTMP2
      CHARACTER*200 LINE
C     ------------------------------------------------------------------
C
C  Read the parameter name and definition
      READ(IN,'(A)') LINE
C
      LLOC=1
      CALL URWORD(LINE,LLOC,ISTART,ISTOP,0,N,R,IOUT,IN)
      PN=LINE(ISTART:ISTOP)
      CTMP1=PN
      CALL UPCASE(CTMP1)
      CALL URWORD(LINE,LLOC,ISTART,ISTOP,1,N,R,IOUT,IN)
      PTYP=LINE(ISTART:ISTOP)
      CALL URWORD(LINE,LLOC,ISTART,ISTOP,3,N,PV,IOUT,IN)
      CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,NLST,R,IOUT,IN)
C     Check for multiple instances
      CALL URWORD(LINE,LLOC,ISTART,ISTOP,1,N,R,IOUT,IN)
      IF (LINE(ISTART:ISTOP).EQ.'INSTANCES') THEN
        CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,NUMINST,R,IOUT,IN)
        IF (NUMINST.LT.1) THEN
          WRITE(IOUT,12) PN,PTYP
   12     FORMAT(/,1X,'*** ERROR: NUMINST SPECIFIED LESS THAN 1',
     &        ' FOR PARAMETER "',A,'"',/,12X,'OF TYPE "',A,
     &        '" -- STOP EXECUTION (UPARLSTRP)')
          CALL USTOP(' ')
        ENDIF
      ELSE
        NUMINST = 0
      ENDIF
C
      DO 10 NP=1,MXPAR
        CTMP2=PARNAM(NP)
        CALL UPCASE(CTMP2)
        IF(CTMP1.EQ.CTMP2) THEN
C         If found, determine if it is an illegal duplicate or if it was
C         predefined in the SEN file.
          IF(PARTYP(NP).NE.' ' .AND. IDEFPAR.EQ.0) THEN
C           Illegal duplicate
            WRITE(IOUT,110) CTMP1
  110       FORMAT (' Duplicate parameter name: ',A)
            CALL USTOP(' ')
          END IF
C  Parameter was predefined -- leave its value alone (i.e. ignore PV).
          GO TO 100
        ELSE IF(PARNAM(NP).EQ.' ') THEN
C         Parameter was not found in the list, so it is a new definition.
          PARNAM(NP)=PN
          B(NP)=PV
          IPSUM=IPSUM+1
          GO TO 100
        ENDIF
10    CONTINUE
C  Too many parameters
      WRITE(IOUT,99)
  99  FORMAT(' Number of parameters exceeds MXPAR -- STOP EXECUTION')
      CALL USTOP(' ')
 100  CONTINUE
C
      IF(ITERP.EQ.1) THEN
C       PUT PARAMETER TYPE IN THE LIST
        PARTYP(NP)=PTYP
C
        IPLOC(1,NP)=LSTSUM
        NI=MAX(1,NUMINST)
        LSTSUM=LSTSUM+(NLST*NI)
        IPLOC(2,NP)=LSTSUM-1
        IPLOC(3,NP)=NUMINST
        IPLOC(4,NP)=INAMLOC
        INAMLOC=INAMLOC+NUMINST
C
C-----WRITE PARAMETER INFORMATION
        WRITE(IOUT,121) PARNAM(NP),PARTYP(NP)
  121   FORMAT(1X/,1X,'PARAMETER NAME:',A,'   TYPE:',A)
        WRITE(IOUT,122) PV
  122   FORMAT(1X,'Parameter value from package file is: ',1PG13.5)
        IF(B(NP).NE.PV) THEN
          WRITE(IOUT,123) B(NP)
  123     FORMAT(1X,'This value has been changed to:',7X,1PG13.5,
     &        ', as read from',/,' the Sensitivity Process file')
        END IF
        WRITE(IOUT,130) NLST
  130   FORMAT(  '   NUMBER OF ENTRIES: ',I6)
        IF(NUMINST.GT.0) THEN
          WRITE(IOUT,131)NUMINST
  131     FORMAT('   NUMBER OF INSTANCES: ',I4)
        ENDIF
C
C  Check for list too large
        IF((LSTSUM-1) .GT. MXLST) THEN
          WRITE(IOUT,134) LSTSUM-1,MXLST
  134     FORMAT(1X,'EXCEEDED THE MAXIMUM NUMBER OF LIST ENTRIES:'/
     1          1X,I5,' list entries have been specified'/
     2          1X,'The maximum number of list entries is',I5)
          CALL USTOP(' ')
        END IF
        IF((INAMLOC-1).GT.MXINST) THEN
          WRITE(IOUT,135)INAMLOC-1,MXINST
  135     FORMAT(1X,'EXCEEDED THE MAXIMUM NUMBER OF INSTANCES:'/
     1          1X,I5,' instances have been specified'/
     2          1X,'The maximum number of instances is',I5)
          CALL USTOP(' ')
        END IF
C
C  Check for correct parameter type
        IF(PARTYP(NP).NE.PTYPX) THEN
          WRITE(IOUT,137) PTYPX,PACK
  137     FORMAT(1X,'Parameter type must be:',A,' in the ',A,' Package')
          CALL USTOP(' ')
        END IF
C
C       Parameter definition must include at least one cell
        IF (NLST.LE.0) THEN
          WRITE(IOUT,140) PN
          CALL USTOP(' ')
        ENDIF
  140   FORMAT(' ERROR:  DEFINITION FOR PARAMETER "',A,'"',
     &      ' INCLUDES NO CELLS',/,'   -- STOP EXECUTION (UPARLSTRP)')
      ELSE
        LSTSUM=LSTSUM+IPLOC(2,NP)-IPLOC(1,NP)+1
        NUMINST=IPLOC(3,NP)
      ENDIF
C
      IACTIVE(NP)=0
C
      RETURN
      END
      SUBROUTINE UINSRP(I,IN,IOUT,IP,ITERP)
C-----VERSION 20011206 UINSRP
C     ******************************************************************
C     Read and store one instance name
C     ******************************************************************
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
      INCLUDE 'param.inc'
      CHARACTER*10 CTMP1,CTMP2
      CHARACTER*200 LINE
C     ------------------------------------------------------------------
 1000 FORMAT(A)
 1010 FORMAT(/,3X,'INSTANCE:  ',A)
 1020 FORMAT(/,1X,'*** ERROR: "',A,
     &'" IS A DUPLICATE INSTANCE NAME FOR THIS PARAMETER',/,
     &' -- STOP EXECUTION (UINSRP)')
C
      LLOC = 1
      IPL4 = IPLOC(4,IP)
      ILOC = IPL4+I-1
      READ(IN,1000)LINE
C     READ INSTANCE NAME
      CALL URWORD(LINE,LLOC,ISTART,ISTOP,0,N,R,IOUT,IN)
      INAME(ILOC) = LINE(ISTART:ISTOP)
      CTMP1 = LINE(ISTART:ISTOP)
      CALL UPCASE(CTMP1)
      IF (ITERP.EQ.1) WRITE(IOUT,1010)INAME(ILOC)
      IF (I.GT.1) THEN
        DO 10 J=IPL4,IPL4+I-2
          CTMP2 = INAME(J)
          CALL UPCASE(CTMP2)
          IF (CTMP1.EQ.CTMP2) THEN
            WRITE(IOUT,1020)INAME(J)
            CALL USTOP(' ')
          ENDIF
   10   CONTINUE
      ENDIF
      RETURN
      END
      SUBROUTINE UPARLSTSUB(IN,PACK,IOUTU,PTYP,RLIST,LSTVL,LSTDIM,NREAD,
     1                MXLST,NTOT,IPVL1,IPVL2,LABEL,CAUX,NCAUX,NAUX)
C
C-----VERSION 20020412 UPARLSTSUB
C     ******************************************************************
C     Read a list parameter name, look it up in the list of parameters,
C     and substitute values into active part of package array.
C     ******************************************************************
C     Modified 11/6/2001 to support parameter instances - ERB
C
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
      INCLUDE 'param.inc'
      CHARACTER*(*) PACK,PTYP
      DIMENSION RLIST(LSTVL,LSTDIM)
      CHARACTER*(*) LABEL
      CHARACTER*16 CAUX(NCAUX)
      CHARACTER*200 LINE
      CHARACTER*10 CTMP1,CTMP2,CTMP3,CTMP4
C     ------------------------------------------------------------------
C
      IOUT = ABS(IOUTU)
      READ(IN,'(A)') LINE
      LLOC=1
      CALL URWORD(LINE,LLOC,ISTART,ISTOP,0,IDUM,RDUM,IOUT,IN)
      WRITE(IOUT,1) LINE(ISTART:ISTOP)
    1 FORMAT(/,' Parameter:  ',A)
      IF(LINE(ISTART:ISTOP).EQ.' ') THEN
        WRITE(IOUT,*) ' Blank parameter name in the ',PACK,' file.'
        CALL USTOP(' ')
      END IF
C
      CTMP1=LINE(ISTART:ISTOP)
      CALL UPCASE(CTMP1)
      DO 100 IP=1,MXPAR
        CTMP2=PARNAM(IP)
        CALL UPCASE(CTMP2)
        IF(CTMP1.EQ.CTMP2) THEN
          IF(PARTYP(IP).NE.PTYP) THEN
            WRITE(IOUT,81) PARNAM(IP),PARTYP(IP),PACK,PTYP
   81       FORMAT(1X,'Parameter type conflict:',/
     1        1X,'Named parameter:',A,' was defined as type:',A,/
     2        1X,'However, this parameter is used in the ',A,
     3          ' file, so it should be type:',A)
            CALL USTOP(' ')
          END IF
C
C         DESIGNATE CELLS CORRESPONDING TO CORRECT PARAMETER INSTANCE
          NLST=IPLOC(2,IP)-IPLOC(1,IP)+1
          NUMINST=IPLOC(3,IP)
          ILOC=IPLOC(4,IP)
          NI=1
          IF(NUMINST.GT.0) THEN
            NLST=NLST/NUMINST
            CALL URWORD(LINE,LLOC,ISTART,ISTOP,0,IDUM,RDUM,IOUT,IN)
            CTMP3=LINE(ISTART:ISTOP)
            IF(CTMP3.EQ.' ') THEN
              WRITE(IOUT,1000)PACK,PARNAM(IP)
 1000         FORMAT(/,1X,'Blank instance name in the ',A,
     &               ' file for parameter ',A)
              CALL USTOP(' ')
            ENDIF
            WRITE(IOUT,1010) CTMP3
 1010       FORMAT(3X,'Instance:  ',A)
            CALL UPCASE(CTMP3)
            DO 50 KI=1,NUMINST
              CTMP4=INAME(ILOC+KI-1)
              CALL UPCASE(CTMP4)
              IF(CTMP3.EQ.CTMP4) THEN
                NI=KI
                GOTO 55
              ENDIF
   50       CONTINUE
            WRITE(IOUT,1020) PACK,CTMP3,PARNAM(IP)
 1020       FORMAT(/,1X,'The ',A,' file specifies undefined instance "',
     &             A,'" for parameter ',A)
            CALL USTOP(' ')
   55       CONTINUE
          ENDIF
C
          IF (IACTIVE(IP).GT.0) THEN
            WRITE(IOUT,1030) PARNAM(IP)
 1030       FORMAT(/,1X,'*** ERROR: PARAMETER "',A,
     &          '" HAS ALREADY BEEN ACTIVATED THIS STRESS PERIOD',/,
     &          ' -- STOP EXECUTION (UPARLSTSUB)')
            CALL USTOP(' ')
          ENDIF
C
          IACTIVE(IP)=NI
C
          NTOT=NTOT+NLST
          IF(NTOT.GT.MXLST) THEN
            WRITE(IOUT,83) NTOT,MXLST
   83       FORMAT(1X,/1X,'THE NUMBER OF ACTIVE LIST ENTRIES (',I6,
     1       ')',/1X,'IS GREATER THAN THE MAXIMUM ALLOWED (',I6,')')
            CALL USTOP(' ')
          END IF
C
C  Write label for list values
          IF (IOUTU.GT.0) CALL ULSTLB(IOUT,LABEL,CAUX,NCAUX,NAUX)
C
C  Substitute values
          DO 90 I=1,NLST
            II=NTOT-NLST+I
            III=I-1+IPLOC(1,IP)+(NI-1)*NLST
            DO 85 J=1,NREAD
              RLIST(J,II)=RLIST(J,III)
   85       CONTINUE
            DO 86 IPVL=IPVL1,IPVL2
              RLIST(IPVL,II)=RLIST(IPVL,II)*B(IP)
   86       CONTINUE
            IL=RLIST(1,II)
            IR=RLIST(2,II)
            IC=RLIST(3,II)
            IF (IOUTU.GT.0) WRITE(IOUT,89) II,IL,IR,IC,
     &          (RLIST(JJ,II),JJ=4,NREAD)
   89       FORMAT(1X,I6,I7,I7,I7,14G16.4)
   90     CONTINUE
          RETURN
        END IF
  100 CONTINUE
C
      WRITE(IOUT,*) ' The ',PACK,
     1   ' file specifies an undefined parameter:',LINE(ISTART:ISTOP)
      CALL USTOP(' ')
C
C
      END
      SUBROUTINE PRESET(PTYP)
C
C-----VERSION 30MARCH1998
C     ******************************************************************
C     Clear time step flag for all parameters of the specified type
C     ******************************************************************
C
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
      INCLUDE 'param.inc'
      CHARACTER*(*) PTYP
C     ------------------------------------------------------------------
C
      DO 10 I=1,IPSUM
      IF(PARTYP(I).EQ.PTYP) IACTIVE(I)=0
   10 CONTINUE
C
      RETURN
      END

      SUBROUTINE USUB2D(ZZ,NCOL,NROW,IP,ILAY,INIT,RMLT,IZON,NMLTAR,
     1             NZONAR,NSUB)
C
C-----VERSION 21NOV2001 USUB2D
C     ******************************************************************
C     Substitute values for a single parameter into a 2-D array.
C     ******************************************************************
C     Modified 11/21/2001 to support parameter instances - ERB
C
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
      INCLUDE 'param.inc'
      DIMENSION ZZ(NCOL,NROW),RMLT(NCOL,NROW,NMLTAR),
     1          IZON(NCOL,NROW,NZONAR)
C     ------------------------------------------------------------------
      ZERO=0.0
C
C     Initialize the array.
      IF(INIT.NE.0) THEN
        DO 10 I=1,NROW
          DO 5 J=1,NCOL
            ZZ(J,I)=ZERO
    5     CONTINUE
   10   CONTINUE
      END IF
C
      ICSTART=IPLOC(1,IP)
      ICSTOP=IPLOC(2,IP)
      NUMINST=IPLOC(3,IP)
      IF(NUMINST.GT.1) THEN
C       Select correct instance
        NCLU=(ICSTOP-ICSTART+1)/NUMINST
        NI=IACTIVE(IP)
        ICSTART=ICSTART+(NI-1)*NCLU
        ICSTOP=ICSTART+NCLU-1
      ENDIF
C
C     Loop through each cluster definition for layers that match the
C     specified layer.
      NSUB=0
      DO 80 IC=ICSTART,ICSTOP
C       Check if the cluster layer matches the specified layer
        IF(IPCLST(1,IC).EQ.ILAY) THEN
C         The parameter layer matches the specified layer, so loop
C         through each value of the array.
          MLT=IPCLST(2,IC)
          AA=1.
          IZ=IPCLST(3,IC)
          IF(IZ.GT.0) THEN
            DO 50 I=1,NROW
              DO 40 J=1,NCOL
                DO 30 JJ=5,IPCLST(4,IC)
C                 If the value in the zone array is equal to the cluster
C                 zone value, modify the array value.
                  IF(IZON(J,I,IZ).EQ.IPCLST(JJ,IC)) THEN
                    IF(MLT.GT.0) AA=RMLT(J,I,MLT)
                    ZZ(J,I)=ZZ(J,I)+AA*B(IP)
                    NSUB=NSUB+1
                  END IF
   30           CONTINUE
   40         CONTINUE
   50       CONTINUE
          ELSE
            DO 70 I=1,NROW
              DO 60 J=1,NCOL
                IF(MLT.GT.0) AA=RMLT(J,I,MLT)
                ZZ(J,I)=ZZ(J,I)+AA*B(IP)
   60         CONTINUE
   70       CONTINUE
            NSUB=NSUB+NCOL*NROW
          END IF
        END IF
   80 CONTINUE
C
C
      RETURN
      END
      SUBROUTINE UPARLSTLOC(IN,PACK,IOUT,PTYP,IBEG,IEND,PV)
C
C-----VERSION 20011107 UPARLSTLOC
C     ******************************************************************
C     Read a list parameter name, look it up in the list of
C     parameters, and return its location.
C     ******************************************************************
C     Modified 11/7/2001 to support parameter instances - ERB
C
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
      INCLUDE 'param.inc'
      CHARACTER*(*) PACK,PTYP
      CHARACTER*200 LINE
      CHARACTER*10 CTMP1,CTMP2,CTMP3,CTMP4
C     ------------------------------------------------------------------
  500 FORMAT(' Parameter:  ',A)
  510 FORMAT(1X,'Parameter type conflict:',/
     &       1X,'Named parameter:',A,' was defined as type:',A,/
     &       1X,'However, this parameter is used in the ',A,
     &          ' file, so it should be type:',A)
  520 FORMAT(/,1X,'Blank instance name in the ',A,
     &       ' file for parameter ',A)
  530 FORMAT(3X,'Instance:  ',A)
  540 FORMAT(/,1X,'The ',A,' file specifies undefined instance "',
     &       A,'" for parameter ',A)
  550 FORMAT(/,1X,'*** ERROR: PARAMETER "',A,
     &'" HAS ALREADY BEEN ACTIVATED THIS STRESS PERIOD',/,
     &' -- STOP EXECUTION (UPARLSTLOC)')
C
      READ(IN,'(A)') LINE
      LLOC=1
      CALL URWORD(LINE,LLOC,ISTART,ISTOP,0,IDUM,RDUM,IOUT,IN)
      WRITE(IOUT,500) LINE(ISTART:ISTOP)
      IF(LINE(ISTART:ISTOP).EQ.' ') THEN
        WRITE(IOUT,*) ' Blank parameter name in the ',PACK,' file.'
        CALL USTOP(' ')
      END IF
C
      CTMP1=LINE(ISTART:ISTOP)
      CALL UPCASE(CTMP1)
      DO 100 IP=1,MXPAR
        CTMP2=PARNAM(IP)
        CALL UPCASE(CTMP2)
        IF(CTMP1.EQ.CTMP2) THEN
          IF(PARTYP(IP).NE.PTYP) THEN
            WRITE(IOUT,510) PARNAM(IP),PARTYP(IP),PACK,PTYP
            CALL USTOP(' ')
          END IF
C
C         DESIGNATE CELLS CORRESPONDING TO CORRECT PARAMETER INSTANCE
          NLST=IPLOC(2,IP)-IPLOC(1,IP)+1
          NUMINST=IPLOC(3,IP)
          ILOC=IPLOC(4,IP)
          NI=1
          IF(NUMINST.GT.0) THEN
            NLST=NLST/NUMINST
            CALL URWORD(LINE,LLOC,ISTART,ISTOP,0,IDUM,RDUM,IOUT,IN)
            CTMP3=LINE(ISTART:ISTOP)
            IF(CTMP3.EQ.' ') THEN
              WRITE(IOUT,520)PACK,PARNAM(IP)
              CALL USTOP(' ')
            ENDIF
            WRITE(IOUT,530) CTMP3
            CALL UPCASE(CTMP3)
            DO 50 KI=1,NUMINST
              CTMP4=INAME(ILOC+KI-1)
              CALL UPCASE(CTMP4)
              IF(CTMP3.EQ.CTMP4) THEN
                NI=KI
                GOTO 60
              ENDIF
   50       CONTINUE
            WRITE(IOUT,540) PACK,CTMP3,PARNAM(IP)
            CALL USTOP(' ')
   60       CONTINUE
          ENDIF
C
          IF (IACTIVE(IP).GT.0) THEN
            WRITE(IOUT,550) PARNAM(IP)
            CALL USTOP(' ')
          ENDIF
C
          IACTIVE(IP)=NI
C
          IBEG=IPLOC(1,IP)+(NI-1)*NLST
          IEND=IBEG+NLST-1
          PV=B(IP)
          IACTIVE(IP)=NI
          RETURN
        END IF
  100 CONTINUE
C
      WRITE(IOUT,*) ' The ',PACK,
     &   ' file specifies an undefined parameter:',LINE(ISTART:ISTOP)
      CALL USTOP(' ')
C
      END
      SUBROUTINE UPARARRCK(BUFF,IBOUND,IOUT,IZON,LAY,NCOL,NLAY,NROW,
     &                     NZONAR,PTYP)
C
C-----VERSION 19990805 ERB
C     ******************************************************************
C     CHECK FOR COMPLETE DEFINITION OF ONE LAYER OF CELLS BY PARAMETERS
C     OF A GIVEN TYPE
C     ******************************************************************
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
      INCLUDE 'param.inc'
      INTEGER IBOUND(NCOL,NROW,NLAY), IZON(NCOL,NROW,NZONAR)
      REAL BUFF(NCOL,NROW)
      CHARACTER*4 PTYP
C     ------------------------------------------------------------------
  500 FORMAT(1X,'ERROR: BLANK PARAMETER TYPE -- STOP EXECUTION',
     &       ' (UPARARRCK)')
  510 FORMAT(1X,'ROW: ',I5,', COLUMN: ',I5,' IN LAYER ',I3,
     &       ' NOT DEFINED FOR PARAMETER TYPE ',A)
  520 FORMAT(/,1X,'PARAMETER DEFINITIONS INCOMPLETE -- STOP',
     &       ' EXECUTION (UPARARRCK)')
C
      IF (PTYP.EQ.' ') THEN
        WRITE (IOUT,500)
        CALL USTOP(' ')
      ENDIF
C
C-----INITIALIZE BUFF TO INDICATE DEFINITION BY PARAMETERS
      DO 20 I = 1, NROW
        DO 10 J = 1, NCOL
          BUFF(J,I) = 0.0
   10   CONTINUE
   20 CONTINUE
C
C-----INCREMENT BUFF FOR EACH CELL WHERE A PARAMETER OF THE CORRECT TYPE
C     APPLIES -- LOOP THROUGH PARAMETERS TO FIND MATCHING PARAMETER
C     TYPES
      DO 100 IP = 1, MXPAR
        IF (PARTYP(IP).EQ.PTYP) THEN
C---------LOOP THROUGH CLUSTERS ASSOCIATED WITH THIS PARAMETER
          DO 80 IC = IPLOC(1,IP), IPLOC(2,IP)
            IF (IPCLST(1,IC).EQ.LAY) THEN
              IZA = IPCLST(3,IC)
              DO 60 I = 1, NROW
                DO 50 J = 1,NCOL
                  IF (IZA.GT.0) THEN
C-------------------LOOP THROUGH ZONES LISTED FOR THIS CLUSTER
                    DO 40 IZI = 5, IPCLST(4,IC)
                      IZ = IPCLST(IZI,IC)
                      IF (IZ.EQ.IZON(J,I,IZA)) THEN
                        BUFF(J,I) = BUFF(J,I) + 1.0
                      ENDIF
   40               CONTINUE
                  ELSE
C-------------------ZONES DO NOT APPLY TO THIS CLUSTER
                    BUFF(J,I) = BUFF(J,I) + 1.0
                  ENDIF
   50           CONTINUE
   60         CONTINUE
            ENDIF
   80     CONTINUE
        ENDIF
  100 CONTINUE
C
C-----IDENTIFY ANY ACTIVE CELLS THAT ARE STILL EQUAL TO ZERO, THEREFORE
C     NOT CONTROLLED BY ANY PARAMETER OF THE CORRECT TYPE
      IERR = 0
      DO 140 I = 1, NROW
        DO 120 J = 1, NCOL
          IF (IBOUND(J,I,LAY).NE.0) THEN
            IF (BUFF(J,I).EQ.0.0)THEN
              WRITE (IOUT,510) I,J,LAY,PTYP
              IERR = IERR + 1
            ENDIF
          ENDIF
  120   CONTINUE
  140 CONTINUE
C
C-----IF ANY UNCONTROLLED ACTIVE CELLS ARE FOUND, WRITE ERROR MESSAGE
C     AND STOP
      IF (IERR.GT.0) THEN
        WRITE (IOUT,520)
        CALL USTOP(' ')
      ENDIF
C
      RETURN
      END
      SUBROUTINE UPARFIND(PNAME,PTYP,PACK,IFOUND,IOUT)
C
C-----VERSION 31AUG2000 UPARFIND
C     ******************************************************************
C     Find the parameter number for a parameter name
C     ******************************************************************
C
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
      INCLUDE 'param.inc'
      CHARACTER*(*) PNAME,PTYP,PACK
      CHARACTER*10 CTMP1,CTMP2
C     ------------------------------------------------------------------
C
      IF(PNAME.EQ.' ') THEN
         WRITE(IOUT,*) ' Blank parameter name in the ',PACK,' file.'
         CALL USTOP(' ')
      END IF
C
      CTMP1=PNAME
      CALL UPCASE(CTMP1)
      DO 100 IP=1,MXPAR
        CTMP2=PARNAM(IP)
        CALL UPCASE(CTMP2)
        IF(CTMP1.EQ.CTMP2) THEN
           IF(PARTYP(IP).NE.PTYP) THEN
              WRITE(IOUT,81) PARNAM(IP),PARTYP(IP),PACK,PTYP
   81         FORMAT(1X,'Parameter type conflict:',/
     1          1X,'Named parameter:',A,' was defined as type:',A,/
     2          1X,'However, this parameter is used in the ',A,
     3            ' file, so it should be type:',A)
              CALL USTOP(' ')
           END IF
           IFOUND=IP
           RETURN
        END IF
  100 CONTINUE
C
      WRITE(IOUT,101) PACK
  101 FORMAT(1X,'Parameter for ',A,' Package has not been defined')
      CALL USTOP(' ')
C
      END
      INTEGER FUNCTION INDXPTR(IP,NPE)
C
C-----VERSION 20010301 ERB INDXPTR
C     ******************************************************************
C     Return the position in the IPPTR pointer array of a specified
C     parameter number.  This provides the position for a parameter in
C     arrays with a dimension of NPE.  Function returns 0 if the
C     parameter number IP is not in IPPTR.
C     ******************************************************************
C     IP -  A PARAMETER NUMBER IN THE LIST OF NPLIST PARAMETERS IN THE
C           SEN FILE
C     NPE - NUMBER OF PARAMETERS FOR WHICH ISENS > 0 IN SEN FILE
C
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
      INCLUDE 'param.inc'
C     ------------------------------------------------------------------
      INDXPTR = 0
      DO 10 I=1,NPE
        IF (IPPTR(I).EQ.IP) THEN
          INDXPTR = I
          RETURN
        ENDIF
   10 CONTINUE
      RETURN
      END

max_stars_repo_name: quanpands/wflow

max_issues_repo_name: quanpands/wflow

max_forks_repo_name: quanpands/wflow


text:
      SUBROUTINE PICENV (WKID)

C  PICENV: sets up an environment of posted structures to the
C  specified workstation, so that PICCHG can be perform requested
C  changes.

C  Structure Conventions:
C
C  #101 is posted and contains a polyline, polymarker, text,
C       fill-area-set to exercise primitive representation changes
C       (PCC 1-7).
C
C  #201 is posted with lines fanning out from the bottom,
C       available for element deletion (PCC 13).
C
C  #301-350 are posted each with line fanning out from the top,
C       available for unposting or structure deletion (PCC 15-16)
C
C  #400,401,402 is a small network, with 400 executing either 401 or
C       402, available for <change structure references> (PCC 17).
C       401 has a 60-deg line, 402 a 150-deg line.
C
C  PCC 8-12, 14 require no additional environment.  PCC 14 will post
C  a new structure 5xx, with vertical lines.

C aspect source
C                bundled     individual
      INTEGER    PBUNDL,     PINDIV
      PARAMETER (PBUNDL = 0, PINDIV = 1)
C clipping indicator
C                noclip      clip
      INTEGER    PNCLIP,     PCLIP
      PARAMETER (PNCLIP = 0, PCLIP = 1)

      INTEGER   WKID, ENDPTS(2), IX, LIM2, NAMSET(5), ATTRIB

      REAL      IMAT(3,3), VCLIP(4), PLX(2),PLY(2), PMX(1), PMY(1)
      REAL      FASX(6), FASY(6), ANG, PI
      PARAMETER (PI = 3.14159265)

      DATA VCLIP / 0.0, 1.0, 0.0, 1.0  /

      DATA PLX   / 0.3,0.7 /, PMX /0.08/
      DATA PLY   / 0.7,0.3 /, PMY /0.08/

      DATA FASX   / 0.1, 0.2, 0.3, 0.7, 0.8, 0.9 /
      DATA FASY   / 0.1, 0.3, 0.1, 0.9, 0.7, 0.9 /
      DATA ENDPTS / 3,6 /

C first, clear the decks
      CALL PDAS

C set up 101 with bundled primitives
      CALL POPST (101)
      DO 100 ATTRIB = 0,17
         CALL PSIASF (ATTRIB, PBUNDL)
100   CONTINUE
C use entry #1 in all bundles. This is the default, except for view,
C which must be set explicitly.
      CALL PSVWI (1)
      CALL IDMAT (3, IMAT)
C set up view #1 like default
      CALL PSVWR (WKID, 1, IMAT,IMAT, VCLIP, PCLIP)
      CALL PPL (2, PLX,PLY)
      CALL PPM (1, PMX,PMY)
C potential highlight: filter = [1]
      NAMSET(1) = 1
      CALL PADS (1, NAMSET)
      CALL PSCHH (0.1)
      CALL PTX (0.15, 0.50, '?')
C potential invisibility: filter = [2]
      CALL PRES (1, NAMSET)
      NAMSET(1) = 2
      CALL PADS (1, NAMSET)
      CALL PFAS (2, ENDPTS, FASX,FASY)
      CALL PRES (1, NAMSET)
      CALL PCLST
      CALL PPOST (WKID, 101, 0.5)

C set up 201, posted, with lines fanning out from the bottom
      CALL POPST (201)
      PLX(1) = 0.5
      PLY(1) = 0.0
      LIM2 = 50
      DO 200 IX = 1,LIM2-1
         ANG = PI * IX / LIM2
         PLX(2) = PLX(1) + 0.3 * COS(ANG)
         PLY(2) = PLY(1) + 0.3 * SIN(ANG)
         CALL PPL (2, PLX,PLY)
200   CONTINUE
      CALL PCLST
      CALL PPOST (WKID, 201, 0.5)

C  set up 301-350, posted, each with line fanning out from the top
      PLX(1) = 0.5
      PLY(1) = 1.0
      LIM2 = 50
      DO 300 IX = 1,LIM2
         CALL POPST (300+IX)
         ANG = PI * IX / LIM2
         PLX(2) = PLX(1) + 0.3 * COS(ANG)
         PLY(2) = PLY(1) - 0.3 * SIN(ANG)
         CALL PPL (2, PLX,PLY)
         CALL PCLST
         CALL PPOST (WKID, 300+IX, 0.5)
300   CONTINUE

C  set up 400,401,402 as a small posted network, with 400
C  executing either 401 or 402.  401 has a 60-deg line, 402 a
C  150-deg line.
      CALL POPST (400)
      CALL PEXST (401)
      CALL PCLST
      CALL PPOST (WKID, 400, 0.5)

      PLX(1) = 0.5
      PLY(1) = SQRT(0.75)
      PLY(2) = 0.0

      CALL POPST (401)
      PLX(2) = 0.0
      CALL PPL (2, PLX,PLY)
      CALL PCLST

      CALL POPST (402)
      PLX(2) = 1.0
      CALL PPL (2, PLX,PLY)
      CALL PCLST

      END

ext: f


text:
C    %W% %G%
      function keybrd(key)
C
C     This function returns a value of zero or one. If the value is
c     one, the debug switch for KEY is on. Entry point KRDDBG(KEY)
c     sets the value of each debug switch as defined on the debug
c     card. KRDDBG is called by SWINGM.
C
      include 'tspinc/reread.inc'
      include 'tspinc/param.inc'

      dimension tsnap(6), keywrd(36), keyx(36)

      save

      data tsnap / 6 * 0.0 /
      data keywrd  / 36 * 0 /

C     -     begin     begin     begin     begin     begin     begin

      keybrd = keywrd(key+1)
      if (keybrd .ne. 0) then
        if (to .gt. 0.01) then
          do i = 1, 6, 2
            if ((to .ge. tsnap(i)) .and. (to .le. tsnap(i+1))) goto 100
          enddo
          keybrd = 0
        endif
      endif
      goto 100
      entry krddbg(keyx)
      do i = 1, 36
        keywrd(i) = keyx(i)
      enddo
      read (buffer, 10000) (tsnap(i), i = 1, 6)
10000 format (bz, 50x, 6f5.1)
      nbl = 0
      to = 0.0
      do i = 1, 6
        if (tsnap(i) .gt. 0.0) nbl = 1
      enddo
      if (nbl .eq. 0) tsnap(2) = 9999.0
      keybrd = 0
  100 return
      end

max_stars_repo_name: mbheinen/bpa-ipf-tsp

max_issues_repo_name: cuihantao/bpa-ipf-tsp

max_forks_repo_name: mbheinen/bpa-ipf-tsp


text:
! <get_model_depth.for - A component of the City-scale
!                 Chemistry Transport Model EPISODE-CityChem>
!*****************************************************************************!
!*
!* EPISODE - An urban-scale air quality model
!* ==========================================
!* Copyright (C) 2018  NILU - Norwegian Institute for Air Research
!*                     Instituttveien 18
!*                     PO Box 100
!*                     NO-2027 Kjeller
!*                     Norway
!*
!*                     Contact persons: Gabriela Sousa Santos - gss@nilu.no
!*                                      Paul Hamer - pdh@nilu.no
!*
!* Unless explicitly acquired and licensed from Licensor under another license,
!* the contents of this file are subject to the Reciprocal Public License ("RPL")
!* Version 1.5, https://opensource.org/licenses/RPL-1.5 or subsequent versions as
!* allowed by the RPL, and You may not copy or use this file in either source code
!* or executable form, except in compliance with the terms and conditions of the RPL.
!*
!* All software distributed under the RPL is provided strictly on an "AS IS" basis,
!* WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, AND LICENSOR HEREBY
!* DISCLAIMS ALL SUCH WARRANTIES, INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF
!* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT, OR NON-INFRINGEMENT.
!* See the RPL for specific language governing rights and limitations under the RPL.
!*
!* ==========================================
!* The dispersion model EPISODE (Grønskei et. al., 1993; Larssen et al., 1994;
!* Walker et al., 1992, 1999; Slørdal et al., 2003, 2008) is an Eulerian grid model
!* with embedded subgrid models for calculations of pollutant concentrations resulting
!* from different types of sources (area-, line- and point sources). EPISODE solves the
!* time dependent advection/-diffusion equation on a 3 dimensional grid.
!* Finite difference numerical methods are applied to integrate the solution forward in time.
!* It also includes extensions as the implementation of a simplified EMEP photochemistry
!* scheme for urban areas (Walker et al. 2004) and a scheme for Secondary Organic Aerosol
!* implemented by Håvard Slørdal
!*
!* Grønskei, K.E., Walker, S.E., Gram, F. (1993) Evaluation of a model for hourly spatial
!*    concentrations distributions. Atmos. Environ., 27B, 105-120.
!* Larssen, S., Grønskei, K.E., Gram, F., Hagen, L.O., Walker, S.E. (1994) Verification of
!*    urban scale time-dependent dispersion model with sub-grid elements in Oslo, Norway.
!*    In: Air poll. modelling and its appl. X. New York, Plenum Press.
!* Slørdal, L.H., McInnes, H., Krognes, T. (2008): The Air Quality Information System AirQUIS.
!*    Info. Techn. Environ. Eng., 1, 40-47, 2008.
!* Slørdal, L.H., Walker, S.-E., Solberg, S. (2003) The Urban Air Dispersion Model EPISODE
!*    applied in AirQUIS. Technical Description. NILU TR 12/2003. ISBN 82-425-1522-0.
!* Walker, S.E., Grønskei, K.E. (1992) Spredningsberegninger for on-line overvåking i Grenland.
!*    Programbeskrivelse og brukerveiledning. Lillestrøm,
!*    Norwegian Institute for Air Research (NILU OR 55/92).
!* Walker, S.E., Slørdal, L.H., Guerreiro, C., Gram, F., Grønskei, K.E. (1999) Air pollution
!*    exposure monitoring and estimation. Part II. Model evaluation and population exposure.
!*    J. Environ. Monit, 1, 321-326.
!* Walker, S.-E., Solberg, S., Denby, B. (2003) Development and implementation of a simplified
!*    EMEP photochemistry scheme for urban areas in EPISODE. NILU TR 13/2013.
!*    ISBN 82-425-1524-7
!*
!* ==========================================
!*
!**********************************************************************

      subroutine get_model_depth

!***********************************************************************
!
! This routine either reads the topography from some external source
! or calculates some idealized topography for test purposes,
! and calculates the model-depth.

! Modifications:
!    29 Jan 2019  M. Karl: Commented pre-processor directive 'main_program'
!    29 Jan 2019  M. Karl: replaced TAB by spaces
!
!***********************************************************************
! If needed, insert the necessary MODULE calls:
!
      use module_mc_wind_files
      use module_mc_wind_domain
!
!***********************************************************************

! *** We require the use of: implicit none:
      implicit none

! *** Local declarations:
      integer :: i,j
      real    :: min_topo
      real    :: topo_scale

!MSK!DEC$ IF DEFINED (main_program)

      integer :: k
      integer :: iant_smooth,i_smooth_formula
      real    :: pi,x,y,xlength,ylength
      real    :: bigD
      real    :: wsm_sum
      real    :: wsm(1:25)

      real, allocatable :: sm_topo(:,:)

      if (.not. allocated (sm_topo))  &
            allocate (sm_topo(0:im+1,0:jm+1))

! *** Content of the routine:

      if (fe_in_top) then

        min_topo   = MINVAL(in_top)
        topo_scale = 1.0

        do i = 1,im
          do j = 1,jm
            topo(i,j) = (in_top(i,j) - min_topo) * topo_scale
          end do
        end do

        else

! ***   If an idealized topography is needed, it is computed below:
        pi = 2.0 * ASIN(1.0)

        xlength = (im-1)*dx
        ylength = (jm-1)*dy

        topo = 0.0

        do i = 2,im-1
          do j = 2,jm-1
            x = (i-1)*dx
            y = (j-1)*dy
                topo(i,j) = SIN((pi*x)/xlength)*SIN((pi*y)/ylength)* &
                       elev_max
          end do
        end do

      end if  ! (fe_in_top)

!MSK!DEC$ ELSE
!
! ***   DLL_Version:
!
!        min_topo   = MINVAL(in_top)
!        topo_scale = 1.0
!
!        do i = 1,im
!          do j = 1,jm
!            topo(i,j) = (in_top(i,j) - min_topo) * topo_scale
!          end do
!        end do
!
!MSK!DEC$ ENDIF

! *** If the topography is read from some external source we must
! *** decide on what to do at the boundaries. If the available
! *** topography just covers the inner domain (i=1,im , j=1,jm) then
! *** we must define the outermost values, i.e topo(i,j) for i=0,
! *** i=im+1, j=0 and j=jm+1. Below this is done by setting these
! *** values equal to the neighbour inner domain point:
      do j=1,jm
        topo(0,j)    = topo(1,j)
        topo(im+1,j) = topo(im,j)
      end do
      do i=0,im+1
        topo(i,0)    = topo(i,1)
        topo(i,jm+1) = topo(i,jm)
      end do

!MSK!DEC$ IF DEFINED (main_program)

! ----------------------------------------------------------------------
! *** Smoothing the topography:
      iant_smooth = 1

      i_smooth_formula = 1
!      i_smooth_formula = 5
!      i_smooth_formula = 8
!       i_smooth_formula = 13
!      i_smooth_formula = 24

      wsm = 0.0
      wsm_sum = 0.0

      if ( i_smooth_formula == 1 ) then

        wsm(13) = 1.0

      else if (i_smooth_formula == 5 ) then
        wsm(8)  = 1.0/8.0
        wsm(12) = 1.0/8.0
        wsm(13) = 1.0/2.0
        wsm(14) = 1.0/8.0
        wsm(18) = 1.0/8.0

      else if ( i_smooth_formula == 13 ) then

        wsm(3)  = 1.0/24.0
        wsm(7)  = 1.0/24.0
        wsm(8)  = 1.0/12.0
        wsm(9)  = 1.0/24.0
        wsm(11) = 1.0/24.0
        wsm(12) = 1.0/12.0
        wsm(13) = 1.0/3.0
        wsm(14) = 1.0/12.0
        wsm(15) = 1.0/24.0
        wsm(17) = 1.0/24.0
        wsm(18) = 1.0/12.0
        wsm(19) = 1.0/24.0
        wsm(23) = 1.0/24.0

      else if ( i_smooth_formula == 8 ) then

        bigD   = 1.0/(1.5*dx)

        wsm(1) = dx*SQRT(1.25)
        wsm(1) = 1.0*EXP(-wsm(1)*bigD)
        wsm(3) = 1.5*dx
        wsm(3) = 1.0*EXP(-wsm(3)*bigD)
        wsm(4) = 0.5*dx
        wsm(4) = 1.0*EXP(-wsm(4)*bigD)

        wsm(2) = wsm(1)
        wsm(5) = wsm(4)
        wsm(6) = wsm(3)
        wsm(7) = wsm(1)
        wsm(8) = wsm(1)

      else if ( i_smooth_formula == 24 ) then

        bigD   = 1.0/(2.0*dx)

        wsm(1) = SQRT(2.5*dx)
        wsm(1) = 1.0*EXP(-wsm(1)*bigD)
        wsm(2) = 1.5*dx
        wsm(2) = 1.0*EXP(-wsm(2)*bigD)
        wsm(5) = SQRT(1.5*dx)
        wsm(5) = 1.0*EXP(-wsm(5)*bigD)
        wsm(9) = dx
        wsm(9) = 1.0*EXP(-wsm(9)*bigD)

        wsm(3)  = wsm(1)
        wsm(4)  = wsm(1)
        wsm(7)  = wsm(1)
        wsm(18) = wsm(1)
        wsm(21) = wsm(1)
        wsm(22) = wsm(1)
        wsm(24) = wsm(1)

        wsm(11) = wsm(2)
        wsm(14) = wsm(2)
        wsm(23) = wsm(2)

        wsm(6)  = wsm(5)
        wsm(8)  = wsm(5)
        wsm(10) = wsm(5)
        wsm(15) = wsm(5)
        wsm(17) = wsm(5)
        wsm(19) = wsm(5)
        wsm(20) = wsm(5)

        wsm(12) = wsm(9)
        wsm(13) = wsm(9)
        wsm(16) = wsm(9)

      end if

      do k = 1,25
        wsm_sum = wsm_sum + wsm(k)
      end do
      do k = 1,25
        wsm(k) = wsm(k)/wsm_sum
      end do

      do k = 1,25
        print *,' wsm(k) = ',wsm(k),' for k = ',k
      end do

      do k = 1,iant_smooth

        if (i_smooth_formula == 1 .OR. i_smooth_formula == 5 .OR. &
       i_smooth_formula ==13)then

          do i = 2,im-1
            do j = 2,jm-1
              sm_topo(i,j) =  &
                    wsm(1) *topo(i-2,j+2)  + wsm(2) *topo(i-1,j+2) &
                  + wsm(3) *topo(i,j+2)    + wsm(4) *topo(i+1,j+2) &
                  + wsm(5) *topo(i+2,j+2)  + wsm(6) *topo(i-2,j+1) &
                  + wsm(7) *topo(i-1,j+1)  + wsm(8) *topo(i,j+1) &
                  + wsm(9) *topo(i+1,j+1)  + wsm(10)*topo(i+2,j+1) &
                  + wsm(11)*topo(i-2,j)    + wsm(12)*topo(i-1,j) &
                  + wsm(13)*topo(i,j)      + wsm(14)*topo(i+1,j) &
                  + wsm(15)*topo(i+2,j)    + wsm(16)*topo(i-2,j-1) &
                  + wsm(17)*topo(i-1,j-1)  + wsm(18)*topo(i,j-1) &
                  + wsm(19)*topo(i+1,j-1)  + wsm(20)*topo(i+2,j-1) &
                  + wsm(21)*topo(i-2,j-2)  + wsm(22)*topo(i-1,j-2) &
                  + wsm(23)*topo(i,j-2)    + wsm(24)*topo(i+1,j-2) &
                  + wsm(25)*topo(i+2,j-2)
            end do
          end do

        else if(i_smooth_formula == 24) then

          do i = 2,im-1
            do j = 2,jm-1
              sm_topo(i,j) =  &
                    wsm(1)  * 0.5*(topo(i-1,j+2) + topo(i-1,j+1)) &
                  + wsm(2)  * 0.5*(topo(i,j+2)   + topo(i,j+1)) &
                  + wsm(3)  * 0.5*(topo(i+1,j+2) + topo(i+1,j+1)) &
                  + wsm(4)  * 0.5*(topo(i-2,j+1) + topo(i-1,j+1)) &
                  + wsm(5)  * 0.5*(topo(i-1,j+1) + topo(i,j+1)) &
                  + wsm(6)  * 0.5*(topo(i,j+1)   + topo(i+1,j+1)) &
                  + wsm(7)  * 0.5*(topo(i+1,j+1) + topo(i+2,j+1)) &
                  + wsm(8)  * 0.5*(topo(i-1,j+1) + topo(i-1,j)) &
                  + wsm(9)  * 0.5*(topo(i,j+1)   + topo(i,j)) &
                  + wsm(10) * 0.5*(topo(i+1,j+1) + topo(i+1,j)) &
                  + wsm(11) * 0.5*(topo(i-2,j)   + topo(i-1,j)) &
                  + wsm(12) * 0.5*(topo(i-1,j)   + topo(i,j)) &
                  + wsm(13) * 0.5*(topo(i,j)     + topo(i+1,j)) &
                  + wsm(14) * 0.5*(topo(i+1,j)   + topo(i+2,j)) &
                  + wsm(15) * 0.5*(topo(i-1,j)   + topo(i-1,j-1)) &
                  + wsm(16) * 0.5*(topo(i,j)     + topo(i,j-1)) &
                  + wsm(17) * 0.5*(topo(i+1,j)   + topo(i+1,j-1)) &
                  + wsm(18) * 0.5*(topo(i-2,j-1) + topo(i-1,j-1)) &
                  + wsm(19) * 0.5*(topo(i-1,j-1) + topo(i,j-1)) &
                  + wsm(20) * 0.5*(topo(i,j-1)   + topo(i+1,j-1)) &
                  + wsm(21) * 0.5*(topo(i+1,j-1) + topo(i+2,j-1)) &
                  + wsm(22) * 0.5*(topo(i-1,j-1) + topo(i-1,j-2)) &
                  + wsm(23) * 0.5*(topo(i,j-1)   + topo(i,j-2)) &
                  + wsm(24) * 0.5*(topo(i+1,j-1) + topo(i+1,j-2))
            end do
          end do

        else if(i_smooth_formula == 8) then

          do i = 1,im-1
            do j = 1,jm
              topou(i,j) =  wsm(1) * topo(i,  j+1) &
                     + wsm(2) * topo(i+1,j+1) &
                     + wsm(3) * topo(i-1,j  ) &
                     + wsm(4) * topo(i  ,j  ) &
                     + wsm(5) * topo(i+1,j  ) &
                     + wsm(6) * topo(i+2,j  ) &
                     + wsm(7) * topo(i  ,j-1) &
                     + wsm(8) * topo(i+1,j-1)
            end do
          end do

          do j = 1,im
            topou(0,j)  = topou(i,1)
            topou(im,j) = topou(i,im-1)
          end do

          do i = 1,im
            do j = 1,jm-1
              topov(i,j) =  wsm(1) * topo(i-1,j+1) &
                     + wsm(2) * topo(i+1,j+1) &
                     + wsm(3) * topo(i  ,j+2) &
                     + wsm(4) * topo(i  ,j+1) &
                     + wsm(5) * topo(i  ,j  ) &
                     + wsm(6) * topo(i  ,j-1) &
                     + wsm(7) * topo(i-1,j  ) &
                     + wsm(8) * topo(i+1,j  )
            end do
          end do

          do i = 1,im
            topov(i,0)  = topov(i,1)
            topov(i,im) = topov(i,im-1)
          end do

        end if

        do i = 2,im-1
         do j = 2,jm-1
           topo(i,j) = sm_topo(i,j)
         end do
        end do

      end do ! k = 1,iant_smooth

! *** Deallocate local variables:
      if (allocated (sm_topo)) deallocate (sm_topo)
! ----------------------------------------------------------------------

!MSK!DEC$ ENDIF

! Define the model depth: "depth(0:im+1,0:jm+1)" from the
! maximum model depth, "h0", and the topography: "topo(0:im+1,0:jm+1)":

      do j = 0,jm+1
        do i = 0,im+1
          depth(i,j) = h0 - topo(i,j)
        end do
      end do

      return
      end subroutine get_model_depth

ext: for

max_stars_repo_name: mdhillmancmcl/TheWorldAvatar-CMCL-Fork

max_issues_repo_name: mdhillmancmcl/TheWorldAvatar-CMCL-Fork

max_forks_repo_name: mdhillmancmcl/TheWorldAvatar-CMCL-Fork


! Objetivo: Integrar a equacao diferencial do oscilador de Van der Pol
!	    de t=0 ate t=8pi para obter os graficos x, v e E/m em funcao de
!           t/pi e investigar sua trajetoria no espaco de fase.

MODULE derivada
	REAL, PARAMETER :: omega0=1.0,mu=1.0,x0=1.0
CONTAINS
	SUBROUTINE deriv_func_vanderpol(t, x, dxdt)
		USE nrtype
		IMPLICIT none
		REAL(SP), intent(in) :: t
		REAL(SP), DIMENSION(:), intent(in) :: x
		REAL(SP), DIMENSION(:), intent(out) :: dxdt
		dxdt(1)=x(2)
		dxdt(2)=mu*x(2)*(x0**2-(x(1))**2)-x(1)*omega0**2
	END SUBROUTINE deriv_func_vanderpol
END MODULE derivada

PROGRAM oscilador_van_der_pol
	USE nrtype
	USE derivada
	USE nr, only: bsstep, odeint
	IMPLICIT none
	INTEGER :: ponto_ti, curva_in
	INTEGER, PARAMETER :: Arquivo_t_x_v_Em=1, Arquivo_espaco_fase=2
	INTEGER, PARAMETER :: pontos=800, num_curvas=6
	REAL :: t1, t2, Em
	REAL, DIMENSION(2) :: x
	REAL, PARAMETER :: pts_menos1=pontos-1, curv_menos1=num_curvas-1
	REAL, PARAMETER :: tempo_i=0.0, tempo_final=8.0*pi, variacao_t= &
					& (tempo_final-tempo_i)/pts_menos1
	REAL, PARAMETER :: posicao_i=0.5, posicao_f=3.0, variacao_posi= &
					& (posicao_f-posicao_i)/curv_menos1
	REAL, PARAMETER :: velocidade_i=0.0, eps=epsilon(posicao_i), &
						&  h1=1.e-6, hmin=0.0
	REAL, PARAMETER :: meio_omega02=0.5*omega0**2
	x(1)=posicao_i
	x(2)=velocidade_i
	t1=tempo_i

	OPEN(unit=Arquivo_t_x_v_Em, file="x_v_Em_vs_tpi.dat")
	OPEN(unit=Arquivo_espaco_fase, file="v_vs_x.dat")
! Escrever a posicao, velocidade e energia total dividida pela massa
! em funcao do tempo/pi
	WRITE(unit=Arquivo_t_x_v_Em,fmt=*) t1/pi, x, 0.5*x(2)**2+ &
						& meio_omega02*x(1)**2
	t2=tempo_i+variacao_t
	DO ponto_ti=2, pontos
		CALL odeint(x, t1, t2, eps, h1, hmin, deriv_func_vanderpol, bsstep)
! Escrever a posicao, velocidade e energia total dividida pela massa
! em funcao do tempo/pi
		WRITE(unit=Arquivo_t_x_v_Em,fmt=*) t2/pi, x, 0.5*x(2)**2+ &
						& meio_omega02*x(1)**2
		t1=t2
		t2=t2+variacao_t
	END DO
! Investigando a trajetoria do oscilador no espaco de fase
	x(1)=posicao_i
	DO curva_in=1, num_curvas
		t1=tempo_i
		t2=tempo_i+variacao_t
		x(2)=x(1)
		WRITE(unit=Arquivo_espaco_fase,fmt=*) x
		DO ponto_ti=1,pontos
			CALL odeint(x,t1,t2,eps,h1,hmin,deriv_func_vanderpol,bsstep)
			WRITE(unit=Arquivo_espaco_fase,fmt=*) x
			t1=t2
			t2=t2+variacao_t
		END DO
		WRITE(unit=Arquivo_espaco_fase,fmt=*)
		x(1)=posicao_i+variacao_posi*REAL(curva_in)
	END DO
	CLOSE(unit=Arquivo_t_x_v_Em)
	CLOSE(unit=Arquivo_espaco_fase)
END PROGRAM oscilador_van_der_pol


! { dg-do run }
! { dg-options "-fdec-structure" }
!
! Test whether union backend declarations are corrently _not_ copied when they
! are not in fact equal. The structure defined in sub() is seen later, but
! where siz has a different value.
!

subroutine aborts (s)
  character(*), intent(in) :: s
  print *, s
  STOP 1
end subroutine

subroutine sub ()
  integer, parameter :: siz = 1024
  structure /s6/
    union ! U0
      map ! M0
        integer ibuf(siz)
      end map
      map ! M1
        character(8) cbuf(siz)
      end map
      map ! M2
        real rbuf(siz)
      end map
    end union
  end structure
  record /s6/ r6
  r6.ibuf(1) = z'badbeef'
  r6.ibuf(2) = z'badbeef'
end subroutine

! Repeat definition from subroutine sub with different size parameter.
! If the structure definition is copied here the stack may get messed up.
integer, parameter :: siz = 65536
structure /s6/
  union ! U12
    map
      integer ibuf(siz)
    end map
    map
      character(8) cbuf(siz)
    end map
    map
      real rbuf(siz)
    end map
  end union
end structure

record /s6/ r6
integer :: r6_canary = 0

! Copied type declaration - this should not cause problems
i = 1
do while (i < siz)
  r6.ibuf(i) = z'badbeef'
  i = i + 1
end do

if ( r6_canary .ne. 0 ) then
  call aborts ('copied decls: overflow')
endif

end


text:
*> \brief \b ALAERH
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU,
*                          N5, IMAT, NFAIL, NERRS, NOUT )
*
*       .. Scalar Arguments ..
*       CHARACTER*3        PATH
*       CHARACTER*( * )    SUBNAM
*       CHARACTER*( * )    OPTS
*       INTEGER            IMAT, INFO, INFOE, KL, KU, M, N, N5, NERRS,
*      $                   NFAIL, NOUT
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ALAERH is an error handler for the LAPACK routines.  It prints the
*> header if this is the first error message and prints the error code
*> and form of recovery, if any.  The character evaluations in this
*> routine may make it slow, but it should not be called once the LAPACK
*> routines are fully debugged.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] PATH
*> \verbatim
*>          PATH is CHARACTER*3
*>          The LAPACK path name of subroutine SUBNAM.
*> \endverbatim
*>
*> \param[in] SUBNAM
*> \verbatim
*>          SUBNAM is CHARACTER*(*)
*>          The name of the subroutine that returned an error code.
*> \endverbatim
*>
*> \param[in] INFO
*> \verbatim
*>          INFO is INTEGER
*>          The error code returned from routine SUBNAM.
*> \endverbatim
*>
*> \param[in] INFOE
*> \verbatim
*>          INFOE is INTEGER
*>          The expected error code from routine SUBNAM, if SUBNAM were
*>          error-free.  If INFOE = 0, an error message is printed, but
*>          if INFOE.NE.0, we assume only the return code INFO is wrong.
*> \endverbatim
*>
*> \param[in] OPTS
*> \verbatim
*>          OPTS is CHARACTER*(*)
*>          The character options to the subroutine SUBNAM, concatenated
*>          into a single character string.  For example, UPLO = 'U',
*>          TRANS = 'T', and DIAG = 'N' for a triangular routine would
*>          be specified as OPTS = 'UTN'.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The matrix row dimension.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The matrix column dimension.  Accessed only if PATH = xGE or
*>          xGB.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*>          KL is INTEGER
*>          The number of sub-diagonals of the matrix.  Accessed only if
*>          PATH = xGB, xPB, or xTB.  Also used for NRHS for PATH = xLS.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*>          KU is INTEGER
*>          The number of super-diagonals of the matrix.  Accessed only
*>          if PATH = xGB.
*> \endverbatim
*>
*> \param[in] N5
*> \verbatim
*>          N5 is INTEGER
*>          A fifth integer parameter, may be the blocksize NB or the
*>          number of right hand sides NRHS.
*> \endverbatim
*>
*> \param[in] IMAT
*> \verbatim
*>          IMAT is INTEGER
*>          The matrix type.
*> \endverbatim
*>
*> \param[in] NFAIL
*> \verbatim
*>          NFAIL is INTEGER
*>          The number of prior tests that did not pass the threshold;
*>          used to determine if the header should be printed.
*> \endverbatim
*>
*> \param[in,out] NERRS
*> \verbatim
*>          NERRS is INTEGER
*>          On entry, the number of errors already detected; used to
*>          determine if the header should be printed.
*>          On exit, NERRS is increased by 1.
*> \endverbatim
*>
*> \param[in] NOUT
*> \verbatim
*>          NOUT is INTEGER
*>          The unit number on which results are to be printed.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2013
*
*> \ingroup aux_lin
*
*  =====================================================================
      SUBROUTINE ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU,
     $                   N5, IMAT, NFAIL, NERRS, NOUT )
*
*  -- LAPACK test routine (version 3.5.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2013
*
*     .. Scalar Arguments ..
      CHARACTER*3        PATH
      CHARACTER*( * )    SUBNAM
      CHARACTER*( * )    OPTS
      INTEGER            IMAT, INFO, INFOE, KL, KU, M, N, N5, NERRS,
     $                   NFAIL, NOUT
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      CHARACTER          UPLO
      CHARACTER*2        P2
      CHARACTER*3        C3
*     ..
*     .. External Functions ..
      LOGICAL            LSAME, LSAMEN
      EXTERNAL           LSAME, LSAMEN
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          LEN_TRIM
*     ..
*     .. External Subroutines ..
      EXTERNAL           ALADHD, ALAHD
*     ..
*     .. Executable Statements ..
*
      IF( INFO.EQ.0 )
     $   RETURN
      P2 = PATH( 2: 3 )
      C3 = SUBNAM( 4: 6 )
*
*     Print the header if this is the first error message.
*
      IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN
         IF( LSAMEN( 3, C3, 'SV ' ) .OR. LSAMEN( 3, C3, 'SVX' ) ) THEN
            CALL ALADHD( NOUT, PATH )
         ELSE
            CALL ALAHD( NOUT, PATH )
         END IF
      END IF
      NERRS = NERRS + 1
*
*     Print the message detailing the error and form of recovery,
*     if any.
*
      IF( LSAMEN( 2, P2, 'GE' ) ) THEN
*
*        xGE:  General matrices
*
         IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9988 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, M, N, N5,
     $            IMAT
            ELSE
               WRITE( NOUT, FMT = 9975 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, N5, IMAT
            END IF
            IF( INFO.NE.0 )
     $         WRITE( NOUT, FMT = 9949 )
*
         ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9984 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, N, N5,
     $            IMAT
            ELSE
               WRITE( NOUT, FMT = 9970 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, N, N5, IMAT
            END IF
*
         ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9992 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE,
     $            OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT
            ELSE
               WRITE( NOUT, FMT = 9997 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ),
     $            OPTS( 2: 2 ), N, N5, IMAT
            END IF
*
         ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
*
            WRITE( NOUT, FMT = 9971 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, N, N5, IMAT
*
         ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
*
            WRITE( NOUT, FMT = 9978 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, IMAT
*
         ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
*
            WRITE( NOUT, FMT = 9969 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M,
     $         IMAT
*
         ELSE IF( LSAMEN( 3, C3, 'LS ' ) ) THEN
*
            WRITE( NOUT, FMT = 9965 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, N,
     $         KL, N5, IMAT
*
         ELSE IF( LSAMEN( 3, C3, 'LSX' ) .OR. LSAMEN( 3, C3, 'LSS' ) )
     $             THEN
*
            WRITE( NOUT, FMT = 9974 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, KL, N5, IMAT
*
         ELSE
*
            WRITE( NOUT, FMT = 9963 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, N5,
     $         IMAT
         END IF
*
      ELSE IF( LSAMEN( 2, P2, 'GB' ) ) THEN
*
*        xGB:  General band matrices
*
         IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9989 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, M, N, KL,
     $            KU, N5, IMAT
            ELSE
               WRITE( NOUT, FMT = 9976 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, KL, KU, N5,
     $            IMAT
            END IF
            IF( INFO.NE.0 )
     $         WRITE( NOUT, FMT = 9949 )
*
         ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9986 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, N, KL, KU,
     $            N5, IMAT
            ELSE
               WRITE( NOUT, FMT = 9972 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, N, KL, KU, N5,
     $            IMAT
            END IF
*
         ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9993 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE,
     $            OPTS( 1: 1 ), OPTS( 2: 2 ), N, KL, KU, N5, IMAT
            ELSE
               WRITE( NOUT, FMT = 9998 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ),
     $            OPTS( 2: 2 ), N, KL, KU, N5, IMAT
            END IF
*
         ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
*
            WRITE( NOUT, FMT = 9977 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, KL, KU, IMAT
*
         ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
*
            WRITE( NOUT, FMT = 9968 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, KL,
     $         KU, IMAT
*
         ELSE
*
            WRITE( NOUT, FMT = 9964 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, KL,
     $         KU, N5, IMAT
         END IF
*
      ELSE IF( LSAMEN( 2, P2, 'GT' ) ) THEN
*
*        xGT:  General tridiagonal matrices
*
         IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9987 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, N, IMAT
            ELSE
               WRITE( NOUT, FMT = 9973 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, N, IMAT
            END IF
            IF( INFO.NE.0 )
     $         WRITE( NOUT, FMT = 9949 )
*
         ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9984 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, N, N5,
     $            IMAT
            ELSE
               WRITE( NOUT, FMT = 9970 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, N, N5, IMAT
            END IF
*
         ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9992 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE,
     $            OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT
            ELSE
               WRITE( NOUT, FMT = 9997 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ),
     $            OPTS( 2: 2 ), N, N5, IMAT
            END IF
*
         ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
*
            WRITE( NOUT, FMT = 9969 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M,
     $         IMAT
*
         ELSE
*
            WRITE( NOUT, FMT = 9963 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, N5,
     $         IMAT
         END IF
*
      ELSE IF( LSAMEN( 2, P2, 'PO' ) ) THEN
*
*        xPO:  Symmetric or Hermitian positive definite matrices
*
         UPLO = OPTS( 1: 1 )
         IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9980 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, M,
     $            N5, IMAT
            ELSE
               WRITE( NOUT, FMT = 9956 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, N5, IMAT
            END IF
            IF( INFO.NE.0 )
     $         WRITE( NOUT, FMT = 9949 )
*
         ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9979 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, N,
     $            N5, IMAT
            ELSE
               WRITE( NOUT, FMT = 9955 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, N, N5, IMAT
            END IF
*
         ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9990 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE,
     $            OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT
            ELSE
               WRITE( NOUT, FMT = 9995 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ),
     $            OPTS( 2: 2 ), N, N5, IMAT
            END IF
*
         ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
*
            WRITE( NOUT, FMT = 9956 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, N5, IMAT
*
         ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) .OR.
     $            LSAMEN( 3, C3, 'CON' ) ) THEN
*
            WRITE( NOUT, FMT = 9960 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, IMAT
*
         ELSE
*
            WRITE( NOUT, FMT = 9955 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, N5, IMAT
         END IF
*
      ELSE IF( LSAMEN( 2, P2, 'PS' ) ) THEN
*
*        xPS:  Symmetric or Hermitian positive semi-definite matrices
*
         UPLO = OPTS( 1: 1 )
         IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9980 )SUBNAM, INFO, INFOE, UPLO, M,
     $            N5, IMAT
            ELSE
               WRITE( NOUT, FMT = 9956 )SUBNAM, INFO, UPLO, M, N5, IMAT
            END IF
            IF( INFO.NE.0 )
     $         WRITE( NOUT, FMT = 9949 )
*
         ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9979 )SUBNAM, INFO, INFOE, UPLO, N,
     $            N5, IMAT
            ELSE
               WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, N, N5, IMAT
            END IF
*
         ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9990 )SUBNAM, INFO, INFOE,
     $            OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT
            ELSE
               WRITE( NOUT, FMT = 9995 )SUBNAM, INFO, OPTS( 1: 1 ),
     $            OPTS( 2: 2 ), N, N5, IMAT
            END IF
*
         ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
*
            WRITE( NOUT, FMT = 9956 )SUBNAM, INFO, UPLO, M, N5, IMAT
*
         ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMT' ) .OR.
     $            LSAMEN( 3, C3, 'CON' ) ) THEN
*
            WRITE( NOUT, FMT = 9960 )SUBNAM, INFO, UPLO, M, IMAT
*
         ELSE
*
            WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, M, N5, IMAT
         END IF
*
      ELSE IF( LSAMEN( 2, P2, 'SY' )
     $         .OR. LSAMEN( 2, P2, 'SR' )
     $         .OR. LSAMEN( 2, P2, 'HE' )
     $         .OR. LSAMEN( 2, P2, 'HR' ) ) THEN
*
*        xSY: symmetric indefinite matrices
*             with partial (Bunch-Kaufman) pivoting;
*        xSR: symmetric indefinite matrices
*             with rook (bounded Bunch-Kaufman) pivoting;
*        xHE: Hermitian indefinite matrices
*             with partial (Bunch-Kaufman) pivoting.
*        xHR: Hermitian indefinite matrices
*             with rook (bounded Bunch-Kaufman) pivoting;
*
         UPLO = OPTS( 1: 1 )
         IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9980 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, M,
     $            N5, IMAT
            ELSE
               WRITE( NOUT, FMT = 9956 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, N5, IMAT
            END IF
            IF( INFO.NE.0 )
     $         WRITE( NOUT, FMT = 9949 )
*
         ELSE IF( LSAMEN( 2, C3, 'SV' ) ) THEN
*
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9979 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, N,
     $            N5, IMAT
            ELSE
               WRITE( NOUT, FMT = 9955 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, N, N5, IMAT
            END IF
*
         ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9990 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE,
     $            OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT
            ELSE
               WRITE( NOUT, FMT = 9995 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ),
     $            OPTS( 2: 2 ), N, N5, IMAT
            END IF
*
         ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) .OR.
     $            LSAMEN( 3, C3, 'TRI' ) .OR. LSAMEN( 3, C3, 'CON' ) )
     $             THEN
*
            WRITE( NOUT, FMT = 9960 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, IMAT
*
         ELSE
*
            WRITE( NOUT, FMT = 9955 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, N5, IMAT
         END IF
*
      ELSE IF( LSAMEN( 2, P2, 'PP' ) .OR. LSAMEN( 2, P2, 'SP' ) .OR.
     $         LSAMEN( 2, P2, 'HP' ) ) THEN
*
*        xPP, xHP, or xSP:  Symmetric or Hermitian packed matrices
*
         UPLO = OPTS( 1: 1 )
         IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9983 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, M,
     $            IMAT
            ELSE
               WRITE( NOUT, FMT = 9960 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, IMAT
            END IF
            IF( INFO.NE.0 )
     $         WRITE( NOUT, FMT = 9949 )
*
         ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9979 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, N,
     $            N5, IMAT
            ELSE
               WRITE( NOUT, FMT = 9955 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, N, N5, IMAT
            END IF
*
         ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9990 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE,
     $            OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT
            ELSE
               WRITE( NOUT, FMT = 9995 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ),
     $            OPTS( 2: 2 ), N, N5, IMAT
            END IF
*
         ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) .OR.
     $            LSAMEN( 3, C3, 'TRI' ) .OR. LSAMEN( 3, C3, 'CON' ) )
     $             THEN
*
            WRITE( NOUT, FMT = 9960 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, IMAT
*
         ELSE
*
            WRITE( NOUT, FMT = 9955 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, N5, IMAT
         END IF
*
      ELSE IF( LSAMEN( 2, P2, 'PB' ) ) THEN
*
*        xPB:  Symmetric (Hermitian) positive definite band matrix
*
         UPLO = OPTS( 1: 1 )
         IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9982 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, M,
     $            KL, N5, IMAT
            ELSE
               WRITE( NOUT, FMT = 9958 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, KL, N5,
     $            IMAT
            END IF
            IF( INFO.NE.0 )
     $         WRITE( NOUT, FMT = 9949 )
*
         ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9981 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, N,
     $            KL, N5, IMAT
            ELSE
               WRITE( NOUT, FMT = 9957 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, N, KL, N5,
     $            IMAT
            END IF
*
         ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9991 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE,
     $            OPTS( 1: 1 ), OPTS( 2: 2 ), N, KL, N5, IMAT
            ELSE
               WRITE( NOUT, FMT = 9996 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ),
     $            OPTS( 2: 2 ), N, KL, N5, IMAT
            END IF
*
         ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) .OR.
     $            LSAMEN( 3, C3, 'CON' ) ) THEN
*
            WRITE( NOUT, FMT = 9959 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, KL, IMAT
*
         ELSE
*
            WRITE( NOUT, FMT = 9957 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, KL, N5,
     $         IMAT
         END IF
*
      ELSE IF( LSAMEN( 2, P2, 'PT' ) ) THEN
*
*        xPT:  Positive definite tridiagonal matrices
*
         IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9987 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, N, IMAT
            ELSE
               WRITE( NOUT, FMT = 9973 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, N, IMAT
            END IF
            IF( INFO.NE.0 )
     $         WRITE( NOUT, FMT = 9949 )
*
         ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
*
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9984 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, N, N5,
     $            IMAT
            ELSE
               WRITE( NOUT, FMT = 9970 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, N, N5, IMAT
            END IF
*
         ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
*
            IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
               WRITE( NOUT, FMT = 9994 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE,
     $            OPTS( 1: 1 ), N, N5, IMAT
            ELSE
               WRITE( NOUT, FMT = 9999 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), N,
     $            N5, IMAT
            END IF
*
         ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
*
            IF( LSAME( SUBNAM( 1: 1 ), 'S' ) .OR.
     $          LSAME( SUBNAM( 1: 1 ), 'D' ) ) THEN
               WRITE( NOUT, FMT = 9973 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, IMAT
            ELSE
               WRITE( NOUT, FMT = 9969 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M,
     $            IMAT
            END IF
*
         ELSE
*
            WRITE( NOUT, FMT = 9963 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, N5,
     $         IMAT
         END IF
*
      ELSE IF( LSAMEN( 2, P2, 'TR' ) ) THEN
*
*        xTR:  Triangular matrix
*
         IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
            WRITE( NOUT, FMT = 9961 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ),
     $         OPTS( 2: 2 ), M, N5, IMAT
         ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
            WRITE( NOUT, FMT = 9967 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ),
     $         OPTS( 2: 2 ), OPTS( 3: 3 ), M, IMAT
         ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATRS' ) ) THEN
            WRITE( NOUT, FMT = 9952 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ),
     $         OPTS( 2: 2 ), OPTS( 3: 3 ), OPTS( 4: 4 ), M, IMAT
         ELSE
            WRITE( NOUT, FMT = 9953 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ),
     $         OPTS( 2: 2 ), OPTS( 3: 3 ), M, N5, IMAT
         END IF
*
      ELSE IF( LSAMEN( 2, P2, 'TP' ) ) THEN
*
*        xTP:  Triangular packed matrix
*
         IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
            WRITE( NOUT, FMT = 9962 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ),
     $         OPTS( 2: 2 ), M, IMAT
         ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
            WRITE( NOUT, FMT = 9967 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ),
     $         OPTS( 2: 2 ), OPTS( 3: 3 ), M, IMAT
         ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATPS' ) ) THEN
            WRITE( NOUT, FMT = 9952 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ),
     $         OPTS( 2: 2 ), OPTS( 3: 3 ), OPTS( 4: 4 ), M, IMAT
         ELSE
            WRITE( NOUT, FMT = 9953 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ),
     $         OPTS( 2: 2 ), OPTS( 3: 3 ), M, N5, IMAT
         END IF
*
      ELSE IF( LSAMEN( 2, P2, 'TB' ) ) THEN
*
*        xTB:  Triangular band matrix
*
         IF( LSAMEN( 3, C3, 'CON' ) ) THEN
            WRITE( NOUT, FMT = 9966 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ),
     $         OPTS( 2: 2 ), OPTS( 3: 3 ), M, KL, IMAT
         ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATBS' ) ) THEN
            WRITE( NOUT, FMT = 9951 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ),
     $         OPTS( 2: 2 ), OPTS( 3: 3 ), OPTS( 4: 4 ), M, KL, IMAT
         ELSE
            WRITE( NOUT, FMT = 9954 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ),
     $         OPTS( 2: 2 ), OPTS( 3: 3 ), M, KL, N5, IMAT
         END IF
*
      ELSE IF( LSAMEN( 2, P2, 'QR' ) ) THEN
*
*        xQR:  QR factorization
*
         IF( LSAMEN( 3, C3, 'QRS' ) ) THEN
            WRITE( NOUT, FMT = 9974 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, KL, N5, IMAT
         ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
            WRITE( NOUT, FMT = 9978 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, IMAT
         END IF
*
      ELSE IF( LSAMEN( 2, P2, 'LQ' ) ) THEN
*
*        xLQ:  LQ factorization
*
         IF( LSAMEN( 3, C3, 'LQS' ) ) THEN
            WRITE( NOUT, FMT = 9974 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, KL, N5, IMAT
         ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
            WRITE( NOUT, FMT = 9978 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, IMAT
         END IF
*
      ELSE IF( LSAMEN( 2, P2, 'QL' ) ) THEN
*
*        xQL:  QL factorization
*
         IF( LSAMEN( 3, C3, 'QLS' ) ) THEN
            WRITE( NOUT, FMT = 9974 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, KL, N5, IMAT
         ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
            WRITE( NOUT, FMT = 9978 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, IMAT
         END IF
*
      ELSE IF( LSAMEN( 2, P2, 'RQ' ) ) THEN
*
*        xRQ:  RQ factorization
*
         IF( LSAMEN( 3, C3, 'RQS' ) ) THEN
            WRITE( NOUT, FMT = 9974 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, KL, N5, IMAT
         ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
            WRITE( NOUT, FMT = 9978 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, IMAT
         END IF
*
      ELSE IF( LSAMEN( 2, P2, 'LU' ) ) THEN
*
         IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
            WRITE( NOUT, FMT = 9988 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, M, N, N5,
     $         IMAT
         ELSE
            WRITE( NOUT, FMT = 9975 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, N5, IMAT
         END IF
*
      ELSE IF( LSAMEN( 2, P2, 'CH' ) ) THEN
*
         IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
            WRITE( NOUT, FMT = 9985 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, M, N5, IMAT
         ELSE
            WRITE( NOUT, FMT = 9971 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N5, IMAT
         END IF
*
      ELSE
*
*        Print a generic message if the path is unknown.
*
         WRITE( NOUT, FMT = 9950 )
     $     SUBNAM(1:LEN_TRIM( SUBNAM )), INFO
      END IF
*
*     Description of error message (alphabetical, left to right)
*
*     SUBNAM, INFO, FACT, N, NRHS, IMAT
*
 9999 FORMAT( ' *** Error code from ', A, '=', I5, ', FACT=''', A1,
     $      ''', N=', I5, ', NRHS=', I4, ', type ', I2 )
*
*     SUBNAM, INFO, FACT, TRANS, N, KL, KU, NRHS, IMAT
*
 9998 FORMAT( ' *** Error code from ', A, ' =', I5, / ' ==> FACT=''',
     $      A1, ''', TRANS=''', A1, ''', N=', I5, ', KL=', I5, ', KU=',
     $      I5, ', NRHS=', I4, ', type ', I1 )
*
*     SUBNAM, INFO, FACT, TRANS, N, NRHS, IMAT
*
 9997 FORMAT( ' *** Error code from ', A, ' =', I5, / ' ==> FACT=''',
     $      A1, ''', TRANS=''', A1, ''', N =', I5, ', NRHS =', I4,
     $      ', type ', I2 )
*
*     SUBNAM, INFO, FACT, UPLO, N, KD, NRHS, IMAT
*
 9996 FORMAT( ' *** Error code from ', A, ' =', I5, / ' ==> FACT=''',
     $      A1, ''', UPLO=''', A1, ''', N=', I5, ', KD=', I5, ', NRHS=',
     $      I4, ', type ', I2 )
*
*     SUBNAM, INFO, FACT, UPLO, N, NRHS, IMAT
*
 9995 FORMAT( ' *** Error code from ', A, ' =', I5, / ' ==> FACT=''',
     $      A1, ''', UPLO=''', A1, ''', N =', I5, ', NRHS =', I4,
     $      ', type ', I2 )
*
*     SUBNAM, INFO, INFOE, FACT, N, NRHS, IMAT
*
 9994 FORMAT( ' *** ', A, ' returned with INFO =', I5, ' instead of ',
     $      I2, / ' ==> FACT=''', A1, ''', N =', I5, ', NRHS =', I4,
     $      ', type ', I2 )
*
*     SUBNAM, INFO, INFOE, FACT, TRANS, N, KL, KU, NRHS, IMAT
*
 9993 FORMAT( ' *** ', A, ' returned with INFO =', I5, ' instead of ',
     $      I2, / ' ==> FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5,
     $      ', KL=', I5, ', KU=', I5, ', NRHS=', I4, ', type ', I1 )
*
*     SUBNAM, INFO, INFOE, FACT, TRANS, N, NRHS, IMAT
*
 9992 FORMAT( ' *** ', A, ' returned with INFO =', I5, ' instead of ',
     $      I2, / ' ==> FACT=''', A1, ''', TRANS=''', A1, ''', N =', I5,
     $      ', NRHS =', I4, ', type ', I2 )
*
*     SUBNAM, INFO, INFOE, FACT, UPLO, N, KD, NRHS, IMAT
*
 9991 FORMAT( ' *** ', A, ' returned with INFO =', I5, ' instead of ',
     $      I2, / ' ==> FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5,
     $      ', KD=', I5, ', NRHS=', I4, ', type ', I2 )
*
*     SUBNAM, INFO, INFOE, FACT, UPLO, N, NRHS, IMAT
*
 9990 FORMAT( ' *** ', A, ' returned with INFO =', I5, ' instead of ',
     $      I2, / ' ==> FACT=''', A1, ''', UPLO=''', A1, ''', N =', I5,
     $      ', NRHS =', I4, ', type ', I2 )
*
*     SUBNAM, INFO, INFOE, M, N, KL, KU, NB, IMAT
*
 9989 FORMAT( ' *** ', A, ' returned with INFO =', I5, ' instead of ',
     $      I2, / ' ==> M = ', I5, ', N =', I5, ', KL =', I5, ', KU =',
     $      I5, ', NB =', I4, ', type ', I2 )
*
*     SUBNAM, INFO, INFOE, M, N, NB, IMAT
*
 9988 FORMAT( ' *** ', A, ' returned with INFO =', I5, ' instead of ',
     $      I2, / ' ==> M =', I5, ', N =', I5, ', NB =', I4, ', type ',
     $      I2 )
*
*     SUBNAM, INFO, INFOE, N, IMAT
*
 9987 FORMAT( ' *** ', A, ' returned with INFO =', I5, ' instead of ',
     $      I2, ' for N=', I5, ', type ', I2 )
*
*     SUBNAM, INFO, INFOE, N, KL, KU, NRHS, IMAT
*
 9986 FORMAT( ' *** ', A, ' returned with INFO =', I5, ' instead of ',
     $      I2, / ' ==> N =', I5, ', KL =', I5, ', KU =', I5,
     $      ', NRHS =', I4, ', type ', I2 )
*
*     SUBNAM, INFO, INFOE, N, NB, IMAT
*
 9985 FORMAT( ' *** ', A, ' returned with INFO =', I5, ' instead of ',
     $      I2, / ' ==> N =', I5, ', NB =', I4, ', type ', I2 )
*
*     SUBNAM, INFO, INFOE, N, NRHS, IMAT
*
 9984 FORMAT( ' *** ', A, ' returned with INFO =', I5, ' instead of ',
     $      I2, / ' ==> N =', I5, ', NRHS =', I4, ', type ', I2 )
*
*     SUBNAM, INFO, INFOE, UPLO, N, IMAT
*
 9983 FORMAT( ' *** ', A, ' returned with INFO =', I5, ' instead of ',
     $      I2, / ' ==> UPLO = ''', A1, ''', N =', I5, ', type ', I2 )
*
*     SUBNAM, INFO, INFOE, UPLO, N, KD, NB, IMAT
*
 9982 FORMAT( ' *** ', A, ' returned with INFO =', I5, ' instead of ',
     $      I2, / ' ==> UPLO = ''', A1, ''', N =', I5, ', KD =', I5,
     $      ', NB =', I4, ', type ', I2 )
*
*     SUBNAM, INFO, INFOE, UPLO, N, KD, NRHS, IMAT
*
 9981 FORMAT( ' *** ', A, ' returned with INFO =', I5, ' instead of ',
     $      I2, / ' ==> UPLO=''', A1, ''', N =', I5, ', KD =', I5,
     $      ', NRHS =', I4, ', type ', I2 )
*
*     SUBNAM, INFO, INFOE, UPLO, N, NB, IMAT
*
 9980 FORMAT( ' *** ', A, ' returned with INFO =', I5, ' instead of ',
     $      I2, / ' ==> UPLO = ''', A1, ''', N =', I5, ', NB =', I4,
     $      ', type ', I2 )
*
*     SUBNAM, INFO, INFOE, UPLO, N, NRHS, IMAT
*
 9979 FORMAT( ' *** ', A, ' returned with INFO =', I5, ' instead of ',
     $      I2, / ' ==> UPLO = ''', A1, ''', N =', I5, ', NRHS =', I4,
     $      ', type ', I2 )
*
*     SUBNAM, INFO, M, N, IMAT
*
 9978 FORMAT( ' *** Error code from ', A, ' =', I5, ' for M =', I5,
     $      ', N =', I5, ', type ', I2 )
*
*     SUBNAM, INFO, M, N, KL, KU, IMAT
*
 9977 FORMAT( ' *** Error code from ', A, ' =', I5, / ' ==> M = ', I5,
     $      ', N =', I5, ', KL =', I5, ', KU =', I5, ', type ', I2 )
*
*     SUBNAM, INFO, M, N, KL, KU, NB, IMAT
*
 9976 FORMAT( ' *** Error code from ', A, ' =', I5, / ' ==> M = ', I5,
     $      ', N =', I5, ', KL =', I5, ', KU =', I5, ', NB =', I4,
     $      ', type ', I2 )
*
*     SUBNAM, INFO, M, N, NB, IMAT
*
 9975 FORMAT( ' *** Error code from ', A, '=', I5, ' for M=', I5,
     $      ', N=', I5, ', NB=', I4, ', type ', I2 )
*
*     SUBNAM, INFO, M, N, NRHS, NB, IMAT
*
 9974 FORMAT( ' *** Error code from ', A, '=', I5, / ' ==> M =', I5,
     $      ', N =', I5, ', NRHS =', I4, ', NB =', I4, ', type ', I2 )
*
*     SUBNAM, INFO, N, IMAT
*
 9973 FORMAT( ' *** Error code from ', A, ' =', I5, ' for N =', I5,
     $      ', type ', I2 )
*
*     SUBNAM, INFO, N, KL, KU, NRHS, IMAT
*
 9972 FORMAT( ' *** Error code from ', A, ' =', I5, / ' ==> N =', I5,
     $      ', KL =', I5, ', KU =', I5, ', NRHS =', I4, ', type ', I2 )
*
*     SUBNAM, INFO, N, NB, IMAT
*
 9971 FORMAT( ' *** Error code from ', A, '=', I5, ' for N=', I5,
     $      ', NB=', I4, ', type ', I2 )
*
*     SUBNAM, INFO, N, NRHS, IMAT
*
 9970 FORMAT( ' *** Error code from ', A, ' =', I5, ' for N =', I5,
     $      ', NRHS =', I4, ', type ', I2 )
*
*     SUBNAM, INFO, NORM, N, IMAT
*
 9969 FORMAT( ' *** Error code from ', A, ' =', I5, ' for NORM = ''',
     $      A1, ''', N =', I5, ', type ', I2 )
*
*     SUBNAM, INFO, NORM, N, KL, KU, IMAT
*
 9968 FORMAT( ' *** Error code from ', A, ' =', I5, / ' ==> NORM =''',
     $      A1, ''', N =', I5, ', KL =', I5, ', KU =', I5, ', type ',
     $      I2 )
*
*     SUBNAM, INFO, NORM, UPLO, DIAG, N, IMAT
*
 9967 FORMAT( ' *** Error code from ', A, ' =', I5, / ' ==> NORM=''',
     $      A1, ''', UPLO =''', A1, ''', DIAG=''', A1, ''', N =', I5,
     $      ', type ', I2 )
*
*     SUBNAM, INFO, NORM, UPLO, DIAG, N, KD, IMAT
*
 9966 FORMAT( ' *** Error code from ', A, ' =', I5, / ' ==> NORM=''',
     $      A1, ''', UPLO =''', A1, ''', DIAG=''', A1, ''', N=', I5,
     $      ', KD=', I5, ', type ', I2 )
*
*     SUBNAM, INFO, TRANS, M, N, NRHS, NB, IMAT
*
 9965 FORMAT( ' *** Error code from ', A, ' =', I5,
     $      / ' ==> TRANS = ''', A1, ''', M =', I5, ', N =', I5,
     $      ', NRHS =', I4, ', NB =', I4, ', type ', I2 )
*
*     SUBNAM, INFO, TRANS, N, KL, KU, NRHS, IMAT
*
 9964 FORMAT( ' *** Error code from ', A, '=', I5, / ' ==> TRANS=''',
     $      A1, ''', N =', I5, ', KL =', I5, ', KU =', I5, ', NRHS =',
     $      I4, ', type ', I2 )
*
*     SUBNAM, INFO, TRANS, N, NRHS, IMAT
*
 9963 FORMAT( ' *** Error code from ', A, ' =', I5,
     $      / ' ==> TRANS = ''', A1, ''', N =', I5, ', NRHS =', I4,
     $      ', type ', I2 )
*
*     SUBNAM, INFO, UPLO, DIAG, N, IMAT
*
 9962 FORMAT( ' *** Error code from ', A, ' =', I5, / ' ==> UPLO=''',
     $      A1, ''', DIAG =''', A1, ''', N =', I5, ', type ', I2 )
*
*     SUBNAM, INFO, UPLO, DIAG, N, NB, IMAT
*
 9961 FORMAT( ' *** Error code from ', A, ' =', I5, / ' ==> UPLO=''',
     $      A1, ''', DIAG =''', A1, ''', N =', I5, ', NB =', I4,
     $      ', type ', I2 )
*
*     SUBNAM, INFO, UPLO, N, IMAT
*
 9960 FORMAT( ' *** Error code from ', A, ' =', I5, ' for UPLO = ''',
     $      A1, ''', N =', I5, ', type ', I2 )
*
*     SUBNAM, INFO, UPLO, N, KD, IMAT
*
 9959 FORMAT( ' *** Error code from ', A, ' =', I5, / ' ==> UPLO = ''',
     $      A1, ''', N =', I5, ', KD =', I5, ', type ', I2 )
*
*     SUBNAM, INFO, UPLO, N, KD, NB, IMAT
*
 9958 FORMAT( ' *** Error code from ', A, ' =', I5, / ' ==> UPLO = ''',
     $      A1, ''', N =', I5, ', KD =', I5, ', NB =', I4, ', type ',
     $      I2 )
*
*     SUBNAM, INFO, UPLO, N, KD, NRHS, IMAT
*
 9957 FORMAT( ' *** Error code from ', A, '=', I5, / ' ==> UPLO = ''',
     $      A1, ''', N =', I5, ', KD =', I5, ', NRHS =', I4, ', type ',
     $      I2 )
*
*     SUBNAM, INFO, UPLO, N, NB, IMAT
*
 9956 FORMAT( ' *** Error code from ', A, ' =', I5, / ' ==> UPLO = ''',
     $      A1, ''', N =', I5, ', NB =', I4, ', type ', I2 )
*
*     SUBNAM, INFO, UPLO, N, NRHS, IMAT
*
 9955 FORMAT( ' *** Error code from ', A, ' =', I5, / ' ==> UPLO = ''',
     $      A1, ''', N =', I5, ', NRHS =', I4, ', type ', I2 )
*
*     SUBNAM, INFO, UPLO, TRANS, DIAG, N, KD, NRHS, IMAT
*
 9954 FORMAT( ' *** Error code from ', A, ' =', I5, / ' ==> UPLO=''',
     $      A1, ''', TRANS=''', A1, ''', DIAG=''', A1, ''', N=', I5,
     $      ', KD=', I5, ', NRHS=', I4, ', type ', I2 )
*
*     SUBNAM, INFO, UPLO, TRANS, DIAG, N, NRHS, IMAT
*
 9953 FORMAT( ' *** Error code from ', A, ' =', I5, / ' ==> UPLO=''',
     $      A1, ''', TRANS=''', A1, ''', DIAG=''', A1, ''', N =', I5,
     $      ', NRHS =', I4, ', type ', I2 )
*
*     SUBNAM, INFO, UPLO, TRANS, DIAG, NORMIN, N, IMAT
*
 9952 FORMAT( ' *** Error code from ', A, ' =', I5, / ' ==> UPLO=''',
     $      A1, ''', TRANS=''', A1, ''', DIAG=''', A1, ''', NORMIN=''',
     $      A1, ''', N =', I5, ', type ', I2 )
*
*     SUBNAM, INFO, UPLO, TRANS, DIAG, NORMIN, N, KD, IMAT
*
 9951 FORMAT( ' *** Error code from ', A, ' =', I5, / ' ==> UPLO=''',
     $      A1, ''', TRANS=''', A1, ''', DIAG=''', A1, ''', NORMIN=''',
     $      A1, ''', N=', I5, ', KD=', I5, ', type ', I2 )
*
*     Unknown type
*
 9950 FORMAT( ' *** Error code from ', A, ' =', I5 )
*
*     What we do next
*
 9949 FORMAT( ' ==> Doing only the condition estimate for this case' )
*
      RETURN
*
*     End of ALAERH
*
      END

max_stars_repo_name: sydha/Lapack

max_issues_repo_name: sydha/Lapack

max_forks_repo_name: sydha/Lapack