!C IMSL ROUTINE NAME - ODNORM !C !C----------------------------------------------------------------------- !C !C COMPUTER - HP1000/SINGLE !C !C LATEST REVISION - JUNE 1, 1982 !C !C PURPOSE - MULTIVARIATE NORMAL LINEAR DISCRIMINANT !C ANALYSIS AMONG SEVERAL KNOWN GROUPS !C !C USAGE - CALL ODNORM (X,IX,NG,NV,ND,P, !C XM,IXM,S,W,IW,D,ID,IER) !C !C ARGUMENTS X - INPUT MATRIX OF DIMENSION NV BY THE SUM OF !C ND(I) CONTAINING THE GROUP DATA. !C (SEE REMARK 1). !C IX - INPUT ROW DIMENSION OF MATRIX X EXACTLY AS !C SPECIFIED IN THE DIMENSION STATEMENT IN THE !C CALLING PROGRAM. !C NG - INPUT NUMBER OF DISTINCT GROUPS. !C NV - INPUT NUMBER OF DATA VARIABLES. !C ND - INPUT VECTOR OF LENGTH NG. ND(I) CONTAINS !C THE NUMBER OF DATA VECTORS FROM THE I-TH !C GROUP IN THE DATA MATRIX X. !C P - INPUT/OUTPUT VECTOR OF LENGTH NG. ON INPUT, !C P(I) CONTAINS THE BAYESIAN PRIOR PROBABILITY !C THAT A RANDOM OBSERVATION BELONGS TO THE !C I-TH GROUP. (SEE REMARK 2). !C ON OUTPUT, P CONTAINS THE CONSTANTS OF THE !C NG LINEAR DISCRIMINANT FUNCTIONS. !C XM - OUTPUT MATRIX OF DIMENSION NV BY NG. !C THE I-TH COLUMN OF XM CONTAINS THE !C MEAN VECTOR FOR THE I-TH GROUP. !C IXM - INPUT ROW DIMENSION OF MATRIX XM EXACTLY AS !C SPECIFIED IN THE DIMENSION STATEMENT IN THE !C CALLING PROGRAM. !C S - WORK VECTOR OF LENGTH ((NV+1)*NV)/2. !C W - OUTPUT MATRIX OF DIMENSION NV BY NG. THE !C I-TH COLUMN OF W CONTAINS THE VECTOR FOR !C THE I-TH LINEAR DISCRIMINANT FUNCTION. !C IW - INPUT ROW DIMENSION OF MATRIX W EXACTLY AS !C SPECIFIED IN THE DIMENSION STATEMENT IN THE !C CALLING PROGRAM. !C D - OUTPUT PERFORMANCE MATRIX OF DIMENSION NG BY !C NG. (SEE REMARK 3). !C ID - INPUT ROW DIMENSION OF MATRIX D EXACTLY AS !C SPECIFIED IN THE DIMENSION STATEMENT IN THE !C CALLING PROGRAM. !C IER - OUTPUT ERROR PARAMETER !C TERMINAL ERROR !C IER = 129 INDICATES THAT THE COVARIANCE !C MATRIX IS SINGULAR. CHECK THE VARIABLES !C FOR REDUNDANCIES. !C IER = 130 INDICATES ONE OF IX,IXM,IW, OR ID !C IS TOO SMALL. REDIMENSION MATRICES. !C !C PRECISION/HARDWARE - SINGLE AND DOUBLE/H32 !C - SINGLE/H36,H48,H60 !C !C REQD. IMSL ROUTINES - LEQT1P,LUDECP,LUELMP,UERTST,UGETIO !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 1. ON INPUT, THE MATRIX X CONTAINS THE ND(1)+ND(2)+... !C ...+ND(NG) SAMPLE (COLUMN) VECTORS. THE FIRST ND(1) !C COLUMNS OF MATRIX X SHOULD CONTAIN THE DATA FOR GROUP !C ONE. THE NEXT ND(2) COLUMNS OF MATRIX X SHOULD CONTAIN !C THE DATA FOR GROUP TWO, AND SO ON. !C 2. COMMON CHOICES FOR THE BAYESIAN PRIOR PROBABILITIES !C P(I) ARE 1/NG, ND(I)/(ND(1)+ND(2)+...+ND(NG)), OR !C SUBJECTIVE ESTIMATES. THESE SHOULD SUM TO ONE. !C 3. THE RESULTING BAYESIAN CLASSIFIER IS TESTED ON THE !C ORIGINAL DATA X. THE OUTPUT MATRIX D SUMMARIZES THE !C PERFORMANCE. D(I,J) IS THE FRACTION OF SAMPLES IN THE !C I-TH GROUP THAT WERE CLASSIFIED IN THE J-TH GROUP. !C D(I,I) IS FRACTION CLASSIFIED FOR GROUP I. THE ACTUAL !C PERFORMANCE OF THE BAYESIAN CLASSIFIER ON UNLABELED !C OBSERVATIONS WILL BE SLIGHTLY WORSE. !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 ODNORM (X,IX,NG,NV,ND,P,XM,IXM,S,W,IW,D,ID,IER) !C SPECIFICATIONS FOR ARGUMENTS INTEGER IX,NG,NV,ND(1),IXM,IW,ID,IER REAL X(IX,1),P(1),XM(IXM,1),S(1),W(IW,1),D(ID,1) !C SPECIFICATIONS FOR LOCAL VARIABLES INTEGER I,IDGT,IR,J,K,KHI,KLO,L,LMAX,N,NDI,NDJ,NMNG REAL D1,D2,XMAX,XMI,XMJ DOUBLE PRECISION DSUM,DZERO DATA DZERO/0.0D0/ !C !C CHECK SUFFICIENT MATRIX DIMENSIONS !C !C FIRST EXECUTABLE STATEMENT IER = 0 IF (IX.GE.NV.AND.IXM.GE.NV.AND.IW.GE.NV.AND.ID.GE.NG) GO TO 5 IER = 130 GO TO 9000 !C COMPUTE MATRIX OF MEAN VECTORS 5 KHI = 0 DO 20 J=1,NG NDJ = ND(J) KLO = KHI+1 KHI = KLO+NDJ-1 DO 15 I=1,NV DSUM = DZERO DO 10 K=KLO,KHI DSUM = DSUM+X(I,K) 10 CONTINUE XM(I,J) = DSUM/NDJ 15 CONTINUE 20 CONTINUE N = KHI !C COMPUTE POOLED COVARIANCE MATRIX NMNG = N-NG IR = 0 DO 40 I=1,NV DO 35 J=1,I DSUM = DZERO KHI = 0 DO 30 L=1,NG KLO = KHI+1 KHI = KLO+ND(L)-1 XMI = XM(I,L) XMJ = XM(J,L) DO 25 K=KLO,KHI DSUM = DSUM+(X(I,K)-XMI)*(X(J,K)-XMJ) 25 CONTINUE 30 CONTINUE IR = IR+1 S(IR) = DSUM/NMNG 35 CONTINUE 40 CONTINUE DO 50 J=1,NG DO 45 I=1,NV W(I,J) = XM(I,J) 45 CONTINUE 50 CONTINUE !C SOLVE FOR DISCRIMINANT WEIGHT VECTORS IDGT = 0 CALL LEQT1P (S,NG,NV,W,IW,IDGT,D1,D2,IER) IF (IER.NE.0) GO TO 9000 !C COMPUTE CONSTANT WEIGHTS FOR EACH GROUP DO 60 I=1,NG DSUM = DZERO DO 55 J=1,NV DSUM = DSUM+XM(J,I)*W(J,I) 55 CONTINUE P(I) = -DSUM/2+ALOG(P(I)) 60 CONTINUE !C COMPUTE PERFORMANCE MATRIX KHI = 0 DO 90 I=1,NG NDI = ND(I) DO 65 J=1,NG D(I,J) = 0 65 CONTINUE KLO = KHI+1 KHI = KLO+NDI-1 DO 80 K=KLO,KHI XMAX = -1.E20 DO 75 L=1,NG DSUM = DZERO DO 70 J=1,NV DSUM = DSUM+W(J,L)*X(J,K) 70 CONTINUE DSUM = DSUM+P(L) IF (DSUM.LT.XMAX) GO TO 75 XMAX = DSUM LMAX = L 75 CONTINUE D(I,LMAX) = D(I,LMAX)+1 80 CONTINUE DO 85 J=1,NG D(I,J) = D(I,J)/NDI 85 CONTINUE 90 CONTINUE GO TO 9005 9000 CONTINUE CALL UERTST (IER,'ODNORM') 9005 RETURN END !C IMSL ROUTINE NAME - LEQT1P !C !C----------------------------------------------------------------------- !C !C COMPUTER - CDC205/SINGLE !C !C LATEST REVISION - JANUARY 1, 1978 !C !C PURPOSE - LINEAR EQUATION SOLUTION - POSITIVE DEFINITE !C MATRIX - SYMMETRIC STORAGE MODE - SPACE !C ECONOMIZER SOLUTION !C !C USAGE - CALL LEQT1P (A,M,N,B,IB,IDGT,D1,D2,IER) !C !C ARGUMENTS A - INPUT VECTOR OF LENGTH N(N+1)/2 CONTAINING THE !C N BY N COEFFICIENT MATRIX OF THE EQUATION !C AX = B. A IS A POSITIVE DEFINITE SYMMETRIC !C MATRIX STORED IN SYMMETRIC STORAGE MODE. !C ON OUTPUT, A IS REPLACED BY THE LOWER !C TRIANGULAR MATRIX L WHERE A = L*L-TRANSPOSE. !C L IS STORED IN SYMMETRIC STORAGE MODE WITH !C THE DIAGONAL ELEMENTS OF L IN RECIPROCAL !C FORM. !C M - NUMBER OF RIGHT HAND SIDES (COLUMNS IN B). !C (INPUT) !C N - ORDER OF A AND NUMBER OF ROWS IN B. (INPUT) !C B - INPUT MATRIX OF DIMENSION N BY M CONTAINING !C THE RIGHT-HAND SIDES OF THE EQUATION !C AX = B. !C ON OUTPUT, THE N BY M SOLUTION MATRIX X !C REPLACES B. !C IB - ROW DIMENSION OF B EXACTLY AS SPECIFIED IN !C THE DIMENSION STATEMENT IN THE CALLING !C PROGRAM. (INPUT) !C IDGT - THE ELEMENTS OF A ARE ASSUMED TO BE CORRECT !C TO IDGT DECIMAL DIGITS. (CURRENTLY NOT USED) !C D1,D2 - COMPONENTS OF THE DETERMINANT OF A. !C DETERMINANT(A) = D1*2.**D2. (OUTPUT) !C IER - ERROR PARAMETER. (OUTPUT) !C TERMINAL ERROR !C IER = 129 INDICATES THAT THE INPUT MATRIX !C A IS ALGORITHMICALLY NOT POSITIVE !C DEFINITE. (SEE THE CHAPTER L PRELUDE). !C !C PRECISION/HARDWARE - SINGLE AND DOUBLE/H32 !C - SINGLE/H36,H48,H60 !C !C REQD. IMSL ROUTINES - LUDECP,LUELMP,UERTST,UGETIO !C !C NOTATION - INFORMATION ON SPECIAL NOTATION AND !C CONVENTIONS IS AVAILABLE IN THE MANUAL !C INTRODUCTION OR THROUGH IMSL ROUTINE UHELP !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 LEQT1P (A,M,N,B,IB,IDGT,D1,D2,IER) DIMENSION A(1),B(IB,1) !C FIRST EXECUTABLE STATEMENT !C INITIALIZE IER IER = 0 !C DECOMPOSE A CALL LUDECP (A,A,N,D1,D2,IER) IF (IER.NE.0) GO TO 9000 !C PERFORM ELIMINATION DO 5 I = 1,M CALL LUELMP (A,B(1,I),N,B(1,I)) 5 CONTINUE GO TO 9005 9000 CONTINUE CALL UERTST(IER,'LEQT1P') 9005 RETURN END !FTN77,E,J,Y !C IMSL ROUTINE NAME - LUDECP !C !C----------------------------------------------------------------------- !C !C COMPUTER - HP1000/SINGLE !C !C LATEST REVISION - JANUARY 1, 1978 !C !C PURPOSE - DECOMPOSITION OF A POSITIVE DEFINITE MATRIX - !C SYMMETRIC STORAGE MODE !C !C USAGE - CALL LUDECP (A,UL,N,D1,D2,IER) !C !C ARGUMENTS A - INPUT VECTOR OF LENGTH N(N+1)/2 CONTAINING !C THE N BY N POSITIVE DEFINITE SYMMETRIC !C MATRIX STORED IN SYMMETRIC STORAGE MODE. !C UL - OUTPUT VECTOR OF LENGTH N(N+1)/2 CONTAINING !C THE DECOMPOSED MATRIX L SUCH THAT A = L* !C L-TRANSPOSE. L IS STORED IN SYMMETRIC !C STORAGE MODE. THE DIAGONAL OF L CONTAINS THE !C RECIPROCALS OF THE ACTUAL DIAGONAL ELEMENTS. !C N - ORDER OF A. (INPUT) !C D1,D2 - COMPONENTS OF THE DETERMINANT OF A. !C DETERMINANT(A) = D1*2.**D2. (OUTPUT) !C IER - ERROR PARAMETER. (OUTPUT) !C TERMINAL ERROR !C IER = 129 INDICATES THAT MATRIX A IS !C ALGORITHMICALLY NOT POSITIVE DEFINITE. !C (SEE THE CHAPTER L PRELUDE). !C !C PRECISION/HARDWARE - SINGLE AND DOUBLE/H32 !C - SINGLE/H36,H48,H60 !C !C REQD. IMSL ROUTINES - UERTST,UGETIO !C !C NOTATION - INFORMATION ON SPECIAL NOTATION AND !C CONVENTIONS IS AVAILABLE IN THE MANUAL !C INTRODUCTION OR THROUGH IMSL ROUTINE UHELP !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 LUDECP (A,UL,N,D1,D2,IER) !C DIMENSION A(1),UL(1) REAL Q DATA ZERO,ONE,FOUR,SIXTN,SIXTH/0.0,1.,4.,16.,.0625/ !C FIRST EXECUTABLE STATEMENT D1=ONE D2=ZERO RN = ONE/(N*SIXTN) IP = 1 IER=0 DO 45 I = 1,N IQ = IP IR = 1 DO 40 J = 1,I X = A(IP) IF (J .EQ. 1) GO TO 10 DO 5 K=IQ,IP1 X = X - UL(K) * UL(IR) IR = IR+1 5 CONTINUE 10 IF (I.NE.J) GO TO 30 D1 = D1*X Q = A(IP)+X*RN IF (Q .LE. A(IP)) GO TO 50 15 IF (ABS(D1).LE.ONE) GO TO 20 D1 = D1 * SIXTH D2 = D2 + FOUR GO TO 15 20 IF (ABS(D1) .GE. SIXTH) GO TO 25 D1 = D1 * SIXTN D2 = D2 - FOUR GO TO 20 25 UL(IP) = ONE/SQRT(X) GO TO 35 30 UL(IP) = X * UL(IR) 35 IP1 = IP IP = IP+1 IR = IR+1 40 CONTINUE 45 CONTINUE GO TO 9005 50 IER = 129 9000 CONTINUE CALL UERTST(IER,'LUDECP') 9005 RETURN END !C IMSL ROUTINE NAME - LUELMP !C !C----------------------------------------------------------------------- !C !C COMPUTER - HP1000/SINGLE !C !C LATEST REVISION - JANUARY 1, 1978 !C !C PURPOSE - ELIMINATION PART OF THE SOLUTION OF AX=B - !C POSITIVE DEFINITE MATRIX - SYMMETRIC !C STORAGE MODE !C !C USAGE - CALL LUELMP (A,B,N,X) !C !C ARGUMENTS A - INPUT VECTOR OF LENGTH N(N+1)/2 CONTAINING !C THE N BY N MATRIX L WHERE A = L*L-TRANSPOSE. !C L IS A LOWER TRIANGULAR MATRIX STORED IN !C SYMMETRIC STORAGE MODE. THE MAIN DIAGONAL !C ELEMENTS OF L ARE STORED IN RECIPROCAL !C FORM. MATRIX L MAY BE OBTAINED FROM IMSL !C ROUTINE LUDECP. !C B - VECTOR OF LENGTH N CONTAINING THE RIGHT HAND !C SIDE OF THE EQUATION AX = B. (INPUT) !C N - ORDER OF A AND THE LENGTH OF B AND X. (INPUT) !C X - VECTOR OF LENGTH N CONTAINING THE SOLUTION TO !C THE EQUATION AX = B. (OUTPUT) !C !C PRECISION/HARDWARE - SINGLE AND DOUBLE/H32 !C - SINGLE/H36,H48,H60 !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 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 LUELMP (A,B,N,X) !C DIMENSION A(1),B(1),X(1) DATA ZERO/0.0/ !C FIRST EXECUTABLE STATEMENT !C SOLUTION OF LY = B IP=1 IW = 0 DO 15 I=1,N T=B(I) IM1 = I-1 IF (IW .EQ. 0) GO TO 9 IP=IP+IW-1 DO 5 K=IW,IM1 T = T-A(IP)*X(K) IP=IP+1 5 CONTINUE GO TO 10 9 IF (T .NE. ZERO) IW = I IP = IP+IM1 10 X(I)=T*A(IP) IP=IP+1 15 CONTINUE !C SOLUTION OF UX = Y N1 = N+1 DO 30 I = 1,N II = N1-I IP=IP-1 IS=IP IQ=II+1 T=X(II) IF (N.LT.IQ) GO TO 25 KK = N DO 20 K=IQ,N T = T - A(IS) * X(KK) KK = KK-1 IS = IS-KK 20 CONTINUE 25 X(II)=T*A(IS) 30 CONTINUE RETURN END !C IMSL ROUTINE NAME - UERTST !C !C----------------------------------------------------------------------- !C !C COMPUTER - HP1000/SINGLE !C !C LATEST REVISION - JUNE 1, 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,IEQ,IEQDF,IOUNIT,LEVEL,LEVOLD,NAMEQ(6),NAMSET(6),NAMUPK(6),NIN,NMTB DATA NAMSET/1HU,1HE,1HR,1HS,1HE,1HT/ DATA NAMEQ/6*1H / DATA LEVEL/4/,IEQDF/0/,IEQ/1H=/ !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,20H) FROM IMSL ROUTINE ,6A1,A1,6A1) 40 FORMAT(27H *** WARNING WITH FIX ERROR,2X,7H(IER = ,I3,20H) FROM IMSL ROUTINE ,6A1,A1,6A1) 45 FORMAT(18H *** WARNING ERROR,11X,7H(IER = ,I3,20H) FROM IMSL ROUTINE ,6A1,A1,6A1) 50 FORMAT(20H *** UNDEFINED ERROR,9X,7H(IER = ,I5,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 !FTN77,E,J,Y !C IMSL ROUTINE NAME - UGETIO !C !C----------------------------------------------------------------------- !C !C COMPUTER - HP1000/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/7/,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----------------------------------------------------------------------- SUBROUTINE USPKD (PACKED,NCHARS,UNPAKD,NCHMTB) !C SPECIFICATIONS FOR ARGUMENTS INTEGER NC,NCHARS,NCHMTB !C INTEGER UNPAKD(1),IBLANK CHARACTER*(*) PACKED DATA IBLANK /1H / !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