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