C C----------------------------------------------------------------------- C C MACHINE DEPENDENT ROUTINES. C C THESE ARE FOR THE SUN. 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 SUN WORKSTATIONS. C IT USES THE 'FLUSH' FORTRAN SYSTEM ROUTINE. C C 4) ALAN J. WALLCRAFT, SEPTEMBER 1989. C* C********** C CALL FLUSH(IUNIT) 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 SUN FOR SUN FORTRAN. 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 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 (IRLEN.EQ.0) THEN C C SEQUENTIAL. C IF (CSTAT.EQ.'SCRATCH' .OR. + CSTAT.EQ.'scratch' ) THEN OPEN(UNIT=IUNIT, FORM=CFORM, STATUS='SCRATCH', + IOSTAT=IOS) ELSEIF (IUNIT.NE.6) THEN OPEN(UNIT=IUNIT, FILE=CFILE, FORM=CFORM, STATUS=CSTAT, + IOSTAT=IOS) ELSE IOS = 0 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 (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,'.' //) 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 SUN FOR SUN FORTRAN. 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 C C OPEN FILE. C IF (IRLEN.EQ.0) THEN C C SEQUENTIAL. C OPEN(UNIT=IUNIT, FILE=CFILE, FORM=CFORM, STATUS=CSTAT, + IOSTAT=IOS) 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 OPEN(UNIT=IUNIT, FILE=CFILE, FORM=CFORM, STATUS=CSTAT, + 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 9000 FORMAT(// 10X,'ERROR IN ZHOPNC - CAN''T OPEN UNIT',I3,'.' / + 10X,'CFILE = ',A //) 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 SUN WORKSTATIONS, IT USES THE C FDATE SYSTEM ROUTINE. C C FDATE AS A SUN UNIX SYSTEM SUBROUTINE RETURNS A 24 C CHARACTER STRING, FOR EAXMPLE 'Sun Sep 16 01:03:52 1984' C FOR SOMETIME ON THE 16TH OF SEPTEMBER 1984. C C 4) ALAN J. WALLCRAFT, JANUARY 1989. C* C********** C CHARACTER*24 CFDATE C CALL FDATE(CFDATE) CDATE = CFDATE(9:10) // '-' // CFDATE(5:7) // '-' // CFDATE(23:24) 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*4 TARRAY(2) REAL*4 ETIME C SEC = ETIME(TARRAY) 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