C SUBROUTINE DATA (CL,X,LX,NX,NXT,NP,NB) C PARAMETER MB = 100, ML = 100, MP = 2500 CHARACTER*(*) CL DIMENSION X(MB*MP), LX(MB), NX(ML,MB), NXT(MB) C LN = LAST_NONBLANK(CL) + 1 L1 = 1 L2 = LOC_DELIMITER(CL(L1:LN)) + L1 - 1 L4 = LOC_COMMAND(L2,LN,CL) - 1 C IF (CL(L1:L2).EQ.'Display ') THEN C CALL DATA_DISPLAY(CL(L2:L4),X,LX,NX,NXT,NP,NB) C ELSE IF (CL(L1:L2).EQ.'Enter ') THEN C CALL DATA_ENTER (CL(L2:L4),X,LX,NX,NXT,NP,NB) C ELSE IF (CL(L1:L2).EQ.'Create ') THEN C CALL DATA_CREATE (CL(L2:L4),X,LX,NX,NXT,NP,NB) C ELSE IF (CL(L1:L2).EQ.'Format ') THEN C CALL DATA_FORMAT (CL(L2:L4),X,LX,NX,NXT,NP,NB) C ELSE IF (CL(L1:L2).EQ.'Input ') THEN C CALL DATA_INPUT (CL(L2:L4),X,LX,NX,NXT,NP,NB) C ELSE IF (CL(L1:L2).EQ.'Output ') THEN C CALL DATA_OUTPUT (CL(L2:L4),X,LX,NX,NXT,NP,NB) C END IF RETURN END C SUBROUTINE DATA_DISPLAY (CL,X,LX,NX,NXT,NP,NB) C PARAMETER MB = 100, MD = 5, MK = 6, ML = 100, MP = 2500, MV = 5 CHARACTER*(*) CL CHARACTER*132 FNAME(4), TITLES(0:MD) DIMENSION X(MB*MP), LX(MB), NX(ML,MB), NXT(MB) DIMENSION NBS(3), IBS(MV,MK), LS(MK), MS(ML,MK), NS(MV,ML,MK) COMMON /LSA/ NBS,IBS,LS,MS,NS COMMON /LUN/ LUCI,LUCO,LUFI,LUFO,LUII,LUIO,ISAV,FNAME,TITLES C DATA LUCI,LUCO,LUFI,LUFO,LUII,LUIO /1,2,3,4,5,6/ C NBS(1) = 1 NBS(2) = 1 NBS(3) = 1 IBS(4,1) = 1 IBS(5,1) = 1 CALL DATA_SELECT (CL,NBS,IBS,LS,MS,NS,LX,NX,NXT,NP,NB) IF (IBS(1,1).LT.1.OR.NB.LT.IBS(1,1)) RETURN WRITE (LUIO,*) 'Number selected ', LS(1) WRITE (LUIO,*) (NS(MV-1,MS(J,1),1), J = 1, LS(1)) DO I = 1, IBS(3,1) INI = IBS(2,1) + LOCI(I,LS,MS,NS) WRITE (LUIO,*) (ILOCI(I,MS(J,1),LS,MS,NS), 1 J = 1, LS(1)), X(INI) END DO RETURN C ENTRY DATA_ENTER (CL,X,LX,NX,NXT,NP,NB) C NBS(1) = 1 NBS(2) = 1 NBS(3) = 1 IBS(4,1) = 1 IBS(5,1) = 1 CALL DATA_SELECT (CL,NBS,IBS,LS,MS,NS,LX,NX,NXT,NP,NB) IF (IBS(1,1).LT.1.OR.NB.LT.IBS(1,1)) RETURN L1 = 1 LN = LEN(CL) DO I = 1, 3*NBS(1) L1 = INDEX(CL(L1:LN),':') + L1 END DO L2 = INDEX(CL(L1:LN),':') + L1 - 1 IF (L2.LT.L1) L2 = LN WRITE (LUIO,*) 'Number selected ', LS(1) WRITE (LUIO,*) (NS(MV-1,MS(J,1),1), J = 1, LS(1)) DO I = 1, IBS(3,1) INI = IBS(2,1) + LOCI(I,LS,MS,NS) L1 = MIN(L2+1,LN) L2 = INDEX(CL(L1:LN),':') + L1 - 1 IF (L2.LT.L1) L2 = LN IF (L1.GE.L2.OR.CL(L1:L2-1).EQ.' ') THEN IF (CL(L2:L2).EQ.':') THEN WRITE (LUIO,1) (ILOCI(I,MS(J,1),LS,MS,NS), 1 J = 1, LS(1)), X(INI) ELSE WRITE (LUIO,1) (ILOCI(I,MS(J,1),LS,MS,NS), 1 J = 1, LS(1)), X(INI) READ (LUII,*) X(INI) WRITE (LUCO,*) X(INI) END IF ELSE READ (CL(L1:L2-1),*,END=10,ERR=10) X(INI) 10 CONTINUE END IF END DO 1 FORMAT ((I10),G15.7,' ',$) RETURN END C SUBROUTINE DATA_INPUT (CL,X,LX,NX,NXT,NP,NB) C C FILES DATA C READS OR WRITES A SUBARRAY FROM OR TO A FILE OR TERMINAL (TT) C THE FILE IS CHARACTERIZED BY FILE FORMAT NFF, FILE I/O ALL NFA, C FILE HEADER REC NFR, FILE DIMENSIONS AND NUMBER/DIM NFD, NFL C C THE FILE IS ORGANIZED SEQUENTIALLY UN/FORMATTED AS FOLLOWS C RECORD VARIABLE CONTENTS C 1 IRC NUMBER OF HEADER LINES C 2 - IRC+1 LINES HEADER C IRC+2 L, NX(LX) NUMBER OF DIMENSIONS C NUMBER PER DIMENSION C IRC+3 - NRC X(NX(LX)) DATA C C THE M ARRAY HOLDS THE ORDER OF STORAGE IN THE FILE C FOR LOW TO HIGH DIMENSIONS (THE INTERNAL FORMAT) C IT IS 1,2,3,...LX C C THE N ARRAY HOLDS ARRAY INDICES FOR EACH OF LX DIMENSIONS C INITIAL N(1,J) INPUT C FINAL N(2,J) INPUT C DELTA N(3,J) INPUT C NUMBER N(4,J) CALC C MAXIMUM N(5,J) FILE C PARAMETER MB = 100, MD = 5, MK = 6, ML = 100, MP = 2500, MV = 5 PARAMETER MRC = 66 CHARACTER*(*) CL CHARACTER*132 CI, FNAME(4), TITLES(0:MD) CHARACTER*132 LINES(66), UNFOR(2)*12 DIMENSION XI(0:ML), IRC(2), NFF(2), NFA(2), NFR(2), NFD(2), 1 NFL(ML,2) DIMENSION X(MB*MP), LX(MB), NX(ML,MB), NXT(MB) DIMENSION NBS(3), IBS(MV,MK), LS(MK), MS(ML,MK), NS(MV,ML,MK) COMMON /LSA/ NBS,IBS,LS,MS,NS COMMON /LUN/ LUCI,LUCO,LUFI,LUFO,LUII,LUIO,ISAV,FNAME,TITLES C DATA LUCI,LUCO,LUFI,LUFO,LUII,LUIO /1,2,3,4,5,6/ DATA IO,NFF,NFA,NFR,NFD,NDG,NLN /1,2*2,2*1,2*-1,2*0,15,5/, 1 IFM /0/, IR0,IR1 /2*1/, UNFOR /'Unformatted ','Formatted '/ C C DEFINE FILE C IF (NFA(1).NE.1) THEN WRITE (CI,*) IBS(1,1) CALL COMM_SYMBOL ('Part1',CI) END IF L1 = 1 L2 = INDEX(CL,':') LN = LEN(CL) IF (L2.LT.L1) L2 = LN IF (L1.GE.L2.OR.CL(L1:L2-1).EQ.' ') THEN IF (CL(L2:L2).EQ.':') THEN WRITE (LUIO,*) 'File ', FNAME(3) ELSE WRITE (LUIO,*) 'File ? ', FNAME(3) READ (LUII,1) CI WRITE (LUCO,1) CI(1:MAX(1,LAST_NONBLANK(CI))) M1 = 1 MN = LEN(CI) M1 = INDEX(CI(M1:MN),'"') + M1 M2 = INDEX(CI(M1:MN),'"') + M1 - 2 IF (M1.LT.M2) THEN FNAME(3) = CI(M1:M2) ELSE FNAME(3) = ' ' END IF END IF ELSE M1 = INDEX(CL(L1:L2-1),'"') + L1 M2 = INDEX(CL(M1:L2-1),'"') + M1 - 2 IF (M1.LT.M2) THEN FNAME(3) = CL(M1:M2) ELSE FNAME(3) = ' ' END IF END IF C C OPEN FILE C IF (FNAME(3).NE.' ') THEN CLOSE (UNIT = LUFI) OPEN ( UNIT = LUFI, 1 FILE = FNAME(3), 2 DEFAULTFILE = 'INPUT', 3 STATUS = 'OLD', 4 FORM = UNFOR(NFF(1)), 5 ERR = 10, 6 READONLY ) GO TO 20 10 CALL COMM_MESSAGE ('Data Error: ','Nonexistant file') GO TO 100 END IF C C INPUT C 20 L1 = 1 L2 = INDEX(CL,':') LN = LEN(CL) IF (L2.LT.L1) L2 = LN IF (FNAME(3).EQ.'TT') THEN WRITE (LUIO,*) 'Number of header records ?' WRITE (LUIO,*) ' header records ?' WRITE (LUIO,*) 'Number of dimensions ?' WRITE (LUIO,*) 'Number / dimension ?' END IF IF (NFF(1).EQ.1) THEN IF (NFR(1).GE.0) THEN IRC(1) = NFR(1) ELSE READ (LUFI,END=100) IRC(1) END IF DO I = IR0, IR0+IRC(1)-1 J = MOD(I-1,MRC)+1 READ (LUFI,END=100) LINES(J) WRITE (LUIO,2) 1 LINES(J)(1:MAX(1,LAST_NONBLANK(LINES(J)))) IF (I-IR0+1.LE.5) TITLES(I-IR0+1) = LINES(J) END DO IR1 = IR0 IR0 = IR0 + IRC(1) IF (NFD(1).GT.0) THEN LS(2) = NFD(1) DO J = 1, LS(2) MS(J,2) = NFL(J,1) END DO ELSE READ (LUFI,END=100) LS(2), (MS(J,2), J = 1, LS(2)) END IF ELSE IF (NFR(1).GE.0) THEN IRC(1) = NFR(1) ELSE READ (LUFI,*,END=100) IRC(1) END IF DO I = IR0, IR0+IRC(1)-1 J = MOD(I-1,MRC)+1 READ (LUFI,1,END=100) LINES(J) WRITE (LUIO,2) 1 LINES(J)(1:MAX(1,LAST_NONBLANK(LINES(J)))) IF (I-IR0+1.LE.5) TITLES(I-IR0+1) = LINES(J) END DO IR1 = IR0 IR0 = IR0 + IRC(1) IF (NFD(1).GT.0) THEN LS(2) = NFD(1) DO J = 1, LS(2) MS(J,2) = NFL(J,1) END DO ELSE READ (LUFI,*,END=100) LS(2), (MS(J,2), J = 1, LS(2)) END IF END IF NBS(1) = 1 NBS(2) = 1 NBS(3) = 1 IBS(4,1) = 1 IBS(5,1) = 1 L1 = MIN(L2+1,LN) L2 = INDEX(CL(L1:LN),':') + L1 - 1 IF (L2.LT.L1) L2 = LN CALL DATA_DEFINE (CL(L1:LN),NBS,IBS,LS(2),MS(1,2),NS(1,1,2), 1 LX,NX,NXT,NP,NB) IF (IBS(1,1).LT.1.OR.NB.LT.IBS(1,1)) GO TO 100 IF (IBS(3,1).GT.NP) THEN CALL COMM_MESSAGE ('Data Error: ','Partition overflow') GO TO 100 END IF C LS(1) = LS(2) DO J = 1, LS(1) MS(J,1) = J DO I = 1, MV NS(I,J,1) = NS(I,J,2) END DO IF (NS(3,J,2).LT.0) THEN NS(1,J,1) = NS(2,J,2) NS(2,J,1) = NS(1,J,2) NS(3,J,1) = -NS(3,J,2) END IF END DO C IF (NFF(1).EQ.1) THEN C READ (LUFI,END=30) 1 (A, I0 = 1, LOCI( 1,LS(1),MS(1,1),NS(1,1,1))-1), 2 X( IBS(2,1) + ICOL( LOCI( 1,LS(1),MS(1,1),NS(1,1,1)), 2 LS(2),MS(1,2),NS(1,1,2)) ), 3 ( (A, I0 = LOCI(I-1,LS(1),MS(1,1),NS(1,1,1))+1 , 4 LOCI(I ,LS(1),MS(1,1),NS(1,1,1))-1), 5 X( IBS(2,1) + ICOL( LOCI(I ,LS(1),MS(1,1),NS(1,1,1)), 5 LS(2),MS(1,2),NS(1,1,2)) ), 6 I = 2, IBS(3,1)), 7 (A, I0 = LOCI(IBS(3,1),LS(1),MS(1,1),NS(1,1,1))+1, 7 NXT(IBS(1,1))) C ELSE C READ (LUFI,*,END=30) 1 (A, I0 = 1, LOCI( 1,LS(1),MS(1,1),NS(1,1,1))-1), 2 X( IBS(2,1) + ICOL( LOCI( 1,LS(1),MS(1,1),NS(1,1,1)), 2 LS(2),MS(1,2),NS(1,1,2)) ), 3 ( (A, I0 = LOCI(I-1,LS(1),MS(1,1),NS(1,1,1))+1 , 4 LOCI(I ,LS(1),MS(1,1),NS(1,1,1))-1), 5 X( IBS(2,1) + ICOL( LOCI(I ,LS(1),MS(1,1),NS(1,1,1)), 5 LS(2),MS(1,2),NS(1,1,2)) ), 6 I = 2, IBS(3,1)), 7 (A, I0 = LOCI(IBS(3,1),LS(1),MS(1,1),NS(1,1,1))+1, 7 NXT(IBS(1,1))) C END IF C 30 DO J = 1, LS(1) NX(J,IBS(1,1)) = NS(MV-1,MS(J,2),2) END DO NXT(IBS(1,1)) = IBS(3,1) C C INPUT UNTIL EOF ? C IF (NFA(1).NE.1) THEN WRITE (CI,*) IBS(1,1) CALL COMM_SYMBOL ('PartN',CI) IBS(1,1) = IBS(1,1) + 1 GO TO 20 END IF 100 RETURN C ENTRY DATA_OUTPUT (CL,X,LX,NX,NXT,NP,NB) C IF (NFA(2).NE.1) THEN WRITE (CI,*) IBS(1,1) CALL COMM_SYMBOL ('Part1',CI) END IF C C DEFINE FILE C L1 = 1 LN = LEN(CL) L2 = INDEX(CL(L1:LN),':') + L1 - 1 IF (L2.LT.L1) L2 = LN 40 IF (L1.GE.L2.OR.CL(L1:L2-1).EQ.' ') THEN IF (CL(L2:L2).EQ.':') THEN WRITE (LUIO,*) 'File ', 1 FNAME(4)(1:MAX(1,LAST_NONBLANK(FNAME(4)))) ELSE WRITE (LUIO,*) 'File ? ', 1 FNAME(4)(1:MAX(1,LAST_NONBLANK(FNAME(4)))) READ (LUII,1) CI WRITE (LUCO,1) CI(1:MAX(1,LAST_NONBLANK(CI))) M1 = 1 MN = LEN(CI) M1 = INDEX(CL(M1:MN),'"') + M1 M2 = INDEX(CL(M1:MN),'"') + M1 - 2 IF (M1.LT.M2) THEN FNAME(4) = CI(M1:M2) ELSE FNAME(4) = ' ' END IF END IF ELSE M1 = INDEX(CL(L1:L2-1),'"') + L1 M2 = INDEX(CL(M1:L2-1),'"') + M1 - 2 IF (M1.LT.M2) THEN FNAME(4) = CL(M1:M2) ELSE FNAME(4) = ' ' END IF END IF C C OPEN FILE C IF (FNAME(4).NE.' ') THEN CLOSE (UNIT = LUFO) OPEN ( UNIT = LUFO, 1 FILE = FNAME(4), 2 DEFAULTFILE = 'OUTPUT', 3 STATUS = 'NEW', 4 FORM = UNFOR(NFF(2)), 5 ERR = 40 ) END IF C 50 L1 = 1 LN = LEN(CL) L1 = INDEX(CL(L1:LN),':') + L1 L2 = INDEX(CL(L1:LN),':') + L1 - 1 IF (L2.LT.L1) L2 = LN NBS(1) = 1 NBS(2) = 1 NBS(3) = 1 IBS(4,1) = 1 IBS(5,1) = 1 CALL DATA_SELECT (CL(L1:LN),NBS,IBS,LS,MS,NS,LX,NX,NXT,NP,NB) IF (IBS(1,1).LT.1.OR.NB.LT.IBS(1,1)) RETURN IR0 = IR1 IRC(2) = NFR(2) IF (NFR(2).LT.0) THEN IRC(2) = IRC(1) IF (IRC(2).GE.0) THEN IF (NFF(2).EQ.1) THEN WRITE (LUFO) IRC(2) ELSE WRITE (LUFO,*) IRC(2) END IF END IF END IF DO I = IR0, IR0+IRC(2)-1 J = MOD(I-1,MRC)+1 IF (JRC.GT.0) THEN WRITE (LUIO,*) ' header record ? ', I WRITE (LUIO,2) 1 LINES(J)(1:MAX(1,LAST_NONBLANK(LINES(J)))) READ (LUII,1) LINES(MRC) IF (LINE.NE.'/') LINES(J) = LINES(MRC) WRITE (LUCO,*) 1 LINES(J)(1:MAX(1,LAST_NONBLANK(LINES(J)))) END IF IF (NFF(2).EQ.1) THEN WRITE (LUFO) 1 LINES(J)(1:MAX(1,LAST_NONBLANK(LINES(J)))) ELSE WRITE (LUFO,1) 1 LINES(J)(1:MAX(1,LAST_NONBLANK(LINES(J)))) END IF END DO IR0 = IR0 + IRC(2) C IF (NFF(2).EQ.1) THEN C IF (NFD(2).LE.0) 1 WRITE (LUFO) LS(1), (NS(MV-1,MS(J,1),1), J = 1, LS(1)) WRITE (LUFO) (X( IBS(2,1) + 1 LOCI(I,LS,MS,NS) ), I = 1, IBS(3,1)) C ELSE C NLN = 5 NUM = MAX(1,NS(MV-1,MS(1,1),1)) NVR = MAX(1,NS(MV-1,MS(2,1),1)) IF (NUM.LE.NLN) THEN NLN = NUM NUM = NUM*NVR IF (LS(1).LE.2) THEN NVR = 1 ELSE NVR = MAX(1,NS(MV-1,MS(3,1),1)) END IF END IF IF (NFD(2).LE.0) 1 WRITE (LUFO,*) LS(1), (NS(MV-1,MS(J,1),1), J = 1, LS(1)) IF (NUM.LE.NLN) THEN WRITE (LUFO,201) (X( IBS(2,1) + LOCI(I,LS,MS,NS) ), 1 I = 1, IBS(3,1)) ELSE WRITE (LUFO,211) (X( IBS(2,1) + LOCI(I,LS,MS,NS) ), 1 I = 1, IBS(3,1)) END IF END IF C C OUTPUT UNTIL EOD ? C IF (NFA(2).NE.1.AND.LX(IBS(1,1)+1).GT.0) THEN WRITE (CI,*) IBS(1,1) CALL COMM_SYMBOL ('PartN',CI) IBS(1,1) = IBS(1,1) + 1 GO TO 50 END IF C 1 FORMAT ((A)) 2 FORMAT (' ',(A)) C C NDG NUMBER OF DIGITS / ELEMENT (>=1/9 (I/R)) C NLN NUMBER OF ELEMENTS / LINE (>=1) C NUM NUMBER OF ELEMENTS / VECTOR (>=1) C NVR NUMBER OF VECTORS (>=1) C NDM NUMBER OF DIMENSIONS (>=1) C C ONLY A LIST DIRECTED READ IS NECESSARY WITH THIS C C READ (LU,*) ((A(I,J),I=1,NUM),J=1,NVR*NDM) C C SIMPLE FORMATTER (ASSUMES NDG >= 1/9, NLN,NUM,NVR >= 1) C INTEGER FORMAT I NUM <= NLN 101 NUM > NLN 111 C C 101 FORMAT (1P,( C 1 I,//)) C 111 FORMAT (1P,(( C 1 I,(/)), C 2 I,//)) C C REAL FORMAT G NUM <= NLN 201 NUM > NLN 211 C C 201 FORMAT (1P,( C 1 G.,//)) C 211 FORMAT (1P,(( C 1 G.,(/)), C 2 G.,//)) C C INVINCIBLE FORMATTER C INTEGER FORMAT I NUM <= NLN 101 NUM > NLN 111 C 101 FORMAT (1P,( 1 I,//)) 111 FORMAT (1P,( 1 (I, 2 (/)), 3 I,//)) C C REAL FORMAT G NUM <= NLN 201 NUM > NLN 211 C 201 FORMAT (1P,( 1 G.,//)) 211 FORMAT (1P,( 1 (G., 2 (/)), 3 G.,//)) RETURN C ENTRY DATA_CREATE (CL,X,LX,NX,NXT,NP,NB) C NBS(1) = 1 NBS(2) = 1 NBS(3) = 1 IBS(4,1) = 1 IBS(5,1) = 1 CALL DATA_SELECT (CL,NBS,IBS,LS,MS,NS,LX,NX,NXT,NP,NB) IF (IBS(1,1).LT.1.OR.NB.LT.IBS(1,1)) RETURN C L1 = 1 LN = LEN(CL) DO I = 1, 3*NBS(1) L1 = INDEX(CL(L1:LN),':') + L1 END DO L2 = INDEX(CL(L1:LN),':') + L1 - 1 IF (L2.LT.L1) L2 = LN IF (L1.GE.L2.OR.CL(L1:L2-1).EQ.' ') THEN IF (CL(L2:L2).EQ.':') THEN WRITE (LUIO,*) 'Data form ', IFM ELSE WRITE (LUIO,*) 'Data form ? ', IFM WRITE (LUIO,*) ' 0. X(NX(LX)) = X(0) + ', 1 '(SUM(I) (NX(I)-1)*X(I) I = 1, LX) ' WRITE (LUIO,*) ' 1. X(NX(LX)) = X(NX(1)) ' WRITE (LUIO,*) ' 2. X(NX(LX)) = X(NX(1),NX(2)) ' WRITE (LUIO,*) ' L. X(NX(LX)) = X(NX(LX)) ' READ (LUII,*) IFM WRITE (LUCO,*) IFM END IF ELSE READ (CL(L1:L2-1),*,END=110,ERR=110) IFM 110 CONTINUE END IF L1 = MIN(L2+1,LN) L2 = INDEX(CL(L1:LN),':') + L1 - 1 IF (L2.LT.L1) L2 = LN IF (IFM.LT.0) THEN ELSE IF (IFM.EQ.0) THEN IF (L1.GE.L2.OR.CL(L1:L2-1).EQ.' ') THEN IF (CL(L2:L2).EQ.':') THEN WRITE (LUIO,*) 'Data X(NX(LX)) ', (XI(J), 1 J = 0, LS(1)) ELSE WRITE (LUIO,*) 'Data X(NX(LX)) ? ' READ (LUII,*) (XI(J), J = 0, LS(1)) WRITE (LUCO,*) (XI(J), J = 0, LS(1)) END IF ELSE READ (CL(L1:L2-1),*,END=120,ERR=120) (XI(J), 1 J = 0, LS(1)) 120 CONTINUE END IF DO I = 1, IBS(3,1) INI = IBS(2,1) + LOCI(I,LS,MS,NS) X(INI) = XI(0) DO J = 1, LS(1) X(INI) = X(INI) + 1 XI(J)*(ILOCI(I,MS(J,1),LS,MS,NS)-1) END DO END DO ELSE IF (IFM.LE.LS(1)) THEN IF (L1.GE.L2.OR.CL(L1:L2-1).EQ.' ') THEN IF (CL(L2:L2).EQ.':') THEN WRITE (LUIO,*) 'Data X(NX(LX)) ' WRITE (LUIO,*) (X(IBS(2,1) + 1 LOCI(I,LS,MS,NS)), I = 1, IBS(3,1)) ELSE WRITE (LUIO,*) 'Data X(NX(LX)) ? ' READ (LUII,*) (X(IBS(2,1) + 1 LOCI(I,LS,MS,NS)), I = 1, IBS(3,1)) WRITE (LUCO,*) (X(IBS(2,1) + 1 LOCI(I,LS,MS,NS)), I = 1, IBS(3,1)) END IF ELSE READ (CL(L1:L2-1),*,END=130,ERR=130) (X(IBS(2,1) + 1 LOCI(I,LS,MS,NS)), I = 1, IBS(3,1)) 130 CONTINUE END IF K = 1 DO I = 1, IFM K = K*NS(4,MS(I,1),1) END DO DO I = K+1, IBS(3,1) J = MOD(I-1,K) + 1 INI = IBS(2,1) + LOCI(J,LS,MS,NS) INO = IBS(2,1) + LOCI(I,LS,MS,NS) X(INO) = X(INI) END DO END IF RETURN C ENTRY DATA_FORMAT (CL) C C SET FORMAT VARIABLES C INPUT/OUTPUT (1/2), UN/FORMATTED (1/2) C NHEADER RECORDS C ND, L(ND) NUMBER OF DIMENSIONS, NUMBER PER DIMENSION C NDG, NLN NUMBER OF DIGITS PER ELEMENT, NUMBER OF ELEMENTS PER LINE C L1 = 1 L2 = INDEX(CL,':') LN = LEN(CL) IF (L2.LT.L1) L2 = LN IF (L1.GE.L2.OR.CL(L1:L2-1).EQ.' ') THEN IF (CL(L2:L2).EQ.':') THEN WRITE (LUIO,*) 1 'In/Out, Un/formatted, All (1/2) ', IO, NFF(IO), NFA(IO) ELSE WRITE (LUIO,*) 1 'In/Out, Un/formatted, All (1/2) ? ', IO, NFF(IO), NFA(IO) READ (LUII,*) IO, NFF(IO), NFA(IO) WRITE (LUCO,*) IO, NFF(IO), NFA(IO) END IF ELSE READ (CL(L1:L2-1),*,END=210,ERR=210) IO, NFF(IO), NFA(IO) 210 CONTINUE END IF L1 = MIN(L2+1,LN) L2 = INDEX(CL(L1:LN),':') + L1 - 1 IF (L2.LT.L1) L2 = LN IF (L1.GE.L2.OR.CL(L1:L2-1).EQ.' ') THEN IF (CL(L2:L2).EQ.':') THEN WRITE (LUIO,*) 'Nrc, Nd, L(Nd) ', NFR(IO), NFD(IO), 1 (NFL(L,IO), L = 1, NFD(IO)) ELSE WRITE (LUIO,*) 'Nrc, Nd, L(Nd)?', NFR(IO), NFD(IO), 1 (NFL(L,IO), L = 1, NFD(IO)) READ (LUII,*) NFR(IO), NFD(IO), 1 (NFL(L,IO), L = 1, NFD(IO)) WRITE (LUCO,*) NFR(IO), NFD(IO), 1 (NFL(L,IO), L = 1, NFD(IO)) END IF ELSE READ (CL(L1:L2-1),*,END=220,ERR=220) NFR(IO), NFD(IO), 1 (NFL(L,IO), L = 1, NFD(IO)) 220 CONTINUE END IF L1 = MIN(L2+1,LN) L2 = INDEX(CL(L1:LN),':') + L1 - 1 IF (L2.LT.L1) L2 = LN IF (L1.GE.L2.OR.CL(L1:L2-1).EQ.' ') THEN IF (CL(L2:L2).EQ.':') THEN WRITE (LUIO,*) 'Nln, Ndg ', NLN, NDG ELSE WRITE (LUIO,*) 'Nln, Ndg ? ', NLN, NDG READ (LUII,*) NLN, NDG WRITE (LUCO,*) NLN, NDG END IF ELSE READ (CL(L1:L2-1),*,END=230,ERR=230) NLN, NDG 230 CONTINUE END IF RETURN END C SUBROUTINE DATA_SELECT (CL,NBS,IBS,LS,MS,NS,LX,NX,NXT,NP,NB) C C CHANGE DATA SELECTION C C NBS ( NVAR, MNVAR, MXVAR ) C IBS ( IPS, NXS, NXT, IOR, ISE ) C IPS PARTITION SELECTED C NXS PARTITION STARTING LOCATION (IBS-1)*NP C NXT NUMBER OF POINTS SELECTED IN PARTITION C IOR = -1 LAST ORDERING ISE = -1 LAST SELECTION C 0 DEFAULT ORDERING 0 DEFAULT SELECTION C 1 CHANGE ORDERING 1 CHANGE SELECTION C PARAMETER MD = 5, MK = 5, ML = 100, MV = 5 CHARACTER*(*) CL CHARACTER*132 FNAME(4), TITLES(0:MD) DIMENSION LX(1), NX(ML,1), NXT(1), IN(MK) DIMENSION NBS(3), IBS(MV,1), LS(1), MS(ML,1), NS(MV,ML,1) COMMON /LUN/ LUCI,LUCO,LUFI,LUFO,LUII,LUIO,ISAV,FNAME,TITLES DATA LUCI,LUCO,LUFI,LUFO,LUII,LUIO /1,2,3,4,5,6/, ISAV /0/ C L1 = 1 L2 = INDEX(CL,':') LN = LEN(CL) IF (L2.LT.L1) L2 = LN IF (L1.GE.L2.OR.CL(L1:L2-1).EQ.' ') THEN IF (CL(L2:L2).EQ.':') THEN WRITE (LUIO,*) 'Number of variables ', 1 NBS(2), NBS(3) ELSE IF (NBS(2).EQ.NBS(3)) THEN NBS(1) = NBS(2) ELSE WRITE (LUIO,*) 'Number of variables ? ', 1 NBS(2), NBS(3) READ (LUII,*) NBS(1) WRITE (LUCO,*) NBS(1) NBS(1) = MIN(NBS(3),MAX(NBS(2),NBS(1))) END IF END IF ELSE IF (NBS(2).EQ.NBS(3)) THEN NBS(1) = NBS(2) ELSE READ (CL(L1:L2-1),*,END=5,ERR=5) NBS(1) 5 CONTINUE L1 = MIN(L2+1,LN) L2 = INDEX(CL(L1:LN),':') + L1 - 1 END IF END IF C DO IDM = 1, NBS(1) C L10 = L1 L20 = L2 IBS(1,IDM) = MAX(1,MIN(NB,IBS(1,MAX(1,IDM-1)))) IF (L1.GE.L2.OR.CL(L1:L2-1).EQ.' ') THEN IF (CL(L2:L2).EQ.':') THEN WRITE (LUIO,*) 'Part ', 1 IBS(1,IDM) ELSE WRITE (LUIO,*) 'Part ? ', 1 IBS(1,IDM) READ (LUII,*) IBS(1,IDM) WRITE (LUCO,*) IBS(1,IDM) END IF ELSE READ (CL(L1:L2-1),*,END=10,ERR=10) IBS(1,IDM) 10 CONTINUE END IF C IF (1.LE.IBS(1,IDM).AND.IBS(1,IDM).LE.NB) THEN C IBS(2,IDM) = (IBS(1,IDM)-1)*NP LS(IDM) = LX(IBS(1,IDM)) IF (IDM.GT.1) THEN IF (IBS(1,IDM).EQ.IBS(1,IDM-1)) THEN C C DEFAULT TO LAST VARIABLE C DO L = 1, LS(IDM) MS(L,IDM) = MS(L,IDM-1) DO J = 1, MV NS(J,L,IDM) = NS(J,L,IDM-1) END DO END DO IBS(3,IDM) = IBS(3,IDM-1) ELSE C C MAKE ROOM AVAILABLE IF NONE C IF (LS(IDM).EQ.0) THEN IBS(4,IDM) = -1 IBS(5,IDM) = -1 LX(IBS(1,IDM)) = LX(IBS(1,IDM-1)) LS(IDM) = LX(IBS(1,IDM)) DO L = 1, LS(IDM) MS(L,IDM) = L NI = NS(MV-1,MS(L,IDM),IDM-1) NS(1,L,IDM) = 1 NS(2,L,IDM) = NI NS(3,L,IDM) = 1 NS(4,L,IDM) = NI NS(5,L,IDM) = NI NX(L,IBS(1,IDM)) = NI END DO NXT(IBS(1,IDM)) = IBS(3,IDM-1) END IF END IF END IF C L1 = MIN(L2+1,LN) L2 = INDEX(CL(L1:LN),':') + L1 - 1 IF (L2.LT.L1) L2 = LN IF (IBS(4,IDM).EQ.0) THEN CALL ORDERI (CL(L1:L2),LS(IDM),MS(1,IDM)) ELSE IF (IBS(4,IDM).EQ.1) THEN CALL ORDER (CL(L1:L2),LS(IDM),MS(1,IDM)) END IF L1 = MIN(L2+1,LN) L2 = INDEX(CL(L1:LN),':') + L1 - 1 IF (L2.LT.L1) L2 = LN IF (IBS(5,IDM).EQ.0) THEN CALL SELECTI (CL(L1:L2),LS(IDM),MS(1,IDM), 1 NX(1,IBS(1,IDM)),NS(1,1,IDM),IBS(3,IDM)) ELSE IF (IBS(5,IDM).EQ.1) THEN CALL SELECT (CL(L1:L2),LS(IDM),MS(1,IDM), 1 NX(1,IBS(1,IDM)),NS(1,1,IDM),IBS(3,IDM)) END IF L1 = MIN(L2+1,LN) L2 = INDEX(CL(L1:LN),':') + L1 - 1 IF (L2.LT.L1) L2 = LN IF ((L1.GE.L2.OR.CL(L1:L2-1).EQ.' ').AND. 1 CL(L2:L2).NE.':') THEN L1 = L10 L2 = L20 END IF ELSE WRITE (LUIO,*) 'Data Warning: Nonexistant partition' END IF END DO RETURN C ENTRY DATA_DEFINE (CL,NBS,IBS,LS,MS,NS,LX,NX,NXT,NP,NB) C C USE LS, MS TO INDEX PARTITION PRIOR TO SELECTION OF LX, NX, NXT C L1 = 1 L2 = INDEX(CL,':') LN = LEN(CL) IF (L2.LT.L1) L2 = LN IF (L1.GE.L2.OR.CL(L1:L2-1).EQ.' ') THEN IF (CL(L2:L2).NE.':') THEN IF (NBS(2).EQ.NBS(3)) THEN NBS(1) = NBS(2) ELSE WRITE (LUIO,*) 'Number of variables ? ', NBS(1) READ (LUII,*) NBS(1) WRITE (LUCO,*) NBS(1) NBS(1) = MIN(NBS(3),MAX(NBS(2),NBS(1))) END IF END IF ELSE NBS(1) = NBS(3) END IF C DO IDM = 1, NBS(1) C L10 = L1 L20 = L2 IBS(1,IDM) = MAX(1,MIN(NB,IBS(1,MAX(1,IDM-1)))) IF (L1.GE.L2.OR.CL(L1:L2-1).EQ.' ') THEN IF (CL(L2:L2).EQ.':') THEN WRITE (LUIO,*) 'Part ', 1 IBS(1,IDM) ELSE WRITE (LUIO,*) 'Part ? ', 1 IBS(1,IDM) READ (LUII,*) IBS(1,IDM) WRITE (LUCO,*) IBS(1,IDM) END IF ELSE READ (CL(L1:L2-1),*,END=20,ERR=20) IBS(1,IDM) 20 CONTINUE END IF C IF (1.LE.IBS(1,IDM).AND.IBS(1,IDM).LE.NB) THEN C LX(IBS(1,IDM)) = LS(IDM) NXT(IBS(1,IDM)) = 1 DO L = 1, LS(IDM) NX(L,IBS(1,IDM)) = MS(L,IDM) MS(L,IDM) = L NXT(IBS(1,IDM)) = NXT(IBS(1,IDM))*NX(L,IBS(1,IDM)) END DO IBS(2,IDM) = (IBS(1,IDM)-1)*NP IBS(3,IDM) = NXT(IBS(1,IDM)) C IF (IDM.GT.1) THEN IF (IBS(1,IDM).EQ.IBS(1,IDM-1)) THEN C C DEFAULT TO LAST VARIABLE C DO L = 1, LS(IDM) MS(L,IDM) = MS(L,IDM-1) DO J = 1, MV NS(J,L,IDM) = NS(J,L,IDM-1) END DO END DO IBS(3,IDM) = IBS(3,IDM-1) ELSE C C MAKE ROOM AVAILABLE IF NONE C IF (LS(IDM).EQ.0) THEN IBS(4,IDM) = -1 IBS(5,IDM) = -1 LX(IBS(1,IDM)) = LX(IBS(1,IDM-1)) LS(IDM) = LX(IBS(1,IDM)) DO L = 1, LS(IDM) MS(L,IDM) = L NI = NS(MV-1,MS(L,IDM),IDM-1) NS(1,L,IDM) = 1 NS(2,L,IDM) = NI NS(3,L,IDM) = 1 NS(4,L,IDM) = NI NS(5,L,IDM) = NI NX(L,IBS(1,IDM)) = NI END DO NXT(IBS(1,IDM)) = IBS(3,IDM-1) END IF END IF END IF C L1 = MIN(L2+1,LN) L2 = INDEX(CL(L1:LN),':') + L1 - 1 IF (L2.LT.L1) L2 = LN IF (IBS(4,IDM).EQ.0) THEN CALL ORDERI (CL(L1:L2),LS(IDM),MS(1,IDM)) ELSE IF (IBS(4,IDM).EQ.1) THEN CALL ORDER (CL(L1:L2),LS(IDM),MS(1,IDM)) END IF L1 = MIN(L2+1,LN) L2 = INDEX(CL(L1:LN),':') + L1 - 1 IF (L2.LT.L1) L2 = LN IF (IBS(5,IDM).EQ.0) THEN CALL SELECTI (CL(L1:L2),LS(IDM),MS(1,IDM), 1 NX(1,IBS(1,IDM)),NS(1,1,IDM),IBS(3,IDM)) ELSE IF (IBS(5,IDM).EQ.1) THEN CALL SELECT (CL(L1:L2),LS(IDM),MS(1,IDM), 1 NX(1,IBS(1,IDM)),NS(1,1,IDM),IBS(3,IDM)) END IF L1 = MIN(L2+1,LN) L2 = INDEX(CL(L1:LN),':') + L1 - 1 IF (L2.LT.L1) L2 = LN IF ((L1.GE.L2.OR.CL(L1:L2-1).EQ.' ').AND. 1 CL(L2:L2).NE.':') THEN L1 = L10 L2 = L20 END IF ELSE WRITE (LUIO,*) 'Data Warning: Nonexistant partition' END IF END DO RETURN C ENTRY DATA_INDICES (II,IN,NBS,IBS,LS,MS,NS) C C COMPUTE DATA INDICES OF THE VARIABLES AT I C DO IDM = 1, NBS(1) IF (IBS(3,IDM).EQ.IBS(3,NBS(1))) THEN IN(IDM) = IBS(2,IDM) + 1 LOCI(II,LS(IDM),MS(1,IDM),NS(1,1,IDM)) ELSE J = LOCI(II,LS(NBS(1)),MS(1,NBS(1)),NS(1,1,NBS(1))) IN(IDM) = IBS(2,IDM) + 1 LOCL( J,LS(IDM),MS(1,IDM),NS(1,1,IDM),NS(1,1,NBS(1))) END IF END DO RETURN END C SUBROUTINE ORDER (CL,L,M) C C ORDER OF DATA C PARAMETER MD = 5 CHARACTER*(*) CL CHARACTER*132 FNAME(4), TITLES(0:MD) DIMENSION M(1) COMMON /LUN/ LUCI,LUCO,LUFI,LUFO,LUII,LUIO,ISAV,FNAME,TITLES DATA LUCI,LUCO,LUFI,LUFO,LUII,LUIO /1,2,3,4,5,6/, ISAV /0/ C DO J = 1, L M(J) = J END DO L1 = 1 L2 = INDEX(CL,':') LN = LEN(CL) IF (L2.LT.L1) L2 = LN IF (L1.GE.L2.OR.CL(L1:L2-1).EQ.' ') THEN IF (CL(L2:L2).EQ.':') THEN WRITE (LUIO,*) 'Order of dimensions 1-L ', L WRITE (LUIO,*) (M(J), J = 1, L) ELSE WRITE (LUIO,*) 'Order of dimensions 1-L ?', L READ (LUII,*) (M(J), J = 1, L) WRITE (LUCO,*) (M(J), J = 1, L) END IF ELSE READ (CL(L1:L2-1),*,END=10,ERR=10) (M(J), J = 1, L) 10 CONTINUE END IF RETURN C ENTRY ORDERI (CL,L,M) C DO J = 1, L M(J) = J END DO RETURN END C SUBROUTINE SELECT (CL,L,M,N,NI,NS) C C SELECT SUBARRAY C THE NI ARRAY HOLDS ARRAY INDICES FOR EACH OF L DIMENSIONS C INITIAL NI(1,L) INPUT C FINAL NI(2,L) INPUT C DELTA1 NI(3,L) INPUT C NUMBER NI(4,L) CALC C MAXIMUM NI(5,L) FILE C NS IS THE TOTAL NUMBER SELECTED C PARAMETER MD = 5, MV = 5 CHARACTER*(*) CL CHARACTER*132 FNAME(4), TITLES(0:MD) DIMENSION M(1), N(1), NI(MV,1) COMMON /LUN/ LUCI,LUCO,LUFI,LUFO,LUII,LUIO,ISAV,FNAME,TITLES DATA LUCI,LUCO,LUFI,LUFO,LUII,LUIO /1,2,3,4,5,6/, ISAV /0/ C DO J = 1, L NI(1,J) = 1 NI(2,J) = 0 NI(3,J) = 1 NI(4,J) = 1 NI(5,J) = N(J) END DO C L1 = 1 L2 = INDEX(CL,':') LN = LEN(CL) IF (L2.LT.L1) L2 = LN IF (L1.GE.L2.OR.CL(L1:L2-1).EQ.' ') THEN IF (CL(L2:L2).EQ.':') THEN WRITE (LUIO,*) 'Total', (NI(5,M(J)), J = 1, L) WRITE (LUIO,*) ((NI(I,M(J)), I = 1, 3), J = 1, L) ELSE WRITE (LUIO,*) 'Total', (NI(5,M(J)), J = 1, L) WRITE (LUIO,*) 'Initial, final, delta ? ' READ (LUII,*) ((NI(I,M(J)), I = 1, 3), J = 1, L) WRITE (LUCO,*) ((NI(I,M(J)), I = 1, 3), J = 1, L) END IF ELSE READ (CL(L1:L2-1),*,END=10,ERR=10) ((NI(I,M(J)), I = 1, 3), 1 J = 1, L) 10 CONTINUE END IF C C INSURE THE FINAL VALUE IS ACTUALLY READ C AND COMPUTE THE INTERNAL P/V/D SPACING C NS = 1 DO J = 1, L IF (NI(3,J).LT.0) THEN I = 1 ELSE I = 2 END IF IF (NI(I,J).EQ.0) THEN NI(I,J) = NI(5,J) ELSE IF (NI(5,J).EQ.0) THEN NI(5,J) = NI(I,J) END IF NI(I,J) = NI(I,J) - MOD(NI(2,J)-NI(1,J),NI(3,J)) NI(4,J) = (NI(2,J) - NI(1,J)) / NI(3,J) + 1 NS = NS * NI(4,J) END DO RETURN C ENTRY SELECTI (CL,L,M,N,NI,NS) C DO J = 1, L NI(1,J) = 1 NI(2,J) = N(J) NI(3,J) = 1 NI(4,J) = N(J) NI(5,J) = N(J) END DO NS = 1 DO J = 1, L NS = NS * NI(4,J) END DO RETURN END C FUNCTION LOCMJ(J,L,M) C C COMPUTE THE LOCATION IN M OF J (M INVERSE OF J) C RETURNS 0 IF NONEXISTENT C DIMENSION M(1) K = L DO WHILE (M(K).NE.J.AND.K.GT.0) K = K - 1 END DO LOCMJ = K RETURN END C FUNCTION ICOL(I,L,M,NI) C C IF M IS THE IDENTITY FUNCTION (J = LOCMJ(J,L,M)) C COMPUTE THE COUNT IN THE INPUT OF THE LOCATION C ELSE C COMPUTE THE COUNT IN THE OUTPUT OF THE LOCATION C END IF C LOCI INVERSE. THE COUNT RETURNED IS LESS THAN OR EQUAL TO C THE LOCATION. C PARAMETER ML = 100, MV = 5 DIMENSION IN(ML), M(1), NI(MV,1) C NS = 1 DO J = 1, L IN(J) = MOD((I-1)/NS,NI(5,J))+1 IN(J) = MIN( MAX(NI(1,J),NI(2,J)), MAX( MIN(NI(1,J),NI(2,J)), 1 IN(J) ) ) IN(J) = (IN(J) - NI(1,J))/NI(3,J) + 1 NS = NS * NI(5,J) END DO IC = 1 NS = 1 DO J = 1, L IC = IC + (IN(M(J))-1)*NS NS = NS * NI(4,M(J)) END DO ICOL = IC RETURN END C FUNCTION LOCL(I,L,M,NI,NN) C C COMPUTES THE LOCATION LESS THAN OR EQUAL TO THE INPUT LOCATION C IN THE SELECTED SUBARRAY (M UNUSED) C PARAMETER ML = 100, MV = 5 DIMENSION IN(ML), M(1), NI(MV,1), NN(MV,1) C NS = 1 DO J = 1, L IN(J) = MOD((I-1)/NS,NN(5,J))+1 IN(J) = MIN( MAX(NI(1,J),NI(2,J)), MAX( MIN(NI(1,J),NI(2,J)), 1 IN(J) ) ) IN(J) = IN(J) - MOD(IN(J)-NI(1,J),NI(3,J)) NS = NS * NN(5,J) END DO IC = 1 NS = 1 DO J = 1, L IC = IC + (IN(J)-1)*NS NS = NS * NI(5,J) END DO LOCL = IC RETURN END C FUNCTION LOCI(I,L,M,NI) C C IF M IS THE IDENTITY FUNCTION (J = LOCMJ(J,L,M)) C COMPUTE THE LOCATION IN THE INPUT OF THE INPUT COUNT C ELSE C COMPUTE THE LOCATION IN THE INPUT OF THE OUTPUT COUNT C END IF C PARAMETER MV = 5 DIMENSION M(1), NI(MV,1) C IN = 1 JN = 1 DO J = 1, L IN = IN + JN*(ILOCI(I,J,L,M,NI)-1) JN = JN*NI(5,J) END DO LOCI = IN RETURN C ENTRY LOCO(I,L,M,NI) C C COMPUTE THE LOCATION IN THE OUTPUT OF THE INPUT COUNT C IN = 1 JN = 1 DO J = 1, L IN = IN + JN*(ILOCO(I,J,L,M,NI)-1) JN = JN*NI(4,M(J)) END DO LOCO = IN RETURN END C FUNCTION ILOCI(I,J,L,M,NI) C C COMPUTE THE JTH INDEX OF THE LOCATION IN THE INPUT C CORRESPONDING TO THE INPUT COUNT I C PARAMETER MV = 5 DIMENSION M(1), NI(MV,1) KN = 1 DO K = 1, LOCMJ(J,L,M)-1 KN = KN*NI(4,M(K)) END DO ILOCI = 1 + ( NI(3,J)*MOD((I-1)/KN,NI(4,J)) + NI(1,J) - 1 ) RETURN C ENTRY ILOCO(I,J,L,M,NI) C C COMPUTE THE JTH INDEX OF THE LOCATION IN THE OUTPUT C CORRESPONDING TO THE INPUT COUNT I C KN = 1 DO K = 1, M(J)-1 KN = KN*NI(4,K) END DO ILOCO = 1 + MOD((I-1)/KN,NI(4,M(J))) RETURN END C FUNCTION AMODN(AM,AN) C C NEGATIVE MODULUS (REMAINDER OF AM ON DIVISION BY AN) C AL = AMOD(AM,AN) IF (AL.GT.0.0) AL = AL - AN AMODN = AL RETURN C ENTRY AMODP(AM,AN) C C POSITIVE MODULUS (REMAINDER OF AM ON DIVISION BY AN) C AL = AMOD(AM,AN) IF (AL.LT.0.0) AL = AL + AN AMODP = AL RETURN C ENTRY MODN(M,N) C C NEGATIVE MODULUS (REMAINDER OF M ON DIVISION BY N) C L = MOD(M,N) IF (L.GT.0) L = L - N MODN = L RETURN C ENTRY MODP(M,N) C C POSITIVE MODULUS (REMAINDER OF M ON DIVISION BY N) C L = MOD(M,N) IF (L.LT.0) L = L + N MODP = L RETURN END