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 9
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 9
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 9
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 9
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 9
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 9
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