aboutsummaryrefslogtreecommitdiff
path: root/sys/gio/ncarutil/sysint/support.f
diff options
context:
space:
mode:
Diffstat (limited to 'sys/gio/ncarutil/sysint/support.f')
-rw-r--r--sys/gio/ncarutil/sysint/support.f581
1 files changed, 581 insertions, 0 deletions
diff --git a/sys/gio/ncarutil/sysint/support.f b/sys/gio/ncarutil/sysint/support.f
new file mode 100644
index 00000000..84d11ba5
--- /dev/null
+++ b/sys/gio/ncarutil/sysint/support.f
@@ -0,0 +1,581 @@
+ SUBROUTINE ENCD (VALU,ASH,IOUT,NC,IOFFD)
+C
+C +-----------------------------------------------------------------+
+C | |
+C | Copyright (C) 1986 by UCAR |
+C | University Corporation for Atmospheric Research |
+C | All Rights Reserved |
+C | |
+C | NCARGRAPHICS Version 1.00 |
+C | |
+C +-----------------------------------------------------------------+
+C
+C
+C
+C
+C
+C
+C ON INPUT VALU FLOATING POINT NUMBER FROM WHICH THE LABEL IS
+C TO BE CREATED.
+C ASH SEE IOFFD.
+C IOFFD IF IOFFD .EQ. 0, A LABEL WHICH REFLECTS THE
+C MAGNITUDE OF VALU IS TO BE CREATED.
+C .1 .LE. ABS(VALU) .LE. 99999.49999...
+C OR VALUE .EQ. 0.0. THE LABEL CREATED
+C SHOULD HAVE 3 TO 5 CHARACTERS DEPENDING
+C ON THE MAGNITUDE OF VALU. SEE IOUT.
+C IF IOFFD .NE. 0, A LABEL WHICH DOES NOT REFLECT
+C THE MAGNITUDE OF VALU IS TO BE CREATED.
+C ASH IS USED AS THE NORMALIZATION FACTOR.
+C 1. .LE. ASH*ABS(VALU) .LT. 1000. OR
+C VALU .EQ. 0.0. THE LABEL CREATED SHOULD
+C HAVE 1 TO 3 CHARACTERS, DEPENDING ON THE
+C MAGNITUDE OF ASH*VALU. SEE IOUT.
+C ON OUTPUT IOUT CONTAINS THE LABEL CREATED. IT SHOULD HAVE NO
+C LEADING BLANKS. SEE NC.
+C NC THE NUMBERS IN THE LABEL IN IOUT. SHOULD BE
+C 1 TO 5.
+C
+ SAVE
+ CHARACTER*11 IFMT
+ CHARACTER*(*) IOUT
+C
+C IFMT MUST HOLD 11 CHARACTERS
+C
+ VAL = VALU
+ IF (IOFFD .NE. 0) GO TO 103
+ IF (VAL) 101,104,101
+ 101 LOG = IFIX((ALOG10(ABS(VAL))+.00001)+5000.)-5000
+ V = VAL
+ NS = MAX0(4,MIN0(6,LOG+2))
+ ND = MIN0(3,MAX0(0,2-LOG))
+c IF (VAL.LT.0) NS = NS + 1
+c + NOAO - replacing ftn i/o for iraf implementation
+c 102 WRITE (IFMT,'(A2,I2,A1,I1,A1)') '(F',NS,'.',ND,')'
+ 102 continue
+ ifmt(1:6) = '(f . )'
+ ifmt(3:3) = char (ns + ichar ('0'))
+ ifmt(5:5) = char (nd + ichar ('0'))
+c WRITE (IOUT,IFMT) V
+ call encode (ns, ifmt, iout, v)
+ NC = NS
+c + NOAO
+c The following statement was making 5 digit labels (+4800) come out
+c truncated (+480) and it has been commented out.
+c IF (LOG.GE.3) NC = NC - 1
+c - NOAO
+ RETURN
+ 103 NS = 4
+ IF (VAL.LT.0.) NS=5
+ IF (VAL.EQ.0.) NS=2
+ ND = 0
+ V = VAL*ASH
+ LOG = 100
+ GO TO 102
+ 104 iout(1:3) = '0.0'
+ nc = 3
+c 104 NS = 3
+c ND = 1
+c LOG = -100
+c V = 0.
+c GO TO 102
+C
+C1001 FORMAT('(F',I2,'.',I1,',1H',A1,')')
+C
+ END
+C
+ SUBROUTINE ENCODE (NCHARS, FTNFMT, FTNOUT, RVAL)
+
+ INTEGER SZFMT, SZBUF
+ PARAMETER (SZFMT=11)
+ PARAMETER (SZBUF=15)
+
+ CHARACTER*(*) FTNFMT
+ CHARACTER*(*) FTNOUT
+ INTEGER*2 SPPFMT(SZFMT), SPPOUT(SZBUF)
+
+C UNPACK THE FORTRAN CHARACTER STRING, CALL FENCD TO ACTUALLY ENCODE THE
+C OUTPUT STRING, THEN PACK THE OUTPUT STRING INTO A FORTRAN STRING FOR RETURN
+C
+ CALL F77UPK (FTNFMT, SPPFMT, SZFMT)
+ CALL FENCD (NCHARS, SPPFMT, SPPOUT, RVAL)
+ CALL F77PAK (SPPOUT, FTNOUT, NCHARS)
+
+ END
+C
+C PACKAGE ERPRT77 DESCRIPTION OF INDIVIDUAL USER ENTRIES
+C FOLLOWS THIS PACKAGE DESCRIPTION.
+C
+C LATEST REVISION FEBRUARY 1985
+C
+C PURPOSE TO PROVIDE A PORTABLE, FORTRAN 77 ERROR
+C HANDLING PACKAGE.
+C
+C USAGE THESE ROUTINES ARE INTENDED TO BE USED IN
+C THE SAME MANNER AS THEIR SIMILARLY NAMED
+C COUNTERPARTS ON THE PORT LIBRARY. EXCEPT
+C FOR ROUTINE SETER, THE CALLING SEQUENCES
+C OF THESE ROUTINES ARE THE SAME AS FOR
+C THEIR PORT COUNTERPARTS.
+C ERPRT77 ENTRY PORT ENTRY
+C ------------- ----------
+C ENTSR ENTSRC
+C RETSR RETSRC
+C NERRO NERROR
+C ERROF ERROFF
+C SETER SETERR
+C EPRIN EPRINT
+C FDUM FDUMP
+C
+C I/O SOME OF THE ROUTINES PRINT ERROR MESSAGES.
+C
+C PRECISION NOT APPLICABLE
+C
+C REQUIRED LIBRARY MACHCR, WHICH IS LOADED BY DEFAULT ON
+C FILES NCAR'S CRAY MACHINES.
+C
+C LANGUAGE FORTRAN 77
+C
+C HISTORY DEVELOPED OCTOBER, 1984 AT NCAR IN BOULDER,
+C COLORADO BY FRED CLARE OF THE SCIENTIFIC
+C COMPUTING DIVISION BY ADAPTING THE NON-
+C PROPRIETARY, ERROR HANDLING ROUTINES
+C FROM THE PORT LIBRARY OF BELL LABS.
+C
+C PORTABILITY FULLY PORTABLE
+C
+C REFERENCES SEE THE MANUAL
+C PORT MATHEMATICAL SUBROUTINE LIBRARY
+C ESPECIALLY "ERROR HANDLING" IN SECTION 2
+C OF THE INTRODUCTION, AND THE VARIOUS
+C SUBROUTINE DESCRIPTIONS.
+C ******************************************************************
+C
+C SUBBROUTINE ENTSR(IROLD,IRNEW)
+C
+C PURPOSE SAVES THE CURRENT RECOVERY MODE STATUS AND
+C SETS A NEW ONE. IT ALSO CHECKS THE ERROR
+C STATE, AND IF THERE IS AN ACTIVE ERROR
+C STATE A MESSAGE IS PRINTED.
+C
+C USAGE CALL ENTSR(IROLD,IRNEW)
+C
+C ARGUMENTS
+C
+C ON INPUT IRNEW
+C VALUE SPECIFIED BY USER FOR ERROR
+C RECOVERY
+C = 0 LEAVES RECOVERY UNCHANGED
+C = 1 GIVES RECOVERY
+C = 2 TURNS RECOVERY OFF
+C
+C ON OUTPUT IROLD
+C RECEIVES THE CURRENT VALUE OF THE ERROR
+C RECOVERY MODE
+C
+C SPECIAL CONDITIONS IF THERE IS AN ACTIVE ERROR STATE, THE
+C MESSAGE IS PRINTED AND EXECUTION STOPS.
+C
+C ERROR STATES -
+C 1 - ILLEGAL VALUE OF IRNEW.
+C 2 - CALLED WHILE IN AN ERROR STATE.
+C ******************************************************************
+C
+C SUBROUTINE RETSR(IROLD)
+C
+C PURPOSE SETS THE RECOVERY MODE TO THE STATUS GIVEN
+C BY THE INPUT ARGUMENT. A TEST IS THEN MADE
+C TO SEE IF A CURRENT ERROR STATE EXISTS WHICH
+C IS UNRECOVERABLE; IF SO, RETSR PRINTS AN
+C ERROR MESSAGE AND TERMINATES THE RUN.
+C
+C BY CONVENTION, RETSR IS USED UPON EXIT
+C FROM A SUBROUTINE TO RESTORE THE PREVIOUS
+C RECOVERY MODE STATUS STORED BY ROUTINE
+C ENTSR IN IROLD.
+C
+C USAGE CALL RETSR(IROLD)
+C
+C ARGUMENTS
+C
+C ON INPUT IROLD
+C = 1 SETS FOR RECOVERY
+C = 2 SETS FOR NONRECOVERY
+C
+C ON OUTPUT NONE
+C
+C SPECIAL CONDITIONS IF THE CURRENT ERROR BECOMES UNRECOVERABLE,
+C THE MESSAGE IS PRINTED AND EXECUTION STOPS.
+C
+C ERROR STATES -
+C 1 - ILLEGAL VALUE OF IROLD.
+C ******************************************************************
+C
+C INTEGER FUNCTION NERRO(NERR)
+C
+C PURPOSE PROVIDES THE CURRENT ERROR NUMBER (IF ANY)
+C OR ZERO IF THE PROGRAM IS NOT IN THE
+C ERROR STATE.
+C
+C USAGE N = NERRO(NERR)
+C
+C ARGUMENTS
+C
+C ON INPUT NONE
+C
+C ON OUTPUT NERR
+C CURRENT VALUE OF THE ERROR NUMBER
+C ******************************************************************
+C SUBROUTINE ERROF
+C
+C PURPOSE TURNS OFF THE ERROR STATE BY SETTING THE
+C ERROR NUMBER TO ZERO
+C
+C USAGE CALL ERROF
+C
+C ARGUMENTS
+C
+C ON INPUT NONE
+C
+C ON OUTPUT NONE
+C ******************************************************************
+C
+C SUBROUTINE SETER(MESSG,NERR,IOPT)
+C
+C PURPOSE SETS THE ERROR INDICATOR AND, DEPENDING
+C ON THE OPTIONS STATED BELOW, PRINTS A
+C MESSAGE AND PROVIDES A DUMP.
+C
+C
+C USAGE CALL SETER(MESSG,NERR,IOPT)
+C
+C ARGUMENTS
+C
+C ON INPUT MESSG
+C HOLLERITH STRING CONTAINING THE MESSAGE
+C ASSOCIATED WITH THE ERROR
+C
+C NERR
+C THE NUMBER TO ASSIGN TO THE ERROR
+C
+C IOPT
+C = 1 FOR A RECOVERABLE ERROR
+C = 2 FOR A FATAL ERROR
+C
+C IF IOPT = 1 AND THE USER IS IN ERROR
+C RECOVERY MODE, SETERR SIMPLY REMEMBERS
+C THE ERROR MESSAGE, SETS THE ERROR NUMBER
+C TO NERR, AND RETURNS.
+C
+C IF IOPT = 1 AND THE USER IS NOT IN ERROR
+C RECOVERY MODE, SETERR PRINTS THE ERROR
+C MESSAGE AND TERMINATES THE RUN.
+C
+C IF IOPT = 2 SETERR ALWAYS PRINTS THE ERROR
+C MESSAGE, CALLS FDUM, AND TERMINATES THE RUN.
+C
+C ON OUTPUT NONE
+C
+C SPECIAL CONDITIONS CANNOT ASSIGN NERR = 0, AND CANNOT SET IOPT
+C TO ANY VALUE OTHER THAN 1 OR 2.
+C ******************************************************************
+C
+C SUBROUTINE EPRIN
+C
+C PURPOSE PRINTS THE CURRENT ERROR MESSAGE IF THE
+C PROGRAM IS IN THE ERROR STATE; OTHERWISE
+C NOTHING IS PRINTED.
+C
+C USAGE CALL EPRIN
+C
+C ARGUMENTS
+C
+C ON INPUT NONE
+C
+C ON OUTPUT NONE
+C ******************************************************************
+C
+C SUBROUTINE FDUM
+C
+C PURPOSE TO PROVIDE A DUMMY ROUTINE WHICH SERVES
+C AS A PLACEHOLDER FOR A SYMBOLIC DUMP
+C ROUTINE, SHOULD IMPLEMENTORS DECIDE TO
+C PROVIDE SUCH A ROUTINE.
+C
+C USAGE CALL EPRIN
+C
+C ARGUMENTS
+C
+C ON INPUT NONE
+C
+C ON OUTPUT NONE
+C ******************************************************************
+ SUBROUTINE ENTSR(IROLD,IRNEW)
+C
+ LOGICAL TEMP
+ IF (IRNEW.LT.0 .OR. IRNEW.GT.2)
+ 1 CALL SETER(' ENTSR - ILLEGAL VALUE OF IRNEW',1,2)
+C
+ TEMP = IRNEW.NE.0
+ IROLD = I8SAV(2,IRNEW,TEMP)
+C
+C IF HAVE AN ERROR STATE, STOP EXECUTION.
+C
+ IF (I8SAV(1,0,.FALSE.) .NE. 0) CALL SETER
+ 1 (' ENTSR - CALLED WHILE IN AN ERROR STATE',2,2)
+C
+ RETURN
+C
+ END
+ SUBROUTINE RETSR(IROLD)
+C
+ IF (IROLD.LT.1 .OR. IROLD.GT.2)
+ 1 CALL SETER(' RETSR - ILLEGAL VALUE OF IROLD',1,2)
+C
+ ITEMP=I8SAV(2,IROLD,.TRUE.)
+C
+C IF THE CURRENT ERROR IS NOW UNRECOVERABLE, PRINT AND STOP.
+C
+ IF (IROLD.EQ.1 .OR. I8SAV(1,0,.FALSE.).EQ.0) RETURN
+C
+ CALL EPRIN
+ CALL FDUM
+c STOP
+C
+ END
+ INTEGER FUNCTION NERRO(NERR)
+C
+ NERRO=I8SAV(1,0,.FALSE.)
+ NERR=NERRO
+ RETURN
+C
+ END
+ SUBROUTINE ERROF
+C
+ I=I8SAV(1,0,.TRUE.)
+ RETURN
+C
+ END
+ SUBROUTINE SETER(MESSG,NERR,IOPT)
+C
+ CHARACTER*(*) MESSG
+ COMMON /UERRF/IERF
+C
+C THE UNIT FOR ERROR MESSAGES IS I1MACH(4)
+C
+c + NOAO - blockdata uerrbd changed to runtime initialization subroutine
+C FORCE LOAD OF BLOCKDATA
+C
+c EXTERNAL UERRBD
+ call uerrbd
+c - NOAO
+ IF (IERF .EQ. 0) THEN
+ IERF = I1MACH(4)
+ ENDIF
+C
+ NMESSG = LEN(MESSG)
+ IF (NMESSG.GE.1) GO TO 10
+C
+C A MESSAGE OF NON-POSITIVE LENGTH IS FATAL.
+C
+c + NOAO - FTN writes rewritten as calls to uliber for IRAF
+c WRITE(IERF,9000)
+c9000 FORMAT(' ERROR 1 IN SETER - MESSAGE LENGTH NOT POSITIVE.')
+ call uliber (1,' SETER - MESSAGE LENGTH NOT POSITIVE.', 80)
+c - NOAO
+ GO TO 60
+C
+ 10 CONTINUE
+ IF (NERR.NE.0) GO TO 20
+C
+C CANNOT TURN THE ERROR STATE OFF USING SETER.
+C
+c + NOAO - FTN writes rewritten as calls to uliber for IRAF
+c WRITE(IERF,9001)
+c9001 FORMAT(' ERROR 2 IN SETER - CANNOT HAVE NERR=0'/
+c 1 ' THE CURRENT ERROR MESSAGE FOLLOWS'/)
+ call uliber (2, ' SETER - CANNOT HAVE NERR=0', 80)
+ call uliber (2, ' SETER - THE CURRENT ERROR MSG FOLLOWS', 80)
+c - NOAO
+ CALL E9RIN(MESSG,NERR,.TRUE.)
+ ITEMP=I8SAV(1,1,.TRUE.)
+ GO TO 50
+C
+C SET LERROR AND TEST FOR A PREVIOUS UNRECOVERED ERROR.
+C
+ 20 CONTINUE
+ IF (I8SAV(1,NERR,.TRUE.).EQ.0) GO TO 30
+C
+c + NOAO - FTN writes rewritten as calls to uliber for IRAF
+c WRITE(IERF,9002)
+c9002 FORMAT(' ERROR 3 IN SETER -',
+c 1 ' AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR.'//
+c 2 ' THE PREVIOUS AND CURRENT ERROR MESSAGES FOLLOW.'///)
+ call uliber (3,' SETER - A SECOND UNRECOV ERROR SEEN.', 80)
+ call uliber (3,' SETER - THE ERROR MESSAGES FOLLOW.', 80)
+c - NOAO
+ CALL EPRIN
+ CALL E9RIN(MESSG,NERR,.TRUE.)
+ GO TO 50
+C
+C SAVE THIS MESSAGE IN CASE IT IS NOT RECOVERED FROM PROPERLY.
+C
+ 30 CALL E9RIN(MESSG,NERR,.TRUE.)
+C
+ IF (IOPT.EQ.1 .OR. IOPT.EQ.2) GO TO 40
+C
+C MUST HAVE IOPT = 1 OR 2.
+C
+c + NOAO - FTN writes rewritten as calls to uliber for IRAF
+c WRITE(IERF,9003)
+c9003 FORMAT(' ERROR 4 IN SETER - BAD VALUE FOR IOPT'//
+c 1 ' THE CURRENT ERROR MESSAGE FOLLOWS'///)
+ call uliber (4, ' SETER - BAD VALUE FOR IOPT', 80)
+ call uliber (4, ' SETER - THE CURRENT ERR MSG FOLLOWS', 80)
+c - NOAO
+ GO TO 50
+C
+C TEST FOR RECOVERY.
+C
+ 40 CONTINUE
+ IF (IOPT.EQ.2) GO TO 50
+C
+ IF (I8SAV(2,0,.FALSE.).EQ.1) RETURN
+C
+ CALL EPRIN
+ CALL FDUM
+c STOP
+C
+ 50 CALL EPRIN
+ 60 CALL FDUM
+c STOP
+C
+ END
+ SUBROUTINE EPRIN
+C
+ CHARACTER*1 MESSG
+C
+ CALL E9RIN(MESSG,1,.FALSE.)
+ RETURN
+C
+ END
+ SUBROUTINE E9RIN(MESSG,NERR,SAVE)
+C
+C THIS ROUTINE STORES THE CURRENT ERROR MESSAGE OR PRINTS THE OLD ONE,
+C IF ANY, DEPENDING ON WHETHER OR NOT SAVE = .TRUE. .
+C
+ CHARACTER*(*) MESSG
+ CHARACTER*113 MESSGP
+ INTEGER NERRP
+ LOGICAL SAVE
+ COMMON /UERRF/IERF
+ SAVE MESSGP,NERRP
+C
+C MESSGP STORES THE FIRST 113 CHARACTERS OF THE PREVIOUS MESSAGE
+C
+C
+C START WITH NO PREVIOUS MESSAGE.
+C
+ DATA MESSGP/'1'/
+ DATA NERRP/0/
+C
+ IF (.NOT.SAVE) GO TO 20
+C
+C SAVE THE MESSAGE.
+C
+ NERRP=NERR
+ MESSGP = MESSG
+C
+ GO TO 30
+C
+ 20 IF (I8SAV(1,0,.FALSE.).EQ.0) GO TO 30
+C
+C PRINT THE MESSAGE.
+C
+c + NOAO - FTN write rewritten as call to uliber
+c WRITE(IERF,9000) NERRP,MESSGP
+c9000 FORMAT(' ERROR ',I4,' IN ',A113)
+ call uliber (nerrp, messgp, 113)
+C
+ 30 RETURN
+C
+ END
+ INTEGER FUNCTION I8SAV(ISW,IVALUE,SET)
+C
+C IF (ISW = 1) I8SAV RETURNS THE CURRENT ERROR NUMBER AND
+C SETS IT TO IVALUE IF SET = .TRUE. .
+C
+C IF (ISW = 2) I8SAV RETURNS THE CURRENT RECOVERY SWITCH AND
+C SETS IT TO IVALUE IF SET = .TRUE. .
+C
+ LOGICAL SET
+ INTEGER LERROR, LRECOV
+ SAVE LERROR,LRECOV
+C
+C START EXECUTION ERROR FREE AND WITH RECOVERY TURNED OFF.
+C
+ DATA LERROR/0/ , LRECOV/2/
+ IF (ISW .EQ. 1) THEN
+ I8SAV = LERROR
+ IF (SET) LERROR = IVALUE
+ ELSE IF (ISW .EQ. 2) THEN
+ I8SAV = LRECOV
+ IF (SET) LRECOV = IVALUE
+ ENDIF
+ RETURN
+ END
+ SUBROUTINE FDUM
+C
+C DUMMY ROUTINE TO BE LOCALLY IMPLEMENTED
+C
+ RETURN
+ END
+C
+ SUBROUTINE Q8QST4(NAME,LBRARY,ENTRY,VRSION)
+C
+C DIMENSION OF NAME(1),LBRARY(1),ENTRY(1),VRSION(1)
+C ARGUMENTS
+C
+C LATEST REVISION MARCH 1984
+C
+C PURPOSE MONITORS LIBRARY USE BY WRITING A RECORD WITH
+C INFORMATION ABOUT THE CIRCUMSTANCES OF A
+C LIBRARY ROUTINE CALL TO THE SYSTEM ACCOUNTING
+C TAPE FOR LATER PROCESSING.
+C
+C NOTE--- THIS VERSION OF Q8QST4 SIMPLY RETURNS TO THE
+C CALLING ROUTINE. LOCAL IMPLEMENTORS MAY WISH
+C TO IMPLEMENT A VERSION OF THIS ROUTINE THAT
+C MONITORS USE OF NCAR ROUTINES WITH LOCAL
+C MECHANISMS. OTHERWISE IT WILL SAVE A SMALL
+C AMOUNT OF SPACE AND TIME IF CALLS TO Q8QST4 ARE
+C DELETED FROM ALL NSSL ROUTINES.
+C
+ CHARACTER*(*) NAME,LBRARY,ENTRY,VRSION
+C
+ RETURN
+ END
+c + NOAO - Blockdata uerrbd rewritten as a runtime initialization subroutine
+c BLOCKDATA UERRBD
+ subroutine uerrbd
+c
+ COMMON /UERRF/IERF
+C DEFAULT ERROR UNIT
+c DATA IERF/0/
+ IERF= 0
+ END
+c -NOAO
+ subroutine uliber (errcode, pkerrmsg, msglen)
+
+ character*80 pkerrmsg
+ integer errcode, msglen
+ integer*2 sppmsg(81)
+ integer SZLINE
+ parameter (SZLINE=80)
+
+c unpack the fortran character string, call fulib to output the string.
+c
+ call f77upk (pkerrmsg, sppmsg, SZLINE)
+ call fulib (errcode, sppmsg, msglen)
+
+ end
generated by cgit (git 2.34.1) at 2025-09-20 14:04:12 -0400