IMPLICIT REAL*8 (A-H,O-Z) PARAMETER(MSPA=100000) C MSPA - MAX SIZE OF PRIMARY MEMORY ARRAY REAL*8 O(MSPA) CHARACTER CH*2 LOGICAL SEXF N=100 NB=10 NV=0 X=0D0 CALL SINI(MSPA) CALL SDEF('ID','I',N,KID) CALL ASS1(N,NB,X,O(KID),MSIZ) write(*,*)'msiz',msiz CALL SDEF('IB','I',N,KIB) CALL JDJB(N,O(KID),O(KIB)) CALL SDEF('IV','I',N,KIV) CALL ASS2(N,NV,X,O(KIV)) CALL SDEF('AA','R8',MSIZ,KAA) CALL SDEF('A','R8',MSIZ,KA) CALL SDEF('XX','R8',N,KXX) CALL SDEF('X','R8',N,KX) CALL SDEF('BB','R8',N,KBB) CALL SDEF('B','R8',N,KB) CALL ASS3(N,MSIZ,O(KID),X,O(KAA)) CALL ASS4(N,X,O(KXX)) CALL ASS4(N,X,O(KBB)) CALL SINF c CALL SPRI(O, 'ID') write(*,*)'solv in' do i=1,100000 CALL VECOPY(MSIZ,O(KAA),O(KA)) CALL VECOPY(N,O(KXX),O(KX)) CALL VECOPY(N,O(KBB),O(KB)) CALL SOLs(N,0,O(KID), c I O(KIV), M O(KA),O(KX), c M O(KB), O NZER,NNEG) enddo write(*,*)'nzer,nneg',nzer,nneg CALL SPRI(O, 'X') END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE ASS1( I N,NB, M X, O IV,K) C ASSIGN VALUES TO VECTOR C INPUT: C N - DIMENSION OF VECTOR C OUTPUT: C IV(N) - INTEGER VECTOR C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! IMPLICIT REAL*8 (A-H,O-Z) INTEGER IV(*) K=0 DO I=1,N J=INUM(1,MIN(I,NB),X) K=K+J IV(I)=K c write(*,*)'i,j,k',i,j,k ENDDO RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE ASS2( I N,NV, M X, O IV) C ASSIGN VALUES TO VECTOR C INPUT: C N - DIMENSION OF VECTOR C OUTPUT: C IV(N) - INTEGER VECTOR C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! IMPLICIT REAL*8 (A-H,O-Z) INTEGER IV(*) DO I=1,N IV(N)=0 ENDDO DO I=1,NV 10 J=INUM(1,N,X) IF(IV(J).EQ.0)THEN IV(J)=1 ELSE GOTO 10 ENDIF c write(*,*)'i,j',i,j ENDDO RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE ASS3( I N,M,ID,X, O V) C ASSIGN VALUES TO VECTOR C INPUT: C N - DIMENSION OF VECTOR C OUTPUT: C V(N) - VECTOR C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! IMPLICIT REAL*8 (A-H,O-Z) INTEGER ID(*) REAL*8 V(*) DO I=1,M V(I)=RNUM(0D0,1D0,X) c write(*,*)'i,v',i,v(i) ENDDO DO I=1,N V(ID(I))=N*V(ID(I)) c write(*,*)'*i,v',i,v(id(i)) ENDDO RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE ASS4( I N,X, O V) C ASSIGN VALUES TO VECTOR C INPUT: C N - DIMENSION OF VECTOR C OUTPUT: C V(N) - VECTOR C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! IMPLICIT REAL*8 (A-H,O-Z) REAL*8 V(*) DO I=1,N V(I)=RNUM(0D0,1D0,X) c write(*,*)'i,v',i,v(i) ENDDO RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE JDJB( I N,ID, O IB) C COPY VECTOR C INPUT: C N - DIMENSION OF VECTORS C ID(N) - POINTERS TO DIAGONAL TERMS OF MATRIX C OUTPUT: C IB(N) - FIRST ROW NUMBER C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! IMPLICIT REAL*8 (A-H,O-Z) INTEGER ID(*),IB(*) KE=0 DO I=1,N KB=KE+1 KE=ID(I) IB(I)=I-KE+KB c write(*,*)'i,id,ib',i,id(i),ib(i) ENDDO RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE VECOPY( I N,U, O V) C COPY VECTOR C INPUT: C N - DIMENSION OF VECTORS C U(N) - VECTOR C OUTPUT: C V(N) - COPY OF VECTOR C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! IMPLICIT REAL*8 (A-H,O-Z) REAL*8 U(*),V(*) DO I=1,N V(I)=U(I) ENDDO RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! FUNCTION RNDM(X) C GENERATE RANDOM NUMBER FROM INTERVAL [0,1) C INPUT & OUTPUT: C X - GENERATOR VALUE C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! IMPLICIT REAL*8 (A-H,O-Z) IF(X.EQ.0D0)X=.49753297356723D0 X=X*32.967493748987D0 X=X-INT(X) RNDM=X RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! FUNCTION RNUM(A,B, X) C GENERATE REAL*8 RANDOM NUMBER FROM INTERVAL [A,B] C INPUT: C A - LOWER BOUND C B - UPPER BOUND C INPUT & OUTPUT: C X - GENERATOR VALUE C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! IMPLICIT REAL*8 (A-H,O-Z) RNUM=RNDM(X) RNUM=A+RNUM*(B-A) IF(RNUM.LT.A)RNUM=A IF(RNUM.GT.B)RNUM=B RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! FUNCTION INUM(IA,IB, X) C GENERATE INTEGER RANDOM NUMBER FROM INTERVAL [A,B] C INPUT: C IA - LOWER BOUND C IB - UPPER BOUND C INPUT & OUTPUT: C X - GENERATOR VALUE C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! IMPLICIT REAL*8 (A-H,O-Z) R=RNDM(X) R=IA+R*(IB-IA+1) INUM=INT(R) IF(INUM.LT.IA)INUM=IA IF(INUM.GT.IB)INUM=IB RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE SOLS( I N,M,ID, M A,V, O NZER,NNEG) C SOLVES SYMMETRIC SYSTEM OF EQUATIONS C [ A ] [ X ] = [ B ] C SOLUTION X AS OUTPUT. C INPUT: C N - DIMENSION OF MATRIX AND VECTORS C M - DIMENSION OF ALREADY TRIANGULATED SUBMATRIX: C M=0 ORIGINAL MATRIX C 0 0 - INDICATES INCORRECT DECOMPOSITION C NNEG - NUMBER OF NEGATIVE TERMS OF CURRENTLY TRIANGULATED C PART OF DIAGONAL MATRIX D. C NNEG > 0 - INDICATES THAT MATRIX A IS NOT POSITIVE C DEFINITE C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! IMPLICIT REAL*8 (A-H,O-Z) INTEGER ID(*) REAL*8 A(*),V(*) PARAMETER(ZERO=1D-100) NZER=0 NNEG=0 IF(M.LT.N)THEN C TRIANGULATE MATRIX A := L * (D)-1 * LT IF(M.LE.0)THEN JE=ID(1) M1=2 T=A(JE) IF(T.LE.ZERO)THEN NNEG=NNEG+1 IF(T.GT.-ZERO)THEN NZER=NZER+1 T=DSIGN(ZERO,T) ENDIF ENDIF A(JE)=1D0/T ELSE JE=ID(M) M1=M+1 ENDIF DO J=M1,N JB=JE+1 JE=ID(J) JP=JE-J JP1=JP-1 I1=JB-JP IE=ID(I1) IJ=JB DO I=I1+1,J-1 IB=IE+1 IE=ID(I) KP=IE-I-JP IJ=IJ+1 R=A(IJ) DO K=MAX(JB,IB-KP),JP1+I R=R-A(K)*A(K+KP) ENDDO A(IJ)=R ENDDO T=A(JE) IJ=JB DO I=I1,J-1 R=A(IJ) S=R*A(ID(I)) A(IJ)=S IJ=IJ+1 T=T-R*S ENDDO IF(T.LE.ZERO)THEN NNEG=NNEG+1 IF(T.GT.-ZERO)THEN NZER=NZER+1 T=DSIGN(ZERO,T) ENDIF ENDIF A(JE)=1D0/T ENDDO ENDIF C TRIANGULATE VECTOR B := (L)-1 * B KP=ID(1) DO J=2,N R=V(J) KP=KP+1 DO I=J+KP-ID(J),J-1 R=R-A(KP)*V(I) KP=KP+1 ENDDO V(J)=R ENDDO C MULTIPLY BY DIAGONAL TERMS X := D * B DO I=1,N V(I)=A(ID(I))*V(I) ENDDO C BACKSUBSTITUTE X := (LT)-1 * X KP=ID(N) DO J=N,2,-1 R=V(J) KP=KP-1 DO I=J-1,J-KP+ID(J-1),-1 V(I)=V(I)-A(KP)*R KP=KP-1 ENDDO ENDDO RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! C *** STACK MANAGEMENT SYSTEM *** VERSION REAL*8 C AUTHOR: MAREK KLISINSKI C PARAMETERS: C MSTE - MAXIMUM NUMBER OF STACK ENTRIES C IOSF - INPUT-OUTPUT UNIT FOR STACK-FILE OPERATIONS C LREC - RECORD LENGTH FOR STACK-FILE OPERATIONS C COMMON: /CSTACK/ C CHARACTER*6 ARNA(MSTE) - VECTOR OF ARRAY NAMES C CHARACTER*2 ARTY(MSTE) - VECTOR OF ARRAY TYPES C INTEGER IARD(MSTE) - VECTOR OF ARRAY DIMENSIONS C INTEGER IARP(MSTE) - VECTOR OF ARRAY POINTERS C INTEGER MSPA - SIZE OF PRIMARY MEMORY ARRAY AS REAL*8 C INTEGER LARP - LAST USED ARRAY POINTER C INTEGER NSTE - NUMBER OF STACK ENTRIES C DESCRIBED IN FILE 'sms.h' C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! C SUBROUTINES: C SCOM - COMPRESS STACK BY PUSHING IT DOWN C SDEF - DEFINE NEW ENTRY IN STACK C SDEL - DELETE LAST ARRAY OR SET OF ARRAYS FROM STACK C SGET - GET INFORMATION ABOUT STACK ENTRY C SINF - PRINT INFORMATION ABOUT STACK ENTRIES C SINI - INITIALIZE STACK C SINP - INPUT ARRAY OR SET OF THEM FROM EXTERNAL FILE TO STACK C SOUT - OUTPUT ARRAY OR SET OF THEM FROM STACK TO EXTERNAL FILE C SPRF - PRINT CONTENTS OF FILE TO DEFAUT OUTPUT C SPRI - PRINT CONTENTS OF STACK ENTRY TO DEFAUT OUTPUT C SREM - REMOVE SET OF ARRAYS BY PUSHING STACK DOWN C SREN - RENAME ENTRY IN STACK C SZER - ZERO STACK ARRAY C FUNCTIONS: C SDAT - DETERMINE NUMBER OF DATA AS REAL*8 C SDIM - DETERMINE DIMENSION OF ARRAY C SEXE - CHECK EXISTENCE OF ENTRY NAME IN STACK C SEXF - CHECK EXISTENCE OF STACK DATA FILE WITH EXTENSION '.STA' C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE SCOM(O) C COMPRESS STACK BY PUSHING IT DOWN C ENTRIES NAMED 'DELETE' ARE DELETED FROM STACK C !!! CAUTION !!! C DO NOT USE THIS SUBROUTINE UNLESS NECESSARY. C PRIMARY MEMORY ARRAY IS MODIFIED. C POINTERS TO MOST ENTRIES MAY CHANGE. C O(ISPA) - PRIMARY MEMORY ARRAY C ISPA - DECLARED SIZE OF PRIMARY MEMORY ARRAY C INPUT & OUTPUT: NONE C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! REAL*8 O(*) C *** SMS ICLUDE FILE *** PARAMETER(MSTE=500,IOSF=9,LREC=100) C MSTE - MAXIMUM NUMBER OF STACK ENTRIES C IOSF - INPUT-OUTPUT UNIT FOR STACK-FILE OPERATIONS C LREC - RECORD LENGTH FOR STACK-FILE OPERATIONS CHARACTER ARNA(MSTE)*6,ARTY(MSTE)*2 INTEGER IARD(MSTE),IARP(MSTE) COMMON /CSTACK/ARNA,ARTY,IARD,IARP,MSPA,LARP,NSTE C ARNA(MSTE) - VECTOR OF ARRAY NAMES C ARTY(MSTE) - VECTOR OF ARRAY TYPES C IARD(MSTE) - VECTOR OF ARRAY DIMENSIONS C IARP(MSTE) - VECTOR OF ARRAY POINTERS C MSPA - SIZE OF PRIMARY MEMORY ARRAY C LARP - LAST USED ARRAY POINTER C NSTE - NUMBER OF STACK ENTRIES LOGICAL SEXE,SEXF INTEGER SDAT C SEXE - FUNCTION TO CHECK EXISTENCE OF ENTRY NAME IN STACK C SEXF - FUNCTION TO CHECK EXISTENCE OF FILE IN CURRENT DIRECTORY C SDAT - INTERNAL FUNCTION TO DETERMINE NUMBER OF DATA AS REAL*8 CHARACTER NAME*6,TYPE*2 C ERROR INDICATORS IE=0 IERR=0 C NUMBER OF STACK ENTRIES AND LAST POINTER JSTE=0 LPTA=0 C LOOP THROUGH ALL ENTRIES DO ISTE=1,NSTE C ENTRY PARAMETERS NAME=ARNA(ISTE) IF(NAME.NE.'DELETE')THEN TYPE=ARTY(ISTE) IDIM=IARD(ISTE) IPTA=IARP(ISTE) NA=SDAT('SCOM',NAME, TYPE,IDIM, IE) IF(LPTA.LT.0)IE=IE+1 NPTA=LPTA+NA IF(NPTA.GT.MSPA)IE=IE+2 IF(JSTE.GE.MSTE)IE=IE+4 IF(IE.EQ.0)THEN C PERFORM STACK UPDATE JSTE=JSTE+1 ARNA(JSTE)=NAME ARTY(JSTE)=TYPE IARD(JSTE)=IDIM JPTA=LPTA+1 IARP(JSTE)=JPTA LPTA=NPTA IF(JPTA.NE.IPTA)THEN C PERFORM PRIMARY MEMORY ARRAY PUSH DOWN IPI=IPTA IPJ=JPTA DO IPJ=IPJ,IPJ+NA-1 O(IPJ)=O(IPI) IPI=IPI+1 ENDDO ENDIF ELSE C ERROR MESAGES IF(MOD(IE,2).GE.1) & WRITE(*,*)'* SCOM * ',NAME,' : NEGATIVE LAST POINTER =',LPTA IF(MOD(IE,4).GE.2) & WRITE(*,*)'* SCOM * ',NAME,' : ARRAY TOO BIG. MAXIMUM SIZE ( &REAL*8) =',MSPA-LPTA IF(MOD(IE,8).GE.4) & WRITE(*,*)'* SCOM * ',NAME,' : TOO MANY STACK ENTRIES >', & MSTE IE=0 IERR=1 ENDIF ENDIF ENDDO IF(IERR.EQ.1)THEN CALL SINF STOP ELSE LARP=LPTA NSTE=JSTE ENDIF RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE SDEF( I NAME,TYPE,IDIM, O IPTA) C DEFINE NEW ENTRY IN STACK C INPUT: C NAME - NAME OF NEW ENTRY (ARRAY OR SET OF ARRAYS) C FIRST 6 CHARACTERS SIGNIFICANT C TYPE - TYPE OF ARRAY C = 'R8' FOR REAL*8 = DOUBLE PRECISION C = 'R4' = 'R' FOR REAL*4 = REAL C = 'I4' = 'I' FOR INTEGER*4 = INTEGER C = 'I2' FOR INTEGER*2 C = 'N0' = 'N' FOR NAME OF SET OF ARRAYS C IDIM - DIMENSION OF ARRAY C OUTPUT: C IPTA - POINTER TO ARRAY C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! CHARACTER*(*) NAME,TYPE C *** SMS ICLUDE FILE *** PARAMETER(MSTE=500,IOSF=9,LREC=100) C MSTE - MAXIMUM NUMBER OF STACK ENTRIES C IOSF - INPUT-OUTPUT UNIT FOR STACK-FILE OPERATIONS C LREC - RECORD LENGTH FOR STACK-FILE OPERATIONS CHARACTER ARNA(MSTE)*6,ARTY(MSTE)*2 INTEGER IARD(MSTE),IARP(MSTE) COMMON /CSTACK/ARNA,ARTY,IARD,IARP,MSPA,LARP,NSTE C ARNA(MSTE) - VECTOR OF ARRAY NAMES C ARTY(MSTE) - VECTOR OF ARRAY TYPES C IARD(MSTE) - VECTOR OF ARRAY DIMENSIONS C IARP(MSTE) - VECTOR OF ARRAY POINTERS C MSPA - SIZE OF PRIMARY MEMORY ARRAY C LARP - LAST USED ARRAY POINTER C NSTE - NUMBER OF STACK ENTRIES LOGICAL SEXE,SEXF INTEGER SDAT C SEXE - FUNCTION TO CHECK EXISTENCE OF ENTRY NAME IN STACK C SEXF - FUNCTION TO CHECK EXISTENCE OF FILE IN CURRENT DIRECTORY C SDAT - INTERNAL FUNCTION TO DETERMINE NUMBER OF DATA AS REAL*8 CHARACTER TYP*2 C ERROR INDICATOR IE=0 C CHECK IF ENTRY EXIST IF(SEXE(NAME,I).AND.NAME.NE.'DELETE')IE=1 C CHECK ARRAY TYPE TYP=TYPE NA=SDAT('SDEF',NAME, TYP,IDIM, IE) C ARRAY SIZE AND NEW POINTER IF(LARP.LT.0)IE=IE+2 NARP=LARP+NA IF(NARP.GT.MSPA)IE=IE+4 IF(NSTE.GE.MSTE)IE=IE+8 IF(IE.EQ.0)THEN C ASSIGN NEW ARRAY NSTE=NSTE+1 ARNA(NSTE)=NAME ARTY(NSTE)=TYP IARD(NSTE)=IDIM IPTA=LARP+1 IARP(NSTE)=IPTA LARP=NARP ELSE C ERROR MESAGES IF(MOD(IE,2).GE.1) & WRITE(*,*)'* SDEF * ',NAME,' : DUPLICATE ENTRY NAME' IF(MOD(IE,4).GE.2) & WRITE(*,*)'* SDEF * ',NAME,' : NEGATIVE LAST POINTER =',LARP IF(MOD(IE,8).GE.4) & WRITE(*,*)'* SDEF * ',NAME,' : ARRAY TOO BIG. MAXIMUM SIZE (REAL &*8) =',MSPA-LARP IF(MOD(IE,16).GE.8) & WRITE(*,*)'* SDEF * ',NAME,' : TOO MANY STACK ENTRIES >',MSTE CALL SINF STOP ENDIF RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE SDEL( I NAME) C DELETE LAST ARRAY OR SET OF ARRAYS FROM STACK C INPUT: C NAME - NAME OF ENTRY (ARRAY OR SET) TO BE DELETED C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! CHARACTER*(*) NAME C *** SMS ICLUDE FILE *** PARAMETER(MSTE=500,IOSF=9,LREC=100) C MSTE - MAXIMUM NUMBER OF STACK ENTRIES C IOSF - INPUT-OUTPUT UNIT FOR STACK-FILE OPERATIONS C LREC - RECORD LENGTH FOR STACK-FILE OPERATIONS CHARACTER ARNA(MSTE)*6,ARTY(MSTE)*2 INTEGER IARD(MSTE),IARP(MSTE) COMMON /CSTACK/ARNA,ARTY,IARD,IARP,MSPA,LARP,NSTE C ARNA(MSTE) - VECTOR OF ARRAY NAMES C ARTY(MSTE) - VECTOR OF ARRAY TYPES C IARD(MSTE) - VECTOR OF ARRAY DIMENSIONS C IARP(MSTE) - VECTOR OF ARRAY POINTERS C MSPA - SIZE OF PRIMARY MEMORY ARRAY C LARP - LAST USED ARRAY POINTER C NSTE - NUMBER OF STACK ENTRIES LOGICAL SEXE,SEXF INTEGER SDAT C SEXE - FUNCTION TO CHECK EXISTENCE OF ENTRY NAME IN STACK C SEXF - FUNCTION TO CHECK EXISTENCE OF FILE IN CURRENT DIRECTORY C SDAT - INTERNAL FUNCTION TO DETERMINE NUMBER OF DATA AS REAL*8 C ERROR INDICATOR IE=0 C CHECK IF NAME EXIST IF(.NOT.SEXE(NAME,I))THEN IE=1 GOTO 90 ENDIF C CHECK ARRAY TYPE IF(ARTY(I).NE.'N0')THEN C CHECK IF ARRAY IS LAST IF(I.NE.NSTE)IE=IE+2 ELSE C CHECK IF SET NAME IS LAST DO J=I+1,NSTE IF(ARTY(J).EQ.'N0')THEN IE=IE+4 GOTO 90 ENDIF ENDDO ENDIF 90 IF(IE.EQ.0)THEN C DELETE ARRAY OR SET OF ARRAYS NSTE=I-1 LARP=IARP(I)-1 ELSE C ERROR MESAGES IF(MOD(IE,2).GE.1) & WRITE(*,*)'* SDEL * ',NAME,' : ENTRY NOT EXIST' IF(MOD(IE,4).GE.2) & WRITE(*,*)'* SDEL * ',NAME,' : ARRAY IS NOT LAST' IF(MOD(IE,8).GE.4) & WRITE(*,*)'* SDEL * ',NAME,' : ARRAY SET IS NOT LAST' CALL SINF STOP ENDIF RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE SGET( I NAME, O TYPE,IDIM,IPTA) C GET INFORMATION ABOUT STACK ENTRY C INPUT: C NAME - NAME OF ARRAY OR SET OF ARRAYS C OUTPUT: C TYPE - TYPE OF ARRAY C IDIM - DIMENSION OF ARRAY (MAY BE GREATER THAN DECLARED) C IPTA - POINTER TO ARRAY C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! CHARACTER*(*) NAME,TYPE C *** SMS ICLUDE FILE *** PARAMETER(MSTE=500,IOSF=9,LREC=100) C MSTE - MAXIMUM NUMBER OF STACK ENTRIES C IOSF - INPUT-OUTPUT UNIT FOR STACK-FILE OPERATIONS C LREC - RECORD LENGTH FOR STACK-FILE OPERATIONS CHARACTER ARNA(MSTE)*6,ARTY(MSTE)*2 INTEGER IARD(MSTE),IARP(MSTE) COMMON /CSTACK/ARNA,ARTY,IARD,IARP,MSPA,LARP,NSTE C ARNA(MSTE) - VECTOR OF ARRAY NAMES C ARTY(MSTE) - VECTOR OF ARRAY TYPES C IARD(MSTE) - VECTOR OF ARRAY DIMENSIONS C IARP(MSTE) - VECTOR OF ARRAY POINTERS C MSPA - SIZE OF PRIMARY MEMORY ARRAY C LARP - LAST USED ARRAY POINTER C NSTE - NUMBER OF STACK ENTRIES LOGICAL SEXE,SEXF INTEGER SDAT C SEXE - FUNCTION TO CHECK EXISTENCE OF ENTRY NAME IN STACK C SEXF - FUNCTION TO CHECK EXISTENCE OF FILE IN CURRENT DIRECTORY C SDAT - INTERNAL FUNCTION TO DETERMINE NUMBER OF DATA AS REAL*8 C ERROR INDICATOR IE=0 C CHECK IF NAME EXIST IF(.NOT.SEXE(NAME,I))THEN IE=1 GOTO 90 ENDIF C ASSIGN PARAMETERS TYPE=ARTY(I) IDIM=IARD(I) IPTA=IARP(I) 90 IF(IE.NE.0)THEN C ERROR MESAGES IF(MOD(IE,2).GE.1) & WRITE(*,*)'* SGET * ',NAME,' : ENTRY NOT EXIST' CALL SINF STOP ENDIF RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE SINF C PRINT INFORMATION ABOUT STACK ENTRIES C INPUT & OUTPUT: NONE C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! C *** SMS ICLUDE FILE *** PARAMETER(MSTE=500,IOSF=9,LREC=100) C MSTE - MAXIMUM NUMBER OF STACK ENTRIES C IOSF - INPUT-OUTPUT UNIT FOR STACK-FILE OPERATIONS C LREC - RECORD LENGTH FOR STACK-FILE OPERATIONS CHARACTER ARNA(MSTE)*6,ARTY(MSTE)*2 INTEGER IARD(MSTE),IARP(MSTE) COMMON /CSTACK/ARNA,ARTY,IARD,IARP,MSPA,LARP,NSTE C ARNA(MSTE) - VECTOR OF ARRAY NAMES C ARTY(MSTE) - VECTOR OF ARRAY TYPES C IARD(MSTE) - VECTOR OF ARRAY DIMENSIONS C IARP(MSTE) - VECTOR OF ARRAY POINTERS C MSPA - SIZE OF PRIMARY MEMORY ARRAY C LARP - LAST USED ARRAY POINTER C NSTE - NUMBER OF STACK ENTRIES LOGICAL SEXE,SEXF INTEGER SDAT C SEXE - FUNCTION TO CHECK EXISTENCE OF ENTRY NAME IN STACK C SEXF - FUNCTION TO CHECK EXISTENCE OF FILE IN CURRENT DIRECTORY C SDAT - INTERNAL FUNCTION TO DETERMINE NUMBER OF DATA AS REAL*8 WRITE(*,1) 1 FORMAT(/8X,'** STACK INFORMATION **'/ & ' ENTRY NAME TYPE SIZE POINTER'/) DO I=1,NSTE WRITE(*,2)I,ARNA(I),ARTY(I),IARD(I),IARP(I) 2 FORMAT(I6,' >',A6,'< ',A2,2I10) ENDDO WRITE(*,3)MSPA-LARP,LARP+1 3 FORMAT(' NEXT MAX R8',2I10) RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE SINI(ISPA) C INITIALIZE STACK C INPUT: C ISPA - DECLARED SIZE OF PRIMARY MEMORY ARRAY C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! C *** SMS ICLUDE FILE *** PARAMETER(MSTE=500,IOSF=9,LREC=100) C MSTE - MAXIMUM NUMBER OF STACK ENTRIES C IOSF - INPUT-OUTPUT UNIT FOR STACK-FILE OPERATIONS C LREC - RECORD LENGTH FOR STACK-FILE OPERATIONS CHARACTER ARNA(MSTE)*6,ARTY(MSTE)*2 INTEGER IARD(MSTE),IARP(MSTE) COMMON /CSTACK/ARNA,ARTY,IARD,IARP,MSPA,LARP,NSTE C ARNA(MSTE) - VECTOR OF ARRAY NAMES C ARTY(MSTE) - VECTOR OF ARRAY TYPES C IARD(MSTE) - VECTOR OF ARRAY DIMENSIONS C IARP(MSTE) - VECTOR OF ARRAY POINTERS C MSPA - SIZE OF PRIMARY MEMORY ARRAY C LARP - LAST USED ARRAY POINTER C NSTE - NUMBER OF STACK ENTRIES LOGICAL SEXE,SEXF INTEGER SDAT C SEXE - FUNCTION TO CHECK EXISTENCE OF ENTRY NAME IN STACK C SEXF - FUNCTION TO CHECK EXISTENCE OF FILE IN CURRENT DIRECTORY C SDAT - INTERNAL FUNCTION TO DETERMINE NUMBER OF DATA AS REAL*8 MSPA=ISPA LARP=0 NSTE=0 RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE SINP(O, I NAME) C INPUT ARRAY OR SET OF ARRAYS FROM EXTERNAL FILE TO STACK C O(ISPA) - PRIMARY MEMORY ARRAY C ISPA - DECLARED SIZE OF PRIMARY MEMORY ARRAY C INPUT: C NAME - NAME OF ARRAY OR SET OF ARRAYS TO INPUT C FILE 'NAME.STA' C THIS SUBROUTINE CALLS SUBROUTINES SDEF AND SGET. C SOME ERRORS MAY BE DETECTED BY THOSE SUBROUTINES C AND THEN ERRORS APPEAR WITH THEIR NAMES. C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! REAL*8 O(*) CHARACTER*(*) NAME C *** SMS ICLUDE FILE *** PARAMETER(MSTE=500,IOSF=9,LREC=100) C MSTE - MAXIMUM NUMBER OF STACK ENTRIES C IOSF - INPUT-OUTPUT UNIT FOR STACK-FILE OPERATIONS C LREC - RECORD LENGTH FOR STACK-FILE OPERATIONS CHARACTER ARNA(MSTE)*6,ARTY(MSTE)*2 INTEGER IARD(MSTE),IARP(MSTE) COMMON /CSTACK/ARNA,ARTY,IARD,IARP,MSPA,LARP,NSTE C ARNA(MSTE) - VECTOR OF ARRAY NAMES C ARTY(MSTE) - VECTOR OF ARRAY TYPES C IARD(MSTE) - VECTOR OF ARRAY DIMENSIONS C IARP(MSTE) - VECTOR OF ARRAY POINTERS C MSPA - SIZE OF PRIMARY MEMORY ARRAY C LARP - LAST USED ARRAY POINTER C NSTE - NUMBER OF STACK ENTRIES LOGICAL SEXE,SEXF INTEGER SDAT C SEXE - FUNCTION TO CHECK EXISTENCE OF ENTRY NAME IN STACK C SEXF - FUNCTION TO CHECK EXISTENCE OF FILE IN CURRENT DIRECTORY C SDAT - INTERNAL FUNCTION TO DETERMINE NUMBER OF DATA AS REAL*8 CHARACTER NAM*6,TYPE*2,TYP*2 LOGICAL LEE C ERROR INDICATOR IE=0 C CHECK IF FILE EXIST NAM=NAME IF(.NOT.SEXF(NAM))THEN IE=1 GOTO 90 ENDIF C CHECK IF ENTRY EXIST LEE=SEXE(NAME,I) DO K=6,2,-1 IF(NAM(K:K).NE.' ')GOTO 10 ENDDO 10 OPEN(IOSF,FILE=NAM(1:K)//'.STA',FORM='UNFORMATTED') C READ FIRST ENTRY 20 READ(IOSF,END=80,ERR=70)NAM,TYPE,IDIM C CHECK IF FILE CONTAINS ARRAY OR SET OF ARRAYS IF(NAM.NE.NAME)THEN IF(LEE)THEN CALL SGET(NAME, TYP,IDI,IP) IF(TYP.NE.'N0')IE=IE+8 I=I+1 ELSE CALL SDEF(NAME,'N0',0, IP) ENDIF ENDIF C SET POINTERS 30 IF(LEE)THEN IF(I.LE.NSTE)THEN IF(NAM.NE.ARNA(I))THEN IE=IE+16 ENDIF ELSE IE=IE+32 ENDIF CALL SGET(NAM, TYP,IDI,IPF) IF(TYP.NE.TYPE)IE=IE+64 IF(IDI.LT.IDIM)IE=IE+128 I=I+1 ELSE CALL SDEF(NAM,TYPE,IDIM, IPF) ENDIF IPL=IPF+SDAT('SINP',NAME, TYPE,IDIM, IE)-1 IF(IE.EQ.0)THEN C READ DATA NREC=(IPL-IPF)/LREC DO IREC=1,NREC IPE=IPF+LREC READ(IOSF,END=80,ERR=70)(O(IP),IP=IPF,IPE-1) IPF=IPE ENDDO READ(IOSF,END=80,ERR=70)(O(IP),IP=IPF,IPL) C READ NEXT ENTRY READ(IOSF,END=99,ERR=70)NAM,TYPE,IDIM GOTO 30 ENDIF GOTO 90 70 IE=IE+2 GOTO 90 80 IE=IE+4 90 IF(IE.NE.0)THEN C ERROR MESAGES IF(MOD(IE,2).GE.1) & WRITE(*,*)'* SINP * ',NAME,' : FILE NOT EXIST' IF(MOD(IE,4).GE.2) & WRITE(*,*)'* SINP * ',NAME,' : ERROR DURING INPUT FROM FILE' IF(MOD(IE,8).GE.4) & WRITE(*,*)'* SINP * ',NAME,' : UNEXPECTED END OF FILE' IF(MOD(IE,16).GE.8) & WRITE(*,*)'* SINP * ',NAME,' : EXISTING ENTRY IS NOT SET OF ARRA &YS' IF(MOD(IE,32).GE.16) & WRITE(*,*)'* SINP * ',NAME,' : INCORRECT ORDER OF ARRAYS' IF(MOD(IE,64).GE.32) & WRITE(*,*)'* SINP * ',NAME,' : UNEXPECTED END OF STACK' IF(MOD(IE,128).GE.64) & WRITE(*,*)'* SINP * ',NAME,' : UNMATCHED TYPE ',TYPE,' WITH EXIS & TING ENTRY' IF(MOD(IE,256).GE.128) & WRITE(*,*)'* SINP * ',NAME,' : DIMENSION OF EXISTING ENTRY TOO S &MALL <',IDIM CALL SINF STOP ENDIF 99 CLOSE(IOSF) RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE SOUT(O, I NAME) C OUTPUT ARRAY OR SET OF ARRAYS FROM STACK TO EXTERNAL FILE C O(ISPA) - PRIMARY MEMORY ARRAY C ISPA - DECLARED SIZE OF PRIMARY MEMORY ARRAY C INPUT: C NAME - NAME OF ARRAY OR SET OF ARRAYS TO OUTPUT C OUTPUT: C FILE 'NAME.STA' C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! REAL*8 O(*) CHARACTER*(*) NAME C *** SMS ICLUDE FILE *** PARAMETER(MSTE=500,IOSF=9,LREC=100) C MSTE - MAXIMUM NUMBER OF STACK ENTRIES C IOSF - INPUT-OUTPUT UNIT FOR STACK-FILE OPERATIONS C LREC - RECORD LENGTH FOR STACK-FILE OPERATIONS CHARACTER ARNA(MSTE)*6,ARTY(MSTE)*2 INTEGER IARD(MSTE),IARP(MSTE) COMMON /CSTACK/ARNA,ARTY,IARD,IARP,MSPA,LARP,NSTE C ARNA(MSTE) - VECTOR OF ARRAY NAMES C ARTY(MSTE) - VECTOR OF ARRAY TYPES C IARD(MSTE) - VECTOR OF ARRAY DIMENSIONS C IARP(MSTE) - VECTOR OF ARRAY POINTERS C MSPA - SIZE OF PRIMARY MEMORY ARRAY C LARP - LAST USED ARRAY POINTER C NSTE - NUMBER OF STACK ENTRIES LOGICAL SEXE,SEXF INTEGER SDAT C SEXE - FUNCTION TO CHECK EXISTENCE OF ENTRY NAME IN STACK C SEXF - FUNCTION TO CHECK EXISTENCE OF FILE IN CURRENT DIRECTORY C SDAT - INTERNAL FUNCTION TO DETERMINE NUMBER OF DATA AS REAL*8 CHARACTER NAM*6 C ERROR INDICATOR IE=0 C CHECK IF NAME EXIST IF(.NOT.SEXE(NAME,I))THEN IE=1 GOTO 90 ENDIF NAM=ARNA(I) C CHECK TYPE IF(ARTY(I).EQ.'N0')THEN C FIND NEXT SET NAME DO J=I+1,NSTE IF(ARTY(J).EQ.'N0')GOTO 10 ENDDO 10 I=I+1 J=J-1 ELSE J=I ENDIF IF(J.GE.I)THEN C OUTPUT ALL ARRAYS DO K=6,2,-1 IF(NAM(K:K).NE.' ')GOTO 20 ENDDO 20 OPEN(IOSF,FILE=NAM(1:K)//'.STA',FORM='UNFORMATTED') DO I=I,J IPF=IARP(I) IPL=IPF+SDAT('SOUT',NAME ,ARTY(I),IARD(I), IE)-1 IF(IE.EQ.0)THEN WRITE(IOSF)ARNA(I),ARTY(I),IARD(I) NREC=(IPL-IPF)/LREC DO IREC=1,NREC IPE=IPF+LREC WRITE(IOSF)(O(IP),IP=IPF,IPE-1) IPF=IPE ENDDO WRITE(IOSF)(O(IP),IP=IPF,IPL) ELSE GOTO 90 ENDIF ENDDO ELSE IE=IE+2 ENDIF 90 IF(IE.NE.0)THEN C ERROR MESAGES IF(MOD(IE,2).GE.1) & WRITE(*,*)'* SOUT * ',NAME,' : ENTRY NOT EXIST' IF(MOD(IE,4).GE.2) & WRITE(*,*)'* SOUT * ',NAME,' : NOTHING TO OUTPUT' CALL SINF STOP ENDIF CLOSE(IOSF) RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE SPRF( I NAME) C PRINT CONTENTS OF FILE TO DEFAUT OUTPUT C INPUT: C NAME - NAME OF FILE TO PRINT C FILE 'NAME.STA' C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! CHARACTER*(*) NAME C *** SMS ICLUDE FILE *** PARAMETER(MSTE=500,IOSF=9,LREC=100) C MSTE - MAXIMUM NUMBER OF STACK ENTRIES C IOSF - INPUT-OUTPUT UNIT FOR STACK-FILE OPERATIONS C LREC - RECORD LENGTH FOR STACK-FILE OPERATIONS CHARACTER ARNA(MSTE)*6,ARTY(MSTE)*2 INTEGER IARD(MSTE),IARP(MSTE) COMMON /CSTACK/ARNA,ARTY,IARD,IARP,MSPA,LARP,NSTE C ARNA(MSTE) - VECTOR OF ARRAY NAMES C ARTY(MSTE) - VECTOR OF ARRAY TYPES C IARD(MSTE) - VECTOR OF ARRAY DIMENSIONS C IARP(MSTE) - VECTOR OF ARRAY POINTERS C MSPA - SIZE OF PRIMARY MEMORY ARRAY C LARP - LAST USED ARRAY POINTER C NSTE - NUMBER OF STACK ENTRIES LOGICAL SEXE,SEXF INTEGER SDAT C SEXE - FUNCTION TO CHECK EXISTENCE OF ENTRY NAME IN STACK C SEXF - FUNCTION TO CHECK EXISTENCE OF FILE IN CURRENT DIRECTORY C SDAT - INTERNAL FUNCTION TO DETERMINE NUMBER OF DATA AS REAL*8 CHARACTER NAM*6,TYPE*2,TYP*2 LOGICAL LEE REAL*8 R(LREC) C ERROR INDICATOR IE=0 C CHECK IF FILE EXIST NAM=NAME IF(.NOT.SEXF(NAM))THEN IE=1 GOTO 90 ENDIF DO K=6,2,-1 IF(NAM(K:K).NE.' ')GOTO 10 ENDDO 10 OPEN(IOSF,FILE=NAM(1:K)//'.STA',FORM='UNFORMATTED') WRITE(*,1)NAM 1 FORMAT(/3X,'** FILE : ',A6,' **') C READ FILE ENTRIES 20 READ(IOSF,END=99,ERR=70)NAM,TYPE,IDIM WRITE(*,2)NAM,TYPE,IDIM 2 FORMAT(/' NAME TYPE SIZE'/' >',A6,'< ',A2,I10/) IPL=SDAT('SPRF',NAME, TYPE,IDIM, IE) IF(IE.GT.0)GOTO 90 NREC=1+(IPL-1)/LREC IP=0 DO IREC=1,NREC IF(IREC.LT.NREC)THEN IL=LREC ELSE IL=IPL-(NREC-1)*LREC ENDIF READ(IOSF,END=80,ERR=70)(R(I),I=1,IL) DO I=1,IL C PRINT CORRECT DATA IP=IP+1 IF(TYPE.EQ.'R8')THEN CALL SFR8(R(I),IP) ELSE IF(TYPE.EQ.'R4')THEN CALL SFR4(R(I),IP) ELSE IF(TYPE.EQ.'I4')THEN CALL SFI4(R(I),IP) ELSE IF(TYPE.EQ.'I2')THEN CALL SFI2(R(I),IP) ENDIF ENDDO ENDDO GOTO 20 70 IE=IE+2 GOTO 90 80 IE=IE+4 90 IF(IE.NE.0)THEN C ERROR MESAGES IF(MOD(IE,2).GE.1) & WRITE(*,*)'* SPRF * ',NAME,' : FILE NOT EXIST' IF(MOD(IE,4).GE.2) & WRITE(*,*)'* SPRF * ',NAME,' : ERROR DURING INPUT FROM FILE' IF(MOD(IE,8).GE.4) & WRITE(*,*)'* SPRF * ',NAME,' : UNEXPECTED END OF FILE' CALL SINF STOP ENDIF 99 CLOSE(IOSF) RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE SFR8(A,N) REAL*8 A WRITE(*,*)N,':',A RETURN END SUBROUTINE SFR4(A,N) REAL*4 A(2) DO I=1,2 WRITE(*,*)2*(N-1)+I,':',A(I) ENDDO RETURN END SUBROUTINE SFI4(A,N) INTEGER*4 A(2) DO I=1,2 WRITE(*,*)2*(N-1)+I,':',A(I) ENDDO RETURN END SUBROUTINE SFI2(A,N) INTEGER*2 A(4) DO I=1,4 WRITE(*,*)4*(N-1)+I,':',A(I) ENDDO RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE SPRI(O, I NAME) C PRINT CONTENTS OF STACK ENTRY TO DEFAUT OUTPUT C O(ISPA) - PRIMARY MEMORY ARRAY C ISPA - DECLARED SIZE OF PRIMARY MEMORY ARRAY C INPUT: C NAME - NAME OF STACK ENTRY C THIS SUBROUTINE CALLS SUBROUTINE SGET. C SOME ERRORS MAY BE DETECTED BY THAT SUBROUTINE C AND THEN ERRORS APPEAR WITH ITS NAME. C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! REAL*8 O(*) CHARACTER*(*) NAME C *** SMS ICLUDE FILE *** PARAMETER(MSTE=500,IOSF=9,LREC=100) C MSTE - MAXIMUM NUMBER OF STACK ENTRIES C IOSF - INPUT-OUTPUT UNIT FOR STACK-FILE OPERATIONS C LREC - RECORD LENGTH FOR STACK-FILE OPERATIONS CHARACTER ARNA(MSTE)*6,ARTY(MSTE)*2 INTEGER IARD(MSTE),IARP(MSTE) COMMON /CSTACK/ARNA,ARTY,IARD,IARP,MSPA,LARP,NSTE C ARNA(MSTE) - VECTOR OF ARRAY NAMES C ARTY(MSTE) - VECTOR OF ARRAY TYPES C IARD(MSTE) - VECTOR OF ARRAY DIMENSIONS C IARP(MSTE) - VECTOR OF ARRAY POINTERS C MSPA - SIZE OF PRIMARY MEMORY ARRAY C LARP - LAST USED ARRAY POINTER C NSTE - NUMBER OF STACK ENTRIES LOGICAL SEXE,SEXF INTEGER SDAT C SEXE - FUNCTION TO CHECK EXISTENCE OF ENTRY NAME IN STACK C SEXF - FUNCTION TO CHECK EXISTENCE OF FILE IN CURRENT DIRECTORY C SDAT - INTERNAL FUNCTION TO DETERMINE NUMBER OF DATA AS REAL*8 CHARACTER NAM*6,TYPE*2 NAM=NAME CALL SGET(NAM, TYPE,IDIM,IP) WRITE(*,1)NAM,TYPE,IDIM 1 FORMAT(/3X,'** ENTRY CONTENTS **'/' NAME TYPE SIZE'/ & ' >',A6,'< ',A2,I10/) C PRINT CORRECT DATA IF(TYPE.EQ.'R8')THEN CALL SWR8(O(IP),IDIM) ELSE IF(TYPE.EQ.'R4')THEN CALL SWR4(O(IP),IDIM) ELSE IF(TYPE.EQ.'I4')THEN CALL SWI4(O(IP),IDIM) ELSE IF(TYPE.EQ.'I2')THEN CALL SWI2(O(IP),IDIM) ENDIF RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE SWR8(A,N) REAL*8 A(*) DO I=1,N WRITE(*,*)I,':',A(I) ENDDO RETURN END SUBROUTINE SWR4(A,N) REAL*4 A(*) DO I=1,N WRITE(*,*)I,':',A(I) ENDDO RETURN END SUBROUTINE SWI4(A,N) INTEGER*4 A(*) DO I=1,N WRITE(*,*)I,':',A(I) ENDDO RETURN END SUBROUTINE SWI2(A,N) INTEGER*2 A(*) DO I=1,N WRITE(*,*)I,':',A(I) ENDDO RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE SREM(O, I NAME) C REMOVE SET OF ARRAYS BY PUSHING STACK DOWN C !!! CAUTION !!! C DO NOT USE THIS SUBROUTINE UNLESS NECESSARY. C PRIMARY MEMORY ARRAY IS MODIFIED. C POINTERS OF ARRAYS ABOVE REMOVED SET CHANGE. C O(ISPA) - PRIMARY MEMORY ARRAY C ISPA - DECLARED SIZE OF PRIMARY MEMORY ARRAY C INPUT: C NAME - NAME OF SET OF ARRAYS TO BE REMOVED C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! REAL*8 O(*) CHARACTER*(*) NAME C *** SMS ICLUDE FILE *** PARAMETER(MSTE=500,IOSF=9,LREC=100) C MSTE - MAXIMUM NUMBER OF STACK ENTRIES C IOSF - INPUT-OUTPUT UNIT FOR STACK-FILE OPERATIONS C LREC - RECORD LENGTH FOR STACK-FILE OPERATIONS CHARACTER ARNA(MSTE)*6,ARTY(MSTE)*2 INTEGER IARD(MSTE),IARP(MSTE) COMMON /CSTACK/ARNA,ARTY,IARD,IARP,MSPA,LARP,NSTE C ARNA(MSTE) - VECTOR OF ARRAY NAMES C ARTY(MSTE) - VECTOR OF ARRAY TYPES C IARD(MSTE) - VECTOR OF ARRAY DIMENSIONS C IARP(MSTE) - VECTOR OF ARRAY POINTERS C MSPA - SIZE OF PRIMARY MEMORY ARRAY C LARP - LAST USED ARRAY POINTER C NSTE - NUMBER OF STACK ENTRIES LOGICAL SEXE,SEXF INTEGER SDAT C SEXE - FUNCTION TO CHECK EXISTENCE OF ENTRY NAME IN STACK C SEXF - FUNCTION TO CHECK EXISTENCE OF FILE IN CURRENT DIRECTORY C SDAT - INTERNAL FUNCTION TO DETERMINE NUMBER OF DATA AS REAL*8 C ERROR INDICATOR IE=0 C CHECK IF NAME EXIST IF(.NOT.SEXE(NAME,I))THEN IE=1 GOTO 90 ENDIF C CHECK TYPE IF(ARTY(I).EQ.'N0')THEN C FIND NEXT SET NAME DO J=I+1,NSTE IF(ARTY(J).EQ.'N0')GOTO 10 ENDDO C USE SIMPLE DELETE NSTE=I-1 LARP=IARP(I)-1 GOTO 90 C PERFORM STACK PUSH DOWN 10 IPI=IARP(I) IPJ=IARP(J) IPD=IPJ-IPI DO J=J,NSTE ARNA(I)=ARNA(J) ARTY(I)=ARTY(J) IARD(I)=IARD(J) IARP(I)=IARP(J)-IPD I=I+1 ENDDO NSTE=I-1 C PERFORM PRIMARY MEMORY ARRAY PUSH DOWN DO IPJ=IPJ,LARP O(IPI)=O(IPJ) IPI=IPI+1 ENDDO LARP=LARP-IPD ELSE IE=IE+2 ENDIF 90 IF(IE.NE.0)THEN C ERROR MESAGES IF(MOD(IE,2).GE.1) & WRITE(*,*)'* SREM * ',NAME,' : ENTRY NOT EXIST' IF(IE.GE.2) & WRITE(*,*)'* SREM * ',NAME,' : ENTRY IS NOT SET OF ARRAYS' CALL SINF STOP ENDIF RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE SREN( I NOLD,NNEW,TYPE,IDIM, O IPTA) C RENAME ENTRY IN STACK C CAUTION : C NEW ENTRY MUST REQUIRE NO MORE SPACE THAN OLD ONE C INPUT: C NOLD - OLD NAME OF STACK ENTRY C NNEW - NEW NAME OF STACK ENTRY (ARRAY OR SET OF ARRAYS) C FIRST 6 CHARACTERS SIGNIFICANT C TYPE - TYPE OF NEW ARRAY C = 'R8' FOR REAL*8 = DOUBLE PRECISION C = 'R4' = 'R' FOR REAL*4 = REAL C = 'I4' = 'I' FOR INTEGER*4 = INTEGER C = 'I2' FOR INTEGER*2 C = 'N0' = 'N' FOR NAME OF SET OF ARRAYS C IDIM - DIMENSION OF NEW ARRAY C OUTPUT: C IPTA - POINTER TO ARRAY C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! CHARACTER*(*) NOLD,NNEW,TYPE C *** SMS ICLUDE FILE *** PARAMETER(MSTE=500,IOSF=9,LREC=100) C MSTE - MAXIMUM NUMBER OF STACK ENTRIES C IOSF - INPUT-OUTPUT UNIT FOR STACK-FILE OPERATIONS C LREC - RECORD LENGTH FOR STACK-FILE OPERATIONS CHARACTER ARNA(MSTE)*6,ARTY(MSTE)*2 INTEGER IARD(MSTE),IARP(MSTE) COMMON /CSTACK/ARNA,ARTY,IARD,IARP,MSPA,LARP,NSTE C ARNA(MSTE) - VECTOR OF ARRAY NAMES C ARTY(MSTE) - VECTOR OF ARRAY TYPES C IARD(MSTE) - VECTOR OF ARRAY DIMENSIONS C IARP(MSTE) - VECTOR OF ARRAY POINTERS C MSPA - SIZE OF PRIMARY MEMORY ARRAY C LARP - LAST USED ARRAY POINTER C NSTE - NUMBER OF STACK ENTRIES LOGICAL SEXE,SEXF INTEGER SDAT C SEXE - FUNCTION TO CHECK EXISTENCE OF ENTRY NAME IN STACK C SEXF - FUNCTION TO CHECK EXISTENCE OF FILE IN CURRENT DIRECTORY C SDAT - INTERNAL FUNCTION TO DETERMINE NUMBER OF DATA AS REAL*8 CHARACTER TYP*2,TYPO*2 C ERROR INDICATOR IE=0 C CHECK IF OLD ENTRY EXIST IF(.NOT.SEXE(NOLD,I))IE=1 C CHECK IF NEW ENTRY NOT EXIST IF(SEXE(NNEW,J).AND.NNEW.NE.'DELETE'.AND.NNEW.NE.NOLD)IE=IE+2 C CHECK ARRAY TYPE TYP=TYPE IDAN=SDAT('SREN',NNEW, TYP,IDIM, IE) C ARRAY DIMENSION IF(IE.NE.0)GOTO 90 TYPO=ARTY(I) IDIO=IARD(I) IDAO=SDAT('SREN',NOLD, TYPO,IDIO, IE) IF(IDAN.GT.IDAO)IE=IE+4 90 IF(IE.EQ.0)THEN C RENAME ARRAY ARNA(I)=NNEW ARTY(I)=TYP IARD(I)=IDIM IPTA=IARP(I) ELSE C ERROR MESAGES IF(MOD(IE,2).GE.1) & WRITE(*,*)'* SREN * ',NOLD,' : ENTRY NOT EXIST' IF(MOD(IE,4).GE.2) & WRITE(*,*)'* SREN * ',NNEW,' : DUPLICATE ENTRY NAME' IF(MOD(IE,8).GE.4) & WRITE(*,*)'* SREN * ',NNEW,' : ARRAY TOO BIG. MAXIMUM ARRAY SIZE & (REAL*8) =',IDAO CALL SINF STOP ENDIF RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! SUBROUTINE SZER(O, I NAME) C ZERO STACK ARRAY C O(ISPA) - PRIMARY MEMORY ARRAY C ISPA - DECLARED SIZE OF PRIMARY MEMORY ARRAY C INPUT: C NAME - NAME OF ARRAY TO ZERO C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! REAL*8 O(*) CHARACTER*(*) NAME C *** SMS ICLUDE FILE *** PARAMETER(MSTE=500,IOSF=9,LREC=100) C MSTE - MAXIMUM NUMBER OF STACK ENTRIES C IOSF - INPUT-OUTPUT UNIT FOR STACK-FILE OPERATIONS C LREC - RECORD LENGTH FOR STACK-FILE OPERATIONS CHARACTER ARNA(MSTE)*6,ARTY(MSTE)*2 INTEGER IARD(MSTE),IARP(MSTE) COMMON /CSTACK/ARNA,ARTY,IARD,IARP,MSPA,LARP,NSTE C ARNA(MSTE) - VECTOR OF ARRAY NAMES C ARTY(MSTE) - VECTOR OF ARRAY TYPES C IARD(MSTE) - VECTOR OF ARRAY DIMENSIONS C IARP(MSTE) - VECTOR OF ARRAY POINTERS C MSPA - SIZE OF PRIMARY MEMORY ARRAY C LARP - LAST USED ARRAY POINTER C NSTE - NUMBER OF STACK ENTRIES LOGICAL SEXE,SEXF INTEGER SDAT C SEXE - FUNCTION TO CHECK EXISTENCE OF ENTRY NAME IN STACK C SEXF - FUNCTION TO CHECK EXISTENCE OF FILE IN CURRENT DIRECTORY C SDAT - INTERNAL FUNCTION TO DETERMINE NUMBER OF DATA AS REAL*8 C ERROR INDICATOR IE=0 C CHECK IF NAME EXIST IF(.NOT.SEXE(NAME,I))THEN IE=1 GOTO 90 ENDIF C CHECK TYPE IF(ARTY(I).EQ.'N0')IE=IE+2 90 IF(IE.EQ.0)THEN IPF=IARP(I) IPL=IPF+SDAT('SZER',NAME ,ARTY(I),IARD(I), IE)-1 DO IP=IPF,IPL O(IP)=0D0 ENDDO ELSE C ERROR MESAGES IF(MOD(IE,2).GE.1) & WRITE(*,*)'* SZER * ',NAME,' : ENTRY NOT EXIST' IF(MOD(IE,4).GE.2) & WRITE(*,*)'* SZER * ',NAME,' : ENTRY IS NOT ARRAY' CALL SINF STOP ENDIF RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! FUNCTION SDAT(NACS,NAME, TYPE,IDIM, IERR) C INTERNAL FUNCTION TO DETERMINE NUMBER OF DATA AS REAL*8 C INPUT: C NACS - NAME OF CALLING SUBROUTINE C NAME - NAME OF ENTRY OR FILE C IDIM - DIMENSION OF ARRAY C INPUT & OUTPUT: C TYPE - TYPE OF ARRAY C IERR - ERROR INDICATOR C OUTPUT: C SDAT - NUMBER OF DATA AS REAL*8 C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! CHARACTER NACS*4,NAME*(*),TYPE*2 C *** SMS ICLUDE FILE *** PARAMETER(MSTE=500,IOSF=9,LREC=100) C MSTE - MAXIMUM NUMBER OF STACK ENTRIES C IOSF - INPUT-OUTPUT UNIT FOR STACK-FILE OPERATIONS C LREC - RECORD LENGTH FOR STACK-FILE OPERATIONS CHARACTER ARNA(MSTE)*6,ARTY(MSTE)*2 INTEGER IARD(MSTE),IARP(MSTE) COMMON /CSTACK/ARNA,ARTY,IARD,IARP,MSPA,LARP,NSTE C ARNA(MSTE) - VECTOR OF ARRAY NAMES C ARTY(MSTE) - VECTOR OF ARRAY TYPES C IARD(MSTE) - VECTOR OF ARRAY DIMENSIONS C IARP(MSTE) - VECTOR OF ARRAY POINTERS C MSPA - SIZE OF PRIMARY MEMORY ARRAY C LARP - LAST USED ARRAY POINTER C NSTE - NUMBER OF STACK ENTRIES LOGICAL SEXE,SEXF INTEGER SDAT C SEXE - FUNCTION TO CHECK EXISTENCE OF ENTRY NAME IN STACK C SEXF - FUNCTION TO CHECK EXISTENCE OF FILE IN CURRENT DIRECTORY C SDAT - INTERNAL FUNCTION TO DETERMINE NUMBER OF DATA AS REAL*8 IF(TYPE.EQ.'R8'.OR.TYPE.EQ.'r8')THEN TYPE='R8' N=1 ELSE IF(TYPE.EQ.'R4'.OR.TYPE.EQ.'r4'.OR. & TYPE.EQ.'R '.OR.TYPE.EQ.'r ')THEN TYPE='R4' N=2 ELSE IF(TYPE.EQ.'I4'.OR.TYPE.EQ.'i4'.OR. & TYPE.EQ.'I '.OR.TYPE.EQ.'i ')THEN TYPE='I4' N=2 ELSE IF(TYPE.EQ.'I2'.OR.TYPE.EQ.'i2')THEN TYPE='I2' N=4 ELSE IF(TYPE.EQ.'N0'.OR.TYPE.EQ.'n0'.OR. & TYPE.EQ.'N '.OR.TYPE.EQ.'n ')THEN TYPE='N0' N=0 ELSE IERR=IERR+1024 ENDIF IF(IDIM.LT.0)IERR=IERR+2048 SDAT=0 IF(IERR.EQ.0)THEN IF(N.GT.0)SDAT=1+(IDIM-1)/N ELSE C ERROR MESAGES IF(MOD(IERR,2048).GE.1024) & WRITE(*,*)'* ',NACS,' * ',NAME,' : INCORRECT TYPE ',TYPE IF(MOD(IERR,4096).GE.2048) & WRITE(*,*)'* ',NACS,' * ',NAME,' : NEGATIVE DIMENSION =',IDIM ENDIF RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! FUNCTION SEXE( I NAME, O IENT) C LOGICAL FUNCTION TO CHECK EXISTENCE OF ENTRY NAME IN STACK C INPUT: C NAME - NAME OF ENTRY (ARRAY OR SET OF ARRAYS) C OUTPUT: C SEXE = .TRUE. IF ENTRY EXIST C = .FALSE. IF NOT C IENT - NUMBER OF STACK ENTRY C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! CHARACTER*(*) NAME C *** SMS ICLUDE FILE *** PARAMETER(MSTE=500,IOSF=9,LREC=100) C MSTE - MAXIMUM NUMBER OF STACK ENTRIES C IOSF - INPUT-OUTPUT UNIT FOR STACK-FILE OPERATIONS C LREC - RECORD LENGTH FOR STACK-FILE OPERATIONS CHARACTER ARNA(MSTE)*6,ARTY(MSTE)*2 INTEGER IARD(MSTE),IARP(MSTE) COMMON /CSTACK/ARNA,ARTY,IARD,IARP,MSPA,LARP,NSTE C ARNA(MSTE) - VECTOR OF ARRAY NAMES C ARTY(MSTE) - VECTOR OF ARRAY TYPES C IARD(MSTE) - VECTOR OF ARRAY DIMENSIONS C IARP(MSTE) - VECTOR OF ARRAY POINTERS C MSPA - SIZE OF PRIMARY MEMORY ARRAY C LARP - LAST USED ARRAY POINTER C NSTE - NUMBER OF STACK ENTRIES LOGICAL SEXE,SEXF INTEGER SDAT C SEXE - FUNCTION TO CHECK EXISTENCE OF ENTRY NAME IN STACK C SEXF - FUNCTION TO CHECK EXISTENCE OF FILE IN CURRENT DIRECTORY C SDAT - INTERNAL FUNCTION TO DETERMINE NUMBER OF DATA AS REAL*8 DO IENT=NSTE,1,-1 IF(NAME.EQ.ARNA(IENT))THEN SEXE=.TRUE. RETURN ENDIF ENDDO SEXE=.FALSE. RETURN END C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! FUNCTION SEXF( I NAME) C LOGICAL FUNCTION TO CHECK EXISTENCE OF FILE WITH EXTENSION C '.STA' IN CURRENT DIRECTORY C INPUT: C NAME - NAME OF FILE WITHOUT EXTENSION '.STA' C OUTPUT: C SEXF = .TRUE. IF FILE EXIST C = .FALSE. IF NOT C....&...1....:....2....:....3....:....4....:....5....:....6....:....7.! CHARACTER*(*) NAME LOGICAL SEXF CHARACTER NAM*6 NAM=NAME DO K=6,2,-1 IF(NAM(K:K).NE.' ')GOTO 10 ENDDO 10 INQUIRE(FILE=NAM(1:K)//'.STA',EXIST=SEXF) RETURN END