C IMSL ROUTINE NAME - UGETIO C C----------------------------------------------------------------------- C C COMPUTER - IBM77/SINGLE C C LATEST REVISION - JUNE 1, 1981 C C PURPOSE - TO RETRIEVE CURRENT VALUES AND TO SET NEW C VALUES FOR INPUT AND OUTPUT UNIT C IDENTIFIERS. C C USAGE - CALL UGETIO(IOPT,NIN,NOUT) C C ARGUMENTS IOPT - OPTION PARAMETER. (INPUT) C IF IOPT=1, THE CURRENT INPUT AND OUTPUT C UNIT IDENTIFIER VALUES ARE RETURNED IN NIN C AND NOUT, RESPECTIVELY. C IF IOPT=2, THE INTERNAL VALUE OF NIN IS C RESET FOR SUBSEQUENT USE. C IF IOPT=3, THE INTERNAL VALUE OF NOUT IS C RESET FOR SUBSEQUENT USE. C NIN - INPUT UNIT IDENTIFIER. C OUTPUT IF IOPT=1, INPUT IF IOPT=2. C NOUT - OUTPUT UNIT IDENTIFIER. C OUTPUT IF IOPT=1, INPUT IF IOPT=3. C C PRECISION/HARDWARE - SINGLE/ALL C C REQD. IMSL ROUTINES - NONE REQUIRED C C NOTATION - INFORMATION ON SPECIAL NOTATION AND C CONVENTIONS IS AVAILABLE IN THE MANUAL C INTRODUCTION OR THROUGH IMSL ROUTINE UHELP C C REMARKS EACH IMSL ROUTINE THAT PERFORMS INPUT AND/OR OUTPUT C OPERATIONS CALLS UGETIO TO OBTAIN THE CURRENT UNIT C IDENTIFIER VALUES. IF UGETIO IS CALLED WITH IOPT=2 OR C IOPT=3, NEW UNIT IDENTIFIER VALUES ARE ESTABLISHED. C SUBSEQUENT INPUT/OUTPUT IS PERFORMED ON THE NEW UNITS. C C COPYRIGHT - 1978 BY IMSL, INC. ALL RIGHTS RESERVED. C C WARRANTY - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN C APPLIED TO THIS CODE. NO OTHER WARRANTY, C EXPRESSED OR IMPLIED, IS APPLICABLE. C C----------------------------------------------------------------------- C SUBROUTINE UGETIO(IOPT,NIN,NOUT) C SPECIFICATIONS FOR ARGUMENTS INTEGER IOPT,NIN,NOUT C SPECIFICATIONS FOR LOCAL VARIABLES INTEGER NIND,NOUTD DATA NIND/5/,NOUTD/6/ C FIRST EXECUTABLE STATEMENT IF (IOPT.EQ.3) GO TO 10 IF (IOPT.EQ.2) GO TO 5 IF (IOPT.NE.1) GO TO 9005 NIN = NIND NOUT = NOUTD GO TO 9005 5 NIND = NIN GO TO 9005 10 NOUTD = NOUT 9005 RETURN END C IMSL ROUTINE NAME - UERTST C C----------------------------------------------------------------------- C C COMPUTER - IBM77/SINGLE C C LATEST REVISION - MARCH 26, 1982 C C PURPOSE - PRINT A MESSAGE REFLECTING AN ERROR CONDITION C C USAGE - CALL UERTST (IER,NAME) C C ARGUMENTS IER - ERROR PARAMETER. (INPUT) C IER = I+J WHERE C I = 128 IMPLIES TERMINAL ERROR MESSAGE, C I = 64 IMPLIES WARNING WITH FIX MESSAGE, C I = 32 IMPLIES WARNING MESSAGE. C J = ERROR CODE RELEVANT TO CALLING C ROUTINE. C NAME - A CHARACTER STRING OF LENGTH SIX PROVIDING C THE NAME OF THE CALLING ROUTINE. (INPUT) C C PRECISION/HARDWARE - SINGLE/ALL C C REQD. IMSL ROUTINES - UGETIO,USPKD C C NOTATION - INFORMATION ON SPECIAL NOTATION AND C CONVENTIONS IS AVAILABLE IN THE MANUAL C INTRODUCTION OR THROUGH IMSL ROUTINE UHELP C C REMARKS THE ERROR MESSAGE PRODUCED BY UERTST IS WRITTEN C TO THE STANDARD OUTPUT UNIT. THE OUTPUT UNIT C NUMBER CAN BE DETERMINED BY CALLING UGETIO AS C FOLLOWS.. CALL UGETIO(1,NIN,NOUT). C THE OUTPUT UNIT NUMBER CAN BE CHANGED BY CALLING C UGETIO AS FOLLOWS.. C NIN = 0 C NOUT = NEW OUTPUT UNIT NUMBER C CALL UGETIO(3,NIN,NOUT) C SEE THE UGETIO DOCUMENT FOR MORE DETAILS. C C COPYRIGHT - 1982 BY IMSL, INC. ALL RIGHTS RESERVED. C C WARRANTY - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN C APPLIED TO THIS CODE. NO OTHER WARRANTY, C EXPRESSED OR IMPLIED, IS APPLICABLE. C C----------------------------------------------------------------------- C SUBROUTINE UERTST (IER,NAME) C SPECIFICATIONS FOR ARGUMENTS INTEGER IER CHARACTER NAME*(*) C SPECIFICATIONS FOR LOCAL VARIABLES INTEGER I,IEQDF,IOUNIT,LEVEL,LEVOLD,NIN,NMTB CHARACTER IEQ,NAMEQ(6),NAMSET(6),NAMUPK(6) DATA NAMSET/'U','E','R','S','E','T'/ DATA NAMEQ/6*' '/ DATA LEVEL/4/,IEQDF/0/,IEQ/'='/ C UNPACK NAME INTO NAMUPK C FIRST EXECUTABLE STATEMENT CALL USPKD (NAME,6,NAMUPK,NMTB) C GET OUTPUT UNIT NUMBER CALL UGETIO(1,NIN,IOUNIT) C CHECK IER IF (IER.GT.999) GO TO 25 IF (IER.LT.-32) GO TO 55 IF (IER.LE.128) GO TO 5 IF (LEVEL.LT.1) GO TO 30 C PRINT TERMINAL MESSAGE IF (IEQDF.EQ.1) WRITE(IOUNIT,35) IER,NAMEQ,IEQ,NAMUPK IF (IEQDF.EQ.0) WRITE(IOUNIT,35) IER,NAMUPK GO TO 30 5 IF (IER.LE.64) GO TO 10 IF (LEVEL.LT.2) GO TO 30 C PRINT WARNING WITH FIX MESSAGE IF (IEQDF.EQ.1) WRITE(IOUNIT,40) IER,NAMEQ,IEQ,NAMUPK IF (IEQDF.EQ.0) WRITE(IOUNIT,40) IER,NAMUPK GO TO 30 10 IF (IER.LE.32) GO TO 15 C PRINT WARNING MESSAGE IF (LEVEL.LT.3) GO TO 30 IF (IEQDF.EQ.1) WRITE(IOUNIT,45) IER,NAMEQ,IEQ,NAMUPK IF (IEQDF.EQ.0) WRITE(IOUNIT,45) IER,NAMUPK GO TO 30 15 CONTINUE C CHECK FOR UERSET CALL DO 20 I=1,6 IF (NAMUPK(I).NE.NAMSET(I)) GO TO 25 20 CONTINUE LEVOLD = LEVEL LEVEL = IER IER = LEVOLD IF (LEVEL.LT.0) LEVEL = 4 IF (LEVEL.GT.4) LEVEL = 4 GO TO 30 25 CONTINUE IF (LEVEL.LT.4) GO TO 30 C PRINT NON-DEFINED MESSAGE IF (IEQDF.EQ.1) WRITE(IOUNIT,50) IER,NAMEQ,IEQ,NAMUPK IF (IEQDF.EQ.0) WRITE(IOUNIT,50) IER,NAMUPK 30 IEQDF = 0 RETURN 35 FORMAT(19H *** TERMINAL ERROR,10X,7H(IER = ,I3, 1 20H) FROM IMSL ROUTINE ,6A1,A1,6A1) 40 FORMAT(27H *** WARNING WITH FIX ERROR,2X,7H(IER = ,I3, 1 20H) FROM IMSL ROUTINE ,6A1,A1,6A1) 45 FORMAT(18H *** WARNING ERROR,11X,7H(IER = ,I3, 1 20H) FROM IMSL ROUTINE ,6A1,A1,6A1) 50 FORMAT(20H *** UNDEFINED ERROR,9X,7H(IER = ,I5, 1 20H) FROM IMSL ROUTINE ,6A1,A1,6A1) C C SAVE P FOR P = R CASE C P IS THE PAGE NAMUPK C R IS THE ROUTINE NAMUPK 55 IEQDF = 1 DO 60 I=1,6 60 NAMEQ(I) = NAMUPK(I) 65 RETURN END C IMSL ROUTINE NAME - USPKD C C----------------------------------------------------------------------- C C COMPUTER - IBM77/SINGLE C C LATEST REVISION - NOVEMBER 1, 1984 C C PURPOSE - NUCLEUS CALLED BY IMSL ROUTINES THAT HAVE C CHARACTER STRING ARGUMENTS C C USAGE - CALL USPKD (PACKED,NCHARS,UNPAKD,NCHMTB) C C ARGUMENTS PACKED - CHARACTER STRING TO BE UNPACKED.(INPUT) C NCHARS - LENGTH OF PACKED. (INPUT) SEE REMARKS. C UNPAKD - CHARACTER ARRAY TO RECEIVE THE UNPACKED C REPRESENTATION OF THE STRING. (OUTPUT) C NCHMTB - NCHARS MINUS TRAILING BLANKS. (OUTPUT) C C PRECISION/HARDWARE - SINGLE/ALL C C REQD. IMSL ROUTINES - NONE C C REMARKS 1. USPKD UNPACKS A CHARACTER STRING INTO A CHARACTER ARRAY C IN (A1) FORMAT. C 2. UP TO 129 CHARACTERS MAY BE USED. ANY IN EXCESS OF C THAT ARE IGNORED. C C COPYRIGHT - 1984 BY IMSL, INC. ALL RIGHTS RESERVED. C C WARRANTY - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN C APPLIED TO THIS CODE. NO OTHER WARRANTY, C EXPRESSED OR IMPLIED, IS APPLICABLE. C C----------------------------------------------------------------------- SUBROUTINE USPKD (PACKED,NCHARS,UNPAKD,NCHMTB) C SPECIFICATIONS FOR ARGUMENTS INTEGER NC,NCHARS,NCHMTB C CHARACTER UNPAKD(1),IBLANK CHARACTER*(*) PACKED DATA IBLANK /' '/ C INITIALIZE NCHMTB NCHMTB = 0 C RETURN IF NCHARS IS LE ZERO IF(NCHARS.LE.0) RETURN C SET NC=NUMBER OF CHARS TO BE DECODED NC = MIN0 (129,NCHARS) READ (PACKED,150) (UNPAKD(I),I=1,NC) 150 FORMAT (129A1) C CHECK UNPAKD ARRAY AND SET NCHMTB C BASED ON TRAILING BLANKS FOUND DO 200 N = 1,NC NN = NC - N + 1 IF(UNPAKD(NN) .NE. IBLANK) GO TO 210 200 CONTINUE NN = 0 210 NCHMTB = NN RETURN END