C
C-----------------------------------------------------------------------
C
C     MACHINE DEPENDENT ROUTINES.
C
C     THESE ARE FOR THE CRAY UNDER UNICOS 8.0.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE ZHFLSH(IUNIT)
      IMPLICIT NONE
C
      INTEGER IUNIT
C
C**********
C*
C 1)  MACHINE SPECIFIC ROUTINE THAT FLUSHES THE OUTPUT BUFFERS OF 
C      LOGICAL UNIT 'IUNIT'.
C
C 2)  USE ZAIOFL TO FLUSH ARRAY I/O.
C
C 3)  THIS VERSION IS FOR CRAY C90 UNDER F90.
C      IT USES THE 'FLUSH' FORTRAN SYSTEM ROUTINE.
C
C 4)  ALAN J. WALLCRAFT,  SEPTEMBER 1989.
C*
C**********
C
      INTEGER       IOS,IRLEN
      CHARACTER*240 CACC,CFILE,CFORM
C
      CALL FLUSH(IUNIT,IOS)
C
      IF     (IOS.EQ.-1) THEN
C
C       IF FLUSH DID NOT WORK, CLOSE AND RE-OPEN THE FILE.
C
        INQUIRE(UNIT=IUNIT, NAME=CFILE, FORM=CFORM,
     +          ACCESS=CACC, RECL=IRLEN)
        CLOSE(  UNIT=IUNIT, STATUS='KEEP')
        IF     (CACC.NE.'DIRECT') THEN
          IF     (CFORM.NE.'FORMATTED') THEN
            OPEN(UNIT=IUNIT, FILE=CFILE, FORM=CFORM, STATUS='OLD',
     +           ACTION='WRITE', POSITION='APPEND')
          ELSE
            OPEN(UNIT=IUNIT, FILE=CFILE, FORM=CFORM, STATUS='OLD',
     +           DELIM='QUOTE', RECL=4096,
     +           ACTION='WRITE', POSITION='APPEND')
          ENDIF
        ELSE
          OPEN(UNIT=IUNIT, FILE=CFILE, FORM=CFORM, STATUS='OLD',
     +         ACTION='WRITE', ACCESS='DIRECT', RECL=IRLEN)
        ENDIF
      ENDIF
      RETURN
C     END OF ZHFLSH.
      END
      SUBROUTINE ZHOPEN(IUNIT,CFORM,CSTAT,IRLEN)
      IMPLICIT NONE
C
      INTEGER       IUNIT,IRLEN
      CHARACTER*(*) CFORM,CSTAT
C
C**********
C*
C 1)  MACHINE SPECIFIC ROUTINE FOR SIMPLE OPEN STATEMENTS.
C
C     SEE ALSO, ZHOPNC.
C
C 2)  THIS VERSION IS FOR THE CRAY C90 UNDER F90.
C      THE FILENAME IS TAKEN FROM THE ENVIRONMENT VARIABLE FOR0xx,
C       WHERE xx = IUNIT, WITH DEFAULT fort.xx.
C
C 3)  CSTAT CAN BE 'SCRATCH', 'OLD', 'NEW', OR 'UNKNOWN'.
C     CFORM CAN BE 'FORMATTED' OR 'UNFORMATTED'.
C     IRLEN CAN BE ZERO (FOR SEQUENTIAL ACCESS), OR NON-ZERO (FOR DIRECT
C      ACCESS INDICATING RECORD LENGTH IN TERMS OF REAL VARIABLES).
C     IF IRLEN IS NEGATIVE, THE OUTPUT WILL BE IN IEEE BINARY, IF THAT
C      CAPABILITY EXISTS USING STANDARD FORTRAN I/O.  THIS CAPABILITY
C      IS PRIMARILY TARGETED TO CRAYS, ON OTHER MACHINES -LEN AND LEN
C      ARE LIKELY TO DO THE SAME THING.
C
C     ON THE SUN, LEN AND -LEN BOTH GIVE IEEE FILES.
C
C 4)  FOR F90 COMPILERS, DELIM='QUOTE' IS INCLUDED IN THE  OPEN
C      STATEMENT WHERE APPROPRIATE.  NOTE THAT THE FOLLOWING CALL
C            CALL ZHOPEN(6,'FORMATTED','UNKNOWN',0)
C      IS LEGAL, AND WOULD HAVE THE EFFECT OF SETTING DELIM='QUOTE'
C      FOR STDOUT.  IUNIT=6 IS TYPICALLY TREATED AS A SPECIAL CASE.
C     ADDITIONALLY, FOR F90 COMPILERS:
C       STATUS='NEW'     IMPLIES ACTION='WRITE'
C       STATUS='OLD'     IMPLIES ACTION='READ'
C       STATUS='SCRATCH' IMPLIES ACTION='READWRITE'
C
C 5)  ALAN J. WALLCRAFT,  DECEMBER 1991 AND AUGUST 1993.
C*
C**********
C
      INTEGER   IOS,NRECL
      CHARACTER CFILE*240,CENV*6,CACT*9,CFCONV*8,CFSPEC*18
C
C     GET FILENAME.
C
      WRITE(CENV,1000) IUNIT
      CFILE = ' '
      CALL GETENV(CENV,CFILE)
      IF     (CFILE.EQ.' ') THEN
        WRITE(CFILE,1100) IUNIT
      ENDIF
C
C     OPEN FILE.
C
      IF     (CSTAT.EQ.'OLD' .OR.
     +        CSTAT.EQ.'old'     ) THEN
        CACT = 'READ'
      ELSEIF (CSTAT.EQ.'NEW' .OR.
     +        CSTAT.EQ.'new'     ) THEN
        CACT = 'WRITE'
      ELSE
        CACT = 'READWRITE'
      ENDIF
C
      IF     (IRLEN.EQ.0) THEN
C
C       SEQUENTIAL (UNFORMATTED USES IEEE I/O WITH F77/UNIX BLOCKING).
C
        IF     (CFORM.EQ.'UNFORMATTED' .OR.
     +          CFORM.EQ.'unformatted'     ) THEN
          CALL ASNUNIT(IUNIT,'-F f77 -N ieee',IOS)
          IF     (CSTAT.EQ.'SCRATCH' .OR.
     +            CSTAT.EQ.'scratch'     ) THEN
            OPEN(UNIT=IUNIT,             FORM=CFORM, STATUS='SCRATCH',
     +           ACTION=CACT, IOSTAT=IOS)
          ELSE
            OPEN(UNIT=IUNIT, FILE=CFILE, FORM=CFORM, STATUS=CSTAT,
     +           ACTION=CACT, IOSTAT=IOS)
          ENDIF
        ELSE
          IF     (CSTAT.EQ.'SCRATCH' .OR.
     +            CSTAT.EQ.'scratch'     ) THEN
            OPEN(UNIT=IUNIT,             FORM=CFORM, STATUS='SCRATCH',
     +           ACTION=CACT, DELIM='QUOTE', RECL=4096, IOSTAT=IOS)
          ELSEIF (IUNIT.NE.6) THEN
            OPEN(UNIT=IUNIT, FILE=CFILE, FORM=CFORM, STATUS=CSTAT,
     +           ACTION=CACT, DELIM='QUOTE', RECL=4096, IOSTAT=IOS)
          ELSE
            OPEN(UNIT=6,      DELIM='QUOTE', RECL=4096, IOSTAT=IOS)
          ENDIF
        ENDIF
      ELSE
C
C       UNFORMATTED DIRECT ACCESS.
C
        IF     (CFORM.NE.'UNFORMATTED' .AND.
     +          CFORM.NE.'unformatted'      ) THEN
          WRITE(6,9100) IUNIT
          CALL ZHFLSH(6)
          STOP
        ENDIF
C
        IF     (IRLEN.LT.0) THEN
C
C         IEEE I/O.
C
          CFCONV = '-N ieee'
          NRECL = -4*IRLEN
        ELSE
          CFCONV = ' '
          NRECL =  8*IRLEN
        ENDIF
        IF     (MOD(NRECL,16384).EQ.0 .AND. NRECL.GT.16384*4) THEN
C
C         NO BUFFERS FOR LARGE, WELL-FORMED RECORDS.
C
          CFSPEC = '-F syscall'
        ELSE
C
C         CACHEA FOR SMALL RECORDS,
C         16 PAGES OF 8 BLOCKS WITH READ-AHEAD OF TWO.
C
          CFSPEC = '-F cachea:8:16:2'
        ENDIF
        CALL ASNUNIT(IUNIT,CFSPEC//CFCONV,IOS)
        IF     (IOS.NE.0) THEN
          WRITE(6,9050) IUNIT
          WRITE(6,*) 'CFSPEC = ',CFSPEC
          WRITE(6,*) 'CFCONV = ',CFCONV
          WRITE(6,*) 'IOS    = ',IOS
          CALL ZHFLSH(6)
          STOP
        ENDIF
        IF     (CSTAT.EQ.'SCRATCH' .OR.
     +          CSTAT.EQ.'scratch'     ) THEN
          OPEN(UNIT=IUNIT,             FORM=CFORM, STATUS='SCRATCH',
     +         ACCESS='DIRECT', RECL=NRECL, IOSTAT=IOS)
        ELSE
          OPEN(UNIT=IUNIT, FILE=CFILE, FORM=CFORM, STATUS=CSTAT,
     +         ACCESS='DIRECT', RECL=NRECL, IOSTAT=IOS)
        ENDIF
      ENDIF
      IF     (IOS.NE.0) THEN
        WRITE(6,9000) IUNIT
        WRITE(6,*) 'IOS = ',IOS
        CALL ZHFLSH(6)
        STOP
      ENDIF
      RETURN
C
 1000 FORMAT('FOR',I3.3)
 1100 FORMAT('fort.',I2.2)
 9000 FORMAT(// 10X,'ERROR IN ZHOPEN -  CAN''T OPEN UNIT',I3,'.' //)
 9050 FORMAT(// 10X,'ERROR IN ZHOPEN -  CAN''T ASNUNIT',I3,'.' //)
 9100 FORMAT(// 10X,'ERROR IN ZHOPEN (UNIT',I3.2,')  -' /
     +   20X,'ONLY UNFORMATTED DIRECT ACCESS ALLOWED.' //)
C     END OF ZHOPEN.
      END
      SUBROUTINE ZHOPNC(IUNIT,CFILE,CFORM,CSTAT,IRLEN)
      IMPLICIT NONE
C
      INTEGER       IUNIT,IRLEN
      CHARACTER*(*) CFILE,CFORM,CSTAT
C
C**********
C*
C 1)  MACHINE SPECIFIC ROUTINE FOR SIMPLE OPEN STATEMENTS.
C
C     SEE ALSO, ZHOPEN.
C
C 2)  THIS VERSION IS FOR THE CRAY C90 UNDER F90.
C      THE FILENAME IS TAKEN FROM 'CFILE'.
C
C 3)  CSTAT CAN BE 'SCRATCH', 'OLD', 'NEW', OR 'UNKNOWN'.
C     CFORM CAN BE 'FORMATTED' OR 'UNFORMATTED'.
C     IRLEN CAN BE ZERO (FOR SEQUENTIAL ACCESS), OR NON-ZERO (FOR DIRECT
C      ACCESS INDICATING RECORD LENGTH IN TERMS OF REAL VARIABLES).
C     IF IRLEN IS NEGATIVE, THE OUTPUT WILL BE IN IEEE BINARY, IF THAT
C      CAPABILITY EXISTS USING STANDARD FORTRAN I/O.  THIS CAPABILITY
C      IS PRIMARILY TARGETED TO CRAYS, ON OTHER MACHINES -LEN AND LEN
C      ARE LIKELY TO DO THE SAME THING.
C
C     ON THE SUN, LEN AND -LEN BOTH GIVE IEEE FILES.
C
C 4)  FOR F90 COMPILERS, DELIM='QUOTE' IS INCLUDED IN THE  OPEN
C      STATEMENT WHERE APPROPRIATE.
C     ADDITIONALLY, FOR F90 COMPILERS:
C       STATUS='NEW'     IMPLIES ACTION='WRITE'
C       STATUS='OLD'     IMPLIES ACTION='READ'
C       STATUS='SCRATCH' IMPLIES ACTION='READWRITE'
C
C 5)  ALAN J. WALLCRAFT,  DECEMBER 1991 AND AUGUST 1993.
C*
C**********
C
      INTEGER   LEN_TRIM
      INTEGER   IOS,NRECL
      CHARACTER CACT*9,CFCONV*8,CFSPEC*18
C
C     OPEN FILE.
C
      IF     (CSTAT.EQ.'OLD' .OR.
     +        CSTAT.EQ.'old'     ) THEN
        CACT = 'READ'
      ELSEIF (CSTAT.EQ.'NEW' .OR.
     +        CSTAT.EQ.'new'     ) THEN
        CACT = 'WRITE'
      ELSE
        CACT = 'READWRITE'
      ENDIF
C
      IF     (IRLEN.EQ.0) THEN
C
C       SEQUENTIAL (UNFORMATTED USES IEEE I/O WITH F77/UNIX BLOCKING).
C
        IF     (CFORM.EQ.'UNFORMATTED' .OR.
     +          CFORM.EQ.'unformatted'     ) THEN
          CALL ASNUNIT(IUNIT,'-F f77 -N ieee',IOS)
          OPEN(UNIT=IUNIT, FILE=CFILE, FORM=CFORM, STATUS=CSTAT,
     +         ACTION=CACT, IOSTAT=IOS)
        ELSE
          OPEN(UNIT=IUNIT, FILE=CFILE, FORM=CFORM, STATUS=CSTAT,
     +         ACTION=CACT, DELIM='QUOTE', RECL=4096, IOSTAT=IOS)
        ENDIF
      ELSE
C
C       UNFORMATTED DIRECT ACCESS.
C
        IF     (CFORM.NE.'UNFORMATTED' .AND.
     +          CFORM.NE.'unformatted'      ) THEN
          WRITE(6,9100) IUNIT
          CALL ZHFLSH(6)
          STOP
        ENDIF
C
        IF     (IRLEN.LT.0) THEN
C
C         IEEE I/O.
C
          CFCONV = '-N ieee'
          NRECL  = -4*IRLEN
        ELSE
          CFCONV = ' '
          NRECL  =  8*IRLEN
        ENDIF
        IF     (MOD(NRECL,16384).EQ.0.AND.NRECL.GT.16384*4) THEN
C
C         NO BUFFERS FOR LARGE, WELL-FORMED RECORDS.
C
          CFSPEC = '-F syscall'
        ELSE
C
C         CACHEA FOR SMALL RECORDS,
C         16 PAGES OF 8 BLOCKS WITH READ-AHEAD OF TWO.
C
          CFSPEC = '-F cachea:8:16:2'
        ENDIF
        CALL ASNUNIT(IUNIT,CFSPEC//CFCONV,IOS)
        IF     (IOS.NE.0) THEN
          WRITE(6,9050) IUNIT
          WRITE(6,*) 'CFSPEC = ',CFSPEC
          WRITE(6,*) 'CFCONV = ',CFCONV
          WRITE(6,*) 'IOS    = ',IOS
          CALL ZHFLSH(6)
          STOP
        ENDIF
        OPEN(UNIT=IUNIT, FILE=CFILE, FORM=CFORM, STATUS=CSTAT,
     +       ACTION=CACT, ACCESS='DIRECT', RECL=NRECL, IOSTAT=IOS)
      ENDIF
      IF     (IOS.NE.0) THEN
        WRITE(6,9000) IUNIT,CFILE(1:LEN_TRIM(CFILE))
        WRITE(6,*) 'IOS = ',IOS
        CALL ZHFLSH(6)
        STOP
      ENDIF
      RETURN
C
 1000 FORMAT('FOR',I3.3)
 1100 FORMAT('fort.',I2.2)
 9000 FORMAT(// 10X,'ERROR IN ZHOPNC -  CAN''T OPEN UNIT',I3,'.' /
     +   10X,'CFILE = ',A //)
 9050 FORMAT(// 10X,'ERROR IN ZHOPEN -  CAN''T ASNUNIT',I3,'.' //)
 9100 FORMAT(// 10X,'ERROR IN ZHOPNC (UNIT',I3.2,')  -' /
     +   20X,'ONLY UNFORMATTED DIRECT ACCESS ALLOWED.' //)
C     END OF ZHOPNC.
      END
      SUBROUTINE ZHDATE(CDATE)
      IMPLICIT NONE
C
      CHARACTER*9 CDATE
C
C**********
C*
C 1)  MACHINE SPECIFIC ROUTINE THAT RETURNS THE DATE IN 'CDATE'.
C
C 2)  THE FORMAT OF CDATE NEED NOT BE IDENTICAL ON ALL MACHINES,
C      BUT IT SHOULD LOOK SOMETHING LIKE, FOR EXAMPLE, '16-SEP-84',
C      OR '16-Sep-84', OR ' 16/09/84' FOR THE 16TH OF SEPTEMBER 1984.
C
C 3)  THIS VERSION FOR THE CRAY C90 UNDER F90, IT USES THE
C      DATE SYSTEM ROUTINE.
C
C     DATE AS A CRAY SYSTEM SUBROUTINE RETURNS, FOR EXAMPLE
C      '16/09/84' FOR THE 16TH OF SEPTEMBER 1984.
C
C 4)  ALAN J. WALLCRAFT,  JANUARY 1989.
C*
C**********
C
      CDATE(1:1) = ' '
      CALL DATE(CDATE(2:9))
      RETURN
C     END OF ZHDATE.
      END
      SUBROUTINE ZHSEC(SEC)
      IMPLICIT NONE
C
      REAL*8  SEC
C
C**********
C*
C 1) MACHINE SPECIFC ROUTINE FOR TOTAL CPU TIME UP TO THIS POINT.
C
C 2) THIS VERSION FOR THE SUN.
C
C 3) ALAN J. WALLCRAFT,  PLANNING SYSTEMS INC.,  OCTOBER 1993.
C*
C**********
C
      REAL*8  SECOND
C
      SEC = SECOND()
      RETURN
C     END OF ZHSEC.
      END
      INTEGER FUNCTION LEN_TRIM(CSTR)
      IMPLICIT NONE
C
      CHARACTER*(*) CSTR
C
C     THIS FUNCTION DETERMINES THE RIGHT MOST NON-BLANK CHARACTER
C     POSITION IN A STRING..
C
C     CSTR - STRING WHOSE NON-BLANK LENGTH IS TO BE DETERMINED.
C
C     LEN_TRIM IS AN ELEMENTAL FUNCTION IN FORTRAN 90,
C
      INTEGER I
      INTEGER LEN
C
      DO 110 I= LEN(CSTR), 1, -1
        IF     (CSTR(I:I).NE.' ') THEN
          LEN_TRIM = I
          GOTO 1110
        ENDIF
  110 CONTINUE
      LEN_TRIM = 0
 1110 CONTINUE
      RETURN
C     END OF LEN_TRIM.
      END