C
C-----------------------------------------------------------------------
C
C MACHINE DEPENDENT ROUTINES.
C
C THESE ARE FOR A SINGLE T3E PROCESSOR UNDER F90 (REAL*4).
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 T3E UNDER F90 (REAL*4).
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)
IF (CACC.EQ.'SEQUENTIAL') THEN
CLOSE(UNIT=IUNIT, STATUS='KEEP')
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
ELSEIF (CACC.EQ.'DIRECT') THEN
CLOSE(UNIT=IUNIT, STATUS='KEEP')
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
INTEGER JPR
COMMON/NPROCS/ JPR
SAVE /NPROCS/
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 T3E UNDER F90 (REAL*4).
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 T3E, 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) JPR FROM COMMON /NPROCS/ IS THE EXPECTED JPR PARAMETER IN THE
C TARGET OCEAN MODEL.
C
C 6) ALAN J. WALLCRAFT, NRL, MAY 1997.
C*
C**********
C
INTEGER IOS,NRECL
CHARACTER CFILE*240,CENV*6,CACT*9
C
INTEGER IBLOCK,ICACHE,JCACHE
CHARACTER CASN*40
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',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
IOS = 0
* 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
NRECL = -4*IRLEN
ELSE
NRECL = 4*IRLEN
ENDIF
IF (MOD(NRECL,4096).EQ.0) THEN
ICACHE = NRECL/4096
IF (MOD(ICACHE,JPR).EQ.0) THEN
JCACHE = ICACHE/JPR
IF (MOD(JCACHE,3).EQ.0) THEN
IBLOCK = JCACHE/3
ELSEIF (MOD(JCACHE,2).EQ.0) THEN
IBLOCK = JCACHE/2
ELSE
IBLOCK = JCACHE
ENDIF
WRITE(CASN,8000) ICACHE,IBLOCK
8000 FORMAT('-F cachea:',I4.4,':1:0 -p6-63 -q',I4.4)
CALL ASNUNIT(IUNIT,CASN,IOS)
ENDIF
ENDIF
IF (CSTAT.EQ.'SCRATCH' .OR.
+ CSTAT.EQ.'scratch' ) THEN
OPEN(UNIT=IUNIT, FORM=CFORM, STATUS='SCRATCH',
+ ACTION=CACT, ACCESS='DIRECT', RECL=NRECL, IOSTAT=IOS)
ELSE
OPEN(UNIT=IUNIT, FILE=CFILE, FORM=CFORM, STATUS=CSTAT,
+ ACTION=CACT, ACCESS='DIRECT', RECL=NRECL, IOSTAT=IOS)
ENDIF
ENDIF
IF (IOS.NE.0) THEN
WRITE(6,9000) IUNIT
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,'.' //)
9100 FORMAT(// 10X,'ERROR IN ZHOPEN (UNIT',I3.2,') -' /
+ 20X,'ONLY UNFORMATTED DIRECT ACCESS ALLOWED.' //)
C END OF ZHOPEN.
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 T3E, 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 T3E UNDER F90 (REAL*4).
C
C 3) ALAN J. WALLCRAFT, OCTOBER 1993.
C*
C**********
C
INTEGER IRTC
C
SEC = IRTC() * 3.333333333E-9
RETURN
C END OF ZHSEC.
END
SUBROUTINE GETENV(CNAME, CVALUE)
IMPLICIT NONE
C
CHARACTER*(*) CNAME,CVALUE
C
C THIS SUBROUTINE PROVIDES GETENV FUNCTIONALITY
C ON THE T3E, USING PXFGETENV.
C
INTEGER INAME,IVALUE,IERR
C
INAME = 0
IERR = 0
CALL PXFGETENV(CNAME,INAME, CVALUE,IVALUE, IERR)
IF (IERR.NE.0) THEN
CVALUE = ' '
ENDIF
RETURN
C END OF GETENV.
END