PROGRAM VPLX PARAMETER (MSIZED=1000000) C ! Size of double precision array PARAMETER (MAXFMT=20) PARAMETER (MAXSUB=500,MAXSBL=2000,MAXSNL=24) PARAMETER (MAXSBC=6000) PARAMETER (MAXALT=5) INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 INTEGER U5ALT(MAXALT),U5ASTT(MAXALT) COMMON /A5BLCK/U5ALT,U5ASTT CHARACTER*256 CARD COMMON /CRDBLK/CARD C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) CHARACTER*80 CARDIN CHARACTER*(MAXSNL) SUBNAM(MAXSUB) CHARACTER*12 SUBCSV(MAXSBC) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI, . NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL), . U5LCSW COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI, . NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW C CHARACTER*160 FNERRR,FNWARN COMMON /IOBLK3/FNERRR,FNWARN C INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW, . OSCODE,NEWFNM COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE, . ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM CHARACTER*256 CARDWK,CARDSV,CARDIM COMMON /CMBLK2/CARDWK,CARDSV,CARDIM COMMON /CINBLK/CARDIN,SUBNAM,SUBCSV LOGICAL REFRSH EXTERNAL REFRSH C LOGICAL DONE,LTEMP INTEGER ITYPE(3),IFLAG(3) DATA ITYPE/1,0,0/ C 102 FORMAT(30X,'VPLX - Version 1998.09A') C 200 FORMAT(' OUT OF ORDER OR INCORRECT FORMAT') 201 FORMAT(' MISSING NAME') 202 FORMAT(/,'***** End of CREATE specification/beginning of executio' .,'n') 203 FORMAT(/,'***** End of TRANSFORM specification/beginning of execu' .,'tion') 204 FORMAT(/,'***** End of REWEIGHT specification/beginning of execut' .,'ion') 205 FORMAT(/,'***** End of specification/beginning of execution') C LSTVPL(1:1)=' ' C C Initializations related to substitutions C DO 1 I=81,256 CARDIM(I:I)=' ' 1 CONTINUE ITYPE(1)=1 ITYPE(2)=0 ITYPE(3)=0 NSUB=0 NSUBLM=0 NSUBCM=0 ISUBCN=0 ILNCNT=0 ICHCNT=0 ISSLVL=0 U5LCSW=1 C C Initializations related to standard input and output C U5=5 U6=6 U5END=0 U5ECHO=1 U5ALT(1)=U5 DO 2 I=2,MAXALT U5ALT(I)=0 2 CONTINUE C C Initializations related to tracking highest use of DX C LASTPD=0 SIZED=MSIZED C C Initialization of error code C IMERR1 - used to hold error or warning code C IMERR2 - indicator for position on record C IMERR3 - flag for verbose warning messages C IMERR1=0 IMERR2=0 IMERR3=0 C C Identifier for OS, used in some cases for parsing of file names C NEWFNM=0 C ! =1, flag to signal special rules to stop processing C ! file names under unix with / following first "." C OSCODE=1 C ! PC DOS/WIN32 version OSCODE=2 C ! UNIX C OSCODE=3 ! VMS/VAX C C Initialization of error and warning file information C DO 3 I=1,160 FNERRR(I:I)=' ' FNWARN(I:I)=' ' 3 CONTINUE C C Default error and warning files for PC DOS version C C FNERRR(1:20)='C:\VPLX\VPLERROR.TXT' C FNWARN(1:20)='C:\VPLX\VPLWARNG.TXT' C C Default error and warning file for VAX ISAR cluster at Census Bureau C C FNERRR(1:34)='DIR_DISK2:[R_FAY.VPLX]VPLERROR.TXT' C FNWARN(1:34)='DIR_DISK2:[R_FAY.VPLX]VPLWARNG.TXT' C C Default error and warning file for MCVX09 cluster at Census Bureau C C FNERRR(1:25)='STSD_1:[VPLX]VPLERROR.TXT' C FNWARN(1:25)='STSD_1:[VPLX]VPLWARNG.TXT' C C Default error and warning file for SUN OS dsmde1 (UNIX) at Census C Bureau C FNERRR(1:22)='/opt/vplx/vplerror.txt' C FNWARN(1:22)='/opt/vplx/vplwarng.txt' C C CMPFLG=0 WRITE(U6,102) 5 CONTINUE LTEMP=REFRSH(IPOS) 10 CONTINUE IF(U5END.EQ.1) THEN CALL VPSTOP END IF CALL RRESET NXPTI=1 NXPTD=1 CALL KYFND2(IGROUP,IKEY,IPOS) IF(IKEY.EQ.-1) THEN GO TO 10 ELSE IF(IGROUP.EQ.0) THEN IF(IKEY.EQ.1) THEN C ! CREATE CALL SETUP1 CALL HADAMG CALL SETUP2 CALL CREAT1 IF(U5ECHO.EQ.1)WRITE(U6,202) CALL CREAT2(DONE) IF(.NOT.DONE) THEN CALL CREAT3(DONE) IF(.NOT.DONE) THEN CALL CREAT4 END IF END IF ELSE IF(IKEY.EQ.2) THEN C ! CONTENTS CALL CONTNT ELSE IF(IKEY.EQ.3) THEN C ! DISPLAY CALL DSETUP(DONE) IF(.NOT.DONE) THEN C ! for old syntax CALL DCREAT END IF ELSE IF(IKEY.EQ.4) THEN C ! TRANSFORM CALL TSET1 IF(U5ECHO.EQ.1)WRITE(U6,203) CALL TCREA1 CALL TCREA2 ELSE IF(IKEY.EQ.5.OR.IKEY.EQ.11) THEN C ! DELETE, FREE CALL CRDPRN(3) IF(IKEY.EQ.11) THEN CALL FNREAD(IPOS,ITYPE,IFLAG,6,IPOSSC) ELSE CALL FNREAD(IPOS,ITYPE,IFLAG,5,IPOSSC) END IF IF(IMERR1.GT.0) THEN CALL FSTOP END IF IF(IFLAG(1).EQ.0) THEN IF(U5ECHO.GT.0)WRITE(U6,201) END IF IF(IPOSSC.GT.0) THEN U5LCSW=1 END IF GO TO 5 ELSE IF(IKEY.EQ.6) THEN C ! REWEIGHT CALL SETUP1 IF(U5ECHO.EQ.1)WRITE(U6,204) CALL HADAMG CALL RWGHT2 ELSE IF(IKEY.EQ.7) THEN C ! IMPORT CALL IMPORT ELSE IF(IKEY.EQ.8) THEN C ! EXPORT CALL EXPORT ELSE IF(IKEY.EQ.9) THEN C ! REPGEN, CONVERT CALL SETUP1 IF(U5ECHO.EQ.1)WRITE(U6,205) CALL HADAMG CALL REPGEN ELSE IF(IKEY.EQ.10) THEN C ! JACKKNIFE CALL JACKKN ELSE IF(IKEY.EQ.12.OR. C ! MERGE . IKEY.EQ.14) THEN C ! EXTRACT CALL VMERGE ELSE IF(IKEY.EQ.13) THEN C ! RUN CALL CRDPRN(3) U5LCSW=1 C ! RUN is the only "step" GO TO 5 C ! without specified files END IF ELSE WRITE(U6,200) CALL CRDPRN(2) CALL FESTOP(160330) END IF IF(U5.GE.13.AND.U5.LE.17) THEN C C If have been reading from a scratch file, the following restores the C active input file, if any. Note that REFRSH is used to read from the C scratch file until an end of file is encountered, then one additional C call is made to restore the previous input. C IF(U5ESAV.EQ.0) THEN L=U5ECHO U5ECHO=0 90 CONTINUE IF(U5END.EQ.0) THEN LTEMP=REFRSH(IPT) GO TO 90 END IF LTEMP=REFRSH(IPT) U5ECHO=L ELSE U5END=1 END IF END IF GO TO 10 END C BLOCK DATA KEYDEF PARAMETER (NKEY=200) CHARACTER*12 KEYWRD(NKEY) COMMON /KEYBLK/KEYWRD C C List of keywords. C Note that LOGICAL FUNCTION REFRSH is now written to interpret any C keyword beginning with 'COMM' as 'COMMENT' C DATA (KEYWRD(I),I=1,40)/ . 'SCRATCH1 ','SCRATCH2 ','SCRATCH3 ','SCRATCH4 ', . 'SCRATCH5 ','CLASS ','CATEGORICAL ','CAT ', . 'SELECT ','MISSING ','BY ','REPLICATION ', . 'REP ','UNWEIGHTED ','INPUT ','FORMAT ', . 'COMPUTE ','DROP ','KEEP ','LABEL ', . 'LEVEL ','RENAME ','REPLICATE ','WEIGHT ', . 'STRATUM ','CLUSTER ','SECOND ','COEFFICIENT ', . 'FPC1 ','FPC2 ','CROSS ','IDCHANGE ', . 'COPY ','BLOCK ','CREATE ','OPTION ', . 'CONTENT ','DISPLAY ','CONTRAST ','LIST '/ DATA (KEYWRD(I),I=41,80)/ . 'COV ','COVARIANCE ','CORR ','CORRELATION ', . 'T ','TEST ','TABLE ','COMMENT ', . 'TRANSFORM ','OLD ','MODIFY ','CONSTANT ', . 'DERIVED ','REAL ','COUNT ','CROSSED ', . 'REMOVE ','USER1 ','USER2 ','USER3 ', . 'USER4 ','USER5 ','USER6 ','USER7 ', . 'USER8 ','USER9 ','USER10 ','REFORMAT ', . 'ADD ','SUBTRACT ','MULTIPLY ','DIVIDE ', . 'POWER ','RECIPROCAL ','LOG ','PAIRED ', . 'RMULTIPLY ','SAVEFULL ','GLUE ','RPRINT '/ DATA (KEYWRD(I),I=81,120)/ . 'REPPRINT ','REPWRITE ','REPREAD ','BINARYWRITE ', . 'BINARYREAD ','COLLAPSE ','STRING ','LONGSTRING ', . 'INTEGER ','SLICELENGTH ','SLICE_LENGTH','BOOLEAN ', . 'AND ','OR ','NOT ','DEFAULT ', . 'LINK ','LINK_MISSING','DELETE ','ADD_MS ', . 'SUBTRACT_MS ','MULTIPLY_MS ','DIVIDE_MS ','IF ', . 'ELSE ','ELSEIF ','END ','ENDIF ', . 'REWEIGHT ','OUTFORMAT ','OUTPUT ','MODIFYREPF ', . 'RETAIN ','IMPORT ','EXPORT ','READFULL ', . 'REPGEN ','HADAMARD ','CPSCOL ','SIPPCOL '/ DATA (KEYWRD(I),I=121,160)/ . 'RGENERATE ','MODEL ','PINVERT ','PSOLVE ', . 'PMULTIPLYM ','PMULTIPLYP ','PSYMMULTM ','PSYMMULTP ', . 'PPACK ','PUNPACK ','PTRACE ','PDIAG ', . 'PEIGENVECTOR','PEIGENVALUE ','PSQRT ','MINVERT ', . 'MSOLVE ','MMULTIPLY ','MMULTIPLYM ','MSYMMULT ', . 'MSYMMULTM ','MTRACE ','MDIAG ','PBMULTIPLYM ', . 'PBMULTIPLYP ','PBSYMMULTM ','PBSYMMULTP ','PBDIAG ', . 'CPSCHILDCOL ','CPSNICOL ','GRIDSEARCH ','RAO_SHAO ', . 'NEWCPSCHCOL ','NPSCHILDCOL ','OLDCPSCHCOL ','PRINT ', . 'ON ','C ','JACKKNIFE ','FREE '/ DATA (KEYWRD(I),I=161,200)/ . 'XMEDIAN ','SIPPC_ROWCOL','SIPPC_CLMCOL','SIPPC_RAKE ', . 'VPLXAPPEND ','VPLX_APPEND ','VPLX ','ZZZZZZZZZZZZ', . 'SIPPC_NICOL ','CPS_COMP_COL','CONVERT ','RUN ', . 'ZZZZZZZZZZZZ','ZZZZZZZZZZZZ','ZZZZZZZZZZZZ','ZZZZZZZZZZZZ', . 'ZZZZZZZZZZZZ','ZZZZZZZZZZZZ','ZZZZZZZZZZZZ','ZZZZZZZZZZZZ', . 'ZZZZZZZZZZZZ','ZZZZZZZZZZZZ','ZZZZZZZZZZZZ','ZZZZZZZZZZZZ', . 'ZZZZZZZZZZZZ','ZZZZZZZZZZZZ','ZZZZZZZZZZZZ','ZZZZZZZZZZZZ', . 'ZZZZZZZZZZZZ','ZZZZZZZZZZZZ','ZZZZZZZZZZZZ','ZZZZZZZZZZZZ', . 'ZZZZZZZZZZZZ','EXTRACT ','AS ','INCORPORATE ', . 'MERGE ','STEP ','STEPOPTION ','STEP_OPTION '/ END BLOCK DATA KEYDF2 C C Key word groups: C 0 - Step C 1 - Subroutine in TRANSFORM, shared with CREATE C 2 - Other use in TRANSFORM, shared with CREATE C 3 - Subroutine in TRANSFORM, general C 4 - Subroutine in TRANSFORM naming file C 5 - Subroutine in TRANSFORM, specialized to Census Bureau applications C 6 - Other use in TRANSFORM C 7 - CREATE only C 8 - Miscellaneous C 9 - synonyms C PARAMETER (NKEY0=14,NKEY1=19,NKEY2=16,NKEY3=45,NKEY4=6,NKEY5=12) PARAMETER (NKEY6=9,NKEY7=28,NKEY8=12,NKEY9=15) PARAMETER (NKEY1B=NKEY0+1,NKEY1E=NKEY0+NKEY1) PARAMETER (NKEY2B=NKEY1E+1,NKEY2E=NKEY1E+NKEY2) PARAMETER (NKEY3B=NKEY2E+1,NKEY3E=NKEY2E+NKEY3) PARAMETER (NKEY4B=NKEY3E+1,NKEY4E=NKEY3E+NKEY4) PARAMETER (NKEY5B=NKEY4E+1,NKEY5E=NKEY4E+NKEY5) PARAMETER (NKEY6B=NKEY5E+1,NKEY6E=NKEY5E+NKEY6) PARAMETER (NKEY7B=NKEY6E+1,NKEY7E=NKEY6E+NKEY7) PARAMETER (NKEY8B=NKEY7E+1,NKEY8E=NKEY7E+NKEY8) PARAMETER (NKEY9B=NKEY8E+1,NKEY9E=NKEY8E+NKEY9) CHARACTER*12 KYWRD2(NKEY9E) COMMON /KYBLK2/KYWRD2 INTEGER KEYGR1(NKEY9),KEYGR2(NKEY9) COMMON /KYBLK3/KEYGR1,KEYGR2 C C List of keywords. C Note that LOGICAL FUNCTION REFRSH is now written to interpret any C keyword beginning with 'COMM' as 'COMMENT' C C Group 0: Steps C DATA (KYWRD2(I),I=1,NKEY0)/ . 'CREATE ','CONTENT ','DISPLAY ','TRANSFORM ', . 'DELETE ','REWEIGHT ','IMPORT ','EXPORT ', . 'REPGEN ','JACKKNIFE ','FREE ','MERGE ', . 'RUN ','EXTRACT '/ C C Group 1: CREATE and subroutine in TRANSFORM C DATA (KYWRD2(I),I=NKEY1B,NKEY1E)/ . 'COMPUTE ','COPY ','ADD ','SUBTRACT ', . 'MULTIPLY ','DIVIDE ','POWER ','RECIPROCAL ', . 'LOG ','PRINT ','BOOLEAN ','AND ', . 'OR ','NOT ','IF ','ELSE ', . 'ELSEIF ','END ','ENDIF '/ C C Group 2: CREATE and other use in TRANSFORM C DATA (KYWRD2(I),I=NKEY2B,NKEY2E)/ . 'CLASS ','CATEGORICAL ','MISSING ','REAL ', . 'CROSSED ','FORMAT ','KEEP ','LABEL ', . 'LEVEL ','RENAME ','OPTION ','CONSTANT ', . 'OUTFORMAT ','STEP ','STEPOPTION ','MODEL '/ C C Group 3: TRANSFORM subroutines, general C DATA (KYWRD2(I),I=NKEY3B,NKEY3B+39)/ . 'USER1 ','USER2 ','USER3 ','USER4 ', . 'USER5 ','USER6 ','USER7 ','USER8 ', . 'USER9 ','USER10 ','RMULTIPLY ','SAVEFULL ', . 'GLUE ','COLLAPSE ','MODIFYREPF ','PAIRED ', . 'PINVERT ','PSOLVE ','PMULTIPLYM ','PMULTIPLYP ', . 'PSYMMULTM ','PSYMMULTP ','PPACK ','PUNPACK ', . 'PTRACE ','PDIAG ','PEIGENVECTOR','PEIGENVALUE ', . 'PSQRT ','MINVERT ','MSOLVE ','MMULTIPLY ', . 'MMULTIPLYM ','MSYMMULT ','MSYMMULTM ','MTRACE ', . 'MDIAG ','PBMULTIPLYM ','PBMULTIPLYP ','PBSYMMULTM '/ C DATA (KYWRD2(I),I=NKEY3B+40,NKEY3E)/ . 'PBSYMMULTP ','PBDIAG ','GRIDSEARCH ','RAO_SHAO ', . 'XMEDIAN '/ C C Group 4: TRANSFORM subroutines, naming files C C DATA (KYWRD2(I),I=NKEY4B,NKEY4E)/ . 'WRITE ','READ ','BINARYWRITE ','BINARYREAD ', . 'VPLXAPPEND ','VPLX '/ C C Group 5: TRANSFORM subroutines, specialized to Census Bureau C applications C DATA (KYWRD2(I),I=NKEY5B,NKEY5E)/ . 'CPSCOL ','SIPPCOL ','CPSCHILDCOL ','CPSNICOL ', . 'NEWCPSCHCOL ','NPSCHILDCOL ','OLDCPSCHCOL ','SIPPC_ROWCOL', . 'SIPPC_CLMCOL','SIPPC_RAKE ','SIPPC_NICOL ','CPS_COMP_COL'/ C C Group 6: Other TRANSFORM C DATA (KYWRD2(I),I=NKEY6B,NKEY6E)/ . 'OLD ','MODIFY ','DERIVED ','REMOVE ', . 'COUNT ','SLICELENGTH ','STRING ','LONGSTRING ', . 'INTEGER '/ C C Group 7: CREATE only C DATA (KYWRD2(I),I=NKEY7B,NKEY7E)/ . 'SELECT ','BY ','REPLICATION ','UNWEIGHTED ', . 'INPUT ','DROP ','REP ','REPLICATE ', . 'WEIGHT ','STRATUM ','CLUSTER ','SECOND ', . 'COEFFICIENT ','FPC1 ','FPC2 ','CROSS ', . 'IDCHANGE ','BLOCK ','LINK ','LINK_MISSING', . 'ADD_MS ','SUBTRACT_MS ','MULTIPLY_MS ','DIVIDE_MS ', . 'OUTPUT ','HADAMARD ','RETAIN ','RGENERATE '/ C C Group 8 Miscellaneous C DATA (KYWRD2(I),I=NKEY8B,NKEY8E)/ . 'LIST ','COVARIANCE ','CORRELATION ','T ', . 'TEST ','AS ','INCORPORATE ','COMMENT ', . 'C ','ON ','ECHO ','TEMPLATE '/ C C Synonyms C DATA (KYWRD2(I),I=NKEY9B,NKEY9E)/ . 'CAT ','COV ','CORR ','RPRINT ', . 'REPPRINT ','REPWRITE ','REPREAD ','SLICE_LENGTH', . 'STEP_OPTION ','REFORMAT ','VPLX_APPEND ','CONVERT ', . 'F ','F1 ','F2 '/ DATA (KEYGR1(I),I=1,NKEY9)/ 2, 8, 8, 1, 1, 4, 4, 6, . 2, 1, 4, 0, 7, 7, 7/ DATA (KEYGR2(I),I=1,NKEY9)/ 2, 2, 3, 10, 10, 1, 2, 6, . 15, 2, 5, 9, 14, 14, 15/ C C . 'DEFAULT ', C . 'READFULL ', C . 'ON ','C ',/ END C C Start of B.FOR - basic utilities, error returns C SUBROUTINE FESTOP(ICODE) C INTEGER ICODE C C End on error during execution of a step, passing an error code C to be stored in IMERR1. C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 IMERR1=ICODE CALL FSTOP STOP END C SUBROUTINE FPSTOP(ICODE,IPOS) C INTEGER ICODE,IPOS C C End on error during parsing of a command, passing an error code, C and a position for the error, to be stored in IMERR1 and IMERR2, C respectively. C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 IMERR1=ICODE IMERR2=IPOS CALL FSTOP STOP END C SUBROUTINE FSTOP C C End originally called from most locations. (As error messages are C incorporated, many calls will eventually be to FESTOP or FPSTOP, C which then call FSTOP in turn.) C C Prints error codes, if set, and deletes the output file. C PARAMETER (MAXFMT=20) LOGICAL FOPEND INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT C CHARACTER*160 FNERRR,FNWARN COMMON /IOBLK3/FNERRR,FNWARN C CHARACTER*6 VERROR CHARACTER*79 ERRREC CHARACTER*1 ALPHA1(26) DATA ALPHA1/ 'A','B','C','D','E','F','G','H','I','J','K','L', . 'M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/ C 100 FORMAT(/,' OUT= FILE DELETED',/) 101 FORMAT(1X) 102 FORMAT(/,' VPLX ERROR CODE ',A6) 103 FORMAT('V',A1,I4) 104 FORMAT('V',A1,'0',I3) 105 FORMAT('V',A1,'00',I2) 106 FORMAT('V',A1,'000',I1) 107 FORMAT(A79) 108 FORMAT(1X,A79) C C If IMERR1 > 0, print the corresponding error code C IF(IMERR1.GT.0) THEN I=IMERR1/10000 J=MOD(IMERR1,10000) IF(J.GE.1000) THEN WRITE(VERROR,103)ALPHA1(I),J ELSE IF(J.GE.100) THEN WRITE(VERROR,104)ALPHA1(I),J ELSE IF(J.GE.10) THEN WRITE(VERROR,105)ALPHA1(I),J ELSE WRITE(VERROR,106)ALPHA1(I),J END IF WRITE(U6,102)VERROR IF(FNERRR(1:1).NE.' ') THEN FNWRK=FNERRR INQUIRE(UNIT=10,OPENED=FOPEND) IF(FOPEND) THEN CLOSE(UNIT=10) END IF C C Check to see if error file exists C CALL FINQEX(FOPEND) IF(FOPEND) THEN C C Reset IMERR1=0 so that OPENRF will open the error file. C IMERR1=0 CALL OPENRF(10) 3 CONTINUE READ(10,107,END=5)ERRREC IF(ERRREC(1:6).EQ.VERROR) THEN WRITE(U6,101) 4 CONTINUE WRITE(U6,108)ERRREC READ(10,107,END=5)ERRREC IF(ERRREC(1:1).NE.'V') GO TO 4 ELSE GO TO 3 END IF 5 CONTINUE END IF END IF END IF C C If IMERR2 > 0, print an error message with the approximate C position of the error. C IF(IMERR2.GT.0) THEN CALL CRDPRN(4) WRITE(U6,101) END IF INQUIRE(UNIT=11,OPENED=FOPEND) IF(FOPEND) THEN CLOSE(UNIT=11,STATUS='DELETE') WRITE(U6,100) END IF CALL VPSTOP END C SUBROUTINE RCHECK(IRCODE,IRNOW,IRNEED) C INTEGER IRCODE,IRNOW,IRNEED C C IRCODE - resource code, with possible values given below C IRNOW - current value in use C IRNEED - request C C If resources are available, the routine simply returns without C changing any values. If the resource is exceeded, a fatal error C message is issued. C INTEGER SIZED,RCEIL(13) C COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*20 RSOURC (13) DATA RSOURC / 'GENRL INTEGER MATRIX', . 'INPUT/NEW VARIABLES ','VARIANCE IDS/BY VARS', . 'RECODED VARIABLES ','RANGES ', . 'SETS OF RANGES ','LEVELS OF CAT/CLASS ', . 'CLASS BLOCKS ','CLASS POINTER ARRAYS', . 'DIMENSN OF CROSSED V','CHARACTER STRINGS ', . 'TRANSFORMATIONS ','TEMPORARY NAMES '/ C 200 FORMAT(1X,I7,' EXCEEDS AVAILABLE RESOURCES FOR ',A20) C IF(IRNOW+IRNEED-1.LE.RCEIL(IRCODE))RETURN IRNOW=IRNOW+IRNEED-1 WRITE(U6,200)IRNOW,RSOURC(IRCODE) IMERR1=160200+IRCODE CALL FSTOP END C SUBROUTINE RINCR(IRCODE,IRNOW,IRNEED) C INTEGER IRCODE,IRNOW,IRNEED C C IRCODE - resource code, with possible values given in the comments C to RCHECK, above C IRNOW - current value in use C IRNEED - request C C This routine calls RCHECK to see if the resource is available. C If so, the subroutine changes IRNOW C CALL RCHECK(IRCODE,IRNOW,IRNEED) IRNOW=IRNOW+IRNEED RETURN END C SUBROUTINE ROOMD(SPACE) C C ARGUMENT DECLARATION C INTEGER SPACE C C COMMON BLOCK DECLARATIONS C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C 101 FORMAT(/,' DOUBLE PRECISION STORAGE MATRIX OF SIZE',I8,' INSUFFICI .ENT, AT LEAST',I8,' NEEDED') NXPTD=NXPTD+SPACE IF(NXPTD.GT.LASTPD)LASTPD=NXPTD-1 IF(LASTPD.GT.SIZED) THEN WRITE(U6,101)SIZED,LASTPD CALL FESTOP(160200) END IF RETURN END C SUBROUTINE ROOMI(SPACE) C C ARGUMENT DECLARATION C INTEGER SPACE C C COMMON BLOCK DECLARATIONS C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C CALL RINCR(1,NXPTI,SPACE) RETURN END C SUBROUTINE RRESET C C This subroutine resets all resources to their initial values. C PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (MAXFMT=20) PARAMETER (MTRANS=1500) C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C RCEIL(2)=MVAR RCEIL(3)=MAXIDS RCEIL(4)=MRECOD RCEIL(5)=MRANGE RCEIL(6)=MRNSET RCEIL(7)=MLEVEL RCEIL(8)=MCLBLK RCEIL(9)=MCLBAR RCEIL(10)=MCRSSD RCEIL(11)=MAXFMT RCEIL(12)=MTRANS RCEIL(13)=MVAR RETURN END C SUBROUTINE VPSTOP C C Normal end, called directly only from main program and by C VSTOP after displaying errors. C LOGICAL FOPEND INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C 100 FORMAT('1Use of double precision matrix:',I8,' out of',I8) C C Close scratch files. C DO 10 IUNIT=13,19 INQUIRE(UNIT=IUNIT,OPENED=FOPEND) IF(FOPEND)CLOSE(UNIT=IUNIT,STATUS='DELETE') 10 CONTINUE C C Printing of use of double precision matrix. C IF(U5ECHO.EQ.1)WRITE(U6,100)LASTPD,SIZED STOP END C C End of B.FOR C C C Start of I.FOR - general routines to handle I/O operations C SUBROUTINE FCLALL C C Subroutine to close all open files except standard output, input C and alternative input files. C PARAMETER (MAXALT=5) C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 INTEGER U5ALT(MAXALT),U5ASTT(MAXALT) COMMON /A5BLCK/U5ALT,U5ASTT LOGICAL FOPEND C DO 15 IUNIT=8,39 IF(IUNIT.EQ.U5.OR.IUNIT.EQ.U6)GO TO 15 DO 12 I=1,MAXALT IF(IUNIT.GE.13.AND.IUNIT.LE.19)GO TO 15 C C U5ALT contains the list of alternative files. REFRSH resets C the corresponding entry to 0 on end of file, so this list is C always current. C IF(IUNIT.EQ.U5ALT(I))GO TO 15 12 CONTINUE INQUIRE(UNIT=IUNIT,OPENED=FOPEND) IF(FOPEND) THEN CLOSE(UNIT=IUNIT) END IF 15 CONTINUE RETURN END C SUBROUTINE FNFIND(ISTART) C INTEGER ISTART C C ISTART - position in CARD to begin search for a file name. C C This routine looks for a file name of up to 80 characters. C It does not attempt to find optional parameters enclosed in C parentheses. C PARAMETER (MAXFMT=20) C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW, . OSCODE,NEWFNM COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE, . ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM C CHARACTER*256 CARD COMMON /CRDBLK/CARD C LOGICAL APOSTR C IPOS=ISTART IDOT=0 CALL NBFIND(CARD(IPOS:256),IPOS,256,IPT) IF(IPT.EQ.0) THEN CALL FPSTOP(160300,IPOS) END IF L=0 APOSTR=.FALSE. 20 CONTINUE IF(CARD(IPT:IPT).EQ.'''') THEN IF(L.EQ.0) THEN C C If encounter initial apostrophe, note C APOSTR=.TRUE. ELSE IF(APOSTR) THEN C C If encounter apostrophe, after an initial apostrophe, assume end of C name. C IPT=IPT+1 GO TO 25 ELSE CALL FPSTOP(160301,IPT) END IF C C Conditions under which file name ends C 9/21/98 now add condition on '/' as deliminator when NEWFNM=1 C Considered delimitor under WIN32 and VMS; delimitor under UNIX after C first '.' in file name C ELSE IF(.NOT.APOSTR.AND. . (CARD(IPT:IPT).EQ.' '.OR.CARD(IPT:IPT).EQ.','.OR. . CARD(IPT:IPT).EQ.')'.OR.CARD(IPT:IPT).EQ.';'.OR. . (CARD(IPT:IPT).EQ.'/'.AND.NEWFNM.EQ.1.AND. . (OSCODE.NE.2.OR.IDOT.GT.0)))) THEN C C Except when a file name was set within an initial apostrophe, C blank, comma, semicolon, and ")" all indicate the end of the name. C GO TO 25 ELSE L=L+1 IF(L.GT.80) THEN CALL FPSTOP(160302,IPT) END IF FNWRK(L:L)=CARD(IPT:IPT) IF(CARD(IPT:IPT).EQ.'.') THEN C ! Record occurence of '.' in IDOT=IPT C ! file name END IF C C Insure that name of file does not start with blank, even if C within apostrophes. C IF(L.EQ.1.AND.CARD(IPT:IPT).EQ.' ')L=0 END IF IPT=IPT+1 IF(IPT.LE.256)GO TO 20 25 CONTINUE IF(L.LT.80) THEN DO 30 I=L+1,80 FNWRK(I:I)=' ' 30 CONTINUE END IF ISTART=IPT RETURN END C SUBROUTINE FNLGTH(LEN) C INTEGER LEN C C LEN - returned by subroutine as the last nonblank character C in FNWRK(1:80). C PARAMETER (MAXFMT=20) CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT C DO 1 L=80,1,-1 IF(FNWRK(L:L).NE.' ')GO TO 2 1 CONTINUE L=0 2 CONTINUE LEN=L RETURN END C SUBROUTINE FNREAD(BASE,ITYPE,IFLAG,IACTN,IPOSSC) C INTEGER BASE,ITYPE(3),IFLAG(3),IACTN C C BASE - starting position to scan, reset to 1 if FNREAD reads C a new card with REFRSH C ITYPE - array with flags indicating possible types of files C to expect. These are passed to FNRD2. C ITYPE(1) = 0, when IACTN=1, is reset to 1 for character C input, 2 unformatted input, based on FORTRAN C INQUIRE C ITYPE(1) = 1 expect character input C ITYPE(2) = 2 expect unformatted input C ITYPE(2) = 1 expect character output C ITYPE(2) = 2 expect unformatted output C ITYPE(3) = 1 expect formatted output (IACTN=7) C ITYPE(3) = 2 expect unformatted VPLXIN= input C ITYPE(3) =-2, optional unformatted file, but do not default C to last VPLX file in LSTVPL C Other values for ITYPE(1, 2, or 3) upon return C 2 file is identified as unformatted integer C 3 file is identified as unformatted real C 4 file is identified as unformatted double C precision C C IFLAG - initialized to 0, then, for IACTN =1 C IFLAG(1) = 1 opened input (unit 12) C IFLAG(2) = 1 opened output (unit 11) C IFLAG(3) = 1 opened input (unit 10) for VPLXIN=10 in C REWEIGHT step (IACNT=1) or output from C CREATE step (IACNT=7) C C For IACTN=2, the appropriate IFLAG will be set to the C assigned unit number. C IACTN = 1 primary file specification for step, units 11, 12, 10 C are eligible for opening C = 2 input or output from a subroutine in TRANSFORM, etc. C Open and return the unit number in IFLAG. C = 3 scratch file - do not open C = 4 other file - do not open. C = 5 delete C = 6 free C = 7 primary file specification for CREATE step, units 11, C 12, 10 are eligible for opening C C IPOSSC - position of semicolon ending statement C = 0 no semicolon encountered. C C Reads filename statements in form IN=fn OUT=fn and opens files, C by calling FNRD2 and reading additional lines with REFRSH C C This subroutine repeatedly calls FNRD2 without checking IFPSW. C The process ends when REFRSH is false, i.e., either an end-of-file C or record with a keyword has been read. C C IMERR1 is set to a value in FNRD2 if a fatal error occurs and if C the input file is a scratch file. C CHARACTER*256 CARD COMMON /CRDBLK/ CARD LOGICAL REFRSH EXTERNAL REFRSH INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C IF(BASE.LE.0)BASE=257 CALL FNRD2(BASE,ITYPE,IFLAG,IACTN,1,IFPSW,IFNAME,IPOSSC) IF(IMERR1.GT.0) THEN RETURN END IF 1 CONTINUE IF(IPOSSC.EQ.0) THEN IF(REFRSH(BASE)) THEN CALL FNRD2(BASE,ITYPE,IFLAG,IACTN,2,IFPSW,IFNAME,IPOSSC) IF(IMERR1.GT.0) THEN RETURN END IF GO TO 1 ELSE CALL FNRD2(BASE,ITYPE,IFLAG,IACTN,3,IFPSW,IFNAME,IPOSSC) IF(IMERR1.GT.0) THEN RETURN END IF END IF END IF RETURN END C SUBROUTINE FNRD2(BASE,ITYPE,IFLAG,IACTN,ICSTAT,IFPSW,IFNAME, . IPOSSC) C INTEGER BASE,ITYPE(3),IFLAG(3),IACTN,ICSTAT,IFPSW,IFNAME,IPOSSC C C BASE - starting position to scan. Not changed by this subroutine. C ITYPE - array with flags indicating possible types of files C to expect. C ITYPE(1) = 0, when IACTN=1, is reset to 1 for character C input, 2 unformatted input, based on FORTRAN C INQUIRE C ITYPE(1) = 1 expect character input C ITYPE(2) = 2 expect unformatted input C ITYPE(2) = 1 expect character output C ITYPE(2) = 2 expect unformatted output C ITYPE(3) = 2 expect unformatted VPLXIN= input C ITYPE(3) =-2, optional unformatted file, but do not default C to last VPLX file in LSTVPL C Other values for ITYPE (1, 2, or 3) upon return: C 3 file is identified as unformatted integer C 4 file is identified as unformatted real C 5 file is identified as unformatted double C precision C C IFLAG - initialized to 0, then, for IACTN =1 C IFLAG(1) = 1 opened input (unit 12) C IFLAG(2) = 1 opened output (unit 11) C IFLAG(3) = 1 opened input (unit 10) for VPLXIN=10 in C REWEIGHT step (IACNT=1) or output from C CREATE step (IACNT=7) C Other values for ITYPE (1, 2, or 3) C 3 file is identified as unformatted integer C 4 file is identified as unformatted real C 5 file is identified as unformatted double precision C C For IACTN=2, the appropriate IFLAG will be set to the C assigned unit number. C IACTN = 1 primary file specification for step, units 11, 12, 10 C are eligible for opening C = 2 input or output from a subroutine in TRANSFORM, etc. C Open and return the unit number in IFLAG. C = 3 scratch file - do not open C = 4 other file - do not open - e.g. ERRORFILE. C = 5 delete C = 6 free C = 7 primary file specification for CREATE step, units 11, C 12, 10 are eligible for opening C C ICSTAT - call status - C = 1 first call C = 2 subsequent call with new information in CARD C = 3 close-out call. Do not examine CARD but conclude C processing of a files in progress, if any. C IFPSW - file name/parameter switch - set by FNRD2 C = 1 expect a file name C = 2 while reading parameters. C C IFNAME - set to 1 when a file name has been read, 0 otherwise C C IPOSSC - position of ending semicolon in CARD C = 0 no ending semicolon encountered. C C Reads filename statements in form IN=fn OUT=fn and opens files. C C This routine is called by FNREAD and directly by REFRSH. It C examines only the current contents of CARD but does not C initiate reading of additional records, which is managed by C FNREAD or by REFRSH. C PARAMETER (MAXFMT=20) PARAMETER (NPRMKY=10) PARAMETER (MAXKWL=24) CHARACTER*(MAXKWL) KEYWRD CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) CHARACTER*160 FNAM11,FNAM12 COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT CHARACTER*256 CARD COMMON /CRDBLK/ CARD INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW, . OSCODE,NEWFNM COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE, . ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM LOGICAL FEXIST,DONE,REFRSH EXTERNAL REFRSH C C The following SAVE statement requests that internal variables C retain their assigned values over repeated calls of FNRD2 C SAVE IEQST,DONE,IFLAGE,FNAM11,FNAM12,IDONE,IFPARM,IFV C CHARACTER*8 PRMKEY(NPRMKY) DATA PRMKEY/'UNIT ','VOL ','VOLSER ','RECL ', . 'LRECL ','TRK ','MAXREC ','SECOND ', . 'BLKSIZE ','STATUS '/ C 211 FORMAT(5X,'NOT OPEN') 212 FORMAT(5X,'DOES NOT EXIST') C C Initializations C IF(ICSTAT.EQ.1) THEN C ! For first call to subroutine IFLAG(1)=0 IFLAG(2)=0 IFLAG(3)=0 DONE=.FALSE. IFV=1 C C Set IEQST=1 to indicate initial call to EQSCN2 C IEQST=1 C C Set IFPSW to initially expect a file name. IFPSW=2 while C reading parameters. C IFPSW=1 C C Set IFNAME=0 to indicate that a filename has not yet been read. C Set IFPARM=0 to indicate that file parameters have not been read. C IFNAME=0 IFPARM=0 C C Normally, both IDONE and IFLAGE are set on the initial call to C EQSCN2. Set them to their initial values so that this information C will be available if ICSTAT=3 C IDONE=0 IFLAGE=0 END IF IPT=BASE 10 CONTINUE C C Except for ICSTAT=3, scan CARD for new information. C IF(ICSTAT.NE.3) THEN C C Return if BASE does not indicate a starting point C IPOSSC=0 IF(BASE.LE.0.OR.BASE.GT.256.OR.U5END.EQ.1)GO TO 90 CALL NBFIND(CARD(IPT:256),IPT,256,IPOS) IF(IPOS.EQ.0)GO TO 90 IPT=IPOS C C For each new file, clear out record for file name and storage of C optional file parameters. C IF(IEQST.EQ.1.AND.IFPSW.EQ.1.AND.IFNAME.EQ.0.AND. . IFPARM.EQ.0) THEN DO 12 I=1,160 FNWRK(I:I)=' ' 12 CONTINUE END IF IF(CARD(IPT:IPT).EQ.'(') THEN C C If at beginning of parameters, set switches and return to 10 C to begin to read. C IF(IFPSW.EQ.1) THEN IFPSW=2 IFPARM=1 IPT=IPT+1 GO TO 10 ELSE C C Error return C IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160303 IMERR2=IPT RETURN ELSE CALL FPSTOP(160303,IPT) END IF END IF ELSE IF(CARD(IPT:IPT).EQ.')') THEN IF(IFPSW.EQ.1) THEN C C Error return C IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160304 IMERR2=IPT RETURN ELSE CALL FPSTOP(160304,IPT) END IF ELSE IFPSW=1 IPOS=IPT+1 CALL NBFND2(IPOS,IPT) IF(CARD(IPT:IPT).EQ.';') THEN IPOSSC=IPT IFPSW=1 END IF C C Go to 25 to open file. C GO TO 25 END IF ELSE IF(CARD(IPT:IPT).EQ.';'.AND.IFPSW.NE.2) THEN IPOSSC=IPT IFPSW=1 GO TO 25 ELSE IF(CARD(IPT:IPT).EQ.',') THEN C C Skip over commas. C IPT=IPT+1 GO TO 10 ELSE IF(IFPSW.EQ.1.AND.IFNAME.EQ.1) THEN C C If filename has been read, go to 25 to open. C GO TO 25 END IF C C Call EQSCN2 to look for IN = fname or OUT = fname C CALL EQSCN2(IPT,IPOS,KEYWRD,IFLAGE,IEQST,IDONE) IPT=IPOS IF(IDONE.EQ.0) THEN C C IDONE=0 indicates EQSCN2 not finished with keyword = syntax C RETURN in order to read another record. C IEQST=0 GO TO 90 END IF END IF C C We arrive here in one of 2 ways: C 1) EQSCN2 has identified one or more parts of in = fname, etc. C 2) ICSTAT=3 C C If EQSCAN picked up a file name of MAXKWL or fewer characters C in KEYWRD, copy it into FNWRK. C IF(IFLAGE.EQ.2..AND.IFPSW.EQ.1.AND.IFNAME.EQ.0) THEN IF(IFLAG(1).EQ.0.OR.IACTN.NE.1) THEN FNWRK(1:MAXKWL)=KEYWRD IFNAME=1 C C If IN =, OUT =, VPLXIN = not given, determine whether input or output C IF(IACTN.NE.2.OR.ITYPE(1).GT.0) THEN IT=1 ELSE IT=2 END IF C C Transfer to 10 to look for parameters. C IF(ICSTAT.EQ.3) THEN GO TO 25 ELSE GO TO 10 END IF ELSE IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160305 RETURN ELSE CALL FESTOP(160305) END IF END IF ELSE IF(ICSTAT.EQ.3) THEN C C Except for the concluding the case just considered for a file name C picked up as a keyword by EQSCN2, conclude processing for ICSTAT=3 C GO TO 25 ELSE IF(IFLAGE.EQ.0.AND.IFPSW.EQ.1.AND.IFNAME.EQ.0) THEN C C If EQSCAN did not even partially scan, check for a long file name C Note: This will be the case upon encountering any file name with C initial or embedded forward / or back slashes. C IF((IFLAG(1).EQ.0.OR.IACTN.NE.1).AND.IPT.NE.0) THEN CALL NBFIND(CARD(IPT:256),IPT,256,IPOS) IF(IPOS.GT.0) THEN IPT=IPOS IF(IACTN.NE.2.OR.ITYPE(1).GT.0) THEN IT=1 ELSE IT=2 END IF CALL FNFIND(IPT) IFNAME=1 C C Return to 10 to continue reading. C GO TO 10 ELSE IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160306 IMERR2=IPT RETURN ELSE CALL FPSTOP(160306,IPT) END IF END IF END IF C C For KEYWRD = found, determine whether IN=, OUT=, OR VPLXIN= C ELSE IF(IFPSW.EQ.1.AND.IFNAME.EQ.0) THEN CALL CMATCH(KEYWRD,1,MAXKWL,'IN',2,IPOS,1) IF(IPOS.GT.0) THEN IT=1 ELSE CALL CMATCH(KEYWRD,1,MAXKWL,'OUT',3,IPOS,1) IF(IPOS.GT.0) THEN IF(IACTN.EQ.3) THEN IT=1 ELSE IT=2 END IF ELSE CALL CMATCH(KEYWRD,1,MAXKWL,'VPLXIN',6,IPOS,1) IF(IPOS.GT.0) THEN IF(ITYPE(3).EQ.0) THEN IT=1 ELSE IT=3 END IF ELSE IT=0 CALL CMATCH(KEYWRD,1,MAXKWL,'VPLXOUT',7,IPOS,1) IF(IPOS.GT.0) THEN IT=2 END IF CALL CMATCH(KEYWRD,1,MAXKWL,'UNF_INTEGER_IN',14,IPOS,1) IF(IPOS.GT.0) THEN IT=1 IFV=3 END IF CALL CMATCH(KEYWRD,1,MAXKWL,'UNF_REAL_IN',11,IPOS,1) IF(IPOS.GT.0) THEN IT=1 IFV=4 END IF CALL CMATCH(KEYWRD,1,MAXKWL,'UNF_DOUBLE_IN',13,IPOS,1) IF(IPOS.GT.0) THEN IT=1 IFV=5 END IF CALL CMATCH(KEYWRD,1,MAXKWL,'UNF_INTEGER_OUT',15,IPOS,1) IF(IPOS.GT.0) THEN IT=2 IFV=3 END IF CALL CMATCH(KEYWRD,1,MAXKWL,'UNF_REAL_OUT',12,IPOS,1) IF(IPOS.GT.0) THEN IT=2 IFV=4 END IF CALL CMATCH(KEYWRD,1,MAXKWL,'UNF_DOUBLE_OUT',14,IPOS,1) IF(IPOS.GT.0) THEN IT=2 IFV=5 END IF C C Specification of an unformatted file with CREATE pertains to the unit C 10 output file, rather than the primary VPLX file output C IF(IACTN.EQ.7.AND.IT.EQ.2) THEN IT=3 END IF C CALL CMATCH(KEYWRD,1,MAXKWL,'FORMATTED_OUT',13,IPOS,1) IF(IPOS.GT.0) THEN IF(IACTN.EQ.7) THEN IT=3 ELSE IT=2 END IF IF(IFLAG(IT).EQ.2) THEN IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160323 RETURN ELSE CALL FESTOP(160323) END IF END IF END IF CALL CMATCH(KEYWRD,1,MAXKWL,'FORMATTED_IN',12,IPOS,1) IF(IPOS.GT.0) THEN IT=1 IF(IFLAG(IT).EQ.2) THEN IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160323 RETURN ELSE CALL FESTOP(160323) END IF END IF END IF IF(IT.EQ.0) THEN IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160307 RETURN ELSE CALL FESTOP(160307) END IF END IF END IF END IF END IF CALL FNFIND(IPT) IFNAME=1 GO TO 10 ELSE C C Interpretation of parameters. C IF(IFLAGE.NE.1) THEN IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160308 RETURN ELSE CALL FESTOP(160308) END IF END IF DO 16 L=1,NPRMKY CALL CMATCH(KEYWRD,1,MAXKWL,PRMKEY(L),8,IPOS,1) IF(IPOS.GT.0)GO TO 17 16 CONTINUE C C If no match, go to error return C IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160309 RETURN ELSE CALL FESTOP(160309) END IF 17 CONTINUE IF(L.EQ.2) THEN I=IPT+3 CALL CMATCH(CARD(IPT:I),IPT,I,'SER',3,IPOS,1) IF(IPOS.GT.0) THEN C C VOL=SER construction C IDONE=0 IFLAGE=2 IEQST=0 IPT=IPT+3 GO TO 10 END IF END IF IF(L.LE.3.OR.L.EQ.10) THEN IF(L.EQ.1) THEN IPOS=80 ELSE IF(L.EQ.2.OR.L.EQ.3) THEN IPOS=88 ELSE IF(L.EQ.10) THEN IPOS=136 END IF 20 CONTINUE IF(CARD(IPT:IPT).NE.'''') THEN IPOS=IPOS+1 IF((L.EQ.1.AND.IPOS.GT.88).OR. . ((L.EQ.2.OR.L.EQ.3).AND.IPOS.GT.96).OR. . (L.EQ.10.AND.IPOS.GT.144)) THEN IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160310 IMERR2=IPT RETURN ELSE CALL FPSTOP(160310,IPT) END IF END IF FNWRK(IPOS:IPOS)=CARD(IPT:IPT) END IF IPT=IPT+1 IF(CARD(IPT:IPT).NE.' '.AND.CARD(IPT:IPT).NE.','.AND. . CARD(IPT:IPT).NE.')')GO TO 20 ELSE IF(L.EQ.4.OR.L.EQ.5) THEN IPOS=113 ELSE IF(L.EQ.6.OR.L.EQ.7) THEN FNWRK(97:104)=PRMKEY(L) IPOS=105 ELSE IF(L.EQ.8) THEN IPOS=121 ELSE IPOS=129 END IF CALL IFIND(CARD(IPT:256),IPT,256,I,J) IF(I.EQ.0) THEN IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160311 IMERR2=IPT RETURN ELSE CALL FPSTOP(160311,IPT) END IF END IF IF(J.LT.0.OR.J.GT.99999999) THEN IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160312 IMERR2=IPT RETURN ELSE CALL FPSTOP(160312,IPT) END IF END IF IPT=I WRITE(FNWRK(IPOS:IPOS+7),'(I8)')J END IF IEQST=1 GO TO 10 END IF 25 CONTINUE C C If there is no name in progress and ICSTAT=3 or a semicolon has c been encountered, proceed to final cleanup. C IF((ICSTAT.EQ.3.OR.IPOSSC.GT.0).AND.IFNAME.EQ.0)GO TO 80 C C Duplicate input, output, etc. C IF(IFLAG(IT).GT.0) THEN IF(IT.EQ.1) THEN IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160313 RETURN ELSE IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160313 RETURN ELSE CALL FESTOP(160313) END IF END IF ELSE IF(IT.EQ.2) THEN IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160314 RETURN ELSE CALL FESTOP(160314) END IF ELSE IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160315 RETURN ELSE CALL FESTOP(160315) END IF END IF END IF C CALL FNLGTH(L) IF(IFV.GE.3) THEN IF(ITYPE(IT).NE.1) THEN IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160322 RETURN ELSE CALL FESTOP(160322) END IF ELSE ITYPE(IT)=IFV END IF END IF IF(IACTN.EQ.1.OR.IACTN.EQ.7) THEN C ! primary statement of step IFLAG(IT)=1 IF(IT.EQ.1) THEN IU=12 FNAM12=FNWRK ELSE IF(IT.EQ.2) THEN IU=11 FNAM11=FNWRK ELSE IU=10 END IF ELSE IF(IACTN.EQ.2) THEN C ! open file e.g., in transform step C C Call IUFIND to obtain a unit number. C CALL IUFIND(IFLAG(IT)) IU=IFLAG(IT) IF(IFV.GE.3) THEN ITYPE(IT)=IFV END IF ELSE IFLAG(IT)=1 END IF C IF(IACTN.LE.2.OR.IACTN.EQ.7) THEN IF(IT.EQ.1.OR.(IACTN.LE.2.AND.IT.EQ.3)) THEN C C Check that input file exists. C CALL FINQEX(FEXIST) IF(.NOT.FEXIST) THEN IF(IT.EQ.1) THEN IF((U5.GE.13.AND.U5.LE.17).OR.CMPFLG.EQ.1) THEN IMERR1=160316 RETURN ELSE CALL FESTOP(160316) END IF ELSE IF((U5.GE.13.AND.U5.LE.17).OR.CMPFLG.EQ.1) THEN IMERR1=160317 RETURN ELSE CALL FESTOP(160317) END IF END IF END IF END IF IF(IT.EQ.1) THEN C C For ITYPE(1) = 0, determine whether file is formatted or unformatted. C IF(ITYPE(1).EQ.0) THEN CALL FINQFM(KEYWRD(1:12)) CALL CMATCH(KEYWRD,1,MAXKWL,'FORMATTED',9,IPOS,1) IF(IPOS.GT.0) THEN ITYPE(1)=1 ELSE ITYPE(1)=2 END IF END IF END IF C C Open file. C IF(IT.EQ.1.AND.ITYPE(1).EQ.1) THEN CALL OPENRF(IU) IF(IMERR1.GT.0)RETURN ELSE IF(ITYPE(IT).GE.2.AND.(IT.EQ.1.OR.(IACTN.EQ.1.AND.IT.EQ.3)) . )THEN CALL OPENRU(IU) IF(IMERR1.GT.0)RETURN IF(IT.EQ.3) THEN C C VPLXIN = file becomes the future default file for REWEIGHT C LSTVPL=FNWRK END IF ELSE IF(ITYPE(IT).EQ.1) THEN CALL OPENWF(IU) IF(IMERR1.GT.0)RETURN ELSE CALL OPENWU(IU) IF(IMERR1.GT.0)RETURN END IF ELSE IF(IACTN.EQ.5.OR.IACTN.EQ.6) THEN CALL FINQEX(FEXIST) IF(FEXIST) THEN C C Within this if block, FEXIST will now denote whether the file C is open. C CALL FINQOP(FEXIST) IF(.NOT.FEXIST) THEN C C If the file is not open, print warning message for FREE, open the C file for delete. C IF(IACTN.EQ.6) THEN IF(U5ECHO.GT.0)WRITE(U6,211) ELSE CALL IUFIND(IU) CALL OPENG(IU) END IF ELSE C C Obtain the unit number of an open file C CALL FINQIU(IU) END IF C C DELETE C IF(IACTN.EQ.5) THEN CLOSE(UNIT=IU,STATUS='DELETE') ELSE IF(FEXIST) THEN C C FREE C IF(IU.GE.13.AND.IU.LE.17) THEN CLOSE(UNIT=IU,STATUS='DELETE') ELSE CLOSE(UNIT=IU) END IF END IF ELSE C C Warning message for nonexistent file. C WRITE(U6,212) END IF END IF BASE=IPT IF(IACTN.NE.3) THEN IEQST=1 C C Set IEQST=1 to indicate initial call to EQSCN2 C IEQST=1 C C Set IFPSW to initially expect a file name. IFPSW=2 while C reading parameters. C IFPSW=1 C C Set IFNAME=0 to indicate that a filename has not yet been read. C Set IFPARM=0 to indicate that file parameters have not been read. C IFNAME=0 IFPARM=0 C C Normally, both IDONE and IFLAGE are set on the initial call to C EQSCN2. Set them to their initial values so that this information C will be available if ICSTAT=3 C IDONE=0 IFLAGE=0 IFV=1 END IF IF(ICSTAT.NE.3.AND.IPOSSC.EQ.0)GO TO 10 C C Final cleanup. Under IACTN=1, use previous VPLX files, C if present, as input files, if VPLX files expected C 80 CONTINUE IF(IACTN.EQ.1.OR.IACTN.EQ.7) THEN IF(.NOT.DONE) THEN IF((IFLAG(1).EQ.0.AND.ITYPE(1).EQ.2).OR. . (IFLAG(3).EQ.0.AND.ITYPE(3).EQ.2)) THEN C C If no input has yet been assigned, try the last VPLX file. C IF(LSTVPL(1:1).NE.' ') THEN DONE=.TRUE. IF(IFLAG(1).EQ.0.AND.ITYPE(1).EQ.2) THEN IT=1 ELSE IT=3 END IF FNWRK=LSTVPL IFNAME=1 GO TO 25 END IF IF(IFLAG(3).EQ.0.AND.ITYPE(3).EQ.2) THEN IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160318 RETURN ELSE CALL FESTOP(160318) END IF END IF END IF IF(IFLAG(1).EQ.0) THEN IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160319 RETURN ELSE CALL FESTOP(160319) END IF END IF END IF IF(IFLAG(2).EQ.1.AND.ITYPE(2).EQ.2) THEN LSTVPL=FNAM11 ELSE IF(ITYPE(1).EQ.2) THEN LSTVPL=FNAM12 END IF ELSE IF(ITYPE(1).NE.0.AND.IFLAG(1).EQ.0) THEN IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160320 RETURN ELSE CALL FESTOP(160320) END IF ELSE IF(ITYPE(2).NE.0.AND.IFLAG(2).EQ.0) THEN IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160321 RETURN ELSE CALL FESTOP(160321) END IF END IF END IF BASE=1 90 CONTINUE RETURN END C SUBROUTINE FRSTOP(IUNIT) C INTEGER IUNIT C C Return for error on reading input file, unit IUNIT C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C 100 FORMAT(/,' ERROR ON PRIMARY IN= UNIT FROM STEP') 101 FORMAT(/,' INPUT ERROR ON UNIT',I3) C IF(IUNIT.EQ.11) THEN WRITE(U6,100) IF(IMERR1.EQ.0)IMERR1=90101 ELSE WRITE(U6,101)IUNIT IF(IMERR1.EQ.0)IMERR1=90102 END IF CALL FSTOP END C SUBROUTINE FWSTOP(IUNIT) C INTEGER IUNIT C C Return for error on writing output file, unit IUNIT C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C 100 FORMAT(/,' ERROR ON PRIMARY OUT= UNIT FROM STEP') 101 FORMAT(/,' OUTPUT ERROR ON UNIT',I3) C CLOSE(UNIT=IUNIT,STATUS='DELETE') IF(IUNIT.EQ.11) THEN WRITE(U6,100) IF(IMERR1.EQ.0)IMERR1=90001 ELSE WRITE(U6,101)IUNIT IF(IMERR1.EQ.0)IMERR1=90002 END IF CALL FSTOP END C SUBROUTINE INTIN(IUNIT,IX,TSIZE,ENDFLE) C INTEGER IUNIT,TSIZE LOGICAL ENDFLE INTEGER IX(TSIZE) C C IUNIT - FORTRAN unit number C IX - integer array to read C TSIZE - size of IX C ENDFLE - end of file indicator. C C Reads unformatted integers in blocks of 64 by calling INTIN0 C ENDFLE=.FALSE. IF(TSIZE.LE.0)RETURN DO 10 I=1,TSIZE,64 IF(I+63.GT.TSIZE) THEN J=TSIZE-I+1 ELSE J=64 END IF CALL INTIN0(IUNIT,IX(I),J,ENDFLE) IF(ENDFLE) GO TO 20 10 CONTINUE 20 CONTINUE RETURN END C SUBROUTINE INTIN0(IUNIT,IX,TSIZE,ENDFLE) C C IUNIT - FORTRAN unit number C IX - integer array to read C TSIZE - size of IX C ENDFLE - end of file indicator. C INTEGER IUNIT,TSIZE LOGICAL ENDFLE INTEGER IX(TSIZE) C C Read of integer array matrix C READ(IUNIT,END=10,ERR=20)IX RETURN 10 CONTINUE ENDFLE=.TRUE. RETURN 20 CONTINUE CALL FRSTOP(IUNIT) END C SUBROUTINE INTOUT(IUNIT,IX,TSIZE) C INTEGER IUNIT,TSIZE INTEGER IX(TSIZE) C C IUNIT - FORTRAN unit number C IX - integer array to read C TSIZE - size of IX C C Writes blocks of unformatted integers in blocks of 64 by calling C INTOU0 C IF(TSIZE.LE.0)RETURN DO 10 I=1,TSIZE,64 IF(I+63.GT.TSIZE) THEN J=TSIZE-I+1 ELSE J=64 END IF CALL INTOU0(IUNIT,IX(I),J) 10 CONTINUE RETURN END C SUBROUTINE INTOU0(IUNIT,IX,TSIZE) C INTEGER IUNIT,TSIZE INTEGER IX(TSIZE) C C IUNIT - FORTRAN unit number C IX - integer array to read C TSIZE - size of IX C WRITE(IUNIT,ERR=20)IX RETURN 20 CONTINUE CALL FWSTOP(IUNIT) END C SUBROUTINE IUFIND(IUNIT) C INTEGER IUNIT C C Returns a possible unit number from 20-99 not currently in C use. C C Note: changed 9/26/98 to reserve 18+19 as scratch, avoid use C of 18+19, upper limit of 99 instead of 39 C PARAMETER (MAXALT=5) PARAMETER (MSIZED=1000000) DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 INTEGER U5ALT(MAXALT),U5ASTT(MAXALT) COMMON /A5BLCK/U5ALT,U5ASTT C INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW, . OSCODE,NEWFNM COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE, . ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM CHARACTER*256 CARDWK,CARDSV,CARDIM COMMON /CMBLK2/CARDWK,CARDSV,CARDIM C LOGICAL FOPEND C 200 FORMAT(' COULD NOT ASSIGN UNIT') 201 FORMAT(5X,'Assigned to unit',I3) 202 FORMAT(1X) IUNIT=20 10 CONTINUE IF(IUNIT.EQ.U5.OR.IUNIT.EQ.U6)GO TO 15 DO 12 I=1,MAXALT IF(IUNIT.EQ.U5ALT(I))GO TO 15 12 CONTINUE INQUIRE(UNIT=IUNIT,OPENED=FOPEND) IF(.NOT.FOPEND) THEN IF(CMPFLG.EQ.1) THEN CALL STBLNK(CARDWK,1,256) WRITE(CARDWK,201)IUNIT WRITE(13)CARDWK CALL STBLNK(CARDWK,1,256) WRITE(13)CARDWK NLINE=NLINE+2 CALL ROOMD(2) IF(U5ENOW.GE.1) THEN DX(NXPTD-2)=1 DX(NXPTD-1)=1 ELSE DX(NXPTD-2)=0 DX(NXPTD-1)=0 END IF ELSE IF(U5ECHO.EQ.1) THEN WRITE(U6,201)IUNIT END IF END IF RETURN END IF 15 CONTINUE IUNIT=IUNIT+1 IF(IUNIT.EQ.100) THEN C C Error message if no more units. C CALL FESTOP(90200) END IF GO TO 10 END C SUBROUTINE SCPOSN(ISUB,NCELL) C INTEGER ISUB,NCELL C C ISUB - number of subroutine writing file C NCELL - size of stored data C C During TRANSFORM, positions scratch file to data stored for C subroutine ISUB and returns NCELL. C The scratch file is laid out as a series of records. A record C containing ISUB and NCELL as integers is followed by NCELL C double precision values blocked in records of length 32. C PARAMETER (MSIZED=1000000) COMMON /DBLOCK/DX DOUBLE PRECISION DX(MSIZED) INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C LOGICAL ENDFLE C C First, test if file is in currect position already. C ENDFLE=.FALSE. READ(13,END=2)ISUBIN,NCELL GO TO 4 2 CONTINUE ENDFLE=.TRUE. 4 CONTINUE C C If necessary, rewind file to search from the beginning. C IF(ISUBIN.GT.ISUB.OR.ENDFLE) THEN REWIND(13) READ(13,END=90)ISUBIN,NCELL END IF IF(ISUBIN.EQ.ISUB)GO TO 80 NXPTDS=NXPTD CALL ROOMD(32) 5 CONTINUE DO 10 I=1,NCELL,32 IF(I+32.GT.NCELL) THEN J=NCELL-I+1 ELSE J=32 END IF CALL UNFIN0(13,DX(NXPTDS),J,ENDFLE) 10 CONTINUE READ(13)ISUBIN,NCELL IF(ISUBIN.LT.ISUB) THEN GO TO 5 ELSE IF(ISUBIN.GT.ISUB) THEN GO TO 90 END IF NXPTD=NXPTDS 80 CONTINUE RETURN 90 CONTINUE CALL FESTOP(90201) END C SUBROUTINE PREAMB C C Subroutine to read a VPLX file as the primary input and to C store the metadata in the COMMON arrays. C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) C C MVAR represents the maximum number of incoming and created C variables, replicate factors and wts C MLEVEL is the maximum number of stored labels for levels C MCRSSD is the maximum number of pointers for crossed arrays C MCLBLK is the maximum number of class blocks C MCLBAR is the maximum number of cells of class block arrays C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT C INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C LOGICAL ENDFLE C 202 FORMAT(' INCOMING VERSION NUMBER:',I12) C READ(12,ERR=51)IVERSN GO TO 52 51 CONTINUE IMERR1=90105 CALL FRSTOP(12) 52 CONTINUE IF(IVERSN.NE.9004.AND.IVERSN.NE.9203) THEN WRITE(U6,202)IVERSN CALL FESTOP(90106) END IF READ(12,ERR=99)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE, . VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR c write(*,*)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE, c . VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR CALL RCHECK(2,NVTOT,0) NID=NVARID+NBY IF(IVERSN.EQ.9004)NIDTOT=NID IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN IF(NVTOT.NE.NVREG+NCLASS+NVARID+NBY+NWGT-1) THEN WRITE(U6,*)VFTYPE,NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT END IF ELSE IF(NVTOT.NE.NVREG+NCLASS+NVARID+NBY+NWGT) THEN WRITE(U6,*)VFTYPE,NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT END IF END IF C C NVTOT - total number of variables on file C NVREG - number of variables, excluding class, variance id's, C BY variables, and weight variable C NCLASS - total number of class variables C NVARID - number of variance id's, excluding BY variables C NBY - number of BY variables C NWGT - 0 or 1 indicating unweighted vs. weighted analysis C VFTYPE - type of input used to create the file C VROPTN - variance option C NIDTOT - length of the ID records on the VPLX file C TSIZE - total size of matrix C NCLBLK - total number of class blocks C NCLBAR - total size of class block information arrays C C Note: NID is not on the file but is computed as NID=NVARID+NBY C for convenience of some subroutines C C VFTYPE = 3 Weighted obs. with cluster/replicate number C 4 Unweighted " C 5 Replicate weights C 6 Unweighted initial obs. followed by replicate weights C 7 Replicate factors multiplying initial weight C 8 Replicate factors of unweighted initial obs ( = VFTYPE 6) C 11 Replicate factors multiplying initial weight, including C factor for replicate 0, overall estimate C 12 Unweighted initial obs " (= VFTYPE 5) C 13 Weighted obs. with cluster code C 14 Unweighted " C 15 Weighted obs. Stratum no. cluster code C 16 Unweighted " C 17 Wtd. Stratum code, cluster code C 18 Unwtd " C 21 Wtd. Stratum no. 2nd stage no, cluster code C 22 Unwtd. " C 23 Wtd. Stratum no. 2nd stage cd, cluster code C 24 Unwtd. " C 25 Wtd. Stratum code 2nd stage no. cluster code C 26 Unwtd " C 27 Wtd. Stratum code 2nd stage cd, cluster code C 28 Unwtd. " C 29 Wtd 2nd stage number cluster code C 30 Unwtd. " C 31 Wtd 2nd stage code cluster code C 32 Unwtd " C 33 Wtd Replicate number governed by stratum counts C 34 Unwtd " C 35 Wtd Rep numb govrned by stratum and 2nd stage counts C 36 Unwtd " C 37 Wtd Rep number governed by 2nd stage counts C 38 Unwtd " C CALL RCHECK(8,NCLBLK,0) CALL RCHECK(9,NCLBAR,0) DO 1 I=1,NCLBLK READ(12,ERR=99)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I), . BLVSIZ(I),BLNCLS(I),BLCPNT(I) c write(*,*)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I), c . BLVSIZ(I),BLNCLS(I),BLCPNT(I) 1 CONTINUE IF(NCLBAR.GT.0) THEN CALL INTIN(12,CLTYPE,NCLBAR,ENDFLE) CALL INTIN(12,CLPNT,NCLBAR,ENDFLE) END IF C C BLTYPE - 1 or 0 indicating row of (weighted) n vs. no row C BLXSTR - pointer to first cell of incoming data in X matrix C BLXINC - length of the X matrix for a single combination C of the class variables in the block C BLXSIZ - total size of block data in X matrix (integer multiple C of BLXINC) C BLVSTR - pointer to first variable C BLVSIZ - number of variables in block C BLNCLS - number of class variables in block C BLCPNT - pointer for class information C CLTYPE - type of class in array C CLPNT - pointer to class variables C IF(NVTOT.GT.0)CALL INTIN(12,MTYPE,NVTOT,ENDFLE) C if(nvtot.gt.0)write(*,*)(mtype(i),i=1,nvtot) C C Variable types are read into MTYPE C C Contents of MTYPE C 1 = real variable (total) C 2 = real variable with missing checks C 3 = categorical variable C 4 = class variable, known dimension C 5 = by variable, known dimension C 6 = by variable, unknown dimension C 7 = select transformation (not variable type) C 8 = cross variable, real value C 9 = cross variable, categorical C 11 = derived variable C 13 = crossed derived variable, single dimension C 19 = crossed derived variable C IF(NVTOT.GT.0)CALL INTIN(12,MSIZE,NVTOT,ENDFLE) c if(nvtot.gt.0)write(*,*)(msize(i),i=1,nvtot) C C Sizes are read into MSIZE C IF(NVREG.GT.0)CALL INTIN(12,VMAPL,NVREG,ENDFLE) c if(nvtot.gt.0)write(*,*)(vmapl(i),i=1,nvreg) C C VMAPL contains pointers to the first NVREG variables C READ(12,ERR=99)NCRSSD c write(*,*)ncrssd CALL RCHECK(10,NCRSSD,0) IF(NCRSSD.GT.0)CALL INTIN(12,CROSSD,NCRSSD,ENDFLE) ILC=1 C C Create an array of pointers, CDMPNT, from the variables to C the starting entries in CROSSD C DO 3 I=1,NVTOT J=MTYPE(I) IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN CDMPNT(I)=ILC ILC=CROSSD(ILC)+ILC+2 ELSE CDMPNT(I)=0 END IF 3 CONTINUE IF(NCRSSD+1.NE.ILC) THEN CALL FESTOP(90107) END IF ILC=0 C C Read variable names and labels, and create an array of pointers, C LPOINT, to labels for the levels of the variables C DO 6 I=1,NVTOT READ(12,ERR=99)VNAME(I),LABEL(I) J=MTYPE(I) IF(J.EQ.3.OR.J.EQ.4.OR.J.EQ.5.OR.J.EQ.13) THEN LPOINT(I)=ILC+1 ILC=ILC+MSIZE(I) ELSE IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN LPOINT(I)=ILC+1 K=CDMPNT(I) L=CROSSD(K) DO 4 M=1,L K=K+1 ILC=ILC+CROSSD(K)+1 4 CONTINUE ELSE LPOINT(I)=0 END IF 6 CONTINUE C C Read in labels for the levels C READ(12,ERR=99)NCRVL c write(*,*)ncrvl CALL RCHECK(7,NCRVL,0) IF(ILC.NE.NCRVL) THEN CALL FESTOP(90108) END IF IF(ILC.GT.0) THEN DO 10 I=1,ILC READ(12,ERR=99)LEVEL(I) 10 CONTINUE END IF READ(12,ERR=99)ILC C C Read in variable names for crossed variables C CALL RCHECK(13,ILC,0) SVTEMP=ILC+1 DO 12 I=1,ILC READ(12,ERR=99)VTEMP(I) 12 CONTINUE IF(NBY.GE.1) THEN READ(12,ERR=99)NBYGRP SDBYID=NXPTD K=NBYGRP*NBY CALL ROOMD(K) K=SDBYID-1 DO 17 I=1,NBYGRP READ(12,ERR=99)(DX(K+J),J=1,NBY) K=K+NBY 17 CONTINUE ELSE SDBYID=0 NBYGRP=1 END IF READ(12,ERR=99)NRPTOT IF(NRPTOT.GT.0) THEN SDCOEF=NXPTD CALL ROOMD(NRPTOT) CALL UNFIN(12,DX(SDCOEF),NRPTOT,ENDFLE) ELSE SDCOEF=0 END IF RETURN 99 CONTINUE CALL FRSTOP(12) END C SUBROUTINE PREAMO C C Subroutine to write a VPLX file as the primary output, exactly C reversing the logic of PREAMB C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) C C MVAR represents the maximum number of incoming and created C variables, replicate factors and wts C MLEVEL is the maximum number of stored labels for levels C MCRSSD is the maximum number of pointers for crossed arrays C MCLBLK is the maximum number of class blocks C MCLBAR is the maximum number of cells of class block arrays C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT C INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C 200 FORMAT(' ERROR: STORED INTEGER VALUE:',I8,3X,'RECOMPUTED:',I8) C WRITE(11,ERR=99)IVERSN WRITE(11,ERR=99)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE, . VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR C C DO 1 I=1,NCLBLK WRITE(11,ERR=99)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I), . BLVSIZ(I),BLNCLS(I),BLCPNT(I) 1 CONTINUE IF(NCLBAR.GT.0) THEN CALL INTOUT(11,CLTYPE,NCLBAR) CALL INTOUT(11,CLPNT,NCLBAR) END IF C IF(NVTOT.GT.0)CALL INTOUT(11,MTYPE,NVTOT) C C IF(NVTOT.GT.0)CALL INTOUT(11,MSIZE,NVTOT) C C Sizes are read into MSIZE C IF(NVREG.GT.0)CALL INTOUT(11,VMAPL,NVREG) C C C Recompute, based on the entries in CROSSD, the expected number C for NCRSSD and also compute the number of variable names for C levels store in VNTEMP. C ILC1=0 ILC2=0 DO 3 I=1,NVTOT J=MTYPE(I) IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN ILC2=CROSSD(ILC1+1)+ILC2 ILC1=CROSSD(ILC1+1)+ILC1+2 END IF 3 CONTINUE IF(NCRSSD.NE.ILC1) THEN WRITE(U6,200)NCRSSD,ILC1 CALL FESTOP(90111) END IF WRITE(11,ERR=99)NCRSSD IF(NCRSSD.GT.0)CALL INTOUT(11,CROSSD,NCRSSD) C C Write variable names and labels C ILC3=0 DO 6 I=1,NVTOT WRITE(11,ERR=99)VNAME(I),LABEL(I) J=MTYPE(I) IF(J.EQ.3.OR.J.EQ.4.OR.J.EQ.5.OR.J.EQ.13) THEN ILC3=ILC3+MSIZE(I) ELSE IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN K=CDMPNT(I) L=CROSSD(K) DO 4 M=1,L K=K+1 ILC3=ILC3+CROSSD(K)+1 4 CONTINUE END IF 6 CONTINUE IF(ILC3.NE.NCRVL) THEN WRITE(U6,200)NCRVL,ILC3 CALL FESTOP(90112) END IF C C Write labels for the levels C WRITE(11,ERR=99)NCRVL IF(NCRVL.GT.0) THEN DO 10 I=1,NCRVL WRITE(11,ERR=99)LEVEL(I) 10 CONTINUE END IF WRITE(11,ERR=99)ILC2 C C Write variable names for crossed variables C IF(ILC2.GT.0) THEN DO 12 I=1,ILC2 WRITE(11,ERR=99)VTEMP(I) 12 CONTINUE END IF IF(NBY.GE.1) THEN WRITE(11,ERR=99)NBYGRP K=SDBYID-1 DO 17 I=1,NBYGRP WRITE(11,ERR=99)(DX(K+J),J=1,NBY) K=K+NBY 17 CONTINUE END IF WRITE(11,ERR=99)NRPTOT IF(NRPTOT.GT.0) THEN CALL UNFOUT(11,DX(SDCOEF),NRPTOT) END IF RETURN 99 CONTINUE CALL FWSTOP(11) END C SUBROUTINE SCOPEN(IUNIT) C INTEGER IUNIT C C IUNIT - unit number, 13-17, to open as scratch file. C C If IUNIT is already open, rewind the file, else open a C scratch file. C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 LOGICAL FOPEND INQUIRE(UNIT=IUNIT,OPENED=FOPEND) 100 FORMAT(/,5X,'Unnamed scratch file opened on unit',I3) IF(.NOT.FOPEND) THEN OPEN(UNIT=IUNIT,FORM='UNFORMATTED',STATUS='SCRATCH',ERR=10) IF(U5ECHO.GT.0)WRITE(U6,100)IUNIT ELSE REWIND(UNIT=IUNIT) END IF RETURN 10 CONTINUE CALL FESTOP(90209) RETURN END C SUBROUTINE UNFIN(IUNIT,DX,TSIZE,ENDFLE) C INTEGER IUNIT,TSIZE LOGICAL ENDFLE DOUBLE PRECISION DX(TSIZE) C C IUNIT - unit number C DX - matrix to read C TSIZE - size of DX C ENDFLE - end of file C C This routine reads double precision numbers in records of size C 32 by repeated calls to UNFIN0 C ENDFLE=.FALSE. IF(TSIZE.LE.0)RETURN DO 10 I=1,TSIZE,32 IF(I+31.GT.TSIZE) THEN J=TSIZE-I+1 ELSE J=32 END IF CALL UNFIN0(IUNIT,DX(I),J,ENDFLE) IF(ENDFLE) GO TO 20 10 CONTINUE 20 CONTINUE RETURN END C SUBROUTINE UNFIN0(IUNIT,DX,TSIZE,ENDFLE) C INTEGER IUNIT,TSIZE LOGICAL ENDFLE DOUBLE PRECISION DX(TSIZE) C C IUNIT - unit number C DX - matrix to read C TSIZE - size of DX C ENDFLE - end of file C READ(IUNIT,END=10,ERR=20)DX RETURN 10 CONTINUE ENDFLE=.TRUE. RETURN 20 CONTINUE CALL FRSTOP(IUNIT) END C SUBROUTINE UNFOUT(IUNIT,DX,TSIZE) C INTEGER IUNIT,TSIZE DOUBLE PRECISION DX(TSIZE) C C IUNIT - unit number C DX - matrix to write C TSIZE - size of DX C C This routine writes double precision numbers in records of size C 32 by repeated calls to UNFOU0 C C IF(TSIZE.LE.0)RETURN DO 10 I=1,TSIZE,32 IF(I+31.GT.TSIZE) THEN J=TSIZE-I+1 ELSE J=32 END IF CALL UNFOU0(IUNIT,DX(I),J) 10 CONTINUE RETURN END SUBROUTINE UNFOU0(IUNIT,DX,TSIZE) C INTEGER IUNIT,TSIZE DOUBLE PRECISION DX(TSIZE) C C IUNIT - unit number C DX - matrix to read C TSIZE - size of DX C WRITE(IUNIT,ERR=20)DX 10 CONTINUE RETURN 20 CONTINUE CALL FWSTOP(IUNIT) END C C SUBROUTINE OPENCH C C Checks whether file in FNWRK is already opened. If the file C is open, the run terminates in error. C PARAMETER (MAXFMT=20) C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C LOGICAL FOPEND C 100 FORMAT(' ALREADY OPENED ON UNIT',I3) 101 FORMAT(1X,A80) C CALL FINQOP(FOPEND) IF(FOPEND) THEN CALL FINQIU(I) WRITE(U6,100)I WRITE(U6,101)FNWRK(1:80) IMERR1=90202 RETURN END IF RETURN END C C The following routines require changes to run in IBM CMS or MVS C environments. C There are also some VMS specific features. C SUBROUTINE FINQEX(FEXIST) C LOGICAL FEXIST C C Check whether the file FNWRK already exists. C PARAMETER (MAXFMT=20) C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT C CALL FNLGTH(I) C C CALL IBMFII C INQUIRE(FILE=FNWRK(1:I),EXIST=FEXIST) RETURN END C SUBROUTINE FINQFM(KEYWRD) C CHARACTER*12 KEYWRD C C Keyword - FORTRAN-supplied UNFORMATTED, FORMATTED, returned by C INQUIRE C C Routine to determine the format of a given file in FNWRK. C PARAMETER (MAXFMT=20) C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT C CALL FNLGTH(I) C C CALL IBMFII C INQUIRE(FILE=FNWRK(1:I),FORM=KEYWRD) RETURN END C SUBROUTINE FINQIU(IUNIT) C C IUNIT - unit number where file is opened. C C Check whether the file named in FNWRK is already open. C INTEGER IUNIT PARAMETER (MAXFMT=20) C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT C CALL FNLGTH(I) C C CALL IMBFII C INQUIRE(FILE=FNWRK(1:I),NUMBER=IUNIT) RETURN END C SUBROUTINE FINQOP(FOPEND) C LOGICAL FOPEND C C FOPEND - logical returned as "true" if the file in FNWRK is already C opened, false otherwise. C PARAMETER (MAXFMT=20) C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT C CALL FNLGTH(L) C C CALL IBMFII C INQUIRE(FILE=FNWRK(1:L),OPENED=FOPEND) RETURN END C SUBROUTINE OPENG(IUNIT) C C IUNIT - An available unit number. C An open subroutine used to open a file in order to delete it. C PARAMETER (MAXFMT=20) C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT C CALL FNLGTH(L) C C CALL IBMFIR C OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),STATUS='UNKNOWN',ERR=10) RETURN 10 CONTINUE CALL FESTOP(90204) END C SUBROUTINE OPENRF(IUNIT) C C IUNIT - unit number to open. C Open file for formatted reading. C PARAMETER (MAXFMT=20) C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C 100 FORMAT(' ATTEMPTED OPEN FOR FORMATTED READING ON UNIT',I3) CALL FNLGTH(L) CALL OPENCH IF(IMERR1.GT.0) THEN WRITE(U6,100)IUNIT IF(U5.GE.13.AND.U5.LE.17) THEN RETURN ELSE CALL FSTOP END IF END IF C C CALL IBMFIR C OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),FORM='FORMATTED',STATUS='OLD', . ERR=10) C C VAX-specific form of the OPEN statement to take advantage of the C READONLY option. C C OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),FORM='FORMATTED',STATUS='OLD', C . READONLY,ERR=10) C C RETURN 10 CONTINUE IMERR1=90205 RETURN END C SUBROUTINE OPENRU(IUNIT) C INTEGER IUNIT c C IUNIT - unit number to open. C Open file for unformatted reading. C PARAMETER (MAXFMT=20) C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT C 100 FORMAT(' ATTEMPTED OPEN FOR UNFORMATTED READING ON UNIT',I3) CALL FNLGTH(L) CALL OPENCH IF(IMERR1.GT.0) THEN WRITE(U6,100)IUNIT IF(U5.GE.13.AND.U5.LE.17) THEN RETURN ELSE CALL FSTOP END IF END IF C C CALL IBMFIR C OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),FORM='UNFORMATTED',STATUS='OLD', C . RECFM='VBS',ACTION='READ') C OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),FORM='UNFORMATTED',STATUS='OLD', . ERR=10) C C VAX-specific form of the OPEN statement to take advantage of the C READONLY option. C C OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),FORM='UNFORMATTED',STATUS='OLD', C . READONLY,ERR=10) C RETURN 10 CONTINUE IMERR1=90206 END C SUBROUTINE OPENSC(IUNIT) C INTEGER IUNIT C C IUNIT - unit number to open. C Open named scratch file. This routine is used exclusively C by REFRSH for SCRATCH1 etc. C PARAMETER (MAXFMT=20) C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW, . OSCODE,NEWFNM COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE, . ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM C LOGICAL FOPEND C CALL FNLGTH(L) INQUIRE(UNIT=IUNIT,OPENED=FOPEND) IF(FOPEND) THEN CLOSE(UNIT=IUNIT,STATUS='DELETE') END IF CALL CMATCH(FNWRK(137:139),137,139,'NEW',3,I,1) CALL CMATCH(FNWRK(137:143),137,143,'UNKNOWN',7,J,1) IF(I.GT.0.OR.(OSCODE.NE.1.AND.J.EQ.0)) THEN INQUIRE(FILE=FNWRK(1:L),EXIST=FOPEND) IF(FOPEND) THEN IMERR1=90210 RETURN END IF END IF OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),FORM='UNFORMATTED', . STATUS='UNKNOWN',ERR=10) RETURN 10 CONTINUE IMERR1=90203 RETURN END C SUBROUTINE OPENWF(IUNIT) C INTEGER IUNIT c C IUNIT - unit number to open. C Open file for formatted writing. C PARAMETER (MAXFMT=20) C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT LOGICAL FEXIST C 100 FORMAT(' ATTEMPTED OPEN FOR FORMATTED WRITING ON UNIT',I3) CALL FNLGTH(L) CALL OPENCH IF(IMERR1.GT.0) THEN WRITE(U6,100)IUNIT IF(U5.GE.13.AND.U5.LE.17) THEN RETURN ELSE CALL FSTOP END IF END IF C C CALL IBMFIF C C If the file exists, open it and delete it first. This feature C ensures on the VAX system that the output will receive a current C date. C CALL FINQEX(FEXIST) IF(FEXIST) THEN CALL OPENG(IUNIT) CLOSE(UNIT=IUNIT,STATUS='DELETE') END IF OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),FORM='FORMATTED',STATUS='UNKNOWN', . ERR=10) C C VAX-specific form of the OPEN statement with CARRIAGECONTROL option C to produce a FORTRAN-readable output file without FORTRAN carriage C control. If RECF has been specified, include this in the open C statement. C C 100 FORMAT(I8) C READ(FNWRK(113:120),100)IRECL C IF(IRECL.LE.0) THEN C OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),FORM='FORMATTED', C . STATUS='UNKNOWN',CARRIAGECONTROL='LIST',ERR=10) C ELSE C OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),FORM='FORMATTED', C . STATUS='UNKNOWN',CARRIAGECONTROL='LIST',RECL=IRECL,ERR=10) C END IF C RETURN 10 CONTINUE IMERR1=90207 RETURN END C SUBROUTINE OPENWU(IUNIT) C INTEGER IUNIT C C IUNIT - unit number to open. C Open file for unformatted writing. C PARAMETER (MAXFMT=20) C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT LOGICAL FEXIST C 100 FORMAT(' ATTEMPTED OPEN FOR UNFORMATTED WRITING ON UNIT',I3) CALL FNLGTH(L) CALL OPENCH IF(IMERR1.GT.0) THEN WRITE(U6,100)IUNIT IF(U5.GE.13.AND.U5.LE.17) THEN RETURN ELSE CALL FSTOP END IF END IF C C CALL IBMFIU C C If the file exists, open it and delete it first. C CALL FINQEX(FEXIST) IF(FEXIST) THEN CALL OPENG(IUNIT) CLOSE(UNIT=IUNIT,STATUS='DELETE') END IF OPEN(UNIT=IUNIT,FILE=FNWRK(1:L),FORM='UNFORMATTED', . STATUS='UNKNOWN',ERR=10) RETURN 10 CONTINUE IMERR1=90208 RETURN END C C End of I.FOR C C C Start of SC.FOR - general parsing routines. C LOGICAL FUNCTION ALPCHK(C) C CHARACTER*1 C C C Returns TRUE if character is alphabetic or underscore C CHARACTER*1 ALPHA1(26),ALPHA2(26) DATA ALPHA1/ 'A','B','C','D','E','F','G','H','I','J','K','L', . 'M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/ DATA ALPHA2/ 'a','b','c','d','e','f','g','h','i','j','k','l', . 'm','n','o','p','q','r','s','t','u','v','w','x','y','z'/ C DO 1 I=1,26 IF(C.EQ.ALPHA1(I).OR.C.EQ.ALPHA2(I)) THEN ALPCHK=.TRUE. RETURN END IF 1 CONTINUE IF(C.EQ.'_') THEN ALPCHK=.TRUE. ELSE ALPCHK=.FALSE. END IF RETURN END C LOGICAL FUNCTION BCHECK(C,BASE,TOP) C INTEGER BASE,TOP CHARACTER*(*) C C C C - character variable to be checked for blanks C BASE - starting position in calling routine of the segment to be C checked. C TOP - ending position in calling routine to be checked. C C Returns TRUE if C(BASE:TOP) is all blank. C C Note: call is of the form BCHECK(C(BASE:TOP),BASE,TOP) C LEN=TOP-BASE+1 DO 1 I=1,LEN IF(C(I:I).NE.' ') THEN BCHECK=.FALSE. RETURN END IF 1 CONTINUE BCHECK=.TRUE. RETURN END C SUBROUTINE CRDPRN(LSKIP) C INTEGER LSKIP C C Subroutine to print one line from the command file, indicating C substitutions, if any. C C LSKIP - 0 no line skip, do not print under ECHO LITE unless a C substitution is made. It is used, for example, C for normal continuation lines. C - 1 skip one line, do not print under ECHO LITE unless C substitution - normal printing for lines beginning C with a keyword C - 2 skip no line, print under all circumstances (e.g., C error messages) C - 3 skip one line, print under ECHO LITE or ECHO (e.g., C 1st line of step) C - 4 on the basis of IMERR2, indicate error position with C a $ - used only while displaying information about C a fatal error C C The routine recognizes comments following ! C It prints them, but always blanks them out in CARD before return C When substitutions occur, it prints CARDIN first, but only C duplicates comments if substitutions occur within the comment C PARAMETER (MAXSUB=500,MAXSBL=2000,MAXSNL=24) PARAMETER (MAXSBC=6000) INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI, . NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL), . U5LCSW COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI, . NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 CHARACTER*80 CARDIN CHARACTER*8 LFMT CHARACTER*(MAXSNL) SUBNAM(MAXSUB) CHARACTER*12 SUBCSV(MAXSBC) COMMON /CINBLK/CARDIN,SUBNAM,SUBCSV INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW, . OSCODE,NEWFNM COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE, . ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM CHARACTER*256 CARD COMMON /CRDBLK/CARD CHARACTER*256 CARDWK,CARDSV,CARDIM COMMON /CMBLK2/CARDWK,CARDSV,CARDIM C 100 FORMAT(1X) 101 FORMAT(1X,A79) 102 FORMAT(1X,A80) 103 FORMAT(1X,A76,'(-)') 104 FORMAT(2X,A78) 105 FORMAT(2X,A75,'(-)') 106 FORMAT(2X,A30) 107 FORMAT('(1X,A',I1,')') 108 FORMAT('(1X,A',I2,')') 109 FORMAT(5X,'Approximate position of error marked by ''$'' above') C IAPOST=0 IEXCLM=0 CALL LASTCI(ILAST) DO 2 I=1,ILAST C ! Determine IEXCLM, IF(IAPOST.EQ.1) THEN C ! beginning of comment, IF(CARDIM(I:I).EQ.'''') THEN C ! if any, in CARDIM IAPOST=0 END IF ELSE IF(IAPOST.EQ.2) THEN IF(CARDIM(I:I).EQ.'"') THEN IAPOST=0 END IF ELSE IF(CARDIM(I:I).EQ.'''') THEN IAPOST=1 ELSE IF(CARDIM(I:I).EQ.'"') THEN IAPOST=2 ELSE IF(CARDIM(I:I).EQ.'!') THEN IF(IEXCLM.EQ.0) THEN IEXCLM=I END IF GO TO 4 END IF 2 CONTINUE 4 CONTINUE IEXCL2=0 IAPOST=0 DO 6 I=1,80 C ! Determine IEXCL2 IF(IAPOST.EQ.1) THEN C ! beginning of comment, IF(CARDIN(I:I).EQ.'''') THEN C ! if any, in CARDIN IAPOST=0 END IF ELSE IF(IAPOST.EQ.2) THEN IF(CARDIN(I:I).EQ.'"') THEN IAPOST=0 END IF ELSE IF(CARDIN(I:I).EQ.'''') THEN IAPOST=1 ELSE IF(CARDIN(I:I).EQ.'"') THEN IAPOST=2 ELSE IF(CARDIN(I:I).EQ.'!') THEN IF(IEXCL2.EQ.0) THEN IEXCL2=I END IF GO TO 8 END IF 6 CONTINUE 8 CONTINUE C C Return under ECHO OFF unless LSKIP indicates to print under all C circumstances/ C IF(U5ECHO.EQ.0.AND.LSKIP.NE.2.AND. . LSKIP.NE.4) THEN IF(IEXCLM.GT.0) THEN C ! If comments, always IF(CMPFLG.EQ.0) THEN C ! blank if CMPFLG = 0 CALL STBLNK(CARDIM,IEXCLM,256) ELSE IF(IEXCL2.GT.0) THEN C ! If CMPFLG = 1, blank IF(CARDIN(IEXCL2:80).EQ. C ! if substitution . CARDIM(IEXCLM:IEXCLM+80-IEXCL2).AND. C ! but no . CARDIN.NE.CARDIM(1:80)) THEN C ! substitution in CALL STBLNK(CARDIM,IEXCLM,256) C ! comment END IF END IF END IF RETURN END IF C C IMATCH is used to determine whether to print a card once (=1) C or twice (=0): before and after substitutions. For LSKIP=4 only C print the result of substitution. C C CININI (in common array) - 1 usual line C 0 part of multi-line substitution C IF(CININI.EQ.1) THEN IF(U5.GE.13.AND.U5.LE.17) THEN IMATCH=1 ELSE IF(CARDIN.EQ.CARDIM(1:80)) THEN IMATCH=1 ELSE IMATCH=0 END IF ELSE IMATCH=0 END IF C C Determination of whether to skip a line before printing card. C CININI=0 if this line is part of a multi-line substitution and C not the first line. Usually, CININI=1. Skip a line if LSKIP=4. C IF((CININI.EQ.1.AND.(IMATCH.EQ.0.OR.LSKIP.EQ.3.OR. . (LSKIP.EQ.1.AND.U5ECHO.EQ.1))).OR.LSKIP.EQ.4) THEN WRITE(U6,100) END IF C C Print input card if substitutions occur. C IF(IMATCH.EQ.0.AND.CININI.EQ.1) THEN C C In Microsoft Powerstation implementation, the input line may be an C special end-of-file - determine this by call to the standard FORTRAN C function ICHAR. Do not attempt to print the line in this case. C This test should not affect other FORTRAN implementations. C ITEST=ICHAR(CARDIN(1:1)) IF(ITEST.NE.26) THEN IF(CARDIN(80:80).EQ.' ') THEN WRITE(U6,101)CARDIN(1:79) ELSE WRITE(U6,102)CARDIN END IF C C If the line includes a comment following '!', see if C substitutions have modified the comment itself. If not, C blank out the matching section of CARD to avoid a redundant C printing of the comment. C IF(IEXCLM.GT.0) THEN IF(IEXCL2.GT.0) THEN IF(CARDIN(IEXCL2:80).EQ. . CARDIM(IEXCLM:IEXCLM+80-IEXCL2)) THEN CALL STBLNK(CARDIM,IEXCLM,256) END IF END IF END IF END IF END IF C C For LSKIP=4, set up the '$' in the appropriate position in CARDIN. C Just in case, adjust IMERR2 to be no more than 1 + the last position C on the card. C IF(LSKIP.EQ.4.AND.IMERR2.GT.0) THEN CALL STBLNK(CARDIN,1,80) CALL LASTCI(ILAST) IF(IMERR2.GT.ILAST)IMERR2=ILAST+1 C C ILAST is used here and below to indicate the last character to be C printed. Usually, ILAST < 80 and this approach economizes on the C size of the print file compared to printing each line to 79. C IF(IMERR2.GT.ILAST)ILAST=IMERR2 IF(ILAST.LE.80) THEN CARDIN(IMERR2:IMERR2)='$' ELSE IF(IMERR2.LE.76) THEN CARDIN(IMERR2:IMERR2)='$' ELSE C C Compute K as the relative position in CARDIN when the $ will C appear after the first displayed line. C IF(ILAST.LE.154) THEN K=IMERR2-76 ELSE IF(IMERR2.LE.151) THEN K=IMERR2-76 ELSE IF(ILAST.LE.229) THEN K=IMERR2-151 ELSE IF(IMERR2.LE.226) THEN K=IMERR2-151 ELSE K=IMERR2-226 END IF END IF END IF END IF CARDIN(K:K)='$' END IF END IF END IF C C Printing of the contents of CARD after substitutions. C IF(IMATCH.EQ.0.OR.U5ECHO.EQ.1.OR.(LSKIP.GE.2.AND.LSKIP.LE.4)) THEN C C Determine ILAST, the last character for display C CALL LASTCI(ILAST) IF(LSKIP.EQ.4) THEN IF(IMERR2.GT.ILAST)ILAST=IMERR2+1 END IF C IF(ILAST.EQ.80) THEN WRITE(U6,102)CARDIM(1:80) IF(LSKIP.EQ.4)WRITE(U6,102)CARDIN(1:80) ELSE IF(ILAST.LT.80) THEN C C By far, ILAST < 80 will be the most frequent. In this case, C construct an output format and write only CARDIM(1:ILAST) instead of C CARDIM(1:79) in order to reduce the size of the print file. C Construct a format in LFMT. C IF(ILAST.LE.9) THEN IF(ILAST.EQ.0)ILAST=1 WRITE(LFMT,107)ILAST ELSE WRITE(LFMT,108)ILAST END IF WRITE(U6,FMT=LFMT)CARDIM(1:ILAST) IF(LSKIP.EQ.4)WRITE(U6,FMT=LFMT)CARDIN(1:ILAST) C C For printing of lines (after substitution) longer than 80 C ELSE WRITE(U6,103)CARDIM(1:76) IF(LSKIP.EQ.4) THEN IF(IMERR2.LE.76) THEN WRITE(U6,103)CARDIN(1:76) C C If printing '$' here, skip an extra line to emphasize that it applies C to the line above it. C WRITE(U6,100) END IF END IF IF(ILAST.LE.154) THEN WRITE(U6,104)CARDIM(77:154) IF(LSKIP.EQ.4) THEN IF(IMERR2.GE.77.AND.IMERR2.LE.154) THEN WRITE(U6,104)CARDIN(1:78) END IF END IF ELSE WRITE(U6,105)CARDIM(77:151) IF(LSKIP.EQ.4) THEN IF(IMERR2.GE.77.AND.IMERR2.LE.151) THEN WRITE(U6,105)CARDIN(1:75) C C If printing '$' here, skip an extra line to emphasize that it applies C to the line above it. C WRITE(U6,100) END IF END IF IF(ILAST.LE.229) THEN WRITE(U6,104)CARDIM(152:229) IF(LSKIP.EQ.4) THEN IF(IMERR2.GE.152.AND.IMERR2.LE.229) THEN WRITE(U6,104)CARDIN(1:78) END IF END IF ELSE WRITE(U6,105)CARDIM(152:226) IF(LSKIP.EQ.4) THEN IF(IMERR2.GE.152.AND.IMERR2.LE.226) THEN WRITE(U6,105)CARDIN(1:75) C C If printing '$' here, skip an extra line to emphasize that it applies C to the line above it. C WRITE(U6,100) END IF END IF WRITE(U6,106)CARDIM(227:256) IF(LSKIP.EQ.4) THEN IF(IMERR2.GE.227.AND.IMERR2.LE.256) THEN WRITE(U6,106)CARDIN(1:30) END IF END IF END IF END IF END IF C C Also skip a line to set off a substitution. C IF(IMATCH.EQ.0.AND.ISUBCN.EQ.0.AND.ICHCNT.EQ.0)WRITE(U6,100) IF(LSKIP.EQ.4)WRITE(U6,109) END IF C IF(IEXCLM.GT.0) THEN ! Get to here under CMPFLG=0 C CALL STBLNK(CARDIM,IEXCLM,256) ! always blank comments C END IF C IF(IMERR1.GT.0.OR.IMERR2.GT.0) THEN C WRITE(U6,110)CARD(1:75) C 110 FORMAT(1X,'**',1X,A75) C END IF RETURN END C SUBROUTINE CLSCAN(BASE,IPOSN,IA,MAXIA,NSPTOT,VTMP,MVTMP,RANGET, . MAXRNG,RTYPET,RGRPT,NVIN) C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C INTEGER BASE,IPOSN,MAXIA,NSPTOT,MVTMP,MAXRNG,NVIN INTEGER IA(3,MAXIA),RTYPET(MAXRNG),RGRPT(MAXRNG) DOUBLE PRECISION RANGET(2,MAXRNG) CHARACTER*12 VTMP(MVTMP) C C Beginning at CARD(BASE:BASE), CLSCAN will scan CARD for class C specifications C C BASE - starting position, reset to 1 if CLSCAN reads another C card C IPOSN - position at end of class processing - returned by CLSCAN C set to 0 if at end of all continuation lines C IA - array encoding results of parsing - returned. A description C of the contents of this array is given by comments below. C MAXIA - maximum available rows in IA. CLSCAN will monitor to C avoid overfilling IA C NSPTOT - total number of rows of IA filled. CLSCAN will C identify one or more class groupings. A product of C class variables joined by * is considered a single C group C VTMP - a work array that CLSCAN uses to hold variable names C MVTMP - the size of VTMP C RANGET - an array that CLSCAN uses to hold ranges C MAXRNG - the maximum size of RANGET(2,MAXRNG), RTYPET, RGRPT C RTYPET - an array that CLSCAN uses to hold variable types C RGRPT - an array that CLSCAN uses to hold range groups C NVIN - the number of currently defined variables C PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) C C MVAR represents the maximum number of incoming and created C variables, replicate factors and weights C MLEVEL is the maximum number of stored labels for levels C MCRSSD is the maximum number of pointers for crossed arrays C MCLBLK is the maximum number of class blocks C MCLBAR is the maximum number of cells of class block arrays C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 CHARACTER*256 CARD COMMON /CRDBLK/CARD C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT C INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C LOGICAL REFRSH EXTERNAL REFRSH C 201 FORMAT(' UNRECOGNIZED VARIABLE NAME: ',A12) 203 FORMAT(' NOT A CLASS VARIABLE: ',A12) 204 FORMAT(' OVERFLOW IN CLSCAN ARRAY') 205 FORMAT(' IMPROPER RANGE: ',A12) 206 FORMAT(' PRODUCT WITH ITSELF: ',A12) C IPOSN=BASE C C Initial setting for NSPTOT. During CLSCAN, NSPTOT is generally C larger than the actual completed storage but represents the top of C the anticipated use of IA. It is set to the actual number of rows C just before returning, after 35 CONTINUE. C NSPTOT=2 IF(NSPTOT.GT.MAXIA)GO TO 90 C C IS - marks start of current series of class groupings. A set C of classes linked as a product by *'s is called a "group" C here. C ISTAR - flag to indicate * just read C IV1 - current class variable C IVTMP - current variable # read by VNFIND under consideration C NVTMP - number of variables read by VNFIND C ICLM - the product of the dimensions of the classes, to be C stored eventually into IA(3,IS) C NIV - number of class variables in the group, to be stored C eventually into IA(2,IS) C IS=1 IA(1,1)=0 IA(2,1)=0 IA(3,1)=0 ISTAR=0 IV1=0 IVTMP=0 NVTMP=0 ICLM=1 NIV=0 C C Storage into IA(3,*) (output from CLSCAN) C C IA(1,a) = number of rows in group, not counting row a C IA(2,a) = number of class variables referenced C IA(3,a) = product of dimensions of specified classes C IA(1,a+1) etc. number of class variable C IA(2,a+1) =0, IA(3,a+1) both zero - use all levels of class C IA(2,a+1) level of class (possibly including 0) C IA(3,a+1) group into which it falls 1, 2, etc. C 10 CONTINUE C C If no remaining continuation records, go to end C IF(IPOSN.EQ.0)GO TO 35 C C Find next non-blank character. If another card is read, reset C BASE. C CALL NBFND2(IPOSN,IPOS2) IF(IPOSN.EQ.1)BASE=1 C C If IPOS2=0, no remaining continuation lines. C IF(IPOS2.EQ.0) THEN IPOSN=0 GO TO 35 END IF IPOSN=IPOS2 IF(CARD(IPOSN:IPOSN).EQ.'*') THEN C C If encounter '*', error unless preceded by a class C IF(IV1.EQ.0) THEN CALL FPSTOP(160001,IPOSN) END IF C C Set ISTAR=1 and reset IV1 to 0 C ISTAR=1 IPOSN=IPOSN+1 IV1=0 GO TO 10 ELSE IF(CARD(IPOSN:IPOSN).EQ.',') THEN C C Processing of ',' is similar to '*', but ISTAR not set. C IPOSN=IPOSN+1 IV1=0 GO TO 10 ELSE IF(CARD(IPOSN:IPOSN).EQ.'(') THEN C C Processing of a range specification after a class variable. C C If encounter '(' generate an error message unless preceded by a class C IF(IV1.LE.0) THEN CALL FPSTOP(160002,IPOSN) END IF C IPOSN=IPOSN+1 C C The class has already been entered into IA without allowance for C the specification to follow in the parenthesis, hence must adjust C entries in IA already made. ICLM is divided by MSIZE(IV1) to undo C a previous multiplication by MSIZE(IV1) C NSPTOT=NSPTOT-1 ICLM=ICLM/MSIZE(IV1) C C The call to RNSCAN is used to determine the specified ranges, RNSCAN C will look for a ')' to end the specification. C CALL RNSCAN(IPOSN,IPOS2,RANGET,MAXRNG,RTYPET, . RGRPT,NR,3,LEVEL,1) C C Error if RNSCAN did not successfully find ranges. C IF(NR.LE.0) THEN IF(IPOSN.GT.1) IMERR2=IPOSN CALL FESTOP(160003) END IF C C Change BASE if new card read. C IF(IPOSN.EQ.1)BASE=1 IPOSN=IPOS2 C C IG - index for the number of levels specified C IPLUS - + included in range specification C IPLSV - retains plus from the previous level C C Interpret ranges from RNSCAN as levels of the class variable C IG=0 IPLSV=0 DO 15 IR=1,NR IRT=RTYPET(IR) IF(IRT.GT.6) THEN IPLUS=1 IRT=IRT-6 ELSE IPLUS=0 END IF C C Range type C 1 value1 - value2 C 2 LOW - value C 3 value - HIGH C 4 LOW - HIGH C 5 MISSING C 6 value - n C C Edit the range. C IF(IRT.EQ.5) THEN WRITE(U6,205)VNAME(IV1) CALL FESTOP(160004) ELSE IF(IRT.EQ.1.OR.IRT.EQ.3.OR.IRT.EQ.6) THEN I=RANGET(1,IR) IF(I.LT.0..OR.I.GT.MSIZE(IV1))GO TO 98 END IF IF(IRT.EQ.1.OR.IRT.EQ.2) THEN I=RANGET(2,IR) IF(I.LT.0..OR.I.GT.MSIZE(IV1))GO TO 98 END IF C C Loop over the possible levels of the class, including 0, C to determine what levels fall inside the range. C DO 12 I=0,MSIZE(IV1) DI=I IF(IRT.EQ.1) THEN IF(DI.LT.RANGET(1,IR).OR.DI.GT.RANGET(2,IR))GO TO 12 ELSE IF(IRT.EQ.2) THEN IF(DI.GT.RANGET(2,IR))GO TO 12 ELSE IF(IRT.EQ.3.OR.IRT.EQ.6) THEN IF(DI.LT.RANGET(1,IR))GO TO 12 END IF C C If a plus was not detected previously, increment the level C IF(IPLSV.EQ.0)IG=IG+1 C C Storage of the specification in the following manner. C C IA(1,a+1) etc. number of class variable C IA(2,a+1) level of class (possibly including 0) C IA(3,a+1) group into which it falls 1, 2, etc. C IA(1,NSPTOT)=IV1 IA(2,NSPTOT)=I IA(3,NSPTOT)=IG C C Increment NSPTOT and check that have not run out of space C NSPTOT=NSPTOT+1 IF(NSPTOT.GT.MAXIA)GO TO 90 12 CONTINUE C C Save whether a plus is given in the range specification to determine C incrementing of IG. C IPLSV=IPLUS 15 CONTINUE C C Accumulate the product of the specified dimensions. C ICLM=ICLM*IG GO TO 10 ELSE C C Processing of a class variable or TOTAL. C 20 CONTINUE C C If this class variable is not preceded by * and if NSPTOT > IS+1, C then complete the storage of the previous group. C C IA(1,a) = number of rows in group, not counting row a C IA(2,a) = number of class variables referenced C IA(3,a) = product of dimensions of specified classes C IF(ISTAR.EQ.0.AND.NSPTOT.GT.IS+1) THEN IA(1,IS)=NSPTOT-IS-1 IA(2,IS)=NIV IA(3,IS)=ICLM C C Reinitialize for beginning of next group and check availability C in IA array. C ICLM=1 NIV=0 IS=NSPTOT IA(1,IS)=0 IA(2,IS)=0 IA(3,IS)=1 NSPTOT=NSPTOT+1 IF(NSPTOT.GT.MAXIA)GO TO 90 END IF C C NVTMP contains the number of variables previously read by VNFIND C (initialized to 0 at the top of the subroutine, and IVTMP contains C the number that have been processed. If appropriate, attempt to C read variables, including under initial conditions IVTMP=NVTMP=0 C IF(IVTMP.GE.NVTMP) THEN CALL VNFIND(IPOSN,VTMP,MVTMP,NVTMP,IPOS2,2,VNAME,NVIN) IF(IPOSN.EQ.1)BASE=1 IPOSN=IPOS2 C C Check for error return C IF(NVTMP.EQ.-1) THEN IF(IPOSN.NE.1)IMERR2=IPOSN CALL FESTOP(160007) C C If no variables read at this point, conclude the processing. C ELSE IF(NVTMP.EQ.0) THEN GO TO 35 C C One or more variables read, reset IVTMP C ELSE IVTMP=1 END IF ELSE C C If VNFIND was not just read, increment IVTMP C IVTMP=IVTMP+1 END IF C C First check for 'TOTAL' C CALL CMATCH(VTMP(IVTMP),1,12,'TOTAL',5,IPOS2,1) IF(IPOS2.GT.0) THEN IV1=0 C C If TOTAL does appear, it cannot be part of a product, C e.g., AGE * TOTAL C IF(NSPTOT-IS.NE.1) THEN CALL FESTOP(160008) END IF IF(NSPTOT+2.GT.MAXIA)GO TO 90 IA(1,IS)=1 IA(2,IS)=0 IA(3,IS)=1 IS=IS+1 IA(1,IS)=0 IA(2,IS)=0 IA(3,IS)=0 IS=IS+1 IA(1,IS)=0 IA(2,IS)=0 IA(3,IS)=1 NSPTOT=IS+1 C C If more variables remain, recycle to 20. Note that the storage into C IA immediately after 20 will not occur in this case since NSPTOT=IS+1 C IF(IVTMP.LT.NVTMP) THEN GO TO 20 ELSE GO TO 10 END IF ELSE C C All other cases besides 'TOTAL' C First, identify the variable and assure that it is a class variable. C CALL VNMTCH(VTMP(IVTMP),VNAME,NVIN,IV1) IF(IV1.GT.0) THEN IF(MTYPE(IV1).NE.4) THEN WRITE(U6,203)VNAME(IV1) CALL FESTOP(160009) ELSE IF(ISTAR.EQ.1) THEN DO 22 I=IS+1,NSPTOT-1 IF(IV1.EQ.IA(1,I)) THEN WRITE(U6,206)VNAME(IV1) CALL FESTOP(160010) END IF 22 CONTINUE END IF IA(1,NSPTOT)=IV1 IA(2,NSPTOT)=0 IA(3,NSPTOT)=0 C C At this point, multiply ICLM by the number of levels of the class C variable, even though this may be changed later to reflect a C subsequent specification enclosed in parentheses. C ICLM=ICLM*MSIZE(IV1) C C Increment the count of the number of class variables here. C NIV=NIV+1 ISTAR=0 NSPTOT=NSPTOT+1 IF(NSPTOT.GT.MAXIA)GO TO 90 C C If more variables remain, recycle to 20. C IF(IVTMP.LT.NVTMP) THEN GO TO 20 ELSE GO TO 10 END IF END IF ELSE C C Error return for unrecognized variable name. C WRITE(U6,201)VTMP(IVTMP) CALL FESTOP(160011) END IF END IF END IF 35 CONTINUE C C End of CLSCAN processing. If NSPTOT > IS+1, complete the storage C of the last group and set NSPTOT to mark the end. Otherwise, C reduce NSPTOT to mark the end of the last real group processed. C IF(NSPTOT.GT.IS+1) THEN IA(1,IS)=NSPTOT-IS-1 IA(2,IS)=NIV IA(3,IS)=ICLM NSPTOT=NSPTOT-1 ELSE NSPTOT=NSPTOT-2 END IF RETURN 90 CONTINUE WRITE(U6,204) CALL FESTOP(160006) 98 CONTINUE WRITE(U6,205)VNAME(IV1) CALL FESTOP(160005) END C SUBROUTINE CMATCH(C,BASE,TOP,C1,C1LEN,IPOS,IFLAG) C INTEGER BASE,TOP,C1LEN,IPOS,IFLAG CHARACTER*(*) C,C1 C C Attempts to match C1 to C up to length of C(BASE:TOP) or first C blank in C1, in upper or lower case. C C C - string to be searched C BASE - starting position in C C TOP - ending position. Call to CMATCH begins C CALL CMATCH(C(BASE:TOP),BASE,TOP,... C C1 - reference string to find C C1LEN - exact length of C1 to match (i.e. C1(1:C1LEN)) C C1(1:C1LEN) should not include blanks C IPOS - return first character in C beyond match, if successful C return 0 - match not successful. C IFLAG=1 match full length C1LEN of C1, and, as long as not C beyond TOP, check that next character in C(BASE:TOP) C is not alphabetic or numeric C =2 do not perform check. Without the check, CMATCH may C return true even if additional letters follow the C matched segment in C C =3 generally, same as IFLAG=1, but also allow . as part of C name C LOGICAL ALPCHK,DGTCHK EXTERNAL ALPCHK,DGTCHK CHARACTER*1 ALPHA1(26),ALPHA2(26) DATA ALPHA1/ 'A','B','C','D','E','F','G','H','I','J','K','L', . 'M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/ DATA ALPHA2/ 'a','b','c','d','e','f','g','h','i','j','k','l', . 'm','n','o','p','q','r','s','t','u','v','w','x','y','z'/ C IPOS=0 LEN=TOP-BASE+1 DO 4 J=1,C1LEN IF(C1(J:J).EQ.' ')GO TO 5 IF(J.GT.LEN)GO TO 6 IF(C(J:J).EQ.C1(J:J))GO TO 4 DO 3 K=1,26 C C This part of the code makes the match case insensitive. C IF(C1(J:J).EQ.ALPHA1(K).OR.C1(J:J).EQ.ALPHA2(K)) THEN IF(C(J:J).EQ.ALPHA1(K).OR.C(J:J).EQ.ALPHA2(K)) THEN GO TO 4 ELSE GO TO 6 END IF END IF 3 CONTINUE GO TO 6 4 CONTINUE J=C1LEN+1 5 CONTINUE IF(J.LE.LEN.AND.IFLAG.EQ.1) THEN IF(ALPCHK(C(J:J)).OR.DGTCHK(C(J:J)).OR. . (IFLAG.EQ.3.AND.C(J:J).EQ.'.'))GO TO 6 END IF IPOS=J+BASE-1 6 CONTINUE RETURN END C SUBROUTINE DASCAN(BASE,IPOS,DA,MAXDA,N) C INTEGER BASE,IPOS,MAXDA,N DOUBLE PRECISION DA(MAXDA) C C Searches the contents of the current command line (card) for C constants and reads additional lines, if appropriate. C C BASE - starting position in C (in common block) to search C IPOS - next interpretable position C set to 0, if REFRSH returned false, i.e., no more C continuation lines. C DA - array to receive values. C MAXDA - maximum available space in DA C N - number of double precision values found and stored into DA C return 0 if no values successfully found. C C DASCAN includes the '*' feature to indicate multiple values, e.g. C 50 * .08. It treats ',' and ' ' as spacing. C DOUBLE PRECISION DVALUE,DVAL2 LOGICAL ICHECK EXTERNAL ICHECK CHARACTER*256 C COMMON /CRDBLK/C C IPOS=BASE N=0 C C IMULT - integer indicating multiplier in '*' syntax, e.g., 50 * .08 C IMULT=0 C 10 CONTINUE CALL NBFND2(IPOS,IPOS2) IF(IPOS.EQ.1)BASE=1 IPOS=IPOS2 C C Return if run out of information C IF(IPOS.EQ.0) THEN RETURN END IF C C Call DFIND to establish whether have encountered a valid number. C CALL DFIND(IPOS,IPOS2,DVALUE,DVAL2,1) C C Treatment of cases where a number has not been read. C IF(IPOS2.LE.0) THEN C C Simply skip ',' C IF(C(IPOS:IPOS).EQ.',') THEN IPOS=IPOS+1 C C If encounter '*' C ELSE IF(C(IPOS:IPOS).EQ.'*') THEN IF(N.GE.1.AND.IMULT.EQ.0) THEN IF(ICHECK(DA(N),DVALUE)) THEN IMULT=DVALUE+.5 IF(IMULT.GE.1.AND.IMULT.LT.1000000) THEN N=N-1 IPOS=IPOS+1 ELSE CALL FPSTOP(160031,IPOS) END IF ELSE CALL FPSTOP(160031,IPOS) END IF ELSE IF(IMULT.NE.0) THEN CALL FPSTOP(160032,IPOS) ELSE IF(N.GE.1) THEN CALL FPSTOP(160031,IPOS) END IF ELSE C C Return if encountered some other character. C RETURN END IF ELSE C C When a value has been read by DFIND C IF(IMULT.LE.0)IMULT=1 DO 12 I=1,IMULT N=N+1 IF(N.GE.MAXDA) THEN CALL FPSTOP(160030,IPOS) END IF DA(N)=DVALUE 12 CONTINUE IMULT=0 IPOS=IPOS2 END IF GO TO 10 END C SUBROUTINE DFIND(BASE,IPOS,DVALUE,DVAL2,IFLAG) C INTEGER BASE,IPOS,IFLAG DOUBLE PRECISION DVALUE,DVAL2 C C Reads a double precision number, DVALUE, IPOS=0 no number, C IPOS=-1 error on read, IPOS is next position after number C If IFLAG=2, DVAL2 is returned falling just below next larger C value of DVALUE by adding 1 to least significant digit given C e.g., DVALUE at 1.9 returns DVAL2 just below 2.0 C C BASE - integer, unchanged, giving starting character to C search card - CARD(BASE:BASE) assumed nonblank C IPOS - integer, returned giving C 0 - no valid number C >0 - next character after number C C DVALUE - double precision - returned value if IPOS > 0 C DVAL2 - double precision - returned number just below DVALUE C if IFLAG = 2 C IFLAG - integer - passed, unchanged C 1 computation of DVALUE only C 2 computation of both DVALUE and DVAL2 C C As the routine scans the character string, it builds up in C CDVAL2 a number representing the precision in DVALUE. C CHARACTER*256 CARD COMMON /CRDBLK/ CARD DOUBLE PRECISION DBELOW EXTERNAL DBELOW CHARACTER*8 WFMT CHARACTER*30 CDVAL2 LOGICAL DGTCHK EXTERNAL DGTCHK CHARACTER*1 DIGIT(10) DATA DIGIT /'0','1','2','3','4','5','6','7','8','9'/ C IPOS=0 DVALUE=0. IF(IFLAG.EQ.2)DVAL2=0. CALL NBFIND(CARD(BASE:256),BASE,256,IPT) IF(IPT.EQ.0) THEN IPOS=0 RETURN END IF ISTART=IPT C C Starting at ISTART, begin search for a valid number. C Set flags during parsing - C C IBLANK - blank encountered C IDEC - position decimal point encountered C INEND - pointer to last digit C IBLANK=0 IDEC=0 IDFORM=0 IEXP=0 INEND=0 IPT2=1 C IF(DGTCHK(CARD(ISTART:ISTART))) THEN C C If encounter a digit first, start CDVAL2 with a 0. C INEND=ISTART CDVAL2(1:1)='0' ELSE IF(CARD(ISTART:ISTART).EQ.'.') THEN IDEC=ISTART CDVAL2(1:1)=CARD(ISTART:ISTART) ELSE IF(CARD(ISTART:ISTART).EQ.'+'.OR. . CARD(ISTART:ISTART).EQ.'-') THEN C C In case of '+' or '-' simply begin CDVAL with a blank. C CDVAL2(1:1)=' ' ELSE C C Return here if CARD(ISTART:ISTART) does not begin a number C RETURN END IF C 10 CONTINUE IPT=IPT+1 C C If have scanned to the very end of CARD, conclude processing C following 50 CONTINUE C IF(IPT.GT.256) GO TO 50 IF(IPT-ISTART.GE.30) THEN IF(CARD(IPT:IPT).EQ.' ') THEN GO TO 50 ELSE C C Error condition if number seems too long C CALL FPSTOP(160035,IPT) END IF END IF C C Have encountered a digit. C IF(DGTCHK(CARD(IPT:IPT))) THEN C C If digits have been found previously then: C If a "D" or "E" has not been encountered: C Intervening blanks -> beginning of new number C No intervening blanks -> continuation of this number C Else if "D" or "E" encountered -> part of exponent C Else - mark beginning of digits. C C IF(INEND.GT.0) THEN IF(IDFORM.EQ.0) THEN IF(IBLANK.GT.0) THEN GO TO 50 ELSE INEND=IPT END IF ELSE IEXP=IPT END IF ELSE INEND=IPT END IF ELSE IF(CARD(IPT:IPT).EQ.' ') THEN C C If blank occurs before any digits - not a valid number. C IF(INEND.EQ.0) THEN RETURN ELSE C C Allow blanks before or after "D" or "E" e.g., .1 D 0 C If a blank occurs after an exponent, conclude processing. C IF(IDFORM.EQ.0) THEN IF(IBLANK.EQ.0) IBLANK=IPT ELSE IF(IEXP.GT.0) THEN GO TO 50 END IF END IF ELSE IF(CARD(IPT:IPT).EQ.'+'.OR.CARD(IPT:IPT).EQ.'-') THEN C C If encounter "+" or "-" after 1st position, conclude processing C unless possibly part of exponent. C IF(IDFORM.EQ.0.OR.IEXP.GT.0) GO TO 50 ELSE IF(CARD(IPT:IPT).EQ.'D'.OR.CARD(IPT:IPT).EQ.'E'.OR. . CARD(IPT:IPT).EQ.'d'.OR.CARD(IPT:IPT).EQ.'e') THEN C C Identification of "D" or "E" as part of scientific notation. C IF(IDFORM.EQ.0) THEN IDFORM=IPT ELSE GO TO 50 END IF ELSE IF(CARD(IPT:IPT).EQ.'.') THEN C C Handling of decimal point. C IF(IDEC.GT.0.OR.IBLANK.GT.0) THEN GO TO 50 ELSE IDEC=IPT END IF ELSE GO TO 50 END IF C C Build up value in CDVAL2 C IPT2=IPT2+1 IF(DGTCHK(CARD(IPT:IPT)).AND.IDFORM.EQ.0) THEN CDVAL2(IPT2:IPT2)='0' ELSE CDVAL2(IPT2:IPT2)=CARD(IPT:IPT) END IF GO TO 10 C C Loop back to 10 to look at next character. C C Transfer to 50 at end of this number. C 50 CONTINUE C C If INEND = 0, no digits encountered C IF(INEND.EQ.0)RETURN C C N1 - width of field to read C IF(IDFORM.GT.0) THEN N1=IEXP-ISTART+1 ELSE IF(INEND.GT.IDEC) THEN N1=INEND-ISTART+1 ELSE N1=IDEC-ISTART+1 END IF C IPOS=ISTART+N1 C C N2 - number of places after decimal C IF(IDEC.GT.0) THEN IF(IDFORM.GT.0) THEN N2=IDFORM-IDEC-1 ELSE IF(INEND.GT.IDEC) THEN N2=INEND-IDEC ELSE N2=0 END IF ELSE N2=0 END IF C C Choose between floating point and scientific notation. C IF(IDFORM.EQ.0) THEN WFMT(1:2)='(F' ELSE WFMT(1:2)='(D' END IF C I=3 52 CONTINUE C C Complete the format (Fn1.n2) or (Dn1.n2) C IF(N1.GT.9) THEN J=N1/10 N1=N1-J*10 WFMT(I:I)=DIGIT(J+1) I=I+1 GO TO 52 ELSE WFMT(I:I)=DIGIT(N1+1) I=I+1 END IF WFMT(I:I)='.' I=I+1 54 CONTINUE IF(N2.GT.9) THEN J=N2/10 N2=N2-J*10 WFMT(I:I)=DIGIT(J+1) I=I+1 GO TO 54 ELSE WFMT(I:I)=DIGIT(N2+1) I=I+1 END IF WFMT(I:I)=')' READ(CARD(ISTART:256),WFMT,ERR=60)DVALUE IF(IFLAG.EQ.2) THEN INEND=INEND-ISTART+1 CDVAL2(INEND:INEND)='1' READ(CDVAL2,WFMT,ERR=61)DVAL2 DVAL2=DVALUE+DVAL2 DVAL2=DBELOW(DVAL2) END IF RETURN C C Return for error reading value. C 60 CONTINUE CALL FPSTOP(160036,ISTART) C C Return for error reading CDVAL2 C 61 CONTINUE CALL FPSTOP(160037,ISTART) RETURN END C LOGICAL FUNCTION DGTCHK(C) C C Returns TRUE if character is digit C CHARACTER*1 C CHARACTER*1 DIGIT(10) DATA DIGIT /'0','1','2','3','4','5','6','7','8','9'/ C DO 1 I=1,10 IF(C.EQ.DIGIT(I)) THEN DGTCHK=.TRUE. RETURN END IF 1 CONTINUE DGTCHK=.FALSE. RETURN END C SUBROUTINE EQSCAN(BASE,IPT,KEYWRD,IFLAG) C INTEGER BASE,IPT,IFLAG PARAMETER (MAXKWL=24) CHARACTER*(MAXKWL) KEYWRD C C Searches command line(s) for a string of the form KEYWRD = C BASE - starting position to search C reset to 1 if REFRSH used to read another line C set to 0 if at end of records C IPT - returned ending position on conclusion of search C 0 if no continuation lines remain C KEYWRD - returned keyword found C IFLAG=1 successful match, returns KEYWRD and, in IPT, C the next non-blank character after = C =2 valid KEYWRD only, IPT is next non-blank character C =0 invalid KEYWRD, IPT is first non-blank position C C This subroutine will read additional lines from the input C file, if necessary, by calling REFRSH and managing the calls C to EQSCN2. C C If KEYWRD = has been encountered, but no additional expression C follows, EQSCAN terminates with a fatal error C LOGICAL REFRSH EXTERNAL REFRSH C CALL EQSCN2(BASE,IPT,KEYWRD,IFLAG,1,IDONE) 10 CONTINUE IF(IDONE.EQ.0) THEN IF(REFRSH(BASE)) THEN CALL EQSCN2(BASE,IPT,KEYWRD,IFLAG,0,IDONE) GO TO 10 ELSE IF(IFLAG.EQ.1) THEN CALL FESTOP(160043) ELSE IPT=0 END IF END IF END IF RETURN END C SUBROUTINE EQSCN2(BASE,IPT,KEYWRD,IFLAG,ICSTAT,IDONE) C INTEGER BASE,IPT,IFLAG,ICSTAT,IDONE PARAMETER (MAXKWL=24) CHARACTER*(MAXKWL) KEYWRD C C Searches a command line for a string of the form KEYWRD = C BASE - starting position to search, not changed by EQSCN2 C IPT - returned ending position on conclusion of search C 0 reached end of line C KEYWRD - returned keyword found C IFLAG=1 successful match, returns KEYWRD and, in IPT, C the next non-blank character after = C =2 valid KEYWRD only, IPT is next non-blank character C =0 invalid KEYWRD, IPT is first non-blank position C ICSTAT = 1 passed flag indicating first call to routine, C = 0 continuation of problem C (not changed by EQSCN2) C IDONE = 1 now done C 0 not apparently done, specification may continue on C another line C (returned) C C This version of the subroutine processes a line at a time, and C returns in IDONE an indication of whether the task is complete. C C This subroutine is called by EQSCAN, which uses REFRSH to read C multiple lines, if necessary, and by REFRSH through FNRD2, in order C to interpret INCLUDE, etc. C C CHARACTER*256 CARD COMMON /CRDBLK/ CARD LOGICAL ALPCHK,DGTCHK EXTERNAL ALPCHK,DGTCHK C IPT=BASE C C On the initial call, i.e., ICSTAT=1, set IFLAG and IDONE C IF(ICSTAT.EQ.1) THEN IFLAG=0 IDONE=0 END IF C 10 CONTINUE CALL NBFIND(CARD(IPT:256),IPT,256,IPOS) IPT=IPOS C C If no remaining nonblank charcters, return C IF(IPT.EQ.0) GO TO 99 IF(CARD(IPT:IPT).EQ.','.AND.IFLAG.EQ.0) THEN C C Ignore "," C IPT=IPT+1 ELSE IF(IFLAG.EQ.0) THEN C C If a keywork has not yet been established, look here. C IF(.NOT.ALPCHK(CARD(IPT:IPT))) THEN C C No valid keyword established. Upon return IFLAG=0 and IPT is C position of next nonblank character. C IDONE=1 GO TO 99 END IF C C Copy into KEYWRD C L=1 IFLAG=2 12 CONTINUE KEYWRD(L:L)=CARD(IPT:IPT) IPT=IPT+1 IF(IPT.LE.256.AND.L.LT.MAXKWL) THEN IF(ALPCHK(CARD(IPT:IPT)).OR.DGTCHK(CARD(IPT:IPT))) THEN L=L+1 GO TO 12 END IF END IF IF(L.LT.MAXKWL) THEN DO 14 I=L+1,MAXKWL KEYWRD(I:I)=' ' 14 CONTINUE END IF IF(CARD(IPT:IPT).NE.' '.AND.CARD(IPT:IPT).NE.'='.AND. . CARD(IPT:IPT).NE.';') THEN C C If unexpected characters, then end, either leaving IFLAG=2, C i.e., valid key word only, or IFLAG=0, i.e., no success. (In some C EQSCN2 may be trying to read a filename longer than 12 characters C as if it were a key word.) Note that file names with imbedded C forward, / or back slashes will not be considered key words C IF(CARD(IPT:IPT).NE.',') THEN IFLAG=0 IPT=IPOS END IF IDONE=1 GO TO 99 END IF ELSE IF(IFLAG.EQ.2) THEN C C Test whether '=' found when expected (IFLAG=2) C IF(CARD(IPT:IPT).NE.'=') THEN IDONE=1 GO TO 99 END IF IFLAG=1 IPT=IPT+1 ELSE C C Arrive here if IPT>0 and IFLAG=1, i.e., successful completion C IDONE=1 GO TO 99 END IF GO TO 10 99 CONTINUE RETURN END C SUBROUTINE IFIND(C,BASE,TOP,IPOS,IVALUE) C INTEGER BASE,TOP,IPOS,IVALUE CHARACTER*(*) C C C Finds an unsigned integer C C C - Character string to search C BASE - Starting position in calling routine C TOP - Ending position in calling routine C Note: call is of the form CALL IFIND(C(BASE:TOP),BASE,TOP,... C IPOS - 0 returned if unsuccessful C >0 next character (with respect to calling program) C i.e., C(IPOS,IPOS) is next character C Note: may be TOP+1 C IVALUE - value if IPOS > 0 C = -1 if IPOS = 0 C CHARACTER*1 DIGIT(10) DATA DIGIT /'0','1','2','3','4','5','6','7','8','9'/ C IPOS=0 IVALUE=-1 LEN=TOP-BASE+1 IPT=0 C C Program will loop back to 10 until the first digit is read C 10 CONTINUE IPT=IPT+1 IF(IPT.GT.LEN) RETURN DO 20 I=1,10 IF(C(IPT:IPT).EQ.DIGIT(I)) GO TO 30 20 CONTINUE IF(C(IPT:IPT).EQ.' ') THEN GO TO 10 ELSE RETURN END IF C C Transfer to 30 after first digit read C Set IVALUE and IPOS to indicate valid integer C 30 CONTINUE IVALUE=I-1 ICOUNT=1 31 CONTINUE IPOS=IPT+BASE IF(IPT.LT.LEN) THEN DO 33 I=1,10 IF(C(IPT+1:IPT+1).EQ.DIGIT(I)) THEN ICOUNT=ICOUNT+1 IF(ICOUNT.GT.9) THEN CALL FPSTOP(160040,IPOS) ELSE IVALUE=10*IVALUE+I-1 IPT=IPT+1 GO TO 31 END IF END IF 33 CONTINUE END IF RETURN END C SUBROUTINE KYCHK2(IPT,IGROUP,IKEY,IPNT) C INTEGER IPT,IGROUP,IKEY,IPNT C C IPT - starting position to begin search, not changed by C KYCHK2. IPT should already point to an alphabetic C character. C IGROUP - key word group. C (may be 0) C IKEY - code for key word C = 0 if no match found C IPNT - IPNT first nonblank character after key word C = 0 if no match found, or if no nonblank character C follows the keyword. C C Returns in IKEY the number of the keyword matching the first columns C of CARD, and in IPNT the first nonblank column after the C keyword. A final 's' at the end of the keyword is accepted. C If an exact match is not found, a check will be made for an C unambiguous shortening. If no match is found, KYCHK2 simply C returns with IPNT=0, unlike KYFND2 C PARAMETER (NKEY0=14,NKEY1=19,NKEY2=16,NKEY3=45,NKEY4=6,NKEY5=12) PARAMETER (NKEY6=9,NKEY7=28,NKEY8=12,NKEY9=15) PARAMETER (NKEY1B=NKEY0+1,NKEY1E=NKEY0+NKEY1) PARAMETER (NKEY2B=NKEY1E+1,NKEY2E=NKEY1E+NKEY2) PARAMETER (NKEY3B=NKEY2E+1,NKEY3E=NKEY2E+NKEY3) PARAMETER (NKEY4B=NKEY3E+1,NKEY4E=NKEY3E+NKEY4) PARAMETER (NKEY5B=NKEY4E+1,NKEY5E=NKEY4E+NKEY5) PARAMETER (NKEY6B=NKEY5E+1,NKEY6E=NKEY5E+NKEY6) PARAMETER (NKEY7B=NKEY6E+1,NKEY7E=NKEY6E+NKEY7) PARAMETER (NKEY8B=NKEY7E+1,NKEY8E=NKEY7E+NKEY8) PARAMETER (NKEY9B=NKEY8E+1,NKEY9E=NKEY8E+NKEY9) CHARACTER*12 KYWRD2(NKEY9E) COMMON /KYBLK2/KYWRD2 INTEGER KEYGR1(NKEY9),KEYGR2(NKEY9) COMMON /KYBLK3/KEYGR1,KEYGR2 INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 CHARACTER*256 CARD COMMON /CRDBLK/ CARD C IGROUP=0 IKEY=0 C IPOS2=IPT IPOS12=IPT+11 C C First, check for an exact match on a key word, or match C with an added 's' C DO 20 I=1,NKEY9E CALL CMATCH(CARD(IPOS2:IPOS12),IPOS2,IPOS12,KYWRD2(I), . 12,IPOS,1) IF(IPOS.GT.0) THEN IKEY=I CALL NBFIND(CARD(IPOS:256),IPOS,256,IPNT) GO TO 80 ELSE CALL CMATCH(CARD(IPOS2:IPOS12),IPOS2,IPOS12,KYWRD2(I), . 12,IPOS,2) IF(IPOS.GT.0) THEN IF((CARD(IPOS:IPOS).EQ.'S'.OR.CARD(IPOS:IPOS).EQ.'s').AND. . CARD(IPOS+1:IPOS+1).EQ.' ') THEN IKEY=I IPOS=IPOS+1 CALL NBFIND(CARD(IPOS:256),IPOS,256,IPNT) GO TO 80 END IF END IF END IF 20 CONTINUE C C If no exact match, check for a shortening of a key word, which C is acceptable only if it is unambiguous. C C First, determine where the abbreviation in CARD(IPOS2:IPOS12) ends C DO 22 I=IPOS2,IPOS12 IF(CARD(I:I).EQ.' ')GO TO 23 22 CONTINUE GO TO 24 23 CONTINUE IPOS12=I-1 24 CONTINUE ILEN=IPOS12-IPOS2+1 C C Now loop over key words, finding how many key words the abbreviation C matches. C NMATCH=0 IF(ILEN.GT.0) THEN DO 30 I=1,NKEY9E CALL CMATCH(CARD(IPOS2:IPOS12),IPOS2,IPOS12,KYWRD2(I), . ILEN,IPOS,2) IF(IPOS.EQ.IPOS12+1) THEN NMATCH=NMATCH+1 IKEY=I CALL NBFIND(CARD(IPOS:256),IPOS,256,IPNT) END IF 30 CONTINUE END IF IF(NMATCH.GE.2) THEN IKEY=0 IPNT=0 END IF C C Recode IKEY into IGROUP, IKEY C 80 CONTINUE IF(IKEY.LE.NKEY0) THEN IGROUP=0 ELSE IF(IKEY.LE.NKEY1E) THEN IGROUP=1 IKEY=IKEY-NKEY0 ELSE IF(IKEY.LE.NKEY2E) THEN IGROUP=2 IKEY=IKEY-NKEY1E ELSE IF(IKEY.LE.NKEY3E) THEN IGROUP=3 IKEY=IKEY-NKEY2E ELSE IF(IKEY.LE.NKEY4E) THEN IGROUP=4 IKEY=IKEY-NKEY3E ELSE IF(IKEY.LE.NKEY5E) THEN IGROUP=5 IKEY=IKEY-NKEY4E ELSE IF(IKEY.LE.NKEY6E) THEN IGROUP=6 IKEY=IKEY-NKEY5E ELSE IF(IKEY.LE.NKEY7E) THEN IGROUP=7 IKEY=IKEY-NKEY6E ELSE IF(IKEY.LE.NKEY8E) THEN IGROUP=8 IKEY=IKEY-NKEY7E ELSE I=IKEY-NKEY8E IGROUP=KEYGR1(I) IKEY=KEYGR2(I) END IF RETURN END C SUBROUTINE KYFIND(IKEY,IPNT) C INTEGER IKEY,IPNT C C IKEY - code for key word C = -1 if _ not followed by a key word C IPNT - IPNT first nonblank character after key word C C Returns in IKEY the number of the keyword matching the first columns C of CARD, and in IPNT the first nonblank column after the C keyword. A final 's' at the end of the keyword is accepted. C If an exact match is not found, a check will be made for an C unambiguous shortening. A fatal error occurs if no match is found. C PARAMETER (NKEY=200) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 CHARACTER*256 CARD COMMON /CRDBLK/ CARD CHARACTER*12 KEYWRD(NKEY) COMMON /KEYBLK/KEYWRD C 100 FORMAT(' _') 201 FORMAT(' AMBIGUOUS KEY WORD - POSSIBLE:') 202 FORMAT(5X,A12) 203 FORMAT(' UNMATCHED KEY WORD') C IKEY=0 C C If position 1 contains _, then find beginning of key word C IF(CARD(1:1).EQ.'_') THEN IPOS=2 CALL NBFIND(CARD(IPOS:256),IPOS,256,IPOS2) IF(IPOS2.EQ.0) THEN IF(U5ECHO.EQ.1)WRITE(U6,100) CALL NBFND2(IPOS,IPOS2) END IF IF(IPOS2.EQ.0) THEN C C Return -1 if key word not found C IKEY=-1 IPNT=0 GO TO 90 ELSE IPOS12=IPOS2+11 END IF ELSE IPOS2=1 IPOS12=12 END IF C C First, check for an exact match on a key word, or match C with an added 's' C DO 20 I=1,NKEY CALL CMATCH(CARD(IPOS2:IPOS12),IPOS2,IPOS12,KEYWRD(I), . 12,IPOS,1) IF(IPOS.GT.0) THEN IKEY=I CALL NBFIND(CARD(IPOS:256),IPOS,256,IPNT) GO TO 90 ELSE CALL CMATCH(CARD(IPOS2:IPOS12),IPOS2,IPOS12,KEYWRD(I), . 12,IPOS,2) IF(IPOS.GT.0) THEN IF((CARD(IPOS:IPOS).EQ.'S'.OR.CARD(IPOS:IPOS).EQ.'s').AND. . CARD(IPOS+1:IPOS+1).EQ.' ') THEN IKEY=I IPOS=IPOS+1 CALL NBFIND(CARD(IPOS:256),IPOS,256,IPNT) GO TO 90 END IF END IF END IF 20 CONTINUE C C If no exact match, check for a shortening of a key word, which C is acceptable only if it is unambiguous. C C First, determine where the abbreviation in CARD(IPOS2:IPOS12) ends C DO 22 I=IPOS2,IPOS12 IF(CARD(I:I).EQ.' ')GO TO 23 22 CONTINUE GO TO 24 23 CONTINUE IPOS12=I-1 24 CONTINUE ILEN=IPOS12-IPOS2+1 C C Now loop over key words, finding how many key words the abbreviation C matches. C NMATCH=0 IF(ILEN.GT.0) THEN DO 30 I=1,NKEY CALL CMATCH(CARD(IPOS2:IPOS12),IPOS2,IPOS12,KEYWRD(I), . ILEN,IPOS,2) IF(IPOS.EQ.IPOS12+1) THEN NMATCH=NMATCH+1 IF(NMATCH.GE.2) THEN IF(NMATCH.EQ.2) THEN CALL CRDPRN(2) WRITE(U6,201) WRITE(U6,202)KEYWRD(IKEY) END IF WRITE(U6,202)KEYWRD(I) END IF IKEY=I CALL NBFIND(CARD(IPOS:256),IPOS,256,IPNT) END IF 30 CONTINUE END IF IF(NMATCH.EQ.0) THEN CALL CRDPRN(2) WRITE(U6,203) CALL FPSTOP(160045,IPOS2) ELSE IF(NMATCH.GE.2) THEN CALL FPSTOP(160045,IPOS2) END IF 90 CONTINUE RETURN END C SUBROUTINE KYFND2(IGROUP,IKEY,IPNT) C INTEGER IGROUP,IKEY,IPNT C C IGROUP - key word group. C IKEY - code for key word C = -1 if _ not followed by a key word C IPNT - IPNT first nonblank character after key word C C Returns in IKEY the number of the keyword matching the first columns C of CARD, and in IPNT the first nonblank column after the C keyword. A final 's' at the end of the keyword is accepted. C If an exact match is not found, a check will be made for an C unambiguous shortening. A fatal error occurs if no match is found. C PARAMETER (NKEY0=14,NKEY1=19,NKEY2=16,NKEY3=45,NKEY4=6,NKEY5=12) PARAMETER (NKEY6=9,NKEY7=28,NKEY8=12,NKEY9=15) PARAMETER (NKEY1B=NKEY0+1,NKEY1E=NKEY0+NKEY1) PARAMETER (NKEY2B=NKEY1E+1,NKEY2E=NKEY1E+NKEY2) PARAMETER (NKEY3B=NKEY2E+1,NKEY3E=NKEY2E+NKEY3) PARAMETER (NKEY4B=NKEY3E+1,NKEY4E=NKEY3E+NKEY4) PARAMETER (NKEY5B=NKEY4E+1,NKEY5E=NKEY4E+NKEY5) PARAMETER (NKEY6B=NKEY5E+1,NKEY6E=NKEY5E+NKEY6) PARAMETER (NKEY7B=NKEY6E+1,NKEY7E=NKEY6E+NKEY7) PARAMETER (NKEY8B=NKEY7E+1,NKEY8E=NKEY7E+NKEY8) PARAMETER (NKEY9B=NKEY8E+1,NKEY9E=NKEY8E+NKEY9) CHARACTER*12 KYWRD2(NKEY9E) COMMON /KYBLK2/KYWRD2 INTEGER KEYGR1(NKEY9),KEYGR2(NKEY9) COMMON /KYBLK3/KEYGR1,KEYGR2 INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 CHARACTER*256 CARD COMMON /CRDBLK/ CARD C 100 FORMAT(' _') 201 FORMAT(' AMBIGUOUS KEY WORD - POSSIBLE:') 202 FORMAT(5X,A12) 203 FORMAT(' UNMATCHED KEY WORD') C IGROUP=0 IKEY=0 C C If position 1 contains _, then find beginning of key word C IF(CARD(1:1).EQ.'_') THEN IPOS=2 CALL NBFIND(CARD(IPOS:256),IPOS,256,IPOS2) IF(IPOS2.EQ.0) THEN IF(U5ECHO.EQ.1)WRITE(U6,100) CALL NBFND2(IPOS,IPOS2) END IF IF(IPOS2.EQ.0) THEN C C Return -1 if key word not found C IKEY=-1 IPNT=0 GO TO 90 ELSE IPOS12=IPOS2+11 END IF ELSE IPOS2=1 IPOS12=12 END IF C C First, check for an exact match on a key word, or match C with an added 's' C DO 20 I=1,NKEY9E CALL CMATCH(CARD(IPOS2:IPOS12),IPOS2,IPOS12,KYWRD2(I), . 12,IPOS,1) IF(IPOS.GT.0) THEN IKEY=I CALL NBFIND(CARD(IPOS:256),IPOS,256,IPNT) GO TO 80 ELSE CALL CMATCH(CARD(IPOS2:IPOS12),IPOS2,IPOS12,KYWRD2(I), . 12,IPOS,2) IF(IPOS.GT.0) THEN IF((CARD(IPOS:IPOS).EQ.'S'.OR.CARD(IPOS:IPOS).EQ.'s').AND. . CARD(IPOS+1:IPOS+1).EQ.' ') THEN IKEY=I IPOS=IPOS+1 CALL NBFIND(CARD(IPOS:256),IPOS,256,IPNT) GO TO 80 END IF END IF END IF 20 CONTINUE C C If no exact match, check for a shortening of a key word, which C is acceptable only if it is unambiguous. C C First, determine where the abbreviation in CARD(IPOS2:IPOS12) ends C DO 22 I=IPOS2,IPOS12 IF(CARD(I:I).EQ.' ')GO TO 23 22 CONTINUE GO TO 24 23 CONTINUE IPOS12=I-1 24 CONTINUE ILEN=IPOS12-IPOS2+1 C C Now loop over key words, finding how many key words the abbreviation C matches. C NMATCH=0 IF(ILEN.GT.0) THEN DO 30 I=1,NKEY9E CALL CMATCH(CARD(IPOS2:IPOS12),IPOS2,IPOS12,KYWRD2(I), . ILEN,IPOS,2) IF(IPOS.EQ.IPOS12+1) THEN NMATCH=NMATCH+1 IF(NMATCH.GE.2) THEN IF(NMATCH.EQ.2) THEN CALL CRDPRN(2) WRITE(U6,201) WRITE(U6,202)KYWRD2(IKEY) END IF WRITE(U6,202)KYWRD2(I) END IF IKEY=I CALL NBFIND(CARD(IPOS:256),IPOS,256,IPNT) END IF 30 CONTINUE END IF IF(NMATCH.EQ.0) THEN CALL CRDPRN(2) WRITE(U6,203) CALL FPSTOP(160045,IPOS2) ELSE IF(NMATCH.GE.2) THEN CALL FPSTOP(160045,IPOS2) END IF C C Recode IKEY into IGROUP, IKEY C 80 CONTINUE IF(IKEY.LE.NKEY0) THEN IGROUP=0 ELSE IF(IKEY.LE.NKEY1E) THEN IGROUP=1 IKEY=IKEY-NKEY0 ELSE IF(IKEY.LE.NKEY2E) THEN IGROUP=2 IKEY=IKEY-NKEY1E ELSE IF(IKEY.LE.NKEY3E) THEN IGROUP=3 IKEY=IKEY-NKEY2E ELSE IF(IKEY.LE.NKEY4E) THEN IGROUP=4 IKEY=IKEY-NKEY3E ELSE IF(IKEY.LE.NKEY5E) THEN IGROUP=5 IKEY=IKEY-NKEY4E ELSE IF(IKEY.LE.NKEY6E) THEN IGROUP=6 IKEY=IKEY-NKEY5E ELSE IF(IKEY.LE.NKEY7E) THEN IGROUP=7 IKEY=IKEY-NKEY6E ELSE IF(IKEY.LE.NKEY8E) THEN IGROUP=8 IKEY=IKEY-NKEY7E ELSE I=IKEY-NKEY8E IGROUP=KEYGR1(I) IKEY=KEYGR2(I) END IF 90 CONTINUE RETURN END C SUBROUTINE LASTCI(ILAST) C INTEGER ILAST C C ILAST - the last nonblank character in CARDIM. C CHARACTER*256 CARDWK,CARDSV,CARDIM COMMON /CMBLK2/CARDWK,CARDSV,CARDIM DO 1 I=256,1,-1 IF(CARDIM(I:I).NE.' ')GO TO 2 1 CONTINUE ILAST=0 GO TO 3 2 CONTINUE ILAST=I 3 CONTINUE RETURN END C SUBROUTINE LASTCR(ILAST) C INTEGER ILAST C C ILAST - the last nonblank character in CARD. C CHARACTER*256 CARD COMMON /CRDBLK/CARD DO 1 I=256,1,-1 IF(CARD(I:I).NE.' ')GO TO 2 1 CONTINUE ILAST=0 GO TO 3 2 CONTINUE ILAST=I 3 CONTINUE RETURN END C SUBROUTINE LEVELD(LABEL,NLABEL) C INTEGER NLABEL CHARACTER*24 LABEL(NLABEL) C C LABEL - array labels C NLABEL - number of labels C C Reviews the labels in LABEL and inserts a default label where blank. C 201 FORMAT('Level',I2) 202 FORMAT('Level',I3) 203 FORMAT('Level',I5) 204 FORMAT('Level',I8) C DO 10 L=1,NLABEL DO 2 I=1,24 IF(LABEL(L)(I:I).NE.' ')GO TO 10 2 CONTINUE IF(NLABEL.LE.9) THEN WRITE(LABEL(L),201)L ELSE IF(NLABEL.LE.99) THEN WRITE(LABEL(L),202)L ELSE IF(NLABEL.LE.9999) THEN WRITE(LABEL(L),203)L ELSE WRITE(LABEL(L),204)L END IF 10 CONTINUE RETURN END C SUBROUTINE LEVELR(BASE,IPOS,N,LABEL,MLABEL) C INTEGER BASE,IPOS,N,MLABEL CHARACTER*24 LABEL(MLABEL) C C BASE - starting position in CARD to scan C IPOS - next position beyond labels C 0 - end of continuation lines C N - number of labels returned C LABEL - array into which to store labels C MLABEL - maximum number of labels to accept C C Returns N as number of entries in LABEL returned, up to MLABEL C Continues scanning even after LABEL is full. C CHARACTER*256 CARD COMMON /CRDBLK/ CARD INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 LOGICAL REFRSH EXTERNAL REFRSH C C 100 FORMAT(' UNBALANCED APOSTROPHIES ON LINE') C C 101 FORMAT(' MORE LABELS THAN EXPECTED') C C ISWTCH - toggle to indicate whether information is enclosed in C apostrophes. C ISWTCH=0 N=0 5 CONTINUE I=BASE-1 10 CONTINUE I=I+1 C C If at end of command line C IF(I.GT.256) THEN IF(ISWTCH.EQ.1) THEN CALL FESTOP(160050) ELSE IF(.NOT.REFRSH(BASE)) THEN IPOS=0 IF(N.GT.MLABEL)N=MLABEL RETURN ELSE GO TO 5 END IF END IF C C If not now within the range of apostropes. C IF(ISWTCH.EQ.0) THEN IF(CARD(I:I).EQ.'''') THEN ISWTCH=1 L=0 N=N+1 C C Only blanks and commas expected between labels, otherwise C return C ELSE IF(CARD(I:I).NE.' '.AND.CARD(I:I).NE.',') THEN IPOS=I IF(N.GT.MLABEL)N=MLABEL RETURN END IF ELSE C C If within range of apostrophe, first check for second apostrophe C IF(CARD(I:I).EQ.'''') THEN IF(I.LT.256) THEN C C Check whether adjacent apostrophes should be translated into a C single apostrophe within the label. C IF(CARD(I+1:I+1).EQ.'''') THEN L=L+1 IF(L.LE.24.AND.N.LE.MLABEL)LABEL(N)(L:L)=CARD(I:I) I=I+1 GO TO 10 END IF END IF C C At end of current label. C ISWTCH=0 IF(L.LT.24.AND.N.LE.MLABEL) THEN DO 24 J=L+1,24 LABEL(N)(J:J)=' ' 24 CONTINUE END IF ELSE C C Storage of character into label. C L=L+1 IF(L.LE.24.AND.N.LE.MLABEL)LABEL(N)(L:L)=CARD(I:I) END IF END IF GO TO 10 END C SUBROUTINE NBFIND(C,BASE,TOP,IPOS) C INTEGER BASE,TOP,IPOS CHARACTER*(*) C C C C - string to search C BASE - starting position in C to search C TOP - ending position to search C Note: call is of form NBFIND(C(BASE:TOP),BASE,TOP,... C IPOS - next nonblank character (as numbered in calling program) C 0 all blanks. C IPOS=0 IPT=0 LEN=TOP-BASE+1 10 CONTINUE IPT=IPT+1 IF(IPT.GT.LEN) RETURN IF(C(IPT:IPT).EQ.' ') GO TO 10 IPOS=IPT+BASE-1 RETURN END C SUBROUTINE NBFND2(BASE,IPOS) C C BASE - starting position in CARD to search. C It will be reset to 1 if additional lines have been read. C IPOS - next nonblank character (as numbered in calling program) C 0 no more continuation lines C C Finds next nonblank character, IPOS is nonblank position C 0 otherwise C NBFND2 is specific to the search of command lines, and will C initiate the reading of additional lines through REFRSH C INTEGER BASE,IPOS C CHARACTER*256 CARD COMMON /CRDBLK/ CARD LOGICAL REFRSH EXTERNAL REFRSH C IPOS=0 IF(BASE.GT.256.OR.BASE.EQ.0) THEN IF(.NOT.REFRSH(BASE))GO TO 30 END IF 10 CONTINUE DO 20 IPT=BASE,256 IF(CARD(IPT:IPT).NE.' ') THEN IPOS=IPT GO TO 30 END IF 20 CONTINUE IF(REFRSH(BASE))GO TO 10 30 CONTINUE RETURN END C SUBROUTINE OPTNTR(NOPTN,INDX,IVALUE,OPTNW,BASE,IPOS,IOPTN) C INTEGER NOPTN,BASE,IPOS,IOPTN(*) INTEGER INDX(NOPTN) INTEGER IVALUE(NOPTN) CHARACTER*12 OPTNW(NOPTN) PARAMETER (MAXKWL=24) CHARACTER*(MAXKWL) KEYWRD CHARACTER*12 VNKEYW(1) C C Subroutine to read options of the form C OPTION1 , OPTION2 = VALUE2 C where VALUE2 is an integer, etc. C C NOPTN - number of posible options to search C INDX - pointer mapping options in OPTNW to places in IVALUE C to receive the result C IVALUE - value if key word appears by itself without = C OPTNW - option key words to look for C BASE - location in CARD to begin search C reset to 1 if new card read C IPOS - ending position, 0 if no more continuation lines. C IOPTN - C CHARACTER*256 CARD COMMON /CRDBLK/ CARD INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 LOGICAL REFRSH EXTERNAL REFRSH C 100 FORMAT(/,5X,'UNMATCHED OPTION: ',A12) C IPT=BASE 1 CONTINUE C C Call EQSCAN to find out how much of keyword = value C appears C CALL EQSCAN(IPT,IPOS,KEYWRD,IFLAG) C C If new line has been read, reset BASE C IF(IPT.EQ.1)BASE=1 C C EQSCAN returns 1 for keyword = C 2 for keyword followed by a character other than = C IF(IFLAG.EQ.1.OR.IFLAG.EQ.2) THEN VNKEYW(1)=KEYWRD(1:12) DO 3 J=1,NOPTN CALL VNMTCH(OPTNW(J),VNKEYW,1,IPOS2) IF(IPOS2.GT.0) THEN C C If keyword matches, initialize from IVALUE C IOPTN(INDX(J))=IVALUE(J) IF(IFLAG.EQ.1) THEN CALL IFIND(CARD(IPOS:256),IPOS,256,IPT,IVAL) IF(IPT.GT.0) THEN IOPTN(INDX(J))=IVAL IPOS=IPT ELSE IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160055 RETURN ELSE CALL FPSTOP(160055,IPOS) END IF END IF ELSE IPT=IPOS END IF GO TO 5 END IF 3 CONTINUE C C If no match, print message and treat as nonfatal error. C WRITE(U6,100)VNKEYW(1) IF(IFLAG.EQ.1) THEN CALL IFIND(CARD(IPOS:256),IPOS,256,IPT,IVAL) IF(IPT.GT.0) THEN IPOS=IPT ELSE IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=160055 RETURN ELSE CALL FPSTOP(160055,IPOS) END IF END IF ELSE IPT=IPOS END IF 5 CONTINUE IF(IPT.GT.256) THEN IF(.NOT.REFRSH(BASE)) RETURN IPT=1 END IF IF(IPT.GT.0)GO TO 1 END IF RETURN END C LOGICAL FUNCTION REFRSH(BASE) C INTEGER BASE C C BASE - reset to 1 C C Refreshes CARD by reading the next record. C U5END is set to 1 on end of primary file. C C Returns TRUE unless end of file or first character is C alphanumeric or _, that is, TRUE indicates that the new record C is a continuation line. C C REFRSH returns FALSE on end of file on the original U5 (while C implementing any INCLUDEs) or when the line appears C to begin a command line. C C Entirely blank records are simply printed and the next record is C read. Consequently, the routine returns with either a nonblank C record or U5END = 1. C C Several accommodations have been made to the new syntax, where C CMPFLG = 1 or U5 may be a scratch file on units 13-17 C C REFRSH handles: C COMMENT and C C ECHO C ERRORFILE C INCLUDE C IGNORE and IGNORE OFF C LONGCOMMENT and LONGCOMMENT OFF C MACROWRITE and MACROEND C SCRATCH1 - SCRATCH7, SCRATCHSTEM C SET C MACROIMPLEMENT and MACROIMPLEMENTEND C and subsequent command lines associated with processing these C features. The calling routine does not have to be concerned C with them. C C 12/97 REFRSH also implements the /* comment */ syntax, keeping C track of the number of /*'s encountered. C C CARDIN - holds the command line as read. C CARDIM - (intermediate) holds the line with all the resulting C substitutions implemented, including /* comments */ C and ! comments. CRDPRN prints CARDIN and CARDIM (if C different). C CARD - the command line to be interpreted, with comments removed C C At the end of an INCLUDEd file, REFRSH also switches the input file C in the stack to the calling INCLUDEd file or primary input file. C Consequently, RETURN occurs to the calling routine when the next C record to be processed normally has been read, or on end of file C for the input stream. C PARAMETER (MAXSUB=500,MAXSBL=2000,MAXSNL=24) PARAMETER (MAXSBC=6000) PARAMETER (MAXFMT=20) PARAMETER (MAXALT=5) PARAMETER (MSIZED=1000000) DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI, . NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL), . U5LCSW COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI, . NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 INTEGER U5ALT(MAXALT),U5ASTT(MAXALT) CHARACTER *80 U5LINE(MAXALT) COMMON /A5BLCK/U5ALT,U5ASTT COMMON /U5LBLK/U5LINE CHARACTER*256 CARD COMMON /CRDBLK/CARD CHARACTER*80 CARDIN CHARACTER*(MAXSNL) SUBNAM(MAXSUB) CHARACTER*12 SUBCSV(MAXSBC) COMMON /CINBLK/CARDIN,SUBNAM,SUBCSV LOGICAL ALPCHK,DGTCHK EXTERNAL ALPCHK,DGTCHK LOGICAL MACROI,FOPEND INTEGER IFLAGI(3),ITYPEI(3) C CHARACTER*160 FNERRR,FNWARN COMMON /IOBLK3/FNERRR,FNWARN CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW, . OSCODE,NEWFNM COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE, . ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM CHARACTER*256 CARDWK,CARDSV,CARDIM COMMON /CMBLK2/CARDWK,CARDSV,CARDIM C CHARACTER*1 C,A(31) CHARACTER*6 LFMT CHARACTER*176 OVERFL C C The data statement contains all of the ASCII characters that VPLX C will recognize, in addition to letters and digits. This form is C used with Microsoft PowerStation for the PC, and VAX, among others. C C DATA A/'$','?','!','"','#','%','&','(',')','*', C . '+',',','-','.','/',':',';','<','=','>', C . '?','@','[','\',']','^','{','}','|','~','`'/ C C Special form for SUN OS and UNIX generally to handle \. C A single \ is interpreted as an escape character, so \\ is C required in the DATA statement. C DATA A/'$','?','!','"','#','%','&','(',')','*', . '+',',','-','.','/',':',';','<','=','>', . '?','@','[','\\',']','^','{','}','|','~','`'/ C C 100 FORMAT(A80,A176) 101 FORMAT(1X,A79) 102 FORMAT(1X,A80) 103 FORMAT(1X) 107 FORMAT('(A',I1,')') 108 FORMAT('(A',I2,')') 109 FORMAT(I1,'.tmp') 200 FORMAT(5X,'WARNING - UNEXPECTED CHARACTER(S) CONVERTED TO BLANK IN . THE NEXT RECORD') 202 FORMAT(' TOO MANY LEVELS, MAXIMUM=',I2) 203 FORMAT(' UNSUCCESSFUL SUBSTITUTION') 204 FORMAT(' WARNING: UNBALANCED OFF') 205 FORMAT(' SET ERROR') 206 FORMAT(' RESOURCE CONSTRAINT') 207 FORMAT(' INCLUDE FAILED') C ISTAT=0 REFRSH=.FALSE. BASE=1 ISBFLG=0 C C MACROIMPLEMENT 3/97 C Always set MACROI to FALSE when REFRSH is called. C MACROI=.FALSE. C C Just in case, RETURN if already at end-of-file C IF(U5END.EQ.1)THEN IF(U5.GE.13.AND.U5.LE.17) THEN GO TO 90 ELSE IF(MACROI) THEN CLOSE(UNIT=MACROF) END IF RETURN END IF END IF C C ISTAT = 0 normal reading of input stream C 1 LONGCOMMENT C 2 IGNORE C 3 COMMENT C 4 SET C 5 INCLUDE C 6 SCRATCH, SCRATCHSTEM C 7 MACROWRITE statement C 8 ON statement C 9 ERRORFILE C 10 MACROIMPLEMENT statement C C LEVEL keeps track of the nesting of IGNORE, and LONGCOMMENT C C ISSLVL keeps track of the net balance between /* and */ C C U5LCSW is initialized to 1 in the main program to VPLX. C REFRSH sets it to 2 on reading any line that may contain file names, C such as the beginning of a step. When U5LCSW=2, it will be set C to 3 here when all associated records with the filename(s) have been C read. It is set =4 when the end of file is reached while reading C a file name. C When REFRSH is called with U5LCSW=3, it is reset to 1. C C C The logic for SET and substitutions is complex. The following C descriptions are repeated later in the subroutine: C C Variables and arrays used by SET and substitutions: C C NSUB - the number of assigned substitution strings C NSUBLM - the number of assigned lines C NSUBCM - the number of assigned elements of the character array C ISUBCN - ISUB for a substitution string with continuation lines, C while in use. C ICHCNT - holds current position in line in case of substitution C of multi-line strings. C CININI - 1 - a line has just been read from the input file C 0 - this is a continuation line. C NSUBLN - number of lines for the substitution string. C IPTSBL - pointer from ISUB to the first line of substitution. C NSBCHR - number of characters in the substitution line C IPTSBC - pointer from ILINE to the first element of character C array for the line. C U5LCSW - switch to control flow when step or subroutine referencing C file names encountered. C C The main routine begins a VPLX run with the following C initializations related to substitutions connected with SET: C C NSUB=0 C NSUBLM=0 C NSUBCM=0 C ISUBCN=0 C ILNCNT=0 C ICHCNT=0 C U5LCSW=1 C ISTAT=0 C LEVEL=0 C 1 CONTINUE C C First, fill the end of CARDIM with blanks, if substitutions are C possible. C IF(NSUB.GT.0) THEN CALL STBLNK(CARDIM,81,256) END IF C C Next, determine if should read from input file or from the C continuation of a multi-line substitution. C C If U5LCSW is 3, may now reset U5LCSW to 1 and begin to process C string held in CARD since previous call. C IF(U5LCSW.EQ.3) THEN U5LCSW=1 C C If U5LCSW is 4, INCLUDED file ended with a statement including a C file name (although not an INCLUDE statement). Control has been C returned to the calling program already to conclude processing of C filename. At this point, must transfer to 90 to handle end of C the INCLUDEd file. C ELSE IF(U5LCSW.EQ.4) THEN C ! Open new file (delayed U5LCSW=1 C ! until file name GO TO 90 C ! processing completed ELSE IF(ISUBCN.GT.0) THEN C C Copy continuation lines of multi-line substitution here. C Multiline substitutions occur when a SET statement equates C a name to two or more lines. C C CININI is passed to CRDPRN to identify substitution continuation C lines. The variable is usually 1 but is zero for substitution C lines. C ILNCNT is the count of continuation lines processed. C ICHCNT saves the position of the next character from the initial C input line to be interpreted after the completion of a C multiline substitution. C CININI=0 IF(ILNCNT.LT.NSUBLN(ISUBCN)) THEN C C Continuation line copied into CARDIM here. C ILINE=IPTSBL(ISUBCN)+ILNCNT JJ=IPTSBC(ILINE) DO 4 J=1,NSBCHR(ILINE),12 CARDIM(J:J+11)=SUBCSV(JJ) JJ=JJ+1 4 CONTINUE IF(NSBCHR(ILINE).LT.80) THEN DO 5 J=NSBCHR(ILINE)+1,80 CARDIM(J:J)=' ' 5 CONTINUE END IF C C Increment ILNCNT here, to reflect number of line just added. C ILNCNT=ILNCNT+1 ELSE C C If, after multi-line substitution, copy the remaining contents C of CARDIN, if present. Set ILNCNT=0 and ISUBCN=0 to prevent C coming through this loop again, unless another multi-line C substitution is initiated. C ISUBCN=0 ILNCNT=0 DO 6 J=1,ICHCNT-1 CARDIM(J:J)=' ' 6 CONTINUE CARDIM(ICHCNT:80)=CARDIN(ICHCNT:80) END IF ELSE C C Reading of record from input file. This is the normal circumstance. C CININI=1 IF(U5.GE.13.AND.U5.LE.17) THEN READ(U5,END=90)CARDIM LNCNTR=LNCNTR+1 ELSE READ(U5,100,END=90)CARDIN,OVERFL CALL NBFIND(OVERFL,1,20,IPOS) IF(IPOS.GT.0) THEN IF(CMPFLG.EQ.1) THEN IMERR1=160117 RETURN ELSE CALL FESTOP(160117) END IF END IF CARDIM(1:80)=CARDIN END IF END IF C C If currently in process of reading lines that may contain file C names, (when U5LCSW=2), stop reading lines and hold them in CARD, C if encounter nonblank position 1. (Except for MACROI.) C Note that, in a sense, the RETURN occurs prematurely, for C example, no substitutions will have been made yet for substitution C strings in CARD. After the calling routine completes the process of C opening files, the calling routine must call REFRSH again to C complete the processing of CARD. C C This complex logic arises to ensure that all file processing is C completed before attempting to process CARDIM, which itself may C contain file references, e.g., when it has INCLUDE. C IF(U5LCSW.EQ.2) THEN IF(CARDIM(1:1).NE.' ') THEN IF(ISUBCN.GT.0) THEN C C If continuation line of substitution continues beyond file name, C the logic is in trouble - generate error. C WRITE(U6,207) IF(CMPFLG.EQ.1) THEN IMERR1=160100 RETURN ELSE CALL FESTOP(160100) END IF ELSE C C Return here if at end of file specification but next line continues C a command. Calling routine should complete all decisions based on C the file name before calling REFRSH again. C U5LCSW=3 RETURN END IF END IF END IF 7 CONTINUE C C For INCLUDE, MACROWRITE, and MACROIMPLEMENT, check if file name C appears to have been read. All three skip to 37 to avoid C implementing substitutions on next card: C INCLUDE - the INCLUDED file may contain SET statements with C consequences for CARD C MACROWRITE - the contents of CARD should be written without C implementing substitutions. C MACROIMPLEMENT - should go to special MACROIMPLEMENT processing C IF(ISTAT.EQ.5.OR.ISTAT.EQ.7.OR.ISTAT.EQ.10) THEN IF(ICLEND.EQ.1) THEN GO TO 37 ELSE IF(CARDIM(1:1).NE.' '.OR.IFLAGI(1).GT.0) THEN ICLEND=1 GO TO 37 C C If have read a complete file name (IFNAME=1), but have not yet C begun to read file parameters initiated by '(', then stop scanning C if next nonblank character is not '(' C ELSE IF(IFNAME.EQ.1.AND.IFPSW.EQ.1) THEN CALL NBFIND(CARDIM(1:256),1,256,IPOS) IF(IPOS.GT.0) THEN IF(CARDIM(IPOS:IPOS).NE.'(') THEN ICLEND=1 GO TO 37 END IF END IF END IF END IF ICLEND=0 IFLAG=0 IAPOST=0 C C Find last nonblank character in CARDIM. ILAST will be used C repeatedly to avoid repeated unnecessary scans through 240 c characters in CARDIM. C CALL LASTCI(ILAST) C C Loop to fill in substitution strings if ISUBCN = 0, that is, C if not already inside a multi-line substitution. C IONFLG=0 IF(ISUBCN.EQ.0) THEN J=1 ICHCNT=1 8 CONTINUE IF(CARDIM(J:J).EQ.'&') THEN JJ=J+1 IF(ALPCHK(CARDIM(JJ:JJ))) THEN JJ=JJ+1 10 CONTINUE IF(ALPCHK(CARDIM(JJ:JJ)).OR.DGTCHK(CARDIM(JJ:JJ)).OR. . CARDIM(JJ:JJ).EQ.'.') THEN IF(JJ.LE.J+MAXSNL) THEN JJ=JJ+1 GO TO 10 END IF ELSE IF(CARDIM(JJ:JJ).EQ.'&') THEN C C Arrive here if CARDIM(J:JJ) contains &stringname& C Check to see if name has already appeared. C IF(NSUB.GT.0) THEN ILEN=JJ-J-1 DO 22 I=1,NSUB CALL CMATCH(SUBNAM(I),1,MAXSNL,CARDIM(J+1:JJ-1),ILEN, . IPOS2,1) IF(IPOS2.GT.0) THEN C C Successful match C ILINE=IPTSBL(I) N=NSBCHR(ILINE) II=IPTSBC(ILINE) ICHCNT=ICHCNT+ILEN+1 C C First, shift the contents of CARDIM to make room for substitution. C IDIF=N-ILEN-2 IF(IDIF.GT.0.AND.JJ.LT.ILAST) THEN IF(ILAST+IDIF.GT.240) THEN CALL CRDPRN(2) WRITE(U6,203) IF(CMPFLG.EQ.1) THEN IMERR1=160101 RETURN ELSE CALL FESTOP(160101) END IF END IF DO 12 K=ILAST,JJ+1,-1 CARDIM(K+IDIF:K+IDIF)=CARDIM(K:K) 12 CONTINUE ELSE IF(IDIF.LT.0) THEN IF(JJ.LT.ILAST) THEN DO 14 K=JJ+1,ILAST CARDIM(K+IDIF:K+IDIF)=CARDIM(K:K) 14 CONTINUE END IF C C In this case, we must fill vacated space with blanks. C DO 15 K=-1,IDIF,-1 CARDIM(ILAST+1+K:ILAST+1+K)=' ' 15 CONTINUE END IF C C Update both ILAST and JJ to reflect length of substituted string. C ILAST=ILAST+IDIF JJ=JJ+IDIF C C Special check during MACROIMPLEMENT - is ON substituted C at the beginning of a line? C IF(MACROI) THEN IF(N.EQ.2.AND.J.EQ.1) THEN CALL CMATCH(SUBCSV(II),1,2,'ON',2,IONFLG,2) END IF END IF C C Make the substitution here. C NFULL=N/12 IF(NFULL.GT.0) THEN DO 16 K=1,NFULL CARDIM(J:J+11)=SUBCSV(II) J=J+12 II=II+1 16 CONTINUE N=N-NFULL*12 END IF C C For residual, if any. C IF(N.GT.0) THEN CARDIM(J:JJ)=SUBCSV(II)(1:N) END IF C C If substitution is single line, continue looping, else C store appropriate information for first line of multi-line C string. C IF(NSUBLN(I).EQ.1) THEN J=JJ GO TO 24 ELSE ISUBCN=I ILNCNT=1 C C At this point, store information on whether residual remains in C CARDIN, or whether multi-line substitution begins at end of line. C IF(JJ.GE.ILAST) THEN ICHCNT=0 ELSE ICHCNT=ICHCNT+1 DO 18 J=JJ+1,ILAST CARDIM(J:J)=' ' 18 CONTINUE END IF C C Since have now set ISUBCN > 0, skip to 33 avoids instructions C appropriate only for single lines. C GO TO 33 END IF END IF 22 CONTINUE END IF C C Arrive here if no stored substitutions, or if no match. Except C under LONGCOMMENT, IGNORE, or COMMENT, this is a fatal error. C IF(ISTAT.EQ.0.OR.ISTAT.GT.3) THEN IF(CARDIM(1:1).NE.' ') THEN C C This code checks whether the current line is a COMMENT line. C K=1 IF(CARDIM(1:1).EQ.'_') THEN CALL NBFIND(CARDIM(2:256),2,256,K) END IF CALL CMATCH(CARDIM(K:256),K,256,'COMM',4,KK,2) IF(KK.EQ.0) THEN CALL CMATCH(CARDIM(K:256),K,256,'C',1,KK,1) END IF IF(KK.GT.0) GO TO 24 END IF C C Error call for unsuccessful substitution. C CALL CRDPRN(2) WRITE(U6,203) IF(CMPFLG.EQ.1) THEN IF(NSUB.EQ.0) THEN IMERR1=160103 ELSE IMERR1=160102 END IF IMERR2=J RETURN ELSE IF(NSUB.EQ.0) THEN CALL FPSTOP(160103,J) ELSE CALL FPSTOP(160102,J) END IF END IF END IF 24 CONTINUE END IF C C Convert && into & without making substitutions C ELSE IF(CARDIM(JJ:JJ).EQ.'&') THEN DO 26 K=JJ,ILAST CARDIM(K:K)=CARDIM(K+1:K+1) 26 CONTINUE ILAST=ILAST-1 ICHCNT=ICHCNT+1 END IF END IF J=J+1 ICHCNT=ICHCNT+1 IF(J.LT.ILAST)GO TO 8 C C If all substitutions successful to here, there is no residual in C CARDIN. C C NLINE - keeps track of records written to unit 13 from REFRSH, for C use with CMPFLG=1 (new syntax). C LNCNTR - relative counter of input lines from units 13-17. C It is often set to 0 or to a specific value in C another routine. C ICHCNT=0 IF(CMPFLG.EQ.1) THEN IF(CARDIN.NE.CARDIM(1:80).AND.ISTAT.NE.1.AND.ISTAT.NE.2) THEN CALL STBLNK(CARDWK,1,256) CALL ROOMD(2) IF(U5ENOW.GE.1) THEN C ! Here and elsewhere, when DX(NXPTD-2)=1 C ! CMPFLG==1, store in DX(NXPTD-1) DX(NXPTD-1)=1 C ! the effective value of u5echo ELSE C ! for later printing. DX(NXPTD-2)=0 C ! For substituted line, print DX(NXPTD-1)=0 C ! under ECHO and ECHO LITE END IF WRITE(13)CARDWK CARDWK(1:80)=CARDIN WRITE(13)CARDWK NLINE=NLINE+2 ISBFLG=1 C ! Flag to mark substitutions END IF END IF END IF C C Beginning of multi-line substitutions have skipped to here. C 33 CONTINUE C C If all lines have been substituted, and if there is no residual in C CARDIN, set ISUBCN=0 here, to read a new record into CARDIN at 1. C IF(ISUBCN.GT.0) THEN IF(ILNCNT.EQ.NSUBLN(ISUBCN)) THEN IF(ICHCNT.EQ.0)ISUBCN=0 END IF END IF C C The loop to 40 is to check for non-ASCII characters C Change non-ASCII characters to blank, unless within apostrophies C 37 CONTINUE IAPOST=0 IAPOS2=0 IEXCLF=0 C ! Beginning of ! comment IEXCL2=0 I=1 II=1 38 CONTINUE C=CARDIM(I:I) IF(C.EQ.' ')GO TO 40 IF(IAPOS2.EQ.1) THEN IF(C.EQ.'''') THEN IAPOS2=0 GO TO 40 END IF ELSE IF(IAPOS2.EQ.2) THEN IF(C.EQ.'"') THEN IAPOS2=0 GO TO 40 END IF ELSE IF(C.EQ.'''') THEN IF(IEXCL2.EQ.0) THEN IAPOS2=1 END IF GO TO 40 ELSE IF(C.EQ.'"'.AND.IEXCL2.EQ.0) THEN IAPOS2=2 GO TO 40 ELSE IF(C.EQ.'!') THEN IF(IEXCL2.EQ.0.AND.IAPOS2.EQ.0)IEXCL2=I GO TO 40 END IF IF(IAPOS2.GT.0)GO TO 40 IF(ALPCHK(C))GO TO 40 IF(DGTCHK(C))GO TO 40 DO 39 J=1,31 IF(A(J).EQ.C)GO TO 40 39 CONTINUE C C Special check for Fortran PowerStation 1.0 - skip warning message C on end of file. C IFLAG=1 IF(I.EQ.1) THEN IF(ICHAR(C).EQ.26) THEN IFLAG=0 END IF END IF CARDIM(I:I)=' ' CARD(II:II)=' ' C=' ' 40 CONTINUE IF(ISTAT.EQ.1.OR.ISTAT.EQ.2) THEN C ! LONGCOMMENT, IGNORE IF(IEXCL2.GT.0) THEN CARD(II:II)=' ' ELSE CARD(II:II)=CARDIM(I:I) END IF ELSE IF(C.EQ.'/'.AND.I.LE.255) THEN IF(CARDIM(I+1:I+1).EQ.'*') THEN C ! check for /* IF(I.LE.253.AND.IEXCL2.EQ.0.AND. C ! check for /*/* . IAPOS2.GT.0) THEN IF(CARDIM(I+2:I+3).EQ.'/*') THEN CARD(II:II+1)='/*' I=I+4 II=II+2 IF(I.LE.256) THEN GO TO 38 ELSE GO TO 41 END IF END IF END IF IF(ISTAT.NE.5) THEN ISSLVL=ISSLVL+1 END IF CARD(II:II+1)=' ' I=I+2 II=II+2 IF(I.LE.256) THEN GO TO 38 ELSE GO TO 41 END IF END IF ELSE IF(C.EQ.'*'.AND.I.LE.255) THEN IF(CARDIM(I+1:I+1).EQ.'/') THEN C ! check for */ IF(I.LE.253.AND.IEXCL2.EQ.0.AND. C ! check for */*/ . IAPOS2.GT.0) THEN IF(CARDIM(I+2:I+3).EQ.'*/') THEN CARD(II:II+1)='*/' I=I+4 II=II+2 IF(I.LE.256) THEN GO TO 38 ELSE GO TO 41 END IF END IF END IF IF(ISSLVL.GT.0.AND.ISTAT.NE.5)ISSLVL=ISSLVL-1 CARD(II:II+1)=' ' I=I+2 II=II+2 IF(I.LE.256) THEN GO TO 38 ELSE GO TO 41 END IF END IF END IF IF(ISSLVL.GT.0.OR.IEXCLF.GT.0) THEN CARD(II:II)=' ' ELSE CARD(II:II)=C IF(IAPOST.EQ.1.AND.C.EQ.'''') THEN IAPOST=0 ELSE IF(IAPOST.EQ.2.AND.C.EQ.'"') THEN IAPOST=0 ELSE IF(C.EQ.'''') THEN IAPOST=1 ELSE IF(C.EQ.'"') THEN IAPOST=2 ELSE IF(C.EQ.'!'.AND.IAPOST.EQ.0) THEN IEXCLF=II CARD(II:II)=' ' END IF END IF END IF I=I+1 II=II+1 IF(I.LE.256) GO TO 38 41 CONTINUE IF(II.LT.256) THEN II=II+1 CALL STBLNK(CARD,II,256) END IF CALL LASTCR(ILAST) IF(ISTAT.EQ.1.OR.ISTAT.EQ.2) THEN IEXCLF=IEXCL2 END IF C C Warning message for non-ASCII characters. C IF(IFLAG.EQ.1) THEN IF(CMPFLG.EQ.1) THEN CALL STBLNK(CARDWK,1,256) WRITE(CARDWK,200) WRITE(13)CARDWK NLINE=NLINE+1 CALL ROOMD(1) C ! Print warning for non-ASCII DX(NXPTD-1)=U5ENOW C ! characters under ECHO ELSE WRITE(U6,200) END IF END IF C C If the previous line was ON, reset ISTAT to 0. C IF(ISTAT.EQ.8)ISTAT=0 C C Scan the image for ECHO, LONGCOMMENT, IGNORE, COMMENT, SET, C MACROWRITE, INCLUDE, ERRORFILE, MACROIMPLEMENT, and MACROIMPLEMENTEND C IM=0 C C IM records a match for this line on: C 1 = INCLUDE C 2 = LONGCOMMENT (except within range of IGNORE) C 3 = IGNORE (except within range of LONGCOMMENT) C 4 = ECHO (except within range of IGNORE or LONGCOMMENT) C 5 = SET (except within range of IGNORE or LONGCOMMENT) C 6 = SCRATCH (except within range of IGNORE or LONGCOMMENT) C 7 = MACROWRITE (except within range of IGNORE or LONGCOMMENT) C 9 = ERRORFILE (except within the range of IGNORE or LONGCOMMENT) C 10 = MACROIMPLEMENT C 11 = MACROIMPLEMENTEND C C A letter OR '_' in column 1 ends the range of COMMENT, SET, C INCLUDE, SCRATCH, or MACROWRITE. ICLEND=1 if apparently at C end of the file name associated with INCLUDE or MACROWRITE. C CALL NBFIND(CARDIM,1,256,IEXCLM) C ! Determine if comment IF(IEXCLM.NE.IEXCLF) THEN C ! line IEXCLM=0 END IF C C ISTAT = 0 normal reading of input stream C 1 LONGCOMMENT C 2 IGNORE C 3 COMMENT C 4 SET C 5 INCLUDE C 6 SCRATCH C 7 MACROWRITE statement C 8 ON statement C 9 ERRORFILE C 10 MACROIMPLEMENT statement C IF(ALPCHK(CARD(1:1)).OR.ICLEND.EQ.1.OR.IEXCLM.NE.0) THEN C C Just in case, however, save ISTAT in case it should be restored C after processing INCLUDE. C IF(ICLEND.EQ.0)ISTTSV=ISTAT IF((ISTAT.EQ.3.AND.IEXCLM.EQ.0).OR. C ! COMMENT . ISTAT.EQ.4)ISTAT=0 C ! SET C C Conclude processing of active INCLUDE statement. Save the current C contents of CARDIN, which will be restored only after the INCLUDEd C file has been read. C IF(ISTAT.EQ.5) THEN C ! INCLUDE J=1 IF(IPOSSC.EQ.0) THEN C ! IPOSSC > 0 CALL FNRD2(J,ITYPEI,IFLAGI,2,3,IFPSW, C ! if ';' read . IFNAME,IPOSSC) END IF IF(IMERR1.GT.0) THEN IF(IMERR1.EQ.160316) THEN IMERR1=160104 END IF RETURN ELSE IF(IFLAGI(1).EQ.0) THEN WRITE(U6,207) IF(CMPFLG.EQ.1) THEN IMERR1=160104 RETURN ELSE CALL FESTOP(160104) END IF END IF IF(U5ALT(MAXALT).NE.0) THEN IF(U5ALT(MAXALT).NE.U5) THEN WRITE(U6,202)MAXALT IF(CMPFLG.EQ.1) THEN IMERR1=160105 RETURN ELSE CALL FESTOP(160105) END IF END IF END IF DO 511 I=MAXALT,1,-1 IF(U5ALT(I).NE.0) THEN U5ASTT(I)=1 U5LINE(I)=CARDIN IF(I.LT.MAXALT) THEN U5ALT(I+1)=IFLAGI(1) END IF GO TO 512 END IF 511 CONTINUE 512 CONTINUE U5=IFLAGI(1) C C At this point, ISTAT is restored to its previous value before C encountering the INCLUDE statement. If the previous status was C SCRATCH, MACROWRITE, ERRORFILE, or MACROIMPLEMENT, set to normal C reading instead. C ISTAT=ISTTSV IF(ISTAT.EQ.6.OR.ISTAT.EQ.7.OR.ISTAT.EQ.9.OR. . ISTAT.EQ.10)ISTAT=0 C C Transfer to 1 to begin reading from the new file. C GO TO 1 C C Conclude processing of active SCRATCH statement. C ELSE IF(ISTAT.EQ.6.AND..NOT.MACROI) THEN J=1 IF(ISCRND.EQ.0) THEN CALL FNRD2(J,ITYPEI,IFLAGI,3,3,IFPSW,IFNAME,IPOSSC) END IF IF(IMERR1.GT.0) THEN CALL FSTOP ELSE IF(IFLAGI(1).EQ.0) THEN CALL FESTOP(160106) ELSE IF(IU.GT.0) THEN CALL OPENSC(IU) ELSE CALL FNLGTH(J) IF(J.GT.75) THEN CALL FESTOP(160324) END IF DO 514 I=1,7 IU=12+I INQUIRE(UNIT=IU,OPENED=FOPEND) IF(.NOT.FOPEND) THEN WRITE(FNWRK(J+1:J+5),109)I CALL OPENSC(IU) IF(IMERR1.GT.0) THEN WRITE(U6,102)FNWRK(1:80) CALL FSTOP END IF END IF 514 CONTINUE END IF ISTAT=0 C C Conclude processing of MACROWRITE statement. C ELSE IF(ISTAT.EQ.7) THEN J=1 IF(IPOSSC.EQ.0) THEN CALL FNRD2(J,ITYPEI,IFLAGI,2,3,IFPSW,IFNAME,IPOSSC) END IF IF(IMERR1.GT.0) THEN IF(CMPFLG.EQ.1) THEN RETURN ELSE CALL FSTOP END IF ELSE IF(IFLAGI(2).EQ.0) THEN IF(CMPFLG.EQ.1) THEN IMERR1=160107 RETURN ELSE CALL FESTOP(160107) END IF ELSE IU=IFLAGI(2) END IF C C Begin to write records to the macro file. C 44 CONTINUE IF(CMPFLG.EQ.1) THEN CALL STBLNK(CARDWK,1,256) CARDWK(1:80)=CARDIN WRITE(13)CARDWK C ! Under CMPFLG, print under NLINE=NLINE+1 C ! ECHO only CALL ROOMD(1) DX(NXPTD-1)=U5ENOW ELSE IF(U5ECHO.EQ.1) THEN IF(CARDIN(80:80).EQ.' ') THEN WRITE(U6,101)CARDIN(1:79) ELSE WRITE(U6,102)CARDIN END IF END IF C C Test for MACROEND at end of macro file C CALL CMATCH(CARDIN(1:9),1,9,'MACROEND',8,I,1) IF(I.GT.0) GO TO 46 WRITE(IU,100)CARDIN READ(U5,100,END=46)CARDIN,OVERFL CALL NBFIND(OVERFL,1,20,IPOS) IF(IPOS.GT.0) THEN CALL FESTOP(160117) END IF CARD(1:80)=CARDIN GO TO 44 C C Continue to read records and write to macro file C 46 CONTINUE CLOSE(IU) ISTAT=0 C C Transfer to 1 to continue reading from file. C GO TO 1 C C Conclude processing of active ERRORFILE statement. C ELSE IF(ISTAT.EQ.9) THEN J=1 IF(ISCRND.EQ.0) THEN CALL FNRD2(J,ITYPEI,IFLAGI,4,3,IFPSW,IFNAME,IPOSSC) END IF IF(IMERR1.GT.0) THEN CALL FSTOP END IF FNERRR=FNWRK ISTAT=0 C C Conclude processing of MACROIMPLEMENT C ELSE IF(ISTAT.EQ.10) THEN J=1 IF(IPOSSC.EQ.0) THEN CALL FNRD2(J,ITYPEI,IFLAGI,2,3,IFPSW,IFNAME,IPOSSC) END IF IF(IMERR1.GT.0) THEN CALL FSTOP ELSE IF(IFLAGI(2).EQ.0) THEN CALL FESTOP(160113) ELSE MACROF=IFLAGI(2) MACROI=.TRUE. ISTAT=0 GO TO 7 END IF C END IF C C Processing of command lines beginning with letter or underscore. C Check for INCLUDE, SCRATCH, MACROWRITE and ERRORFILE encountered C during normal reading (not inside the scope of IGNORE, LONGCOMMENT, C etc. C J=1 IF(CARD(1:1).EQ.'_') THEN CALL NBFIND(CARD(2:256),2,256,J) ELSE IF(IEXCLM.GT.0) THEN J=0 END IF I=0 IF(J.GT.0) THEN IF(ISTAT.EQ.0) THEN CALL CMATCH(CARD(J:256),J,256,'INCLUDE',7,I,1) IF(I.GT.0) THEN IM=1 ELSE CALL CMATCH(CARD(J:256),J,256,'MACROWRITE',10,I,1) IF(I.GT.0) THEN IM=7 ELSE IF(CMPFLG.NE.1) THEN CALL CMATCH(CARD(J:256),J,256,'SCRATCH',7,I,2) IF(I.GT.0.AND..NOT.MACROI) THEN CALL IFIND(CARD(I:256),I,256,IPOS,IU) IF(IU.GE.1.AND.IU.LE.7) THEN IU=12+IU I=IPOS IM=6 ELSE CALL CMATCH(CARD(I:256),I,256,'STEM',4,IPOS,1) IF(IPOS.GT.0) THEN IU=-1 I=IPOS IM=6 END IF END IF ELSE CALL CMATCH(CARD(J:256),J,256,'ERRORFILE',9,I,1) IF(I.GT.0.AND..NOT.MACROI.AND.CMPFLG.NE.1) THEN IM=9 ELSE CALL CMATCH(CARD(J:256),J,256, . 'MACROIMPLEMENT',14,I,1) IF(I.GT.0) THEN IF(MACROI) THEN CALL FESTOP(160114) ELSE IM=10 END IF ELSE CALL CMATCH(CARD(J:256),J,256, . 'MACROIMPLEMENTEND',17,I,1) IF(I.GT.0) THEN IM=11 END IF END IF END IF END IF END IF END IF END IF IF(I.EQ.0.AND.ISTAT.NE.2) THEN CALL CMATCH(CARD(J:256),J,256,'LONGCOMMENT',11,I,1) IF(I.GT.0)IM=2 END IF IF(I.EQ.0.AND.ISTAT.NE.1) THEN CALL CMATCH(CARD(J:256),J,256,'IGNORE',6,I,1) IF(I.GT.0)IM=3 END IF IF(I.EQ.0.AND.ISTAT.NE.1) THEN CALL CMATCH(CARD(J:256),J,256,'OFF',3,I,1) IF(I.GT.0)IM=3 END IF IF(I.EQ.0.AND.ISTAT.EQ.0.AND..NOT.MACROI) THEN CALL CMATCH(CARD(J:256),J,256,'ECHO',4,I,1) IF(I.GT.0)IM=4 END IF IF(I.EQ.0.AND.ISTAT.EQ.0) THEN CALL CMATCH(CARD(J:256),J,256,'SET',3,I,1) IF(I.GT.0)IM=5 END IF IF(I.EQ.0.AND.ISTAT.EQ.0.AND.CMPFLG.EQ.0.AND..NOT.MACROI) THEN C C For regular key words, call KYFND2 to identify. C CALL KYFND2(IGROUP,IKEY,I) C C The following checks for the first line of any step name or C subroutine that will read file names. U5LCSW is set to 2 to C identify that reading of a file name is in progress. C C Special Note: This IF statement must be amended in adding C steps or TRANSFORM subroutines that employ file names. C IF(IKEY.GT.0) THEN IF(IGROUP.EQ.0.OR.IGROUP.EQ.4.OR. . (IGROUP.EQ.7.AND. . (IKEY.EQ.19.OR.IKEY.EQ.20)).OR. C ! LINK, LINK_MISSING . (IGROUP.EQ.8.AND.IKEY.EQ.7)) THEN C ! INCORPORATE U5LCSW=2 END IF END IF I=0 END IF C C Instead of setting IM, change status immediately for COMMENT and ON C C or any string beginning with COMM is treated as COMMENT. C IF(I.EQ.0.AND.ISTAT.EQ.0.AND..NOT.MACROI) THEN CALL CMATCH(CARD(J:256),J,256,'COMM',4,I,2) IF(I.EQ.0) THEN CALL CMATCH(CARD(J:256),J,256,'C',1,I,1) END IF IF(I.GT.0.AND.CMPFLG.EQ.0) THEN ISTAT=3 IF(U5ECHO.EQ.1)WRITE(U6,103) I=0 ELSE CALL CMATCH(CARD(J:256),J,256,'ON',2,I,1) IF(I.GT.0) THEN ISTAT=8 I=0 IF(CMPFLG.EQ.1) THEN CALL STBLNK(CARDWK,1,256) WRITE(13)CARDWK NLINE=NLINE+1 CALL ROOMD(1) C ! Under CMPFLG==, print ON only DX(NXPTD-1)=U5ENOW C ! UNDER ECHO ? ELSE IF(U5ECHO.EQ.1)WRITE(U6,103) END IF END IF END IF END IF END IF C C Except for COMMENT, now handle the consequences of INCLUDE, C LONGCOMMENT, IGNORE, SET, ECHO, MACROIMPLEMENT and C MACROIMPLEMENTEND here. C IF(I.GT.0) THEN C C Print according to U5ECHO, but always print ECHO itself. C IF(CMPFLG.EQ.1) THEN IF(CARDIN.NE.CARD(1:80).AND.(ISTAT.EQ.1.OR.ISTAT.EQ.2)) THEN CARDWK(1:80)=CARDIN WRITE(13)CARDWK NLINE=NLINE+1 CALL ROOMD(1) IF(U5ENOW.GE.1.OR.IM.EQ.4) THEN DX(NXPTD-1)=1 ELSE DX(NXPTD-1)=0 END IF END IF C CALL STBLNK(CARDWK,1,256) C WRITE(13)CARDWK WRITE(13)CARD C NLINE=NLINE+2 NLINE=NLINE+1 CALL ROOMD(1) IF(U5ENOW.GE.1.OR.IM.EQ.4) THEN DX(NXPTD-1)=1 ELSE DX(NXPTD-1)=0 END IF ELSE IF(CMPFLG.NE.1) THEN IF(U5ECHO.GT.0.OR.(IM.EQ.4.AND..NOT.MACROI)) THEN WRITE(U6,103) CALL CRDPRN(2) C ! Note that ! comments END IF C ! removed from CARD here END IF C C INCLUDE C IF(IM.EQ.1) THEN C C Nesting on INCLUDE can go MAXALT+1 deep, i.e., each element of U5ALT C can be different, as well as U5, for a total of MAXALT+1 open units. C ITYPEI(1)=1 ITYPEI(2)=0 ITYPEI(3)=0 IPT=I+1 CALL FNRD2(IPT,ITYPEI,IFLAGI,2,1,IFPSW,IFNAME,IPOSSC) IF(IMERR1.GT.0) THEN IF(CMPFLG.EQ.1) THEN RETURN ELSE CALL FSTOP END IF END IF ISTAT=5 IACTN=2 IF(IPOSSC.NE.0)ICLEND=1 GO TO 1 C C SCRATCH C ELSE IF(IM.EQ.6) THEN ITYPEI(1)=1 ITYPEI(2)=0 ITYPEI(3)=0 CALL FNRD2(I,ITYPEI,IFLAGI,3,1,IFPSW,IFNAME,IPOSSC) IF(IMERR1.GT.0) THEN CALL FSTOP END IF ISTAT=6 IACTN=3 IF(IPOSSC.NE.0)THEN ICLEND=1 ISCRND=1 ELSE ISCRND=0 END IF GO TO 1 C C MACROWRITE C ELSE IF(IM.EQ.7) THEN ITYPEI(1)=0 ITYPEI(2)=1 ITYPEI(3)=0 IPT=I+1 CALL FNRD2(IPT,ITYPEI,IFLAGI,2,1,IFPSW,IFNAME,IPOSSC) IF(IMERR1.GT.0) THEN IF(CMPFLG.EQ.1) THEN RETURN ELSE CALL FSTOP END IF END IF ISTAT=7 IACTN=2 IF(IPOSSC.NE.0)ICLEND=1 GO TO 1 C C ERRORFILE C ELSE IF(IM.EQ.9) THEN ITYPEI(1)=1 ITYPEI(2)=0 ITYPEI(3)=0 IPT=I+1 CALL FNRD2(IPT,ITYPEI,IFLAGI,4,1,IFPSW,IFNAME,IPOSSC) IF(IMERR1.GT.0) THEN CALL FSTOP END IF ISTAT=9 IACTN=1 IF(IPOSSC.NE.0)THEN ICLEND=1 ISCRND=1 ELSE ISCRND=0 END IF GO TO 1 C C MACROIMPLEMENT C ELSE IF(IM.EQ.10) THEN ITYPEI(1)=0 ITYPEI(2)=1 ITYPEI(3)=0 IPT=I+1 CALL FNRD2(IPT,ITYPEI,IFLAGI,2,1,IFPSW,IFNAME,IPOSSC) IF(IMERR1.GT.0) THEN CALL FSTOP END IF ISTAT=10 IACTN=2 IF(IPOSSC.NE.0)ICLEND=1 GO TO 1 C C MACROIMPLEMENTEND C ELSE IF(IM.EQ.11) THEN ISTAT=0 MACROI=.FALSE. CLOSE(UNIT=MACROF) GO TO 1 ELSE IF(IM.NE.5) THEN C C LONGCOMMENT, IGNORE, ECHO C First, assume "ON", then check for "OFF" or "LITE" C Note that only this line is checked - continuation lines C are not anticipated i.e., C ECHO C off C will not be interpreted as C ECHO off C C LEVEL keeps tract of the depth of IGNORE or LONGCOMMENT statements. C IF(IM.EQ.2) THEN ISTAT=1 LEVEL=LEVEL+1 ELSE IF(IM.EQ.3) THEN ISTAT=2 LEVEL=LEVEL+1 ELSE IF(CMPFLG.NE.1) THEN U5ECHO=1 ELSE U5ENOW=1 END IF C C Check here for IGNORE OFF, LONGCOMMENT OFF, ECHO OFF C CALL NBFIND(CARD(I:256),I,256,J) IF(J.GT.0) THEN CALL CMATCH(CARD(J:256),J,256,'OFF',3,I,1) IF(I.GT.0) THEN IF(IM.EQ.4) THEN IF(CMPFLG.NE.1) THEN U5ECHO=0 ELSE U5ENOW=0 END IF ELSE LEVEL=LEVEL-2 IF(LEVEL.LE.0) THEN IF(LEVEL.EQ.-1) THEN IF(CMPFLG.EQ.1) THEN CALL STBLNK(CARDWK,1,256) WRITE(CARDWK,204) WRITE(13)CARDWK C ! For CMPFLG==1, always NLINE=NLINE+1 C ! print warning CALL ROOMD(1) DX(NXPTD-1)=1 ELSE WRITE(U6,204) END IF LEVEL=0 END IF ISTAT=0 END IF END IF C C Check for ECHO LITE C ELSE IF(IM.EQ.4) THEN CALL CMATCH(CARD(J:256),J,256,'LITE',4,I,1) IF(I.GT.0) THEN IF(CMPFLG.EQ.1) THEN U5ENOW=2 ELSE U5ECHO=2 END IF END IF END IF END IF C C If LONGCOMMENT, IGNORE, or ECHO, read next record C GO TO 1 ELSE C C Initialize SET, J records where to begin processing C ISTAT=4 ISUB=0 CALL NBFIND(CARD(I:256),I,256,J) END IF END IF ELSE IF(ISTAT.EQ.4) THEN C C Continuation line of SET, J records where to begin processing C CALL NBFIND(CARD(1:256),1,256,J) IF(CMPFLG.EQ.1) THEN WRITE(13)CARD NLINE=NLINE+1 CALL ROOMD(1) DX(NXPTD-1)=U5ENOW ELSE CALL CRDPRN(0) END IF ELSE IF(ISTAT.EQ.5.OR.ISTAT.EQ.6.OR.ISTAT.EQ.7.OR.ISTAT.EQ.10)THEN C C Continue to read file name for INCLUDE, SCRATCH, MACROWRITE, C MACROIMPLEMENT. C J=1 CALL FNRD2(J,ITYPEI,IFLAGI,IACTN,2,IFPSW,IFNAME,IPOSSC) IF(IMERR1.GT.0) THEN IF(CMPFLG.EQ.1) THEN RETURN ELSE CALL FSTOP END IF END IF IF(CMPFLG.EQ.1) THEN WRITE(13)CARD NLINE=NLINE+1 CALL ROOMD(1) DX(NXPTD-1)=U5ENOW ELSE CALL CRDPRN(0) END IF IF(IPOSSC.NE.0)ICLEND=1 C C Transfer to 1 to read next line. C GO TO 1 END IF C C Processing of SET here, for both initial and continuation lines. C C Variables and arrays used by SET and substitutions: C C NSUB - the number of assigned substitution strings C NSUBLM - the number of assigned lines C NSUBCM - the number of assigned elements of the character array C ISUBCN - ISUB for a substitution string with continuation lines, C while in use. C ICHCNT - holds current position in line in case of substitution C of multi-line strings. C CININI - 1 - a line has just been read from the input file C 0 - this is a continuation line. C NSUBLN - number of lines for the substitution string. C IPTSBL - pointer from ISUB to the first line of substitution. C NSBCHR - number of characters in the substitution line C IPTSBC - pointer from ILINE to the first element of character C array for the line. C U5LCSW - switch to control flow when step or subroutine referencing C file names encountered. C IF(ISTAT.EQ.4) THEN IAPOST=0 C IF(IEXCLF.GT.1) THEN ! Adjust ILAST to C DO 50 ILAST=IEXCLF-1,1,-1 ! last character C IF(CARD(ILAST:ILAST).NE.' ') GO TO 501 ! before comments C 50 CONTINUE C ILAST=1 C END IF C 501 CONTINUE IF(ILAST.GT.1.AND.CARD(ILAST:ILAST).EQ.';') THEN ISCEND=1 C ! ISCEND - flag K=ILAST-1 C ! indicating ending DO 502 ILAST=K,1,-1 C ! ';' IF(CARD(ILAST:ILAST).NE.' ') GO TO 503 502 CONTINUE ILAST=1 503 CONTINUE ELSE ISCEND=0 END IF 51 CONTINUE IF(J.EQ.0) GO TO 1 C C If name of string has not yet been established, the name should C begin at J. C IF(ISUB.EQ.0) THEN IF(.NOT.ALPCHK(CARD(J:J))) THEN WRITE(U6,205) IF(CMPFLG.EQ.1) THEN IMERR1=160111 RETURN ELSE CALL FPSTOP(160111,J) END IF END IF JJ=J+1 52 CONTINUE IF(ALPCHK(CARD(JJ:JJ)).OR.DGTCHK(CARD(JJ:JJ)).OR. . CARD(JJ:JJ).EQ.'.') THEN JJ=JJ+1 IF(JJ.LE.J+MAXSNL)GO TO 52 WRITE(U6,205) IF(CMPFLG.EQ.1) THEN IMERR1=160112 RETURN ELSE CALL FPSTOP(160112,JJ) END IF END IF LEN=JJ-J JJ=JJ-1 C C At this point, the name is in the range J:JJ C C Check if name already in use C IF(NSUB.GT.0) THEN DO 54 I=1,NSUB CALL CMATCH(SUBNAM(I),1,MAXSNL,CARD(J:JJ),LEN,IPOS2,1) IF(IPOS2.GT.0) THEN ISUB=I ISUBLN=IPTSBL(I) NSBCHR(ISUBLN)=0 C C If ISUBLN = NSUBLM, may reuse space, otherwise, ISUBLN and IPTSBL C will be reassigned below. C IF(ISUBLN.EQ.NSUBLM) THEN NSUBCM=IPTSBC(ISUBLN) ELSE ISUBLN=0 END IF GO TO 55 END IF 54 CONTINUE 55 CONTINUE END IF C C Assign ISUB here if not matched. C IF(ISUB.EQ.0) THEN NSUB=NSUB+1 ISUB=NSUB IF(NSUB.GT.MAXSUB) THEN WRITE(U6,206) IF(CMPFLG.EQ.1) THEN IMERR1=160108 RETURN ELSE CALL FESTOP(160108) END IF END IF ISUBLN=0 SUBNAM(ISUB)=CARD(J:JJ) IF(LEN.LT.MAXSNL) THEN DO 56 L=LEN+1,MAXSNL SUBNAM(ISUB)(L:L)=' ' 56 CONTINUE END IF END IF C C Except in case of match to previous ISUBLN=NSUBLM, assign ISUBLN to C new space here. C IF(ISUBLN.EQ.0) THEN NSUBLM=NSUBLM+1 IF(NSUBLM.GT.MAXSBL) THEN WRITE(U6,206) IF(CMPFLG.EQ.1) THEN IMERR1=160109 RETURN ELSE CALL FESTOP(160109) END IF END IF NSUBCM=NSUBCM+1 IF(NSUBCM.GT.MAXSBC) THEN WRITE(U6,206) IF(CMPFLG.EQ.1) THEN IMERR1=160110 RETURN ELSE CALL FESTOP(160110) END IF END IF ISUBLN=NSUBLM IPTSBL(ISUB)=ISUBLN NSBCHR(ISUBLN)=0 IPTSBC(ISUBLN)=NSUBCM END IF JJ=JJ+1 C C Set IEQUAL=0 to indicate that we have not yet matched "=" C IEQUAL=0 NSUBLN(ISUB)=1 CALL NBFIND(CARD(JJ:256),JJ,256,J) IF(J.GT.0)GO TO 51 GO TO 1 ELSE IF(IEQUAL.EQ.0) THEN C C Check for "=" - if do not match, assume are at beginning of string C IEQUAL=1 LFIRST=1 IF(CARD(J:J).EQ.'=') THEN JJ=J+1 CALL NBFIND(CARD(JJ:256),JJ,256,J) IF(J.EQ.0)GO TO 1 END IF GO TO 51 ELSE C C If not at first line of substitution, record new line. C IF(LFIRST.EQ.0) THEN NSUBLN(ISUB)=NSUBLN(ISUB)+1 NSUBLM=NSUBLM+1 IF(NSUBLM.GT.MAXSBL) THEN WRITE(U6,206) IF(CMPFLG.EQ.1) THEN IMERR1=160109 RETURN ELSE CALL FESTOP(160109) END IF END IF NSUBCM=NSUBCM+1 IF(NSUBCM.GT.MAXSBC) THEN WRITE(U6,206) IF(CMPFLG.EQ.1) THEN IMERR1=160110 RETURN ELSE CALL FESTOP(160110) END IF END IF ISUBLN=NSUBLM NSBCHR(ISUBLN)=0 IPTSBC(ISUBLN)=NSUBCM C C Unless explicit positioning indicated by "'", insert a blank as C first character of continuation line. C IF(CARD(J:J).EQ.'''') THEN L=0 J=J+1 NCHAR=0 IAPOST=1 ELSE IF(CARD(J:J).EQ.'"') THEN L=0 J=J+1 NCHAR=0 IAPOST=2 ELSE SUBCSV(NSUBCM)(1:1)=' ' L=1 NCHAR=1 END IF ELSE C C On first line of substitution, begin at character 1, unless directed C by "'" C L=0 NCHAR=0 IF(CARD(J:J).EQ.'''') THEN J=J+1 IAPOST=1 ELSE IF(CARD(J:J).EQ.'"') THEN J=J+1 IAPOST=2 END IF LFIRST=0 END IF C C Loop to 57 stores the string, a character at a time. C Convert && to &. C 57 CONTINUE IF(J.GT.ILAST.OR. . J.EQ.ILAST.AND.(CARD(J:J).EQ.''''.OR.CARD(J:J).EQ.'"'))THEN IF(L.LT.12) THEN DO 58 JJ=L+1,12 SUBCSV(NSUBCM)(JJ:JJ)=' ' 58 CONTINUE END IF NSBCHR(ISUBLN)=NCHAR IF(ISCEND.EQ.1) THEN ISTAT=0 END IF GO TO 1 END IF IF(CARD(J:J).EQ.'&'.AND.CARD(J+1:J+1).EQ.'&') THEN J=J+1 ELSE IF(CARD(J:J).EQ.'''') THEN IF(IAPOST.EQ.1) THEN IF(CARD(J+1:J+1).EQ.'''') THEN J=J+1 ELSE IAPOST=0 J=J+1 GO TO 57 END IF ELSE IF(IAPOST.EQ.0) THEN IAPOST=1 J=J+1 GO TO 57 END IF ELSE IF(CARD(J:J).EQ.'"') THEN IF(IAPOST.EQ.2) THEN IF(CARD(J+1:J+1).EQ.'"') THEN J=J+1 ELSE IAPOST=0 J=J+1 GO TO 57 END IF ELSE IF(IAPOST.EQ.0) THEN IAPOST=2 J=J+1 GO TO 57 END IF END IF L=L+1 NCHAR=NCHAR+1 IF(L.EQ.13) THEN NSUBCM=NSUBCM+1 IF(NSUBCM.GT.MAXSBC) THEN WRITE(U6,206) IF(CMPFLG.EQ.1) THEN IMERR1=160110 RETURN ELSE CALL FESTOP(160110) END IF END IF L=1 END IF SUBCSV(NSUBCM)(L:L)=CARD(J:J) J=J+1 GO TO 57 END IF C C Under SET, always read the next record to determine continuation, if C any. C GO TO 1 END IF C C End of SET processing. C C Print the contents here if continuation card or if LONGCOMMENT C IF(ISTAT.NE.2) THEN IF(ISTAT.NE.0.OR..NOT.ALPCHK(CARD(1:1)).OR.MACROI) THEN IF(CMPFLG.EQ.1.AND.ISTAT.NE.0) THEN WRITE(13)CARDIM NLINE=NLINE+1 CALL ROOMD(1) DX(NXPTD-1)=U5ENOW ELSE CALL CRDPRN(0) END IF END IF IF(MACROI) THEN IF(IONFLG.GT.0) THEN GO TO 1 ELSE CALL LASTCR(ILAST) IF(ILAST.GT.80) THEN CALL FESTOP(160115) ELSE IF(ILAST.LE.9) THEN IF(ILAST.EQ.0)ILAST=1 WRITE(LFMT,107)ILAST ELSE WRITE(LFMT,108)ILAST END IF IF(ILAST.GE.1) THEN WRITE(MACROF,FMT=LFMT,ERR=62)CARD(1:ILAST) ELSE WRITE(MACROF,FMT=LFMT,ERR=62) END IF GO TO 1 62 CONTINUE CALL FESTOP(160116) END IF END IF END IF C C Eliminate entirely blank cards unless CMPFLG=1 C If ISTAT ne 0, then keep reading more records under COMMENT, ON, C LONGCOMMENT or IGNORE. C CALL NBFIND(CARD(1:256),1,256,J) IF((J.EQ.0.AND.CMPFLG.EQ.0).OR.ISTAT.NE.0)GO TO 1 IF(ALPCHK(CARD(1:1))) THEN IF(CMPFLG.EQ.1.AND.ISBFLG.EQ.1) THEN C ! If two lines have NLINE=NLINE-2 C ! been written to 13 END IF C ! for substitution, ELSE C ! adjust nline REFRSH=.TRUE. END IF ELSE GO TO 1 END IF RETURN C C Handling of end of input file - check to return to previous file C in stack. C 90 CONTINUE C C If the file ended with an INCLUDE statement, process immediately. C IF(ISTAT.EQ.5) THEN J=1 CALL FNRD2(J,ITYPEI,IFLAGI,2,3,IFPSW,IFNAME,IPOSSC) IF(IMERR1.GT.0) THEN IF(CMPFLG.EQ.1) THEN RETURN ELSE CALL FSTOP END IF ELSE IF(IFLAGI(1).EQ.0) THEN WRITE(U6,207) IF(CMPFLG.EQ.1) THEN IMERR1=160104 RETURN ELSE CALL FESTOP(160104) END IF END IF IF(U5ALT(MAXALT).NE.0) THEN IF(U5ALT(MAXALT).NE.U5) THEN WRITE(U6,202)MAXALT IF(CMPFLG.EQ.1) THEN IMERR1=160105 RETURN ELSE CALL FESTOP(160105) END IF END IF END IF C C Find current included file and set U5ALT to 0 C DO 91 I=MAXALT,1,-1 IF(U5ALT(I).NE.0) THEN U5ASTT(I)=0 IF(I.LT.MAXALT) THEN U5ALT(I+1)=IFLAGI(1) END IF GO TO 92 END IF 91 CONTINUE 92 CONTINUE U5=IFLAGI(1) ISTAT=ISTTSV IF(ISTAT.EQ.6)ISTAT=0 C C Transfer to 1 to begin reading from this new file. C GO TO 1 END IF C C Except for INCLUDE, handled above, if the file ended C while processing a file name (U5LCSW=2), return to C calling program with U5LCSW=4 C IF(U5LCSW.EQ.2) THEN IF(ISUBCN.GT.0) THEN C C If continuation line of substitution continues beyond file name, C the logic is in trouble - generate error. C WRITE(U6,207) IF(CMPFLG.EQ.1) THEN IMERR1=160100 RETURN ELSE CALL FESTOP(160100) END IF ELSE C C Return here if at end of file specification but next line continues C a command. Calling routine should complete all decisions based on C the file name before calling REFRSH again. C U5LCSW=4 RETURN END IF END IF C C If reading from a scratch file, set U5END to 1 on encountering C an end-of-file. The calling program must call REFRSH again to begin C processing the incoming files. C IF(U5.GE.13.AND.U5.LE.17) THEN IF(U5END.EQ.0) THEN U5END=1 RETURN ELSE U5END=U5ESAV IF(U5END.EQ.1) THEN U5=U5ALT(1) RETURN END IF END IF END IF C C In all other cases, close the file unless this is the primary input C file. Restore the contents of CARDIN. C IF(U5.NE.U5ALT(1)) THEN IF(U5.GE.13.AND.U5.LE.17) THEN REWIND(UNIT=U5) ELSE CLOSE(UNIT=U5) END IF IF(U5ALT(MAXALT).NE.0.AND.U5.NE.U5ALT(MAXALT)) THEN U5=U5ALT(MAXALT) IF(U5ASTT(MAXALT).EQ.1)CARDIN=U5LINE(MAXALT) J=U5ASTT(MAXALT) ELSE DO 93 I=MAXALT,2,-1 IF(U5ALT(I).NE.0) THEN U5ALT(I)=0 U5=U5ALT(I-1) IF(U5ASTT(I-1).EQ.1)CARDIN=U5LINE(I-1) J=U5ASTT(I-1) GO TO 94 END IF 93 CONTINUE 94 CONTINUE END IF C C On end of file, turn off IGNORE or LONGCOMMENT, set ISSLVL=0 C IF(ISTAT.EQ.1.OR.ISTAT.EQ.2)ISTAT=0 LEVEL=0 ISSLVL=0 C C Check to see if the restored file itself is at end of file. C If so, loop back to 90 to handle in the same way. C IF(J.EQ.0) THEN GO TO 90 ELSE CININI=1 CARDIM(1:80)=CARDIN IF(NSUB.GT.0) THEN CALL STBLNK(CARD,81,256) END IF GO TO 7 END IF END IF C C Arrive here on end of primary file. C U5END=1 RETURN END C SUBROUTINE RENAMV(BASE,VNAME,NVIN,VTEMP,VTMPSZ,VTEMP2, . VNKEEP,NKEEP,MTYPE,LPOINT,CDMPNT,CROSSD,LABEL,LEVEL,IPOS) C INTEGER BASE,NVIN,VTMPSZ,NKEEP,IPOS INTEGER MTYPE(NVIN),LPOINT(NVIN),CDMPNT(NVIN),CROSSD(*) CHARACTER*12 VNAME(NVIN),VTEMP(VTMPSZ),VTEMP2(*),VNKEEP(*) CHARACTER*24 LABEL(NVIN),LEVEL(*) C C Renames variables in VNAME, and also changes references to the old C name for crossed variables. C C BASE - pointer to the first non-blank character in CARD, C set to 1 if another card is read C VNAME(NVIN) - primary array of current names C NVIN - number of current variables C VTEMP - work array C VTMPSZ - size of VTEMP C VTEMP2(*) - an array of names associated with crossed variables C VNKEEP - an array holding the list of KEEP variables C NKEEP - the current entries in VNKEEP C MTYPE(NVIN) - variable types C LPOINT(NVIN) - pointer to LEVELS C CDMPNT(NVIN) - pointer to information on crossed variables C CROSSD(*) - information on crossed variables C LABEL - labels for the variables C LEVEL - labels for levels of categorical and crossed C variables C IPOS - ending position (added 1/4/98) C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C INTEGER J,JJ,K,L,L1,MATCH,N,N1,N2 C 201 FORMAT(' DUPLICATION OF EXISTING VARIABLE NAME - ',A12) 205 FORMAT(' WARNING - UNRECOGNIZED VARIABLE NAME ',A12) C CALL VNFIND(BASE,VTEMP,VTMPSZ,N,IPOS,2,VNAME,NVIN) IF(N.LE.2) THEN CALL FESTOP(160060) END IF N1=1 10 CONTINUE N2=N-N1+1 C C Find the first occurence of AS or INTO C CALL VNMTCH('AS ',VTEMP(N1),N2,L) CALL VNMTCH('INTO ',VTEMP(N1),N2,L2) IF(L2.GT.0.AND.(L.EQ.0.OR.L2.LT.L)) THEN L=L2 END IF IF(L.EQ.0) THEN CALL FESTOP(160061) ELSE IF(2*L+N1.GT.N+2) THEN CALL FESTOP(160062) END IF L=L+N1-2 L1=L+2 DO 20 I=N1,L MATCH=0 CALL VNMTCH(VTEMP(L1),VNAME,NVIN,K) IF(K.GT.0) THEN WRITE(U6,201)VTEMP(L1) CALL FESTOP(160063) END IF CALL VNMTCH(VTEMP(I),VNAME,NVIN,K) IF(K.GT.0) THEN VNAME(K)=VTEMP(L1) MATCH=1 C C If the label for the old variable was the same as the variable C name, then relabel the variable with the new name. C IF(LABEL(K)(1:12).EQ.VTEMP(I).AND. . LABEL(K)(13:24).EQ.' ') THEN LABEL(K)(1:12)=VTEMP(L1) END IF END IF C C If the old name appeared in a KEEP list, then revise the list. C IF(NKEEP.GT.0) THEN CALL VNMTCH(VTEMP(I),VNKEEP,NKEEP,K) IF(K.GT.0) THEN VNKEEP(K)=VTEMP(L1) END IF END IF C C If the old name was included as a label for any crossed variable, C revise the label here too. C DO 15 JJ=1,NVIN IF(MTYPE(JJ).EQ.8.OR.MTYPE(JJ).EQ.9) THEN L=LPOINT(JJ) K=CDMPNT(JJ) N3=CROSSD(K) NM=CROSSD(K+N3+1) DO 6 J=1,N3 CALL VNMTCH(VTEMP2(NM),VTEMP(I),1,LL) IF(LL.EQ.1) THEN IF(LEVEL(L)(1:12).EQ.VTEMP2(NM).AND. . LEVEL(L)(13:24).EQ.' ') THEN LEVEL(L)(1:12)=VTEMP(L1) END IF VTEMP2(NM)=VTEMP(L1) MATCH=1 END IF NM=NM+1 L=L+1+CROSSD(K+J) 6 CONTINUE END IF 15 CONTINUE C C Nonfatal error message if old name is not in use. C IF(MATCH.EQ.0.AND.U5ECHO.GT.0)WRITE(U6,205)VTEMP(I) L1=L1+1 20 CONTINUE N1=L1 IF(N1.LE.N)GO TO 10 RETURN END C SUBROUTINE RLABEL(BASE,VNAME,NVIN,VTEMP,VTMPSZ,VTEMP2,MTYPE, . LPOINT,CDMPNT,CROSSD,LABEL,LEVEL,NLEVEL,MLEVEL,IPOS) C INTEGER BASE,NVIN,VTMPSZ,NLEVEL,MLEVEL,IPOS INTEGER MTYPE(NVIN),LPOINT(NVIN),CDMPNT(NVIN),CROSSD(*) CHARACTER*12 VNAME(NVIN),VTEMP(VTMPSZ),VTEMP2(*) CHARACTER*24 LABEL(NVIN),LEVEL(MLEVEL) C C Reads variable labels after LABEL statement. C C BASE - pointer to the first non-blank character in CARD, C set to 1 if another record is read C VNAME(NVIN) - primary array of current names C NVIN - number of current variables C VTEMP - work array C VTMPSZ - size of VTEMP C VTEMP2(*) - an array of names associated with crossed variables C MTYPE(NVIN) - variable types C LPOINT(NVIN) - pointer to LEVELS C CDMPNT(NVIN) - pointer to information on crossed variables C CROSSD(*) - information on crossed variables C LABEL - labels for the variables C LEVEL - labels for levels of categorical and crossed C variables. Unused space in this array is used C as scratch space in this routine. C NLEVEL - the number of current entries in LEVEL C MLEVEL - the maximum allowed entries in LEVEL C IPOS - ending position (may be =0) (added 1/4/98) C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 CHARACTER*256 CARD COMMON /CRDBLK/ CARD LOGICAL ALPCHK EXTERNAL ALPCHK C INTEGER I,IPT,N,NL,N1LEV C 205 FORMAT(' WARNING - UNRECOGNIZED VARIABLE NAME ',A12) 210 FORMAT(1X,I7,' EXCEEDS AVAILABLE RESOURCES FOR LEVELS OF CAT/CLASS .') C IPT=BASE 1 CONTINUE C C Determine variables to label. On return from VNFIND, N will provide C the number of variables C CALL VNFIND(IPT,VTEMP,VTMPSZ,N,IPOS,2,VNAME,NVIN) IF(IPT.EQ.1)BASE=1 IF(N.LE.0.OR.IPOS.EQ.0)RETURN IPT=IPOS N1LEV=NLEVEL+1 IF(NLEVEL+N.GT.MLEVEL) THEN NLEVEL=NLEVEL+N WRITE(U6,210)NLEVEL CALL FESTOP(160065) END IF C C LEVELR uses N as the maximum number to accept and returns NL, the C number actually read. C CALL LEVELR(IPT,IPOS,NL,LEVEL(N1LEV),N) IF(IPT.EQ.1)BASE=1 IF(NL.GT.N)NL=N DO 20 I=1,NL MATCH=0 CALL VNMTCH(VTEMP(I),VNAME,NVIN,K) IF(K.GT.0) THEN LABEL(K)=LEVEL(N1LEV) MATCH=1 END IF C C If have stored this label for the variable, update the labels C in any crossed variables. C DO 15 JJ=1,NVIN IF(MTYPE(JJ).EQ.8.OR.MTYPE(JJ).EQ.9.OR. . MTYPE(JJ).EQ.19) THEN L=LPOINT(JJ) K=CDMPNT(JJ) N=CROSSD(K) NM=CROSSD(K+N+1) DO 6 J=1,N CALL VNMTCH(VTEMP2(NM),VTEMP(I),1,LL) IF(LL.EQ.1) THEN LEVEL(L)=LEVEL(N1LEV) MATCH=1 END IF NM=NM+1 L=L+1+CROSSD(K+J) 6 CONTINUE END IF 15 CONTINUE IF(MATCH.EQ.0) THEN WRITE(U6,205)VTEMP(I) END IF N1LEV=N1LEV+1 20 CONTINUE IF(U5END.EQ.1.OR.(BASE.EQ.1.AND.ALPCHK(CARD(1:1)))) THEN RETURN ELSE IPT=IPOS GO TO 1 END IF END C SUBROUTINE RLEVEL(BASE,VNAME,NVIN,VTEMP,VTMPSZ,MSIZE, . LPOINT,LEVEL,NLEVEL,MLEVEL,IPOS) C INTEGER BASE,NVIN,VTMPSZ,NLEVEL,MLEVEL,IPOS INTEGER LPOINT(NVIN),MSIZE(NVIN) CHARACTER*12 VNAME(NVIN),VTEMP(VTMPSZ) CHARACTER*24 LEVEL(MLEVEL) C C Reads labels for levels after LEVEL statement. C C BASE - pointer to the first non-blank character in CARD, C set to 1 if another record is read C VNAME(NVIN) - primary array of current names C NVIN - number of current variables C VTEMP - work array C VTMPSZ - size of VTEMP C MSIZE - size of the variables, used to determine the C expected number of level labels C LPOINT - pointer to LEVELS C LEVEL - labels for levels of categorical and crossed C variables. C NLEVEL - the number of current entries in LEVEL C MLEVEL - the maximum allowed entries in LEVEL C IPOS - final position (added 1/4/98) C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 CHARACTER*256 CARD COMMON /CRDBLK/ CARD LOGICAL ALPCHK EXTERNAL ALPCHK C INTEGER I,IPT,N,NL,N1LEV C 205 FORMAT(' WARNING - UNRECOGNIZED VARIABLE NAME ',A12) 210 FORMAT(1X,I7,' EXCEEDS AVAILABLE RESOURCES FOR LEVELS OF CAT/CLASS .') C IPT=BASE 1 CONTINUE C C First, read the name(s) of the variable(s). C CALL VNFIND(IPT,VTEMP,VTMPSZ,N,IPOS,2,VNAME,NVIN) IF(IPT.EQ.1)BASE=1 C C Return if no variable names or if no labels follow. C IF(N.LE.0.OR.IPOS.EQ.0.OR.U5END.EQ.1)RETURN IPT=IPOS N1LEV=NLEVEL+1 IF(N1LEV.GT.MLEVEL) THEN NLEVEL=N1LEV WRITE(U6,210)NLEVEL CALL FESTOP(160070) END IF N2LEV=MLEVEL-NLEVEL CALL LEVELR(IPT,IPOS,NL,LEVEL(N1LEV),N2LEV) IF(IPT.EQ.1)BASE=1 C C Set LPOINT to point from the variables to the beginning of the C levels. Determine the maximum number of levels expected C according to MSIZE C LMAX=1 DO 20 I=1,N CALL VNMTCH(VTEMP(I),VNAME,NVIN,K) IF(K.EQ.0) THEN WRITE(U6,205)VTEMP(I) ELSE LPOINT(K)=N1LEV IF(MSIZE(K).GT.LMAX)LMAX=MSIZE(K) END IF 20 CONTINUE C C If one or more variables have a size larger than the number of C levels provided, fill the remaining labels with blanks. C IF(LMAX.GT.NL) THEN DO 25 I=NL+1,LMAX LEVEL(NLEVEL+I)=' ' 25 CONTINUE END IF NLEVEL=NLEVEL+LMAX IF(U5END.EQ.1.OR.(IPT.EQ.1.AND.ALPCHK(CARD(1:1))))RETURN IPT=IPOS GO TO 1 END C SUBROUTINE RNSCAN(BASE,IPOS,RANGET,MAXRNG,RTYPET,RGRPT,N,IFLAG, . TEMPLB,MAXTLB) C INTEGER BASE,IPOS,MAXRNG,N,IFLAG,MAXTLB INTEGER RTYPET(MAXRNG),RGRPT(MAXRNG) DOUBLE PRECISION RANGET(2,MAXRNG) CHARACTER*24 TEMPLB(MAXTLB) C C Subroutine to scan for ranges. Used with IF, CLASS, CAT, etc. C Also used by CLSCAN to determine levels of class variables. C C BASE - starting position to scan, reset to 1 if new card read C IPOS - ending position returned by RNSCAN C RANGET - matrix into which RNSCAN stores the lower and upper C limits of each range C MAXRNG - the maximum space in RANGET, RTYPET, and RGRPT, C determined by the calling program C RTYPET - integer codes to indicate the type of range (documented C below C RGRPT - an array that marks level membership C IFLAG - from calling routine - RNSCAN C TEMPLB - an array into which RNSCAN should store labels based on C the ranges themselves. This feature, used with CLASS, C CAT, etc., provides provisional labels in case they are C not otherwise given. C MAXTLB - the size of TEMPLB. C C The routine reads successive cards, if necessary, C resetting BASE=1 if it does so. C C If IFLAG=1 or 2 "," delimits ranges, "/" delimits levels C e.g., CLASS, CAT C IFLAG=3 " " delimits ranges "," delimits levels C e.g., as used by CLSCAN to determine C levels of a class variable. C C If IFLAG=1 store ranges as default labels into TEMPLB C CHARACTER*256 C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 COMMON /CRDBLK/C DOUBLE PRECISION DLOW,DLOW1,DHIGH,DHIGH1 DOUBLE PRECISION DBELOW,DABOVE LOGICAL REFRSH EXTERNAL REFRSH,DBELOW,DABOVE INTEGER LEVEL C IPOS=0 N=0 IPT=BASE C C LEVEL - for IFLAG = 1 or 2, level as marked off by "/" C NEWLVL - keeps tract of increments in LEVEL C LEVEL=1 NEWLVL=1 C C The next three indices have to do with copying ranges into levels C for use as labels. C ILSTRT - position in CARD of beginning of range, or next part of C range to copy C ILEND - last nonblank position in CARD with part of range (not C initialized here but set when beginning of range is C detected. C LSTART - character position in TEMPLB to beginning copying range C LEND - last character position in TEMPLB to receive range C ILSTRT=1 LSTART=0 LEND=0 C C For IFLAG=1 or 2, use two flags to decide whether blank should be C allowed as a delimitor between numbers. C INGEVR - negative number ever read C IBLEVR - blank ever used as delimitor C INGEVR=0 IBLEVR=0 C C Control returns to 8 to begin processing a new range C C NSWTCH - switch to record processing of 2-component range. C 1 - 1st number or MISSING, LOW, RES, read C 2 - at minus sign C 3 - 2nd number or HIGH, N read C ILOW - indicates "LOW" read as part of range C IHIGH - indicates "HIGH" read C IRES - indicates "RES" read C INFLAG - indicates "N" read C IMSSNG - indicates "MISSING" read C IPLUS - indicates "+" read C 8 CONTINUE NSWTCH=0 ILOW=0 IHIGH=0 IRES=0 INFLAG=0 IMSSNG=0 IPLUS=0 C C Control returns to 10 to continue processing a given range C 10 CONTINUE IF(IPT.GT.256) THEN C C If at end of card, copy segment of range into TEMPLB, if appropriate C IF(IFLAG.EQ.1.AND.LSTART.GT.0.AND.LEND.GT.0.AND. . ILSTRT.LE.24.AND.LEVEL.LE.MAXTLB) THEN ILEND=ILSTRT+LEND-LSTART IF(ILEND.GT.24)ILEND=24 LEND=LSTART+ILEND-ILSTRT TEMPLB(LEVEL)(ILSTRT:ILEND)=C(LSTART:LEND) C C If space is available, add a single blank to mark end of line. C IF(ILEND.LT.24)TEMPLB(LEVEL)(ILEND+1:ILEND+1)=' ' LSTART=0 LEND=0 ILSTRT=ILEND+2 END IF IF(.NOT.REFRSH(BASE)) THEN CALL FESTOP(160075) END IF IPT=1 C C Return to 10 to continue processing additional parts of this range. C GO TO 10 END IF C CALL NBFIND(C(IPT:256),IPT,256,IPOS2) IPT=IPOS2 IF(LSTART.EQ.0)LSTART=IPT IF(IPOS2.EQ.0) THEN C C If remaining characters are blank, set IPT=257. On return to 10 C next record will be read. C IPT=257 ELSE IF(((IFLAG.EQ.1.OR.IFLAG.EQ.2).AND.C(IPT:IPT).EQ.'/').OR. . (IFLAG.EQ.3.AND.C(IPT:IPT).EQ.',')) THEN C C Increment level, first into NEWLVL, on encountering delimitor C NEWLVL=NEWLVL+1 IPT=IPT+1 C C Transfer to 20 to conclude processing of range C GO TO 20 ELSE IF(C(IPT:IPT).EQ.',') THEN C C After "," transfer to 20 to conclude processing of range C LEND=IPT IPT=IPT+1 GO TO 20 ELSE IF(IFLAG.EQ.3.AND.C(IPT:IPT).EQ.'+') THEN C C Record when encounter + and conclude processing of range C LEND=IPT IPT=IPT+1 IPLUS=1 GO TO 20 ELSE IF(C(IPT:IPT).EQ.'-') THEN C C For minus, must differentiate whether dash separating 2 end points C of range or a minus sign connected with a number C IF(NSWTCH.EQ.1) THEN C C If NSWTCH = 1, previously have read first part of range, so C set to indicate dash separating parts. C NSWTCH=2 IPT=IPT+1 ELSE C C For NSWTCH=0 or =2, assume part of number. Call DFIND to read. C IF(NSWTCH.EQ.0) THEN CALL DFIND(IPT,IPOS2,DLOW,DLOW1,2) ELSE CALL DFIND(IPT,IPOS2,DHIGH,DHIGH1,1) END IF IF(IPOS2.GT.0) THEN C C If encountered negative number, set INGEVR and check status of C IBLEVR. C INGEVR=1 IF(IBLEVR.EQ.1) THEN CALL FPSTOP(160081,IPT) END IF NSWTCH=NSWTCH+1 IPT=IPOS2 ELSE C C If a number could not be read at this point, an error has occurred. C CALL FPSTOP(160076,IPT) END IF END IF LEND=IPT-1 ELSE IF(C(IPT:IPT).EQ.')'.OR.C(IPT:IPT).EQ.'}') THEN C C If have read ending ")", must still process this range. C IPOS=IPT+1 NEWLVL=NEWLVL+1 GO TO 20 ELSE IF(NSWTCH.EQ.0) THEN C C Options if the 1st element of the range has not been read. C CALL DFIND(IPT,IPOS2,DLOW,DLOW1,1) IF(IPOS2.GT.0) THEN C C If DFIND successfully read a number, set NSWTCH=1 C NSWTCH=1 IPT=IPOS2 ELSE CALL CMATCH(C(IPT:256),IPT,256,'LOW',3,IPOS2,1) IF(IPOS2.GT.0) THEN ILOW=1 ELSE CALL CMATCH(C(IPT:256),IPT,256,'RES',3,IPOS2,1) IF(IPOS2.EQ.0) THEN CALL CMATCH(C(IPT:256),IPT,256,'MISSING',7,IPOS2,1) IF(IPOS2.EQ.0) THEN C C Within this IF block, identifying error and ending C CALL CMATCH(C(IPT:256),IPT,256,'HIGH',4,IPOS2,1) IF(IPOS2.GT.0) THEN CALL FPSTOP(160078,IPT) END IF CALL CMATCH(C(IPT:256),IPT,256,'N',1,IPOS2,1) IF(IPOS2.GT.0) THEN CALL FPSTOP(160078,IPT) END IF CALL FPSTOP(160077,IPT) C C End of processing of errors C END IF IMSSNG=1 ELSE IRES=1 END IF END IF IPT=IPOS2 C C NSWTCH=1 if MISSING, LOW, or RES read C NSWTCH=1 END IF LEND=IPT-1 ELSE IF(NSWTCH.EQ.2) THEN CALL DFIND(IPT,IPOS2,DHIGH,DHIGH1,2) IF(IPOS2.GT.0) THEN C C If DFIND successfully read a number, set NSWTCH=3 C NSWTCH=3 IPT=IPOS2 ELSE CALL CMATCH(C(IPT:256),IPT,256,'HIGH',4,IPOS2,1) IF(IPOS2.GT.0) THEN IHIGH=1 ELSE CALL CMATCH(C(IPT:256),IPT,256,'N',1,IPOS2,1) IF(IPOS2.EQ.0) THEN C C Within this IF block, identifying error and ending C CALL CMATCH(C(IPT:256),IPT,256,'LOW',3,IPOS2,1) IF(IPOS2.GT.0) THEN CALL FPSTOP(160080,IPT) END IF CALL CMATCH(C(IPT:256),IPT,256,'RES',3,IPOS2,1) IF(IPOS2.GT.0) THEN CALL FPSTOP(160080,IPT) END IF CALL CMATCH(C(IPT:256),IPT,256,'MISSING',7,IPOS2,1) IF(IPOS2.GT.0) THEN CALL FPSTOP(160080,IPT) END IF CALL FPSTOP(160079,IPT) END IF C C End of processing of errors C INFLAG=1 END IF IPT=IPOS2 NSWTCH=3 END IF LEND=IPT-1 ELSE IF(INGEVR.EQ.0.AND.(NSWTCH.EQ.1.OR.NSWTCH.EQ.3)) THEN C C Tolerance for blank as a delimitor requires no previous appearance C of negative numbers C IBLEVR=1 GO TO 20 ELSE C C Error condition C CALL DFIND(IPT,IPOS2,DHIGH,DHIGH1,2) IF(IPOS2.GT.0) THEN CALL FPSTOP(160082,IPT) ELSE CALL FPSTOP(160083,IPT) END IF END IF C C Return to 10 to continue processing range C GO TO 10 C C Processing of completed range C 20 CONTINUE N=N+1 IF(N.GT.MAXRNG) THEN CALL FESTOP(160084) END IF IF(IFLAG.EQ.1.AND.LEVEL.LE.MAXTLB) THEN C C For IFLAG=1, copy remaining segment of the range into the label C IF(LSTART.GT.0.AND.LEND.GT.0.AND.ILSTRT.LE.24) THEN ILEND=ILSTRT+LEND-LSTART IF(ILEND.GT.24)ILEND=24 LEND=LSTART+ILEND-ILSTRT TEMPLB(LEVEL)(ILSTRT:ILEND)=C(LSTART:LEND) ILSTRT=ILEND+1 END IF C C If have encountered a new level, fill remaining space with blanks. C IF(NEWLVL.NE.LEVEL) THEN CALL STBLNK(TEMPLB(LEVEL),ILSTRT,24) C IF(ILSTRT.LE.24) THEN C DO 22 I=ILSTRT,24 C TEMPLB(LEVEL)(I:I)=' ' C 22 CONTINUE C END IF ILSTRT=1 END IF LSTART=0 LEND=0 END IF RGRPT(N)=LEVEL NSAVE=N C C Range type C 1 value1 - value2 C 2 LOW - value C 3 value - HIGH C 4 LOW - HIGH C 5 MISSING C 6 value - n C IF(IRES.EQ.1.OR.(ILOW.EQ.1.AND.IHIGH.EQ.1)) THEN RTYPET(N)=4 ELSE IF(IMSSNG.EQ.1) THEN RTYPET(N)=5 ELSE IF(NSWTCH.EQ.3) THEN C C For ranges with 2 components. C IF(ILOW.EQ.1) THEN RTYPET(N)=2 ELSE RTYPET(N)=1 IF(DLOW.LT.0.)DLOW=DLOW1 IF(DLOW.LT.0.) THEN DLOW=DABOVE(DLOW) ELSE DLOW=DBELOW(DLOW) END IF RANGET(1,N)=DLOW END IF IF(IHIGH.EQ.1) THEN RTYPET(N)=3 ELSE IF(INFLAG.EQ.1) THEN RTYPET(N)=6 ELSE IF(DHIGH.LT.0.)DHIGH1=DHIGH IF(DHIGH.GE.0.) THEN DHIGH1=DBELOW(DHIGH1) ELSE DHIGH1=DABOVE(DHIGH1) END IF RANGET(2,N)=DHIGH1 END IF ELSE IF(NSWTCH.EQ.1.OR.NSWTCH.EQ.2) THEN C C For ranges with a single component. C IF(ILOW.GT.0) THEN CALL FESTOP(160085) END IF RANGET(1,N)=DLOW-1.0D-12 RANGET(2,N)=DLOW+1.0D-12 RTYPET(N)=1 ELSE C C If NSWTCH=0, do not store. C N=N-1 END IF C C For IFLAG=3, Add 6 to the code unless NSWTCH=0 if range is followed C by a plus. C IF(N.EQ.NSAVE.AND.IFLAG.EQ.3.AND.IPLUS.EQ.1)RTYPET(N)=RTYPET(N)+6 IF(C(IPT:IPT).EQ.')'.OR.C(IPT:IPT).EQ.'}')RETURN LEVEL=NEWLVL GO TO 8 END C SUBROUTINE STBLNK(C,ISTART,IEND) INTEGER ISTART,IEND CHARACTER *(*) C IF(ISTART.LE.IEND) THEN DO 1 I=ISTART,IEND C(I:I)=' ' 1 CONTINUE END IF RETURN END C SUBROUTINE VNFIND(BASE,VNAMET,MAXVN,N,IPOS,IFLAG,VNAME,NVIN) C INTEGER BASE,MAXVN,N,IPOS,IFLAG,NVIN INTEGER VNLEN,MVIN PARAMETER (VNLEN=12) PARAMETER (MVIN=500) CHARACTER *12 VNAMET(MAXVN),VNAME(MVIN) C C BASE - starting position in C (CARD) to search, reset to 1 if C additional lines read. C VNAMET - character array to receive resulting names C MAXVN - size of VNAMET C N - resulting number of names found C IPOS - ending position C IFLAG - governs conventions. C 1 - read variable names, but do not allow "--" convention C (e.g. with INPUT statement). If "--" encountered, C attempt to interpret it as single "-" C 2 - implement the "--" convention for variable names. C 3 - return only the first variable name found C VNAME - existing variable names (used for "--") C NVIN - number of existing variables (may be 0) C CHARACTER*256 C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 COMMON /CRDBLK/C LOGICAL ALPCHK,DGTCHK,REFRSH EXTERNAL ALPCHK,DGTCHK,REFRSH CHARACTER*1 DIGIT(10) DATA DIGIT /'0','1','2','3','4','5','6','7','8','9'/ C 104 FORMAT(' INVALID RANGE: VARIABLE NAME: ',A12,' NOT PREVIOUSLY DEF' .,'INED') 105 FORMAT(' NAME EXCEEDS 12 CHARACTERS: ',A13) 106 FORMAT(5X,'Note: The leading ''0'' in ',A12,' may cause a difficu' .,'lty',/,11x,'in expanding the range') C IPOS=BASE N=0 8 CONTINUE C C NSWTCH - keeps tract of status C = 0 no names read C = 1 one name read, could be beginning of range of names. C = 2 both beginning and ending names of range now read. C NMINUS - count of current minus signs - destinguish "-" from "--" C ISTART - character position of start of current name C NSWTCH=0 NMINUS=0 9 CONTINUE ISTART=0 GO TO 11 C C Transfers to 10 increment IPOS, looking at next character. C 10 CONTINUE IPOS=IPOS+1 C C Transfers to 11 review same character. C 11 CONTINUE C C Decision on reading more names. C IF(ISTART.EQ.0.AND.IPOS.GT.256) THEN IPOS=0 IF(.NOT.REFRSH(BASE))RETURN IPOS=1 C C Transfer to 11 to begin scanning new record. C GO TO 11 END IF C C If name currently under way is too long, stop C IF(ISTART.GT.0) THEN IF(IPOS.GT.256)GO TO 20 IF(IPOS-ISTART.GE.VNLEN) THEN IF(ALPCHK(C(IPOS:IPOS)).OR.DGTCHK(C(IPOS:IPOS))) THEN WRITE(U6,105)C(ISTART:IPOS) CALL FPSTOP(160140,IPOS) END IF C C Transfer to 20 to conclude processing name C GO TO 20 END IF END IF IF(ALPCHK(C(IPOS:IPOS))) THEN IF(ISTART.EQ.0)ISTART=IPOS C C Return to 10 will increment IPOS C GO TO 10 END IF IF(ISTART.EQ.0) THEN IF(C(IPOS:IPOS).EQ.' '.OR.C(IPOS:IPOS).EQ.',') THEN GO TO 10 ELSE IF(C(IPOS:IPOS).EQ.'-') THEN C C Encountering a minus here is an error. C CALL FPSTOP(160141,IPOS) ELSE C C Return if not in process of reading name. C RETURN END IF ELSE IF(DGTCHK(C(IPOS:IPOS))) THEN C C Check for digit as part of name. Transfer to 10 continues reading. C GO TO 10 END IF 20 CONTINUE NSWTCH=NSWTCH+1 N=N+1 IF(N.GT.MAXVN) THEN C C For too many names. C CALL FESTOP(160142) END IF C C Copy current name into VNAMET C J=1 DO 22 I=ISTART,IPOS-1 VNAMET(N)(J:J)=C(I:I) J=J+1 22 CONTINUE CALL STBLNK(VNAMET(N),J,VNLEN) C IF(J.LE.VNLEN) THEN C DO 24 I=J,VNLEN C VNAMET(N)(I:I)=' ' C 24 CONTINUE C END IF C C If IFLAG=3, interested only in a single name. C IF(IFLAG.EQ.3) RETURN C C If NSWTCH=1, look for "-" or "--" C IF(NSWTCH.EQ.1) THEN 26 CONTINUE IF(IPOS.GT.256) GO TO 30 DO 28 IPOS=IPOS,256 IF(C(IPOS:IPOS).EQ.' '.OR.C(IPOS:IPOS).EQ.',') THEN GO TO 28 ELSE IF(C(IPOS:IPOS).EQ.'-') THEN NMINUS=NMINUS+1 ELSE IF(NMINUS.GE.1) THEN C C If have read one or more minuses, transfer to 9 to begin searching C for second name to end the range. C GO TO 9 ELSE C C Otherwise, transfer to 8 resets NSWTCH. C GO TO 8 END IF 28 CONTINUE 30 CONTINUE IPOS=0 IF(.NOT.REFRSH(BASE))RETURN IPOS=1 GO TO 26 ELSE IF(IFLAG.EQ.2.AND.NMINUS.GE.2) THEN C C Implementation of "--" syntax, to define a group of variables C based on their previous order of appearance. C C N1 points to name before "--" C N1=N-1 DO 31 I=1,NVIN CALL CMATCH(VNAMET(N1),1,12,VNAME(I),12,IPOS2,1) IF(IPOS2.GT.0) THEN IEND1=I GO TO 32 END IF 31 CONTINUE WRITE(U6,104)VNAMET(N1) CALL FESTOP(160143) 32 CONTINUE DO 33 I=1,NVIN CALL CMATCH(VNAMET(N),1,12,VNAME(I),12,IPOS2,1) IF(IPOS2.GT.0) THEN IEND2=I GO TO 34 END IF 33 CONTINUE WRITE(U6,104)VNAMET(N) CALL FESTOP(160143) 34 CONTINUE IF(IEND2-IEND1+N-1.GT.MAXVN) THEN CALL FESTOP(160142) END IF N=N-2 DO 38 I=IEND1,IEND2 N=N+1 VNAMET(N)=VNAME(I) 38 CONTINUE ELSE IF(NMINUS.GE.1) THEN C C For interpretation of "-" ranges. C C Find last characters, IEND1 and IEND2, in VNAMET(N1) and VNAMET(N) C that are not digits. C IEND1=0 IEND2=0 N1=N-1 DO 42 I=VNLEN,1,-1 IF(VNAMET(N1)(I:I).NE.' '.AND..NOT.DGTCHK(VNAMET(N1)(I:I))) . THEN IF(IEND1.EQ.0)IEND1=I END IF IF(VNAMET(N)(I:I).NE.' '.AND..NOT.DGTCHK(VNAMET(N)(I:I))) THEN IF(IEND2.EQ.0)IEND2=I END IF 42 CONTINUE C IF(IEND1.EQ.0.OR.IEND1.EQ.VNLEN.OR.IEND1.NE.IEND2) THEN IF(IFLAG.EQ.2.AND.NMINUS.GT.1) THEN CALL FESTOP(160144) ELSE CALL FESTOP(160145) END IF END IF C C Check that names begin with same stem. C CALL CMATCH(VNAMET(N1),1,IEND1,VNAMET(N),IEND1,IPOS2,2) IF(IPOS2.EQ.0) THEN CALL FESTOP(160145) END IF C C Translate ending digits into numbers. C IEND1=IEND1+1 CALL IFIND(VNAMET(N1)(IEND1:VNLEN),IEND1,VNLEN,IPOS2,IVAL1) IF(IPOS2.EQ.0) THEN C C Just in case, error message for inability to extract IVAL1. This C should not occur, however, since should be looking only at digits, C unless there are no concluding digits. C CALL FESTOP(160146) ELSE IF(VNAMET(N1)(IEND1:IEND1).EQ.'0'.AND.IVAL1.NE.0) THEN WRITE(U6,106)VNAMET(N1) END IF CALL IFIND(VNAMET(N)(IEND1:VNLEN),IEND1,VNLEN,IPOS2,IVAL2) IF(IPOS2.EQ.0) THEN C C Just in case, error message for inability to extract IVAL2. This C should not occur, however, since should be looking only at digits, C unless there are no concluding digits. C CALL FESTOP(160146) END IF IF(IVAL1.GT.IVAL2) THEN C C Error message for IVAL1 > IVAL2. C CALL FESTOP(160147) ELSE IF(VNAMET(N)(IEND1:IEND1).EQ.'0') THEN WRITE(U6,106)VNAMET(N) END IF IF(IVAL2-IVAL1+N-1.GT.MAXVN) THEN CALL FESTOP(160142) END IF N=N-1 C C Fill in all the implied values. C DO 48 I=IVAL1+1,IVAL2 N=N+1 VNAMET(N)(1:IEND2)=VNAMET(N1)(1:IEND2) I10=1 44 CONTINUE IF(I10*10.LE.I) THEN I10=I10*10 GO TO 44 END IF K=I J=IEND1 46 CONTINUE L=K/I10 K=K-I10*L I10=I10/10 VNAMET(N)(J:J)=DIGIT(L+1) J=J+1 IF(I10.GT.0)GO TO 46 CALL STBLNK(VNAMET(N),J,VNLEN) C IF(J.LE.VNLEN) THEN C DO 47 L=J,VNLEN C VNAMET(N)(L:L)=' ' C 47 CONTINUE C END IF 48 CONTINUE END IF END IF GO TO 8 END C SUBROUTINE VNMTCH(VNAMET,VA,NVA,NUM) C INTEGER NVA,NUM CHARACTER*12 VA(*) CHARACTER*(*) VNAMET C C VNAMET - variable name to look for C VA - array of variable names to search C NVA - number of names in VA C NUM - number of name in VA that is matched - 0 otherwise C C This routine searches for the variable name VNAMET in the array C VA(NVA) C DO 1 I=1,NVA CALL CMATCH(VNAMET,1,12,VA(I),12,IPOS,1) IF(IPOS.GT.0) THEN NUM=I RETURN END IF 1 CONTINUE NUM=0 RETURN END C SUBROUTINE VTSCAN(BASE,VNAME,MTYPE,MSIZE,CDMPNT,CROSSD,NVIN, . VTEMP,VTMPSZ,VLIST,TTYPE,LEN,MXVLST,IV,LTOT,IPOSN,IERR) C INTEGER BASE,MTYPE(*),MSIZE(*),CDMPNT(*),CROSSD(*),NVIN INTEGER VTMPSZ,MXVLST,IV,LTOT,IPOSN,IERR INTEGER VLIST(MXVLST),TTYPE(MXVLST),LEN(MXVLST) CHARACTER*12 VNAME(*),VTEMP(VTMPSZ) C C BASE - starting position, reset to 1 if another record read C VNAME - variable names C MTYPE - variable types C MSIZE - variable sizes C CDMPNT - pointer to CROSSD C CROSSD - dimensions of crossed variables C NVIN - number of variables C VTEMP - work array of variable names C VTMPSZ - size of VTEMP C VLIST - array of variables C TTYPE - array of transformation types, see below C LEN - lengths of transformed variables (ignoring C cross-classifications by CLASS variables) C MXVLST - maximum length of VLIST, TTYPE, and LEN C IV - number of variables/transformed variables C LTOT - total length specified C IPOSN - position of next nonblank character, 0 if C end of file or next command line C IERR - 0 no error detected C 1 unrecognized variable C 2 probable error in returned position or other C problem of interpretation C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 CHARACTER*256 CARD COMMON /CRDBLK/CARD LOGICAL REFRSH EXTERNAL REFRSH C CHARACTER*11 CTYPE(6) DATA CTYPE / 'PERCENT1 ','TOTAL1 ','PERCENT2 ', . 'PROPORTION ','PROPORTION1','N '/ C 200 FORMAT(' ERROR IN SPECIFICATION') 201 FORMAT(' UNRECOGNIZED VARIABLE NAME: ',A12) 202 FORMAT(/,1X,A12,' MAY NOT BE USED WITH ',A11) 203 FORMAT(/,' WORK SPACE OF',I8,' EXCEEDED') C IERR=0 C C IV - cumulative index of number of variables found by VTSCAN. C ITYPE - holds current function status C IV=0 ITYPE=0 LTOT=0 CALL VNFIND(BASE,VTEMP,VTMPSZ,N,IPOSN,2,VNAME,NVIN) IF(N.EQ.0) GO TO 50 11 CONTINUE DO 16 IV0=1,N C C Function type C C 0 - Default C 1 - Percent or Mean C 2 - Total C 3 - Percent1 C 4 - Total1 C 5 - Percent2 C 6 - Proportion C 7 - Proportion1 C 8 - N of a variable C 9 - N of a block C 10 - Value of a variable, i.e., without indicators C C The last "variable" read by VNFIND may be a function - C check this first for IV0 = N C IF(ITYPE.EQ.0.AND.IV0.EQ.N.AND.IPOSN.GT.0) THEN CALL CMATCH(VTEMP(IV0),1,12,'MEAN',4,IPOS,1) IF(IPOS.GT.0) THEN ITYPE=1 END IF CALL CMATCH(VTEMP(IV0),1,12,'MEANS',5,IPOS,1) IF(IPOS.GT.0) THEN ITYPE=1 END IF CALL CMATCH(VTEMP(IV0),1,12,'PERCENT',7,IPOS,1) IF(IPOS.GT.0) THEN ITYPE=1 END IF CALL CMATCH(VTEMP(IV0),1,12,'PERCENTS',8,IPOS,1) IF(IPOS.GT.0) THEN ITYPE=1 END IF CALL CMATCH(VTEMP(IV0),1,12,'TOTAL',5,IPOS,1) IF(IPOS.GT.0) THEN ITYPE=2 END IF CALL CMATCH(VTEMP(IV0),1,12,'TOTALS',6,IPOS,1) IF(IPOS.GT.0) THEN ITYPE=2 END IF CALL CMATCH(VTEMP(IV0),1,12,'PERCENT1',8,IPOS,1) IF(IPOS.GT.0) THEN ITYPE=3 END IF CALL CMATCH(VTEMP(IV0),1,12,'TOTAL1',6,IPOS,1) IF(IPOS.GT.0) THEN ITYPE=4 END IF CALL CMATCH(VTEMP(IV0),1,12,'PERCENT2',8,IPOS,1) IF(IPOS.GT.0) THEN ITYPE=5 END IF CALL CMATCH(VTEMP(IV0),1,12,'PROPORTION',10,IPOS,1) IF(IPOS.GT.0) THEN ITYPE=6 END IF CALL CMATCH(VTEMP(IV0),1,12,'PROPORTIONS',11,IPOS,1) IF(IPOS.GT.0) THEN ITYPE=6 END IF CALL CMATCH(VTEMP(IV0),1,12,'PROPORTION1',11,IPOS,1) IF(IPOS.GT.0) THEN ITYPE=7 END IF CALL CMATCH(VTEMP(IV0),1,12,'N',1,IPOS,1) IF(IPOS.GT.0) THEN ITYPE=8 END IF CALL CMATCH(VTEMP(IV0),1,12,'VALUE',5,IPOS,1) IF(IPOS.GT.0) THEN ITYPE=10 END IF CALL CMATCH(VTEMP(IV0),1,12,'VALUES',6,IPOS,1) IF(IPOS.GT.0) THEN ITYPE=10 END IF 12 CONTINUE C C When one of the recognized functions is not followed by "(", r C reinterpret the function name as a possible variable name. C IF(ITYPE.NE.0) THEN CALL NBFND2(IPOSN,IPOS2) IF(IPOSN.EQ.1)BASE=1 IF(IPOS2.EQ.0) THEN IPOSN=0 ELSE IF(CARD(IPOS2:IPOS2).EQ.'(') THEN IPOSN=IPOS2 C C If a function has been confirmed, skip to the end of the loop C GO TO 16 ELSE ITYPE=0 END IF END IF END IF END IF C C IV1 - index of variable in list of defined variables C IF(NVIN.GT.0) THEN CALL VNMTCH(VTEMP(IV0),VNAME,NVIN,IV1) ELSE IV1=0 END IF C C IVS - saves current value of IV C IVS=IV IF(IV.GE.MXVLST) THEN WRITE(U6,203)MXVLST CALL FESTOP(160170) END IF C IF(IV1.GT.0) THEN IV=IV+1 VLIST(IV)=IV1 TTYPE(IV)=ITYPE C C Translate VALUE into TOTAL for MTYPE < 10 C IF(ITYPE.EQ.10) THEN IF(MTYPE(IV1).LT.10) THEN TTYPE(IV)=2 END IF C C Translate TOTAL into VALUE for MTYPE > 10 C ELSE IF(ITYPE.EQ.2) THEN IF(MTYPE(IV1).GT.10) THEN TTYPE(IV)=10 END IF END IF C C Calculation of the length of the transformed variable C IF(ITYPE.EQ.0) THEN C C Length of default is MSIZE C LEN(IV)=MSIZE(IV1) ELSE IF(TTYPE(IV).EQ.1.OR.TTYPE(IV).EQ.2.OR. . TTYPE(IV).EQ.10) THEN C C For PERCENT, MEAN, TOTAL, VALUE, adjust MSIZE for real with C missing and crossed real variables C IF(MTYPE(IV1).EQ.2.OR.MTYPE(IV1).EQ.8) THEN LEN(IV)=MSIZE(IV1)/2 ELSE LEN(IV)=MSIZE(IV1) END IF ELSE IF(ITYPE.EQ.3.OR.ITYPE.EQ.4.OR.ITYPE.EQ.7) THEN C C PERCENT1, MEAN1, PROPORTION1 C IF(MTYPE(IV1).EQ.3) THEN IF(MSIZE(IV1).GT.1) THEN LEN(IV)=MSIZE(IV1)-1 ELSE C C If MSIZE=1, redefine transformation. C LEN(IV)=1 IF(ITYPE.EQ.3.OR.ITYPE.EQ.4) THEN TTYPE(IV)=ITYPE-2 ELSE TTYPE(IV)=ITYPE-1 END IF END IF ELSE IF(MTYPE(IV1).EQ.9) THEN K=CROSSD(CDMPNT(IV1)+1) IF(K.EQ.1) THEN LEN(IV)=MSIZE(IV1) IF(ITYPE.EQ.3.OR.ITYPE.EQ.4) THEN TTYPE(IV)=ITYPE-2 ELSE TTYPE(IV)=ITYPE-1 END IF ELSE LEN(IV)=((K-1)*MSIZE(IV1))/K END IF ELSE C C PERCENT1, MEAN1, PROPORTION1 may only be used with CAT, or C CROSSED CAT C IV=IV-1 WRITE(U6,202)VNAME(IV1),CTYPE(ITYPE-2) END IF ELSE IF(ITYPE.EQ.5) THEN C C PERCENT2 C IF(MTYPE(IV1).EQ.9) THEN LEN(IV)=MSIZE(IV1) ELSE C C PERCENT2 may only be used with CROSSED CAT C IV=IV-1 WRITE(U6,202)VNAME(IV1),CTYPE(3) END IF ELSE IF(ITYPE.EQ.6) THEN C C PROPORTION C IF(MTYPE(IV1).EQ.3.OR.MTYPE(IV1).EQ.9) THEN LEN(IV)=MSIZE(IV1) ELSE IV=IV-1 WRITE(U6,202)VNAME(IV1),CTYPE(4) END IF ELSE IF(ITYPE.EQ.8) THEN C C N c IF(MTYPE(IV1).EQ.2.OR.MTYPE(IV1).EQ.8) THEN LEN(IV)=MSIZE(IV1)/2 ELSE IF(MTYPE(IV1).EQ.9) THEN K=CROSSD(CDMPNT(IV1)+1) LEN(IV)=MSIZE(IV1)/K ELSE IF(MTYPE(IV1).LT.10) THEN LEN(IV)=1 ELSE C C N may not be used with any form of DERIVED variables C IV=IV-1 WRITE(U6,202)VNAME(IV1),CTYPE(6) END IF END IF C C Check here if a variable has been eliminated C IF(IV.GT.IVS) THEN LTOT=LTOT+LEN(IV) ELSE IERR=1 END IF ELSE C C If have not matched to a defined variable C WRITE(U6,201)VTEMP(IV0) IERR=1 END IF 16 CONTINUE C C Arrive here after processing the list of variables returned by C VNFIND C 17 CONTINUE IF(IPOSN.GT.0) THEN C C Examine next characters, if any C CALL NBFND2(IPOSN,IPOS2) IF(IPOSN.EQ.1)BASE=1 IF(IPOS2.GT.0) THEN IF(CARD(IPOS2:IPOS2).EQ.')') THEN C C Interpret ")" as end of function range C ITYPE=0 ELSE IF(CARD(IPOS2:IPOS2).NE.'(') THEN C C If not "(" or ")" transfer to 18 in preparation for return C IPOSN=IPOS2 GO TO 18 END IF IPOSN=IPOS2+1 IF(IPOSN.GT.256) THEN IF(.NOT.REFRSH(BASE)) THEN IPOSN=0 GO TO 18 ELSE IPOSN=1 END IF END IF IPT=IPOSN C C Call VNFIND to determine if scan should continue. C CALL VNFIND(IPT,VTEMP,VTMPSZ,N,IPOS2,2,VNAME,NVIN) IPOSN=IPOS2 IF(IPT.EQ.1)BASE=1 IF(N.GT.0) THEN C C Transfer to 11 if VNFIND has found variables. C GO TO 11 ELSE IF(ITYPE.EQ.8.AND.IPOSN.GT.0) THEN C C Check here for N of a block - N(1) etc. C CALL IFIND(CARD(IPT:256),IPT,256,IPOSN,IVALUE) IF(IPOSN.GT.0) THEN IV=IV+1 LTOT=LTOT+1 VLIST(IV)=IVALUE TTYPE(IV)=9 LEN(IV)=1 GO TO 17 END IF END IF END IF END IF 18 CONTINUE IF(IPOSN.LE.0) GO TO 50 20 CONTINUE CALL NBFND2(IPOSN,IPOS2) IF(IPOSN.EQ.1)BASE=1 IPOSN=IPOS2 50 CONTINUE C C Check that all function calls closed off C IF(ITYPE.NE.0)IERR=2 RETURN END C DOUBLE PRECISION FUNCTION DABOVE(DVALUE) C DOUBLE PRECISION DVALUE C C This routine finds the next double precision value above C DVALUE, but uses the SAS convention of 1.0D-12 for integers, C that is, double precision values within 1.0D-12 of an integer C DOUBLE PRECISION DTEMP,DTEMP1,DTEMP2,DINC LOGICAL ICHECK EXTERNAL ICHECK DTEMP=DVALUE IF(ICHECK(DTEMP,DTEMP1)) THEN DTEMP1=DTEMP1+1.0D-12 IF(DTEMP.LT.DTEMP1)GO TO 20 END IF DINC=1. DO 10 I=1,200 DINC=DINC/2.0D0 DTEMP2=DTEMP+DINC IF(DTEMP2.LE.DTEMP)GO TO 20 DTEMP1=DTEMP2 10 CONTINUE 20 DABOVE=DTEMP1 RETURN END C DOUBLE PRECISION FUNCTION DBELOW(DVALUE) C DOUBLE PRECISION DVALUE C C This routine finds the next double precision value below C DVALUE, but uses the SAS convention of 1.0D-12 for integers, C that is, double precision values within 1.0D-12 of an integer C DOUBLE PRECISION DTEMP,DTEMP1,DTEMP2,DINC LOGICAL ICHECK EXTERNAL ICHECK DTEMP=DVALUE IF(ICHECK(DTEMP,DTEMP1)) THEN DTEMP1=DTEMP1-1.0D-12 IF(DTEMP.GT.DTEMP1)GO TO 20 END IF DINC=1. DO 10 I=1,200 DINC=DINC/2.0D0 DTEMP2=DTEMP-DINC IF(DTEMP2.GE.DTEMP)GO TO 20 DTEMP1=DTEMP2 10 CONTINUE 20 DBELOW=DTEMP1 RETURN END C LOGICAL FUNCTION ICHECK(DVALUE,DVALU2) C DOUBLE PRECISION DVALUE,DVALU2 C C This routine implements the SAS convention for declaring C a double precision value within 1.0D-12 of an integer to C be that integer. C IF(DVALUE.LT.0.) THEN DVALU2=DVALUE-1.0D-12 ELSE DVALU2=DVALUE+1.0D-12 END IF DVALU2=DINT(DVALU2) IF(DABS(DVALUE-DVALU2).LE.1.0D-12) THEN ICHECK=.TRUE. ELSE ICHECK=.FALSE. END IF RETURN END C C End of SC.FOR C SUBROUTINE SETUP1 IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (MIFLVL=7,IXFLLD=13-MIFLVL) PARAMETER (MAXFMT=20) PARAMETER (NOPTN1=3) C C MVAR represents the maximum number of incoming and created C variables, replicate factors and wts C MAXIDS is the maximum number of class variables C MRECOD is the maximum of variables transformed by CLASS, CAT C MISSING, SELECT, BY etc. C MRANGE is the maximum number of ranges C MRNSET is the maximum number of sets of ranges C MLEVEL is the maximum number of stored labels for levels C MCLBLK is the maximum number of class blocks C MCLBAR is the maximum number of cells of class block arrays C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL INTEGER VTMPSZ C CHARACTER*256 CARD COMMON /CRDBLK/CARD C PARAMETER (MAXSUB=500,MAXSBL=2000,MAXSNL=24) PARAMETER (MAXSBC=6000) PARAMETER (MAXALT=5) INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI, . NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL), . U5LCSW COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI, . NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW INTEGER BASE LOGICAL REFRSH,ALPCHK,DGTCHK EXTERNAL REFRSH,ALPCHK,DGTCHK C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT C C NVTOT (NTOTV) C NVREG (IOUTC1) C NVARID (NID1) C INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1, . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX C DOUBLE PRECISION RANGE(2,MRANGE) INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET), . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD), . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI) C COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP, . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO, . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS, . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT, . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS, . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO, . NLEVEL,NRNSET,NRANGE,NHADAM,ISTEPC,IFLVL,IF1LST,IFLAST,NEWSYN, . IXFILL,SDSTCK,MSDPTH INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS, . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN, . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IFLAST(MIFLVL), . IXFILL(IXFLLD),SDSTCK,MSDPTH C INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW, . OSCODE,NEWFNM COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE, . ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM C C Usage in this subroutine (CREATE): C C BLVSTR - Pointer for block to VNKEEP, 0 if no definition C of block contents by a KEEP statement C BLVSIZ - number of variables for block in VNKEEP C BLNCLS - number of classes in block C BLCPNT - pointer for classes to CLTYPE C CLTYPE - used as pointers to class variables C INTEGER ITYPEF(3),IFILEF(3) LOGICAL LTEMP INTEGER INDX1(NOPTN1) INTEGER IVAL1(NOPTN1) CHARACTER*12 OPTNW1(NOPTN1) DATA OPTNW1 / 'NPRINT ','OBS ','NOBS '/ DATA INDX1/1,2,2/ DATA IVAL1/0,0,0/ C 200 FORMAT(' ERROR IN SPECIFICATION') 203 FORMAT(' THE FORMAT MUST BEGIN WITH ''(''') 205 FORMAT(' UNRECOGNIZED VARIABLE NAME ',A12) 210 FORMAT(' BY missing or unbalanced numbers of variables') 211 FORMAT(' THIS VARIABLE IS NOT OF TYPE CLASS OR CATEGORICAL - ',A12 .) 212 FORMAT(' VARIABLE OF INAPPROPRIATE TYPE - ',A12) 213 FORMAT(' A OR I EDIT DESCRIPTORS NOT ALLOWED IN THE FORMAT') 215 FORMAT(' Variable already exists - ',A12) 216 FORMAT(' COPY into a CLASS variable is not allowed') 218 FORMAT(' BY variable of improper type') 220 FORMAT(5X,'WARNING: COUNT OF CAT, CLASS, ETC. OPERATIONS TO CAT OR . CROSSED VAR:',I4) 222 FORMAT(5X,'FOR REAL, REAL WITH MISSING, OR CROSSED REAL ONLY') 223 FORMAT(' FORMAT ALREADY SPECIFIED') 224 FORMAT(' MISSING FORMAT') 225 FORMAT(' DUPLICATE INPUT') 226 FORMAT(' *** KEY IGNORED - NO PREVIOUS VARIABLES') 227 FORMAT(' KEY VARIABLE NOT ON INPUT LIST') 228 FORMAT(' KEY VARIABLE NOT MATCHED TO PREVIOUS') 229 FORMAT(' DUPLICATION: ',A12) 230 FORMAT(' MISSING INPUT') 232 FORMAT(/,1X,I7,' variables are specified') 233 FORMAT(5X,'Not permitted within IF block') 234 FORMAT(5X,'Unbalanced IFs') 238 FORMAT(' ONLY FOR REWEIGHT') 239 FORMAT(' DUPLICATE OUTPUT statement') 240 FORMAT(' MISSING OUTPUT statement') 241 FORMAT(5X,'Ignored for this step') 242 FORMAT(' WARNING: Not generated here, but may have been generated . earlier') 247 FORMAT(' NO LINK TO BY VARIABLES') 250 FORMAT(5X,'*** PRINT request',I5) 251 FORMAT(' CONFLICT BETWEEN OLD AND NEW SYNTAX') 252 FORMAT(' REDUNDANT CLASS SPECIFICATION') 253 FORMAT(' NOT A CLASS VARIABLE: ',A12) C RCEIL(1)=MSIZEI MSDPTH=0 SDSTCK=0 IFLVL=0 IVZERO=0 IFLOW=0 IFHIGH=0 IFOUTL=0 IFOUTH=0 IRCINP=0 IRCTIN=40 IUINPT=12 NVIN=0 NRECOD=0 NRANGE=0 NRNSET=0 NLEVEL=0 NHADAM=0 NKEEP=0 VKEEPF=0 IREPF=0 IREPW=0 IREPNO=0 IWGT=0 ISTRCD=0 ISTRNO=0 ISNDCD=0 ISNDNO=0 ICLUSC=0 ICLUSN=0 ICLCNT=0 SISTRS=0 SISNDS=0 NISTRS=0 NISNDS=0 NDCOEF=0 SDFPC1=0 NDFPC1=0 SDFPC2=0 NDFPC2=0 NREPW=0 NOWGTF=0 ICWARN=0 IPREQ=0 NEWSYN=0 IOUTFV=0 DO 3 I=1,MVAR MTYPE(I)=1 MTSTRT(I)=1 MSIZE(I)=1 MXSIZE(I)=1 CDMPNT(I)=0 LPOINT(I)=0 3 CONTINUE C C Contents of MTYPE, codes for transformations C 1 = real variable C 2 = real variable with missing checks C 3 = categorical variable C 4 = class variable, known dimension C 5 = by variable, known dimension C 6 = by variable, unknown dimension C 7 = select transformation (not variable type) C 8 = cross variable, real value C 9 = cross variable, categorical C 10 = copy (not variable type) C 21 = boolean " C 22 = boolean - no range " C 23 = and (logical and) " C 24 = or " C 25 = not " C 26 = add_ms " C 27 = subtract_ms " C 28 = multiply_ms " C 29 = divide_ms " C 30 = add " C 31 = subtract " C 32 = multiply " C 33 = divide " C 34 = constants " C 35 = if (else if) " C 36 = go to " C 40 = initial read C 41 = input (link) C 42 = input with missing (link_missing) C v1 v2 v3 rstpnt C iuinpt status # input # keys C 1st v start x start fmt # fmt C # print #obs file type C key x match v last key var # of match v C 43 = add loop to replicate weights/factors C v1 v2 v3 rstpnt C 1st rf/rw # rf/rw var C 44 = subtract loop to replicate weights/factors C 45 = multiply loop " C 46 = divide loop " C 47 = output C v1 v2 v3 rstpnt C #output point IX start fmt # fmt C C 50-60 are during REWEIGHT only C C 50 = add, 0 replicate, using vplxin data C v1 v2 v3 rstpnt C 1st op target vplxin v #classes C for each class: C v1 v2 v3 rstpnt C class/cat 0 offset increment C C 51 = subtract, 0 replicate using vplxin data C 52 = multiply, 0 replicate " C 53 = divide, 0 replicate " C 54 = add loop to replicate weights/factors, using vplxin C v1 v2 v3 rstpnt C 1st rf/rw # rf/rw vplxin var #classes C for each class: C v1 v2 v3 rstpnt C class/cat 0 offset increment C C 55 = subtract loop to replicate weights/factors, using vplxin C 56 = multiply loop " " C 57 = divide loop " " C C 58 = define repf based on var ids C v1 v2 v3 rstpnt C 1st rf/rw # rf/rw wt #var ids C for each id: C v1 v2 v3 rstpnt C variance id C for repw, v3 will give id of weight C 60 = check BY variables C v1 v2 v3 rstpnt C #BY vars C for each BY var: C v1 v2 v3 rstpnt C BY id loc in vid C C 61 = define repf based on rows of Hadamard matrix and C coefficients C v1 v2 v3 rstpnt C 1st rf/rw # rf/rw wt #sets C for each set: C v1 v2 v3 rstpnt C row coefficient C for repw, v3 will give id of weight C C 62 = idchange to return 1 if change in variables C v1 v2 v3 rstpnt C 0 idchange 0 # keys C for each key: C match v pointer to var # of match v C last value C C 63 = print C v1 v2 v3 rstpnt C # print #obs # list # pointer to IX C C 100 = store C 101 = load variable C 102 = add variable C 103 = subtract variable C 104 = multiply variable C 105 = divide variable C 106 = power variable C 111 = load constant C 112 = add constant C 113 = subtract constant C 114 = multiply constant C 115 = divide constant C 116 = power constant C 122 = add stack C 123 = subtract stack C 124 = multiply stack C 125 = divide stack C 126 = power stack C CALL KYFIND(IKEY,IPT) C C REWEIGHT, ISTEPC=2 C ITYPEF(1)=1 IF(IKEY.EQ.109) THEN ISTEPC=2 ITYPEF(2)=1 ITYPEF(3)=2 J=1 C C REPGEN, ISTEPC=3 C ELSE IF(IKEY.EQ.117.OR.IKEY.EQ.171) THEN ISTEPC=3 ITYPEF(2)=1 ITYPEF(3)=0 J=1 C C CREATE, istepc=1 C ELSE ISTEPC=1 ITYPEF(2)=2 ITYPEF(3)=1 J=7 END IF CALL CRDPRN(3) CALL FNREAD(IPT,ITYPEF,IFILEF,J,IPOSSC) IF(IMERR1.GT.0) THEN CALL FSTOP END IF C IF(IFILEF(1).EQ.0.OR.IFILEF(2).EQ.0.OR. . (ISTEPC.EQ.2.AND.IFILEF(3).EQ.0))GO TO 95 IF(ISTEPC.EQ.1) THEN IF(IFILEF(3).NE.0) THEN IOUTFV=ITYPEF(3) END IF ELSE IOUTFV=ITYPEF(2) END IF IF(ISTEPC.EQ.2) THEN CALL PREAMC IV=RCEIL(2) C C Store the number of the block for each variable in MXSIZE C DO 27 ICLBLK=1,NCLBLK IF(BLVSIZ(ICLBLK).GT.0) THEN DO 26 I=1,BLVSIZ(ICLBLK) IV=IV+1 MXSIZE(IV)=ICLBLK 26 CONTINUE END IF 27 CONTINUE IRCOUT=0 IBYCHK=0 VTMPSZ=MVAR-SVTEMP+1 ELSE NCLASS=0 NRPTOT=0 NCLBLK=1 NCLBAR=0 BLCPNT(1)=0 BLNCLS(1)=0 BLVSTR(1)=0 BLVSIZ(1)=0 SVTEMP=1 VTMPSZ=MVAR SDCOEF=0 NBY=0 VROPTN=0 NVREG=0 END IF NCRSSD=0 IF(IPOSSC.GT.0) THEN TSWTCH=2 CALL STBLNK(CARD,1,IPOSSC) IPOSSC=IPOSSC+1 U5LCSW=1 C ! Reset U5LCSW used by REFRSH CALL CMPAR1(IX,IPOSSC) CALL NSETP1(IX(NLINE+NLINE2+1),IX,IX(NLINE+1),ITYPEF,IFILEF) RETURN END IF 1 CONTINUE LTEMP=REFRSH(IPT) 2 CONTINUE IF(U5END.GT.0) THEN IF(U5.GE.13.AND.U5.LE.17) THEN GO TO 1 ELSE IKEY=0 GO TO 90 END IF END IF IBFLAG=0 CALL KYFIND(IKEY,IPT) IF(IKEY.EQ.9.OR.IKEY.EQ.19) THEN IF(NEWSYN.EQ.1) THEN GO TO 98 ELSE IF(NEWSYN.EQ.0) THEN NEWSYN=2 END IF END IF 65 CONTINUE IF(IKEY.GT.34) THEN IF(IKEY.NE.36.AND.IKEY.NE.52.AND.(IKEY.LT.69.OR.IKEY.GT.72) . .AND.(IKEY.LT.92.OR.IKEY.GT.98).AND.IKEY.NE.118.AND. . IKEY.NE.121.AND.IKEY.NE.156.AND. . (IKEY.LT.100.OR.IKEY.GT.111.OR.IKEY.EQ.109))GO TO 90 END IF IF(IBFLAG.EQ.0.AND.IKEY.NE.17)CALL CRDPRN(1) IF(IKEY.EQ.-1) THEN GO TO 2 C C For commands where further specification is expected, check that C additional information begins on this line or continuation. IPT C will contain position of nonblank character. C ELSE IF(IKEY.LE.13.OR.(IKEY.GE.15.AND.IKEY.LE.33.AND.IKEY.NE.17) . .OR.IKEY.GE.110) THEN IF(IPT.LE.0) THEN IPT=20 CALL NBFND2(IPT,IPOS) IF(IPOS.LE.0)GO TO 95 IPT=IPOS END IF END IF C C FORMAT, OUTFORMAT C IF(IKEY.EQ.16.OR.IKEY.EQ.110) THEN IF(IKEY.EQ.110.AND.ISTEPC.EQ.1.AND.IOUTFV.EQ.0)GO TO 97 CALL NBFND2(IPT,IPOS) IF(IPOS.EQ.0)GO TO 95 IF(CARD(IPOS:IPOS).NE.'(') THEN WRITE(U6,203) GO TO 99 END IF L=1 IF(IKEY.EQ.16) THEN IF(IFLOW.GT.0) THEN WRITE(U6,223) GO TO 99 END IF IF(IFOUTH.GT.IFHIGH)IFHIGH=IFOUTH CALL RINCR(11,IFHIGH,1) IFLOW=IFHIGH K=IFHIGH ELSE IF(IFOUTL.GT.0) THEN WRITE(U6,223) GO TO 99 END IF IFOUTH=IFHIGH CALL RINCR(11,IFOUTH,1) IFOUTL=IFOUTH K=IFOUTH END IF 5 CONTINUE DO 6 I=IPOS,256 IF(CARD(I:I).EQ.'x') THEN CARD(I:I)='X' ELSE IF(CARD(I:I).EQ.'f') THEN CARD(I:I)='F' ELSE IF(CARD(I:I).EQ.'d') THEN CARD(I:I)='D' ELSE IF(CARD(I:I).EQ.'e') THEN CARD(I:I)='E' ELSE IF(CARD(I:I).EQ.'A'.OR.CARD(I:I).EQ.'a'.OR. . CARD(I:I).EQ.'I'.OR.CARD(I:I).EQ.'i') THEN WRITE(U6,213) GO TO 99 ELSE IF(CARD(I:I).EQ.' ') THEN GO TO 6 END IF IF(L.GT.128) THEN L=1 IF(IKEY.EQ.16) THEN CALL RINCR(11,IFHIGH,1) ELSE CALL RINCR(11,IFOUTH,1) END IF K=K+1 END IF INFRMT(K)(L:L)=CARD(I:I) L=L+1 6 CONTINUE IF(.NOT.REFRSH(BASE)) GO TO 2 IPOS=1 GO TO 5 C C Except for CREATE, skip SELECT, DROP, KEEP, and BLOCK C ELSE IF(ISTEPC.NE.1.AND.(IKEY.EQ.9.OR.IKEY.EQ.18.OR. . IKEY.EQ.19.OR.IKEY.EQ.34)) THEN 62 CONTINUE IF(REFRSH(IPT)) GO TO 62 IF(U5ECHO.EQ.1)WRITE(U6,241) GO TO 2 C C CLASS, CATEGORICAL, CAT, SELECT, MISSING, COPY, BOOLEAN, NOT, C IF, ELSE, ELSE IF, END, ENDIF C ELSE IF((IKEY.GE.6.AND.IKEY.LE.10).OR.IKEY.EQ.33.OR. . IKEY.EQ.92.OR.IKEY.EQ.95.OR. . (IKEY.GE.104.AND.IKEY.LE.108)) THEN CALL SET1B(IKEY,IPT,VTMPSZ,ICWRNT,IPOS) C C INPUT C ELSE IF(IKEY.EQ.15) THEN IF(IRCINP.GT.0) THEN WRITE(U6,225) GO TO 99 END IF IF(IFLVL.GT.0) THEN IVZERO=1 END IF IRCINP=NRECOD+1 CALL RINCR(4,NRECOD,3) RCTYPE(IRCINP)=IRCTIN V1(IRCINP)=IUINPT V2(IRCINP)=0 RSTPNT(IRCINP)=0 K=NVIN+1 RCTYPE(IRCINP+1)=0 V2(IRCINP+1)=NXPTD V1(NRECOD)=0 V2(NRECOD)=0 V3(NRECOD)=ITYPEF(1) RSTPNT(NRECOD)=0 RCTYPE(NRECOD)=0 J=RCEIL(2)-NVIN CALL VNFIND(IPT,VNAME(K),J,NVINPT,IPOS,1,VNAME,MVAR) IF(NVINPT.EQ.0)GO TO 95 CALL RFADD(VNAME(K),NVINPT,J,1,IX,1) IF(U5ECHO.EQ.1)WRITE(U6,232)NVINPT V3(IRCINP)=NVINPT V1(IRCINP+1)=NXPTI CALL ROOMI(NVINPT) J=V1(IRCINP+1) DO 21 I=1,NVINPT IX(J)=K+I-1 J=J+1 21 CONTINUE C C Set values for LINK_MISSING C IF(IRCTIN.EQ.42) THEN DO 22 I=1,NVINPT MSIZE(K)=2 MXSIZE(K)=2 MTYPE(K)=2 MTSTRT(K)=2 K=K+1 22 CONTINUE END IF C C Look for keyed link or options C 23 CONTINUE IF(IPOS.GT.0) THEN IF(CARD(IPOS:IPOS).EQ.'/') THEN IPOS=IPOS+1 CALL NBFND2(IPOS,IPOS2) IF(IPOS.EQ.1)IPT=1 IF(IPOS2.GT.0) THEN IPOS=IPOS2 CALL CMATCH(CARD(IPOS:256),IPOS,256,'KEY',3,IPOS2,1) IF(IPOS2.GT.0) THEN IPOS=IPOS2 CALL NBFND2(IPOS,IPOS2) IF(IPOS.EQ.1)IPT=1 IPOS=IPOS2 J=RCEIL(2)-NVIN-NVINPT K=NVIN+NVINPT+1 CALL VNFIND(IPOS,VNAME(K),J,L,IPOS2,1,VNAME,MVAR) IF(IPOS.EQ.1)IPT=1 IPOS=IPOS2 IF(L.GE.1) THEN IF(NVIN.EQ.0) THEN IF(U5ECHO.GT.0)WRITE(U6,226) ELSE C C Check that the keyed variable was included on the input list. C RSTPNT(IRCINP)=L DO 71 I=1,L CALL VNMTCH(VNAME(K+I-1),VNAME(NVIN+1),NVINPT,J) IF(J.EQ.0) THEN WRITE(U6,227) GO TO 99 END IF CALL RINCR(4,NRECOD,1) RCTYPE(NRECOD)=0 V1(NRECOD)=NXPTD+J-1 C C Set the type of the keyed variable to 49. C MTYPE(NVIN+J)=49 V3(NRECOD)=NXPTD+NVINPT+I-1 C C Find the previous definition of the keyed variable and stop if not C previously defined. C CALL VNMTCH(VNAME(K+I-1),VNAME,NVIN,V2(NRECOD)) RSTPNT(NRECOD)=V2(NRECOD) IF(V2(NRECOD).EQ.0) THEN WRITE(U6,228) GO TO 99 END IF 71 CONTINUE END IF GO TO 23 END IF ELSE CALL CMATCH(CARD(IPOS:256),IPOS,256,'OPTION',6, . IPOS2,1) IF(IPOS2.EQ.0) THEN CALL CMATCH(CARD(IPOS:256),IPOS,256,'OPTIONS',7, . IPOS2,1) END IF IF(IPOS2.GT.0) THEN IPOS=IPOS2 CALL NBFND2(IPOS,IPOS2) IF(IPOS.EQ.1)IPT=1 IPOS=IPOS2 IX(NXPTI)=0 IX(NXPTI+1)=0 CALL OPTNTR(NOPTN1,INDX1,IVAL1,OPTNW1,IPOS,IPOS2, . IX(NXPTI)) V1(IRCINP+2)=IX(NXPTI) V2(IRCINP+2)=IX(NXPTI+1) IF(IPOS.EQ.1)IPT=1 IPOS=IPOS2 GO TO 23 END IF END IF GO TO 95 END IF END IF END IF L=NVINPT+RSTPNT(IRCINP) CALL ROOMD(L) C C Check that variables have not previously appeared C DO 72 I=1,NVINPT IF(MTYPE(NVIN+1).NE.49.AND.NVIN.GT.0) THEN CALL VNMTCH(VNAME(NVIN+1),VNAME,NVIN,J) IF(J.NE.0) THEN WRITE(U6,229)VNAME(NVIN+1) GO TO 99 END IF END IF CALL RINCR(2,NVIN,1) LABEL(NVIN)(1:12)=VNAME(NVIN) LABEL(NVIN)(13:24)=' ' CALL RFCHCK(1) 72 CONTINUE C C PRINT C C 63 = print C v1 v2 v3 rstpnt C # print #obs # list # pointer to IX C # req C ELSE IF(IKEY.EQ.156) THEN IPREQ=IPREQ+1 CALL RINCR(4,NRECOD,2) RCTYPE(NRECOD-1)=63 V1(NRECOD-1)=0 V2(NRECOD-1)=0 RSTPNT(NRECOD-1)=NXPTI V1(NRECOD)=IPREQ RCTYPE(NRECOD)=0 V2(NRECOD)=0 V3(NRECOD)=0 RSTPNT(NRECOD)=0 K=NVIN+1 J=RCEIL(2)-NVIN CALL VNFIND(IPT,VNAME(K),J,N,IPOS,1,VNAME,MVAR) IF(N.EQ.0)GO TO 95 V3(NRECOD-1)=N CALL ROOMI(N) C C Look for options C 73 CONTINUE IF(IPOS.GT.0) THEN IF(CARD(IPOS:IPOS).EQ.'/') THEN IPOS=IPOS+1 CALL NBFND2(IPOS,IPOS2) IF(IPOS.EQ.1)IPT=1 IF(IPOS2.GT.0) THEN IPOS=IPOS2 CALL CMATCH(CARD(IPOS:256),IPOS,256,'OPTION',6, . IPOS2,1) IF(IPOS2.EQ.0) THEN CALL CMATCH(CARD(IPOS:256),IPOS,256,'OPTIONS',7, . IPOS2,1) END IF IF(IPOS2.GT.0) THEN IPOS=IPOS2 CALL NBFND2(IPOS,IPOS2) IF(IPOS.EQ.1)IPT=1 IPOS=IPOS2 IX(NXPTI)=0 IX(NXPTI+1)=0 CALL OPTNTR(1,INDX1,IVAL1,OPTNW1,IPOS,IPOS2, . IX(NXPTI)) V1(NRECOD-1)=IX(NXPTI) IF(IPOS.EQ.1)IPT=1 IPOS=IPOS2 GO TO 73 END IF GO TO 95 END IF END IF END IF C C Build up list of variables in IX C K=RSTPNT(NRECOD-1) DO 74 I=1,N CALL VNMTCH(VNAME(NVIN+I),VNAME,NVIN,J) IF(J.EQ.0) THEN WRITE(U6,205)VNAME(NVIN+I) GO TO 99 END IF IX(K)=J K=K+1 74 CONTINUE IF(U5ECHO.EQ.1)WRITE(U6,250)IPREQ C C CROSS, ADD, SUBTRACT, MULTIPLY, DIVIDE, AND, OR C ADD_MS, SUBTRACT_MS, MULTIPLY_MS, DIVIDE_MS, RGENERATE, C IDCHANGE C ELSE IF(IKEY.EQ.31.OR.(IKEY.GE.69.AND.IKEY.LE.72).OR. . (IKEY.GE.100.AND.IKEY.LE.103).OR.IKEY.EQ.32.OR. . IKEY.EQ.93.OR.IKEY.EQ.94.OR.IKEY.EQ.96) THEN CALL SET1C(IKEY,IPT,VTMPSZ,IBYCHK) C C CONSTANT(S) C ELSE IF(IKEY.EQ.52) THEN IBEYND=0 53 CONTINUE L=SIZED-NXPTD+1 CALL DASCAN(IPT,IPOS,DX(NXPTD),L,N) IF(IPT.EQ.1)IBEYND=1 IF(N.GT.0.AND.IPOS.GT.0) THEN IPT=IPOS CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,K,IPOS,2,VNAME,NVIN) CALL RFADD(VTEMP(SVTEMP),K,VTMPSZ,2,IX,1) IF(K.NE.N+1)GO TO 95 IF(IPT.EQ.1)IBEYND=1 IPT=IPOS CALL VNMTCH('INTO ',VTEMP(SVTEMP),1,IINTO) IF(IINTO.EQ.0)GO TO 95 DO 54 I=1,N IF(NVIN.GT.0) THEN CALL VNMTCH(VTEMP(I+SVTEMP),VNAME,NVIN,IV2) ELSE IV2=0 END IF IF(IV2.EQ.0) THEN CALL RINCR(2,NVIN,1) IV2=NVIN VNAME(NVIN)=VTEMP(I+SVTEMP) LABEL(NVIN)(1:12)=VNAME(NVIN) LABEL(NVIN)(13:24)=' ' CALL RFCHCK(1) IF(IFLVL.GT.0)IVZERO=1 ELSE IF(IFLVL.GT.0.AND.MTYPE(IV2).NE.1.AND.MTYPE(IV2).LT.50) . GO TO 96 END IF IF(MTYPE(IV2).LT.50)MTYPE(IV2)=1 MSIZE(IV2)=1 LPOINT(IV2)=0 CDMPNT(IV2)=0 CALL RINCR(4,NRECOD,1) RSTPNT(NRECOD)=0 RCTYPE(NRECOD)=34 V1(NRECOD)=NXPTD+I-1 V2(NRECOD)=IV2 V3(NRECOD)=0 54 CONTINUE CALL ROOMD(N) IF(IPT.NE.0)GO TO 53 ELSE IF(N.GT.0.OR.IPOS.GT.0) THEN GO TO 95 END IF IF(IBEYND.EQ.1) THEN IPT=1 ELSE IPT=2 END IF C C SCRATCH1, SCRATCH2, SCRATCH3, SCRATCH4, SCRATCH5, BY, C REPLICATION (REP), UNWEIGHTED, DROP, KEEP, LABEL, LEVEL, C RENAME, REPLICATE, WEIGHT, STRATUM, CLUSTER, SECOND, C COEFFICIENT, FPC1, FPC2, HADAMARD C ELSE IF(IKEY.LE.5.OR.(IKEY.GE.11.AND.IKEY.LE.14).OR. . (IKEY.GE.18.AND.IKEY.LE.30).OR.IKEY.EQ.118) THEN CALL SET1A(IKEY,IPT,VTMPSZ,IPOS) C C OUTPUT C ELSE IF(IKEY.EQ.111.AND.(ISTEPC.NE.1.OR.IOUTFV.GT.0)) THEN C IF(NKEEP.GT.0) THEN C WRITE(U6,239) C GO TO 99 C END IF J=MVAR-NKEEP CALL VNFIND(IPT,VNKEEP(NKEEP+1),J,N,IPOS,2,VNAME,NVIN) IF(N.LE.0)GO TO 95 J=MVAR-NKEEP-N CALL RFADD(VNKEEP(NKEEP+1),N,J,2,IX,1) CALL RINCR(4,NRECOD,1) V1(NRECOD)=N V2(NRECOD)=NXPTI CALL ROOMI(1) IF(ISTEPC.EQ.1) THEN IX(NXPTI-1)=10 ELSE IX(NXPTI-1)=11 END IF CALL ROOMI(1) IX(NXPTI-1)=IOUTFV DO 61 I=1,N CALL ROOMI(1) CALL VNMTCH(VNKEEP(NKEEP+I),VNAME,NVIN,IX(NXPTI-1)) IF(IX(NXPTI-1).EQ.0) THEN WRITE(U6,205)VNKEEP(NKEEP+I) GO TO 95 END IF 61 CONTINUE IRCOUT=NRECOD RCTYPE(NRECOD)=47 C C RGENERATE C ELSE IF(IKEY.EQ.121) THEN CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,K,IPOS,2,VNAME,NVIN) J=NRECOD IF(K.GT.0) THEN CALL RFADD(VTEMP(SVTEMP),K,VTMPSZ,2,IX,1) END IF IF(J.EQ.NRECOD) THEN IF(U5ECHO.EQ.1)WRITE(U6,242) END IF C C LINK, LINK_MISSING C ELSE IF(IKEY.EQ.97.OR.IKEY.EQ.98) THEN GO TO 90 C C COMPUTE C ELSE IF(IKEY.EQ.17) THEN TSWTCH=2 CALL CMPAR1(IX,IPT) GO TO 1 C C BLOCK C ELSE IF(IKEY.EQ.34) THEN CALL RINCR(8,NCLBLK,1) BLCPNT(NCLBLK)=0 BLNCLS(NCLBLK)=0 BLVSTR(NCLBLK)=0 BLVSIZ(NCLBLK)=0 C C Determine if any remaining information on the record suggests C the old or new syntax. IF(IPT.EQ.0) THEN CALL NBFND2(IPT,IPOS) ELSE IPOS=IPT END IF IF(IPOS.EQ.0) THEN IBTYPE=1 ELSE IF(DGTCHK(CARD(IPOS:IPOS))) THEN IBTYPE=1 ELSE IBTYPE=2 END IF END IF IF(IBTYPE.EQ.2) THEN IF(NEWSYN.EQ.2) THEN GO TO 98 ELSE IF(NEWSYN.EQ.0) THEN NEWSYN=1 C C If the preceding blocks were processed under the old syntax originally, C correct them. C NCLBAR=0 IF(NCLBLK.GE.2) THEN DO 63 ICLBLK=1,NCLBLK-1 BLCPNT(ICLBLK)=0 BLNCLS(ICLBLK)=0 BLVSTR(ICLBLK)=0 BLVSIZ(ICLBLK)=0 63 CONTINUE END IF END IF IBFLAG=1 IPT=IPOS ICSPEC=0 END IF END IF 64 CONTINUE IF(IBFLAG.EQ.1.AND.IPOS.GT.0) THEN IF(CARD(IPOS:IPOS).EQ.'/') THEN IPOS=IPOS+1 CALL NBFND2(IPOS,IPOS2) IF(IPOS2.GT.0) THEN IPOS=IPOS2 GO TO 64 END IF ELSE CALL CMATCH(CARD(IPOS:256),IPOS,256,'CLASS',5,IPOS2,1) IF(IPOS2.GT.0) THEN IF(ICSPEC.EQ.1) THEN WRITE(U6,252) GO TO 99 ELSE ICSPEC=1 END IF IPOS=IPOS2 66 CONTINUE IPT=IPOS CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,K,IPOS,2,VNAME,NVIN) IF(K.GT.0) THEN DO 67 I=1,K CALL VNMTCH(VTEMP(I+SVTEMP-1),VNAME,NVIN,J) IF(J.EQ.0) THEN WRITE(U6,205)VTEMP(I+SVTEMP-1) GO TO 99 ELSE IF(MTYPE(J).NE.4) THEN WRITE(U6,253)VTEMP(I+SVTEMP-1) GO TO 99 END IF END IF BLNCLS(NCLBLK)=BLNCLS(NCLBLK)+1 CALL RINCR(9,NCLBAR,1) IF(BLCPNT(NCLBLK).EQ.0)BLCPNT(NCLBLK)=NCLBAR CLTYPE(NCLBAR)=J 67 CONTINUE END IF IF(IPOS.GT.0) THEN IF(CARD(IPOS:IPOS).EQ.'*') THEN IPOS=IPOS+1 GO TO 66 END IF END IF GO TO 64 ELSE CALL CMATCH(CARD(IPOS:256),IPOS,256,'SELECT',6,IPOS2,1) IF(IPOS2.GT.0) THEN IKEY=9 IPT=IPOS2 ELSE CALL CMATCH(CARD(IPOS:256),IPOS,256,'KEEP',4,IPOS2,1) IF(IPOS2.GT.0) THEN IKEY=19 IPT=IPOS2 ELSE IKEY=19 IPT=IPOS END IF END IF END IF GO TO 65 END IF END IF IF(IPT.EQ.1) THEN GO TO 2 ELSE GO TO 1 END IF C C 90 CONTINUE IF((IFLOW.EQ.0.AND.ITYPEF(1).EQ.1).OR.IRCINP.EQ.0) THEN IF(IFLOW.EQ.0)WRITE(U6,224) IF(IRCINP.EQ.0)WRITE(U6,230) GO TO 99 END IF V3(IRCINP+1)=IFLOW RSTPNT(IRCINP+1)=IFHIGH-IFLOW+1 IF(IKEY.EQ.97.OR.IKEY.EQ.98) THEN IFLOW=0 IRCINP=0 ITYPEF(1)=1 ITYPEF(2)=0 ITYPEF(3)=0 CALL FNREAD(IPT,ITYPEF,IFILEF,2,IPOSSC) IF(IMERR1.GT.0) THEN CALL FSTOP END IF IUINPT=IFILEF(1) IF(IKEY.EQ.97) THEN IRCTIN=41 ELSE IRCTIN=42 END IF GO TO 1 END IF IF(ISTEPC.NE.1.OR.IOUTFV.GT.0) THEN IF(IRCOUT.LE.0) THEN WRITE(U6,240) GO TO 99 ELSE IF(IOUTFV.LE.1.AND.IFOUTL.EQ.0) THEN WRITE(U6,224) GO TO 99 END IF V3(IRCOUT)=IFOUTL RSTPNT(IRCOUT)=IFOUTH-IFOUTL+1 IF(ISTEPC.NE.1.AND.NBY.GT.0.AND.IBYCHK.EQ.0) THEN WRITE(U6,247) GO TO 99 END IF END IF IF(ICWARN.GT.0.AND.U5ECHO.GT.0)WRITE(U6,220)ICWARN IF(IFLVL.NE.0) THEN WRITE(U6,234) GO TO 99 END IF IF(NHADAM.GT.0) THEN J=RCEIL(2)-NVIN IF(NRECOD.GT.0) THEN DO 91 I=1,NRECOD IF(RCTYPE(I).EQ.61) GO TO 94 91 CONTINUE END IF IF(IREPF.EQ.1) THEN VNAME(NVIN+1)='REPF ' ELSE VNAME(NVIN+1)='REPW ' END IF NVINPT=1 CALL RFADD(VNAME(NVIN+1),NVINPT,J,2,IX,1) END IF 94 CONTINUE RETURN 95 CONTINUE WRITE(U6,200) GO TO 99 96 CONTINUE WRITE(U6,233) GO TO 99 97 CONTINUE WRITE(U6,238) GO TO 99 98 CONTINUE WRITE(U6,251) 99 CONTINUE CALL FSTOP END SUBROUTINE SET1A(IKEY,IPT,VTMPSZ,IPOS) IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (MIFLVL=7,IXFLLD=15-MIFLVL) PARAMETER (MAXFMT=20) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL INTEGER VTMPSZ C CHARACTER*256 CARD COMMON /CRDBLK/CARD C LOGICAL REFRSH,ALPCHK,DGTCHK EXTERNAL REFRSH,ALPCHK,DGTCHK C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT C C NVTOT (NTOTV) C NVREG (IOUTC1) C NVARID (NID1) C INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1, . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX C DOUBLE PRECISION RANGE(2,MRANGE) INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET), . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD), . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI) C COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP, . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO, . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS, . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT, . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS, . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO, . NLEVEL,NRNSET,NRANGE,NHADAM,ISTEPC,IFLVL,IF1LST,IFLAST,NEWSYN, . IXFILL INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS, . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN, . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IFLAST(MIFLVL), . IXFILL(IXFLLD) C 200 FORMAT(' ERROR IN SPECIFICATION') 205 FORMAT(' UNRECOGNIZED VARIABLE NAME ',A12) 206 FORMAT(' Only one BY statement allowed') 207 FORMAT(' REPLICATION METHOD NOT RECOGNIZED') 208 FORMAT(' CONFLICT WITH PREVIOUS SPECIFICATION') 209 FORMAT(' VARIABLE REQUIRED TO BE OF TYPE REAL - ',A12) 214 FORMAT(' DROP may not be used with KEEP') 242 FORMAT(' INCONSISTENT WITH VPLX FILE') C C BY C IF(IKEY.EQ.11) THEN IF(NBY.GT.0.AND.ISTEPC.EQ.1) THEN WRITE(U6,206) GO TO 99 END IF CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,I,IPOS,2,VNAME,NVIN) IF(I.LE.0)GO TO 95 IF(ISTEPC.EQ.2) THEN IF(I.NE.NBY) THEN WRITE(U6,242) GO TO 99 END IF J=RCEIL(2)+NVREG+NCLASS+NVARID IF(VFTYPE.GE.5.AND.VFTYPE.LE.12)J=J-1 ELSE NBY=I CALL RCHECK(3,0,NBY) END IF DO 26 I=1,NBY CALL VNMTCH(VTEMP(I+SVTEMP-1),VNAME,NVIN,BYLIST(I)) IF(BYLIST(I).EQ.0) THEN WRITE(U6,205)VTEMP(I+SVTEMP-1) GO TO 99 END IF IF(ISTEPC.EQ.2) THEN J=J+1 CALL VNMTCH(VTEMP(I+SVTEMP-1),VNAME(J),1,K) IF(K.NE.1) THEN WRITE(U6,242) GO TO 99 END IF END IF 26 CONTINUE C C REPLICATION [REP] METHOD, C REPLICATE [REP] NUMBER, FACTORS, WEIGHTS, COUNT C HADAMARD C ELSE IF(IKEY.EQ.12.OR.IKEY.EQ.13.OR.IKEY.EQ.23.OR.IKEY.EQ.118) . THEN CALL NBFIND(CARD(IPT:256),IPT,256,IPOS2) IF(IPOS2.EQ.0)GO TO 95 IF(IKEY.EQ.118) THEN IF(NHADAM.GT.0)GO TO 96 CALL IFIND(CARD(IPOS2:256),IPOS2,256,IPT,NHADAM) IF(IPT.LE.0)GO TO 95 GO TO 1 END IF IPT=IPOS2 IFLAG=0 CALL CMATCH(CARD(IPT:256),IPT,256,'NUMBER',6,IPOS2,1) IF(IPOS2.GT.0) THEN IF(IREPNO.GT.0.OR.IREPF.GT.0.OR.IREPW.GT.0.OR. . ISTRCD.GT.0.OR.ISTRNO.GT.0.OR.ISNDCD.GT.0.OR. . ISNDNO.GT.0.OR.ICLUSC.GT.0.OR.ICLUSN.GT.0) THEN GO TO 96 END IF IFLAG=1 IREPNO=1 IPT=IPOS2 END IF CALL CMATCH(CARD(IPT:256),IPT,256,'COUNT',5,IPOS2,1) IF(IPOS2.GT.0) THEN IF(ICLCNT.GT.0) THEN GO TO 96 END IF CALL IFIND(CARD(IPOS2:256),IPOS2,256,IPT,ICLCNT) IF(IPT.LE.0)GO TO 95 GO TO 1 END IF CALL CMATCH(CARD(IPT:256),IPT,256,'FACTORS',7,IPOS2,1) IF(IPOS2.GT.0) THEN IF(IREPNO.GT.0.OR.IREPF.GT.0.OR.IREPW.GT.0.OR. . ISTRCD.GT.0.OR.ISTRNO.GT.0.OR.ISNDCD.GT.0.OR. . ISNDNO.GT.0.OR.ICLUSC.GT.0.OR.ICLUSN.GT.0) THEN GO TO 96 END IF IFLAG=1 IREPF=1 IPT=IPOS2 END IF CALL CMATCH(CARD(IPT:256),IPT,256,'WEIGHTS',7,IPOS2,1) IF(IPOS2.GT.0) THEN IF(IREPNO.GT.0.OR.IREPF.GT.0.OR.IREPW.GT.0.OR. . ISTRCD.GT.0.OR.ISTRNO.GT.0.OR.ISNDCD.GT.0.OR. . ISNDNO.GT.0.OR.ICLUSC.GT.0.OR.ICLUSN.GT.0) THEN GO TO 96 END IF IFLAG=1 IREPW=1 IPT=IPOS2 END IF IF(IFLAG.EQ.1) THEN CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,NREPW,IPOS,2,VNAME, . NVIN) IF(NREPW.LE.0)GO TO 95 IF(IREPNO.EQ.1.AND.NREPW.GT.1)GO TO 95 DO 28 I=1,NREPW CALL VNMTCH(VTEMP(I+SVTEMP-1),VNAME,MVAR,IV1) IF(IV1.LE.0) THEN WRITE(U6,205)VTEMP(I+SVTEMP-1) GO TO 99 END IF IF(IREPNO.EQ.1) THEN IREPNO=IV1 NREPW=0 GO TO 2 END IF IF(MTYPE(IV1).NE.1.OR.MXSIZE(IV1).NE.1) THEN WRITE(U6,209)VTEMP(I+SVTEMP-1) GO TO 99 END IF MTYPE(IV1)=50+I 28 CONTINUE GO TO 2 END IF CALL CMATCH(CARD(IPT:256),IPT,256,'METHOD',6,IPOS2,1) IF(IPOS2.GT.0) THEN CALL NBFIND(CARD(IPOS2:256),IPOS2,256,IPT) IF(IPT.EQ.0) GO TO 95 END IF ISMPL=0 CALL CMATCH(CARD(IPT:256),IPT,256,'SIMPLE',6,IPOS2,1) IF(IPOS2.GT.0) THEN CALL NBFIND(CARD(IPOS2:256),IPOS2,256,IPT) IF(IPT.EQ.0) GO TO 95 ISMPL=1 END IF CALL CMATCH(CARD(IPT:256),IPT,256,'STRAT',5,IPOS2,2) IF(IPOS2.GT.0) THEN VROPTN=4 GO TO 1 END IF CALL CMATCH(CARD(IPT:256),IPT,256,'JACK',4,IPOS2,2) IF(IPOS2.GT.0) THEN VROPTN=1 GO TO 1 END IF CALL CMATCH(CARD(IPT:256),IPT,256,'RE',2,IPOS2,2) IF(IPOS2.GT.0) THEN VROPTN=3 GO TO 1 END IF CALL CMATCH(CARD(IPT:256),IPT,256,'GEN',3,IPOS2,2) IF(IPOS2.GT.0) THEN VROPTN=5 GO TO 1 END IF CALL CMATCH(CARD(IPT:256),IPT,256,'HALF',4,IPOS2,2) IF(IPOS2.GT.0) THEN VROPTN=2 GO TO 1 END IF CALL CMATCH(CARD(IPT:256),IPT,256,'RAND',4,IPOS2,2) IF(IPOS2.GT.0) THEN VROPTN=7 GO TO 1 END IF WRITE(U6,207) GO TO 99 C C UNWEIGHTED C ELSE IF(IKEY.EQ.14) THEN IF(IWGT.NE.0) THEN GO TO 96 END IF NOWGTF=1 C C DROP, KEEP C ELSE IF(IKEY.EQ.18.OR.IKEY.EQ.19) THEN IF(VKEEPF.NE.0) THEN IF((IKEY.EQ.18.AND.VKEEPF.EQ.1).OR. . (IKEY.EQ.19.AND.VKEEPF.EQ.2)) THEN WRITE(U6,214) GO TO 99 END IF ELSE IF(IKEY.EQ.18) THEN VKEEPF=2 ELSE VKEEPF=1 END IF J=MVAR-NKEEP CALL VNFIND(IPT,VNKEEP(NKEEP+1),J,N,IPOS,2,VNAME,NVIN) IF(N.LE.0) GO TO 95 IF(IKEY.EQ.19) THEN IF(BLVSTR(NCLBLK).EQ.0)BLVSTR(NCLBLK)=NKEEP+1 BLVSIZ(NCLBLK)=BLVSIZ(NCLBLK)+N END IF NKEEP=NKEEP+N C C LABEL, LABELS C ELSE IF(IKEY.EQ.20) THEN CALL RLABEL(IPT,VNAME,NVIN,VTEMP(SVTEMP),VTMPSZ,VTEMP, . MTYPE,LPOINT,CDMPNT,CROSSD,LABEL,LEVEL,NLEVEL,MLEVEL,IPOS) C C LEVEL, LEVELS C ELSE IF(IKEY.EQ.21) THEN CALL RLEVEL(IPT,VNAME,NVIN,VTEMP(SVTEMP),VTMPSZ,LPOINT,MSIZE, . LEVEL,NLEVEL,MLEVEL,IPOS) C C RENAME C ELSE IF(IKEY.EQ.22) THEN CALL RENAMV(IPT,VNAME,NVIN,VTEMP(SVTEMP),VTMPSZ,VTEMP, . VNKEEP,NKEEP,MTYPE,LPOINT,CDMPNT,CROSSD,LABEL,LEVEL,IPOS) C C WEIGHT C ELSE IF(IKEY.EQ.24) THEN IF(IWGT.NE.0.OR.NOWGTF.GT.0) THEN GO TO 96 END IF CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,N,IPOS,2,VNAME,NVIN) IF(N.NE.1) GO TO 95 CALL VNMTCH(VTEMP(SVTEMP),VNAME,NVIN,N) IF(N.LE.0) THEN WRITE(U6,205)VTEMP(SVTEMP) GO TO 99 END IF IWGT=N GO TO 2 C C STRATUM SIZE, STRATUM SIZES, STRATUM CODE, STRATUM NUMBER C SECOND STAGE SIZE, SECOND STAGE SIZES, SECOND STAGE CODE, C SECOND STAGE NUMBER C SECOND-STAGE SIZE, SECOND-STAGE SIZES, SECOND-STAGE CODE, C SECOND-STAGE NUMBER C CLUSTER CODE, CLUSTER NUMBER, CLUSTER COUNT C ELSE IF(IKEY.GE.25.AND.IKEY.LE.27) THEN IF(IKEY.EQ.27.AND.CARD(IPT:IPT).EQ.'-')IPT=IPT+1 CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,N,IPOS,2,VNAME,NVIN) IF(N.EQ.0)GO TO 95 IF((IKEY.EQ.25.AND.N.EQ.1).OR. . (IKEY.EQ.27.AND.N.EQ.2)) THEN CALL CMATCH(VTEMP(N+SVTEMP-1),1,12,'SIZE',4,IPOS2,2) IF(IPOS2.GT.0) THEN L=SIZED-NXPTD+1 CALL DASCAN(IPOS,IPOS2,DX(NXPTD),L,N) IF(N.LE.0) GO TO 95 IF(IKEY.EQ.25) THEN IF(SISTRS.GT.0) THEN GO TO 96 ELSE SISTRS=NXPTI NISTRS=N END IF ELSE IF(SISNDS.GT.0) THEN GO TO 96 ELSE SISNDS=NXPTI NISNDS=N END IF END IF J=NXPTI K=NXPTD CALL ROOMI(N) DO 30 I=1,N IF(DX(K).LE.0) GO TO 95 IX(J)=DX(K)+.05 J=J+1 K=K+1 30 CONTINUE GO TO 2 END IF END IF CALL CMATCH(VTEMP(N+SVTEMP-1),1,12,'COUNT',5,IPOS2,2) IF(IPOS2.GT.0) THEN IF(ICLCNT.GT.0.OR.IKEY.NE.26) THEN GO TO 96 END IF CALL IFIND(CARD(IPOS:256),IPOS,256,IPT,ICLCNT) IF(IPT.LE.0)GO TO 95 GO TO 1 END IF CALL VNMTCH(VTEMP(N+SVTEMP-1),VNAME,NVIN,L) IF(L.LE.0) THEN WRITE(U6,205)VTEMP(N+SVTEMP-1) GO TO 99 END IF IF(N.GT.1) THEN N=N-1 CALL CMATCH(VTEMP(N+SVTEMP-1),1,12,'NUMBER',6,IPOS2,1) IF(IPOS2.GT.0) THEN IF(IKEY.EQ.25) THEN IF(ISTRNO.EQ.0.AND.ISTRCD.EQ.0.OR.IREPNO.GT.0) THEN ISTRNO=L GO TO 2 END IF ELSE IF(IKEY.EQ.26) THEN IF(ICLUSN.EQ.0.AND.ICLUSC.EQ.0.OR.IREPNO.GT.0) THEN ICLUSN=L GO TO 2 END IF ELSE IF(ISNDNO.EQ.0.AND.ISNDCD.EQ.0.OR.IREPNO.GT.0) THEN ISNDNO=L GO TO 2 END IF END IF GO TO 96 END IF END IF IF(IKEY.EQ.25) THEN IF(ISTRCD.EQ.0.AND.ISTRCD.EQ.0.OR.IREPNO.GT.0) THEN ISTRCD=L GO TO 2 END IF ELSE IF(IKEY.EQ.26) THEN IF(ICLUSC.EQ.0.AND.ICLUSN.EQ.0.OR.IREPNO.GT.0) THEN ICLUSC=L GO TO 2 END IF ELSE IF(ISNDCD.EQ.0.AND.ISNDNO.EQ.0.OR.IREPNO.GT.0) THEN ISNDCD=L GO TO 2 END IF END IF GO TO 96 C C COEFFICIENTS, FPC1, FPC2 C ELSE IF(IKEY.GE.28.AND.IKEY.LE.30) THEN L=SIZED-NXPTD+1 CALL DASCAN(IPT,IPOS2,DX(NXPTD),L,N) IF(N.LE.0) GO TO 95 IF(IKEY.EQ.28) THEN IF(ISTEPC.EQ.2) THEN IF(N.NE.NRPTOT) GO TO 96 DO 41 I=1,N IF(DABS(DX(NXPTD+I-1)-DX(SDCOEF+I-1)).GT..1D-06)GO TO 96 41 CONTINUE ELSE IF(SDCOEF.GT.0.OR.SDFPC1.GT.0.OR.SDFPC2.GT.0) THEN GO TO 96 ELSE SDCOEF=NXPTD NDCOEF=N END IF ELSE DO 42 I=1,N DX(NXPTD+I-1)=1.D0-DX(NXPTD+I-1) 42 CONTINUE IF(IKEY.EQ.29) THEN IF(SDFPC1.GT.0.OR.(SDCOEF.GT.0.AND.ISTEPC.EQ.1)) THEN GO TO 96 ELSE SDFPC1=NXPTD NDFPC1=N END IF ELSE IF(SDFPC2.GT.0.OR.(SDCOEF.GT.0.AND.ISTEPC.EQ.1)) THEN GO TO 96 ELSE SDFPC2=NXPTD NDFPC2=N END IF END IF END IF IF(ISTEPC.EQ.1.OR.IKEY.NE.28) THEN CALL ROOMD(N) END IF END IF GO TO 3 1 CONTINUE IPT=2 GO TO 3 2 CONTINUE IPT=1 3 CONTINUE RETURN 95 CONTINUE WRITE(U6,200) GO TO 99 96 CONTINUE WRITE(U6,208) 99 CONTINUE CALL FSTOP END SUBROUTINE SET1B(IKEY,IPT,VTMPSZ,ICWRNT,IPOS) IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (MIFLVL=7,IXFLLD=15-MIFLVL) PARAMETER (MAXFMT=20) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL INTEGER VTMPSZ LOGICAL RANGEP C CHARACTER*256 CARD COMMON /CRDBLK/CARD C LOGICAL REFRSH,ALPCHK,DGTCHK EXTERNAL REFRSH,ALPCHK,DGTCHK C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1, . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX C DOUBLE PRECISION RANGE(2,MRANGE) INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET), . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD), . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI) C COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP, . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO, . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS, . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT, . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS, . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO, . NLEVEL,NRNSET,NRANGE,NHADAM,ISTEPC,IFLVL,IF1LST,IFLAST,NEWSYN, . IXFILL INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS, . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN, . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IFLAST(MIFLVL), . IXFILL(IXFLLD) C 200 FORMAT(' ERROR IN SPECIFICATION') 205 FORMAT(' UNRECOGNIZED VARIABLE NAME ',A12) 212 FORMAT(' VARIABLE OF INAPPROPRIATE TYPE - ',A12) 215 FORMAT(' Variable already exists - ',A12) 216 FORMAT(' COPY into a CLASS variable is not allowed') 220 FORMAT(5X,'WARNING: COUNT OF CAT, CLASS, ETC. OPERATIONS TO CAT OR . CROSSED VAR:',I4) 221 FORMAT(5X,'WARNING: OPERATIONS TO CAT OR CROSSED VAR') 222 FORMAT(5X,'FOR REAL, REAL WITH MISSING, OR CROSSED REAL ONLY') 233 FORMAT(' NOT PERMITTED WITHIN IF BLOCK') 234 FORMAT(' UNBALANCED IFS') 235 FORMAT(' EXCEEDS MAXIMUM IF LEVELS') 236 FORMAT(5X,'(If level:',i2,')') 237 FORMAT(' NOT ALLOWED ON REPLICATE WEIGHT/FACTOR') 251 FORMAT(' CONFLICT BETWEEN OLD AND NEW SYNTAX') C C Contents of MTYPE, codes for transformations C 1 = real variable C 2 = real variable with missing checks C 3 = categorical variable C 4 = class variable, known dimension C 5 = by variable, known dimension C 6 = by variable, unknown dimension C 7 = select transformation (not variable type) C 8 = cross variable, real value C 9 = cross variable, categorical C 10 = copy (not variable type) C 21 = boolean " C 22 = boolean - no range " C 23 = and (logical and) " C 24 = or " C 25 = not " C 26 = add_ms " C 27 = subtract_ms " C 28 = multiply_ms " C 29 = divide_ms " C 30 = add " C 31 = subtract " C 32 = multiply " C 33 = divide " C 34 = constants " C 35 = if (else if) " C 36 = go to " C 40 = initial read C 41 = input (link) C 42 = input with missing (link_missing) C v1 v2 v3 rstpnt C iuinpt status # input # keys C 1st v start x start fmt # fmt C # print #obs C key x match v last key var # of match v C 43 = add loop to replicate weights/factors C v1 v2 v3 rstpnt C 1st rf/rw # rf/rw var C 44 = subtract loop to replicate weights/factors C 45 = multiply loop " C 46 = divide loop " C 47 = output C C 50-60 are during REWEIGHT only C C 50 = add, 0 replicate, using vplxin data C v1 v2 v3 rstpnt C 1st op target vplxin v #classes C for each class: C v1 v2 v3 rstpnt C class/cat 0 offset increment C C 51 = subtract, 0 replicate using vplxin data C 52 = multiply, 0 replicate " C 53 = divide, 0 replicate " C 54 = add loop to replicate weights/factors, using vplxin C v1 v2 v3 rstpnt C 1st rf/rw # rf/rw vplxin var #classes C for each class: C v1 v2 v3 rstpnt C class/cat 0 offset increment C C 55 = subtract loop to replicate weights/factors, using vplxin C 56 = multiply loop " " C 57 = divide loop " " C C 58 = define repf based on var ids C v1 v2 v3 rstpnt C 1st rf/rw # rf/rw wt #var ids C for each id: C v1 v2 v3 rstpnt C variance id C for repw, v3 will give id of weight C 60 = check BY variables C v1 v2 v3 rstpnt C #BY vars C for each BY var: C v1 v2 v3 rstpnt C BY id loc in vid C C 61 = define repf based on rows of Hadamard matrix and C coefficients C v1 v2 v3 rstpnt C 1st rf/rw # rf/rw wt #sets C for each set: C v1 v2 v3 rstpnt C row coefficient C for repw, v3 will give id of weight C IBEYND=0 ICWRNT=0 IRC=0 CALL NBFND2(IPT,IPT2) C C Check whether ELSE or ELSE IF C IF(IKEY.EQ.105) THEN IF(IPT2.GT.0) THEN CALL CMATCH(CARD(IPT2:256),IPT2,256,'IF',2,IPOS2,1) IF(IPOS2.EQ.0)GO TO 95 IPOS=IPT2+2 CALL NBFND2(IPOS,IPT2) IF(IPOS.EQ.1)IBEYND=1 IF(IPT2.LE.0)GO TO 95 ELSE C C Handling of ELSE C IF(IFLVL.EQ.0)GO TO 97 IF(IFLAST(IFLVL).LT.0)GO TO 97 CALL RINCR(4,NRECOD,1) RCTYPE(NRECOD)=36 V3(NRECOD)=IFLAST(IFLVL) IFLAST(IFLVL)=-NRECOD IF(IFLVL.GT.1.AND.U5ECHO.EQ.1)WRITE(U6,236)IFLVL RETURN END IF ELSE IF(IKEY.EQ.107.OR.IKEY.EQ.108) THEN C C END, ENDIF C IF(IFLVL.EQ.0)GO TO 97 IF(IFLVL.GT.1.AND.U5ECHO.EQ.1)WRITE(U6,236)IFLVL IRC=NRECOD+1 4 CONTINUE J=IFLAST(IFLVL) IF(J.GT.0) THEN IFLAST(IFLVL)=V3(J) V3(J)=IRC IF(IFLAST(IFLVL).GT.0) THEN V3(J-1)=NRECOD+1 IRC=J GO TO 4 END IF ELSE J=-J IFLAST(IFLVL)=V3(J) V3(J)=IRC IRC=J+1 GO TO 4 END IF IFLVL=IFLVL-1 RETURN ELSE IF(IPT2.LE.0)GO TO 95 END IF C C Preliminary setup for IF and ELSE IF, get beyond first "(" C IF(IKEY.GE.104.AND.IKEY.LE.106) THEN IF(CARD(IPT2:IPT2).EQ.'(') THEN IPOS=IPT2+1 CALL NBFND2(IPOS,IPT2) IF(IPOS.EQ.1)IBEYND=1 IF(IPT2.LE.0)GO TO 95 END IF IF(IKEY.EQ.104) THEN IFLVL=IFLVL+1 IF(IFLVL.GT.MIFLVL) THEN WRITE(U6,235) GO TO 99 END IF IFLAST(IFLVL)=NRECOD+1 IF(IFLVL.EQ.1)IF1LST=NRECOD+1 V3(NRECOD+1)=0 ELSE IF(IFLVL.EQ.0)GO TO 97 IF(IFLAST(IFLVL).LE.0)GO TO 97 CALL RINCR(4,NRECOD,1) RCTYPE(NRECOD)=36 V3(NRECOD+1)=IFLAST(IFLVL) IFLAST(IFLVL)=NRECOD+1 END IF END IF IF(IKEY.EQ.10) THEN IRC=2 ELSE IF(IKEY.EQ.9) THEN IRC=7 ELSE IF(IKEY.GE.104.AND.IKEY.LE.106) THEN IRC=35 END IF CALL VNFIND(IPT2,VTEMP(SVTEMP),VTMPSZ,N,IPOS,2,VNAME,NVIN) IF(IPT2.EQ.1)IPT=1 IF(N.LE.0)GO TO 95 IF(IRC.EQ.35) THEN IF(IPOS.GT.0) THEN IF(CARD(IPOS:IPOS).EQ.')') THEN IPOS2=IPOS+1 CALL NBFND2(IPOS2,IPOS) IF(IPOS2.EQ.1)IBEYND=1 IF(IPOS.GT.0) THEN CALL CMATCH(CARD(IPOS:256),IPOS,256,'THEN',4,IPOS2,1) IF(IPOS2.GT.0) THEN CALL NBFND2(IPOS2,IPOS) IF(IPOS2.NE.1)GO TO 95 IPOS=0 ELSE GO TO 95 END IF END IF END IF END IF END IF C C If IPOS=0, check for COPY or CLASS catvar INTO classvar syntax C IF(IPOS.EQ.0) THEN RANGEP=.FALSE. IF(IKEY.GE.6.AND.IKEY.LE.9.AND.IFLVL.GT.0)GO TO 96 IF((IKEY.EQ.6).OR.IKEY.EQ.33) THEN CALL VNMTCH('INTO ',VTEMP(SVTEMP),N,IINTO) IF(IINTO.GT.0) THEN N1=1 7 CONTINUE IF(IINTO.EQ.0.OR.2*IINTO+N1.GT.N+2)GO TO 95 L=IINTO+N1-2 L1=L+2 DO 9 I=N1,L CALL VNMTCH(VTEMP(I+SVTEMP-1),VNAME,NVIN,IV1) IF(IV1.LE.0) THEN WRITE(U6,205)VTEMP(I+SVTEMP-1) GO TO 99 END IF IF(MTYPE(IV1).NE.3.AND.IKEY.EQ.6) THEN WRITE(U6,212)VTEMP(I+SVTEMP-1) GO TO 99 END IF CALL VNMTCH(VTEMP(L1+SVTEMP-1),VNAME,NVIN,IV2) IF(IV2.NE.0.AND.IKEY.EQ.6) THEN WRITE(U6,215)VTEMP(L1+SVTEMP-1) GO TO 99 END IF IF(IV2.EQ.0) THEN CALL RINCR(2,NVIN,1) IV2=NVIN VNAME(NVIN)=VTEMP(L1+SVTEMP-1) CALL RFCHCK(1) MXSIZE(IV2)=MSIZE(IV1) IF(IKEY.EQ.6) THEN IF(MTYPE(IV2).GE.50)GO TO 98 MTYPE(IV2)=4 IF(ISTEPC.EQ.1.AND.NEWSYN.NE.1) THEN BLNCLS(NCLBLK)=BLNCLS(NCLBLK)+1 CALL RINCR(9,NCLBAR,1) IF(BLCPNT(NCLBLK).EQ.0)BLCPNT(NCLBLK)=NCLBAR CLTYPE(NCLBAR)=IV2 END IF ELSE IF(IFLVL.GT.0) THEN IF(MTYPE(IV1).EQ.2) THEN MTSTRT(IV2)=2 ELSE IF(MTYPE(IV1).NE.1.AND.MTYPE(IV1).LT.50) THEN GO TO 96 END IF IVZERO=1 END IF IF(MTYPE(IV2).LT.50) THEN IF(MTYPE(IV1).LT.50)MTYPE(IV2)=MTYPE(IV1) ELSE IF(MTYPE(IV1).NE.1.AND.MTYPE(IV1).LT.50)GO TO 98 END IF END IF ELSE IF(MTYPE(IV2).EQ.4) THEN WRITE(U6,216) GO TO 99 END IF IF(MTYPE(IV2).GE.50) THEN IF(MTYPE(IV1).NE.1.AND.MTYPE(IV1).LT.50)GO TO 98 ELSE IF(MTYPE(IV1).GE.50) THEN IF(IFLVL.GT.0) THEN IF(MTYPE(IV2).NE.1)GO TO 96 ELSE MTYPE(IV2)=1 END IF ELSE IF(MXSIZE(IV2).LT.MSIZE(IV1))MXSIZE(IV2)=MSIZE(IV1) IF(IFLVL.GT.0) THEN IF(MTYPE(IV2).NE.MTYPE(IV1))GO TO 96 IF(MSIZE(IV2).NE.MSIZE(IV1))GO TO 96 ELSE MTYPE(IV2)=MTYPE(IV1) END IF END IF END IF MSIZE(IV2)=MSIZE(IV1) IF(LABEL(IV1)(1:12).EQ.VNAME(IV1).AND. . LABEL(IV1)(13:24).EQ.' ') THEN LABEL(IV2)(1:12)=VNAME(IV2) LABEL(IV2)(13:24)=' ' ELSE LABEL(IV2)=LABEL(IV1) END IF LPOINT(IV2)=LPOINT(IV1) CDMPNT(IV2)=CDMPNT(IV1) CALL RINCR(4,NRECOD,1) RSTPNT(NRECOD)=0 RCTYPE(NRECOD)=10 V1(NRECOD)=IV1 V2(NRECOD)=IV2 V3(NRECOD)=IV1 L1=L1+1 9 CONTINUE N1=L1 IF(N1.LE.N) THEN N2=N-N1+1 CALL VNMTCH('INTO ',VTEMP(N1+SVTEMP-1),N2,IINTO) GO TO 7 ELSE GO TO 2 END IF ELSE IF(IKEY.EQ.33)GO TO 95 DO 10 I=1,N CALL VNMTCH(VTEMP(I+SVTEMP-1),VNAME,NVIN,J) IF(J.EQ.0) THEN WRITE(U6,205)VTEMP(I+SVTEMP-1) GO TO 99 END IF IF(MTYPE(J).NE.4) THEN WRITE(U6,212)VTEMP(I+SVTEMP-1) GO TO 99 END IF IF(ISTEPC.EQ.1) THEN IF(NEWSYN.EQ.1) THEN WRITE(U6,251) GO TO 99 ELSE NEWSYN=2 END IF BLNCLS(NCLBLK)=BLNCLS(NCLBLK)+1 CALL RINCR(9,NCLBAR,1) IF(BLCPNT(NCLBLK).EQ.0)BLCPNT(NCLBLK)=NCLBAR CLTYPE(NCLBAR)=J END IF 10 CONTINUE GO TO 2 END IF ELSE IF(IKEY.EQ.92) THEN IRC=22 ELSE IF(IKEY.EQ.95) THEN IRC=25 ELSE IF(IRC.EQ.0) THEN GO TO 95 END IF IBEYND=1 ELSE C C Remaining cases all should have range specification C RANGEP=.TRUE. IF(IPT.EQ.1)IBEYND=1 CALL NBFND2(IPOS,IPOS2) IF(IPOS.EQ.1)IBEYND=1 IF(IPOS2.EQ.0)GO TO 95 IF(CARD(IPOS2:IPOS2).NE.'(') GO TO 95 IPOS=IPOS2+1 IF(IPOS.GE.241) THEN IF(.NOT.REFRSH(IPOS)) GO TO 95 IBEYND=1 END IF CALL RCHECK(5,NRANGE,1) NRANG1=NRANGE+1 CALL RINCR(6,NRNSET,1) N1MAX=MRANGE-NRANGE RNGPNT(NRNSET)=NRANG1 CALL RCHECK(7,NLEVEL,1) N1LEV=NLEVEL+1 NL1MAX=MLEVEL-NLEVEL CALL RNSCAN(IPOS,IPOS2,RANGE(1,NRANG1),N1MAX,RTYPE(NRANG1), . RGROUP(NRANG1),NR,1,LEVEL(N1LEV),NL1MAX) IF(IPOS.EQ.1)IBEYND=1 IF(IPOS2.GT.0) THEN CALL NBFND2(IPOS2,IPOS) IF(IPOS2.EQ.1)IBEYND=1 IF(IPOS.GT.0) THEN IF(CARD(IPOS:IPOS).EQ.')')IPOS=IPOS+1 IPOS2=IPOS CALL NBFND2(IPOS2,IPOS) IF(IPOS2.EQ.1)IBEYND=1 IF(IKEY.GE.104.AND.IKEY.LE.106) THEN IF(IPOS.GT.0) THEN CALL CMATCH(CARD(IPOS:256),IPOS,256,'THEN',4,IPOS2,1) IF(IPOS2.EQ.0)GO TO 95 IPOS=IPOS2 END IF ELSE IF(NR.LE.0)GO TO 95 END IF END IF END IF NRNG(NRNSET)=NR CALL RINCR(5,NRANGE,NR) IF(IKEY.LT.9) THEN CALL RINCR(7,NLEVEL,RGROUP(NRANGE)) CALL LEVELR(IPOS2,IPOS,NL,LEVEL(N1LEV),RGROUP(NRANGE)) IF(IPOS2.EQ.1)IBEYND=1 IPOS2=IPOS END IF IF(IKEY.EQ.6.AND.IKEY.LE.9.AND.IFLVL.GT.0)GO TO 96 IF(IKEY.EQ.7.OR.IKEY.EQ.8) THEN IRC=3 ELSE IF(IKEY.EQ.6) THEN IRC=4 ELSE IF(IKEY.EQ.92) THEN IRC=21 ELSE IF(IRC.EQ.0) THEN GO TO 95 END IF END IF CALL VNMTCH('FOR ',VTEMP(SVTEMP),N,IFOR) IF(IFOR.EQ.0) THEN CALL VNMTCH('IF ',VTEMP(SVTEMP),N,IFOR) END IF CALL VNMTCH('INTO ',VTEMP(SVTEMP),N,IINTO) IF(IFOR.GT.0) THEN IF(IKEY.NE.9.AND.IKEY.NE.10)GO TO 95 ELSE IF(.NOT.RANGEP.AND.IRC.EQ.2)GO TO 95 END IF IS1=1 IF(IINTO.GT.0) THEN N1=IINTO-1 I2=IINTO+1 IF(IFOR.GT.0) THEN IF(IFOR.EQ.N-1) THEN IF(N1+IINTO+2.NE.N)GO TO 95 ELSE IF(N1+IINTO+1.NE.IFOR)GO TO 95 IF(IFOR+N1.NE.N)GO TO 95 END IF ELSE IF(N1+IINTO.NE.N)GO TO 95 END IF ELSE IF(IFOR.EQ.1.AND.IKEY.EQ.9) THEN IS1=2 N1=N I2=2 ELSE IF(IFOR.GT.0) THEN N1=IFOR-1 I2=1 IF(IFOR.NE.N-1) THEN IF(IFOR+N1.NE.N)GO TO 95 END IF ELSE N1=N I2=1 END IF IFOR=IFOR+1 C IF(RANGEP) THEN C DO 14 I=NRANG1,NRANGE C IF(RTYPE(I).EQ.5) THEN C IF(IKEY.NE.6)GO TO 95 C END IF C 14 CONTINUE C END IF IF(IRC.EQ.35) THEN IF(IS1.NE.N1)GO TO 95 IF(IFLVL.GT.1.AND.U5ECHO.EQ.1)WRITE(U6,236)IFLVL END IF DO 18 I=IS1,N1 CALL VNMTCH(VTEMP(I+SVTEMP-1),VNAME,NVIN,IV1) CALL VNMTCH(VTEMP(I2+SVTEMP-1),VNAME,NVIN,IV2) CALL VNMTCH(VTEMP(IFOR+SVTEMP-1),VNAME,NVIN,IV3) IF(IV1.EQ.0) THEN WRITE(U6,205)VTEMP(I+SVTEMP-1) GO TO 99 END IF IF(IV3.EQ.0) THEN WRITE(U6,205)VTEMP(IFOR+SVTEMP-1) GO TO 99 END IF IF(IFOR.LT.N)IFOR=IFOR+1 IF(IV2.EQ.0) THEN CALL RINCR(2,NVIN,1) VNAME(NVIN)=VTEMP(I2+SVTEMP-1) LABEL(NVIN)(1:12)=VNAME(NVIN) LABEL(NVIN)(13:24)=' ' IV2=NVIN CALL RFCHCK(1) IF(MTYPE(IV2).GE.50)GO TO 98 IF(IFLVL.GT.0) THEN IF(IKEY.EQ.10) THEN MTSTRT(NVIN)=2 MTYPE(NVIN)=2 ELSE GO TO 96 END IF END IF END IF MTSAVE=MTYPE(IV2) IF(IKEY.LE.10.OR.IRC.EQ.35) THEN MT1=MTYPE(IV1) IF(MT1.GE.50)MT1=1 IF(MT1.EQ.3.OR.MT1.EQ.4.OR.MT1.EQ.8.OR.MT1.EQ.9) THEN ICWARN=ICWARN+1 ICWRNT=ICWRNT+1 END IF END IF CALL RINCR(4,NRECOD,1) IF(RANGEP) THEN RSTPNT(NRECOD)=NRNSET ELSE RSTPNT(NRECOD)=0 END IF RCTYPE(NRECOD)=IRC V1(NRECOD)=IV1 V2(NRECOD)=IV2 IF(IRC.EQ.7) THEN V3(NRECOD)=NCLBLK ELSE IF(IRC.NE.35) THEN V3(NRECOD)=IV3 END IF IF(IKEY.LT.9) THEN MSIZE(IV2)=RGROUP(NRANGE) LPOINT(IV2)=N1LEV MTYPE(IV2)=IRC ELSE IF(IKEY.EQ.10) THEN IF(MTYPE(IV1).EQ.1) THEN MSIZE(IV2)=2 MTYPE(IV2)=2 ELSE MSIZE(IV2)=MSIZE(IV1) MTYPE(IV2)=MTYPE(IV1) END IF ELSE IF(IKEY.EQ.92.OR.IKEY.EQ.95) THEN IF(MTYPE(IV1).NE.1.AND.MTYPE(IV1).NE.2.AND.MTYPE(IV1).NE.8 . .AND.MTYPE(IV1).LT.50) THEN WRITE(U6,222) GO TO 99 END IF MSIZE(IV2)=1 MTYPE(IV2)=1 END IF IF(IRC.NE.35) THEN IF(IFLVL.GT.0.AND.MTSAVE.NE.MTYPE(IV2))GO TO 96 END IF IF(MXSIZE(IV2).LT.MSIZE(IV2))MXSIZE(IV2)=MSIZE(IV2) IF(IKEY.EQ.6.AND.ISTEPC.EQ.1.AND.NEWSYN.NE.1) THEN BLNCLS(NCLBLK)=BLNCLS(NCLBLK)+1 CALL RINCR(9,NCLBAR,1) IF(BLCPNT(NCLBLK).EQ.0)BLCPNT(NCLBLK)=NCLBAR CLTYPE(NCLBAR)=IV2 END IF I2=I2+1 18 CONTINUE IF(ICWRNT.GT.0.AND.U5ECHO.EQ.1)WRITE(U6,221) IF(U5END.EQ.1.OR.(ALPCHK(CARD(1:1)).AND.IBEYND.EQ.1))GO TO 2 IPT=2 GO TO 3 2 CONTINUE IPT=1 3 CONTINUE RETURN 95 CONTINUE WRITE(U6,200) GO TO 99 96 CONTINUE WRITE(U6,233) GO TO 99 97 CONTINUE WRITE(U6,234) GO TO 99 98 CONTINUE WRITE(U6,237) 99 CONTINUE CALL FSTOP END C SUBROUTINE SET1C(IKEY,IPT,VTMPSZ,IBYCHK) IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (MIFLVL=7,IXFLLD=15-MIFLVL) PARAMETER (MAXFMT=20) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL INTEGER VTMPSZ C CHARACTER*256 CARD COMMON /CRDBLK/CARD C LOGICAL REFRSH,ALPCHK,DGTCHK EXTERNAL REFRSH,ALPCHK,DGTCHK C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1, . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX C DOUBLE PRECISION RANGE(2,MRANGE) INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET), . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD), . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI) C COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP, . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO, . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS, . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT, . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS, . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO, . NLEVEL,NRNSET,NRANGE,NHADAM,ISTEPC,IFLVL,IF1LST,IFLAST,NEWSYN, . IXFILL INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS, . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN, . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IFLAST(MIFLVL), . IXFILL(IXFLLD) C INTEGER SVTMP2 C 200 FORMAT(' ERROR IN SPECIFICATION') 205 FORMAT(' UNRECOGNIZED VARIABLE NAME ',A12) 210 FORMAT(' BY missing or unbalanced numbers of variables') 211 FORMAT(' THIS VARIABLE IS NOT OF TYPE CLASS OR CATEGORICAL - ',A12 .) 212 FORMAT(' VARIABLE OF INAPPROPRIATE TYPE - ',A12) 222 FORMAT(5X,'FOR REAL, REAL WITH MISSING, OR CROSSED REAL ONLY') 233 FORMAT(5X,'Not permitted within if block') 237 FORMAT(' NOT ALLOWED ON REPLICATE WEIGHT/FACTOR') 243 FORMAT(' VPLXIN VAR. MUST BE REAL OR DERIVED') 244 FORMAT(' UNMATCHED CLASS: ',A12) 245 FORMAT(' MUST BE CAT OR CLASS: ',A12) 246 FORMAT(' SIZE MISMATCH: ',A12) 248 FORMAT(' UNMATCHED BY VAR: ',A12) 249 FORMAT(5X,'Link to BY variables here') 250 FORMAT(/,5X,'WARNING: Link to BY variables moved to start of level . 1 IF BLOCK') C C Contents of MTYPE, codes for transformations C 1 = real variable C 2 = real variable with missing checks C 3 = categorical variable C 4 = class variable, known dimension C 5 = by variable, known dimension C 6 = by variable, unknown dimension C 7 = select transformation (not variable type) C 8 = cross variable, real value C 9 = cross variable, categorical C 10 = copy (not variable type) C 21 = boolean " C 22 = boolean - no range " C 23 = and (logical and) " C 24 = or " C 25 = not " C 26 = add_ms " C 27 = subtract_ms " C 28 = multiply_ms " C 29 = divide_ms " C 30 = add " C 31 = subtract " C 32 = multiply " C 33 = divide " C 34 = constants " C 35 = if (else if) " C 36 = go to " C 40 = initial read C 41 = input (link) C 42 = input with missing (link_missing) C v1 v2 v3 rstpnt C iuinpt status # input # keys C 1st v start x start fmt # fmt C # print #obs C key x match v last key var # of match v C 43 = add loop to replicate weights/factors C v1 v2 v3 rstpnt C 1st rf/rw # rf/rw var C 44 = subtract loop to replicate weights/factors C 45 = multiply loop " C 46 = divide loop " C 47 = output C C 50-60 are during REWEIGHT only C C 50 = add, 0 replicate, using vplxin data C v1 v2 v3 rstpnt C 1st op target vplxin v #classes C for each class: C v1 v2 v3 rstpnt C class/cat 0 offset increment C C 51 = subtract, 0 replicate using vplxin data C 52 = multiply, 0 replicate " C 53 = divide, 0 replicate " C 54 = add loop to replicate weights/factors, using vplxin C v1 v2 v3 rstpnt C 1st rf/rw # rf/rw vplxin var #classes C for each class: C v1 v2 v3 rstpnt C class/cat 0 offset increment C C 55 = subtract loop to replicate weights/factors, using vplxin C 56 = multiply loop " " C 57 = divide loop " " C C 58 = define repf based on var ids C v1 v2 v3 rstpnt C 1st rf/rw # rf/rw wt #var ids C for each id: C v1 v2 v3 rstpnt C variance id C for repw, v3 will give id of weight C 60 = check BY variables C v1 v2 v3 rstpnt C #BY vars C for each BY var: C v1 v2 v3 rstpnt C BY id loc in vid C C 61 = define repf based on rows of Hadamard matrix and C coefficients C v1 v2 v3 rstpnt C 1st rf/rw # rf/rw wt #sets C for each set: C v1 v2 v3 rstpnt C row coefficient C for repw, v3 will give id of weight C C C 62 = idchange to return 1 if change in variables C v1 v2 v3 rstpnt C 0 idchange 0 # keys C for each key: C 0 match v pointer to var # of match v C last value C IRC=0 CALL VNFIND(IPT,VTEMP(SVTEMP),VTMPSZ,N,IPOS,2,VNAME,NVIN) IF(N.LE.0)GO TO 95 CALL RFADD(VTEMP(SVTEMP),N,VTMPSZ,2,IX,1) C C DEFAULT ADD, SUBTRACT, ... C IF(IKEY.EQ.96) THEN IF(N.LE.1)GO TO 95 CALL VNMTCH('ADD ',VTEMP(SVTEMP),1,IBY) IF(IBY.NE.0) THEN IRC=30 ELSE CALL VNMTCH('SUBTRACT ',VTEMP(SVTEMP),1,IBY) IF(IBY.NE.0) THEN IRC=31 ELSE CALL VNMTCH('MULTIPLY ',VTEMP(SVTEMP),1,IBY) IF(IBY.NE.0) THEN IRC=32 ELSE CALL VNMTCH('DIVIDE ',VTEMP(SVTEMP),1,IBY) IF(IBY.NE.0) THEN IRC=33 ELSE GO TO 95 END IF END IF END IF END IF N=N-1 K=SVTEMP ELSE K=SVTEMP-1 C C IKEY=100-103 => IRC=26-29 ADD_MS, ... C IF(IKEY.GE.100.AND.IKEY.LE.103) THEN IRC=IKEY-74 C C IKEY=69-72 => IRC=30-33 ADD, SUBTRACT, ... C ELSE IF(IKEY.GE.69.AND.IKEY.LE.72) THEN IRC=IKEY-39 C C IKEY=93,94 => IRC=23,24 AND, OR C ELSE IF(IKEY.EQ.93) THEN IRC=23 ELSE IF(IKEY.EQ.94) THEN IRC=24 C C IKEY=32 => IRC=62 IDCHANGE C ELSE IF(IKEY.EQ.32) THEN IRC=62 END IF END IF C C Copy variable list to top of VTEMP array C SVTMP2=MVAR-N+1 DO 32 I=1,N VTEMP(SVTMP2+I-1)=VTEMP(K+I) 32 CONTINUE CALL VNMTCH('BY ',VTEMP(SVTMP2),N,IBY) IF(IBY.EQ.0) THEN IF(IRC.EQ.26.OR.IRC.EQ.30) THEN CALL VNMTCH('PLUS ',VTEMP(SVTMP2),N,IBY) ELSE IF(IRC.EQ.27.OR.IRC.EQ.31) THEN CALL VNMTCH('MINUS ',VTEMP(SVTMP2),N,IBY) ELSE IF(IKEY.EQ.93.OR.IKEY.EQ.94) THEN CALL VNMTCH('WITH ',VTEMP(SVTMP2),N,IBY) END IF END IF CALL VNMTCH('INTO ',VTEMP(SVTMP2),N,IINTO) IF(IRC.EQ.62) THEN IF(IINTO.NE.N-1.OR.IBY.GT.0)GO TO 95 END IF N1=IBY-1 NOUT=N1 IF(IINTO.GT.0) THEN IF(IBY.EQ.0) THEN IF(IINTO.EQ.N-1.AND.(IRC.EQ.26.OR.IRC.EQ.28.OR. . IKEY.EQ.93.OR.IKEY.EQ.94.OR.IRC.EQ.62.OR. . IRC.EQ.30.OR.IRC.EQ.32)) THEN I2=N IF(IRC.EQ.62) THEN NOUT=1 ELSE NOUT=IINTO-2 END IF IBY=1 I1INC=1 I3INC=1 ELSE WRITE(U6,210) GO TO 99 END IF ELSE IF((IINTO-IBY.EQ.2.AND.N1.NE.N-IINTO).OR. . (N1.EQ.1.AND.IINTO-IBY-1.NE.N-IINTO).OR. . (N1.NE.1.AND.IINTO-IBY.NE.2.AND. . (N1.NE.IINTO-IBY-1.OR.N1.NE.N-IINTO))) THEN WRITE(U6,210) GO TO 99 END IF IF(N1.EQ.1) THEN I1INC=0 NOUT=N-IINTO ELSE I1INC=1 END IF IF(IINTO-IBY.EQ.2) THEN I3INC=0 ELSE I3INC=1 END IF I2=IINTO+1 END IF ELSE IF(IBY.EQ.0.OR.(IBY.NE.N-1.AND.2*IBY.NE.N+1)) THEN WRITE(U6,210) GO TO 99 END IF I1INC=1 IF(IBY.EQ.N-1) THEN I3INC=0 ELSE I3INC=1 END IF I2=1 END IF IBY=IBY+1 I1=1 IF(IFLVL.GT.0.AND.IKEY.EQ.31)GO TO 96 C C NRECDL keeps track of NRECOD with RCTYPE=54-57 so that can C build up a loop with the multiplication, etc., of multiple C replicate factors or weights. C NRECDL=0 C C IV3 is variable following BY, PLUS, etc. C DO 52 I=1,NOUT IF((I.EQ.1.OR.I3INC.EQ.1).AND.IRC.NE.62) THEN CALL VNMTCH(VTEMP(IBY+SVTMP2-1),VNAME,NVIN,IV3) IF(IV3.EQ.0) THEN C C During REWEIGHT, check for variable from VPLX file. C IF(ISTEPC.EQ.2.AND.IRC.GE.30.AND.IRC.LE.33) THEN K=RCEIL(2)+1 CALL VNMTCH(VTEMP(IBY+SVTMP2-1),VNAME(K),NVREG,IV3) IF(IV3.GT.0) THEN IV3=IV3+RCEIL(2) IF(MTYPE(IV3).NE.1.AND.MTYPE(IV3).NE.11) THEN WRITE(U6,243) GO TO 99 END IF C C If NBY>0, check if need a RCTYPE=60 statement to check BY variables. C IF(IBYCHK.EQ.0.AND.NBY.GT.0) THEN K=NBY+1 CALL RINCR(4,NRECOD,K) J=NRECOD-K C C If within an IF block, need to find top in order to place BY check C there. Move intervening statements down. C IF(IFLVL.GT.0) THEN DO 44 KK=J,IF1LST,-1 V1(KK+K)=V1(KK) V2(KK+K)=V2(KK) IF(RCTYPE(KK).EQ.35.OR.RCTYPE(KK).EQ.36) THEN IF(V3(KK).GT.0) THEN V3(KK+K)=V3(KK)+K ELSE IF(V3(KK).LT.0) THEN V3(KK+K)=V3(KK)-K ELSE V3(KK+K)=0 END IF ELSE V3(KK+K)=V3(KK) END IF RSTPNT(KK+K)=RSTPNT(KK) RCTYPE(KK+K)=RCTYPE(KK) 44 CONTINUE J=IF1LST IF1LST=IF1LST+K IF(U5ECHO.GT.0)WRITE(U6,250) DO 45 KK=1,IFLVL IF(IFLAST(KK).LT.0) THEN IFLAST(KK)=IFLAST(KK)-K ELSE IF(IFLAST(KK).GT.0) THEN IFLAST(KK)=IFLAST(KK)+K END IF 45 CONTINUE ELSE IF(U5ECHO.EQ.1)WRITE(U6,249) J=J+1 END IF C C Placement of BY check C RCTYPE(J)=60 V1(J)=0 V2(J)=0 V3(J)=0 RSTPNT(J)=NBY KK=RCEIL(2)+NVREG+NCLASS+NVARID IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN KK=KK-1 END IF DO 46 K=1,NBY KK=KK+1 CALL VNMTCH(VNAME(KK),VNAME,NVIN,BYLIST(K)) J=J+1 RCTYPE(J)=0 V1(J)=BYLIST(K) V2(J)=0 V3(J)=0 RSTPNT(J)=K+NVARID IF(BYLIST(K).EQ.0) THEN WRITE(U6,248)VNAME(KK) GO TO 99 END IF 46 CONTINUE IBYCHK=1 END IF END IF END IF IF(IV3.EQ.0) THEN WRITE(U6,205)VTEMP(IBY+SVTMP2-1) GO TO 99 END IF END IF C C If CROSS, IV3 must be CLASS or CAT C IF(IKEY.EQ.31) THEN IF(MTYPE(IV3).NE.3.AND.MTYPE(IV3).NE.4) THEN WRITE(U6,211)VTEMP(IBY+SVTMP2-1) GO TO 99 END IF END IF END IF C C Insure that IV1 exists. C IF(I.EQ.1.OR.I1INC.EQ.1) THEN CALL VNMTCH(VTEMP(I1+SVTMP2-1),VNAME,NVIN,IV1) IF(IV1.EQ.0) THEN WRITE(U6,205)VTEMP(I1+SVTMP2-1) GO TO 99 END IF END IF C C IV2 is target. C CALL VNMTCH(VTEMP(I2+SVTMP2-1),VNAME,NVIN,IV2) IV2NEW=0 IF(IV2.EQ.0) THEN CALL RINCR(2,NVIN,1) VNAME(NVIN)=VTEMP(I2+SVTMP2-1) LABEL(NVIN)(1:12)=VNAME(NVIN) LABEL(NVIN)(13:24)=' ' IV2=NVIN CALL RFCHCK(1) IF(IFLVL.GT.0)IVZERO=1 NRECDL=0 IV2NEW=1 ELSE IF(MTYPE(IV2).GE.50) THEN IF(IV3.GT.NVIN) THEN C C MULTIPLYING, etc. weight or replicate weight by factor from vplx C file. C C Make sure variables match. Thus, C multiply repw1 by factor into repw2 C is not allowed. C IF(IV1.NE.IV2) THEN WRITE(U6,237) GO TO 99 END IF C C If NRECDL > 0, see if can add this case to the loop. If so, C complete with this case and transfer to 515 to increment IV1, C etc. C IF(NRECDL.GT.0) THEN IF(MTYPE(V1(NRECDL))+V2(NRECDL).EQ.MTYPE(IV1)) THEN V2(NRECDL)=V2(NRECDL)+1 GO TO 515 END IF END IF C C If NRECDL=0 to here, set it to NRECOD here to start potential loop C CALL RINCR(4,NRECOD,1) NRECDL=NRECOD V1(NRECOD)=IV1 V2(NRECOD)=1 V3(NRECOD)=IV3 ELSE IF(I.GT.1.AND.IRC.GE.30.AND.IRC.LE.33.AND.IV1.EQ.IV2) . THEN C C MULTIPLYING, etc. a weight or replicate weight by a regular variable C Check to see if should set up loop, IRC=43,...46 in place of C IRC=30,33. If so, skip to 515 to avoid incrementing NRECOD. C NRECDL=0 IF(V3(NRECOD).EQ.IV3) THEN IF(RCTYPE(NRECOD).GE.30.AND.RCTYPE(NRECOD).LE.33) THEN IF(V1(NRECOD).EQ.V2(NRECOD).AND. . MTYPE(V1(NRECOD))+1.EQ.MTYPE(IV1)) THEN RCTYPE(NRECOD)=RCTYPE(NRECOD)+13 V2(NRECOD)=2 GO TO 515 END IF ELSE IF(RCTYPE(NRECOD).GE.43.AND.RCTYPE(NRECOD).LE.46) THEN IF(MTYPE(V1(NRECOD))+V2(NRECOD).EQ.MTYPE(IV1)) THEN V2(NRECOD)=V2(NRECOD)+1 GO TO 515 END IF END IF END IF ELSE NRECDL=0 END IF END IF C C IDCHANGE C IF(IRC.EQ.62) THEN MTYPE(IV2)=1 MSIZE(IV2)=1 K=N-1 CALL RINCR(4,NRECOD,K) K=K-1 RCTYPE(NRECOD-K)=62 V1(NRECOD-K)=0 V2(NRECOD-K)=IV2 V3(NRECOD-K)=0 RSTPNT(NRECOD-K)=K NXPTDS=NXPTD CALL ROOMD(K) DO 47 KK=1,K CALL VNMTCH(VTEMP(KK+SVTMP2-1),VNAME,NVIN,IV1) IF(IV1.EQ.0) THEN WRITE(U6,205)VTEMP(KK+SVTMP2-1) GO TO 99 END IF IF(MTYPE(IV1).NE.1)GO TO 95 DX(NXPTDS)=-98765.432109D0 RCTYPE(NRECOD-K+KK)=0 V1(NRECOD-K+KK)=0 V2(NRECOD-K+KK)=IV1 V3(NRECOD-K+KK)=NXPTDS RSTPNT(NRECOD-K+KK)=IV1 NXPTDS=NXPTDS+1 47 CONTINUE GO TO 53 END IF IF(NRECDL.EQ.0) THEN CALL RINCR(4,NRECOD,1) END IF IF(IKEY.EQ.31) THEN LPIV1=LPOINT(IV1) LPOINT(IV2)=NLEVEL+1 IF(MTYPE(IV1).EQ.1.OR.MTYPE(IV1).EQ.2.OR.MTYPE(IV1).EQ.8.OR. . MTYPE(IV1).GE.50) THEN IRC=8 ELSE IF(MTYPE(IV1).EQ.3.OR.MTYPE(IV1).EQ.4.OR. . MTYPE(IV1).EQ.9) THEN IRC=9 ELSE WRITE(U6,212)VTEMP(IV1+SVTMP2-1) GO TO 99 END IF ICDIV1=CDMPNT(IV1) CDMPNT(IV2)=NCRSSD+1 IF(MTYPE(IV1).EQ.8.OR.MTYPE(IV1).EQ.9) THEN CALL RINCR(10,NCRSSD,1) CROSSD(NCRSSD)=CROSSD(ICDIV1)+1 L=0 K=ICDIV1+CROSSD(ICDIV1)+1 K=CROSSD(K) DO 48 J=1,CROSSD(ICDIV1) CALL RINCR(10,NCRSSD,1) CROSSD(NCRSSD)=CROSSD(ICDIV1+J) L=L+CROSSD(NCRSSD)+1 VTEMP(SVTEMP+J-1)=VTEMP(K) K=K+1 48 CONTINUE KS=SVTEMP+CROSSD(ICDIV1) CALL RINCR(10,NCRSSD,1) K=LPIV1 DO 49 J=1,L CALL RINCR(7,NLEVEL,1) LEVEL(NLEVEL)=LEVEL(K) K=K+1 49 CONTINUE ELSE CROSSD(NCRSSD+1)=2 CALL RINCR(7,NLEVEL,1) LEVEL(NLEVEL)=LABEL(IV1) IF(MTYPE(IV1).EQ.1.OR.MTYPE(IV1).EQ.2) THEN CROSSD(NCRSSD+2)=0 ELSE CROSSD(NCRSSD+2)=MSIZE(IV1) K=LPIV1 DO 50 J=1,MSIZE(IV1) CALL RINCR(7,NLEVEL,1) LEVEL(NLEVEL)=LEVEL(K) K=K+1 50 CONTINUE END IF CALL RINCR(10,NCRSSD,3) VTEMP(SVTEMP)=VNAME(IV1) KS=SVTEMP+1 END IF CROSSD(NCRSSD)=MSIZE(IV3) CALL RINCR(10,NCRSSD,1) CROSSD(NCRSSD)=SVTEMP VTEMP(KS)=VNAME(IV3) SVTEMP=KS+1 CALL RCHECK(13,KS,1) CALL RINCR(7,NLEVEL,1) LEVEL(NLEVEL)=LABEL(IV3) K=LPOINT(IV3) DO 51 J=1,MSIZE(IV3) CALL RINCR(7,NLEVEL,1) LEVEL(NLEVEL)=LEVEL(K) K=K+1 51 CONTINUE IF(IRC.EQ.9.OR.MTYPE(IV1).EQ.8.OR.MTYPE(IV1).EQ.2) THEN MSIZE(IV2)=MSIZE(IV1)*MSIZE(IV3) ELSE MSIZE(IV2)=2*MSIZE(IV3) END IF IF(MTYPE(IV1).EQ.3.OR.MTYPE(IV1).EQ.9) THEN MTYPE(IV2)=9 ELSE MTYPE(IV2)=8 END IF ELSE IF((MTYPE(IV1).NE.1.AND.MTYPE(IV1).NE.2.AND.MTYPE(IV1).NE.8 . .AND.MTYPE(IV1).LT.50).OR. . (MTYPE(IV3).NE.1.AND.MTYPE(IV3).NE.2.AND.MTYPE(IV3).NE.8 . .AND.MTYPE(IV3).LT.50.AND.IV3.LE.NVIN)) THEN WRITE(U6,222) GO TO 99 END IF IF(NRECDL.EQ.0) THEN MTSAVE=MTYPE(IV2) IF((IRC.NE.29.AND.(MTYPE(IV1).EQ.1.OR.MTYPE(IV1).GE.50).AND. . (IV3.GT.NVIN.OR.MTYPE(IV3).EQ.1.OR.MTYPE(IV3).GE.50)).OR. . IKEY.EQ.93.OR.IKEY.EQ.94.OR.(IRC.GE.30.AND.IRC.LE.33)) . THEN MSIZE(IV2)=1 IF(MTYPE(IV2).LT.50)MTYPE(IV2)=1 ELSE IF(MTYPE(IV1).EQ.8) THEN IF(MTYPE(IV2).GE.50)GO TO 98 MTYPE(IV2)=8 MSIZE(IV2)=MSIZE(IV1) CDMPNT(IV2)=CDMPNT(IV1) LPOINT(IV2)=LPOINT(IV1) ELSE IF(MTYPE(IV2).GE.50)GO TO 98 MSIZE(IV2)=2 MTYPE(IV2)=2 END IF IF(IFLVL.GT.0.AND.MTSAVE.NE.MTYPE(IV2).AND.MTSAVE.LT.50. . .AND.MTYPE(IV2).LT.50) THEN IF(IV2NEW.EQ.1) THEN IF(MTYPE(IV2).EQ.2) THEN MTSTRT(IV2)=2 ELSE GO TO 96 END IF END IF END IF END IF END IF IF(MXSIZE(IV2).LT.MSIZE(IV2))MXSIZE(IV2)=MSIZE(IV2) IF(NRECDL.EQ.0) THEN V1(NRECOD)=IV1 V2(NRECOD)=IV2 V3(NRECOD)=IV3 END IF IF(IV3.LE.NVIN) THEN RCTYPE(NRECOD)=IRC RSTPNT(NRECOD)=0 ELSE K=MXSIZE(IV3) IF(NRECDL.EQ.0) THEN RCTYPE(NRECOD)=IRC+20 ELSE RCTYPE(NRECOD)=IRC+24 END IF RSTPNT(NRECOD)=BLNCLS(K) IF(BLNCLS(K).GT.0) THEN INCX=BLXINC(K) ICLBAR=BLCPNT(K) DO 513 J=1,BLNCLS(K) CALL RINCR(4,NRECOD,1) RCTYPE(NRECOD)=0 V2(NRECOD)=0 IC=CLPNT(ICLBAR)+RCEIL(2) CALL VNMTCH(VNAME(IC),VNAME,NVIN,JJ) IF(JJ.EQ.0) THEN WRITE(U6,244)VNAME(IC) GO TO 99 ELSE IF(MTYPE(JJ).NE.3.AND.MTYPE(JJ).NE.4) THEN WRITE(U6,245)VNAME(JJ) GO TO 99 ELSE IF(MSIZE(JJ).NE.MSIZE(IC)) THEN WRITE(U6,246)VNAME(JJ) GO TO 99 END IF V1(NRECOD)=JJ RSTPNT(NRECOD)=INCX IF(CLTYPE(ICLBAR).EQ.1) THEN V3(NRECOD)=0 INCX=INCX*MSIZE(JJ) ELSE V3(NRECOD)=1 INCX=INCX*(MSIZE(JJ)+1) END IF ICLBAR=ICLBAR+1 513 CONTINUE END IF END IF 515 CONTINUE IF(I2.EQ.N) THEN IF(I.EQ.1) THEN I1=I2 END IF ELSE I2=I2+1 I1=I1+I1INC END IF IBY=IBY+I3INC 52 CONTINUE 53 CONTINUE VTMPSZ=MVAR+1-SVTEMP RETURN 95 CONTINUE WRITE(U6,200) GO TO 99 96 CONTINUE WRITE(U6,233) GO TO 99 98 CONTINUE WRITE(U6,237) 99 CONTINUE CALL FSTOP END C SUBROUTINE RFADD(VARRAY,NVA,MAXVA,INPTFL,IXM,ISTATE) PARAMETER (IXDIM=13) IMPLICIT DOUBLE PRECISION (A-H,O-Z) C INTEGER NVA,MAXVA,INPTFL,IXM(IXDIM,ISTATE) CHARACTER*12 VARRAY(MAXVA) C C VARRAY - list of variable names. C NVA - length of list, updated by routine C MAXVA - maximum allowed length of list C INPTFL - 1 if list from INPUT statement, C 2 other applications. C C RFADD inspects the list in VARRAY for REPW, REPF, REPW# and REPF# C REPW and REPF are expanded, if possible. C Instructions are issued in RCTYPE etc. to generate the REPW, etc., C if necessary and revises NRECOD in this case. C PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (MIFLVL=7,IXFLLD=15-MIFLVL) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1, . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX C DOUBLE PRECISION RANGE(2,MRANGE) INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET), . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD), . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI) C COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP, . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO, . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS, . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT, . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS, . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO, . NLEVEL,NRNSET,NRANGE,NHADAM,ISTEPC,IFLVL,IF1LST,IFLAST,NEWSYN, . IXFILL INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS, . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN, . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IFLAST(MIFLVL), . IXFILL(IXFLLD) C 101 FORMAT('REPF',I1,7X) 102 FORMAT('REPF',I2,6X) 103 FORMAT('REPF',I3,5X) 104 FORMAT('REPF',I4,4X) 105 FORMAT('REPF',I5,3X) 201 FORMAT(/,5X,'Implicit: ',A12,'- ',A12,/) 202 FORMAT(' UNMATCHED ID: ',A12) 203 FORMAT(' CANNOT EXPAND REPF/W') 204 FORMAT(/,5X,'WARNING: GENERATION MOVED TO START OF LEVEL 1 IF BLOC .K') 205 FORMAT(/,5X,'WARNING: NO WEIGHT VAR') C IV=1 NRECSV=NRECOD 1 CONTINUE C C Check for a name beginning REPF or REPW, else loop to the C next variable name in the list. C IVALUE=0 CALL CMATCH(VARRAY(IV),1,12,'REPF',4,IPOS,2) IF(IPOS.GT.0) THEN IRT=1 ELSE CALL CMATCH(VARRAY(IV),1,12,'REPW',4,IPOS,2) IF(IPOS.GT.0) THEN IRT=2 ELSE GO TO 50 C ! Transfer to 50 increments IV and END IF C ! loops back to 1 if not done. END IF C C IRT = 1 REPF C = 2 REPW C = 3 REPF* where * is a number C = 4 REPW* where * is a number C IF(VARRAY(IV)(5:5).NE.' ') THEN IRT=IRT+2 CALL IFIND(VARRAY(IV)(5:12),5,12,IPOS,IVALUE) IF(IPOS.EQ.0) GO TO 50 IF(IPOS.LE.12) THEN IF(VARRAY(IV)(IPOS:IPOS).NE.' ')GO TO 50 END IF END IF C C Check for inconsistency with earlier specifications. C IF((IRT.EQ.1.OR.IRT.EQ.3).AND.IREPW.EQ.1.OR. . ((IRT.EQ.2.OR.IRT.EQ.4).AND.IREPF.EQ.1)) THEN IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=30302 RETURN ELSE CALL FESTOP(30302) END IF END IF C C We need to determine two numbers: C 1) the number of variables, NRPINC, to insert into the C variable list, generated on the basis of REPF or REPW C 2) the number of variables, NRPADD, that are generated by C a HADAMARD statement, or through the replicate C generation feature of REWEIGHT for the jackknife. C C For REPF or REPW, determine the number of replicates, NRPINC, C to include and adjust the list of variables accordingly. C In the CREATE step, add the replicates only if a COEFFICIENTS C statement indicates how many, or on the basis of HADAMARD C C Change 8/20/97 for REPGEN, CONVERT - NDCOEF consulted for C NRPINC instead of NDCOEF C NRPINC=0 IF(IRT.LE.2) THEN IF(ISTEPC.EQ.2) THEN NRPINC=NRPTOT C ! REWEIGHT ELSE NRPINC=NDCOEF C ! CREATE, REPGEN C C Change 8/20/97 in effect of NHADAM - now limited to CREATE, REPGEN C C IF(NHADAM.GT.NRPINC) THEN C NRPINC=NHADAM C END IF C IF(NRPINC.EQ.0) THEN NRPINC=NHADAM END IF END IF C C Not knowing how many variables to insert is a fatal flaw. C IF(NRPINC.EQ.0) THEN IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=30300 RETURN ELSE CALL FESTOP(30300) END IF END IF IF(NVA+NRPINC-1.GT.MAXVA) THEN C ! Resource check IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=30301 RETURN ELSE CALL FESTOP(30301) END IF C C For now, move other variables in VARRAY down to make space for C the inserted variables. C ELSE IF(IV.LT.NVA) THEN J=NVA JJ=J+NRPINC-1 DO 3 IV2=IV+1,NVA VARRAY(JJ)=VARRAY(J) JJ=JJ-1 J=J-1 3 CONTINUE END IF END IF C C Now determine if new variables will be generated at this point C C Generate REPF/W based on Hadamard matrix if not previously C done, if reference is to repf, repw, or a repf* or repw* where C * is a number less than or equal to the size of the Hadamard C matrix. C NRPADD=0 IHG=0 IF(NHADAM.GT.0) THEN C C Earlier version of 8/20/97 This code checks whether C a previous instruction has generated the hadamard matrix. C C IF(IVALUE.LE.NHADAM) THEN C IHG=1 C IF(NRECOD.GT.0) THEN C DO 4 I=1,NRECOD C IF(RCTYPE(I).EQ.61)IHG=0 C 4 CONTINUE C END IF C END IF C C In the revised version, generate matrix only if no values have C been provided in the range for repw, repf C IF(IVALUE.LE.NHADAM) THEN IHG=1 IF(NVIN.GT.0) THEN DO 4 I=1,NVIN IF(MTYPE(I).GE.51.AND.MTYPE(I).LE.50+NHADAM)IHG=0 4 CONTINUE END IF END IF C IF(IHG.EQ.1) THEN NRPADD=NHADAM CALL RINCR(2,NVIN,1) NVIN1=NVIN C ! Save start of added NVIN=NVIN-1 C ! variables CALL RINCR(4,NRECOD,1) RCTYPE(NRECOD)=61 V3(NRECOD)=0 IF(IRT.EQ.2.OR.IRT.EQ.4) THEN C ! For replicate weights, IF(IWGT.NE.0) THEN C ! use declared weight V3(NRECOD)=IWGT C ! variable or WEIGHT ELSE IF(NOWGTF.EQ.0) THEN CALL VNMTCH('WEIGHT ',VNAME,NVIN,V3(NRECOD)) IF(V3(NRECOD).EQ.0) THEN IF(U5ECHO.GT.0)WRITE(U6,205) END IF END IF END IF V1(NRECOD)=NVIN+1 V2(NRECOD)=NHADAM NRECS1=NRECOD RSTPNT(NRECOD)=0 C C Search for pairs of variables ROW# COEF# C DO 5 I=1,NVIN CALL CMATCH(VNAME(I),1,12,'ROW',3,IPOS,2) IF(IPOS.GT.0) THEN IF(VNAME(I)(4:4).NE.' ') THEN CALL IFIND(VNAME(I)(4:12),4,12,IPOS,IVALUE) IF(IPOS.EQ.0) GO TO 5 IF(IPOS.LE.12) THEN IF(VNAME(I)(IPOS:IPOS).NE.' ')GO TO 5 END IF CALL RINCR(4,NRECOD,1) V1(NRECOD)=I V3(NRECOD)=0 RCTYPE(NRECOD)=0 RSTPNT(NRECOD)=0 IF(IVALUE.LE.9) THEN WRITE(VNAME(NVIN1),101)IVALUE ELSE IF(IVALUE.LE.99) THEN WRITE(VNAME(NVIN1),102)IVALUE ELSE IF(IVALUE.LE.999) THEN WRITE(VNAME(NVIN1),103)IVALUE ELSE IF(IVALUE.LE.9999) THEN WRITE(VNAME(NVIN1),104)IVALUE ELSE IF(IVALUE.LE.99999) THEN WRITE(VNAME(NVIN1),105)IVALUE ELSE IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=30303 RETURN ELSE CALL FESTOP(30303) END IF END IF VNAME(NVIN1)(1:4)='COEF' CALL VNMTCH(VNAME(NVIN1),VNAME,NVIN,V2(NRECOD)) END IF END IF 5 CONTINUE IF(NRECOD.EQ.NRECS1) THEN IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=30304 RETURN ELSE CALL FESTOP(30304) END IF ELSE RSTPNT(NRECS1)=NRECOD-NRECS1 C ! Number of pairs END IF END IF C C For REWEIGHT, set up pointers to create replicate factors for C jackknife methods. C ELSE IF(ISTEPC.EQ.2) THEN IF(IREPW.EQ.0.AND.IREPF.EQ.0.AND. . (VFTYPE.LT.5.OR.VFTYPE.GT.12)) THEN NRPADD=NRPTOT CALL RINCR(4,NRECOD,1) RCTYPE(NRECOD)=58 V3(NRECOD)=0 IF(IRT.EQ.2.OR.IRT.EQ.4) THEN C ! If appropriate, IF(MOD(VFTYPE,2).EQ.1) THEN C ! search for matching K=RCEIL(2)+NVREG+NCLASS+NID+1 C ! weight variable IF(VFTYPE.GE.5.AND.VFTYPE.LE.12)K=K-1 CALL VNMTCH(VNAME(K),VNAME,NVIN,V3(NRECOD)) IF(V3(NRECOD).EQ.0) THEN WRITE(U6,202)VNAME(K) IF(U5.GE.13.AND.U5.LE.17) THEN C ! Error return if IMERR1=30305 C ! weight not matched RETURN ELSE CALL FESTOP(30305) END IF END IF END IF END IF V1(NRECOD)=NVIN+1 V2(NRECOD)=NRPADD RSTPNT(NRECOD)=NVARID DO 10 I=1,NVARID CALL RINCR(4,NRECOD,1) RCTYPE(NRECOD)=0 V2(NRECOD)=0 V3(NRECOD)=0 RSTPNT(NRECOD)=0 K=RCEIL(2)+NVREG+NCLASS+I CALL VNMTCH(VNAME(K),VNAME,NVIN,V1(NRECOD)) IF(V1(NRECOD).EQ.0) THEN WRITE(U6,202)VNAME(K) IF(U5.GE.13.AND.U5.LE.17) THEN C ! Error return if IMERR1=30306 C ! variance identifier RETURN C ! not matched ELSE CALL FESTOP(30306) END IF CALL FSTOP END IF 10 CONTINUE END IF END IF C C Now, insert the implied number of replicate factors or weights C into the variable list. C IF(NRPINC.GT.NRPADD) THEN NRPMAX=NRPINC ELSE NRPMAX=NRPADD END IF IF(NRPMAX.GT.0) THEN J=IV DO 20 I=1,NRPMAX C C Except for INPUT, we add the first NRPADD variables to the overall C list of variables C IF(I.LE.NRPADD.AND.INPTFL.EQ.2) THEN CALL RINCR(2,NVIN,1) MTYPE(NVIN)=50+I IF(I.LE.9) THEN WRITE(VNAME(NVIN),101)I ELSE IF(I.LE.99) THEN WRITE(VNAME(NVIN),102)I ELSE IF(I.LE.999) THEN WRITE(VNAME(NVIN),103)I ELSE IF(I.LE.9999) THEN WRITE(VNAME(NVIN),104)I ELSE IF(I.LE.99999) THEN WRITE(VNAME(NVIN),105)I ELSE CALL FSTOP END IF IF(IRT.EQ.2.OR.IRT.EQ.4) THEN VNAME(NVIN)(4:4)='W' END IF LABEL(NVIN)(1:12)=VNAME(NVIN) LABEL(NVIN)(13:24)=' ' END IF C C We now include the first NRPINC variables on the list. C IF(I.LE.NRPINC.AND.IRT.LE.2) THEN IF(I.LE.9) THEN WRITE(VARRAY(J),101)I ELSE IF(I.LE.99) THEN WRITE(VARRAY(J),102)I ELSE IF(I.LE.999) THEN WRITE(VARRAY(J),103)I ELSE IF(I.LE.9999) THEN WRITE(VARRAY(J),104)I ELSE IF(I.LE.99999) THEN WRITE(VARRAY(J),105)I ELSE CALL FSTOP END IF IF(IRT.EQ.2) THEN VARRAY(J)(4:4)='W' END IF END IF J=J+1 20 CONTINUE C C Reposition added instructions if within an IF block, except for INPUT C IF(NRPADD.GT.0) THEN IF(U5.LT.13.OR.U5.GT.17) THEN IF(U5ECHO.EQ.1)WRITE(U6,201)VNAME(NVIN-NRPADD+1),VNAME(NVIN) IF(IFLVL.GT.0.AND.INPTFL.EQ.2) THEN IF(U5ECHO.GT.0)WRITE(U6,204) J=NRECOD-NRECSV CALL RINCR(4,NRECOD,J) C ! Confirm temporary NRECOD=NRECOD-J C ! space DO 22 I=1,J RCTYPE(NRECOD+I)=RCTYPE(NRECSV+I) C ! Move the new commands V1(NRECOD+I)=V1(NRECSV+I) C ! into the temporary V2(NRECOD+I)=V2(NRECSV+I) C ! space V3(NRECOD+I)=V3(NRECSV+I) RSTPNT(NRECOD+I)=RSTPNT(NRECSV+I) 22 CONTINUE DO 24 I=NRECSV,IF1LST,-1 C ! Shift other RCTYPE(I+J)=RCTYPE(I) C ! commands up V1(I+J)=V1(I) V2(I+J)=V2(I) IF(RCTYPE(I).EQ.35.OR.RCTYPE(I).EQ.36) THEN IF(V3(I).GT.0) THEN V3(I+J)=V3(I)+J C ! Adjust pointers for ELSE IF(V3(I).LT.0) THEN C ! if statements V3(I+J)=V3(I)-J ELSE V3(I+J)=0 END IF ELSE V3(I+J)=V3(I) END IF RSTPNT(I+J)=RSTPNT(I) 24 CONTINUE DO 26 I=1,J RCTYPE(IF1LST+I-1)=RCTYPE(NRECOD+I) V1(IF1LST+I-1)=V1(NRECOD+I) C ! Move new instructions V2(IF1LST+I-1)=V2(NRECOD+I) C ! into place V3(IF1LST+I-1)=V3(NRECOD+I) RSTPNT(IF1LST+I-1)=RSTPNT(NRECOD+I) 26 CONTINUE DO 28 I=1,IFLVL IF(IFLAST(I).LT.0) THEN IFLAST(I)=IFLAST(I)-J C ! Adjust IFLAST array ELSE IF(IFLAST(I).GT.0) THEN IFLAST(I)=IFLAST(I)+J END IF 28 CONTINUE END IF ELSE IF(ISTATE.GT.0) THEN IF(IXM(6,ISTATE).GT.0.AND.INPTFL.EQ.2) THEN J=NRECOD-NRECSV CALL RINCR(4,NRECOD,J) C ! Confirm temporary NRECOD=NRECOD-J C ! space DO 32 I=1,J RCTYPE(NRECOD+I)=RCTYPE(NRECSV+I) C ! Move the new commands V1(NRECOD+I)=V1(NRECSV+I) C ! into the temporary V2(NRECOD+I)=V2(NRECSV+I) C ! space V3(NRECOD+I)=V3(NRECSV+I) RSTPNT(NRECOD+I)=RSTPNT(NRECSV+I) 32 CONTINUE DO 33 I=ISTATE,1,-1 IF(IXM(6,I).EQ.0) THEN C ! Find preceding GO TO 34 C ! statement at IF END IF C ! level 0 33 CONTINUE I=1 C ! (Not expected) 34 CONTINUE IF1LST=I IF1LSN=IXM(10,IF1LST) C ! Start of matching C ! recode DO 36 I=NRECSV,IF1LSN,-1 C ! Shift other RCTYPE(I+J)=RCTYPE(I) C ! commands up V1(I+J)=V1(I) V2(I+J)=V2(I) IF(RCTYPE(I).EQ.36.OR.RCTYPE(I).EQ.109) THEN IF(V3(I).GT.0) THEN V3(I+J)=V3(I)+J C ! Adjust pointers for ELSE C ! if statements V3(I+J)=0 END IF ELSE V3(I+J)=V3(I) END IF RSTPNT(I+J)=RSTPNT(I) 36 CONTINUE DO 38 I=1,J RCTYPE(IF1LSN+I-1)=RCTYPE(NRECOD+I) V1(IF1LSN+I-1)=V1(NRECOD+I) C ! Move new instructions V2(IF1LSN+I-1)=V2(NRECOD+I) C ! into place V3(IF1LSN+I-1)=V3(NRECOD+I) RSTPNT(IF1LSN+I-1)=RSTPNT(NRECOD+I) 38 CONTINUE DO 39 I=IF1LST,ISTATE IF(IXM(5,I).GE.5.AND.IXM(5,I).LE.7) THEN IF(IXM(10,I).GT.0) THEN IXM(10,I)=IXM(10,I)+J END IF IF(IXM(11,I).GT.0) THEN IXM(11,I)=IXM(11,I)+J END IF END IF 39 CONTINUE END IF END IF END IF C IF(NRPINC.GT.0) THEN IV=IV+NRPINC-1 NVA=NVA+NRPINC-1 END IF END IF IF(IRT.EQ.1.OR.IRT.EQ.3) THEN IREPF=1 ELSE IF(IRT.EQ.2.OR.IRT.EQ.4) THEN IREPW=1 END IF 50 CONTINUE IV=IV+1 IF(IV.LE.NVA) GO TO 1 90 CONTINUE RETURN END C SUBROUTINE RFCHCK(IFLAG) C C Subroutine checks whether VNAME(NVIN) is a replicate factor or C weight and resets MTYPE accordingly. C C If IFLAG=1, it performs checks for redundant specifications. C IFLAG=2, set MTYPE(NVIN) only C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MAXIDS=10) PARAMETER (MIFLVL=7,IXFLLD=15-MIFLVL) C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP, . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO, . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS, . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT, . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS, . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO, . NLEVEL,NRNSET,NRANGE,NHADAM,ISTEPC,IFLVL,IF1LST,IFLAST,NEWSYN, . IXFILL INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS, . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN, . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IFLAST(MIFLVL), . IXFILL(IXFLLD) C C C RFCHCK determines if any new variable is a replicate factor or C weight. C It sets MTYPE and checks for previous duplication C CALL CMATCH(VNAME(NVIN),1,12,'REPF',4,IPOS,2) IF(IPOS.GT.0) THEN IRT=1 ELSE CALL CMATCH(VNAME(NVIN),1,12,'REPW',4,IPOS,2) IF(IPOS.GT.0) THEN IRT=2 ELSE GO TO 90 END IF END IF C C IRT = 1 REPF* C = 2 REPW* C CALL IFIND(VNAME(NVIN)(5:12),5,12,IPOS,IVALUE) IF(IPOS.EQ.0) GO TO 90 IF(IPOS.LE.12) THEN IF(VNAME(NVIN)(IPOS:IPOS).NE.' ')GO TO 90 END IF IF((IRT.EQ.1.AND.IREPW.GT.0).OR. . (IRT.EQ.2.AND.IREPF.GT.0)) THEN IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=30310 RETURN ELSE CALL FESTOP(30310) END IF ELSE IF(IRT.EQ.1) THEN C ! REPF* IF(IVALUE.EQ.0) THEN C ! REPF0 - set IREPF IREPF=2 ELSE IF(IREPF.EQ.0) THEN IREPF=1 END IF MTYPE(NVIN)=50+IVALUE ELSE IF(IVALUE.EQ.0) THEN C ! REPW0 - accept as IF(IWGT.GT.0.AND.IFLAG.EQ.1) THEN C ! weight only if no IF(U5.GE.13.AND.U5.LE.17) THEN C ! conflict IMERR1=30311 RETURN ELSE CALL FESTOP(30311) END IF ELSE IF(IFLAG.EQ.1) THEN IWGT=NVIN END IF C ! Do not change type of C MTYPE(NVIN)=50 ! REPW0 ELSE MTYPE(NVIN)=50+IVALUE IREPW=1 END IF END IF IF(NVIN.GT.1.AND.IFLAG.EQ.1) THEN DO 1 I=1,NVIN-1 IF(MTYPE(I).EQ.50+IVALUE) THEN IF(U5.GE.13.AND.U5.LE.17) THEN IMERR1=30312 RETURN ELSE CALL FESTOP(30312) END IF END IF 1 CONTINUE END IF 90 CONTINUE RETURN END C SUBROUTINE PREAMC IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C LOGICAL ENDFLE C 200 FORMAT(' ERROR IN SPECIFICATION') 201 FORMAT(' ERROR ON INCOMING FILE') 298 FORMAT(' LOGICAL ERROR') READ(10)IVERSN IF(IVERSN.NE.9004.AND.IVERSN.NE.9203)STOP READ(10)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE, . VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR CALL RCHECK(2,NVTOT,0) NID=NVARID+NBY IF(IVERSN.EQ.9004)NIDTOT=NID C C NVTOT - total number of variables on file C NVREG - number of variables, excluding class, variance id's, C BY variables, and weight variable C NCLASS - total number of class variables C NVARID - number of variance id's, excluding BY variables C NBY - number of BY variables C NWGT - 0 or 1 indicating unweighted vs. weighted analysis C TYPE - type of input used to create the file C VROPTN - variance option C TSIZE - total size of matrix C NCLBLK - total number of class blocks C NCLBAR - total size of class block information arrays C C TYPE = 3 Weighted obs. with cluster/replicate number C 4 Unweighted " C 5 Replicate weights C 6 Unweighted initial obs. followed by replicate weights C 7 Replicate factors multiplying initial weight C 8 Replicate factors of unweighted initial obs ( = TYPE 6) C 11 Replicate factors multiplying initial weight, including C factor for replicate 0, overall estimate C 12 Unweighted initial obs " (= TYPE 5) C 13 Weighted obs. with cluster code C 14 Unweighted " C 15 Weighted obs. Stratum no. cluster code C 16 Unweighted " C 17 Wtd. Stratum code, cluster code C 18 Unwtd " C 21 Wtd. Stratum no. 2nd stage no, cluster code C 22 Unwtd. " C 23 Wtd. Stratum no. 2nd stage cd, cluster code C 24 Unwtd. " C 25 Wtd. Stratum code 2nd stage no. cluster code C 26 Unwtd " C 27 Wtd. Stratum code 2nd stage cd, cluster code C 28 Unwtd. " C 29 Wtd 2nd stage number cluster code C 30 Unwtd. " C 31 Wtd 2nd stage code cluster code C 32 Unwtd " C 33 Wtd Replicate number governed by stratum counts C 34 Unwtd " C 35 Wtd Rep numb govrned by stratum and 2nd stage counts C 36 Unwtd " C 37 Wtd Rep number governed by 2nd stage counts C 38 Unwtd " C CALL RCHECK(8,NCLBLK,0) CALL RCHECK(9,NCLBAR,0) DO 1 I=1,NCLBLK READ(10)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I), . BLVSIZ(I),BLNCLS(I),BLCPNT(I) 1 CONTINUE IF(NCLBAR.GT.0) THEN CALL INTIN(10,CLTYPE,NCLBAR,ENDFLE) CALL INTIN(10,CLPNT,NCLBAR,ENDFLE) END IF C C BLTYPE - 1 or 0 indicating row of (weighted) n vs. no row C BLXSTR - pointer to first cell of incoming data in X matrix C BLXINC - length of the X matrix for a single combination C of the class variables in the block C BLXSIZ - total size of block data in X matrix (integer multiple C of BLXINC) C BLVSTR - pointer to first variable C BLVSIZ - number of variables in block C BLNCLS - number of class variables in block C BLCPNT - pointer for class information C CLTYPE - type of class in array C CLPNT - pointer to class variables C RCEIL(2)=MVAR-NVTOT I=RCEIL(2)+1 IF(NVTOT.GT.0) THEN CALL INTIN(10,MTYPE(I),NVTOT,ENDFLE) C C Variable types are read into MTYPE C C Contents of MTYPE C 1 = real variable (total) C 2 = real variable with missing checks C 3 = categorical variable C 4 = class variable, known dimension C 5 = by variable, known dimension C 6 = by variable, unknown dimension C 7 = select transformation (not variable type) C 8 = cross variable, real value C 9 = cross variable, categorical C 11 = derived variable C 13 = crossed derived variable, single dimension C 19 = crossed derived variable C CALL INTIN(10,MSIZE(I),NVTOT,ENDFLE) END IF C C Sizes are read into MSIZE C IF(NVREG.GT.0) THEN CALL INTIN(10,VMAPL(I),NVREG,ENDFLE) END IF C C VMAPL contains pointers to the first NVREG variables C READ(10)NCRSSD CALL RCHECK(10,NCRSSD,0) RCEIL(10)=RCEIL(10)-NCRSSD ILC=RCEIL(10)+1 IF(NCRSSD.GT.0)CALL INTIN(10,CROSSD(ILC),NCRSSD,ENDFLE) C C Create an array of pointers, CDMPNT, from the variables to C the starting entries in CROSSD C DO 3 I=RCEIL(2)+1,MVAR J=MTYPE(I) IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN CDMPNT(I)=ILC ILC=CROSSD(ILC)+ILC+2 ELSE CDMPNT(I)=0 END IF 3 CONTINUE IF(MCRSSD+1.NE.ILC) THEN WRITE(U6,201) GO TO 99 END IF ILC=0 C C Read variable names and labels, and create an array of pointers, C LPOINT, to labels for the levels of the variables C DO 6 I=RCEIL(2)+1,MVAR READ(10)VNAME(I),LABEL(I) J=MTYPE(I) IF(J.EQ.3.OR.J.EQ.4.OR.J.EQ.5.OR.J.EQ.13) THEN LPOINT(I)=ILC+1 ILC=ILC+MSIZE(I) ELSE IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN LPOINT(I)=ILC+1 K=CDMPNT(I) L=CROSSD(K) DO 4 M=1,L K=K+1 ILC=ILC+CROSSD(K)+1 4 CONTINUE ELSE LPOINT(I)=0 END IF 6 CONTINUE C C Read in labels for the levels C READ(10)NCRVL CALL RCHECK(7,NCRVL,0) IF(ILC.NE.NCRVL) THEN WRITE(U6,201) GO TO 99 END IF RCEIL(7)=RCEIL(7)-ILC IF(ILC.GT.0) THEN DO 8 I=RCEIL(2)+1,MVAR IF(LPOINT(I).GT.0)LPOINT(I)=LPOINT(I)+RCEIL(7) 8 CONTINUE DO 10 I=RCEIL(7)+1,MLEVEL READ(10)LEVEL(I) 10 CONTINUE END IF READ(10)ILC C C Read in variable names for crossed variables C CALL RCHECK(13,ILC,0) SVTEMP=ILC+1 DO 12 I=1,ILC READ(10)VTEMP(I) 12 CONTINUE IF(NBY.GE.1) THEN READ(10)NBYGRP SDBYID=NXPTD K=NBYGRP*NBY CALL ROOMD(K) K=SDBYID-1 DO 17 I=1,NBYGRP READ(10)(DX(K+J),J=1,NBY) K=K+NBY 17 CONTINUE ELSE SDBYID=0 NBYGRP=1 END IF READ(10)NRPTOT IF(NRPTOT.GT.0) THEN SDCOEF=NXPTD CALL ROOMD(NRPTOT) CALL UNFIN(10,DX(SDCOEF),NRPTOT,ENDFLE) ELSE SDCOEF=0 END IF RETURN 99 CONTINUE CALL FSTOP END SUBROUTINE SETUP2 IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (IXFLLD=19) PARAMETER (MAXFMT=20) C C MVAR represents the maximum number of incoming and created C variables, replicate factors and wts C MAXIDS is the maximum number of class variables C MRECOD is the maximum of variables transformed by CLASS, CAT C MISSING, SELECT, BY etc. C MRANGE is the maximum number of ranges C MRNSET is the maximum number of sets of ranges C MLEVEL is the maximum number of stored labels for levels C MCLBLK is the maximum number of class blocks C MCLBAR is the maximum number of cells of class block arrays C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP C LOGICAL REFRSH,ALPCHK,DGTCHK EXTERNAL REFRSH,ALPCHK,DGTCHK C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1, . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX C DOUBLE PRECISION RANGE(2,MRANGE) INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET), . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD), . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI) C COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP, . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO, . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS, . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT, . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS, . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO, . NLEVEL,NRNSET,NRANGE,NHADAM,IXFILL INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS, . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN, . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IXFILL(IXFLLD) C C Usage in this subroutine: C C BLXSTR - Pointer for block to X matrix C BLVSTR - revised to become pointer to first variable in block C BLVSIZ - revised to number of variables in block C BLNCLS - number of class variables in block C BLCPNT - pointer for classes to CLTYPE C CLTYPE - used as pointers to class variables C 103 FORMAT(/,5X,'Generalized replication assumed') 104 FORMAT(/,5X,'(Simple) jackknife replication assumed') 105 FORMAT(/,5X,'Stratified jackknife replication assumed') 205 FORMAT(' UNRECOGNIZED VARIABLE NAME ',A12) 206 FORMAT(' DUPLICATED ',A12) 220 FORMAT(' MISSING ONE OR MORE REPLICATES, INCLUDING',I6) C C Changes 9/97: C Cluster count and replicate count will be interpreted as number C of replicates, excluding the full sample (replicate 0) C C 299 FORMAT(' IOUTC=',I5,' NVIN=',I5) C C If BY variables are present, eliminate them from the list C of classes C IF(NBY.GT.0) THEN ICLBAR=0 DO 5 ICLBLK=1,NCLBLK IF(BLNCLS(ICLBLK).GT.0) THEN ICLB=BLCPNT(ICLBLK) NCL=0 DO 4 I=1,BLNCLS(ICLBLK) DO 2 J=1,NBY IF(BYLIST(J).EQ.CLTYPE(ICLB))GO TO 3 2 CONTINUE ICLBAR=ICLBAR+1 CLTYPE(ICLBAR)=CLTYPE(ICLB) NCL=NCL+1 3 CONTINUE ICLB=ICLB+1 4 CONTINUE BLNCLS(ICLBLK)=NCL BLCPNT(ICLBLK)=ICLBAR-NCL+1 END IF 5 CONTINUE NCLBAR=ICLBAR END IF C C If more than one block is present, ensure that the list of C classes for later blocks does not duplicate the first. Under C the new syntax, with explicit BLOCK / CLASS combinations, C this block is zeroed out in NSETP1, so BLNCLS(1)=0 C IF(NCLBLK.GT.1.AND.BLNCLS(1).GT.0) THEN ICLBAR=BLNCLS(1) DO 10 ICLBLK=2,NCLBLK IF(BLNCLS(ICLBLK).GT.0) THEN ICLB=BLCPNT(ICLBLK) NCL=0 DO 9 I=1,BLNCLS(ICLBLK) DO 7 J=1,BLNCLS(1) IF(CLTYPE(J).EQ.CLTYPE(ICLB))GO TO 8 7 CONTINUE ICLBAR=ICLBAR+1 CLTYPE(ICLBAR)=CLTYPE(ICLB) NCL=NCL+1 8 CONTINUE ICLB=ICLB+1 9 CONTINUE BLNCLS(ICLBLK)=NCL BLCPNT(ICLBLK)=ICLBAR-NCL+1 END IF 10 CONTINUE NCLBAR=ICLBAR END IF NID=0 IF(IWGT.EQ.0.AND.NOWGTF.EQ.0) THEN C ! Default weight CALL VNMTCH('WEIGHT ',VNAME,NVIN,IWGT) END IF IF(ISTRCD.EQ.0.AND.ISTRNO.EQ.0) THEN C ! ISTRC2 - match to CALL VNMTCH('STRATUM ',VNAME,NVIN,ISTRC2) C ! 'STRATUM' END IF IF((IREPF.GT.0.OR.IREPW.GT.0).AND.NREPW.EQ.0) THEN NREPW=0 DO 11 I=1,NVIN C ! If replicate IF(MTYPE(I).GT.50+NREPW)NREPW=MTYPE(I)-50 C ! weights/factors 11 CONTINUE C ! appear, confirm DO 13 J=1,NREPW C ! completeness DO 12 I=1,NVIN IF(MTYPE(I).EQ.50+J)GO TO 13 12 CONTINUE WRITE(U6,220)J CALL FESTOP(30230) C ! Error if gap 13 CONTINUE END IF IF(IREPNO.EQ.0.AND.NREPW.EQ.0.AND. C ! ICLUS2 - match to . ICLUSN.EQ.0.AND.ICLUSC.EQ.0) THEN C ! 'CLUSTER' CALL VNMTCH('CLUSTER ',VNAME,NVIN,ICLUS2) IF(ICLUS2.EQ.0) THEN CALL FESTOP(30231) END IF END IF IF(IREPF.GE.1.OR.IREPW.EQ.1) THEN C ! If replicate factors or NRPTOT=NREPW C ! weights have been END IF C ! established, set NRPTOT IF(ICLCNT.GT.0) THEN IF(NRPTOT.GT.0.AND.ICLCNT.NE.NRPTOT) THEN CALL FESTOP(30232) END IF END IF C C VFTYPE = 3 Weighted obs. with cluster/replicate number C 4 Unweighted " C 5 Replicate weights C 6 Unweighted initial obs. followed by replicate weights C 7 Replicate factors multiplying initial weight C 8 Replicate factors of unweighted initial obs ( = VFTYPE 6) C 11 Replicate factors multiplying initial weight, including C factor for replicate 0, overall estimate C 12 Unweighted initial obs " (= VFTYPE 5) C 13 Weighted obs. with cluster code C 14 Unweighted " C 15 Weighted obs. Stratum no. cluster code C 16 Unweighted " C 17 Wtd. Stratum code, cluster code C 18 Unwtd " C 21 Wtd. Stratum no. 2nd stage no, cluster code C 22 Unwtd. " C 23 Wtd. Stratum no. 2nd stage cd, cluster code C 24 Unwtd. " C 25 Wtd. Stratum code 2nd stage no. cluster code C 26 Unwtd " C 27 Wtd. Stratum code 2nd stage cd, cluster code C 28 Unwtd. " C 29 Wtd 2nd stage number cluster code C 30 Unwtd. " C 31 Wtd 2nd stage code cluster code C 32 Unwtd " C 33 Wtd Replicate number governed by stratum counts C 34 Unwtd " C 35 Wtd Rep numb govrned by stratum and 2nd stage counts C 36 Unwtd " C 37 Wtd Rep number governed by 2nd stage counts C 38 Unwtd " C IF(SDCOEF.GT.0) THEN C ! Coefficients establish IF(VROPTN.EQ.0) THEN C ! generalized replication VROPTN=5 IF(U5ECHO.GT.0)WRITE(U6,103) ELSE IF(VROPTN.NE.5.AND. . VROPTN.NE.6) THEN CALL FESTOP(30233) C ! COEFFICIENTS unexpected END IF ELSE IF(VROPTN.EQ.5) THEN CALL FESTOP(30251) C ! COEFFICIENTS missing END IF C C For half-sample replication, generalized, or simple random group C IF(VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5.OR.VROPTN.EQ.7) THEN IF(ISTRCD.GT.0.OR.ISTRNO.GT.0.OR.ISNDCD.GT.0.OR. . ISNDNO.GT.0) THEN CALL FESTOP(30234) C ! Error if stratum/2nd stage END IF C ! specification IF(NRPTOT.EQ.0) THEN IF(VROPTN.EQ.7) THEN NRPTOT=ICLCNT C ! Except for random group, ELSE C ! require specification of IF(ICLCNT.GT.0) THEN C ! number of replicates NRPTOT=ICLCNT ELSE CALL FESTOP(30235) END IF END IF END IF IF(SDFPC2.GT.0) THEN C ! Check for misspecification CALL FESTOP(30236) C ! of FPC's ELSE IF(VROPTN.EQ.7) THEN IF(SDFPC1.GT.0.AND.NDFPC1.NE.1) THEN CALL FESTOP(30238) C ! too many FPC1 END IF ELSE IF(SDFPC1.GT.0) THEN CALL FESTOP(30237) C ! FPC1 unexpected END IF NID=1 C ! NID - count of ID's IF(ICLUSN.GT.0) THEN VFTYPE=4 VIDS(NID)=ICLUSN ELSE IF(IREPNO.GT.0) THEN VFTYPE=4 VIDS(NID)=IREPNO ELSE IF((ICLUSC.GT.0.OR.ICLUS2.GT.0).AND.VROPTN.EQ.7) THEN IF(ICLUSC.EQ.0)ICLUSC=ICLUS2 VFTYPE=14 VIDS(NID)=ICLUSC ELSE IF(IREPW.EQ.1.OR.IREPF.GE.1) THEN VIDS(NID)=0 IF(IREPW.EQ.1) THEN VFTYPE=6 ELSE IF(IREPF.EQ.1) THEN VFTYPE=8 ELSE IF(IREPF.EQ.2) THEN VFTYPE=12 END IF ELSE CALL FESTOP(30239) END IF IF(IWGT.GT.0)VFTYPE=VFTYPE-1 C C Adjustment of NRPTOT for random group C C ELSE IF(VROPTN.NE.6) THEN C ! Simple and stratified jackknife, C ! stratified random group IF(NRPTOT.EQ.0) THEN NRPTOT=ICLCNT END IF IF(ISTRCD.EQ.0.AND.ISTRNO.EQ.0.AND. C ! Recognition of stratum . ISTRC2.GT.0.AND.VROPTN.NE.1) THEN ISTRCD=ISTRC2 END IF IF(ICLUSC.EQ.0.AND.ICLUSN.EQ.0.AND.IREPNO.EQ.0.AND. . VROPTN.EQ.0) THEN C ! If no explicit IF(ICLUS2.GT.0) THEN C ! identification of ICLUSC=ICLUS2 C ! variance identifier, ELSE IF(NREPW.EQ.0) THEN C ! use a variable CALL FESTOP(30231) C ! named "cluster," ELSE C ! else stop. CALL FESTOP(30264) END IF END IF IF(ISTRCD.GT.0.OR.ISTRNO.GT.0.OR.ISNDCD.GT.0.OR. . ISNDNO.GT.0.OR.NISTRS.GT.1.OR.NISNDS.GT.0) THEN IF(VROPTN.NE.4.AND.VROPTN.NE.8) THEN IF(U5ECHO.GT.0)WRITE(U6,105) VROPTN=4 END IF VFTYPE=0 IF(SDFPC2.GT.0) THEN C ! Edits with FPC2 IF(SDFPC1.EQ.0) THEN CALL FESTOP(30240) ELSE IF(ISNDCD.EQ.0.AND.ISNDNO.EQ.0.AND.SISNDS.EQ.0) THEN CALL FESTOP(30241) END IF END IF IF(ISTRNO.GT.0) THEN C ! STRATUM NUMBER VIDS(NID+1)=ISTRNO IF(ISNDNO.GT.0.OR.ISNDCD.GT.0) THEN NID=NID+2 IF(ISNDNO.GT.0) THEN VFTYPE=22 VIDS(NID)=ISNDNO ELSE VFTYPE=24 VIDS(NID)=ISNDCD END IF ELSE VFTYPE=16 NID=NID+1 END IF ELSE IF(ISTRCD.GT.0) THEN C ! STRATUM CODE, stratum VIDS(NID+1)=ISTRCD IF(ISNDNO.GT.0.OR.ISNDCD.GT.0) THEN NID=NID+2 IF(ISNDNO.GT.0) THEN VFTYPE=26 VIDS(NID)=ISNDNO ELSE VFTYPE=28 VIDS(NID)=ISNDCD END IF ELSE VFTYPE=18 NID=NID+1 END IF ELSE IF(ISNDNO.GT.0.OR.ISNDCD.GT.0) THEN C ! Second-stage only NID=NID+1 IF(ISNDNO.GT.0) THEN VFTYPE=30 VIDS(NID)=ISNDNO ELSE VFTYPE=32 VIDS(NID)=ISNDCD END IF END IF NID=NID+1 IF(ICLUSC.GT.0) THEN C ! Cluster code VIDS(NID)=ICLUSC ELSE IF(ICLUSN.GT.0) THEN C ! Cluster number VIDS(NID)=ICLUSN ELSE IF(IREPNO.GT.0) THEN VIDS(NID)=IREPNO ELSE IF(IREPW.EQ.1.OR.IREPF.GE.1) THEN C ! Use of REPW/REPF VIDS(NID)=0 IF(IREPW.EQ.1) THEN VFTYPE=6 ELSE IF(IREPF.EQ.1) THEN VFTYPE=8 ELSE IF(IREPF.EQ.2) THEN VFTYPE=12 END IF ELSE CALL FESTOP(30242) C ! Error if no cluster/repw END IF ISUM1=0 C ! Number of specified units C ! within strata IF(SISTRS.GT.0) THEN IF(NDFPC1.GT.0.AND.NDFPC1.NE.NISTRS) THEN CALL FESTOP(30243) END IF DO 16 I=1,NISTRS ISUM1=ISUM1+IX(I+SISTRS-1) 16 CONTINUE IF(VFTYPE.EQ.0) THEN C ! No stratum code/number, IF(ICLUSN.GT.0.OR. C ! but strata determined by . IREPNO.GT.0) THEN C ! cluster/replicate num VFTYPE=34 C ! and strata counts ELSE CALL FESTOP(30248) END IF END IF IF(NDFPC2.GT.0.AND.NDFPC2.NE.ISUM1) THEN CALL FESTOP(30244) END IF END IF ISUM2=0 IF(SISNDS.GT.0) THEN IF(ISUM1.GT.0.AND.NISNDS.NE.ISUM1) THEN CALL FESTOP(30245) ELSE IF(ISUM1.EQ.0) THEN IF(NDFPC1.NE.0.AND.NDFPC1.NE.1) THEN CALL FESTOP(30246) END IF END IF IF(NDFPC2.GT.0.AND.NDFPC1.EQ.0) THEN CALL FESTOP(30247) END IF DO 18 I=1,NISNDS ISUM2=ISUM2+IX(I+SISNDS-1) 18 CONTINUE IF(NRPTOT.GT.0) THEN IF(NRPTOT.NE.ISUM2) THEN CALL FESTOP(30249) END IF END IF NRPTOT=ISUM2 IF(VFTYPE.EQ.0) THEN IF(ICLUSN.GT.0.OR.IREPNO.GT.0) THEN VFTYPE=38 ELSE CALL FESTOP(30248) END IF ELSE IF(VFTYPE.EQ.34) THEN VFTYPE=36 END IF END IF IF(ISUM2.EQ.0.AND.ISUM1.GT.0) THEN IF(NRPTOT.GT.0) THEN IF(NRPTOT.NE.ISUM1) THEN CALL FESTOP(30250) END IF END IF NRPTOT=ISUM1 END IF ELSE IF(VROPTN.EQ.0) THEN IF(U5ECHO.GT.0)WRITE(U6,104) VROPTN=1 END IF NID=NID+1 IF(NDFPC1.NE.1.AND.NDFPC1.NE.0) THEN CALL FESTOP(30252) ELSE IF(NDFPC2.GT.0) THEN CALL FESTOP(30253) END IF IF(ICLUSN.GT.0) THEN VIDS(NID)=ICLUSN VFTYPE=4 ELSE IF(ICLUSC.GT.0) THEN VIDS(NID)=ICLUSC VFTYPE=14 ELSE IF(IREPNO.GT.0) THEN VIDS(NID)=IREPNO VFTYPE=4 ELSE IF(IREPW.EQ.1.OR.IREPF.GE.1) THEN VIDS(NID)=0 IF(IREPW.EQ.1) THEN VFTYPE=6 ELSE IF(IREPF.EQ.1) THEN VFTYPE=8 ELSE IF(IREPF.EQ.2) THEN VFTYPE=12 END IF ELSE CALL FESTOP(30248) END IF IF(SISTRS.GT.0) THEN IF(NISTRS.GT.1) THEN CALL FESTOP(30254) ELSE IF(NRPTOT.GT.0.AND.IX(SISTRS).NE.NRPTOT) THEN CALL FESTOP(30255) END IF NRPTOT=IX(SISTRS) END IF END IF IF(IWGT.GT.0)VFTYPE=VFTYPE-1 ELSE C ! VROPTN=6 NONE NRPTOT=0 END IF IF(NBY.GT.0) THEN C ! edit BY variables DO 24 I=1,NBY J=BYLIST(I) IF(IWGT.EQ.J) THEN CALL FESTOP(30261) ELSE IF(NID.GT.0) THEN DO 20 L=1,NID IF(VIDS(L).EQ.J) THEN CALL FESTOP(30262) END IF 20 CONTINUE END IF IF(MTYPE(J).EQ.4) THEN MTYPE(J)=5 ELSE IF(MTYPE(J).EQ.1.OR.MTYPE(J).EQ.2) THEN MTYPE(J)=6 ELSE CALL FESTOP(30256) END IF NID=NID+1 VIDS(NID)=J 24 CONTINUE END IF C C NIDTOT - the total length of the ID record on the outgoing file C IF((VROPTN.EQ.4.OR.VROPTN.EQ.8).AND. . (VFTYPE.LT.5.OR.VFTYPE.GT.12)) THEN IF(VFTYPE.GE.33) THEN NIDTOT=NID+2 IF(SISTRS.GT.0)NIDTOT=NIDTOT+3 IF(SISNDS.GT.0)NIDTOT=NIDTOT+3 ELSE NIDTOT=2*NID-NBY+1 END IF ELSE NIDTOT=NID+2 END IF IOUTC=0 BLXSTR(1)=1 ILOC=2 C ! Offset ILOC for N(1) IF(NCLBLK.GT.1.AND.BLVSIZ(1).EQ.0) THEN C ! When first block ICLBLK=2 C ! contains no vars. BLXSTR(2)=1 30 CONTINUE IF(BLVSIZ(ICLBLK).EQ.0.AND.ICLBLK.LT.NCLBLK) THEN ICLBLK=ICLBLK+1 BLXSTR(ICLBLK)=ILOC ILOC=ILOC+1 GO TO 30 END IF ELSE ICLBLK=1 END IF IF(VKEEPF.EQ.1.OR.NCLBLK.GT.1) THEN C ! Reverse sign of MTYPE to DO 32 K=1,NVIN C ! as marker for assignment MTYPE(K)=-IABS(MTYPE(K)) C ! to block if BLOCKS 32 CONTINUE C ! specified or if KEEP END IF IF(NKEEP.GT.0) THEN C ! If KEEP, DROP, or DO 36 I=1,NKEEP C ! BLOCK with one or more CALL VNMTCH(VNKEEP(I),VNAME,NVIN,J) C ! variables, edit list IF(J.EQ.0) THEN WRITE(U6,205)VNKEEP(I) CALL FESTOP(30257) ELSE IF(VKEEPF.EQ.1) THEN C ! Edit KEEP or BLOCK MTYPE(J)=IABS(MTYPE(J)) C ! for type IF(MTYPE(J).GE.4.AND. . MTYPE(J).LE.6) THEN CALL FESTOP(30259) ELSE IF(MTYPE(J).GE.50.OR. C ! Exclude weight, repw . J.EQ.IWGT) THEN CALL FESTOP(30260) ELSE IF(NID.GT.0) THEN C ! Exclude var ids DO 34 L=1,NID IF(VIDS(L).EQ.J) THEN CALL FESTOP(30263) END IF 34 CONTINUE END IF IOUTC=IOUTC+1 IOUT(IOUTC)=J ELSE C ! DROP - change MTYPE to MTYPE(J)=-IABS(MTYPE(J)) C ! negative END IF 36 CONTINUE END IF K=0 IC=0 IF(IOUTC.EQ.0) THEN C ! If no list assembled in LL=NVIN C ! IOUT, loop over all vars ELSE LL=IOUTC C ! else loop over IOUT END IF DO 46 I=1,LL IF(IOUTC.EQ.0) THEN J=I ELSE J=IOUT(I) END IF IF(IABS(MTYPE(J)).EQ.49)GO TO 44 C ! skip over KEY variables IC=IC+1 IF(IABS(MTYPE(J)).GE.50)GO TO 44 C ! skip weight, repw IF(J.EQ.IWGT)GO TO 44 IF(NID.GT.0) THEN C ! skip var ids DO 38 L=1,NID IF(VIDS(L).EQ.J)GO TO 44 38 CONTINUE END IF IF(NCLBAR.GT.0) THEN C ! skip class vars named in DO 40 L=1,NCLBAR C ! block statements IF(CLTYPE(L).EQ.J)GO TO 44 40 CONTINUE END IF IF(MTYPE(J).GT.0) THEN C ! Exclude DROPped variables K=K+1 IOUT(K)=J IOUTL(K)=ILOC VMAPL(J)=ILOC IF(MXSIZE(J).GT.MSIZE(J)) THEN C ! set aside the greater of ILOC=ILOC+MXSIZE(J) C ! the final size and ELSE C ! interim size ILOC=ILOC+MSIZE(J) END IF IF(K.GT.1) THEN DO 42 L=1,K-1 IF(IOUT(L).EQ.J) THEN C ! Duplicate WRITE(U6,206)VNAME(J) CALL FESTOP(30258) END IF 42 CONTINUE END IF END IF 44 CONTINUE IF(IC.GE.BLVSIZ(ICLBLK)) THEN C ! Detect whether moving to next IF(BLVSIZ(ICLBLK).GT.0) THEN C ! block. BLVSIZ(ICLBLK)=K-BLVSTR(ICLBLK)+1 C ! Adjust BLVSIZ to actual size. END IF IF(ICLBLK.LT.NCLBLK) THEN ICLBLK=ICLBLK+1 BLXSTR(ICLBLK)=ILOC IF(IC.GT.BLVSIZ(ICLBLK-1)) THEN BLVSTR(ICLBLK)=K ELSE BLVSTR(ICLBLK)=K+1 END IF ILOC=ILOC+1 IC=0 GO TO 44 C ! Loop to check next block END IF END IF 46 CONTINUE IOUTC=K DO 47 I=1,NVIN C ! Reverse sign all output MTYPE(I)=-MTYPE(I) C ! variables are negative 47 CONTINUE NVREG=IOUTC IF(NCLBLK.EQ.1) THEN BLVSTR(1)=1 BLVSIZ(1)=NVREG END IF ILOC1=ILOC-1 IF(NCLBAR.GT.0) THEN C ! Loop over blocks to find NCLSS1=0 C ! class variables used DO 52 I=1,NCLBAR J=CLTYPE(I) IF(NBY.GT.0) THEN C ! Exclude class variables DO 48 L=1,NBY C ! on BY list IF(BYLIST(L).EQ.J) GO TO 52 48 CONTINUE END IF IF(NCLSS1.GE.1) THEN DO 50 L=NVREG+1,NVREG+NCLSS1 IF(IOUT(L).EQ.J)GO TO 52 50 CONTINUE END IF NCLSS1=NCLSS1+1 IOUTC=IOUTC+1 IOUT(IOUTC)=J IOUTL(IOUTC)=ILOC VMAPL(J)=ILOC ILOC=ILOC+MXSIZE(J) MTYPE(J)=-IABS(MTYPE(J)) 52 CONTINUE NCLASS=NCLSS1 END IF IF(NID.GT.0) THEN C ! Placement of VARID's DO 54 I=1,NID J=VIDS(I) IF(J.EQ.0)GO TO 54 IOUTC=IOUTC+1 IOUT(IOUTC)=J IOUTL(IOUTC)=ILOC VMAPL(J)=ILOC ILOC=ILOC+MXSIZE(J) MTYPE(J)=-IABS(MTYPE(J)) 54 CONTINUE END IF IF(IWGT.NE.0) THEN C ! Placement of weight IOUTC=IOUTC+1 IOUT(IOUTC)=IWGT IOUTL(IOUTC)=ILOC VMAPL(IWGT)=ILOC ILOC=ILOC+MXSIZE(IWGT) MTYPE(IWGT)=-IABS(MTYPE(IWGT)) END IF IOUTC2=IOUTC IF(NREPW.GT.0) THEN IXFILL(5)=1 C ! Setting IREPL IXFILL(6)=NREPW C ! Setting IREPH DO 58 I=1,NREPW+1 DO 56 J=1,NVIN IF(IABS(MTYPE(J)).EQ.49+I) THEN IOUTC=IOUTC+1 IOUT(IOUTC)=J IOUTL(IOUTC)=ILOC VMAPL(J)=ILOC IF(I.EQ.2)IXFILL(8)=ILOC C ! Setting of SDRWF ILOC=ILOC+MXSIZE(J) MTYPE(J)=-IABS(MTYPE(J)) GO TO 58 END IF 56 CONTINUE 58 CONTINUE END IF DO 60 J=1,NVIN IF(MTYPE(J).GT.0.OR. C ! Positive MTYPE are . IABS(MTYPE(J)).EQ.49) THEN C ! not yet assigned IOUTC=IOUTC+1 C ! space IOUT(IOUTC)=J IOUTL(IOUTC)=ILOC VMAPL(J)=ILOC ILOC=ILOC+MXSIZE(J) END IF MTYPE(J)=IABS(MTYPE(J)) 60 CONTINUE LOCEND=ILOC-1 RETURN END SUBROUTINE CREAT1 IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (IXFLLD=17) PARAMETER (MAXFMT=20) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1, . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX C DOUBLE PRECISION RANGE(2,MRANGE) INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET), . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD), . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI) C COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP, . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO, . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS, . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT, . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS, . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO, . NLEVEL,NRNSET,NRANGE,NHADAM,IXFILL,SDSTCK,MSDPTH INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS, . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN, . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IXFILL(IXFLLD), . SDSTCK,MSDPTH C C Usage in this subroutine: C C BLXSTR - pointer for block to X matrix C BLXINC - length of the X matrix for a single combination C of the class variables in the block C BLXSIZ - total size of block data in X matrix (integer multiple C of BLXINC) C BLVSTR - Pointer to first variable in block on outgoing file C BLVSIZ - Number of variables in block C BLNCLS - number of class variables in block C BLCPNT - pointer for classes to CLTYPE C CLTYPE - used as pointers to class variables C C 100 FORMAT(/,5X,'Number of passes of original data =',I3) 101 FORMAT(/,5X,'Total size of tally matrix =',I7) 102 FORMAT(/,5X,'Size of block',I4,' =',8X,I7) 298 FORMAT(' LOGICAL ERROR') C SIINCR=NXPTI CALL ROOMI(NCLBAR) II=SIINCR IBASE=1 ICLBAR=0 NCLBR2=0 TSIZE=0 NCBLK2=0 DO 2 ICLBLK=1,NCLBLK IMULT=IBASE IF(BLNCLS(ICLBLK).GT.0) THEN IF(ICLBLK.EQ.1) THEN IF(NCLBLK.EQ.1) THEN NCLBR2=BLNCLS(1) ELSE IF(BLXSTR(2).GT.1) THEN NCLBR2=BLNCLS(1) END IF ELSE NCLBR2=NCLBR2+BLNCLS(ICLBLK)+BLNCLS(1) END IF DO 1 I=1,BLNCLS(ICLBLK) CALL RINCR(9,ICLBAR,1) IX(II)=IMULT IMULT=IMULT*MSIZE(CLTYPE(ICLBAR)) II=II+1 1 CONTINUE IF(ICLBLK.EQ.1)IBASE=IMULT ELSE IF(ICLBLK.GT.1) THEN NCLBR2=NCLBR2+BLNCLS(1) END IF IF(ICLBLK.EQ.NCLBLK) THEN BLXINC(ICLBLK)=ILOC1-BLXSTR(NCLBLK)+1 ELSE BLXINC(ICLBLK)=BLXSTR(ICLBLK+1)-BLXSTR(ICLBLK) END IF IF(ICLBLK.NE.1.OR.BLXINC(ICLBLK).NE.0) THEN NCBLK2=NCBLK2+1 BLXSIZ(ICLBLK)=BLXINC(ICLBLK)*IMULT IF(U5ECHO.GT.0)WRITE(U6,102)NCBLK2,BLXSIZ(ICLBLK) TSIZE=TSIZE+BLXSIZ(ICLBLK) ELSE BLXSIZ(ICLBLK)=0 END IF 2 CONTINUE CALL RCHECK(9,NCLBR2,0) IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN SDWGT=NXPTD K=NRPTOT+1 CALL ROOMD(K) ELSE SDWGT=0 END IF SDVIN=NXPTD CALL ROOMD(LOCEND) IF(MSDPTH.GT.0) THEN C ! Space for stack K=2*MSDPTH SDSTCK=NXPTD CALL ROOMD(K) END IF IF(U5ECHO.GT.0)WRITE(U6,101)TSIZE SDCLUS=NXPTD SDTOT=SDCLUS+TSIZE MDMX=(SIZED-SDCLUS+1)/TSIZE USTRT=0 USNDS=0 UIDS=0 UTOT=0 IF(MDMX.LE.0)CALL ROOMD(TSIZE) C ! Insufficient space IF((VROPTN.EQ.1.OR.VROPTN.EQ.7).AND. . (VFTYPE.EQ.3.OR.VFTYPE.EQ.4.OR. . VFTYPE.EQ.13.OR.VFTYPE.EQ.14)) THEN NDMX=2 UCLUS=13 IF(NBY.GE.1) THEN NSCRCH=3 UTOT=14 UIDS=15 ELSE NSCRCH=2 UIDS=14 END IF ELSE IF((VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5).AND. . (VFTYPE.EQ.3.OR.VFTYPE.EQ.4.OR. . VFTYPE.EQ.13.OR.VFTYPE.EQ.14)) THEN NDMX=2 IF(NBY.GE.1) THEN NSCRCH=2 UCLUS=13 UIDS=14 ELSE UCLUS=11 NSCRCH=0 END IF ELSE IF((VROPTN.EQ.4.OR.VROPTN.EQ.8).AND.VFTYPE.GE.15) THEN UCLUS=13 IF(VFTYPE.EQ.35.OR.VFTYPE.EQ.36.OR. . (VFTYPE.GE.21.AND.VFTYPE.LE.28)) THEN SDTOT2=SDTOT+TSIZE SDTOT3=SDTOT2+TSIZE NDMX=4 USTRT=14 USNDS=15 IF(NBY.GE.1) THEN UTOT=16 UIDS=17 NSCRCH=5 ELSE NSCRCH=4 UIDS=16 END IF ELSE IF(VFTYPE.EQ.33.OR.VFTYPE.EQ.34.OR. . (VFTYPE.GE.15.AND.VFTYPE.LE.18)) THEN SDTOT2=SDTOT+TSIZE NDMX=3 USTRT=14 IF(NBY.EQ.0) THEN NSCRCH=3 UIDS=15 ELSE UTOT=15 UIDS=16 NSCRCH=4 END IF ELSE IF(VFTYPE.EQ.37.OR.VFTYPE.EQ.38.OR. . (VFTYPE.GE.29.AND.VFTYPE.LE.32)) THEN SDTOT3=SDTOT+TSIZE NDMX=3 USNDS=14 IF(NBY.EQ.0) THEN NSCRCH=3 UIDS=15 ELSE UTOT=15 UIDS=16 NSCRCH=4 END IF ELSE GO TO 98 END IF ELSE IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN NDMX=MDMX IF(VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5) THEN NRPT1=NRPTOT+1 ELSE NRPT1=NRPTOT END IF NPASS=(NRPT1-1)/NDMX+1 IF(NDMX.GT.NRPT1)NDMX=NRPT1 IF(NPASS.GT.1) THEN IF(U5ECHO.GT.0)WRITE(U6,100)NPASS END IF IF(VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5) THEN IF(NBY.EQ.0) THEN UCLUS=11 NSCRCH=0 ELSE UCLUS=13 UIDS=14 NSCRCH=2 END IF ELSE IF(VROPTN.EQ.4.OR.VROPTN.EQ.8) THEN IF(NPASS.EQ.1) THEN UCLUS=13 ELSE UCLUS=14 END IF IF(SISTRS.GT.0.AND.SISNDS.GT.0) THEN SDTOT2=SDTOT+TSIZE SDTOT3=SDTOT2+TSIZE USTRT=14 USNDS=15 IF(NBY.GE.1) THEN NSCRCH=5 UTOT=16 UIDS=17 ELSE NSCRCH=4 UIDS=16 END IF ELSE IF(SISTRS.GT.0) THEN SDTOT2=SDTOT+TSIZE USTRT=14 IF(NBY.GE.1) THEN NSCRCH=4 UTOT=15 UIDS=16 ELSE NSCRCH=3 UIDS=15 END IF ELSE IF(SISNDS.GT.0) THEN SDTOT3=SDTOT+TSIZE USNDS=14 IF(NBY.GE.1) THEN NSCRCH=4 UTOT=15 UIDS=16 ELSE NSCRCH=3 UIDS=15 END IF END IF ELSE IF(NPASS.EQ.1) THEN UCLUS=13 ELSE UCLUS=14 END IF IF(NBY.GE.1) THEN UTOT=14 UIDS=15 NSCRCH=3 ELSE UIDS=14 NSCRCH=2 END IF END IF END IF ITSIZE=TSIZE*NDMX CALL ROOMD(ITSIZE) DO 3 I=1,5 IF(I.LE.NSCRCH) THEN IUNIT=I+12 CALL SCOPEN(IUNIT) END IF 3 CONTINUE IVERSN=9203 WRITE(11,ERR=97)IVERSN IF(IWGT.GT.0) THEN NWGT=1 ELSE NWGT=0 END IF C C Calculation of NVTOT, the total number of variables on VPLX file C Note that NVARID will include allowance for NVARID=1 for C replicate weight input, even though no variable is included in C NVTOT C NVTOT=NVREG+NCLASS+NID+NWGT IF(VFTYPE.GE.5.AND.VFTYPE.LE.12)NVTOT=NVTOT-1 NVARID=NID-NBY WRITE(11,ERR=97)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE, . VROPTN,NIDTOT,TSIZE,NCBLK2,NCLBR2 K=1 J=1 I=1 DO 4 ICLBLK=1,NCLBLK IF(ICLBLK.NE.1.OR.BLXINC(1).GT.0) THEN IF(ICLBLK.EQ.1) THEN II=BLNCLS(ICLBLK) ELSE II=BLNCLS(ICLBLK)+BLNCLS(1) END IF WRITE(11,ERR=97)K,J,BLXINC(ICLBLK),BLXSIZ(ICLBLK), . BLVSTR(ICLBLK),BLVSIZ(ICLBLK),II,I J=J+BLXSIZ(ICLBLK) I=I+II END IF 4 CONTINUE IF(NCLBAR.GT.0) THEN DO 5 I=1,NCLBR2 CLPNT(I)=1 5 CONTINUE CALL INTOUT(11,CLPNT,NCLBR2) ICLBAR=0 ICLB=0 DO 8 ICLBLK=1,NCLBLK IF(ICLBLK.EQ.1) THEN IF(BLNCLS(1).GT.0) THEN IF(BLXINC(1).GT.0) THEN DO 555 I=1,BLNCLS(1) CLPNT(I)=-CLTYPE(I) 555 CONTINUE ICLBAR=BLNCLS(1) END IF ICLB=BLNCLS(1) END IF ELSE IF(BLNCLS(1).GT.0) THEN DO 6 I=1,BLNCLS(1) ICLBAR=ICLBAR+1 CLPNT(ICLBAR)=-CLTYPE(I) 6 CONTINUE END IF IF(BLNCLS(ICLBLK).GT.0) THEN DO 7 I=1,BLNCLS(ICLBLK) ICLBAR=ICLBAR+1 ICLB=ICLB+1 CLPNT(ICLBAR)=-CLTYPE(ICLB) 7 CONTINUE END IF END IF 8 CONTINUE DO 10 I=NVREG+1,NVREG+NCLASS DO 9 J=1,NCLBR2 IF(CLPNT(J).EQ.-IOUT(I))CLPNT(J)=I 9 CONTINUE 10 CONTINUE CALL INTOUT(11,CLPNT,NCLBR2) END IF NXPTIS=NXPTI CALL ROOMI(NVREG) IF(NVREG.GT.0) THEN K=NXPTIS IL=1 I=0 IBASE=1 DO 511 ICLBLK=1,NCLBLK IF(ICLBLK.EQ.1) THEN IF(BLXINC(1).GT.0) THEN IL=2 ELSE GO TO 511 END IF ELSE IL=IBASE+1 END IF DO 510 J=1,BLVSIZ(ICLBLK) I=I+1 IX(K)=IL IF(MXSIZE(IOUT(I)).GT.MSIZE(IOUT(I))) THEN IL=IL+MXSIZE(IOUT(I)) ELSE IL=IL+MSIZE(IOUT(I)) END IF K=K+1 510 CONTINUE IBASE=IBASE+BLXSIZ(ICLBLK) 511 CONTINUE END IF DO 12 I=1,IOUTC2 MXSIZE(I)=MTYPE(IOUT(I)) 12 CONTINUE IF(NVTOT.GT.0)CALL INTOUT(11,MXSIZE,NVTOT) DO 13 I=1,IOUTC2 MXSIZE(I)=MSIZE(IOUT(I)) 13 CONTINUE IF(NVTOT.GT.0)CALL INTOUT(11,MXSIZE,NVTOT) IF(NVREG.GT.0)CALL INTOUT(11,IX(NXPTIS),NVREG) NXPTI=NXPTIS ILC=0 IVC=0 DO 15 I=1,IOUTC2 J=MTYPE(IOUT(I)) IF(J.EQ.8.OR.J.EQ.9) THEN K=CDMPNT(IOUT(I)) L=CROSSD(K) ILC=ILC+1 MXSIZE(ILC)=L DO 14 M=1,L K=K+1 ILC=ILC+1 MXSIZE(ILC)=CROSSD(K) 14 CONTINUE ILC=ILC+1 MXSIZE(ILC)=IVC+1 IVC=IVC+L END IF 15 CONTINUE WRITE(11,ERR=97)ILC IF(ILC.GT.0)CALL INTOUT(11,MXSIZE,ILC) ILC=0 DO 17 I=1,IOUTC2 J=MTYPE(IOUT(I)) WRITE(11,ERR=97)VNAME(IOUT(I)),LABEL(IOUT(I)) IF(J.EQ.3.OR.J.EQ.4.OR.J.EQ.5) THEN ILC=ILC+MSIZE(IOUT(I)) ELSE IF(J.EQ.8.OR.J.EQ.9) THEN K=CDMPNT(IOUT(I)) L=CROSSD(K) DO 16 M=1,L K=K+1 ILC=ILC+CROSSD(K)+1 16 CONTINUE END IF 17 CONTINUE WRITE(11,ERR=97)ILC DO 20 I=1,IOUTC2 J=MTYPE(IOUT(I)) IF(J.EQ.3.OR.J.EQ.4.OR.J.EQ.5) THEN ILC=MSIZE(IOUT(I)) ELSE IF(J.EQ.8.OR.J.EQ.9) THEN K=CDMPNT(IOUT(I)) L=CROSSD(K) ILC=0 DO 18 M=1,L K=K+1 ILC=ILC+CROSSD(K)+1 18 CONTINUE ELSE GO TO 20 END IF L=LPOINT(IOUT(I)) DO 19 J=1,ILC WRITE(11,ERR=97)LEVEL(L) L=L+1 19 CONTINUE 20 CONTINUE WRITE(11,ERR=97)IVC DO 22 I=1,IOUTC2 J=MTYPE(IOUT(I)) IF(J.EQ.8.OR.J.EQ.9) THEN K=CDMPNT(IOUT(I)) L=CROSSD(K) K2=CROSSD(K+L+1) DO 21 M=1,L WRITE(11,ERR=97)VTEMP(K2) K2=K2+1 21 CONTINUE END IF 22 CONTINUE IF(UCLUS.EQ.11) THEN WRITE(11,ERR=97)NRPTOT IF(VROPTN.EQ.5) THEN CALL UNFOUT(11,DX(SDCOEF),NRPTOT) ELSE IF(VROPTN.EQ.2.OR.VROPTN.EQ.3) THEN IF(MSIZED-SDCLUS.LT.NRPTOT)CALL ROOMD(NRPTOT) DFACT=1.D0/DBLE(NRPTOT) DO 23 I=SDCLUS,SDCLUS+NRPTOT-1 DX(I)=DFACT 23 CONTINUE CALL UNFOUT(11,DX(SDCLUS),NRPTOT) END IF END IF IUPPER=SDCLUS+ITSIZE-1 DO 24 I=SDCLUS,IUPPER DX(I)=0. 24 CONTINUE DO 25 I=1,NVIN IF(VMAPL(I).GT.0) THEN VMAPL(I)=VMAPL(I)+SDVIN-1 IOUTL(I)=IOUTL(I)+SDVIN-1 END IF 25 CONTINUE IXFILL(8)=IXFILL(8)+SDVIN-1 C ! SDRWF C C Based on VMAPL, update stored commands C I=1 27 CONTINUE C C INPUT C IF(RCTYPE(I).GE.40.AND.RCTYPE(I).LE.42) THEN C C Check for keys, and update the pointer in V2 to the stored value C IF(RSTPNT(I).GT.0) THEN K=RSTPNT(I) I=I+2 DO 28 J=1,K I=I+1 V2(I)=VMAPL(V2(I)) 28 CONTINUE ELSE I=I+2 END IF C C OUTPUT, update list of output variable locations C ELSE IF(RCTYPE(I).EQ.47) THEN N=V1(I) JJ=V2(I)+1 DO 29 K=1,N JJ=JJ+1 IX(JJ)=VMAPL(IX(JJ)) 29 CONTINUE END IF I=I+1 IF(I.LE.NRECOD)GO TO 27 RETURN 97 CONTINUE CALL FWSTOP(11) 98 CONTINUE WRITE(U6,298) 99 CONTINUE CALL FSTOP END C C C4.FOR C SUBROUTINE CREAT2(DONE) IMPLICIT DOUBLE PRECISION (A-H,O-Z) LOGICAL DONE PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (IXFLLD=19) PARAMETER (MAXFMT=20) C C MVAR represents the maximum number of incoming and created C variables, replicate factors and wts C MAXIDS is the maximum number of class variables C MRECOD is the maximum of variables transformed by CLASS, CAT C MISSING, SELECT, BY etc. C MRANGE is the maximum number of ranges C MRNSET is the maximum number of sets of ranges C MLEVEL is the maximum number of stored labels for levels C MCLBLK is the maximum number of class blocks C MCLBAR is the maximum number of cells of class block arrays C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT C C NVTOT (NTOTV) C NVREG (IOUTC1) C NVARID (NID1) C INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1, . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX C DOUBLE PRECISION RANGE(2,MRANGE) INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET), . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD), . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI) C COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP, . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO, . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS, . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT, . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS, . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO, . NLEVEL,NRNSET,NRANGE,NHADAM,IXFILL INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS, . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN, . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IXFILL(IXFLLD) LOGICAL IXDROP C C Usage in this subroutine: C C BLXSTR - pointer for block to X matrix C BLXINC - length of the X matrix for a single combination C of the class variables in the block C BLXSIZ - total size of block data in X matrix (integer multiple C of BLXINC) C BLVSTR - Pointer to first variable in block on outgoing file C BLVSIZ - Number of variables in block C BLNCLS - number of class variables in block C BLCPNT - pointer for classes to CLTYPE C CLTYPE - used as pointers to class variables C LOGICAL ENDF12,RFIRST,IDCHNG,BYCHNG,STCHNG,SNCHNG DOUBLE PRECISION VIDNOW(MAXIDS),VIDSAV(MAXIDS) 201 FORMAT(/,' Sequence error for BY variables') 202 FORMAT(/,' Sequence error for stratum/2nd/cluster identifiers') 203 FORMAT(/,' Current values',4(/,4F18.4)) 204 FORMAT(/,' Previous values',4(/,4F18.4)) C C Logicals: C C IXDROP - returned by RECODX to denote an entire case to be dropped C ENDF12 - denotes end of primary file - returned by RECODX C RFIRST - true when the current record is the first valid record C IDCHNG - denotes a change in ID(s) - stratum, cluster, etc. C BYCHNG - change in BY group, always false when no BY groups are used C STCHNG - change in stratum number/code C SNCHNG - change in second stage number/code C DONE - set to true if this subroutine is the last needed to C create the VPLX file. C IF(NWGT.GT.0)LWGT=VMAPL(IWGT) RFIRST=.TRUE. DNCLUS=1. IF(UCLUS.EQ.11) THEN NIDOUT=NIDTOT VIDSAV(NIDOUT-1)=0. VIDSAV(NIDOUT)=1. ELSE NIDOUT=NID END IF IF(VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5)DNCLUS=0. NCCLUS=1 NBYGRP=0 C DONE=.FALSE. C C 29 is the return point when multi-passes of the input file C are required. C 29 CONTINUE ENDF12=.FALSE. C C 30 is the return point for each observation C 30 CONTINUE C C If IVZERO=1, then initialize all data to zero (necessary when C one or more real variables are created within an IF condition) C IF(IVZERO.EQ.1) THEN K=SDVIN DO 25 I=1,LOCEND DX(K)=0. K=K+1 25 CONTINUE END IF C C For each block, set the cell denoting block inclusion to 1 C DO 305 ICLBLK=1,NCLBLK DX(SDVIN+BLXSTR(ICLBLK)-1)=1.0D0 305 CONTINUE IXDROP=.FALSE. CALL RECODX(IXDROP,ENDF12) IF(ENDF12)GO TO 50 C C Loop to expand types 3, 4, 8, and 9 C DO 43 I=1,NVREG J=IOUT(I) IF(MTYPE(J).EQ.3.OR.MTYPE(J).EQ.4.OR.MTYPE(J).EQ.9) THEN L=IOUTL(I) L2=L+MSIZE(J)-1 IVAL=DX(L) DO 41 K=L,L2 DX(K)=0. 41 CONTINUE IF(IVAL.GT.0)DX(L+IVAL-1)=1.0D0 ELSE IF(MTYPE(J).EQ.8) THEN L=IOUTL(I) IVAL=DX(L+1) XV1=DX(L) L2=L+MSIZE(J)-1 DO 42 K=L,L2 DX(K)=0. 42 CONTINUE IF(IVAL.GT.0) THEN DX(L+2*IVAL-2)=XV1 DX(L+2*IVAL-1)=1.0D0 END IF END IF 43 CONTINUE C C Determine if there has been a change in IDs C IDCHNG=.FALSE. BYCHNG=.FALSE. C C For the first valid record, treat as a change in id C IF(RFIRST) THEN IDCHNG=.TRUE. IF(NID.GT.0) THEN DO 44 I=1,NID J=VIDS(I) IF(J.EQ.0)GO TO 44 VIDNOW(I)=DX(VMAPL(J)) C C Don't include if any of the ids - stratum, cluster, etc. are missing C IF(MTYPE(J).EQ.4.AND.VIDNOW(I).EQ.0.)GO TO 30 IF(MTYPE(J).EQ.2) THEN IF(DX(VMAPL(J)+1).EQ.0.) GO TO 30 END IF 44 CONTINUE END IF C C For subsequent valid records, check for change in id C ELSE IF(NID.GT.0) THEN DO 45 I=1,NID J=VIDS(I) IF(J.EQ.0) GO TO 45 VIDNOW(I)=DX(VMAPL(J)) IF(MTYPE(J).EQ.4.AND.VIDNOW(I).EQ.0.)GO TO 30 IF(MTYPE(J).EQ.2) THEN IF(DX(VMAPL(J)+1).EQ.0.)GO TO 30 END IF IF(DABS(VIDNOW(I)-VIDSAV(I)).GT..1D-5) THEN IDCHNG=.TRUE. IF(I.GT.NVARID)BYCHNG=.TRUE. END IF 45 CONTINUE C C If there is a change in the BY ids, check that there has C been an increase. C IF(BYCHNG) THEN DO 46 I=NVARID+1,NID IF(VIDNOW(I).GT.VIDSAV(I)+.1D-5) GO TO 47 IF(VIDNOW(I).LT.VIDSAV(I)-.1D-5) THEN WRITE(U6,201) WRITE(U6,203)(VIDNOW(K),K=NVARID+1,NID) WRITE(U6,204)(VIDSAV(K),K=NVARID+1,NID) CALL FESTOP(34001) END IF 46 CONTINUE 47 CONTINUE C C If there is a change in the var ids without a change in the BY ids, C check that there is an increase in the var ids. C ELSE IF(IDCHNG) THEN DO 48 I=1,NVARID IF(VIDNOW(I).GT.VIDSAV(I)+.1D-5) GO TO 49 IF(VIDNOW(I).LT.VIDSAV(I)-.1D-5) THEN WRITE(U6,202) WRITE(U6,203)(VIDNOW(K),K=1,NVARID) WRITE(U6,204)(VIDSAV(K),K=1,NVARID) CALL FESTOP(34002) END IF 48 CONTINUE 49 CONTINUE END IF END IF 50 CONTINUE C C Come here to finish processing of previous data before processing C the current record (or at end of file) C IF(IDCHNG.OR.ENDF12) THEN IF(VFTYPE.LT.5.OR.VFTYPE.GT.12) THEN IF(.NOT.RFIRST) THEN C C Write out cluster-level data and add to stratum and second-stage C totals. C IF(NID.GT.0)WRITE(UNIT=UCLUS,ERR=971)(VIDSAV(I),I=1,NIDOUT) CALL UNFOUT(UCLUS,DX(SDCLUS),TSIZE) IF(USTRT.GT.0) THEN DO 51 I=1,TSIZE DX(SDTOT2+I-1)=DX(SDTOT2+I-1)+DX(SDCLUS+I-1) 51 CONTINUE END IF IF(USNDS.GT.0) THEN DO 52 I=1,TSIZE DX(SDTOT3+I-1)=DX(SDTOT3+I-1)+DX(SDCLUS+I-1) 52 CONTINUE END IF IF(VROPTN.EQ.1.OR.VROPTN.EQ.4.OR. . VROPTN.EQ.7.OR.VROPTN.EQ.8) THEN DO 53 I=1,TSIZE DX(SDTOT+I-1)=DX(SDTOT+I-1)+DX(SDCLUS+I-1) 53 CONTINUE END IF NCCLUS=NCCLUS+1 DO 54 I=SDCLUS,SDTOT-1 DX(I)=0. 54 CONTINUE IF(UIDS.GT.0)WRITE(UNIT=UIDS,ERR=975)(VIDSAV(I),I=1,NID) C C Now check if the stratum has changed. If so, write to file. C IF(USTRT.GT.0) THEN STCHNG=.FALSE. IF(ENDF12.OR.BYCHNG) THEN STCHNG=.TRUE. ELSE IF(VFTYPE.GE.15.AND.VFTYPE.LE.28) THEN IF(DABS(VIDSAV(1)-VIDNOW(1)).GT..1D-5)STCHNG=.TRUE. ELSE IF(VFTYPE.GE.33.AND.VFTYPE.LE.36) THEN I=SISTRS J=SISNDS NC1=VIDSAV(1)+.5D0 NC2=VIDNOW(1)+.5D0 IST1=0 IST2=0 IBOUND=0 DO 56 L=1,NISTRS IF(VFTYPE.LE.34) THEN IBOUND=IBOUND+IX(I) ELSE KK=IX(I) DO 55 K=1,KK IBOUND=IBOUND+IX(J) J=J+1 55 CONTINUE END IF IF(IST1.EQ.0.AND.IBOUND.GE.NC1)IST1=L IF(IST2.EQ.0.AND.IBOUND.GE.NC2)IST2=L I=I+1 56 CONTINUE IF(IST1.NE.IST2)STCHNG=.TRUE. END IF IF(STCHNG) THEN WRITE(UNIT=USTRT,ERR=972)(VIDSAV(I),I=1,NID) CALL UNFOUT(USTRT,DX(SDTOT2),TSIZE) DO 60 I=SDTOT2,SDTOT2+TSIZE-1 DX(I)=0. 60 CONTINUE END IF END IF C C Similarly, check if the second-stage has changed. C IF(USNDS.GT.0) THEN SNCHNG=.FALSE. IF(ENDF12.OR.BYCHNG) THEN SNCHNG=.TRUE. ELSE IF(VFTYPE.GE.21.AND.VFTYPE.LE.28) THEN IF(DABS(VIDSAV(2)-VIDNOW(2)).GT..1D-5)SNCHNG=.TRUE. ELSE IF(VFTYPE.GE.29.AND.VFTYPE.LE.32) THEN IF(DABS(VIDSAV(1)-VIDNOW(1)).GT..1D-5)SNCHNG=.TRUE. ELSE IF(VFTYPE.GE.35.AND.VFTYPE.LE.38) THEN J=SISNDS NC1=VIDSAV(1)+.5D0 NC2=VIDNOW(1)+.5D0 IST1=0 IST2=0 IBOUND=0 DO 61 L=1,NISNDS IBOUND=IBOUND+IX(J) J=J+1 IF(IST1.EQ.0.AND.IBOUND.GE.NC1)IST1=L IF(IST2.EQ.0.AND.IBOUND.GE.NC2)IST2=L I=I+1 61 CONTINUE IF(IST1.NE.IST2)STCHNG=.TRUE. END IF IF(SNCHNG) THEN WRITE(UNIT=USNDS,ERR=973)(VIDSAV(I),I=1,NID) CALL UNFOUT(USNDS,DX(SDTOT3),TSIZE) DO 62 I=SDTOT3,SDTOT3+TSIZE-1 DX(I)=0. 62 CONTINUE END IF END IF IF(BYCHNG.OR.ENDF12) THEN NBYGRP=NBYGRP+1 NCCLUS=1 IF(UTOT.GT.0) THEN WRITE(UNIT=UTOT,ERR=974)(VIDSAV(I),I=1,NID) CALL UNFOUT(UTOT,DX(SDTOT),TSIZE) DO 64 I=SDTOT,SDTOT+TSIZE-1 DX(I)=0. 64 CONTINUE END IF END IF IF(ENDF12)GO TO 90 ELSE IF(ENDF12) THEN CALL FESTOP(34003) ELSE RFIRST=.FALSE. END IF END IF C C This else covers types 5-12 (replicate weights/factors) C ELSE IF(.NOT.RFIRST.OR.ENDF12.OR.BYCHNG) THEN IF(NCCLUS.EQ.1) THEN NBYGRP=NBYGRP+1 IF(UIDS.GT.0.AND.NID.GT.1) THEN WRITE(UNIT=UIDS,ERR=975)(VIDSAV(K),K=2,NID) END IF END IF DO 65 I=1,NDMX VIDSAV(1)=DNCLUS+DBLE(I-1) WRITE(UNIT=UCLUS,ERR=971)(VIDSAV(K),K=1,NIDOUT) J=SDCLUS+(I-1)*TSIZE CALL UNFOUT(UCLUS,DX(J),TSIZE) 65 CONTINUE DO 66 I=SDCLUS,IUPPER DX(I)=0. 66 CONTINUE IF(ENDF12) THEN NCCLUS=NCCLUS+NDMX DNCLUS=DNCLUS+DBLE(NDMX) IF(NCCLUS.GT.NRPT1)GO TO 90 IF(NCCLUS+NDMX-1.GT.NRPT1) THEN NDMX=NRPT1-NCCLUS+1 END IF C C On end of file, loop through commands to update. C IF(NRECOD.GT.0) THEN I=1 67 CONTINUE C C INPUT, rewind unit and set number read to 0 C IF(RCTYPE(I).GE.40.AND.RCTYPE(I).LE.42) THEN REWIND(UNIT=V1(I)) V2(I)=0 C C IDCHANGE, store missing for previous IDs C ELSE IF(RCTYPE(I).EQ.62.OR.RCTYPE(I).EQ.142) THEN DO 671 ITMP=1,RSTPNT(I) DX(V3(I+ITMP))=-98765.432109D0 671 CONTINUE I=I+RSTPNT(I) C C PRINT C ELSE IF(RCTYPE(I).EQ.63) THEN V2(I)=0 END IF I=I+1 IF(I.LE.NRECOD)GO TO 67 END IF RFIRST=.TRUE. GO TO 29 END IF ELSE RFIRST=.FALSE. END IF END IF IF(NID.GT.0) THEN DO 69 I=1,NID VIDSAV(I)=VIDNOW(I) 69 CONTINUE END IF END IF C C If the current observation is to be dropped, return to 30 C IF(IXDROP) GO TO 30 IBASE1=0 J=SDCLUS IS=SIINCR C C Compute index to account for all global class variables. If C any are out of range, return to 30. IBASE1 is used as a C starting point in computations below. C IF(BLNCLS(1).GE.1) THEN DO 71 I=1,BLNCLS(1) IV1=VMAPL(CLTYPE(I)) IV2=DX(IV1) IF(IV2.LE.0)GO TO 30 IBASE1=IBASE1+IX(IS)*(IV2-1) IS=IS+1 71 CONTINUE END IF C C Add in contribution of this observation, for types 1-4, 13+ C IF(VFTYPE.LT.5.OR.VFTYPE.GT.12) THEN IF(MOD(VFTYPE,2).EQ.1.OR.VROPTN.EQ.2) THEN IF(MOD(VFTYPE,2).EQ.0) THEN WGT=1.0D0 ELSE WGT=DX(LWGT) END IF IF(VROPTN.EQ.2.AND.NCCLUS.GT.1)WGT=2.D0*WGT IF(WGT.NE.0.) THEN C C The loop to 75 considers each block and determines whether the C observation is still included. C DO 75 ICLBLK=1,NCLBLK IBASE=IBASE1 IF(ICLBLK.GT.1) THEN IF(BLNCLS(ICLBLK).GT.0) THEN DO 72 I=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1 IV1=VMAPL(CLTYPE(I)) IV2=DX(IV1) IF(IV2.LE.0) THEN IS=IS+BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-I GO TO 74 END IF IBASE=IBASE+IX(IS)*(IV2-1) IS=IS+1 72 CONTINUE END IF END IF KK=J+BLXINC(ICLBLK)*IBASE KL=SDVIN+BLXSTR(ICLBLK)-1 IF(DX(KL).EQ.0.)GO TO 74 DO 73 K=1,BLXINC(ICLBLK) IF(DX(KL).NE.0.) THEN DX(KK)=DX(KK)+WGT*DX(KL) END IF KK=KK+1 KL=KL+1 73 CONTINUE 74 CONTINUE J=J+BLXSIZ(ICLBLK) 75 CONTINUE END IF C C Treatment for unweighted data C Note: there is some overlap in algorithm compared to previous code C but this code is separated for efficient processing C ELSE DO 175 ICLBLK=1,NCLBLK IBASE=IBASE1 IF(ICLBLK.GT.1) THEN IF(BLNCLS(ICLBLK).GT.0) THEN DO 172 I=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1 IV1=VMAPL(CLTYPE(I)) IV2=DX(IV1) IF(IV2.LE.0) THEN IS=IS+BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-I GO TO 174 END IF IBASE=IBASE+IX(IS)*(IV2-1) IS=IS+1 172 CONTINUE END IF END IF KK=J+BLXINC(ICLBLK)*IBASE KL=SDVIN+BLXSTR(ICLBLK)-1 IF(DX(KL).EQ.0.)GO TO 174 DO 173 K=1,BLXINC(ICLBLK) IF(DX(KL).NE.0.) THEN DX(KK)=DX(KK)+DX(KL) END IF KK=KK+1 KL=KL+1 173 CONTINUE 174 CONTINUE J=J+BLXSIZ(ICLBLK) 175 CONTINUE END IF C C Treatment for VFTYPE 5-12 C ELSE DO 77 I=1,NDMX J=I+NCCLUS-2 IF(J.EQ.0) THEN IF(VFTYPE.EQ.5.OR.VFTYPE.EQ.7.OR.VFTYPE.EQ.11) THEN WGT=DX(LWGT) IF(VFTYPE.EQ.11)WGT=WGT*DX(IOUTL(IOUTC2+1)) ELSE WGT=1.0D0 END IF ELSE IF(VFTYPE.EQ.5.OR.VFTYPE.EQ.6.OR.VFTYPE.EQ.8) THEN WGT=DX(IOUTL(IOUTC2+J)) ELSE IF(VFTYPE.EQ.7) THEN WGT=DX(IOUTL(IOUTC2+J))*DX(LWGT) ELSE IF(VFTYPE.EQ.11) THEN WGT=DX(IOUTL(IOUTC2+J+1))*DX(LWGT) ELSE IF(VFTYPE.EQ.12) THEN WGT=DX(IOUTL(IOUTC2+J+1)) END IF IF(VROPTN.EQ.2)WGT=2.D0*WGT END IF DX(SDWGT+I-1)=WGT 77 CONTINUE I2=SDWGT+NDMX-1 J=SDCLUS DO 88 ICLBLK=1,NCLBLK IBASE=IBASE1 IF(ICLBLK.GT.1) THEN IF(BLNCLS(ICLBLK).GT.0) THEN DO 81 I=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1 IV1=VMAPL(CLTYPE(I)) IV2=DX(IV1) IF(IV2.LE.0) THEN IS=IS+BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-I GO TO 87 END IF IBASE=IBASE+IX(IS)*(IV2-1) IS=IS+1 81 CONTINUE END IF END IF KK=J+BLXINC(ICLBLK)*IBASE KL=SDVIN+BLXSTR(ICLBLK)-1 IF(DX(KL).EQ.0.)GO TO 87 DO 84 K=1,BLXINC(ICLBLK) IF(DX(KL).NE.0.) THEN TEMP=DX(KL) IBASE2=KK DO 83 I=SDWGT,I2 C C Possible optimization if many replicate weights are zero C C IF(DX(I).EQ.0.)GO TO 82 C DX(IBASE2)=DX(IBASE2)+DX(I)*TEMP 82 CONTINUE IBASE2=IBASE2+TSIZE 83 CONTINUE END IF KK=KK+1 KL=KL+1 84 CONTINUE 87 CONTINUE J=J+BLXSIZ(ICLBLK) 88 CONTINUE END IF GO TO 30 C C We come here at end of all processing C 90 CONTINUE IF(UCLUS.EQ.11) THEN DONE=.TRUE. CLOSE(UNIT=11) END IF C C Close all input files C DO 91 IRECOD=1,NRECOD IF(RCTYPE(IRECOD).GE.40.AND.RCTYPE(IRECOD).LE.42) THEN CLOSE(UNIT=V1(IRECOD)) END IF 91 CONTINUE RETURN C C Error returns for output write error. C 971 CONTINUE UIDS=UCLUS GO TO 975 972 CONTINUE UIDS=USTRT GO TO 975 973 CONTINUE UIDS=USNDS GO TO 975 974 CONTINUE UIDS=UTOT GO TO 975 975 CONTINUE CALL FWSTOP(UIDS) END C C End of C4.for C SUBROUTINE CREAT3(DONE) IMPLICIT DOUBLE PRECISION (A-H,O-Z) LOGICAL DONE PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (IXFLLD=19) PARAMETER (MAXFMT=20) C C MVAR represents the maximum number of incoming and created C variables, replicate factors and wts C MAXIDS is the maximum number of class variables C MRECOD is the maximum of variables transformed by CLASS, CAT C MISSING, SELECT, BY etc. C MRANGE is the maximum number of ranges C MRNSET is the maximum number of sets of ranges C MLEVEL is the maximum number of stored labels for levels C MCLBLK is the maximum number of class blocks C MCLBAR is the maximum number of cells of class block arrays C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT C C NVTOT (NTOTV) C NVREG (IOUTC1) C NVARID (NID1) C INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1, . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX C DOUBLE PRECISION RANGE(2,MRANGE) INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET), . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD), . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI) C COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP, . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO, . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS, . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT, . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS, . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO, . NLEVEL,NRNSET,NRANGE,NHADAM,IXFILL INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS, . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN, . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IXFILL(IXFLLD) C LOGICAL ENDF12 DOUBLE PRECISION VIDNOW(MAXIDS),VIDSAV(MAXIDS) INTEGER UOUT,SISTR2,SISND2,SDBLST LOGICAL ICHECK EXTERNAL ICHECK C 102 FORMAT(/,5X,' Maximum stratum number is',I6) 103 FORMAT(/,5X,I6,' strata observed on incoming file') 104 FORMAT(/,5X,I6,' second-stage units observed on incoming file') 201 FORMAT(/,' STRATUM NUMBER ',D20.12,' IS NOT AN INTEGER') 202 FORMAT(/,' MAXIMUM STRATUM NUMBER ',I8,' EXCEEDS EXPECTED',I5) 203 FORMAT(/,5X,'ONLY ',I5,' STRATA OBSERVED FROM EXPECTED',I6) 204 FORMAT(/,' OSBERVED STRATA ',I5,' EXCEEDS EXPECTED',I5) 205 FORMAT(/,' SECOND-STAGE NUMBER ',D20.12,' IS NOT AN INTEGER') 206 FORMAT(/,' CLUSTER NUMBER ',D20.12,' IS NOT AN INTEGER') 207 FORMAT(' OR IS OUT OF RANGE') 208 FORMAT(/,' IN STRATUM NUMBER',I3,' COUNT',I5,' OF UNITS EXCEEDS EX .PECTED',I5) 209 FORMAT(/,' OBSERVED SECOND-STAGE UNITS',I4,' EXCEEDS EXPECTED',I4) 210 FORMAT(/,' IN SECOND-STAGE NUMBER',I4,' COUNT',I5,' OF UNITS EXCEE .DS EXPECTED',I5) DONE=.FALSE. IF(UCLUS.GT.0.AND.UCLUS.NE.11)REWIND(UNIT=UCLUS) IF(USTRT.GT.0)REWIND(UNIT=USTRT) IF(USNDS.GT.0)REWIND(UNIT=USNDS) IF(UTOT.GT.0)REWIND(UNIT=UTOT) IF(UIDS.GT.0)REWIND(UNIT=UIDS) IF(UTOT.GT.0) THEN NXPTD=SDCLUS ELSE NXPTD=SDTOT+TSIZE END IF IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN C C If VFTYPE is 5-12, then UIDS will contain the values of the BY C variables defining the BY groups. These are written to the C output VPLX file here. C IF(NBY.GE.1) THEN WRITE(11)NBYGRP DO 2 I=1,NBYGRP READ(UNIT=UIDS)(VIDSAV(ID),ID=2,NID) WRITE(11)(VIDSAV(ID),ID=2,NID) 2 CONTINUE END IF C C If VFTYPE is 5-12 and UCLUS has been used, write NRPTOT and C the replicate factors to the output at this point. C For VROPTN=5, general replication, replicate factors have C already been provided. For VROPTN=2 or 3, half-sample C replication, compute them here. C IF(UCLUS.EQ.13.AND. . (VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5)) THEN WRITE(11)NRPTOT IF(VROPTN.EQ.5) THEN CALL UNFOUT(11,DX(SDCOEF),NRPTOT) ELSE IF(MSIZED-SDCLUS.LT.NRPTOT)CALL ROOMD(NRPTOT) DFACT=1.D0/DBLE(NRPTOT) DO 4 I=SDCLUS,SDCLUS+NRPTOT-1 DX(I)=DFACT 4 CONTINUE CALL UNFOUT(11,DX(SDCLUS),NRPTOT) END IF END IF C C If UCLUS=14, regroup replicates and write to 13 C If UCLUS=13 and VROPTN=2, 3, or 5, can write directly to C final output. If UCLUS=14, first summarize to UOUT=13. C IF(UCLUS.EQ.14.OR. . (UCLUS.EQ.13.AND. . (VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5))) THEN IF(UCLUS.EQ.14) THEN UOUT=13 NIDOUT=NID ELSE IF(UCLUS.EQ.13) THEN UOUT=11 NIDOUT=NIDTOT VIDSAV(NIDOUT-1)=0. VIDSAV(NIDOUT)=1. END IF C C Code added for 94.11 to increase efficiency for UCLUS=13 and large C NBYGRP C IF(UCLUS.EQ.13.AND.NBYGRP.GT.10) THEN NPER=DSQRT(DBLE(FLOAT(NBYGRP))) C C BY groups will be summarized to UIDS in groups of NPER C DO 60 I=1,NBYGRP,NPER IF(I.GT.1)REWIND (UNIT=UCLUS) REWIND(UNIT=UIDS) NCCLUS=1 NDMX=MDMX IF(NDMX.GT.NRPT1)NDMX=NRPT1 DO 53 IPASS=1,NPASS DO 52 J=1,NBYGRP DO 51 L=1,NDMX READ(UNIT=UCLUS)(VIDSAV(ID),ID=1,NID) CALL UNFIN(UCLUS,DX(SDCLUS),TSIZE,ENDF12) IF(J.GE.I.AND.J.LT.I+NPER) THEN WRITE(UNIT=UIDS)(VIDSAV(ID),ID=1,NIDOUT) CALL UNFOUT(UIDS,DX(SDCLUS),TSIZE) END IF 51 CONTINUE 52 CONTINUE NCCLUS=NCCLUS+NDMX IF(IPASS.EQ.NPASS-1) THEN IF(NCCLUS+NDMX-1.GT.NRPT1) THEN NDMX=NRPT1+1-NCCLUS END IF END IF 53 CONTINUE IF(I+NPER.GT.NBYGRP) THEN NPER1=NBYGRP-I+1 ELSE NPER1=NPER END IF C C From here to 58, the BY groups will now be extracted from UIDS C and placed onto UOUT C DO 58 II=1,NPER1 REWIND(UNIT=UIDS) NCCLUS=1 NDMX=MDMX IF(NDMX.GT.NRPT1)NDMX=NRPT1 DO 57 IPASS=1,NPASS DO 56 J=1,NPER1 DO 55 L=1,NDMX READ(UNIT=UIDS)(VIDSAV(ID),ID=1,NID) CALL UNFIN(UIDS,DX(SDCLUS),TSIZE,ENDF12) IF(J.EQ.II) THEN WRITE(UNIT=UOUT)(VIDSAV(ID),ID=1,NIDOUT) CALL UNFOUT(UOUT,DX(SDCLUS),TSIZE) END IF 55 CONTINUE 56 CONTINUE NCCLUS=NCCLUS+NDMX IF(IPASS.EQ.NPASS-1) THEN IF(NCCLUS+NDMX-1.GT.NRPT1) THEN NDMX=NRPT1+1-NCCLUS END IF END IF 57 CONTINUE 58 CONTINUE 60 CONTINUE ELSE C C The DO loop to 8 groups together the replicates for each BY C group. C DO 8 I=1,NBYGRP IF(I.GT.1)REWIND (UNIT=UCLUS) NCCLUS=1 NDMX=MDMX IF(NDMX.GT.NRPT1)NDMX=NRPT1 DO 7 IPASS=1,NPASS DO 6 J=1,NBYGRP DO 5 L=1,NDMX READ(UNIT=UCLUS)(VIDSAV(ID),ID=1,NID) CALL UNFIN(UCLUS,DX(SDCLUS),TSIZE,ENDF12) IF(J.EQ.I) THEN WRITE(UNIT=UOUT)(VIDSAV(ID),ID=1,NIDOUT) CALL UNFOUT(UOUT,DX(SDCLUS),TSIZE) END IF 5 CONTINUE 6 CONTINUE NCCLUS=NCCLUS+NDMX IF(IPASS.EQ.NPASS-1) THEN IF(NCCLUS+NDMX-1.GT.NRPT1) THEN NDMX=NRPT1+1-NCCLUS END IF END IF 7 CONTINUE 8 CONTINUE END IF C C If UCLUS=13, the completed output has been written to 11. C If UCLUS=14, the output to 13 is now ready for a second C level of summarization. C IF(UCLUS.EQ.13) THEN CLOSE(11) DONE=.TRUE. RETURN ELSE REWIND(13) REWIND(14) UCLUS=13 END IF END IF C C The code from here to 20 handles two circumstances: C VROPTN = 2, 3, or 5, and a summary has been created on 13 C The objective will be to calculate totals. C VROPTN = 1, 4, 6, 7, 8, in which case either SISTRS or C SISNDS > 0, or both. C The objective will be to create stratum C and/or second-stage totals. C DO 20 NC=1,NBYGRP I=SISTRS J=SISNDS IF(I.GT.0)IST1=IX(I) IF(J.GT.0)IST2=IX(J) DO 10 K=SDTOT,SDTOT+TSIZE-1 DX(K)=0. 10 CONTINUE IF(USTRT.GT.0) THEN DO 11 K=SDTOT2,SDTOT2+TSIZE-1 DX(K)=0. 11 CONTINUE END IF IF(USNDS.GT.0) THEN DO 12 K=SDTOT3,SDTOT3+TSIZE-1 DX(K)=0. 12 CONTINUE END IF DO 18 IREP=1,NRPTOT READ(UNIT=UCLUS)(VIDSAV(ID),ID=1,NID) CALL UNFIN(UCLUS,DX(SDCLUS),TSIZE,ENDF12) C C Aggregation of stratum totals C IF(USTRT.GT.0) THEN DO 13 K=1,TSIZE DX(SDTOT2+K-1)=DX(SDTOT2+K-1)+DX(SDCLUS+K-1) 13 CONTINUE IF(IREP.EQ.IST1) THEN WRITE(UNIT=USTRT)(VIDSAV(ID),ID=1,NID) CALL UNFOUT(USTRT,DX(SDTOT2),TSIZE) I=I+1 IF(IREP.LT.NRPTOT)IST1=IST1+IX(I) DO 14 K=SDTOT2,SDTOT2+TSIZE-1 DX(K)=0. 14 CONTINUE END IF END IF C C Aggregation of second-stage totals C IF(USNDS.GT.0) THEN DO 15 K=1,TSIZE DX(SDTOT3+K-1)=DX(SDTOT3+K-1)+DX(SDCLUS+K-1) 15 CONTINUE IF(IREP.EQ.IST2) THEN WRITE(UNIT=USNDS)(VIDSAV(ID),ID=1,NID) CALL UNFOUT(USNDS,DX(SDTOT3),TSIZE) J=J+1 IF(IREP.LT.NRPTOT)IST2=IST2+IX(J) DO 16 K=SDTOT3,SDTOT3+TSIZE-1 DX(K)=0. 16 CONTINUE END IF END IF C C Accumulate full-sample total, and write if required C DO 17 K=1,TSIZE DX(SDTOT+K-1)=DX(SDTOT+K-1)+DX(SDCLUS+K-1) 17 CONTINUE 18 CONTINUE IF(UTOT.GT.0) THEN WRITE(UNIT=UTOT)(VIDSAV(ID),ID=1,NID) CALL UNFOUT(UTOT,DX(SDTOT),TSIZE) DO 19 K=SDTOT,SDTOT+TSIZE-1 DX(K)=0. 19 CONTINUE END IF 20 CONTINUE REWIND(UNIT=UCLUS) IF(USTRT.GT.0)REWIND(UNIT=USTRT) IF(USNDS.GT.0)REWIND(UNIT=USNDS) IF(UTOT.GT.0)REWIND(UNIT=UTOT) IF(UIDS.GT.0)REWIND(UNIT=UIDS) ELSE C C For VFTYPE < 5 or VFTYPE > 12 C IF(NBY.GE.1) THEN C C If there are BY groups, build a single list of them, starting at C SDBLST, by reading them from UIDS. C WRITE(11)NBYGRP SDBLST=NXPTD K=(NID-NVARID)*NBYGRP CALL ROOMD(K) IBLST=SDBLST-NID+NVARID NVIDCM=0 C C Statement 21 begins the top of a loop to read the ids from UIDS. C The exit will be through reading the end of file, with transfer C to 35. Note that only the BY ids are being checked and saved, C differences in the VARIDS are being ignored. C 21 CONTINUE READ(UNIT=UIDS,END=35)(VIDNOW(ID),ID=1,NID) C C Check whether this BY group has already been stored. C IF(IBLST.GE.SDBLST) THEN DO 22 I=NVARID+1,NID IF(DABS(DX(IBLST-NVARID+I-1)-VIDNOW(I)).GT..1D-3) GO TO 23 22 CONTINUE C C If this BY group has already been stored, go to 25 C GO TO 25 END IF C C Come to 23 if this is a new BY group. Increment IBLST and output. C 23 CONTINUE IBLST=NBY+IBLST IF(IBLST.GE.NXPTD) THEN CALL FSTOP END IF DO 24 I=NVARID+1,NID DX(IBLST-NVARID+I-1)=VIDNOW(I) 24 CONTINUE WRITE(11)(VIDNOW(I),I=NVARID+1,NID) 25 CONTINUE C C Whether or not the BY group is new, build up the cumulative C list of all variance IDS, across BY groups C IF(NVARID.EQ.0) GO TO 21 L=NXPTD-1 IF(NVIDCM.GT.0) THEN DO 28 K=1,NVIDCM DO 26 I=1,NVARID C C If the stored variance ID < the current ID, skip to the next. C IF(DX(L+I)-VIDNOW(I).LT.-.1D-3)GO TO 27 C C If the stored variance ID > the current ID, it should be C inserted into the list here. C IF(DX(L+I)-VIDNOW(I).GT..1D-3)GO TO 29 26 CONTINUE C C If there is an exact match to a previous ID, go to the next C input from UIDS. C GO TO 21 27 CONTINUE L=L+NVARID 28 CONTINUE END IF C C Come here to insert an ID in the list or to add it to the end. C 29 CONTINUE C C Check that there is still room to store the variance id C IF(NXPTD+(NVIDCM+1)*NVARID.GT.MSIZED) THEN K=NVARID*(NVIDCM+1) CALL ROOMD(K) END IF C C Compute the upper limit of the stored IDS. C If the new ID should be inserted into the list, first move C those above the spot where the new ID should be inserted. C L2=NXPTD+NVIDCM*NVARID-1 IF(L.LT.L2) THEN DO 30 I=L2,L+1,-1 DX(I+NVARID)=DX(I) 30 CONTINUE END IF C C Store the new ID C DO 31 I=1,NVARID DX(L+I)=VIDNOW(I) 31 CONTINUE NVIDCM=NVIDCM+1 C C Process the next record from UIDS C GO TO 21 ELSE C C If there are no BY groups, then building up the list of variance C IDS is simpler, since they need only be read in from UIDS. C NVIDCM=0 L=NXPTD 34 CONTINUE READ(UNIT=UIDS,END=35)(DX(I),I=L,L+NVARID-1) L=L+NVARID NVIDCM=NVIDCM+1 IF(L+NVARID.GT.MSIZED) THEN L=L+NVARID+1-NXPTD CALL ROOMD(L) END IF GO TO 34 END IF C C On arrival at 35, the matrix of variance IDS has been built up C in one of the two alternative paths above. Allocate space by a C call to ROOMD. C 35 CONTINUE K=NVARID*NVIDCM C C NXPTDS will save the beginning of the list of variance ids, which C is held in common and passed to CREAT4 C NXPTDS=NXPTD CALL ROOMD(K) C C The next IF condition considers all TYPEs with strata identified by C either a stratum code or number. C IF(VFTYPE.GE.15.AND.VFTYPE.LE.28) THEN C C NISTR2 builds up a count of unique stratum codes/numbers C NISTRM records the largest stratum number, for VFTYPES 15, 16, 21-24. C NISTR2=0 NISTRM=0 L=NXPTDS DO 36 I=1,NVIDCM IF(I.EQ.1) THEN NISTR2=NISTR2+1 ELSE IF(DABS(DX(L)-DX(L-NVARID)).GT..1D-3)NISTR2=NISTR2+1 END IF C C For stratum numbers, check that each is an integer. C IF(VFTYPE.EQ.15.OR.VFTYPE.EQ.16.OR. . (VFTYPE.GE.21.AND.VFTYPE.LE.24)) THEN IF(.NOT.ICHECK(DX(L),DVALUE)) THEN WRITE(U6,201)DX(L) CALL FSTOP ELSE IF(DVALUE.LT..5) THEN WRITE(U6,201)DX(L) WRITE(U6,207) CALL FSTOP ELSE IVALUE=DVALUE+.05 IF(IVALUE.GT.NISTRM)NISTRM=IVALUE END IF END IF L=L+NVARID 36 CONTINUE C C For VFTYPEs 15, 16, 21-24, confirm that observed stratum numbers C do not violate specified number of strata, NISTRS. C IF(NISTRM.GT.0) THEN IF(NISTRS.GT.0) THEN IF(NISTRM.GT.NISTRS) THEN WRITE(U6,202)NISTRM,NISTRS CALL FSTOP C C Print message if not all the expected strata observed. C ELSE IF(NISTR2.LT.NISTRS) THEN WRITE(U6,203)NISTR2,NISTRS NISTR2=NISTRS END IF ELSE IF(U5ECHO.GT.0)WRITE(U6,102)NISTRM NISTR2=NISTRM END IF C C For VFTYPEs 17-18, 25-28, based on stratum codes, observed count C must be consistent with any specification NISTRS C ELSE IF(NISTRS.GT.0) THEN IF(NISTR2.GT.NISTRS) THEN WRITE(U6,204)NISTR2,NISTRS CALL FSTOP ELSE IF(NISTR2.LT.NISTRS) THEN WRITE(U6,203)NISTR2,NISTRS CALL FSTOP END IF ELSE IF(U5ECHO.GT.0)WRITE(U6,103)NISTR2 END IF END IF END IF C C End of checks for VFTYPES 15-28 C C IF(VROPTN.NE.8) THEN IF(VROPTN.NE.6) THEN IF(NISTRS.EQ.0.AND.VFTYPE.LE.32) THEN C C VFTYPEs 15-28 all involve either strata or second-stage units C Define L such that the second-stage code or replicate number C is at L+1 within the matrix of IDS. C IF(VFTYPE.GE.15.AND.VFTYPE.LE.28) THEN L=NXPTDS N1=NVIDCM C C VFTYPES 1-4, 29-32 involve cluster codes or numbers only C Set both NISTRS=1, and NISTR2=1 C If half-sample or general replication, set L to the starting C location of the IDS; otherwise, offset L by 1 since no stratum C code will be present. C ELSE NISTRS=1 NISTR2=1 IF(VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5) THEN L=NXPTDS N1=NVIDCM-1 ELSE L=NXPTDS-1 N1=NVIDCM END IF IL=1 END IF C C Set SISTRS=SISTR2 and allocate NISTR2 space for counts C SISTRS=NXPTI CALL ROOMI(NISTR2) SISTR2=SISTRS C C For VFTYPES 33-38, governed by replicate numbers, allocate space for C a single count, offsetting L by 1 C ELSE IF(VFTYPE.GE.33) THEN SISTR2=NXPTI NISTR2=1 CALL ROOMI(NISTR2) IL=1 L=NXPTDS-1 N1=NVIDCM C C For VFTYPES 1-32, with NISTRS > 0, allocate NISTR2 of space, C Give L no offset C ELSE L=NXPTDS N1=NVIDCM SISTR2=NXPTI CALL ROOMI(NISTR2) END IF C C For all replication methods, initialize matrix to contain the C counts. C DO 37 I=SISTR2,SISTR2+NISTR2-1 IX(I)=0 37 CONTINUE C C Loop over the matrix of stored IDS. C DO 38 I=1,N1 C C For stratum numbers, set IL to the actual value read C IF(VFTYPE.EQ.15.OR.VFTYPE.EQ.16.OR. . (VFTYPE.GE.21.AND.VFTYPE.LE.24)) THEN IL=DX(L)+.05 C C For stratum codes, start IL at 1 and increment for each change over C .1D-3 C ELSE IF(VFTYPE.GE.17.AND.VFTYPE.LE.28) THEN IF(I.EQ.1) THEN IL=1 ELSE IF(DABS(DX(L)-DX(L-NVARID)).GT..1D-3) THEN IL=IL+1 END IF END IF IF(VFTYPE.EQ.21.OR.VFTYPE.EQ.22.OR.VFTYPE.EQ.25.OR. . VFTYPE.EQ.26.OR.VFTYPE.EQ.29.OR.VFTYPE.EQ.30.OR. . VFTYPE.EQ.3.OR.VFTYPE.EQ.4.OR.VFTYPE.GE.33) THEN C C For VFTYPES 21, 22, 25, 26, 29, 30, 3, 4, 33-38, assure that the C second stage number/replicate number is an integer. C IF(.NOT.ICHECK(DX(L+1),DVALUE)) THEN IF(VFTYPE.GE.21.AND.VFTYPE.LE.30) THEN WRITE(U6,205)DX(L+1) ELSE WRITE(U6,206)DX(L+1) END IF CALL FSTOP C C For these types, also assure that the number is nonnegative, C and > 0 for VROPTN 1, 4, 6, and 7. C ELSE IF(DVALUE.LT.0..OR.(VROPTN.NE.2.AND.VROPTN.NE.3.AND. . VROPTN.NE.5.AND.DVALUE.LE..5D0)) THEN IF(VFTYPE.GE.21.AND.VFTYPE.LE.26) THEN WRITE(U6,205)DX(L+1) ELSE WRITE(U6,206)DX(L+1) END IF WRITE(U6,207) CALL FSTOP ELSE C C Build up the counts of second-stage units C IX(SISTR2+IL-1)=DX(L+1)+.05 END IF C C For second stage codes or cluster codes, build up counts C based on the change in codes. C ELSE IF(I.EQ.1) THEN IX(SISTR2+IL-1)=1 ELSE C C When we have a stratum code or number, check for a change in C either the stratum or second-stage C IF(VFTYPE.GE.15.AND.VFTYPE.LE.28) THEN IF(DABS(DX(L)-DX(L-NVARID)).GT..1D-3.OR. . DABS(DX(L+1)-DX(L-NVARID+1)).GT..1D-3) THEN IX(SISTR2+IL-1)=IX(SISTR2+IL-1)+1 END IF C C Without a stratum code/number, check only the second-stage C ELSE IF(DABS(DX(L+1)-DX(L-NVARID+1)).GT..1D-3) THEN IX(SISTR2+IL-1)=IX(SISTR2+IL-1)+1 END IF END IF END IF L=L+NVARID 38 CONTINUE C C If a replicate number is being used with half-sample or C general replication, reduce the count by 1 if the full-sample is C labelled with 1. C IF((VFTYPE.EQ.3.OR.VFTYPE.EQ.4).AND. . (VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5).AND. . DABS(DX(NXPTDS)-1.0D0).LT..1D-3)IX(SISTR2)=IX(SISTR2)-1 C C If counts within strata had been provided, assure that C observed count < or = to the specified count. C IF(SISTRS.NE.SISTR2.AND.VFTYPE.LE.32) THEN DO 39 I=1,NISTR2 IF(IX(SISTR2+I-1).GT.IX(SISTRS+I-1)) THEN WRITE(U6,208)I,IX(SISTR2+I-1),IX(SISTRS+I-1) CALL FSTOP END IF 39 CONTINUE END IF C C If NISTRS was previously unspecified, set it to the observed C count at this point. C IF(NISTRS.EQ.0)NISTRS=NISTR2 END IF C C For TYPES 21-28, count second-stage units within strata. C For TYPES 29-32, count clusters within second stage units. C IF(VFTYPE.GE.21.AND.VFTYPE.LE.32) THEN K=0 DO 41 I=SISTRS,SISTRS+NISTRS-1 K=K+IX(I) 41 CONTINUE C C If second stage counts have been specified, assure that C observed count < or = specified count. C IF(NISNDS.GT.0) THEN IF(K.GT.NISNDS) THEN WRITE(U6,209)K,NISNDS CALL FSTOP END IF SISND2=NXPTI CALL ROOMI(NISNDS) ELSE SISNDS=NXPTI NISNDS=K CALL ROOMI(NISNDS) IF(U5ECHO.GT.0)WRITE(U6,104)NISNDS SISND2=SISNDS END IF C C If a stratum code/number is present, offset L by 1 C IF(VFTYPE.LE.28) THEN L=NXPTDS+1 ELSE L=NXPTDS END IF C C Initialize the matrix of counts to 0. C DO 42 I=SISND2,SISND2+NISNDS-1 IX(I)=0 42 CONTINUE DO 46 I=1,NVIDCM C C For VFTYPES 21-24, derive the index IL from the stratum number C IF(VFTYPE.GE.21.AND.VFTYPE.LE.24) THEN IL=DX(L-1)+.05 C C For VFTYPES 25-28, derive IL from changes in the stratum code C ELSE IF(VFTYPE.LE.28) THEN IF(I.EQ.1) THEN IL=1 ELSE IF(DABS(DX(L-1)-DX(L-NVARID-1)).GT..1D-3) THEN IL=IL+1 END IF C C For other cases IL=1 C ELSE IL=1 END IF IS=0 C C If IL > 1, build up the count in IS for previous strata C IF(IL.GT.1) THEN DO 44 J=1,IL-1 IS=IS+IX(SISTRS+J-1) 44 CONTINUE END IF C C For VFTYPES 21, 22, 25, 26, 29, and 30, increment IS according C to the second-stage/cluster number. C IDINT is a standard function to convert double precision to C integer. C IF(VFTYPE.EQ.21.OR.VFTYPE.EQ.22.OR.VFTYPE.EQ.25.OR. . VFTYPE.EQ.26.OR.VFTYPE.EQ.29.OR.VFTYPE.EQ.30) THEN IS=IS+IDINT(DX(L)+.05) ELSE C C Otherwise, if using second-stage code, increment for changes in C the code. C If I=1, at first ID, so set IS=1 C IF(I.EQ.1) THEN IS=IS+1 C C Check first, for VFTYPE < 28, for changes in the stratum code/number C If different, increment IS by 1 C ELSE IF(VFTYPE.LE.28.AND.DABS(DX(L-1)-DX(L-NVARID-1)).GT. . .1D-3) THEN IS=IS+1 C C Otherwise, check whether this second-stage code is the same as last C time. C If not, set IS to IS1 + 1, where IS1 retains the last value of IS. C If so, set IS to the previous value C ELSE IF(DABS(DX(L)-DX(L-NVARID)).GT..1D-3) THEN IS=IS1+1 ELSE IS=IS1 END IF IS1=IS END IF C C Build up the count of second-stage units here. C IX(SISND2+IS-1)=IX(SISND2+IS-1)+1 L=L+NVARID 46 CONTINUE C C Check that the observed second-stage counts are not greater C than specified values. C IF(SISND2.NE.SISNDS) THEN DO 48 I=1,NISNDS IF(IX(SISND2+I-1).GT.IX(SISNDS+I-1)) THEN WRITE(U6,210)I,IX(SISND2+I-1),IX(SISNDS+I-1) CALL FSTOP END IF 48 CONTINUE END IF END IF IF(UIDS.GT.0)REWIND(UNIT=UIDS) END IF RETURN END SUBROUTINE CREAT4 IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (IXFLLD=19) PARAMETER (MAXFMT=20) C C MVAR represents the maximum number of incoming and created C variables, replicate factors and wts C MAXIDS is the maximum number of class variables C MRECOD is the maximum of variables transformed by CLASS, CAT C MISSING, SELECT, BY etc. C MRANGE is the maximum number of ranges C MRNSET is the maximum number of sets of ranges C MLEVEL is the maximum number of stored labels for levels C MCLBLK is the maximum number of class blocks C MCLBAR is the maximum number of cells of class block arrays C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT C C NVTOT (NTOTV) C NVREG (IOUTC1) C NVARID (NID1) C INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1, . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX C DOUBLE PRECISION RANGE(2,MRANGE) INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET), . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD), . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI) C COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP, . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO, . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS, . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT, . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS, . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO, . NLEVEL,NRNSET,NRANGE,NHADAM,IXFILL INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS, . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN, . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,IXFILL(IXFLLD) C LOGICAL ENDF12,BYCHNG,ENDCL,ENDSTR,ENDSND LOGICAL BYCSTR,BYCSND DOUBLE PRECISION VIDNOW(MAXIDS),VIDSAV(MAXIDS),VIDOUT(MAXIDS) DOUBLE PRECISION VIDSTR(MAXIDS),VIDSND(MAXIDS) DOUBLE PRECISION VIDCL(MAXIDS) DOUBLE PRECISION VIDSTL(MAXIDS),VIDSTH(MAXIDS) DOUBLE PRECISION VIDSNL(MAXIDS),VIDSNH(MAXIDS) INTEGER SISTR2,SISND2 LOGICAL USECL,USESTR,USESND,SKIPST,SKIPSN LOGICAL ICHECK EXTERNAL ICHECK C IF(VROPTN.NE.5) THEN SDCOEF=NXPTD CALL ROOMD(NRPTOT) END IF C C If no previous information is stored about strata, establish C a single stratum. C IF(SISTRS.EQ.0) THEN SISTRS=NXPTI NISTRS=1 CALL ROOMI(1) IF(SISNDS.GT.0) THEN IX(SISTRS)=NISNDS ELSE IF(NRPTOT.GT.0) THEN IX(SISTRS)=NRPTOT C C Just-in case check C ELSE CALL FSTOP END IF END IF C C For VFTYPE < 5 or VFTYPE > 12, set L to be the location of the C first ID (not counting full sample ID for half-sample/general C LU - upper bound on stored IDS C LINCR - increment to move through stored IDS C IF(VFTYPE.LE.4.OR.VFTYPE.GE.13) THEN IF(VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5) THEN L=NXPTDS+NVARID ELSE L=NXPTDS END IF LU=NXPTDS+NVARID*(NVIDCM-1) LINCR=NVARID C C For TYPE 5-12, set start L=1, upper limit LU=NRPTOT, and C increment LINCR = 1 C ELSE L=1 LU=NRPTOT LINCR=1 END IF C C Establish initial values for the extended loop to 15 over the C number of strata. C C L1L - lower bound for index wrt strata C L2L - lower bound for index wrt second-stage C SISTR2 - beginning of revised count of strata C SISND2 - if appropriate, beginning of revised count of second- C stage units. C NRPT - a revised count of replicates. C NSND - index used when second-stage units present, lower bound C NSND2 - upper bound above NSND C NC1 - index of clusters wrt old list starting with SISTRS C NC2 - index of clusters wrt new list starting with SISTR2 C L1L=L L2L=L SISTR2=NXPTI CALL ROOMI(NISTRS) NRPT=0 NSND=1 NSND2=1 IF(NISNDS.GT.0) THEN SISND2=NXPTI CALL ROOMI(NISNDS) END IF NC1=1 NC2=1 C C For half-sample/general, set NC1 to the full sample ID, which C might either be 1 or 0 C IF(VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5) THEN IF(VFTYPE.EQ.3.OR.VFTYPE.EQ.4)NC1=DX(NXPTDS)+.05D0 END IF DO 15 ISTR=1,NISTRS C C USESTR - boolean to indicate whether to use the stratum in C constructing replicates, set to .FALSE. if the finite population C correction is within .1D-12 of 1. C USESTR=.TRUE. C C Initially, set the revised stratum count to the current count, C but then revise for special condition below. C IX(SISTR2+ISTR-1)=IX(SISTRS+ISTR-1) IF(SDFPC1.GT.0) THEN IF(DABS(DX(SDFPC1+ISTR-1)).LT..1D-12)USESTR=.FALSE. END IF C C Add a second replicate if there is only a single hit within the C stratum. C IF(IX(SISTR2+ISTR-1).EQ.1.AND.USESTR) THEN IX(SISTR2+ISTR-1)=2 END IF C C NCU1 - upper index wrt the old list C NC1U=NC1+IX(SISTRS+ISTR-1)-1 C C NSND2 - upper index of second-stage units wrt the old list C IF(NISNDS.GT.0) THEN NSND2=NSND+IX(SISTRS+ISTR-1)-1 M=IX(SISTR2+ISTR-1) ELSE NC=IX(SISTR2+ISTR-1) END IF C C If stratum totals have been written to a file, find C L1U - the upper index C IF(USTRT.GT.0) THEN L1U=0 IF(L1L.LE.LU) THEN DO 2 I=L1L,LU,LINCR C C For TYPE=3,4 or > 32, can get LIU directly from stored code C IF(VFTYPE.LE.4.OR.VFTYPE.GE.33) THEN IF(DX(I).LE.DBLE(NC1U)+.05)L1U=I C C For TYPE 5-12, LIU can be obtained directly from NC1U C ELSE IF(VFTYPE.LE.12) THEN L1U=NC1U C C For TYPE 13, 14, based on cluster codes, and, in effect, a C single stratum, derive LIU from the number of observed C cluster codes. C ELSE IF(VFTYPE.LE.14) THEN L1U=L1L+LINCR*(IX(SISTRS+ISTR-1)-1) IF(L1U.GT.LU)L1U=LU C C For TYPE 15, 16, 21-24, based on stratum numbers, keep C setting L1U=I until the stored ID exceeds the current number of C the stratum. C ELSE IF(VFTYPE.LE.16.OR.(VFTYPE.GE.21.AND.VFTYPE.LE.24)) THEN IF(DX(I).LE.DBLE(ISTR)+.05)L1U=I C C For TYPEs 17-18, 25-28, based on stratum codes, keep setting C LIU=I until the stored ID differs from the stratum ID for the C current stratum. C ELSE IF(DABS(DX(I)-DX(L1L)).LT..1D-3)L1U=I END IF 2 CONTINUE END IF C C If L1U is equal to or greater than L1L, write lower and upper C limits to UIDS, else write -9876., the code for a missing stratum C IF(L1U.GE.L1L) THEN IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN VIDOUT(1)=L1L WRITE(UNIT=UIDS)VIDOUT(1) VIDOUT(1)=L1U WRITE(UNIT=UIDS)VIDOUT(1) ELSE WRITE(UNIT=UIDS)(DX(I),I=L1L,L1L+NVARID-1) WRITE(UNIT=UIDS)(DX(I),I=L1U,L1U+NVARID-1) DO 3 I=1,LINCR VIDOUT(I)=DX(L1U+I-1) 3 CONTINUE END IF ELSE DO 4 I=1,LINCR VIDOUT(I)=-9876. 4 CONTINUE WRITE(UNIT=UIDS)(VIDOUT(I),I=1,LINCR) WRITE(UNIT=UIDS)(VIDOUT(I),I=1,LINCR) END IF C C If there is not a stratum file, then set L1L and L1U to lower C and upper limits of the ID array. C ELSE L1L=L L1U=LU END IF C C In all cases, write the new stratum count to UIDS. C WRITE(UNIT=UIDS)IX(SISTR2+ISTR-1) C C Within this stratum, loop over second-stage units. C Note that NSND=NSND2=1 if USNDSS=0 C DO 12 ISND=NSND,NSND2 C C If second-stage totals have been written to a file, then C determine L2U by a logic similar to the definition of L1U, above C IF(USNDS.GT.0) THEN L2U=0 NC2U=NC2+IX(SISNDS+ISND-1)-1 IF(L2L.LE.L1U) THEN DO 5 I=L2L,L1U,LINCR C C For VFTYPE 3, 4, 33 - 38, get L2U directly from count C IF(VFTYPE.LE.4.OR.VFTYPE.GE.33) THEN IF(DX(I).LE.DBLE(NC2U)+.05)L2U=I C C For VFTYPE 5-12, get L2U from the count itself C ELSE IF(VFTYPE.LE.12) THEN IF(I.LE.NC2U)L2U=I C C For VFTYPE 13-14, based on the cluster code, compute L2U from the C stored count. C ELSE IF(VFTYPE.LE.14) THEN L2U=L2L+LINCR*(IX(SISNDS+ISND-1)-1) IF(L2U.GT.LU)L2U=LU C C For VFTYPE 21, 22, 25, 26, which use second stage numbers, get L2U C by comparing against the count in this stratum. C ELSE IF(VFTYPE.EQ.21.OR.VFTYPE.EQ.22.OR.VFTYPE.EQ.25.OR. . VFTYPE.EQ.26) THEN IF(DX(I+1).LE.DBLE(ISND-NSND+1)+.05)L2U=I C C For VFTYPE 23, 24, 27, 28, derive L2U as last matching second-stage C code. C ELSE IF(VFTYPE.EQ.23.OR.VFTYPE.EQ.24.OR.VFTYPE.EQ.27.OR. . VFTYPE.EQ.28) THEN IF(DABS(DX(I+1)-DX(L2L+1)).LE..1D-3)L2U=I C C For VFTYPE 29, 30, check against count, similar to handling of TYPES C 21, 22, 25, 26. C ELSE IF(VFTYPE.EQ.29.OR.VFTYPE.EQ.30) THEN IF(DX(I).LE.DBLE(ISND-NSND+1)+.05)L2U=I C C For VFTYPE 31, 32, derive L2U as last matching second-stage code. C ELSE IF(VFTYPE.EQ.31.OR.VFTYPE.EQ.32) THEN IF(DABS(DX(I)-DX(L2L)).LE..1D-3)L2U=I END IF 5 CONTINUE END IF C C IF L2U is greater than or equal to L2L, write out to UIDS, C similar to previous treatment of strata. C IF(L2U.GE.L2L) THEN IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN VIDOUT(1)=L2L WRITE(UNIT=UIDS)VIDOUT(1) VIDOUT(1)=L2U WRITE(UNIT=UIDS)VIDOUT(1) ELSE WRITE(UNIT=UIDS)(DX(I),I=L2L,L2L+NVARID-1) WRITE(UNIT=UIDS)(DX(I),I=L2U,L2U+NVARID-1) DO 6 I=1,LINCR VIDOUT(I)=DX(L2U+I-1) 6 CONTINUE END IF ELSE DO 7 I=1,LINCR VIDOUT(I)=-9876. 7 CONTINUE WRITE(UNIT=UIDS)(VIDOUT(I),I=1,LINCR) WRITE(UNIT=UIDS)(VIDOUT(I),I=1,LINCR) END IF C C Build up count of second-stage units actually to be used in C SISND2. Again, set this initially to the observed/specified C count. C IX(SISND2+ISND-1)=IX(SISNDS+ISND-1) USESND=.TRUE. IF(SDFPC1.GT.0) THEN C C If the stratum factor is 1.0 = (1-fpc1), C or if fpc2 = 1.0, or if fpc1 = 0.0 (not specified), C don't compute second-stage. C IF(DABS(DX(SDFPC1+ISTR-1)-1.D0).LT..1D-12) THEN USESND=.FALSE. ELSE IF(SDFPC2.GT.0) THEN IF(DABS(DX(SDFPC2+ISND-1)).LT..1D-12) USESND=.FALSE. END IF ELSE USESND=.FALSE. END IF C C If there is a single second-stage unit to be used in variance C calculation, create a second "phantom" unit, in the same manner C as a single hit within stratum, previously. C IF(USESND.AND.IX(SISND2+ISND-1).EQ.1)IX(SISND2+ISND-1)=2 NC=IX(SISND2+ISND-1) WRITE(UNIT=UIDS)NC ELSE C C If there is no second-stage file, simply set L2L and L2U to the full C first-stage limits. Don't write anything to UIDS, yet. C L2L=L1L L2U=L1U USESND=.FALSE. END IF C C NC, the number of units within the stratum, is either based C on the revised number of second-stage units (about 8 lines above) C or the number of clusters within the stratum (just after the C beginning of this loop to 15 C DO 10 J=1,NC USECL=.FALSE. C C For VFTYPEs 5 - 12, base the inclusion of the cluster on the count C IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN IF(J+L2L-1.LE.L2U)USECL=.TRUE. C C For VFTYPEs 3-4, check the match on the cluster number C ELSE IF(VFTYPE.EQ.3.OR.VFTYPE.EQ.4) THEN IF(DX(L).LE.DBLE(J)+.05)USECL=.TRUE. C C For VFTYPEs 13-38, check based on L in the range L2L-L2U C ELSE IF(L.GE.L2L.AND.L.LE.L2U)USECL=.TRUE. END IF C C Handle two cases at this point: C Second-stage units with USESND = .TRUE. C No second-stage units, but USESTR = .TRUE. C IF((NISNDS.EQ.0.AND.USESTR).OR.(NISNDS.GT.0.AND.USESND)) THEN IF(NISNDS.GT.0) THEN IF(SDFPC1.GT.0) THEN IF(SDFPC2.GT.0) THEN IF(VROPTN.NE.8) THEN DX(SDCOEF+NRPT)=(1.-DX(SDFPC1+ISTR-1))* . DX(SDFPC2+ISND-1)*DBLE(NC-1)/DBLE(NC) ELSE DX(SDCOEF+NRPT)=(1.-DX(SDFPC1+ISTR-1))* . DX(SDFPC2+ISND-1)/(DBLE(NC)*DBLE(NC-1)) END IF ELSE IF(VROPTN.NE.8) THEN DX(SDCOEF+NRPT)=(1.-DX(SDFPC1+ISTR-1))*DBLE(NC-1) . /DBLE(NC) ELSE DX(SDCOEF+NRPT)=(1.-DX(SDFPC1+ISTR-1)) . /(DBLE(NC)*DBLE(NC-1)) END IF END IF ELSE IF(VROPTN.NE.8) THEN DX(SDCOEF+NRPT)=DBLE(NC-1)/DBLE(NC) ELSE DX(SDCOEF+NRPT)=1.D0/(DBLE(NC)*DBLE(NC-1)) END IF END IF ELSE IF(SDFPC1.GT.0.AND.VROPTN.NE.5) THEN C C Random group, with FPC1 C IF(VROPTN.EQ.7.OR.VROPTN.EQ.8) THEN DX(SDCOEF+NRPT)=DX(SDFPC1+ISTR-1)/(DBLE(NC-1)*DBLE(NC)) C C Half-sample, with FPC1 C ELSE IF(VROPTN.EQ.2.OR.VROPTN.EQ.3) THEN DX(SDCOEF+NRPT)=DX(SDFPC1+ISTR-1)/DBLE(NC) C C Jackknife, stratified jackknife, with FPC1 C ELSE DX(SDCOEF+NRPT)=DX(SDFPC1+ISTR-1)*DBLE(NC-1)/DBLE(NC) END IF ELSE IF(VROPTN.NE.5) THEN C C Random group C IF(VROPTN.EQ.7.OR.VROPTN.EQ.8) THEN DX(SDCOEF+NRPT)=1.D0/(DBLE(NC-1)*DBLE(NC)) C C Half-sample C ELSE IF(VROPTN.EQ.2.OR.VROPTN.EQ.3) THEN DX(SDCOEF+NRPT)=1.D0/DBLE(NC) C C Jackknife, stratified jackknife C ELSE DX(SDCOEF+NRPT)=DBLE(NC-1)/DBLE(NC) END IF END IF END IF C C Increment NRPT, the counter for created replicates C NRPT=NRPT+1 IF(NRPTOT.EQ.0)CALL ROOMD(1) END IF C C If USECL, write out ID to UIDS and increment L C else write out -9876. C IF(USECL) THEN IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN VIDOUT(1)=J+L2L-1 WRITE(UNIT=UIDS)VIDOUT(1) ELSE WRITE(UNIT=UIDS)(DX(I),I=L,L+LINCR-1) END IF L=L+LINCR ELSE VIDOUT(LINCR)=-9876. WRITE(UNIT=UIDS)(VIDOUT(ID),ID=1,LINCR) END IF C C End of loop over clusters C 10 CONTINUE C C If second-stage units, increment L2L at this point C IF(NISNDS.GT.0) THEN IF(L2U.GE.L2L)L2L=L2U+LINCR NC2=NC2+IX(SISNDS+ISND-1) END IF C C If no second-stage units or the stratum is to be skipped, C go to the end of the second-stage loop to 12 C IF(NISNDS.NE.0.AND.USESTR) THEN C C Create a replicate for the second-stage unit here as long C as FPC1 not 1.0. Note that M is the revised count of C second-stage units within the stratum, defined above C IF(SDFPC1.GT.0) THEN IF(DABS(DX(SDFPC1+ISTR-1)).LT..1D-12)GO TO 12 IF(VROPTN.NE.8) THEN DX(SDCOEF+NRPT)=DX(SDFPC1+ISTR-1)*DBLE(M-1)/DBLE(M) ELSE DX(SDCOEF+NRPT)=DX(SDFPC1+ISTR-1)/(DBLE(M)*DBLE(M-1)) END IF ELSE IF(VROPTN.NE.8) THEN DX(SDCOEF+NRPT)=DBLE(M-1)/DBLE(M) ELSE DX(SDCOEF+NRPT)=1.D0/(DBLE(M)*DBLE(M-1)) END IF END IF C C Increment NRPT, the counter for replicates C NRPT=NRPT+1 IF(NRPTOT.EQ.0)CALL ROOMD(1) END IF C C End of loop over second-stage units C 12 CONTINUE C C Increment NC1 and L1L here. C NC1=NC1+IX(SISTRS+ISTR-1) IF(USTRT.GT.0.AND.L1U.GE.L1L)L1L=L1U+LINCR C C If a single-second stage unit has been included in the variance C calculation, construct a second "phantom" unit here. (M=2 in C this case.) C IF(NISNDS.GT.0.AND.NSND.EQ.NSND2.AND.USESTR) THEN IF(SDFPC1.GT.0) THEN IF(DABS(DX(SDFPC1+ISTR-1)).LT..1D-12)GO TO 15 IF(VROPTN.NE.8) THEN DX(SDCOEF+NRPT)=DX(SDFPC1+ISTR-1)*DBLE(M-1)/DBLE(M) ELSE DX(SDCOEF+NRPT)=DX(SDFPC1+ISTR-1)/(DBLE(M)*DBLE(M-1)) END IF ELSE IF(VROPTN.NE.8) THEN DX(SDCOEF+NRPT)=DBLE(M-1)/DBLE(M) ELSE DX(SDCOEF+NRPT)=1.D0/(DBLE(M)*DBLE(M-1)) END IF END IF NRPT=NRPT+1 IF(NRPTOT.EQ.0)CALL ROOMD(1) C C For TYPES 21-28, preserve the previously stored stratum code C in writing the ID to UIDS C IF(VFTYPE.GE.21.AND.VFTYPE.LE.28) THEN ISTART=2 ELSE ISTART=1 END IF DO 14 ID=ISTART,LINCR VIDOUT(ID)=-9876. 14 CONTINUE WRITE(UNIT=UIDS)(VIDOUT(ID),ID=1,LINCR) WRITE(UNIT=UIDS)(VIDOUT(ID),ID=1,LINCR) C C No replicate clusters will be present C NCN=0 WRITE(UNIT=UIDS)NCN END IF IF(NISNDS.GT.0)NSND=NSND+IX(SISTRS+ISTR-1) C C End of loop over strata. C 15 CONTINUE C C Final number of replicates, NRPTOT, has been determined. C Write coefficients to VPLX file. C IF(VROPTN.NE.5) THEN NRPTOT=NRPT NXPTD=SDCOEF CALL ROOMD(NRPT) END IF WRITE(11)NRPTOT CALL UNFOUT(11,DX(SDCOEF),NRPTOT) NXPTD=SDTOT+TSIZE IF(USTRT.GT.0) CALL ROOMD(TSIZE) IF(USNDS.GT.0) CALL ROOMD(TSIZE) C C Read in first IDS from UCLUS C READ(UNIT=UCLUS)(VIDCL(I),I=1,NID) C C ENDCL - end of file on cluster file C BYCSTR - change in BY variables on stratum file C BYCSND - change in BY variables on second-stage file C ENDCL=.FALSE. BYCSTR=.FALSE. BYCSND=.FALSE. IBYGRP=1 20 CONTINUE DNCLUS=1. IF(UIDS.GT.0)REWIND(UNIT=UIDS) C C If stratum file, read ids and stratum tallies unless a change C in BY variables has occurred. C IF(USTRT.GT.0.AND.(VFTYPE.LE.4.OR.VFTYPE.GE.13)) THEN IF(.NOT.BYCSTR) THEN READ(UNIT=USTRT)(VIDSTR(I),I=1,NID) CALL UNFIN(USTRT,DX(SDTOT2),TSIZE,ENDF12) END IF ENDSTR=.FALSE. ELSE IF(USTRT.EQ.0) THEN ENDSTR=.TRUE. ELSE ENDSTR=.FALSE. END IF C C If second-stage file, read ids and second-stage tallies unless C a change in BY variables has occurred. C IF(USNDS.GT.0.AND.(VFTYPE.LE.4.OR.VFTYPE.GE.13)) THEN IF(.NOT.BYCSND) THEN READ(UNIT=USNDS)(VIDSND(I),I=1,NID) CALL UNFIN(USNDS,DX(SDTOT3),TSIZE,ENDF12) END IF ENDSND=.FALSE. ELSE IF(USNDS.EQ.0) THEN ENDSND=.TRUE. ELSE ENDSND=.FALSE. END IF C BYCHNG=.FALSE. BYCSTR=.FALSE. BYCSND=.FALSE. C C For half-sample/generalized, read in first replicate data and C set DNCLUS = 2 as the effective identifier of the replicate C IF((VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5).AND. . UCLUS.NE.11)THEN CALL UNFIN(UCLUS,DX(SDTOT),TSIZE,ENDCL) DNCLUS=2.D0 DO 22 ID=1,NID VIDSAV(ID)=VIDCL(ID) 22 CONTINUE READ(UNIT=UCLUS)(VIDCL(ID),ID=1,NID) ELSE IF(NBY.GE.1) THEN C C For jackknife/random group, if NBY > 0, then UTOT > 0, C read in full sample values for the BY group C READ(UNIT=UTOT)(VIDSAV(I),I=1,NID) CALL UNFIN(UTOT,DX(SDTOT),TSIZE,ENDF12) END IF C C Write out the IDS for the full sample, including any BY C variables. C DO 24 I=1,NIDTOT IF(I.LE.NVARID) THEN VIDOUT(I)=-9878 ELSE IF(I.LE.NID) THEN VIDOUT(I)=VIDSAV(I) ELSE VIDOUT(I)=1.D0 END IF 24 CONTINUE WRITE(11)(VIDOUT(I),I=1,NIDTOT) IF(VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5.OR.VROPTN.EQ.7) . VIDOUT(NID+1)=0. C C Write out the full sample values C CALL UNFOUT(11,DX(SDTOT),TSIZE) C C Partially replicate the logic of the DO loop to 15 above. C Indices NRPT, NSND, and NSND2 are used in the same way as before. C NRPT=0 NSND=1 NSND2=1 C C Loop over strata C DO 95 ISTR=1,NISTRS USESTR=.FALSE. SKIPST=.FALSE. IF(SDFPC1.GT.0) THEN IF(DABS(DX(SDFPC1+ISTR-1)).LT..1D-12)SKIPST=.TRUE. END IF C C If USTRT > 0, UIDS will contain records with lower and upper C bounds of IDS in the strata and the number of units C IF(USTRT.GT.0) THEN READ(UNIT=UIDS)(VIDSTL(I),I=1,LINCR) READ(UNIT=UIDS)(VIDSTH(I),I=1,LINCR) READ(UNIT=UIDS)NCS C C For VFTYPE 5-12, read stratum totals C IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN READ(UNIT=USTRT,END=34)(VIDSTR(ID),ID=1,NID) CALL UNFIN(USTRT,DX(SDTOT2),TSIZE,ENDSTR) USESTR=.TRUE. C C For other VFTYPEs, check whether ID stored in VIDSTL has the code C indicating missing stratum C ELSE IF(DABS(VIDSTL(LINCR)-9876.D0).LT..1D-3)GO TO 34 IF(ENDSTR.OR.BYCSTR)GO TO 34 26 CONTINUE C C Check the current IDs to determine if it falls within the range C for the stratum indicated on the file C DO 28 I=1,LINCR C C Go to 31 if the ID read from the stratum file falls below the C range indicated on UID C IF(VIDSTR(I)-VIDSTL(I).LT.-.1D-3) GO TO 31 C C Go to 34, and do not use the stratum, if the ID read from the C stratum file falls above the range indicated on UID C IF(VIDSTR(I)-VIDSTH(I).GT..1D-3) GO TO 34 28 CONTINUE C C If fall through to here, the ID on the stratum file falls within C the required range, so use it. C USESTR=.TRUE. GO TO 34 C C Come here to read next records from USTRT C 31 CONTINUE READ(UNIT=USTRT,END=33)(VIDSTR(ID),ID=1,NID) CALL UNFIN(USTRT,DX(SDTOT2),TSIZE,ENDSTR) C C Check for a change in BY variables on the stratum file. C IF(NVARID.LT.NID) THEN DO 32 ID=NVARID+1,NID IF(DABS(VIDSTR(ID)-VIDSAV(ID)).GT..1D-3) THEN BYCSTR=.TRUE. GO TO 34 END IF 32 CONTINUE END IF C C Try again to match to the current range of IDS C GO TO 26 33 CONTINUE ENDSTR=.TRUE. END IF ELSE C C If USTRT = 0, simply read number of units, NCS, from UIDS C READ(UNIT=UIDS)NCS END IF C 34 CONTINUE IF(VFTYPE.GE.33.AND.VFTYPE.LE.36) THEN VIDOUT(NID+2)=VIDSTL(1) VIDOUT(NID+3)=VIDSTH(1) END IF C C If NISNDS > 0, then set upper bound NSND2 to process NCS C second stage units in the following loop to 90. C NC is not set to a value yet, it will vary according to the C number of clusters within the second-stage unit. C IF(NISNDS.GT.0) THEN NSND2=NSND+NCS-1 ELSE C C If NISNDS = 0, NSND2 is not updated and the following loop to 90 C will be executed once C NC=NCS END IF C C Loop over second-stage units within the stratum. C DO 90 ISND=NSND,NSND2 SKIPSN=.FALSE. C C C IF(NISNDS.GT.0) THEN IF(SDFPC1.GT.0) THEN IF(DABS(DX(SDFPC1+ISTR-1)-1.D0).LT..1D-12) THEN SKIPSN=.TRUE. ELSE IF(SDFPC2.GT.0) THEN IF(DABS(DX(SDFPC2+ISND-1)).LT..1D-12) SKIPSN=.TRUE. END IF ELSE SKIPSN=.TRUE. END IF END IF USESND=.FALSE. IF(USNDS.GT.0)THEN READ(UNIT=UIDS)(VIDSNL(I),I=1,LINCR) READ(UNIT=UIDS)(VIDSNH(I),I=1,LINCR) READ(UNIT=UIDS)NCN NC=NCN IF(DABS(VIDSNL(LINCR)-9876.D0).LT..1D-3)GO TO 44 C C For VFTYPE 5-12, read stratum totals C IF(VFTYPE.GE.5.AND.VFTYPE.LE.12)THEN READ(UNIT=USNDS)(VIDSND(ID),ID=1,NID) CALL UNFIN(USNDS,DX(SDTOT3),TSIZE,ENDSND) USESND=.TRUE. C C For other VFTYPEs, check the current IDs to determine if it falls C within the range indicated on the second-stage file C ELSE IF(ENDSND.OR.BYCSND)GO TO 44 36 CONTINUE DO 38 I=1,LINCR C C Go to 41 if the ID read from the second-stage file falls below the C range indicated on UID C IF(VIDSND(I)-VIDSNL(I).LT.-.1D-3) GO TO 41 C C Go to 44, and do not use the second-stage unit, if the ID read C from the second-stage file falls above the range indicated on UID C IF(VIDSND(I)-VIDSNH(I).GT..1D-3) GO TO 44 38 CONTINUE C C If fall through to here, the ID on the second-stage file falls C within the required range, so use it. C USESND=.TRUE. GO TO 44 C C Come here to read next records from USNDS C 41 CONTINUE READ(UNIT=USNDS,END=43)(VIDSND(ID),ID=1,NID) CALL UNFIN(USNDS,DX(SDTOT3),TSIZE,ENDSND) C C Check for a change in BY variables on the second-stage file. C IF(NVARID.LT.NID) THEN DO 42 ID=NVARID+1,NID IF(DABS(VIDSND(ID)-VIDSAV(ID)).GT..1D-3) THEN BYCSND=.TRUE. GO TO 44 END IF 42 CONTINUE END IF C C Try again to match to the current range of IDS C GO TO 36 43 CONTINUE ENDSND=.TRUE. END IF END IF 44 CONTINUE IF(VFTYPE.GE.35.AND.VFTYPE.LE.38) THEN VIDOUT(NIDTOT-3)=VIDSNL(1) VIDOUT(NIDTOT-2)=VIDSNH(1) END IF C C The loop to 72 is over clusters within a stratum or second-stage C unit. C NC will be zero if the finite population correction within a C second-stage unit is 1. C IF(NC.EQ.0) GO TO 74 DO 72 J=1,NC USECL=.FALSE. READ(UNIT=UIDS)(VIDNOW(ID),ID=1,LINCR) DO 49 ID=1,LINCR VIDOUT(ID)=VIDNOW(ID) 49 CONTINUE C C Skip if the stratum is missing C IF(DABS(VIDNOW(LINCR)-9876.D0).LT..1D-3)GO TO 55 C C Check if in the same BY group C IF(ENDCL.OR.BYCHNG)GO TO 55 50 CONTINUE IF(NVARID.LT.NID) THEN DO 51 ID=NVARID+1,NID IF(DABS(VIDCL(ID)-VIDSAV(ID)).GT..1D-3) THEN BYCHNG=.TRUE. GO TO 55 END IF 51 CONTINUE END IF C C For VFTYPEs 5-12, determine if the cluster is within range C IF(VFTYPE.GE.5.AND.VFTYPE.LE.12) THEN IF(DNCLUS-VIDNOW(1).LT.-.1D-3)GO TO 53 IF(DNCLUS-VIDNOW(1).GT..1D-3)GO TO 55 C C For other VFTYPEs, check whether current ID falls within the C range C ELSE DO 52 ID=1,LINCR IF(VIDCL(ID)-VIDNOW(ID).LT.-.1D-3) GO TO 53 IF(VIDCL(ID)-VIDNOW(ID).GT..1D-3) GO TO 55 52 CONTINUE END IF USECL=.TRUE. GO TO 55 C C Come to 53 to read in another cluster C 53 CONTINUE CALL UNFIN(UCLUS,DX(SDCLUS),TSIZE,ENDCL) READ(UNIT=UCLUS,END=54)(VIDCL(ID),ID=1,NID) DNCLUS=DNCLUS+1.D0 C C Return to 50 to check the new cluster C GO TO 50 C C Come to 54 for end of file on UCLUS C 54 CONTINUE ENDCL=.TRUE. C C Come here under all circumstances C 55 CONTINUE C C Read in the cluster totals if the cluster is to be used C IF(USECL.AND..NOT.ENDCL) THEN CALL UNFIN(UCLUS,DX(SDCLUS),TSIZE,ENDCL) DNCLUS=DNCLUS+1.D0 END IF IF(USECL.AND..NOT.ENDCL.AND. . ((NISNDS.GT.0.AND..NOT.SKIPSN).OR. . (NISNDS.EQ.0.AND..NOT.SKIPST))) THEN C C Random group C IF(VROPTN.EQ.7) THEN F1=DBLE(NC) DO 57 K=1,TSIZE DX(SDCLUS+K-1)=F1*DX(SDCLUS+K-1) 57 CONTINUE VIDOUT(NIDTOT)=F1 C ELSE IF(USESND) THEN C C Cluster within second-stage unit C IF(VROPTN.NE.8) THEN F1=DBLE(NC) F2=1.0D0/(F1-1.0D0) DO 58 K=1,TSIZE DX(SDCLUS+K-1)=DX(SDTOT+K-1) . +F2*(DX(SDTOT3+K-1)-F1*DX(SDCLUS+K-1)) 58 CONTINUE IF(VFTYPE.LE.32) THEN VIDOUT(NIDTOT-2)=1.D0 ELSE IF(VFTYPE.EQ.35.OR.VFTYPE.EQ.36) THEN VIDOUT(NID+4)=1.D0 ELSE VIDOUT(NID+1)=1.D0 END IF VIDOUT(NIDTOT-1)=F1*F2 VIDOUT(NIDTOT)=0. ELSE F1=DBLE(NC) C F2=1.0D0/(F1-1.0D0) DO 582 K=1,TSIZE DX(SDCLUS+K-1)=DX(SDTOT+K-1) . -DX(SDTOT3+K-1)+F1*DX(SDCLUS+K-1) 582 CONTINUE IF(VFTYPE.LE.32) THEN VIDOUT(NIDTOT-2)=1.D0 ELSE IF(VFTYPE.EQ.35.OR.VFTYPE.EQ.36) THEN VIDOUT(NID+4)=1.D0 ELSE VIDOUT(NID+1)=1.D0 END IF VIDOUT(NIDTOT-1)=0. VIDOUT(NIDTOT)=F1 END IF ELSE IF(USESTR) THEN C C Cluster within stratum C IF(VROPTN.NE.8) THEN F1=DBLE(NCS) F2=1.D0/(F1-1.D0) DO 59 K=1,TSIZE DX(SDCLUS+K-1)=DX(SDTOT+K-1) . +F2*(DX(SDTOT2+K-1)-F1*DX(SDCLUS+K-1)) 59 CONTINUE IF(VFTYPE.LE.28) THEN VIDOUT(NID+2)=F1*F2 ELSE VIDOUT(NID+4)=F1*F2 END IF VIDOUT(NIDTOT)=0. ELSE F1=DBLE(NCS) DO 592 K=1,TSIZE DX(SDCLUS+K-1)=DX(SDTOT+K-1) . -DX(SDTOT2+K-1)+F1*DX(SDCLUS+K-1) 592 CONTINUE IF(VFTYPE.LE.28) THEN VIDOUT(NID+2)=0. ELSE VIDOUT(NID+4)=0. END IF VIDOUT(NIDTOT)=F1 END IF ELSE IF(VROPTN.NE.2.AND.VROPTN.NE.3.AND.VROPTN.NE.5) THEN C C Simple jackknife C F1=DBLE(NRPTOT) F2=1.D0/(F1-1.D0) DO 60 K=1,TSIZE DX(SDCLUS+K-1)=DX(SDTOT+K-1) . +F2*(DX(SDTOT+K-1)-F1*DX(SDCLUS+K-1)) 60 CONTINUE VIDOUT(NID+1)=F1*F2 VIDOUT(NID+2)=0. END IF C C Same conditions as above, but UCLUST = .FALSE. or ENDCL C ELSE IF((NISNDS.GT.0.AND..NOT.SKIPSN).OR. . (NISNDS.EQ.0.AND..NOT.SKIPST)) THEN C C For Half-sample or general replication, store zeros C IF(VROPTN.EQ.2.OR.VROPTN.EQ.3.OR.VROPTN.EQ.5.OR.VROPTN.EQ.7) . THEN DO 62 K=1,TSIZE DX(SDCLUS+K-1)=0. 62 CONTINUE IF(VROPTN.EQ.7)VIDOUT(NIDTOT)=NC C C If second-stage units, reweight second-stage total C ELSE IF(USESND) THEN IF(VROPTN.NE.8) THEN F2=1.0D0/(DBLE(NC)-1.D0) DO 63 K=1,TSIZE DX(SDCLUS+K-1)=DX(SDTOT+K-1) . +F2*DX(SDTOT3+K-1) 63 CONTINUE IF(VFTYPE.LE.32) THEN VIDOUT(NIDTOT-2)=1.D0 ELSE IF(VFTYPE.EQ.35.OR.VFTYPE.EQ.36) THEN VIDOUT(NID+4)=1.D0 ELSE VIDOUT(NID+1)=1.0D0 END IF VIDOUT(NIDTOT-1)=DBLE(NC)*F2 VIDOUT(NIDTOT)=0. ELSE DO 632 K=1,TSIZE DX(SDCLUS+K-1)=DX(SDTOT+K-1) . -DX(SDTOT3+K-1) 632 CONTINUE IF(VFTYPE.LE.32) THEN VIDOUT(NIDTOT-2)=1.D0 ELSE IF(VFTYPE.EQ.35.OR.VFTYPE.EQ.36) THEN VIDOUT(NID+4)=1.D0 ELSE VIDOUT(NID+1)=1.0D0 END IF VIDOUT(NIDTOT-1)=0. VIDOUT(NIDTOT)=DBLE(NC) END IF C C Else if strata, reweight stratum total C ELSE IF(USESTR.AND.USNDS.EQ.0) THEN IF(VROPTN.NE.8) THEN F2=1.0D0/(DBLE(NCS)-1.D0) DO 64 K=1,TSIZE DX(SDCLUS+K-1)=DX(SDTOT+K-1) . +F2*DX(SDTOT2+K-1) 64 CONTINUE IF(VFTYPE.LE.28) THEN VIDOUT(NID+2)=DBLE(NCS)*F2 ELSE VIDOUT(NID+4)=DBLE(NCS)*F2 END IF VIDOUT(NIDTOT)=0. ELSE DO 642 K=1,TSIZE DX(SDCLUS+K-1)=DX(SDTOT+K-1) . -DX(SDTOT2+K-1) 642 CONTINUE IF(VFTYPE.LE.28) THEN VIDOUT(NID+2)=0. ELSE VIDOUT(NID+4)=0. END IF VIDOUT(NIDTOT)=DBLE(NCS) END IF C C Else use full-sample value if replication involves stratum C or second-stage ids C ELSE IF(USTRT.GT.0.OR.USNDS.GT.0) THEN IF(VROPTN.NE.8) THEN DO 65 K=1,TSIZE DX(SDCLUS+K-1)=DX(SDTOT+K-1) 65 CONTINUE F2=1.0D0/(DBLE(NC)-1.D0) IF(USNDS.GT.0) THEN IF(VFTYPE.LE.32) THEN VIDOUT(NIDTOT-2)=1.D0 ELSE IF(VFTYPE.EQ.35.OR.VFTYPE.EQ.36) THEN VIDOUT(NID+4)=1.D0 ELSE VIDOUT(NID+1)=1.D0 END IF VIDOUT(NIDTOT-1)=DBLE(NC)*F2 VIDOUT(NIDTOT)=0. ELSE IF(VFTYPE.LE.28) THEN VIDOUT(NID+2)=DBLE(NC)*F2 ELSE VIDOUT(NID+4)=DBLE(NC)*F2 END IF VIDOUT(NIDTOT)=0. END IF ELSE DO 652 K=1,TSIZE DX(SDCLUS+K-1)=DX(SDTOT+K-1) 652 CONTINUE IF(USNDS.GT.0) THEN IF(VFTYPE.LE.32) THEN VIDOUT(NIDTOT-2)=1.D0 ELSE IF(VFTYPE.EQ.35.OR.VFTYPE.EQ.36) THEN VIDOUT(NID+4)=1.D0 ELSE VIDOUT(NID+1)=1.D0 END IF VIDOUT(NIDTOT-1)=0. VIDOUT(NIDTOT)=DBLE(NC) ELSE IF(VFTYPE.LE.28) THEN VIDOUT(NID+2)=0. ELSE VIDOUT(NID+4)=0. END IF VIDOUT(NIDTOT)=DBLE(NC) END IF END IF C C Simple jackknife C ELSE F2=DBLE(NC)/(DBLE(NC)-1.D0) DO 66 K=1,TSIZE DX(SDCLUS+K-1)=F2*DX(SDTOT+K-1) 66 CONTINUE VIDOUT(NID+1)=F2 VIDOUT(NID+2)=0. END IF ELSE GO TO 71 END IF 70 CONTINUE NRPT=NRPT+1 WRITE(11)(VIDOUT(ID),ID=1,NIDTOT) CALL UNFOUT(11,DX(SDCLUS),TSIZE) C C Cluster loop ends here C 71 CONTINUE IF(USECL.AND..NOT.ENDCL) THEN READ(UNIT=UCLUS,END=61)(VIDCL(ID),ID=1,NID) GO TO 72 61 CONTINUE ENDCL=.TRUE. END IF 72 CONTINUE 74 CONTINUE C C Check if need to generate replicate for second-stage variation C within stratum C IF(NISNDS.EQ.0.OR.SKIPST)GO TO 90 IF(VROPTN.NE.8) THEN F1=NCS F2=1.0D0/(F1-1.D0) VIDOUT(NIDTOT)=0. VIDOUT(NIDTOT-1)=0. IF(VFTYPE.LE.32) THEN VIDOUT(NIDTOT-2)=F1*F2 ELSE VIDOUT(NIDTOT-4)=F1*F2 END IF IF(USESND) THEN IF(USESTR) THEN DO 76 K=1,TSIZE DX(SDCLUS+K-1)=DX(SDTOT+K-1) . +F2*(DX(SDTOT2+K-1)-F1*DX(SDTOT3+K-1)) 76 CONTINUE ELSE DO 77 K=1,TSIZE DX(SDCLUS+K-1)=DX(SDTOT+K-1) . +F2*(DX(SDTOT+K-1)-F1*DX(SDTOT3+K-1)) 77 CONTINUE END IF ELSE IF(USESTR) THEN DO 78 K=1,TSIZE DX(SDCLUS+K-1)=DX(SDTOT+K-1) . +F2*DX(SDTOT2+K-1) 78 CONTINUE ELSE IF(USTRT.GT.0) THEN DO 795 K=1,TSIZE DX(SDCLUS+K-1)=DX(SDTOT+K-1) 795 CONTINUE ELSE F2=F1*F2 DO 79 K=1,TSIZE DX(SDCLUS+K-1)=F2*DX(SDTOT+K-1) 79 CONTINUE END IF ELSE F1=NCS VIDOUT(NIDTOT)=F1 VIDOUT(NIDTOT-1)=F1 IF(VFTYPE.LE.32) THEN VIDOUT(NIDTOT-2)=0. ELSE VIDOUT(NIDTOT-4)=0. END IF IF(USESND) THEN IF(USESTR) THEN DO 762 K=1,TSIZE DX(SDCLUS+K-1)=DX(SDTOT+K-1) . -DX(SDTOT2+K-1)+F1*DX(SDTOT3+K-1) 762 CONTINUE ELSE DO 772 K=1,TSIZE DX(SDCLUS+K-1)=F1*DX(SDTOT3+K-1) 772 CONTINUE END IF ELSE IF(USESTR) THEN DO 782 K=1,TSIZE DX(SDCLUS+K-1)=DX(SDTOT+K-1) . -DX(SDTOT2+K-1) 782 CONTINUE ELSE IF(USTRT.GT.0) THEN DO 7952 K=1,TSIZE DX(SDCLUS+K-1)=DX(SDTOT+K-1) 7952 CONTINUE ELSE F2=F1*F2 DO 792 K=1,TSIZE DX(SDCLUS+K-1)=0. 792 CONTINUE END IF END IF IF(NVARID.GT.0) THEN DO 81 ID=1,NVARID VIDOUT(ID)=VIDSNH(ID) 81 CONTINUE END IF WRITE(11)(VIDOUT(ID),ID=1,NIDTOT) CALL UNFOUT(11,DX(SDCLUS),TSIZE) C C End of loop over strata C 90 CONTINUE IF(NISNDS.GT.0)NSND=NSND+IX(SISTRS+ISTR-1) 95 CONTINUE C C Check to see if another BY group remains to be processed C IBYGRP=IBYGRP+1 IF(NBY.GE.1.AND.IBYGRP.LE.NBYGRP)GO TO 20 CLOSE(11) RETURN END SUBROUTINE RECODX(IXDROP,ENDF12) IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (IXFLLD=3) PARAMETER (MAXFMT=20) PARAMETER (MAXIXM=1000) INTEGER IXM(MAXIXM) REAL RXM(MAXIXM) LOGICAL ENDF,ENDF12,IOERR C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1, . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX C DOUBLE PRECISION RANGE(2,MRANGE) INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET), . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD), . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI) C COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP, . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO, . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS, . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT, . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS, . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO, . NLEVEL,NRNSET,NRANGE,NHADAM,SDHADM,SDOUTP,SDVID,SDVPIN,IREPL, . IREPH,IFILE,SDRFW,IPASS,METHOD,NFILES,SDROUT,NROUT,NMAX,IXFILL, . SDSTCK,MSDPTH INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS, . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN, . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,SDHADM,SDOUTP,SDVID, . SDVPIN,SDRFW,SDROUT,IXFILL(IXFLLD),SDSTCK,MSDPTH C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT LOGICAL IXDROP,ICHECK EXTERNAL ICHECK DOUBLE PRECISION MISSNG DATA MISSNG/-98765.432109D0/ C C Usage in this subroutine: C C BLXSTR - pointer for block to X matrix C BLXINC - length of the X matrix for a single combination C of the class variables in the block C BLXSIZ - total size of block data in X matrix (integer multiple C of BLXINC) C BLVSTR - Pointer to first variable in block on outgoing file C BLVSIZ - Number of variables in block C BLNCLS - number of class variables in block C BLCPNT - pointer for classes to CLTYPE C CLTYPE - used as pointers to class variables C 101 FORMAT(/,5X,'End of primary input file after obs #',I8) 102 FORMAT(/,5X,'I/O error on primary input file after obs #',I8) 103 FORMAT(/,5X,'End on unit',I3,' after obs #',11X,I8) 104 FORMAT(/,5X,'I/O error on unit',I3,' after obs #',I8) 105 FORMAT(/,5X,'Unit',I3,' at obs #',I8,' on end of primary file') 201 FORMAT(' MISMATCH OF KEYS, UNIT',I3,' OBS #',I8) 202 FORMAT(1X,A12,F20.4) 203 FORMAT(' REQUIRED MATCH') 204 FORMAT(' NONASCENDING KEYS ON UNIT',I3,' OBS #',I8) 205 FORMAT(/,' PREVIOUS OBSERVATION UNIT',I3,' OBS #',I8) 206 FORMAT(' PREMATURE END ON UNIT',I3,' OBS #',I8) 208 FORMAT(' MISMATCHING BY VAR(S)') 209 FORMAT(' EMPTY PRIMARY FILE') 210 FORMAT(' NONINTEGER ROW:',F20.4) 212 FORMAT(1X,A12,2F20.4) 213 FORMAT(' NEW VALUES OF BY VARIABLES FOR THE OBSERVATION') 221 FORMAT(' PRINT request',I5:) 222 FORMAT(6X,A12,F20.6,F10.0,2X,'Crossed real') 223 FORMAT(6X,A12,11X,'(M)') 224 FORMAT(6X,A12,F14.0,18X,'Categorical') 225 FORMAT(6X,A12,F14.0,18X,'Class') 226 FORMAT(6X,A12,F14.0,18X,'Crossed categorical') 230 FORMAT(6X,A12,F14.4,10X,A12,F14.4) C DO 32 I=1,NVIN MTYPE(I)=MTSTRT(I) IF(MTSTRT(I).EQ.2) THEN MSIZE(I)=2 ELSE MSIZE(I)=1 END IF 32 CONTINUE IRECOD=0 ISTACK=SDSTCK-2 1 CONTINUE IRECOD=IRECOD+1 2 CONTINUE IF(IRECOD.GT.NRECOD) THEN RETURN END IF IRC=RCTYPE(IRECOD) C C 100 = store (and push down stack) C 101 = load variable C 102 = add variable C 103 = subtract variable C 104 = multiply variable C 105 = divide variable C 106 = power variable C 108 = store with stack in place (for multiple stores) C 109 = go to when stack is 0 or missing C 111 = load constant C 112 = add constant C 113 = subtract constant C 114 = multiply constant C 115 = divide constant C 116 = power constant (noninteger) C 117 = power positive integer C 118 = power negative integer C 119 = square C 121 = or stack C 122 = and stack C 124 = LT stack C 125 = LE stack C 126 = EQ stack C 127 = NE stack C 128 = GT stack C 129 = GE stack C 130 = IN stack (compare stack to interval) C 132 = add stack C 133 = subtract stack C 134 = multiply stack C 135 = divide stack C 136 = power stack C 140 = apply function to stack C 141 = apply function to many in stack C 142 = IDCHANGE C 202 = add many to one C 203 = subtract " C 204 = multiply " C 205 = divide " C 206 = power " C 212 = add one to many C 213 = subtract " C 214 = multiply " C 215 = divide " C 216 = power " C 222 = add many to many C 223 = subtract " C 224 = multiply " C 225 = divide " C 226 = power " C C 250 = load value from VPLX file, 0 replicate C v1 v2 v3 rstpnt C vplxin v #classes C for each class: C v1 v2 v3 rstpnt C class/cat 0 offset increment C C 254 = loop to load values from VPLX files, replicate 1+ C v1 v2 v3 rstpnt C 1st rep # rep vplxin var #classes C for each class: C v1 v2 v3 rstpnt C class/cat 0 offset increment C C 255 = loop to store replicate values, replicate 1+ C v1 v2 C 1st rep # rep C C 256 = loop to load replicate values, replicate 1+ C v1 v2 C 1st rep # rep C C OR 1 1 C AND 2 2 C NOT 3 3 (implemented with PLACE and function) C LT 4 4 C LE 5 4 C EQ 6 4 C NE 7 4 C GT 8 4 C GE 9 4 C IN 10 4 C CHS 11 5 C + 12 5 C - 13 5 C * 14 6 C / 15 6 C ** 16 7 C IF(IRC.GE.100.AND.IRC.LT.200.AND..NOT.ENDF12) THEN IF(IRC.LE.108) THEN IV1=V1(IRECOD) JV1=VMAPL(IV1) IF(IRC.EQ.100.OR.IRC.EQ.108) THEN DX(JV1)=DX(ISTACK) IF(MTYPE(IV1).EQ.2) THEN DX(JV1+1)=DX(ISTACK+1) END IF IF(IRC.EQ.100) THEN ISTACK=ISTACK-2 END IF C write(*,*)irc,istack ELSE IF(IRC.EQ.101) THEN ISTACK=ISTACK+2 C write(*,*)irc,istack DX(ISTACK)=DX(JV1) IF(MTYPE(IV1).EQ.2) THEN DX(ISTACK+1)=DX(JV1+1) ELSE DX(ISTACK+1)=1.D0 END IF ELSE IF(DX(ISTACK+1).GT.0.) THEN IF(MTYPE(IV1).EQ.2.AND.DX(JV1+1).EQ.0.) THEN DX(ISTACK)=0. DX(ISTACK+1)=0. ELSE IF(IRC.EQ.102) THEN DX(ISTACK)=DX(ISTACK)+DX(JV1) ELSE IF(IRC.EQ.103) THEN DX(ISTACK)=DX(ISTACK)-DX(JV1) ELSE IF(IRC.EQ.104) THEN DX(ISTACK)=DX(ISTACK)*DX(JV1) ELSE IF(IRC.EQ.105) THEN IF(DX(JV1).EQ.0.) THEN DX(ISTACK)=0. DX(ISTACK+1)=0. ELSE DX(ISTACK)=DX(ISTACK)/DX(JV1) END IF ELSE IF(IRC.EQ.106) THEN C ! x**y IF(DX(ISTACK).LT.0.) THEN C ! negative x IF(ICHECK(DX(JV1),DVALUE)) THEN C ! integer y IF(DVALUE.LT.0) THEN J=DVALUE-.05D0 ELSE J=DVALUE+.05D0 END IF IF(J.EQ.(J/2)*2) THEN DX(ISTACK)=(DABS(DX(ISTACK)))**J ELSE K=(J/2)*2 IF(J.LT.0) THEN DX(ISTACK)=((DABS(DX(ISTACK)))**K)/DX(ISTACK) ELSE DX(ISTACK)=((DABS(DX(ISTACK)))**K)*DX(ISTACK) END IF END IF ELSE C ! noninteger y DX(ISTACK)=0 DX(ISTACK+1)=0 END IF ELSE IF(DX(ISTACK).EQ.0) THEN C ! x=0 IF(DX(JV1).LE.0.) THEN C ! y<=0 DX(ISTACK)=0 DX(ISTACK+1)=0 END IF ELSE DX(ISTACK)=DX(ISTACK)**DX(JV1) END IF END IF END IF END IF END IF ELSE IF(IRC.GE.111.AND.IRC.LE.119) THEN JV1=V1(IRECOD) IF(IRC.EQ.111) THEN ISTACK=ISTACK+2 C write(*,*)irc,istack DX(ISTACK)=DX(JV1) DX(ISTACK+1)=1.D0 ELSE IF(DX(ISTACK+1).GT.0.) THEN IF(IRC.EQ.112) THEN DX(ISTACK)=DX(ISTACK)+DX(JV1) ELSE IF(IRC.EQ.113) THEN DX(ISTACK)=DX(ISTACK)-DX(JV1) ELSE IF(IRC.EQ.114) THEN DX(ISTACK)=DX(ISTACK)*DX(JV1) ELSE IF(IRC.EQ.115) THEN IF(DX(JV1).EQ.0.) THEN DX(ISTACK)=0. DX(ISTACK+1)=0. ELSE DX(ISTACK)=DX(ISTACK)/DX(JV1) END IF ELSE IF(IRC.EQ.116) THEN C ! noninteger IF(DX(ISTACK).LT.0.) THEN C ! exponent DX(ISTACK)=0. DX(ISTACK+1)=0. ELSE IF(DX(ISTACK).GT.0.) THEN DX(ISTACK)=DX(ISTACK)**DX(JV1) ELSE IF(DX(JV1).LE.0.) THEN DX(ISTACK+1)=0. END IF ELSE IF(IRC.EQ.117.OR.IRC.EQ.118) THEN C ! positive 117 IF(DX(ISTACK).LT.0.) THEN C ! negative 118 IF(JV1.EQ.(JV1/2)*2) THEN C ! integer DX(ISTACK)=(DABS(DX(ISTACK)))**JV1 ELSE K=(JV1/2)*2 IF(IRC.EQ.118) THEN DX(ISTACK)=((DABS(DX(ISTACK)))**K)/DX(ISTACK) ELSE DX(ISTACK)=((DABS(DX(ISTACK)))**K)*DX(ISTACK) END IF END IF ELSE IF(DX(ISTACK).GT.0) THEN DX(ISTACK)=DX(ISTACK)**JV1 ELSE IF(JV1.LE.0) THEN DX(ISTACK+1)=0. END IF ELSE IF(IRC.EQ.119) THEN DX(ISTACK)=DX(ISTACK)*DX(ISTACK) END IF END IF END IF ELSE IF(IRC.GE.121.AND.IRC.LE.136.AND.IRC.NE.130) THEN ISTACK=ISTACK-2 IF(IRC.EQ.121) THEN IF((DX(ISTACK).NE.0..AND.DX(ISTACK+1).NE.0.).OR. . (DX(ISTACK+2).NE.0..AND.DX(ISTACK+3).NE.0.)) THEN DX(ISTACK)=1.D0 DX(ISTACK+1)=1.D0 ELSE IF(DX(ISTACK+1).NE.0..AND.DX(ISTACK+3).NE.0.) THEN DX(ISTACK)=0. DX(ISTACK+1)=1. ELSE DX(ISTACK)=0. DX(ISTACK+1)=0. END IF ELSE IF(DX(ISTACK+3).EQ.0.) THEN DX(ISTACK)=0. DX(ISTACK+1)=0 ELSE IF(DX(ISTACK+1).NE.0.) THEN IF(IRC.GT.130) THEN IF(IRC.EQ.132) THEN DX(ISTACK)=DX(ISTACK)+DX(ISTACK+2) ELSE IF(IRC.EQ.133) THEN DX(ISTACK)=DX(ISTACK)-DX(ISTACK+2) ELSE IF(IRC.EQ.134) THEN DX(ISTACK)=DX(ISTACK)*DX(ISTACK+2) ELSE IF(IRC.EQ.135) THEN IF(DX(ISTACK+2).EQ.0.) THEN DX(ISTACK)=0. DX(ISTACK+1)=0. ELSE DX(ISTACK)=DX(ISTACK)/DX(ISTACK+2) END IF ELSE IF(IRC.EQ.136) THEN IF(DX(ISTACK).LT.0.) THEN IF(ICHECK(DX(ISTACK+2),DVALUE)) THEN IF(DVALUE.LT.0) THEN J=DVALUE-.05D0 ELSE J=DVALUE+.05D0 END IF IF(J.EQ.(J/2)*2) THEN DX(ISTACK)=(DABS(DX(ISTACK)))**J ELSE K=(J/2)*2 IF(J.LT.0) THEN DX(ISTACK)=((DABS(DX(ISTACK)))**K)/DX(ISTACK) ELSE DX(ISTACK)=((DABS(DX(ISTACK)))**K)*DX(ISTACK) END IF END IF ELSE DX(ISTACK)=0 DX(ISTACK+1)=0 END IF ELSE DX(ISTACK)=DX(ISTACK)**DX(ISTACK+2) END IF END IF ELSE IF(IRC.EQ.122) THEN IF(DX(ISTACK).NE.0..AND.DX(ISTACK+2).NE.0) THEN DX(ISTACK)=1.D0 ELSE DX(ISTACK)=0. END IF ELSE IF(ICHECK(DX(ISTACK),DVALUE)) THEN DX(ISTACK)=DVALUE END IF IF(ICHECK(DX(ISTACK+2),DVALUE)) THEN DX(ISTACK+2)=DVALUE END IF DVALUE=0. IF(IRC.EQ.124) THEN IF(DX(ISTACK).LT.DX(ISTACK+2)) THEN DVALUE=1.D0 END IF ELSE IF(IRC.EQ.125) THEN IF(DX(ISTACK).LE.DX(ISTACK+2)) THEN DVALUE=1.D0 END IF ELSE IF(IRC.EQ.126) THEN IF(DX(ISTACK).EQ.DX(ISTACK+2)) THEN DVALUE=1.D0 END IF ELSE IF(IRC.EQ.127) THEN IF(DX(ISTACK).NE.DX(ISTACK+2)) THEN DVALUE=1.D0 END IF ELSE IF(IRC.EQ.128) THEN IF(DX(ISTACK).GT.DX(ISTACK+2)) THEN DVALUE=1.D0 END IF ELSE IF(IRC.EQ.129) THEN IF(DX(ISTACK).GE.DX(ISTACK+2)) THEN DVALUE=1.D0 END IF END IF DX(ISTACK)=DVALUE END IF END IF END IF ELSE IF(IRC.EQ.130) THEN IRNSET=RSTPNT(IRECOD) IRNGPT=RNGPNT(IRNSET) INRNG=NRNG(IRNSET) C C Range type C 1 value1 - value2 C 2 LOW - value C 3 value - HIGH C 4 LOW - HIGH C 5 MISSING C 6 value - n C DO 935 I=IRNGPT,IRNGPT+INRNG-1 IF(RTYPE(I).EQ.5) THEN IF(DX(ISTACK+1).NE.0.) GO TO 935 DX(ISTACK+1)=1.D0 ELSE IF(DX(ISTACK+1).EQ.0.) THEN GO TO 935 ELSE IF(RTYPE(I).EQ.1) THEN IF(DX(ISTACK).LT.RANGE(1,I).OR. . DX(ISTACK).GT.RANGE(2,I)) GO TO 935 ELSE IF(RTYPE(I).EQ.2) THEN IF(DX(ISTACK).GT.RANGE(2,I)) GO TO 935 ELSE IF(RTYPE(I).EQ.3) THEN IF(DX(ISTACK).LT.RANGE(1,I)) GO TO 935 END IF DX(ISTACK)=1.D0 GO TO 936 935 CONTINUE DX(ISTACK)=0. 936 CONTINUE ELSE IF(IRC.EQ.140.OR.IRC.EQ.141) THEN IF(IRC.EQ.140) THEN N=1 ELSE N=V2(IRECOD) END IF IS=ISTACK-2*N+2 DO 58 I=1,N IV1=V1(IRECOD) IF(IV1.EQ.8) THEN C ! MISSING IF(DX(IS+1).NE.0.) THEN DX(IS)=0. ELSE DX(IS)=1.D0 DX(IS+1)=1.D0 END IF ELSE IF(DX(IS+1).NE.0.) THEN IF(IV1.EQ.1) THEN C ! NOT IF(DX(IS).EQ.0.) THEN DX(IS)=1.D0 ELSE DX(IS)=0. END IF ELSE IF(IV1.EQ.2) THEN C ! - X DX(IS)=-DX(IS) ELSE IF(IV1.EQ.3) THEN C ! SQRT IF(DX(IS).GT.0.) THEN DX(IS)=DSQRT(DX(IS)) ELSE IF(DX(ISTACK).LT.0.) THEN DX(IS)=0. DX(IS+1)=0. END IF ELSE IF(IV1.EQ.4) THEN C ! ABS DX(IS)=DABS(DX(IS)) ELSE IF(IV1.EQ.5) THEN C ! LOG IF(DX(IS).GT.0.) THEN DX(IS)=DLOG(DX(IS)) ELSE DX(IS)=0. DX(IS+1)=0. END IF ELSE IF(IV1.EQ.6) THEN C ! EXP DX(IS)=DEXP(DX(IS)) ELSE IF(IV1.EQ.7) THEN C ! INT IF(ICHECK(DX(IS),DVALUE)) THEN DX(IS)=DVALUE ELSE DX(IS)=DVALUE END IF END IF END IF IS=IS+2 58 CONTINUE ELSE IF(IRC.EQ.142) THEN C ! IDCHANGE (as function) ISTACK=ISTACK+2 DX(ISTACK)=0. DX(ISTACK+1)=1.D0 DO 60 I=1,RSTPNT(IRECOD) IV1=V2(IRECOD+I) IF(DABS(DX(VMAPL(IV1))-DX(V3(IRECOD+I))).GT..1D-3) THEN DX(ISTACK)=1.D0 DO 59 II=1,RSTPNT(IRECOD) DX(V3(IRECOD+II))=DX(VMAPL(V2(IRECOD+II))) 59 CONTINUE GO TO 61 END IF 60 CONTINUE 61 CONTINUE IRECOD=IRECOD+RSTPNT(IRECOD) ELSE IF(IRC.EQ.109) THEN C ! GO TO on stack 0/missing ISTACK=ISTACK-2 IF(DX(ISTACK+2).EQ.0..OR.DX(ISTACK+3).EQ.0.) THEN IRECOD=V3(IRECOD) GO TO 2 END IF END IF GO TO 1 ELSE IF(IRC.GE.200.AND..NOT.ENDF12) THEN N=V2(IRECOD) IF(IRC.LE.209) THEN IS=ISTACK-2*N DO 50 I=1,N IF(DX(ISTACK+1).EQ.0.) THEN DX(IS)=0. DX(IS+1)=0. ELSE IF(DX(IS+1).NE.0.) THEN IF(IRC.EQ.202) THEN DX(IS)=DX(IS)+DX(ISTACK) ELSE IF(IRC.EQ.203) THEN DX(IS)=DX(IS)-DX(ISTACK) ELSE IF(IRC.EQ.204) THEN DX(IS)=DX(IS)*DX(ISTACK) ELSE IF(IRC.EQ.205) THEN IF(DX(ISTACK).EQ.0.) THEN DX(IS)=0. DX(IS+1)=0. ELSE DX(IS)=DX(IS)/DX(ISTACK) END IF ELSE IF(IRC.EQ.206) THEN IF(DX(IS).LT.0.) THEN IF(ICHECK(DX(ISTACK),DVALUE)) THEN IF(DVALUE.LT.0) THEN J=DVALUE-.05D0 ELSE J=DVALUE+.05D0 END IF IF(J.EQ.(J/2)*2) THEN DX(IS)=(DABS(DX(IS)))**J ELSE K=(J/2)*2 IF(J.LT.0) THEN DX(IS)=((DABS(DX(IS)))**K)/DX(IS) ELSE DX(IS)=((DABS(DX(IS)))**K)*DX(IS) END IF END IF ELSE DX(IS)=0 DX(IS+1)=0 END IF ELSE DX(IS)=DX(IS)**DX(ISTACK) END IF END IF END IF IS=IS+2 50 CONTINUE ISTACK=ISTACK-2 ELSE IF(IRC.LE.219) THEN ISB=ISTACK-2*N IS=ISB+2 DO 52 I=1,N IF(DX(ISB+1).EQ.0.) THEN DX(IS)=0. DX(IS+1)=0. ELSE IF(DX(IS+1).NE.0.) THEN IF(IRC.EQ.212) THEN DX(IS)=DX(ISB)+DX(IS) ELSE IF(IRC.EQ.213) THEN DX(IS)=DX(ISB)-DX(IS) ELSE IF(IRC.EQ.214) THEN DX(IS)=DX(ISB)*DX(IS) ELSE IF(IRC.EQ.215) THEN IF(DX(IS).EQ.0.) THEN DX(IS)=0. DX(IS+1)=0. ELSE DX(IS)=DX(ISB)/DX(IS) END IF ELSE IF(IRC.EQ.216) THEN IF(DX(ISB).LT.0.) THEN IF(ICHECK(DX(IS),DVALUE)) THEN IF(DVALUE.LT.0) THEN J=DVALUE-.05D0 ELSE J=DVALUE+.05D0 END IF IF(J.EQ.(J/2)*2) THEN DX(IS)=(DABS(DX(ISB)))**J ELSE K=(J/2)*2 IF(J.LT.0) THEN DX(IS)=((DABS(DX(ISB)))**K)/DX(ISB) ELSE DX(IS)=((DABS(DX(ISB)))**K)*DX(ISB) END IF END IF ELSE DX(IS)=0 DX(IS+1)=0 END IF ELSE DX(IS)=DX(ISB)**DX(IS) END IF END IF END IF IS=IS+2 52 CONTINUE IS=ISB+2 DO 54 I=1,N DX(ISB)=DX(IS) DX(ISB+1)=DX(IS+1) ISB=ISB+2 IS=IS+2 54 CONTINUE ISTACK=ISTACK-2 ELSE IF(IRC.LE.229) THEN IS=ISTACK-4*N+2 ISB=IS+2*N DO 56 I=1,N IF(DX(ISB+1).EQ.0.) THEN DX(IS)=0. DX(IS+1)=0. ELSE IF(DX(IS+1).NE.0.) THEN IF(IRC.EQ.222) THEN DX(IS)=DX(IS)+DX(ISB) ELSE IF(IRC.EQ.223) THEN DX(IS)=DX(IS)-DX(ISB) ELSE IF(IRC.EQ.224) THEN DX(IS)=DX(IS)*DX(ISB) ELSE IF(IRC.EQ.225) THEN IF(DX(ISB).EQ.0.) THEN DX(IS)=0. DX(IS+1)=0. ELSE DX(IS)=DX(IS)/DX(ISB) END IF ELSE IF(IRC.EQ.226) THEN IF(DX(IS).LT.0.) THEN IF(ICHECK(DX(ISB),DVALUE)) THEN IF(DVALUE.LT.0) THEN J=DVALUE-.05D0 ELSE J=DVALUE+.05D0 END IF IF(J.EQ.(J/2)*2) THEN DX(IS)=(DABS(DX(IS)))**J ELSE K=(J/2)*2 IF(J.LT.0) THEN DX(IS)=((DABS(DX(IS)))**K)/DX(IS) ELSE DX(IS)=((DABS(DX(IS)))**K)*DX(IS) END IF END IF ELSE DX(IS)=0 DX(IS+1)=0 END IF ELSE DX(IS)=DX(IS)**DX(ISB) END IF END IF END IF IS=IS+2 ISB=ISB+2 56 CONTINUE ISTACK=ISTACK-2*N C ELSE IF(IRC.EQ.250.OR.IRC.EQ.254) THEN IF(IRC.EQ.254) THEN NV=V2(IRECOD) MT=V1(IRECOD) END IF C C calculate the location in the VPLXIN file of the matching factor. C JV3=VMAPL(V3(IRECOD))+SDVPIN-1 K=RSTPNT(IRECOD) IF(K.GT.0) THEN DO 561 I=1,K IRECOD=IRECOD+1 JV1A=VMAPL(V1(IRECOD)) INDX=DX(JV1A)+.05 IF(INDX.EQ.0) THEN JV3=0 ELSE IF(JV3.GT.0) THEN IF(V3(IRECOD).EQ.1) THEN JV3=JV3+RSTPNT(IRECOD)*INDX ELSE JV3=JV3+RSTPNT(IRECOD)*(INDX-1) END IF END IF 561 CONTINUE END IF C C The following transfer was copied from analogous code to handle C IRC=50 through 57, but it is not clear that it is needed. C IF(ENDF12)GO TO 1 C C K=SDRFW+IREPL-1-NMAX C IF(IRC.EQ.250) THEN ISTACK=ISTACK+2 IF(JV3.EQ.0) THEN DX(ISTACK)=0. DX(ISTACK+1)=0. ELSE IF(DABS(DX(JV3)-MISSNG).LE..1D-6) THEN DX(ISTACK)=0. DX(ISTACK+1)=0. ELSE DX(ISTACK)=DX(JV3) DX(ISTACK+1)=1.D0 END IF ELSE C C MT is the index of the first replicate weight/factor to be operated on. C DO 562 I=MT,MT+NV-1 ISTACK=ISTACK+2 IF(I.LT.IREPL.OR.I.GT.IREPH.OR.JV3.EQ.0) THEN DX(ISTACK)=0. DX(ISTACK+1)=0. ELSE JV3T=JV3+TSIZE*(I-IREPL+1) IF(DABS(DX(JV3T)-MISSNG).LE..1D-6) THEN DX(ISTACK)=0. DX(ISTACK+1)=0. ELSE DX(ISTACK)=DX(JV3T) DX(ISTACK+1)=1.D0 END IF END IF 562 CONTINUE END IF ELSE IF(IRC.EQ.255) THEN NV=V2(IRECOD) MT=VMAPL(V1(IRECOD))-SDRFW+1 DO 563 I=MT+NV-1,MT,-1 C ! Unload stack in IF(I.GE.IREPL.AND.I.LE.IREPH) THEN C ! reverse order IF(DX(ISTACK+1).EQ.0.) THEN DX(I+SDRFW-1)=0. ELSE DX(I+SDRFW-1)=DX(ISTACK) END IF END IF ISTACK=ISTACK-2 563 CONTINUE ELSE IF(IRC.EQ.256) THEN NV=V2(IRECOD) MT=VMAPL(V1(IRECOD))-SDRFW+1 DO 564 I=MT,MT+NV-1 ISTACK=ISTACK+2 DX(ISTACK)=DX(I+SDRFW-1) DX(ISTACK+1)=1.D0 564 CONTINUE END IF GO TO 1 ELSE IF(IRC.EQ.36) THEN IRECOD=V3(IRECOD) GO TO 2 C C INPUT C ELSE IF(IRC.GE.40.AND.IRC.LE.42) THEN L=V3(IRECOD) K=V2(IRECOD+1) KF=RSTPNT(IRECOD+2) C ! INFLAG IF(KF.GT.0) THEN DX(VMAPL(KF))=1.D0 C ! Initialize INFLAG = 1 END IF 3 CONTINUE C C If keyed link, check for matching keys. C IF(RSTPNT(IRECOD).GT.0.AND.V2(IRECOD).GT.0.AND..NOT.ENDF12) THEN J=IRECOD+3 DO 7 I=1,RSTPNT(IRECOD) DIFFID=DX(V1(J))-DX(V2(J)) IF(DIFFID.LT.-.1D-03) THEN C C If DIFFID is significantly negative, go to 8 to read a record C from the input file C GO TO 8 C C If the KEY variable is higher on the LINK file, then either C print error message under LINK or set values to missing under C LINK_MISSING or to 0 if LINK and C ELSE IF(DIFFID.GT..1D-03) THEN C C Error message under LINK C IF(IRC.EQ.41.AND.KF.EQ.0) THEN WRITE(U6,201)V1(IRECOD),V2(IRECOD) J=IRECOD+3 DO 4 K=1,RSTPNT(IRECOD) WRITE(U6,202)VNAME(RSTPNT(J)),DX(V1(J)) J=J+1 4 CONTINUE WRITE(U6,203) J=IRECOD+3 DO 5 K=1,RSTPNT(IRECOD) WRITE(U6,202)VNAME(RSTPNT(J)),DX(V2(J)) J=J+1 5 CONTINUE CALL FESTOP(35001) C C Set values to missing under LINK_MISSING or =0 for INFLAG C ELSE IF(KF.GT.0) THEN DX(VMAPL(KF))=0. END IF DO 6 K=V1(IRECOD+1),V1(IRECOD+1)+L-1 II=IX(K) DX(VMAPL(II))=0. IF(IRC.EQ.42) THEN DX(VMAPL(II)+1)=0. END IF 6 CONTINUE C C Update IRECOD and process next transformation C IRECOD=IRECOD+2+RSTPNT(IRECOD) GO TO 1 END IF END IF J=J+1 7 CONTINUE GO TO 16 END IF 8 CONTINUE C C If end of file has not yet occurred, this section reads the next C record from the file. C IF(V2(IRECOD).GE.0) THEN C C Test for premature end of file for NOBS= specification C IF(V2(IRECOD+2).GT.0.AND.V2(IRECOD).GE.V2(IRECOD+2)) THEN ENDF=.TRUE. ELSE KV=V1(IRECOD+1) IF(V3(IRECOD+2).LE.1) THEN IF(RSTPNT(IRECOD+1).EQ.1) THEN CALL XREAD1(DX(K),L,V1(IRECOD),INFRMT(V3(IRECOD+1)), . ENDF,IOERR,V2(IRECOD),IX(KV),V1(IRECOD+2)) ELSE CALL XREAD(DX(K),L,V1(IRECOD),INFRMT(V3(IRECOD+1)), . RSTPNT(IRECOD+1),ENDF,IOERR,V2(IRECOD),IX(KV), . V1(IRECOD+2)) END IF ELSE IF(V3(IRECOD+2).EQ.3) THEN CALL XREADI(DX(K),IXM,L,V1(IRECOD),ENDF,IOERR,V2(IRECOD), . IX(KV),V1(IRECOD+2)) ELSE IF(V3(IRECOD+2).EQ.4) THEN CALL XREADR(DX(K),RXM,L,V1(IRECOD),ENDF,IOERR,V2(IRECOD), . IX(KV),V1(IRECOD+2)) ELSE IF(V3(IRECOD+2).EQ.5) THEN CALL XREADD(DX(K),L,V1(IRECOD),ENDF,IOERR,V2(IRECOD), . IX(KV),V1(IRECOD+2)) END IF END IF C C If error on read, then C 1) If primary file, set ENDF12=.TRUE., but terminate immediately C if no valid records have been read. C 2) If secondary file, terminate unless ENDF12 C IF(IOERR) THEN IF(IRC.EQ.40) THEN WRITE(U6,102)V2(IRECOD) ENDF12=.TRUE. IF(V2(IRECOD).EQ.0) THEN CALL FESTOP(35002) END IF ELSE WRITE(U6,104)V1(IRECOD),V2(IRECOD) IF(.NOT.ENDF12) THEN CALL FESTOP(35003) END IF END IF V2(IRECOD)=-1 GO TO 16 C C On end of file: C 1) If primary file, set ENDF12=.TRUE., but terminate immediately C if no valid records have been read. C 2) If secondary file, terminate under LINK unless ENDF12 C ELSE IF(ENDF) THEN IF(IRC.EQ.40) THEN IF(V2(IRECOD).EQ.0) THEN WRITE(U6,209) CALL FESTOP(35004) ELSE IF(U5ECHO.GT.0) THEN WRITE(U6,101)V2(IRECOD) END IF ENDF12=.TRUE. END IF ELSE IF((RSTPNT(IRECOD).EQ.0.OR.IRC.EQ.41).AND.KF.EQ.0.AND. . .NOT.ENDF12) THEN WRITE(U6,206)V1(IRECOD),V2(IRECOD) CALL FESTOP(35005) ELSE IF(U5ECHO.GT.0) THEN WRITE(U6,103)V1(IRECOD),V2(IRECOD) END IF END IF V2(IRECOD)=-1 GO TO 16 ELSE IF(ENDF12) THEN WRITE(U6,105)V1(IRECOD),V2(IRECOD) GO TO 16 END IF C C Check that matching keys have increased under LINK or LINK_MISSING C IF((IRC.EQ.41.OR.IRC.EQ.42).AND.RSTPNT(IRECOD).GT.0) THEN IF(V2(IRECOD).GT.0) THEN J=IRECOD+3 DO 10 KK=1,RSTPNT(IRECOD) DIFFID=DX(V1(J))-DX(V3(J)) IF(DIFFID.LT.-.1D-03) THEN GO TO 11 ELSE IF(DIFFID.GT..1D-03) THEN C C Transfer to 14 when keys have increased on file. C GO TO 14 END IF J=J+1 10 CONTINUE 11 CONTINUE KK=V2(IRECOD)+1 WRITE(U6,204)V1(IRECOD),KK J=IRECOD+3 DO 12 KK=1,RSTPNT(IRECOD) WRITE(U6,202)VNAME(RSTPNT(J)),DX(V1(J)) J=J+1 12 CONTINUE WRITE(U6,205)V1(IRECOD),V2(IRECOD) J=IRECOD+3 DO 13 K=1,RSTPNT(IRECOD) WRITE(U6,202)VNAME(RSTPNT(J)),DX(V3(J)) J=J+1 13 CONTINUE CALL FESTOP(35006) 14 CONTINUE END IF C C Copy values of key variables for this record to cells to hold C values of keys for previous record C J=IRECOD+3 DO 15 KK=1,RSTPNT(IRECOD) DX(V3(J))=DX(V1(J)) J=J+1 15 CONTINUE V2(IRECOD)=V2(IRECOD)+1 GO TO 3 END IF C C When get to here, new record has been succesfully processed, so C increase record count. C V2(IRECOD)=V2(IRECOD)+1 END IF 16 CONTINUE IF(.NOT.ENDF12) THEN C C Storage of incoming data before end of file C IF(V2(IRECOD).GT.0) THEN IF(IRC.EQ.42) THEN DO 17 KV=V1(IRECOD+1),V1(IRECOD+1)+L-1 I=IX(KV) DX(VMAPL(I))=DX(K) DX(VMAPL(I)+1)=1.0D0 K=K+1 17 CONTINUE ELSE DO 18 KV=V1(IRECOD+1),V1(IRECOD+1)+L-1 I=IX(KV) DX(VMAPL(I))=DX(K) K=K+1 18 CONTINUE END IF ELSE C C Store missing under LINK_MISSING if at end of file. C IF(KF.GT.0) THEN DX(VMAPL(KF))=0. END IF DO 20 KV=V1(IRECOD+1),V1(IRECOD+1)+L-1 II=IX(KV) DX(VMAPL(II))=0. IF(IRC.EQ.42) THEN DX(VMAPL(II)+1)=0. END IF 20 CONTINUE END IF END IF IRECOD=IRECOD+2+RSTPNT(IRECOD) GO TO 1 END IF C C 50 = add, 0 replicate, using vplxin data C v1 v2 v3 rstpnt C 1st op target vplxin v #classes C for each class: C v1 v2 v3 rstpnt C class/cat 0 offset increment C C 51 = subtract, 0 replicate using vplxin data C 52 = multiply, 0 replicate " C 53 = divide, 0 replicate " C 54 = add loop to replicate weights/factors, using vplxin C v1 v2 v3 rstpnt C 1st rf/rw # rf/rw vplxin var #classes C for each class: C v1 v2 v3 rstpnt C class/cat 0 offset increment C C 55 = subtract loop to replicate weights/factors, using vplxin C 56 = multiply loop " " C 57 = divide loop " " C IF(IRC.GE.50.AND.IRC.LE.57) THEN IV1=V1(IRECOD) JV1=VMAPL(IV1) IF(IRC.LE.53) THEN IV2=V2(IRECOD) JV2=VMAPL(IV2) MTYPE(IV2)=MTYPE(IV1) ELSE NV=V2(IRECOD) MT=JV1-SDRFW+1 JV2=JV1 END IF C C calculate the location in the VPLXIN file of the matching factor. C JV3=VMAPL(V3(IRECOD))+SDVPIN-1 K=RSTPNT(IRECOD) IF(K.GT.0) THEN DO 301 I=1,K IRECOD=IRECOD+1 JV1A=VMAPL(V1(IRECOD)) INDX=DX(JV1A)+.05 IF(INDX.EQ.0) THEN JV3=0 ELSE IF(JV3.GT.0) THEN IF(V3(IRECOD).EQ.1) THEN JV3=JV3+RSTPNT(IRECOD)*INDX ELSE JV3=JV3+RSTPNT(IRECOD)*(INDX-1) END IF END IF 301 CONTINUE C C If one or more indices are out of range, do nothing. C Note: transfer to 1 is delayed until this point to leave C IRECOD at the correct value. C IF(JV3.EQ.0)GO TO 1 END IF C C Placement of this transfer insures that IRECOD has been C incremented correctly. C IF(ENDF12)GO TO 1 IF(IRC.GT.53) THEN C C MT is the index of the first replicate weight/factor to be operated on. C IF(MT.GT.IREPL) THEN IF(MT.GT.IREPH)GO TO 1 I=MT JV3=JV3+TSIZE*(I-IREPL+1) ELSE I=IREPL JV1=JV1+IREPL-MT JV2=JV1 C C Since we are starting at IREPL, the first element we need to use is C we need to use is stored just beyond the full sample matrix. C JV3=JV3+TSIZE END IF C C Figure out the stopping index K. C IF(MT+NV-1.LT.IREPH) THEN IF(MT+NV-1.LT.IREPL)GO TO 1 K=MT+NV-1 ELSE K=IREPH END IF END IF 302 CONTINUE IF(DABS(DX(JV3)-MISSNG).LE..1D-6) THEN DX(JV2)=0. ELSE IF(IRC.EQ.50.OR.IRC.EQ.54) THEN DX(JV2)=DX(JV1)+DX(JV3) ELSE IF(IRC.EQ.51.OR.IRC.EQ.55) THEN DX(JV2)=DX(JV1)-DX(JV3) ELSE IF(IRC.EQ.52.OR.IRC.EQ.56) THEN DX(JV2)=DX(JV1)*DX(JV3) ELSE DX(JV2)=DX(JV1)/DX(JV3) END IF IF(IRC.LE.53)GO TO 1 I=I+1 IF(I.GT.K)GO TO 1 JV3=JV3+TSIZE JV2=JV2+1 JV1=JV1+1 GO TO 302 ELSE IF(IRC.EQ.58.OR.IRC.EQ.61) THEN IV1=V1(IRECOD) JV1=VMAPL(IV1) NV=V2(IRECOD) JK=RSTPNT(IRECOD) IF(V3(IRECOD).GT.0) THEN K=VMAPL(V3(IRECOD)) XV3=DX(K) ELSE XV3=1.D0 END IF IF(IRC.EQ.58) THEN JV2=SDVID DO 313 I=1,NV IF(I.GE.IREPL.AND.I.LE.IREPH) THEN JV2=JV2+NIDTOT DX(JV1)=DX(JV2+NID) IF(VFTYPE.LE.32) THEN DO 311 J=1,JK KK=VMAPL(V1(IRECOD+J)) IF(DABS(DX(KK)-DX(JV2+J-1)).GT..1D-3)GO TO 312 DX(JV1)=DX(JV2+NID+J) 311 CONTINUE 312 CONTINUE ELSE KK=VMAPL(V1(IRECOD+1)) IF(DX(KK)-DX(JV2+NID+1).GT.-.1D-03.AND. . DX(JV2+NID+2)-DX(KK).GT.-.1D-03) THEN DX(JV1)=DX(JV2+NID+3) IF(VFTYPE.EQ.35.OR.VFTYPE.EQ.36) THEN IF(DX(KK)-DX(JV2+NID+4).GT.-1.D-03.AND. . DX(JV2+NID+5)-DX(KK).GT.-1.D-03) THEN DX(JV1)=DX(JV2+NID+6) END IF END IF IF(DABS(DX(JV2)-DX(KK)).LT..1D-03) THEN DX(JV1)=DX(JV2+NIDTOT-1) END IF END IF END IF ELSE DX(JV1)=1.D0 END IF DX(JV1)=DX(JV1)*XV3 JV1=JV1+1 313 CONTINUE ELSE C ! IRC = 61 DO 321 I=1,NV DX(JV1+I-1)=1.D0 321 CONTINUE DO 325 J=1,JK KK=VMAPL(V1(IRECOD+J)) IF(ICHECK(DX(KK),XV1)) THEN KK=XV1 IF(KK.GT.0) THEN KK=KK-(KK/NHADAM)*NHADAM IF(KK.EQ.0)KK=NHADAM KK=NHADAM*(KK-1)+SDHADM IF(V2(IRECOD+J).NE.0) THEN JV3=VMAPL(V2(IRECOD+J)) XV1=DX(JV3) ELSE XV1=1.0D0 END IF DO 322 JV3=1,NHADAM DX(JV1+JV3-1)=DX(JV1+JV3-1)+XV1*DX(KK) KK=KK+1 322 CONTINUE END IF ELSE WRITE(U6,210)DX(KK) CALL FESTOP(35009) END IF 325 CONTINUE IF(DABS(XV3-1.D0).GT..1D-12) THEN DO 326 I=1,NHADAM DX(JV1+I-1)=XV3*DX(JV1+I-1) 326 CONTINUE END IF END IF IRECOD=IRECOD+JK GO TO 1 ELSE IF(IRC.EQ.47) THEN IF(ENDF12)GO TO 1 IF(METHOD.NE.1) THEN IF(METHOD.EQ.2.AND.IPASS.EQ.NPASS) THEN K=SDRFW DO 314 I=1,NFILES J=12+I CALL UNFIN(J,DX(K),NMAX,ENDF) K=K+NMAX 314 CONTINUE ELSE IF(METHOD.EQ.3) THEN IF(IPASS.LT.NPASS) THEN IF(IFILE.LT.12+NFILES) THEN K=SDRFW+IREPL-1-NMAX J=NMAX DO 315 I=12+NFILES,IFILE+1,-1 CALL UNFIN(I,DX(K),J,ENDF) J=J*2 K=K-J 315 CONTINUE END IF ELSE J=IPASS-1 K=SDRFW N=2**(NFILES-1) DO 316 I=13,12+NFILES IF(J.GE.N) THEN NN=N*NMAX CALL UNFIN(I,DX(K),NN,ENDF) J=J-N K=K+NN END IF N=N/2 316 CONTINUE END IF END IF END IF IF(IPASS.EQ.NPASS) THEN J=SDOUTP N=V1(IRECOD) JJ=V2(IRECOD) IUNIT=IX(JJ) JJ=JJ+1 IOUTFV=IX(JJ) DO 304 I=1,N JJ=JJ+1 DX(J)=DX(IX(JJ)) J=J+1 304 CONTINUE IF(IOUTFV.LE.2) THEN CALL XWRITE(DX(SDOUTP),N,INFRMT(V3(IRECOD)), . RSTPNT(IRECOD),IUNIT) ELSE IF(IOUTFV.EQ.3) THEN CALL XWRITI(DX(SDOUTP),IXM,N,IUNIT) ELSE IF(IOUTFV.EQ.4) THEN CALL XWRITR(DX(SDOUTP),RXM,N,IUNIT) ELSE IF(IOUTFV.EQ.5) THEN CALL XWRITD(DX(SDOUTP),N,IUNIT) END IF ELSE CALL UNFOUT(IFILE,DX(SDROUT),NROUT) END IF GO TO 1 ELSE IF(IRC.EQ.60) THEN LL=RSTPNT(IRECOD) IF(ENDF12) THEN IRECOD=IRECOD+LL GO TO 1 END IF L=IRECOD 305 CONTINUE IRECOD=L DO 310 I=1,LL IRECOD=IRECOD+1 VBY=DX(SDVID+RSTPNT(IRECOD)-1) XV3=DX(VMAPL(V1(IRECOD))) IF(VBY+.1D-3.LT.XV3) THEN K=SDVID-1 KK=SDVPIN IF(IREPH.LT.NRPTOT) THEN DO 306 J=IREPH+1,NRPTOT READ(10,END=98)(DX(K+JJ),JJ=1,NIDTOT) CALL UNFIN(10,DX(KK),TSIZE,ENDF) IF(ENDF)GO TO 98 306 CONTINUE END IF READ(10,END=98)(DX(K+JJ),JJ=1,NIDTOT) CALL UNFIN(10,DX(KK),TSIZE,ENDF) IF(ENDF)GO TO 98 K=K+NIDTOT KK=KK+TSIZE IF(IREPL.GT.1) THEN DO 307 J=1,IREPL-1 READ(10,END=98)(DX(K+JJ),JJ=1,NIDTOT) CALL UNFIN(10,DX(KK),TSIZE,ENDF) IF(ENDF)GO TO 98 307 CONTINUE END IF DO 308 J=IREPL,IREPH READ(10,END=98)(DX(K+JJ),JJ=1,NIDTOT) CALL UNFIN(10,DX(KK),TSIZE,ENDF) IF(ENDF)GO TO 98 K=K+NIDTOT KK=KK+TSIZE 308 CONTINUE GO TO 305 ELSE IF(VBY-.1D-3.GT.XV3) THEN WRITE(U6,208) IRECOD=L DO 309 J=1,LL IRECOD=IRECOD+1 VBY=DX(SDVID+RSTPNT(IRECOD)-1) XV3=DX(VMAPL(V1(IRECOD))) WRITE(U6,212)VNAME(V1(IRECOD)),XV3,VBY 309 CONTINUE CALL FESTOP(35008) END IF 310 CONTINUE GO TO 1 98 CONTINUE WRITE(U6,213) IRECOD=L DO 331 J=1,LL IRECOD=IRECOD+1 XV3=DX(VMAPL(V1(IRECOD))) WRITE(U6,202)VNAME(V1(IRECOD)),XV3 331 CONTINUE CALL FESTOP(35007) END IF IF(ENDF12)GO TO 1 IV1=V1(IRECOD) IV2=V2(IRECOD) C C ADD/SUBTRACT/MULTIPLY/DIVIDE loops for replicate factors/weights C IF(IRC.GE.43.AND.IRC.LE.46) THEN IV3=V3(IRECOD) JV3=VMAPL(IV3) XV3=DX(JV3) JV1=VMAPL(IV1) IF(IRC.EQ.43) THEN DO 25 I=1,IV2 DX(JV1)=DX(JV1)+XV3 JV1=JV1+1 25 CONTINUE ELSE IF(IRC.EQ.44) THEN DO 26 I=1,IV2 DX(JV1)=DX(JV1)-XV3 JV1=JV1+1 26 CONTINUE ELSE IF(IRC.EQ.45) THEN DO 27 I=1,IV2 DX(JV1)=DX(JV1)*XV3 JV1=JV1+1 27 CONTINUE ELSE DO 28 I=1,IV2 IF(XV3.NE.0.) THEN DX(JV1)=DX(JV1)/XV3 ELSE DX(JV1)=0. END IF JV1=JV1+1 28 CONTINUE END IF GO TO 1 ELSE IF(IRC.EQ.62) THEN C C 62 = idchange to return 1 if change in variables C v1 v2 v3 rstpnt C 0 idchange 0 # keys C for each key: C 0 match v pointer to var # of match v C last value C JV2=VMAPL(IV2) DX(JV2)=0. MSIZE(IV2)=1 MTYPE(IV2)=1 DO 292 I=1,RSTPNT(IRECOD) IV1=V2(IRECOD+I) IF(DABS(DX(VMAPL(IV1))-DX(V3(IRECOD+I))).GT..1D-3) THEN DX(JV2)=1. DO 291 II=1,RSTPNT(IRECOD) DX(V3(IRECOD+II))=DX(VMAPL(V2(IRECOD+II))) 291 CONTINUE GO TO 293 END IF 292 CONTINUE 293 CONTINUE IRECOD=IRECOD+RSTPNT(IRECOD) GO TO 1 C C PRINT C C 63 = print C v1 v2 v3 rstpnt C # print #obs # list # pointer to IX C # request C ELSE IF(IRC.EQ.63.OR.IRC.EQ.64) THEN V2(IRECOD)=IV2+1 IF(IV1.EQ.0.OR.IV1.GT.IV2) THEN WRITE(U6,221)V1(IRECOD+1) K=RSTPNT(IRECOD) IF(IRC.EQ.63) THEN DO 294 I=1,V3(IRECOD) IV1=IX(K) MT1=MTYPE(IV1) JV1=VMAPL(IV1) IF(MT1.EQ.1.OR.MT1.GE.10) THEN WRITE(U6,222)VNAME(IV1),DX(JV1) ELSE IF(MT1.EQ.2) THEN IF(DX(JV1+1).NE.0.) THEN WRITE(U6,222)VNAME(IV1),DX(JV1) ELSE WRITE(U6,223)VNAME(IV1) END IF ELSE IF(MT1.EQ.3) THEN WRITE(U6,224)VNAME(IV1),DX(JV1) ELSE IF(MT1.EQ.4) THEN WRITE(U6,225)VNAME(IV1),DX(JV1) ELSE IF(MT.EQ.8) THEN WRITE(U6,222)VNAME(IV1),DX(JV1),DX(JV1+1) ELSE IF(MT.EQ.9) THEN WRITE(U6,226)VNAME(IV1),DX(JV1) END IF K=K+1 294 CONTINUE ELSE DO 295 I=1,V3(IRECOD),2 IV1=IX(K) JV1=VMAPL(IV1) IF(I.EQ.V3(IRECOD)) THEN WRITE(U6,230)VNAME(IV1),DX(JV1) ELSE IV2=IX(K+1) JV2=VMAPL(IV2) WRITE(U6,230)VNAME(IV1),DX(JV1),VNAME(IV2),DX(JV2) END IF K=K+2 295 CONTINUE END IF END IF IRECOD=IRECOD+1 GO TO 1 END IF JV2=VMAPL(IV2) IF(IRC.EQ.34) THEN DX(JV2)=DX(IV1) MTYPE(IV2)=1 MSIZE(IV2)=1 GO TO 1 END IF JV1=VMAPL(IV1) MT1=MTYPE(IV1) XV1=DX(JV1) IF(IRC.NE.7.AND.IRC.NE.35) THEN IV3=V3(IRECOD) JV3=VMAPL(IV3) XV3=DX(JV3) MT3=MTYPE(IV3) ELSE JV3=JV1 XV3=XV1 IV3=IV1 MT3=MT1 END IF IF(IRC.EQ.8.OR.IRC.EQ.9) THEN IX3=XV3 IF(IX3.EQ.0) GO TO 33 IF(MT1.EQ.2.OR.MT1.EQ.8) THEN IF(DX(JV1+1).EQ.0.) GO TO 33 ELSE IF(MT1.EQ.3.OR.MT1.EQ.4.OR.MT1.EQ.9) . THEN IF(XV1.EQ.0.) GO TO 33 END IF IF(IRC.EQ.8) THEN DX(JV2)=XV1 IF(MT1.EQ.1.OR.MT1.EQ.2) THEN DX(JV2+1)=IX3 ELSE IX1=DX(JV1+1) DX(JV2+1)=(IX3-1)*(MSIZE(IV1)/2)+IX1 END IF ELSE IX1=XV1 DX(JV2)=(IX3-1)*MSIZE(IV1)+IX1 END IF GO TO 34 33 CONTINUE DX(JV2)=0. IF(IRC.EQ.8)DX(JV2+1)=0. 34 CONTINUE IF(IRC.EQ.9.OR.MT1.EQ.8) THEN MSIZE(IV2)=MSIZE(IV1)*MSIZE(IV3) ELSE MSIZE(IV2)=2*MSIZE(IV3) END IF MTYPE(IV2)=IRC ELSE IF(IRC.GE.26.AND.IRC.LE.33) THEN KFLAG=0 KFLAG1=0 KFLAG2=0 IF(MT1.NE.1) THEN KFLAG=1 IF(DX(JV1+1).EQ.0.)KFLAG1=1 IF(IRC.LT.30) THEN DX(JV2+1)=DX(JV1+1) END IF END IF IF(MT3.NE.1) THEN KFLAG=1 IF(DX(JV3+1).EQ.0.)KFLAG2=1 END IF IF(IRC.EQ.29.OR.IRC.EQ.33) THEN KFLAG=1 IF(XV3.EQ.0.)KFLAG2=1 END IF IF(IRC.GE.30) THEN MTYPE(IV2)=1 MSIZE(IV2)=1 ELSE IF(MT1.EQ.1.AND.KFLAG.EQ.1) THEN MTYPE(IV2)=2 MSIZE(IV2)=2 DX(JV2+1)=1.D0 ELSE MTYPE(IV2)=MT1 MSIZE(IV2)=MSIZE(IV1) END IF IF(IRC.LE.29) THEN IF(KFLAG1.EQ.1.OR.KFLAG2.EQ.1) THEN DX(JV2)=0. DX(JV2+1)=0. ELSE IF(IRC.EQ.26) THEN DX(JV2)=XV1+XV3 ELSE IF(IRC.EQ.27) THEN DX(JV2)=XV1-XV3 ELSE IF(IRC.EQ.28) THEN DX(JV2)=XV1*XV3 ELSE DX(JV2)=XV1/XV3 END IF ELSE IF(KFLAG1.EQ.1.AND.KFLAG2.EQ.1) THEN IF(IRC.EQ.32) THEN DX(JV2)=1.D0 ELSE DX(JV2)=0. END IF ELSE IF(KFLAG1.EQ.1) THEN IF(IRC.EQ.30.OR.IRC.EQ.32) THEN DX(JV2)=XV3 ELSE IF(IRC.EQ.31) THEN DX(JV2)=-XV3 ELSE DX(JV2)=0. END IF ELSE IF(KFLAG2.EQ.1) THEN IF(IRC.EQ.33) THEN DX(JV2)=0. ELSE DX(JV2)=XV1 END IF ELSE IF(IRC.EQ.30) THEN DX(JV2)=XV1+XV3 ELSE IF(IRC.EQ.31) THEN DX(JV2)=XV1-XV3 ELSE IF(IRC.EQ.32) THEN DX(JV2)=XV1*XV3 ELSE DX(JV2)=XV1/XV3 END IF END IF ELSE IF(IRC.EQ.23.OR.IRC.EQ.24) THEN KFLAG1=1 KFLAG2=1 IF(XV1.EQ.0.) THEN KFLAG1=0 ELSE IF(MT1.NE.1) THEN IF(DX(JV1+1).EQ.0.)KFLAG1=0 END IF IF(XV3.EQ.0.) THEN KFLAG2=0 ELSE IF(MT3.NE.1) THEN IF(DX(JV3+1).EQ.0.)KFLAG1=0 END IF MSIZE(IV2)=1 MTYPE(IV2)=1 IF(IRC.EQ.23) THEN IF(KFLAG1+KFLAG2.EQ.2) THEN DX(JV2)=1.D0 ELSE DX(JV2)=0. END IF ELSE IF(KFLAG1+KFLAG2.GE.1) THEN DX(JV2)=1.D0 ELSE DX(JV2)=0. END IF END IF ELSE IF(IRC.EQ.22.OR.IRC.EQ.25) THEN KFLAG1=1 IF(XV1.EQ.0.) THEN KFLAG1=0 ELSE IF(MT1.EQ.2.OR.MT1.EQ.8) THEN IF(DX(JV1+1).EQ.0.)KFLAG1=0 END IF MTYPE(IV2)=1 MSIZE(IV2)=1 IF(IRC.EQ.22) THEN IF(KFLAG1.EQ.1) THEN DX(JV2)=1.D0 ELSE DX(JV2)=0. END IF ELSE IF(KFLAG1.EQ.1) THEN DX(JV2)=0. ELSE DX(JV2)=1.D0 END IF END IF ELSE IF(IRC.NE.10) THEN IRNSET=RSTPNT(IRECOD) IF(IRNSET.EQ.0) THEN IF(MT3.EQ.2.OR.MT3.EQ.8) THEN IF(DX(JV3+1).EQ.0) GO TO 36 ELSE IF(MT3.EQ.3.OR.MT3.EQ.4.OR.MT3.EQ.9) THEN IF(XV3.EQ.0) GO TO 36 END IF IF(XV3.EQ.0.) GO TO 36 IF(MT3.EQ.2.OR.MT3.EQ.8) THEN IF(DX(JV3+1).EQ.0.)GO TO 36 END IF GO TO 365 ELSE IRNGPT=RNGPNT(IRNSET) INRNG=NRNG(IRNSET) C C Range type C 1 value1 - value2 C 2 LOW - value C 3 value - HIGH C 4 LOW - HIGH C 5 MISSING C 6 value - n C DO 35 I=IRNGPT,IRNGPT+INRNG-1 IF(RTYPE(I).EQ.5) THEN IF(MT3.EQ.2.OR.MT3.EQ.8) THEN IF(DX(JV3+1).NE.0) GO TO 35 ELSE IF(MT3.EQ.3.OR.MT3.EQ.4.OR.MT3.EQ.9) THEN IF(XV3.NE.0) GO TO 35 ELSE GO TO 35 END IF ELSE IF(MT3.EQ.3.OR.MT3.EQ.4.OR.MT3.EQ.9) THEN IF(XV3.EQ.0) GO TO 35 END IF IF(RTYPE(I).EQ.1) THEN IF(XV3.LT.RANGE(1,I).OR.XV3.GT.RANGE(2,I)) GO TO 35 ELSE IF(RTYPE(I).EQ.2) THEN IF(XV3.GT.RANGE(2,I)) GO TO 35 ELSE IF(RTYPE(I).EQ.3) THEN IF(XV3.LT.RANGE(1,I)) GO TO 35 END IF END IF GO TO 365 35 CONTINUE END IF 36 CONTINUE IF(IRC.EQ.2) THEN DX(JV2)=XV1 IF(MT1.EQ.1) THEN DX(JV2+1)=1.0D0 ELSE IF(MT1.EQ.2.OR.MT1.EQ.8) THEN DX(JV2+1)=DX(JV1+1) END IF ELSE IF(IRC.EQ.3.OR.IRC.EQ.4) THEN DX(JV2)=0. ELSE IF(IRC.EQ.21) THEN DX(JV2)=0. ELSE IF(IRC.EQ.35) THEN IRECOD=V3(IRECOD) GO TO 2 ELSE IF(V3(IRECOD).EQ.1) THEN IXDROP=.TRUE. ELSE DX(BLXSTR(V3(IRECOD))+SDVIN-1)=0. END IF END IF GO TO 37 365 CONTINUE IF(IRC.EQ.2) THEN DX(JV2)=0. IF(MT1.LE.2.OR.MT1.EQ.8)DX(JV2+1)=0. ELSE IF(IRC.EQ.3.OR.IRC.EQ.4) THEN DX(JV2)=RGROUP(I) ELSE IF(IRC.EQ.21) THEN DX(JV2)=1.0D0 END IF 37 CONTINUE IF(IRC.EQ.2.AND.MT1.EQ.1) THEN MSIZE(IV2)=2 MTYPE(IV2)=2 ELSE IF(IRC.EQ.2) THEN MSIZE(IV2)=MSIZE(IV1) MTYPE(IV2)=MTYPE(IV1) ELSE IF(IRC.EQ.3.OR.IRC.EQ.4) THEN MSIZE(IV2)=RGROUP(IRNGPT+INRNG-1) MTYPE(IV2)=IRC ELSE IF(IRC.EQ.21) THEN MSIZE(IV2)=1 MTYPE(IV2)=1 END IF ELSE MSIZE(IV2)=MSIZE(IV1) MTYPE(IV2)=MT1 DO 38 I=1,MSIZE(IV2) DX(I+JV2-1)=DX(I+JV1-1) 38 CONTINUE END IF GO TO 1 END SUBROUTINE XREAD(DXM,N,IUNIT,INF,NFMT,ENDF12,IOERR,NPREV,NVLIST, . NPRINT) C INTEGER N,IUNIT,NPREV,NPRINT INTEGER NVLIST(N) DOUBLE PRECISION DXM(N) LOGICAL ENDF12,IOERR CHARACTER*128 INF(NFMT) C C DXM - output matrix, C N - number of items in DXM C IUNIT - input unit number. C IFLOW - starting element of format in INFRMT C NFMT - number of lines in this format (128 char/line) C ENDF12 - end of input on unit 12. C IOERR - error flag C NPREV - previous observation number C NVLIST - list of variables to read C NPRINT - number to print C PARAMETER (MVAR=10000) C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C 100 FORMAT(/,' Observation',I6,' from unit',I3) 101 FORMAT(6X,A12,F14.4,10X,A12,F14.4) 102 FORMAT(' (Printing discontinued on unit',I3,')') C ENDF12=.FALSE. IOERR=.FALSE. C C Different versions to handle different options on storage of C format. C READ(UNIT=IUNIT,FMT=INF,END=10,ERR=20)DXM IF(NPREV+1.LE.NPRINT) THEN I=NPREV+1 IF(U5ECHO.GT.0) THEN WRITE(U6,100)I,IUNIT DO 5 I=1,N,2 J1=NVLIST(I) IF(I.EQ.N) THEN WRITE(U6,101)VNAME(J1),DXM(I) ELSE J2=NVLIST(I+1) WRITE(U6,101)VNAME(J1),DXM(I),VNAME(J2),DXM(I+1) END IF 5 CONTINUE END IF IF(NPREV+1.EQ.NPRINT) THEN IF(U5ECHO.GT.0)WRITE(U6,102)IUNIT END IF END IF RETURN 10 CONTINUE ENDF12=.TRUE. RETURN 20 CONTINUE IOERR=.TRUE. RETURN END C SUBROUTINE XREAD1(DXM,N,IUNIT,INF,ENDF12,IOERR,NPREV,NVLIST, . NPRINT) C INTEGER N,IUNIT,NPREV,NPRINT INTEGER NVLIST(N) DOUBLE PRECISION DXM(N) LOGICAL ENDF12,IOERR CHARACTER*128 INF C C DXM - output matrix, C N - number of items in DXM C IUNIT - input unit number. C IFLOW - starting element of format in INFRMT C NFMT - number of lines in this format (128 char/line) C ENDF12 - end of input on unit 12. C IOERR - error flag C NPREV - previous observation number C NVLIST - list of variables to read C NPRINT - number to print C PARAMETER (MVAR=10000) C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C 100 FORMAT(/,' Observation',I6,' from unit',I3) 101 FORMAT(6X,A12,F14.4,10X,A12,F14.4) 102 FORMAT(' (Printing discontinued on unit',I3,')') C ENDF12=.FALSE. IOERR=.FALSE. C C Different versions to handle different options on storage of C format. C READ(UNIT=IUNIT,FMT=INF,END=10,ERR=20)DXM IF(NPREV+1.LE.NPRINT) THEN I=NPREV+1 IF(U5ECHO.GT.0) THEN WRITE(U6,100)I,IUNIT DO 5 I=1,N,2 J1=NVLIST(I) IF(I.EQ.N) THEN WRITE(U6,101)VNAME(J1),DXM(I) ELSE J2=NVLIST(I+1) WRITE(U6,101)VNAME(J1),DXM(I),VNAME(J2),DXM(I+1) END IF 5 CONTINUE END IF IF(NPREV+1.EQ.NPRINT) THEN IF(U5ECHO.GT.0)WRITE(U6,102)IUNIT END IF END IF RETURN 10 CONTINUE ENDF12=.TRUE. RETURN 20 CONTINUE IOERR=.TRUE. RETURN END C SUBROUTINE XREADD(DXM,N,IUNIT,ENDF12,IOERR,NPREV,NVLIST, . NPRINT) C INTEGER N,IUNIT,NPREV,NPRINT INTEGER NVLIST(N) DOUBLE PRECISION DXM(N) LOGICAL ENDF12,IOERR C C DXM - output matrix, C IXM - temporary storage for integers C N - number of items in DXM C IUNIT - input unit number. C ENDF12 - end of input on unit 12. C IOERR - error flag C NPREV - previous observation number C NV1ST - pointer to first variable to read C NPRINT - number to print C PARAMETER (MVAR=10000) C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C 100 FORMAT(/,' Observation',I6,' from unit',I3) 101 FORMAT(6X,A12,F14.4,10X,A12,F14.4) 102 FORMAT(' (Printing discontinued on unit',I3,')') C ENDF12=.FALSE. IOERR=.FALSE. C C Different versions to handle different options on storage of C format. C READ(UNIT=IUNIT,END=10,ERR=20)DXM IF(NPREV+1.LE.NPRINT) THEN I=NPREV+1 IF(U5ECHO.GT.0) THEN WRITE(U6,100)I,IUNIT DO 5 I=1,N,2 J1=NVLIST(I) IF(I.EQ.N) THEN WRITE(U6,101)VNAME(J1),DXM(I) ELSE J2=NVLIST(I+1) WRITE(U6,101)VNAME(J1),DXM(I),VNAME(J2),DXM(I+1) END IF 5 CONTINUE END IF IF(NPREV+1.EQ.NPRINT) THEN IF(U5ECHO.GT.0)WRITE(U6,102)IUNIT END IF END IF RETURN 10 CONTINUE ENDF12=.TRUE. RETURN 20 CONTINUE IOERR=.TRUE. RETURN END C SUBROUTINE XREADI(DXM,IXM,N,IUNIT,ENDF12,IOERR,NPREV,NVLIST, . NPRINT) C INTEGER N,IUNIT,NPREV,NPRINT INTEGER NVLIST(N) INTEGER IXM(N) DOUBLE PRECISION DXM(N) LOGICAL ENDF12,IOERR C C DXM - output matrix, C IXM - temporary storage for integers C N - number of items in DXM C IUNIT - input unit number. C ENDF12 - end of input on unit 12. C IOERR - error flag C NPREV - previous observation number C NV1ST - pointer to first variable to read C NPRINT - number to print C PARAMETER (MVAR=10000) C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C 100 FORMAT(/,' Observation',I6,' from unit',I3) 101 FORMAT(6X,A12,F14.4,10X,A12,F14.4) 102 FORMAT(' (Printing discontinued on unit',I3,')') C ENDF12=.FALSE. IOERR=.FALSE. C C Different versions to handle different options on storage of C format. C READ(UNIT=IUNIT,END=10,ERR=20)IXM DO 30 I=1,N DXM(I)=IXM(I) 30 CONTINUE IF(NPREV+1.LE.NPRINT) THEN I=NPREV+1 IF(U5ECHO.GT.0) THEN WRITE(U6,100)I,IUNIT DO 5 I=1,N,2 J1=NVLIST(I) IF(I.EQ.N) THEN WRITE(U6,101)VNAME(J1),DXM(I) ELSE J2=NVLIST(I+1) WRITE(U6,101)VNAME(J1),DXM(I),VNAME(J2),DXM(I+1) END IF 5 CONTINUE END IF IF(NPREV+1.EQ.NPRINT) THEN IF(U5ECHO.GT.0)WRITE(U6,102)IUNIT END IF END IF RETURN 10 CONTINUE ENDF12=.TRUE. RETURN 20 CONTINUE IOERR=.TRUE. RETURN END C SUBROUTINE XREADR(DXM,RXM,N,IUNIT,ENDF12,IOERR,NPREV,NVLIST, . NPRINT) C INTEGER N,IUNIT,NPREV,NPRINT INTEGER NVLIST(N) REAL RXM(N) DOUBLE PRECISION DXM(N) LOGICAL ENDF12,IOERR C C DXM - output matrix, C IXM - temporary storage for integers C N - number of items in DXM C IUNIT - input unit number. C ENDF12 - end of input on unit 12. C IOERR - error flag C NPREV - previous observation number C NV1ST - pointer to first variable to read C NPRINT - number to print C PARAMETER (MVAR=10000) C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C 100 FORMAT(/,' Observation',I6,' from unit',I3) 101 FORMAT(6X,A12,F14.4,10X,A12,F14.4) 102 FORMAT(' (Printing discontinued on unit',I3,')') C ENDF12=.FALSE. IOERR=.FALSE. C C Different versions to handle different options on storage of C format. C READ(UNIT=IUNIT,END=10,ERR=20)RXM DO 30 I=1,N DXM(I)=RXM(I) 30 CONTINUE IF(NPREV+1.LE.NPRINT) THEN I=NPREV+1 IF(U5ECHO.GT.0) THEN WRITE(U6,100)I,IUNIT DO 5 I=1,N,2 J1=NVLIST(I) IF(I.EQ.N) THEN WRITE(U6,101)VNAME(J1),DXM(I) ELSE J2=NVLIST(I+1) WRITE(U6,101)VNAME(J1),DXM(I),VNAME(J2),DXM(I+1) END IF 5 CONTINUE END IF IF(NPREV+1.EQ.NPRINT) THEN IF(U5ECHO.GT.0)WRITE(U6,102)IUNIT END IF END IF RETURN 10 CONTINUE ENDF12=.TRUE. RETURN 20 CONTINUE IOERR=.TRUE. RETURN END C SUBROUTINE XWRITD(DXM,N,IUNIT) C INTEGER N,IUNIT DOUBLE PRECISION DXM(N) C C DXM - array to write C N - number of elements to write C C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C C WRITE(UNIT=IUNIT,ERR=20)DXM RETURN 20 CONTINUE IMERR1=90003 CALL FWSTOP(IUNIT) END C SUBROUTINE XWRITE(DXM,N,INF,NFMT,IUNIT) C INTEGER N,NFMT,IUNIT DOUBLE PRECISION DXM(N) CHARACTER*128 INF(NFMT) C C DXM - array to write C N - number of elements to write C INF - format C NFMT - number of lines of format C C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C C WRITE(UNIT=IUNIT,FMT=INF,ERR=20)DXM RETURN 20 CONTINUE IMERR1=90003 CALL FWSTOP(IUNIT) END C SUBROUTINE XWRITI(DXM,IXM,N,IUNIT) C INTEGER N,IUNIT DOUBLE PRECISION DXM(N) INTEGER IXM(N) C C DXM - array to write C N - number of elements to write C C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C C DO 10 I=1,N IF(DXM(I).GE..5D0) THEN IXM(I)=DXM(I)+.5D0 ELSE IXM(I)=DXM(I)-.5D0 END IF 10 CONTINUE WRITE(UNIT=IUNIT,ERR=20)IXM RETURN 20 CONTINUE IMERR1=90003 CALL FWSTOP(IUNIT) END C SUBROUTINE XWRITR(DXM,RXM,N,IUNIT) C INTEGER N,IUNIT DOUBLE PRECISION DXM(N) REAL RXM(N) C C DXM - array to write C N - number of elements to write C C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C C DO 10 I=1,N RXM(I)=DXM(I) 10 CONTINUE WRITE(UNIT=IUNIT,ERR=20)RXM RETURN 20 CONTINUE IMERR1=90003 CALL FWSTOP(IUNIT) END C SUBROUTINE RWGHT2 IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (IXFLLD=3) PARAMETER (MAXFMT=20) C C MVAR represents the maximum number of incoming and created C variables, replicate factors and wts C MAXIDS is the maximum number of class variables C MRECOD is the maximum of variables transformed by CLASS, CAT C MISSING, SELECT, BY etc. C MRANGE is the maximum number of ranges C MRNSET is the maximum number of sets of ranges C MLEVEL is the maximum number of stored labels for levels C MCLBLK is the maximum number of class blocks C MCLBAR is the maximum number of cells of class block arrays C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP C LOGICAL REFRSH,ALPCHK,DGTCHK,ENDF12,ENDFLE,FOPEND EXTERNAL REFRSH,ALPCHK,DGTCHK C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1, . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX C DOUBLE PRECISION RANGE(2,MRANGE) INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET), . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD), . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI) C COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP, . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO, . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS, . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT, . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS, . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO, . NLEVEL,NRNSET,NRANGE,NHADAM,SDHADM,SDOUTP,SDVID,SDVPIN,IREPL, . IREPH,IFILE,SDRFW,IPASS,METHOD,NFILES,SDROUT,NROUT,NMAX,IXFILL, . SDSTCK,MSDPTH INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS, . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN, . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,SDHADM,SDOUTP,SDVID, . SDVPIN,SDRFW,SDROUT,IXFILL(IXFLLD),SDSTCK,MSDPTH LOGICAL IXDROP C C Usage in this subroutine: C C BLXSTR - Pointer for block to X matrix C BLVSTR - revised to become pointer to first variable in block C BLVSIZ - revised to number of variables in block C BLNCLS - number of class variables in block C BLCPNT - pointer for classes to CLTYPE C CLTYPE - used as pointers to class variables C 201 FORMAT(' MISMATCHING REPF/W') 214 FORMAT(' COMBINATION OF REPLICATION SPECIFICATIONS NOT ALLOWED') 216 FORMAT(' AMBIGUOUS NUMBER OF REPLICATES') 220 FORMAT(' MISSING ONE OR MORE REPLICATES, INCLUDING',I6) 221 FORMAT(/,5X,'PASSES REQUIRED:',I6) 222 FORMAT(' INSUFFICIENT ROOM') 223 FORMAT(/,5X,'Passes required:',I6,', using',I2,' scratch files') C IF(IVERSN.EQ.9004)NIDTOT=NID IF(IWGT.EQ.0.AND.NOWGTF.EQ.0) THEN CALL VNMTCH('WEIGHT ',VNAME,NVIN,IWGT) END IF IF((IREPF.GT.0.OR.IREPW.GT.0).AND.NREPW.EQ.0) THEN NREPW=0 DO 1 I=1,NVIN IF(MTYPE(I).GT.50+NREPW)NREPW=MTYPE(I)-50 1 CONTINUE DO 3 J=1,NREPW DO 2 I=1,NVIN IF(MTYPE(I).EQ.50+J)GO TO 3 2 CONTINUE WRITE(U6,220)J GO TO 99 3 CONTINUE IF(NREPW.NE.NRPTOT) THEN WRITE(U6,201) GO TO 99 END IF END IF IF(ICLCNT.GT.0.AND.ICLCNT.NE.NRPTOT) GO TO 98 C C VFTYPE = 3 Weighted obs. with cluster/replicate number C 4 Unweighted " C 5 Replicate weights C 6 Unweighted initial obs. followed by replicate weights C 7 Replicate factors multiplying initial weight C 8 Replicate factors of unweighted initial obs ( = VFTYPE 6) C 11 Replicate factors multiplying initial weight, including C factor for replicate 0, overall estimate C 12 Unweighted initial obs " (= VFTYPE 5) C 13 Weighted obs. with cluster code C 14 Unweighted " C 15 Weighted obs. Stratum no. cluster code C 16 Unweighted " C 17 Wtd. Stratum code, cluster code C 18 Unwtd " C 21 Wtd. Stratum no. 2nd stage no, cluster code C 22 Unwtd. " C 23 Wtd. Stratum no. 2nd stage cd, cluster code C 24 Unwtd. " C 25 Wtd. Stratum code 2nd stage no. cluster code C 26 Unwtd " C 27 Wtd. Stratum code 2nd stage cd, cluster code C 28 Unwtd. " C 29 Wtd 2nd stage number cluster code C 30 Unwtd. " C 31 Wtd 2nd stage code cluster code C 32 Unwtd " C 33 Wtd Replicate number governed by stratum counts C 34 Unwtd " C 35 Wtd Rep numb govrned by stratum and 2nd stage counts C 36 Unwtd " C 37 Wtd Rep number governed by 2nd stage counts C 38 Unwtd " C ISUM1=0 DO 5 I=1,NRECOD IF(RCTYPE(I).EQ.47) THEN IRCOUT=I GO TO 7 END IF 5 CONTINUE GO TO 98 7 CONTINUE IF(SISTRS.GT.0) THEN IF(NDFPC1.GT.0.AND.NDFPC1.NE.NISTRS)GO TO 97 DO 6 I=1,NISTRS ISUM1=ISUM1+IX(I+SISTRS-1) 6 CONTINUE IF(NDFPC2.GT.0.AND.NDFPC2.NE.ISUM1)GO TO 97 END IF ISUM2=0 IF(SISNDS.GT.0) THEN IF(ISUM1.GT.0.AND.NISNDS.NE.ISUM1) THEN GO TO 98 ELSE IF((ISUM1.EQ.0.AND.((NDFPC1.NE.0.AND.NDFPC1.NE.1).OR. . (NDFPC2.GT.0.AND.NDFPC1.EQ.0)))) THEN GO TO 97 END IF DO 8 I=1,NISNDS ISUM2=ISUM2+IX(I+SISNDS-1) 8 CONTINUE IF(NRPTOT.NE.ISUM2)GO TO 98 END IF IF(ISUM2.EQ.0.AND.ISUM1.GT.0.AND.NRPTOT.NE.ISUM1)GO TO 98 ILOC=NXPTD SDVIN=ILOC N=V1(IRCOUT) JJ=V2(IRCOUT)+1 DO 10 I=1,N JJ=JJ+1 J=IX(JJ) IF(MTYPE(J).LE.50) THEN IX(JJ)=-ILOC VMAPL(J)=ILOC IF(MXSIZE(J).GE.2) THEN ILOC=ILOC+2 ELSE ILOC=ILOC+1 END IF MTYPE(J)=-MTYPE(J) END IF 10 CONTINUE SDRFW=ILOC DO 13 I=1,NREPW DO 12 J=1,NVIN IF(MTYPE(J).EQ.50+I) THEN VMAPL(J)=ILOC ILOC=ILOC+1 END IF 12 CONTINUE 13 CONTINUE JJ=V2(IRCOUT)+1 DO 15 I=1,N JJ=JJ+1 IF(IX(JJ).LT.0) THEN IX(JJ)=-IX(JJ) ELSE J=IX(JJ) IX(JJ)=VMAPL(J) END IF 15 CONTINUE DO 17 I=1,NVIN IF(MTYPE(I).GE.0.AND.MTYPE(I).LE.50) THEN VMAPL(I)=ILOC IF(MXSIZE(I).GE.2) THEN ILOC=ILOC+2 ELSE ILOC=ILOC+1 END IF END IF 17 CONTINUE LOCEND=ILOC-NXPTD CALL ROOMD(LOCEND) SDOUTP=NXPTD CALL ROOMD(N) IF(MSDPTH.GT.0) THEN K=2*MSDPTH SDSTCK=NXPTD CALL ROOMD(K) END IF I=1 20 CONTINUE IF(RCTYPE(I).GE.40.AND.RCTYPE(I).LE.42) THEN IF(RSTPNT(I).GT.0) THEN K=RSTPNT(I) I=I+2 DO 21 J=1,K I=I+1 V2(I)=VMAPL(V2(I)) 21 CONTINUE ELSE I=I+2 END IF END IF I=I+1 IF(I.LE.NRECOD)GO TO 20 SDVID=NXPTD NMAX=(MSIZED-NXPTD+1)/(TSIZE+NIDTOT)-1 IF(NMAX.GE.NRPTOT) THEN NFILES=0 NPASS=1 NMAX=NRPTOT IFILE=11 METHOD=1 SDROUT=0 NROUT=0 ELSE IF(NMAX.LE.0) THEN WRITE(U6,222) GO TO 99 ELSE NPASS=(NRPTOT-1)/NMAX+1 NFILES=NPASS-1 IF(NFILES.GT.31) THEN IF(U5ECHO.GT.0)WRITE(U6,221)NPASS GO TO 99 ELSE IF(NFILES.LT.3) THEN METHOD=2 ELSE IF(NFILES.LE.5) THEN DO 22 I=13,17 INQUIRE(UNIT=I,OPENED=FOPEND) IF(.NOT.FOPEND)GO TO 23 22 CONTINUE I=18 23 CONTINUE I=I-13 IF(NFILES.EQ.3.AND.I.EQ.2) THEN NFILES=2 METHOD=3 ELSE IF(NFILES.GE.4.AND.I.EQ.3) THEN NFILES=3 METHOD=3 ELSE METHOD=2 END IF ELSE METHOD=3 IF(NFILES.LE.7) THEN NFILES=3 ELSE IF(NFILES.LE.15) THEN NFILES=4 ELSE NFILES=5 END IF END IF DO 24 I=1,NFILES J=12+I CALL SCOPEN(J) 24 CONTINUE IF(METHOD.EQ.3) THEN IFILE=12+NFILES ELSE IFILE=13 END IF IF(U5ECHO.GT.0)WRITE(U6,223)NPASS,NFILES SDROUT=SDRFW NROUT=NMAX END IF J=NIDTOT*(NMAX+1) CALL ROOMD(J) SDVPIN=NXPTD J=TSIZE*(NMAX+1) CALL ROOMD(J) 25 CONTINUE IREPL=1 IPASS=1 26 CONTINUE K=SDVID-1+NIDTOT KK=SDVPIN+TSIZE IF(IPASS.EQ.1.OR.NBYGRP.GT.1) THEN READ(10)(DX(SDVID+J-1),J=1,NIDTOT) CALL UNFIN(10,DX(SDVPIN),TSIZE,ENDFLE) IF(IPASS.GT.1) THEN DO 27 I=1,IREPH READ(10)(DX(K+J),J=1,NIDTOT) CALL UNFIN(10,DX(KK),TSIZE,ENDFLE) 27 CONTINUE END IF END IF IREPH=IREPL+NMAX-1 IF(IREPH.GT.NRPTOT) THEN IREPH=NRPTOT END IF ENDF12=.FALSE. DO 28 I=IREPL,IREPH READ(10)(DX(K+J),J=1,NIDTOT) CALL UNFIN(10,DX(KK),TSIZE,ENDFLE) K=K+NIDTOT KK=KK+TSIZE 28 CONTINUE 30 CONTINUE IF(IVZERO.EQ.1) THEN K=SDVIN DO 35 I=1,LOCEND DX(K)=0. K=K+1 35 CONTINUE END IF CALL RECODX(IXDROP,ENDF12) IF(.NOT.ENDF12) GO TO 30 IF(IREPH.LT.NRPTOT) THEN IF(NRECOD.GT.0) THEN I=1 37 CONTINUE IF(RCTYPE(I).GE.40.AND.RCTYPE(I).LE.42) THEN REWIND(UNIT=V1(I)) V2(I)=0 ELSE IF(RCTYPE(I).EQ.62) THEN DO 38 ITMP=1,RSTPNT(I) DX(V3(I+ITMP))=-98765.432109D0 38 CONTINUE I=I+RSTPNT(I) ELSE IF(RCTYPE(I).EQ.63) THEN V2(I)=0 END IF I=I+1 IF(I.LE.NRECOD)GO TO 37 END IF REWIND(UNIT=IFILE) IF(METHOD.EQ.3) THEN IF(IFILE.LT.12+NFILES) THEN DO 40 I=IFILE+1,12+NFILES REWIND(UNIT=I) 40 CONTINUE END IF END IF IREPL=IREPL+NMAX IPASS=IPASS+1 IF(IREPL.GT.1.AND.NBYGRP.GT.1) THEN REWIND(UNIT=10) CALL PREAMR END IF IF(IPASS.EQ.NPASS) THEN IFILE=11 ELSE IF(METHOD.EQ.2) THEN IFILE=IFILE+1 SDROUT=SDROUT+NMAX ELSE N=2**(NFILES-1) DO 44 I=1,NFILES IF((IPASS/N)*N.EQ.IPASS) THEN IFILE=12+I NROUT=N*NMAX SDROUT=SDRFW+IREPL-1-(N-1)*NMAX GO TO 45 END IF N=N/2 44 CONTINUE 45 CONTINUE END IF END IF GO TO 26 END IF DO 59 IRECOD=1,NRECOD IF(RCTYPE(IRECOD).GE.40.AND.RCTYPE(IRECOD).LE.42) THEN CLOSE(UNIT=V1(IRECOD)) END IF 59 CONTINUE CLOSE(10) CLOSE(11) CLOSE(12) RETURN 97 CONTINUE WRITE(U6,214) GO TO 99 98 CONTINUE WRITE(U6,216) 99 CONTINUE CALL FSTOP END SUBROUTINE PREAMR IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C LOGICAL ENDFLE C READ(10)IVERSN READ(10)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE, . VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR DO 1 I=1,NCLBLK READ(10)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I), . BLVSIZ(I),BLNCLS(I),BLCPNT(I) 1 CONTINUE IF(NCLBAR.GT.0) THEN CALL INTIN(10,CLTYPE,NCLBAR,ENDFLE) CALL INTIN(10,CLPNT,NCLBAR,ENDFLE) END IF C C RCEIL(2), RCEIL(7), AND RCEIL(10) were set in PREAMC initially C I=RCEIL(2)+1 IF(NVTOT.GT.0) THEN CALL INTIN(10,MTYPE(I),NVTOT,ENDFLE) CALL INTIN(10,MSIZE(I),NVTOT,ENDFLE) END IF IF(NVREG.GT.0) THEN CALL INTIN(10,VMAPL(I),NVREG,ENDFLE) END IF READ(10)NCRSSD ILC=RCEIL(10)+1 IF(NCRSSD.GT.0)CALL INTIN(10,CROSSD(ILC),NCRSSD,ENDFLE) DO 6 I=RCEIL(2)+1,MVAR READ(10)VNAME(I),LABEL(I) 6 CONTINUE C C Read in labels for the levels C READ(10)NCRVL IF(NCRVL.GT.0) THEN DO 10 I=RCEIL(7)+1,MLEVEL READ(10)LEVEL(I) 10 CONTINUE END IF READ(10)ILC DO 12 I=1,ILC READ(10)VTEMP(I) 12 CONTINUE IF(NBY.GE.1) THEN READ(10)NBYGRP K=SDBYID-1 DO 17 I=1,NBYGRP READ(10)(DX(K+J),J=1,NBY) K=K+NBY 17 CONTINUE END IF READ(10)NRPTOT IF(NRPTOT.GT.0) THEN CALL UNFIN(10,DX(SDCOEF),NRPTOT,ENDFLE) END IF RETURN END SUBROUTINE REPGEN IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (IXFLLD=3) PARAMETER (MAXFMT=20) C C MVAR represents the maximum number of incoming and created C variables, replicate factors and wts C MAXIDS is the maximum number of class variables C MRECOD is the maximum of variables transformed by CLASS, CAT C MISSING, SELECT, BY etc. C MRANGE is the maximum number of ranges C MRNSET is the maximum number of sets of ranges C MLEVEL is the maximum number of stored labels for levels C MCLBLK is the maximum number of class blocks C MCLBAR is the maximum number of cells of class block arrays C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP C LOGICAL REFRSH,ALPCHK,DGTCHK,ENDF12 EXTERNAL REFRSH,ALPCHK,DGTCHK C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1, . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX C DOUBLE PRECISION RANGE(2,MRANGE) INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET), . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD), . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI) C COMMON /STPBLK/NVIN,ILOC1,IOUTC2,LOCEND,IWGT,NOWGTF,NKEEP, . VKEEPF,BYLIST,VIDS,VIDL,NRECOD,ISTRCD,ISTRNO,ISNDCD,ISNDNO, . ICLUSC,ICLUSN,IREPNO,IREPF,IREPW,NREPW,ICLCNT,SISTRS,NISTRS, . SISNDS,NISNDS,NDCOEF,SDFPC1,NDFPC1,SDFPC2,NDFPC2,UCLUS,USTRT, . USNDS,UTOT,UIDS,SDXIN,SDVIN,SDCLUS,SDTOT,SDTOT2,SDTOT3,NPASS, . NRPT1,MDMX,NXPTDS,IUPPER,SDWGT,SIINCR,NDMX,NVIDCM,IVZERO, . NLEVEL,NRNSET,NRANGE,NHADAM,SDHADM,SDOUTP,SDVID,SDVPIN,IREPL, . IREPH,IFILE,SDRFW,IPASS,METHOD,NFILES,SDROUT,NROUT,NMAX,IXFILL, . SDSTCK,MSDPTH INTEGER VKEEPF,BYLIST(MAXIDS),VIDS(MAXIDS),VIDL(MAXIDS),SISTRS, . SISNDS,SDFPC1,SDFPC2,UCLUS,USTRT,USNDS,UTOT,UIDS,SDXIN,SDVIN, . SDCLUS,SDTOT,SDTOT2,SDTOT3,SDWGT,SIINCR,SDHADM,SDOUTP,SDVID, . SDVPIN,SDRFW,SDROUT,IXFILL(IXFLLD),SDSTCK,MSDPTH LOGICAL IXDROP C C C Usage in this subroutine: C C BLXSTR - Pointer for block to X matrix C BLVSTR - revised to become pointer to first variable in block C BLVSIZ - revised to number of variables in block C BLNCLS - number of class variables in block C BLCPNT - pointer for classes to CLTYPE C CLTYPE - used as pointers to class variables C 200 FORMAT(' ERROR IN SPECIFICATION') 220 FORMAT(' MISSING ONE OR MORE REPLICATES, INCLUDING',I6) C NPASS=1 IPASS=1 METHOD=1 IF((IREPF.GT.0.OR.IREPW.GT.0).AND.NREPW.EQ.0) THEN NREPW=0 DO 1 I=1,NVIN IF(MTYPE(I).GT.50+NREPW)NREPW=MTYPE(I)-50 1 CONTINUE DO 3 J=1,NREPW DO 2 I=1,NVIN IF(MTYPE(I).EQ.50+J)GO TO 3 2 CONTINUE WRITE(U6,220)J GO TO 99 3 CONTINUE END IF ILOC=NXPTD SDVIN=ILOC DO 10 I=1,NKEEP J=IOUT(I) IF(MTYPE(J).LE.50) THEN IOUTL(I)=ILOC VMAPL(J)=ILOC IF(MXSIZE(J).GE.2) THEN ILOC=ILOC+2 ELSE ILOC=ILOC+1 END IF MTYPE(J)=-MTYPE(J) END IF 10 CONTINUE SDRFW=ILOC DO 13 I=1,NREPW DO 12 J=1,NVIN IF(MTYPE(J).EQ.50+I) THEN VMAPL(J)=ILOC ILOC=ILOC+1 END IF 12 CONTINUE 13 CONTINUE DO 15 I=1,NKEEP J=IOUT(I) IF(MTYPE(J).GT.50) THEN IOUTL(I)=VMAPL(J) END IF 15 CONTINUE DO 17 I=1,NVIN IF(MTYPE(I).GE.0.AND.MTYPE(I).LE.50) THEN VMAPL(I)=ILOC IF(MXSIZE(I).GE.2) THEN ILOC=ILOC+2 ELSE ILOC=ILOC+1 END IF END IF 17 CONTINUE LOCEND=ILOC-NXPTD CALL ROOMD(LOCEND) SDOUTP=NXPTD CALL ROOMD(NKEEP) I=1 IF(MSDPTH.GT.0) THEN K=2*MSDPTH SDSTCK=NXPTD CALL ROOMD(K) END IF 20 CONTINUE IF(RCTYPE(I).GE.40.AND.RCTYPE(I).LE.42) THEN IF(RSTPNT(I).GT.0) THEN K=RSTPNT(I) I=I+2 DO 21 J=1,K I=I+1 V2(I)=VMAPL(V2(I)) 21 CONTINUE ELSE I=I+2 END IF ELSE IF(RCTYPE(I).EQ.47) THEN K=V2(I)+1 DO 25 J=1,V1(I) K=K+1 KK=IX(K) IX(K)=VMAPL(KK) 25 CONTINUE END IF I=I+1 IF(I.LE.NRECOD)GO TO 20 SDROUT=SDRFW ENDF12=.FALSE. 30 CONTINUE IF(IVZERO.EQ.1) THEN K=SDVIN DO 35 I=1,LOCEND DX(K)=0. K=K+1 35 CONTINUE END IF CALL RECODX(IXDROP,ENDF12) IF(.NOT.ENDF12) GO TO 30 DO 59 IRECOD=1,NRECOD IF(RCTYPE(IRECOD).GE.40.AND.RCTYPE(IRECOD).LE.42) THEN CLOSE(UNIT=V1(IRECOD)) END IF 59 CONTINUE CLOSE(11) CLOSE(12) RETURN 99 CONTINUE CALL FSTOP END C C Parsing for DISPLAY step, original syntax C SUBROUTINE DSETUP(DONE) IMPLICIT DOUBLE PRECISION (A-H,O-Z) LOGICAL DONE PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (MAXFMT=20) C PARAMETER (MDSZI=MSIZEI+6*MRANGE+2*MRNSET+3*MVAR) PARAMETER (IXFLLD=56+3*MAXIDS) PARAMETER (NPOPTN=9) PARAMETER (NOPTN=21) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C C COMMON /STMBLK/IX,RSTPNT,RCTYPE,V1,V2,V3,MXSIZE INTEGER IX(MDSZI),RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD), . V2(MRECOD),V3(MRECOD),MXSIZE(MVAR) C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL C INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID, . SDWRK,VKEEPF,OUTFMT,IXFILL(IXFLLD) COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT, . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF, . OUTFMT,IXFILL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 CHARACTER*256 CARD COMMON /CRDBLK/CARD C C LOGICAL REFRSH,LTEMP EXTERNAL REFRSH INTEGER ITYPEF(3),IFILEF(3) C INTEGER IOPTND(NPOPTN),IOPTNC(NPOPTN) INTEGER SICLSS,VTMPSZ CHARACTER*5 CWORK5 CHARACTER*4 CWORK4 INTEGER INDX(NOPTN) INTEGER IVALUE(NOPTN) CHARACTER*12 OPTNW(NOPTN) DATA OPTNW / 'PRINT ','NOPRINT ','WRITE ', . 'NOWRITE ','LINESIZE ','CLASSSTUB ','CLASS_STUB ', . 'CLASSHEAD ','CLASS_HEAD ','PAGESIZE ','CENTER ', . 'CENTERED ','UNCENTER ','UNCENTERED ','OUTFORMAT ', . 'NDECIMAL ','DECIMAL ','MEAN ','MEANS ', . 'TOTAL ','TOTALS '/ DATA INDX/1,1,2,2,3,4,4,4,4,5,6,6,6,6,8,9,9,7,7,7,7/ DATA IVALUE/1,2,1,2,0,2,2,1,1,0,1,1,2,2,0,4,4,1,1,2,2/ C 101 FORMAT(/,1X) 103 FORMAT(/,5X,'OUTFORMAT SET PREVIOUSLY') 141 FORMAT(I1) 142 FORMAT(I2) 143 FORMAT(I3) 144 FORMAT(I4) 151 FORMAT('11',8I4) 152 FORMAT('12',I4,I2,I4,I2,I4,A12,A24) 153 FORMAT('13',I2,I4,A12,A24) 154 FORMAT('14',I4,A24) 155 FORMAT('15',I4,' 0 0 0 0_N_',A5,4X,'N (wtd) for block ',A4,2X) 156 FORMAT('16',I4,2I2,2I4) 157 FORMAT('17',2I4,I2) 158 FORMAT('18',2I4,2I2) 170 FORMAT(5X,'OUTFORMAT3 SWITCHED TO OUTFORMAT4') 171 FORMAT(/,5X,'Format of type 99 record for classes',/,5X,'Positions . Class') 172 FORMAT(/,5X,'Format of type 99 records for classes',/,5X,'Rec no .Positions Class') 173 FORMAT(7X,I2,'-',I2,4X,A12) 174 FORMAT(6X,I4,5X,I2,'-',I2,4X,A12) 175 FORMAT(/,5X,'MEAN SWITCHED TO TOTAL: ',A12) 176 FORMAT(/,5X,'NO N FOR: ',A12) 177 FORMAT(/,5X,'NO N FOR BLOCK:',I4) 200 FORMAT(' ERROR IN SPECIFICATION') 201 FORMAT(' UNRECOGNIZED VARIABLE NAME: ',A12) 202 FORMAT(' CLASS VARIABLE NOT ALLOWED ON LIST: ',A12) 233 FORMAT(' TEMPORARY ERROR: new syntax not yet implemented for thi', . 's step') C ITYPEF(1)=2 ITYPEF(2)=1 ITYPEF(3)=0 IF(U5ECHO.GT.0)WRITE(U6,101) CALL CRDPRN(3) CALL KYFIND(IKEY,IPT) CALL FNREAD(IPT,ITYPEF,IFILEF,1,IPOSSC) CALL PREAMB IF(IMERR1.GT.0) THEN CALL FSTOP END IF IF(IPOSSC.GT.0) THEN C ! new syntax CALL NDISPL(IPOSSC,ITYPEF,IFILEF) DONE=.TRUE. WRITE(U6,233) CALL FSTOP END IF DONE=.FALSE. RCEIL(1)=MDSZI C ! size of IX in this step IOPTND(1)=1 C ! default is PRINT IF(IFILEF(2).EQ.1) THEN IOPTND(2)=1 ELSE IOPTND(2)=2 C ! NOWRITE END IF IOPTND(3)=80 C ! LINESIZE=80 IOPTND(4)=1 C ! CLASSHEAD (other options C ! not implemented.) IOPTND(5)=57 C ! pagesize=57 IOPTND(6)=2 C ! UNCENTERED IOPTND(NPOPTN-2)=1 C ! MEANS IOPTND(NPOPTN-1)=0 C ! OUTFORMAT=0 IOPTND(NPOPTN)=4 C ! NDECIMAL=4 OUTFMT=0 ISOPEN=0 C ! scratch1 not yet open NVIN=NVTOT VTMPSZ=MVAR-SVTEMP+1 IF(NCLASS.GT.0) THEN C ! space reserved as work I=3*NCLASS C ! array for calls to CLCHCK CALL ROOMI(I) END IF C C For each variable store the number of the block in MXSIZE C IV=0 DO 7 ICLBLK=1,NCLBLK IF(BLVSIZ(ICLBLK).GT.0) THEN DO 6 I=1,BLVSIZ(ICLBLK) IV=IV+1 MXSIZE(IV)=ICLBLK 6 CONTINUE END IF 7 CONTINUE NXPTDS=NXPTD NXPTIS=NXPTI MAXVN=MVAR-NVIN C C 3 CONTINUE IF(U5END.GT.0)GO TO 60 LTEMP=REFRSH(IPT) 4 CONTINUE IF(U5END.GT.0)GO TO 60 CALL KYFIND(IKEY,IPT) IF(IKEY.EQ.-1) THEN CALL CRDPRN(1) GO TO 4 END IF IF(IKEY.LT.39.AND.IKEY.NE.36.AND.IKEY.NE.1)GO TO 60 IF(IKEY.GT.48)GO TO 60 IF(IKEY.EQ.1) THEN I=13 CALL CRDPRN(1) CALL SCOPEN(I) ISOPEN=1 GO TO 3 ELSE IF(IKEY.EQ.36) THEN CALL CRDPRN(1) IOPTSV=IOPTND(NPOPTN-1) IOPTND(NPOPTN-1)=0 CALL OPTNTR(NOPTN,INDX,IVALUE,OPTNW,IPT,IPOS,IOPTND) IF(IOPTND(NPOPTN-1).EQ.0) THEN IOPTND(NPOPTN-1)=IOPTSV ELSE IF(IOPTSV.GT.0) THEN IF(U5ECHO.GT.0)WRITE(U6,103) IOPTND(NPOPTN-1)=IOPTSV END IF IF(IFILEF(2).NE.1) THEN IOPTND(2)=2 END IF IF(IOPTND(1).NE.1.AND.IOPTND(1).NE.2) IOPTND(1)=1 IF(IOPTND(2).NE.1.AND.IOPTND(2).NE.2) IOPTND(2)=1 IF(IOPTND(3).LT.120) THEN IOPTND(3)=80 ELSE IF(IOPTND(3).LT.132) THEN IOPTND(3)=120 ELSE IOPTND(3)=132 END IF IF(IOPTND(4).NE.1.AND.IOPTND(4).NE.2)IOPTND(4)=1 IF(IOPTND(5).LT.30)IOPTND(5)=30 IF(IOPTND(6).NE.1)IOPTND(6)=2 IF(IOPTND(NPOPTN-2).NE.2)IOPTND(NPOPTN-2)=1 IF(IOPTND(NPOPTN).LT.0.OR.IOPTND(NPOPTN).GT.19)IOPTND(NPOPTN)=4 IF(IPT.EQ.1) THEN GO TO 4 ELSE GO TO 3 END IF C C LIST, COV, COVARIANCE(S), CORR, CORRELATION(S), T-TEST, TEST, TABLE C ELSE IF(IKEY.GE.40.AND.IKEY.LE.47) THEN IF(IKEY.EQ.42) THEN IKEY=41 ELSE IF(IKEY.EQ.44) THEN IKEY=43 ELSE IF(IKEY.EQ.46) THEN IKEY=45 END IF IF(ISOPEN.EQ.0) THEN I=13 CALL SCOPEN(I) ISOPEN=1 END IF CALL CRDPRN(1) DO 5 I=1,NPOPTN IOPTNC(I)=IOPTND(I) 5 CONTINUE IBEYND=0 INEXT=0 IF(IPT.EQ.2) THEN IF(CARD(2:2).EQ.'-')IPT=3 CALL CMATCH(CARD(3:6),3,6,'TEST',4,IPOS,1) IF(IPOS.GT.0) THEN IPT=7 IF(CARD(7:7).EQ.'S'.OR.CARD(7:7).EQ.'s')IPT=8 END IF END IF SICLSS=NXPTIS IV=0 IVS=1 ILTOT=0 IXTOT=0 10 CONTINUE CALL NBFND2(IPT,IPOS) IF(IPT.EQ.1)IBEYND=1 IF(IPOS.LE.0) THEN INEXT=1 GO TO 50 END IF IF(CARD(IPOS:IPOS).EQ.'/') THEN IPT=IPOS+1 IF(IPOS.GT.256) THEN IBEYND=1 IF(.NOT.REFRSH(IPT)) THEN INEXT=1 GO TO 50 ELSE GO TO 10 END IF END IF GO TO 10 END IF C IF(IPOS.LE.76) THEN CALL CMATCH(CARD(IPOS:256),IPOS,256,'CLASS',5,IPOS2,1) IF(IPOS2.GT.0) THEN IPOS=IPOS2 MAXIA=(MDSZI-SICLSS-2)/3 MAXRT=MSIZED-NXPTD+1 IF(MVAR-IV.LT.MAXRT)MAXRT=MVAR-IV CALL CLSCAN(IPOS,IPOS2,IX(SICLSS+2),MAXIA,IX(SICLSS), . VTEMP(SVTEMP),VTMPSZ,DX(NXPTD),MAXRT,V1(IV+1),V2(IV+1), . NVIN) IF(IPOS.EQ.1)IBEYND=1 K=SICLSS+2 ICLSIZ=0 15 CONTINUE N=IX(K) ICLSIZ=ICLSIZ+IX(K+2) K=K+3*IX(K)+3 IF(K.LT.SICLSS+3*IX(SICLSS)+2)GO TO 15 ILTOT=ILTOT+IXTOT*ICLSIZ IXTOT=0 IF(IVS.LE.IV) THEN DO 19 I=IVS,IV ICLX=SICLSS+2 185 CONTINUE IF(V2(I).EQ.9) THEN CALL CLCHCK(V1(I),V1(I),V2(I),IX(ICLX),IX(ICLX)) ELSE CALL CLCHCK(MXSIZE(V1(I)),V1(I),V2(I),IX(ICLX),IX(ICLX)) END IF IF(ICLX+3+3*IX(ICLX).LE.SICLSS+3*IX(SICLSS)+1) THEN ICLX=ICLX+3+3*IX(ICLX) GO TO 185 END IF V3(I)=SICLSS-NXPTIS+1 19 CONTINUE END IF IVS=IV+1 SICLSS=SICLSS+3*IX(SICLSS)+2 IF(IPOS2.EQ.0) THEN INEXT=1 GO TO 50 ELSE IPT=IPOS2 GO TO 10 END IF END IF C END IF CALL CMATCH(CARD(IPOS:256),IPOS,256,'OPTIONS',7,IPOS2,1) IF(IPOS2.EQ.0) THEN CALL CMATCH(CARD(IPOS:256),IPOS,256,'OPTION',6,IPOS2,1) END IF IF(IPOS2.GT.256) THEN IF(.NOT.REFRSH(IPOS2))GO TO 10 END IF IF(IPOS2.GT.0) THEN IPT=IPOS2 IOPTNC(NPOPTN-1)=0 CALL OPTNTR(NOPTN,INDX,IVALUE,OPTNW,IPT,IPOS,IOPTNC) IF(IOPTNC(NPOPTN-1).GT.0) THEN IF(IOPTNC(NPOPTN-1).GT.5)IOPTNC(NPOPTN-1)=1 IF(IOPTND(NPOPTN-1).EQ.0) THEN IOPTND(NPOPTN-1)=IOPTNC(NPOPTN-1) ELSE IF(U5ECHO.GT.0)WRITE(U6,103) END IF END IF IF(IPT.EQ.1)IBEYND=1 IF(IFILEF(2).NE.1) THEN IOPTNC(2)=2 END IF IF(IOPTNC(1).NE.1.AND.IOPTNC(1).NE.2) IOPTNC(1)=1 IF(IOPTNC(2).NE.1.AND.IOPTNC(2).NE.2) IOPTNC(2)=1 IF(IOPTNC(3).LT.120) THEN IOPTNC(3)=80 ELSE IF(IOPTNC(3).LT.132) THEN IOPTNC(3)=120 ELSE IOPTNC(3)=132 END IF IF(IOPTNC(4).NE.1.AND.IOPTNC(4).NE.2)IOPTNC(4)=1 IF(IOPTNC(5).LT.30)IOPTNC(5)=30 IF(IOPTNC(6).NE.1)IOPTNC(6)=2 IF(IOPTNC(NPOPTN-2).NE.2)IOPTNC(NPOPTN-2)=1 IF(IOPTNC(NPOPTN).LT.0.OR.IOPTNC(NPOPTN).GT.19) . IOPTNC(NPOPTN)=4 IPT=IPOS IF(IPOS.EQ.0) THEN INEXT=1 GO TO 50 ELSE GO TO 10 END IF END IF IPT=IPOS K=MVAR-IV CALL VTSCAN(IPT,VNAME,MTYPE,MSIZE,CDMPNT,CROSSD,NVIN, . VTEMP(SVTEMP),VTMPSZ,V1(IV+1),V2(IV+1),RSTPNT(IV+1),K, . N,LTOT,IPOS,IERR) IF(IERR.GT.0)GO TO 95 IF(IPT.EQ.1)IBEYND=1 IXLOC=0 DO 30 I=1,N RCTYPE(IV+I)=IOPTNC(NPOPTN) IF(V2(IV+I).NE.9) THEN MT=MTYPE(V1(IV+I)) IF(MT.EQ.4) THEN K=V1(IV+I) WRITE(U6,202)VNAME(K) GO TO 99 ELSE IF(V2(IV+I).EQ.0) THEN IF(MT.LT.10) THEN V2(IV+I)=IOPTNC(NPOPTN-2) IF(MT.EQ.2.OR.MT.EQ.8)RSTPNT(IV+I)=RSTPNT(IV+I)/2 ELSE V2(IV+I)=10 END IF END IF IF(MT.EQ.1) THEN K=V1(IV+I) IF(BLTYPE(MXSIZE(K)).NE.1) THEN IF(V2(IV+I).EQ.1) THEN V2(IV+I)=2 IF(U5ECHO.GT.0)WRITE(U6,175)VNAME(K) ELSE IF(V2(IV+I).EQ.8) THEN WRITE(U6,176)VNAME(K) GO TO 99 END IF END IF END IF ELSE IF(BLTYPE(V1(IV+I)).NE.1) THEN WRITE(U6,177)V1(IV+I) GO TO 99 END IF END IF IXTOT=IXTOT+RSTPNT(IV+I) 30 CONTINUE IV=IV+N IF(IPOS.EQ.0) THEN INEXT=1 GO TO 50 ELSE IPT=IPOS IF(N.EQ.0)IPT=IPT+1 GO TO 10 END IF 50 CONTINUE IF(IV.GE.IVS) THEN DO 52 I=IVS,IV V3(I)=0 IF(V2(I).EQ.9) THEN CALL CLCHCK(V1(I),V1(I),V2(I),IX,0) ELSE CALL CLCHCK(MXSIZE(V1(I)),V1(I),V2(I),IX,0) END IF 52 CONTINUE ILTOT=ILTOT+IXTOT END IF K=SICLSS-NXPTIS WRITE(13)IKEY,IV,ILTOT,K WRITE(13)(IOPTNC(I),I=1,NPOPTN-3) IF(IV.GT.0) THEN CALL INTOUT(13,V1,IV) CALL INTOUT(13,V2,IV) CALL INTOUT(13,V3,IV) CALL INTOUT(13,RSTPNT,IV) CALL INTOUT(13,RCTYPE,IV) IF(K.GT.0) THEN CALL INTOUT(13,IX(NXPTIS),K) END IF END IF IF(IBEYND.EQ.1) THEN GO TO 4 ELSE GO TO 3 END IF END IF C C C 59 CONTINUE U5END=1 60 CONTINUE IF(IOPTND(NPOPTN-1).GT.0) THEN OUTFMT=IOPTND(NPOPTN-1) ELSE OUTFMT=1 END IF IF(OUTFMT.EQ.3.OR.OUTFMT.EQ.4) THEN 61 CONTINUE J=1 K=3 L=0 IF(NCLASS.GT.0) THEN DO 62 I=NVREG+1,NVREG+NCLASS IF(OUTFMT.EQ.3) THEN IF(MSIZE(I).GT.999) THEN IF(U5ECHO.GT.0)WRITE(U6,170) OUTFMT=4 GO TO 61 ELSE KK=3 END IF ELSE IF(MSIZE(I).LE.9) THEN KK=1 ELSE IF(MSIZE(I).LE.99) THEN KK=2 ELSE IF(MSIZE(I).LE.999) THEN KK=3 ELSE KK=4 END IF END IF IF(K+KK.GE.80) THEN J=J+1 K=3 END IF IX(L+1)=J IX(L+2)=K IX(L+3)=KK L=L+3 K=K+KK 62 CONTINUE END IF K=(NBY+2)/3 L=0 DO 63 I=1,NCLBLK IF(BLTYPE(I).EQ.1)L=L+1 63 CONTINUE WRITE(11,151)NVTOT,NVREG,NCLASS,NBY,NCLBLK,L,J,K DO 68 I=1,NVTOT IF(I.LE.NVREG+NCLASS.OR.MTYPE(I).EQ.5.OR. . MTYPE(I).EQ.6) THEN IF(MTYPE(I).EQ.8.OR.MTYPE(I).EQ.9.OR.MTYPE(I).EQ.19) THEN K=CDMPNT(I) N=CROSSD(K) L=0 ELSE IF(MTYPE(I).GE.3.AND.MTYPE(I).LE.5) THEN N=0 L=MSIZE(I) ELSE N=0 L=0 END IF WRITE(11,152)I,MTYPE(I),MSIZE(I),N,L,VNAME(I),LABEL(I) IF(L.GT.0) THEN K=LPOINT(I) DO 64 J=1,L WRITE(11,154)J,LEVEL(K) K=K+1 64 CONTINUE ELSE IF(N.GT.0) THEN KK=LPOINT(I) KL=CROSSD(K+N+1) DO 66 J=1,N K=K+1 WRITE(11,153)J,CROSSD(K),VTEMP(KL),LEVEL(KK) KL=KL+1 KK=KK+1 IF(CROSSD(K).GT.0) THEN DO 65 II=1,CROSSD(K) WRITE(11,154)II,LEVEL(KK) KK=KK+1 65 CONTINUE END IF 66 CONTINUE END IF END IF 68 CONTINUE DO 69 I=1,NCLBLK IF(BLTYPE(I).EQ.1) THEN K=NVTOT+I IF(I.LE.9) THEN WRITE(CWORK4,141)I WRITE(CWORK5,141)I CWORK5(2:2)='_' ELSE IF(I.LE.99) THEN WRITE(CWORK4,142)I WRITE(CWORK5,142)I CWORK5(3:3)='_' ELSE IF(I.LE.999) THEN WRITE(CWORK4,143)I WRITE(CWORK5,143)I CWORK5(4:4)='_' ELSE IF(I.LE.9999) THEN WRITE(CWORK4,144)I WRITE(CWORK5,144)I CWORK5(5:5)='_' END IF J=NVTOT+I WRITE(11,155)J,CWORK5,CWORK4 END IF 69 CONTINUE DO 71 I=1,NCLBLK J=BLVSTR(I)+BLVSIZ(I)-1 WRITE(11,156)I,BLTYPE(I),BLNCLS(I),BLVSTR(I),J IF(BLNCLS(I).GT.0) THEN K=BLCPNT(I) DO 70 J=1,BLNCLS(I) WRITE(11,157)J,CLPNT(K),CLTYPE(K) K=K+1 70 CONTINUE END IF 71 CONTINUE IF(NCLASS.GT.0) THEN L=NCLASS*3-2 J=IX(L) IF(J.EQ.1) THEN IF(U5ECHO.GT.0)WRITE(U6,171) ELSE IF(U5ECHO.GT.0)WRITE(U6,172) END IF K=NVREG L=0 DO 72 I=1,NCLASS K=K+1 WRITE(11,158)K,IX(L+1),IX(L+2),IX(L+3) JJ=IX(L+2)+IX(L+3)-1 IF(J.EQ.1) THEN IF(U5ECHO.GT.0)WRITE(U6,173)IX(L+2),JJ,VNAME(K) ELSE IF(U5ECHO.GT.0)WRITE(U6,174)IX(L+1),IX(L+2),JJ,VNAME(K) END IF L=L+3 72 CONTINUE END IF END IF RETURN 95 CONTINUE WRITE(U6,200) 99 CONTINUE CALL FSTOP END SUBROUTINE CLCHCK(ICLBLK,IV,IT,IA,NA) IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) C INTEGER ICLBLK,IV,IT,IA(3,*),NA C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP C 200 FORMAT(' DERIVED TYPE DOES NOT ALLOW COLLAPSING: ',A12) 201 FORMAT(' ERROR IN CLASS SPECIFICATION: ',A12) 202 FORMAT(' ERROR IN CLASS SPECIFICATION, BLOCK: ',I5) C NIN=BLNCLS(ICLBLK) C C If the block has no class variables, then there should either be: C No class specification for the variable, or C A specification of "/CLASS TOTAL" C NOUT=0 C C Loop through specification to identify class variables C IF(NA.GT.0) THEN K=1 7 CONTINUE N=IA(1,K) K=K+1 J=1 9 CONTINUE C C If the specification includes TOTAL, treat it simply as TOTAL C IF(IA(1,K).EQ.0) THEN NOUT=0 GO TO 20 ELSE NOUT=NOUT+1 IF(NIN.EQ.0)GO TO 98 ICLBAR=BLCPNT(ICLBLK) DO 12 I=1,NIN IF(CLPNT(ICLBAR).EQ.IA(1,K))GO TO 13 ICLBAR=ICLBAR+1 12 CONTINUE GO TO 98 13 CONTINUE IF(IT.NE.9) THEN IF(MTYPE(IV).GT.10) THEN IF(IA(2,K).EQ.0.AND.IA(3,K).NE.0.AND. . CLTYPE(ICLBAR).EQ.1)GO TO 97 END IF END IF IF(J.LT.N) THEN K1=K+1 IF(IA(1,K1).EQ.IA(1,K)) THEN IF(IT.NE.9) THEN IF(MTYPE(IV).GT.10) THEN IF(IA(3,K).EQ.IA(3,K1))GO TO 97 END IF END IF K=K+1 J=J+1 GO TO 13 ELSE DO 14 J1=J+1,N IF(IA(1,K1).EQ.IA(1,K)) THEN GO TO 98 ELSE K1=K1+1 END IF 14 CONTINUE END IF END IF J=J+1 K=K+1 IF(J.LE.N)GO TO 9 IF(K.LE.NA)GO TO 7 END IF END IF 20 CONTINUE IF(IT.NE.9.AND.NIN.GT.0) THEN IF(MTYPE(IV).GT.10) THEN ICLBAR=BLCPNT(ICLBLK) DO 30 I=1,NIN IF(NOUT.GT.0) THEN K=1 23 CONTINUE N=IA(1,K) K=K+1 J=1 25 CONTINUE IF(IA(1,K).EQ.CLPNT(ICLBAR))GO TO 29 J=J+1 K=K+1 IF(J.LE.N)GO TO 25 IF(K.LE.NA)GO TO 23 END IF IF(CLTYPE(ICLBAR).EQ.1)GO TO 97 29 CONTINUE ICLBAR=ICLBAR+1 30 CONTINUE END IF END IF RETURN 97 CONTINUE WRITE(U6,200)VNAME(IV) GO TO 99 98 CONTINUE IF(IT.NE.9) THEN WRITE(U6,201)VNAME(IV) ELSE WRITE(U6,202)IV END IF 99 CONTINUE CALL FSTOP END SUBROUTINE DCREAT IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) C PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) C PARAMETER (MDSZI=MSIZEI+6*MRANGE+2*MRNSET+3*MVAR) PARAMETER (IXFLLD=56+3*MAXIDS) PARAMETER (NPOPTN=6) PARAMETER (NINCR=NPOPTN+3) PARAMETER (MAXLST=20) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C C COMMON /STMBLK/IX,RSTPNT,RCTYPE,V1,V2,V3,MXSIZE INTEGER IX(MDSZI),RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD), . V2(MRECOD),V3(MRECOD),MXSIZE(MVAR) C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL C INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID, . SDWRK,VKEEPF,OUTFMT,IXFILL(IXFLLD) COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT, . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF, . OUTFMT,IXFILL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C INTEGER SDRIN,SDTOT,SDREP,SDVAR,SDVFLG,SDCENT C LOGICAL ENDFLE,HFIRST,END13 LOGICAL ENDFLE,END13 LOGICAL PRINTX,WRITEX INTEGER SDCOSV,SDBYSV DOUBLE PRECISION MISSNG,DT(6),CSUM DATA MISSNG/-98765.432109D0/ C 101 FORMAT('1 ') 102 FORMAT('1',22X,'Covariances of the Sample Estimates') 105 FORMAT(5X,A24,':',3X,A24) 106 FORMAT(5X,A24,':',3X,F15.3) 107 FORMAT('1',21X,'Correlations of the Sample Estimates') 108 FORMAT('1',28X,'T-Tests for Differences') 151 FORMAT('01',I4,I6,2F22.8) 152 FORMAT('02',3I4,F22.8,2D22.14) 153 FORMAT('03',3I4,3D22.14) 154 FORMAT('04',3I4,F22.8,4F11.8) 155 FORMAT('05',3I4,6F11.8) 156 FORMAT('06',3I4,F22.8,4F11.6) 157 FORMAT('07',3I4,6F11.6) 200 FORMAT(' ERROR IN SPECIFICATION') REWIND(13) NREQIN=0 READ(13)IKEYIN,NVINP,ILTOTI,NSCLSS NXPTDS=NXPTD NXPTIS=NXPTI SDCOSV=SDCOEF SDBYSV=SDBYID 1 CONTINUE NXPTD=NXPTDS SICMUL=NXPTI CALL ROOMI(NCLBLK) DO 706 ICLBLK=1,NCLBLK ICSIZE=1 IF(BLNCLS(ICLBLK).GE.1) THEN DO 702 I=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1 IF(CLTYPE(I).EQ.0) THEN ICSIZE=ICSIZE*(MSIZE(CLPNT(I))+1) ELSE ICSIZE=ICSIZE*(MSIZE(CLPNT(I))) END IF 702 CONTINUE END IF IX(SICMUL+ICLBLK-1)=ICSIZE 706 CONTINUE SDRIN=NXPTD CALL ROOMD(TSIZE) END13=.FALSE. LBASE=NXPTI-NINCR-1 K=MAXLST*NINCR CALL ROOMI(K) NLIST=0 ISBASE=NXPTI IV=0 IXSIZE=0 IXSIZ2=0 IXSIZC=0 2 CONTINUE IF(NLIST.GE.MAXLST)GO TO 4 IF(IV+NVINP.GT.MVAR)GO TO 4 IF(ISBASE+NSCLSS+2*NCLASS.GT.MDSZI)GO TO 4 K=NXPTDS+3*IXSIZE+2*IXSIZ2+IXSIZC IF(NLIST.GT.0) THEN IF(IKEYIN.EQ.40.OR.IKEYIN.EQ.47) THEN IF(K+6*ILTOTI+TSIZE.GT.MSIZED)GO TO 4 ELSE IF(K+4*ILTOTI+ILTOTI*(ILTOTI+1)+TSIZE.GT.MSIZED)GO TO 4 END IF END IF NLIST=NLIST+1 NREQIN=NREQIN+1 K=LBASE+NINCR*NLIST IX(K+1)=IKEYIN IX(K+2)=NVINP IX(K+3)=ILTOTI IXSIZE=IXSIZE+ILTOTI IF(IKEYIN.EQ.40.OR.IKEYIN.EQ.47) THEN IXSIZ2=IXSIZ2+ILTOTI ELSE IXSIZ2=IXSIZ2+(ILTOTI*(ILTOTI+1))/2 END IF READ(13)(IX(J),J=K+4,K+NINCR) IF(IX(K+9).EQ.1)IXSIZC=IXSIZC+ILTOTI K=3*IXSIZE+2*IXSIZ2+IXSIZC IF(K+NXPTD.GT.MSIZED+1)CALL ROOMD(K) IF(NVINP.GT.0) THEN CALL INTIN(13,V1(IV+1),NVINP,END13) CALL INTIN(13,V2(IV+1),NVINP,END13) CALL INTIN(13,V3(IV+1),NVINP,END13) DO 801 J=1,NVINP IF(V3(IV+J).GT.0)V3(IV+J)=V3(IV+J)+ISBASE-1 801 CONTINUE CALL INTIN(13,RSTPNT(IV+1),NVINP,END13) CALL INTIN(13,RCTYPE(IV+1),NVINP,END13) IF(NSCLSS.GT.0) then CALL INTIN(13,IX(ISBASE),NSCLSS,END13) END IF ISBASE=ISBASE+NSCLSS END IF IV=IV+NVINP READ(13,END=3)IKEYIN,NVINP,ILTOTI,NSCLSS GO TO 2 3 CONTINUE END13=.TRUE. 4 CONTINUE NREQBS=NREQIN-NLIST K=ISBASE-NXPTI IF(K.GT.0)CALL ROOMI(K) SDTOT=NXPTD CALL ROOMD(IXSIZE) SDREP=NXPTD CALL ROOMD(IXSIZE) SDVAR=NXPTD CALL ROOMD(IXSIZ2) SDVFLG=NXPTD CALL ROOMD(IXSIZ2) SDCENT=NXPTD IF(IXSIZC.GT.0)CALL ROOMD(IXSIZC) IF(NBYGRP.EQ.0)NBYGRP=1 DO 99 IBYGRP=1,NBYGRP IF(IXSIZC.GT.0) THEN DO 991 I=1,IXSIZC DX(SDCENT+I-1)=0. 991 CONTINUE END IF CSUM=0. DO 992 I=1,IXSIZ2 DX(SDVAR+I-1)=0. 992 CONTINUE MAXDFL=0 DO 40 IREP=0,NRPTOT READ(12)(DX(NXPTD+I-1),I=1,NIDTOT) IF(IREP.EQ.0) THEN IF(IBYGRP.GT.1) THEN J=SDBYID+NBY*(IBYGRP-1)-1 DO 993 I=1,NBY DX(SDBYID+I-1)=DX(J+I) 993 CONTINUE END IF IBASE=SDTOT-1 ELSE T=DX(SDCOEF+IREP-1) CSUM=CSUM+T IBASE=SDREP-1 END IF CALL UNFIN(12,DX(SDRIN),TSIZE,ENDFLE) ICELL=0 ICELLV=0 IV=0 ICENT=SDCENT DO 39 ILIST=1,NLIST LBASE1=LBASE+ILIST*NINCR IKEY=IX(LBASE1+1) ICHEAD=IX(LBASE1+7) ICELLS=ICELL NICL1=IX(LBASE1+2) DO 31 ICL=1,NICL1 ICHECK=0 IV=IV+1 IF(ICL.EQ.1) THEN IF(ICHEAD.EQ.1) THEN ICHECK=1 ELSE ICHINC=1 END IF ELSE IF(ICHEAD.EQ.1) THEN IF(V3(IV-1).NE.V3(IV)) THEN ICHECK=1 END IF END IF IF(ICHECK.EQ.1) THEN ICHINC=0 DO 721 ICL1=ICL,NICL1 IF(V3(ICL1-ICL+IV).NE.V3(IV))GO TO 722 ICHINC=ICHINC+RSTPNT(ICL1-ICL+IV) 721 CONTINUE 722 CONTINUE END IF ICLSS=V3(IV) IF(V2(IV).EQ.9) THEN ICLBLK=V1(IV) IS=BLXSTR(ICLBLK)+SDRIN-1 ELSE ICLBLK=MXSIZE(V1(IV)) IF(V2(IV).EQ.8) THEN IF(MTYPE(V1(IV)).EQ.1.OR. . (MTYPE(V1(IV)).EQ.3.AND.MSIZE(V1(IV)).EQ.1)) THEN IS=BLXSTR(ICLBLK)+SDRIN-1 ELSE IS=VMAPL(V1(IV))+SDRIN-1 END IF ELSE IS=VMAPL(V1(IV))+SDRIN-1 END IF END IF ISN=BLXSTR(ICLBLK)+SDRIN-1 IF(ICLSS.GT.0) THEN ICLX=ICLSS+2 ICELLT=ICELL 15 CONTINUE IP=IBASE+ICELLT+1 CALL TMOVE1(IS,BLXINC(ICLBLK),ISN,BLXINC(ICLBLK),IP,ICHINC, . IX(ICLX),IX(ICLX),ICLBLK,V1(IV),V2(IV)) IF(ICLX+3+3*IX(ICLX).LE.ICLSS+3*IX(ICLSS)+1) THEN IF(ICHEAD.EQ.1) THEN ICELLT=ICELLT+ICHINC*(IX(ICLX+2)) ELSE ICELLT=ICELLT+RSTPNT(IV)*IX(ICLX+2) END IF ICLX=ICLX+3+3*IX(ICLX) GO TO 15 END IF IF(ICHEAD.EQ.1) THEN ICHECK=0 IF(ICL.EQ.NICL1) THEN ICHECK=1 ELSE IF(V3(IV+1).NE.V3(IV)) THEN ICHECK=1 END IF END IF IF(ICHECK.EQ.1) THEN ICELL=ICELLT+RSTPNT(IV)+ICHINC*(IX(ICLX+2)-1) ELSE ICELL=ICELL+RSTPNT(IV) END IF ELSE ICELL=ICELLT+RSTPNT(IV)*IX(ICLX+2) END IF ELSE IP=IBASE+ICELL+1 CALL TMOVE1(IS,BLXINC(ICLBLK),ISN,BLXINC(ICLBLK),IP,1,IX, . 0,ICLBLK,V1(IV),V2(IV)) ICELL=ICELL+RSTPNT(IV) END IF 31 CONTINUE NVC=ICELL-ICELLS IF(IREP.EQ.0) THEN IF(IKEY.GT.40.AND.IKEY.NE.47) THEN DO 33 I=1,NVC DO 32 J=1,I IF(DABS(DX(IBASE+ICELLS+I)-MISSNG).LT..1D-6.OR. . DABS(DX(IBASE+ICELLS+J)-MISSNG).LT..1D-6) THEN DX(SDVFLG+ICELLV)=2.D0 ELSE DX(SDVFLG+ICELLV)=1.D0 END IF ICELLV=ICELLV+1 32 CONTINUE 33 CONTINUE ELSE DO 34 I=1,NVC IF(DABS(DX(IBASE+ICELLS+I)-MISSNG).LT..1D-6) THEN DX(SDVFLG+ICELLV)=2.D0 ELSE DX(SDVFLG+ICELLV)=1.D0 END IF ICELLV=ICELLV+1 34 CONTINUE END IF ELSE IF(IX(LBASE1+9).EQ.1) THEN DO 994 I=1,NVC IF(DABS(DX(SDREP+ICELLS+I-1)-MISSNG).GT..1D-06) THEN DX(ICENT)=DX(ICENT)+T*(DX(SDREP+ICELLS+I-1)- . DX(SDTOT+ICELLS+I-1)) END IF ICENT=ICENT+1 994 CONTINUE END IF IF(IKEY.GT.40.AND.IKEY.NE.47) THEN DO 36 I=1,NVC DO 35 J=1,I IF(DABS(DX(SDREP+ICELLS+I-1)-MISSNG).LT..1D-6.OR. . DABS(DX(SDREP+ICELLS+J-1)-MISSNG).LT..1D-6) THEN IF(DABS(DX(SDVFLG+ICELLV)-2.D0).EQ.1.D0) THEN DX(SDVFLG+ICELLV)=3.D0 END IF ELSE IF(DABS(DX(SDREP+ICELLS+I-1)-MISSNG).GT..1D-6.AND. . DABS(DX(SDREP+ICELLS+J-1)-MISSNG).GT..1D-6) THEN DX(SDVAR+ICELLV)=DX(SDVAR+ICELLV)+T* . (DX(SDREP+ICELLS+I-1) - DX(SDTOT+ICELLS+I-1))* . (DX(SDREP+ICELLS+J-1) - DX(SDTOT+ICELLS+J-1)) END IF ICELLV=ICELLV+1 35 CONTINUE 36 CONTINUE ELSE DO 38 I=1,NVC IF(DABS(DX(SDREP+ICELLS+I-1)-MISSNG).LT..1D-6) THEN IF(DABS(DX(SDVFLG+ICELLV)-2.D0).EQ.1.D0) THEN DX(SDVFLG+ICELLV)=3.D0 END IF ELSE DX(SDVAR+ICELLV)=DX(SDVAR+ICELLV)+T* . (DX(SDREP+ICELLS+I-1) - DX(SDTOT+ICELLS+I-1))* . (DX(SDREP+ICELLS+I-1) - DX(SDTOT+ICELLS+I-1)) END IF ICELLV=ICELLV+1 38 CONTINUE END IF END IF 39 CONTINUE 40 CONTINUE ICELLS=0 ICELLV=SDVAR ICELL=SDTOT IV=0 ICENT=SDCENT DO 96 ILIST=1,NLIST ICLLVS=ICELLV LBASE1=LBASE+NINCR*ILIST IKEY=IX(LBASE1+1) IPRINT=IX(LBASE1+4) IF(IPRINT.EQ.1) THEN PRINTX=.TRUE. ELSE PRINTX=.FALSE. END IF IWRITE=IX(LBASE1+5) IF(IKEY.EQ.40.OR.IKEY.EQ.47) THEN IF(IX(LBASE1+9).EQ.1.AND.CSUM.NE.0.) THEN DO 995 I=1,IX(LBASE1+3) T=DX(ICENT)*DX(ICENT)/CSUM IF(T.LE.DX(ICELLV+I-1)) THEN DX(ICELLV+I-1)=DX(ICELLV+I-1)-T ELSE DX(ICELLV+I-1)=0. END IF ICENT=ICENT+1 995 CONTINUE END IF IFTYPE=0 DO 41 I=1,IX(LBASE1+3) IF(DX(ICELLV+I-1).GT.0.) THEN DX(ICELLV+I-1)=DSQRT(DX(ICELLV+I-1)) END IF 41 CONTINUE IF(IWRITE.EQ.1.AND.(OUTFMT.EQ.1.OR.OUTFMT.EQ.2)) THEN J=NREQBS+ILIST DO 415 I=1,IX(LBASE1+3) WRITE(11,151)J,I,DX(ICELL+I-1),DX(ICELLV+I-1) 415 CONTINUE END IF IV2END=1 IV2INC=1 ELSE IV2END=IX(LBASE1+3) IF(IX(LBASE1+9).EQ.1.AND.CSUM.NE.0.) THEN K=0 DO 997 I=1,IV2END DO 996 J=1,I T=DX(ICENT+I-1)*DX(ICENT+J-1)/CSUM IF(I.NE.J.OR.T.LE.DX(ICELLV+K)) THEN DX(ICELLV+K)=DX(ICELLV+K)-T ELSE DX(ICELLV+K)=0. END IF K=K+1 996 CONTINUE 997 CONTINUE ICENT=ICENT+IV2END END IF IF(IKEY.EQ.43) THEN IFTYPE=1 J=IX(LBASE1+6) IF(J.EQ.132) THEN IV2INC=12 ELSE IF(J.EQ.120) THEN IV2INC=11 ELSE IV2INC=6 END IF J=0 DO 42 I=1,IV2END IF(DX(ICELLV+J).GT..0) THEN DX(ICELLV+J)=DSQRT(DX(ICELLV+J)) END IF J=J+I+1 42 CONTINUE K3=1 DO 45 I=2,IV2END K1=(I*(I+1))/2-1 DO 44 J=1,I-1 K2=(J*(J+1))/2-1 IF(DX(ICELLV+K1).GT.0..AND. . DX(ICELLV+K2).GT.0.) THEN DX(ICELLV+K3)=DX(ICELLV+K3)/ . (DX(ICELLV+K1)*DX(ICELLV+K2)) END IF K3=K3+1 44 CONTINUE K3=K3+1 45 CONTINUE J=0 DO 46 I=1,IV2END IF(DX(ICELLV+J).GT..0) THEN DX(ICELLV+J)=1.D0 END IF J=J+I+1 46 CONTINUE ELSE IF(IKEY.EQ.45) THEN IFTYPE=1 J=IX(LBASE1+6) IF(J.EQ.132) THEN IV2INC=12 ELSE IF(J.EQ.120) THEN IV2INC=11 ELSE IV2INC=6 END IF K3=1 DO 49 I=2,IV2END K1=(I*(I+1))/2-1 DO 48 J=1,I-1 K2=(J*(J+1))/2-1 IF((DX(ICELLV+K1).GT.0..OR. . DX(ICELLV+K2).GT.0.).AND. . DABS(DX(ICELL+I-1)-MISSNG).GT..1D-6.AND. . DABS(DX(ICELL+J-1)-MISSNG).GT..1D-6) THEN TVAR=DX(ICELLV+K1)+DX(ICELLV+K2) . -2.0D0*DX(ICELLV+K3) IF(TVAR*TVAR.GT..1D-12*DX(ICELLV+K1)* . DX(ICELLV+K2)) THEN DX(ICELLV+K3)= . (DX(ICELL+I-1)-DX(ICELL+J-1))/ . DSQRT(TVAR) IF(DX(ICELLV+K3).GT.999.999D0) THEN DX(ICELLV+K3)=999.999D0 ELSE IF(DX(ICELLV+K3).LT.-999.999D0) THEN DX(ICELLV+K3)=-999.999D0 END IF ELSE DX(ICELLV+K3)=0. END IF END IF K3=K3+1 48 CONTINUE K3=K3+1 49 CONTINUE J=0 DO 50 I=1,IV2END DX(ICELLV+J)=0. J=J+I+1 50 CONTINUE ELSE IFTYPE=2 J=IX(LBASE1+6) IF(J.EQ.132) THEN IV2INC=6 ELSE IF(J.EQ.120) THEN IV2INC=5 ELSE IV2INC=3 END IF END IF IF(IWRITE.EQ.1.AND.(OUTFMT.EQ.1.OR.OUTFMT.EQ.2)) THEN L=NREQBS+ILIST DO 60 I=1,IX(LBASE1+3) JSTART=1 IF(OUTFMT.EQ.1) THEN IF(IKEY.EQ.41) THEN JEND=JSTART+2 ELSE JEND=JSTART+5 END IF ELSE IF(IKEY.EQ.41) THEN JEND=JSTART+1 ELSE JEND=JSTART+3 END IF END IF 51 CONTINUE IF(JEND.GT.IX(LBASE1+3))JEND=IX(LBASE1+3) K1=0 DO 52 JJ=JSTART,JEND K1=K1+1 IF(I.GE.JJ) THEN K3=(I*(I-1))/2+JJ ELSE K3=(JJ*(JJ-1))/2+I END IF DT(K1)=DX(ICELLV+K3-1) 52 CONTINUE IF(JSTART.EQ.1.AND.OUTFMT.EQ.2) THEN IF(IKEY.EQ.41) THEN WRITE(11,152)L,I,IX(LBASE1+3),DX(ICELL+I-1), . (DT(K3),K3=1,K1) ELSE IF(IKEY.EQ.43) THEN WRITE(11,154)L,I,IX(LBASE1+3),DX(ICELL+I-1), . (DT(K3),K3=1,K1) ELSE WRITE(11,156)L,I,IX(LBASE1+3),DX(ICELL+I-1), . (DT(K3),K3=1,K1) END IF ELSE IF(IKEY.EQ.41) THEN WRITE(11,153)L,I,IX(LBASE1+3),(DT(K3),K3=1,K1) ELSE IF(IKEY.EQ.43) THEN WRITE(11,155)L,I,IX(LBASE1+3),(DT(K3),K3=1,K1) ELSE WRITE(11,157)L,I,IX(LBASE1+3),(DT(K3),K3=1,K1) END IF END IF JSTART=JEND+1 IF(IKEY.EQ.41) THEN JEND=JSTART+2 ELSE JEND=JSTART+5 END IF IF(JSTART.LE.IX(LBASE1+3))GO TO 51 60 CONTINUE END IF END IF LINE=2 IF(IPRINT.EQ.1) THEN IF(IKEY.EQ.40.OR.IKEY.EQ.47) THEN WRITE(U6,101) ELSE IF(IKEY.EQ.41) THEN WRITE(U6,102) ELSE IF(IKEY.EQ.43) THEN WRITE(U6,107) ELSE IF(IKEY.EQ.45) THEN WRITE(U6,108) END IF IF(NBY.GT.0) THEN K=SDBYID+NBY*(IBYGRP-1) IF(VFTYPE.LE.4.OR.VFTYPE.GE.13) THEN L=NVREG+NCLASS+NVARID+1 ELSE L=NVREG+NCLASS+NVARID END IF DO 300 I=1,NBY IF(MTYPE(L).EQ.5) THEN ITEMP=DX(K)+.05D0 WRITE(U6,105)LABEL(L),LEVEL(LPOINT(L)+ITEMP-1) ELSE WRITE(U6,106)LABEL(L),DX(K) END IF LINE=LINE+1 L=L+1 K=K+1 300 CONTINUE END IF END IF ICHEAD=IX(LBASE+NINCR*ILIST+7) IF(IWRITE.EQ.1.AND.(OUTFMT.EQ.3.OR.OUTFMT.EQ.4)) THEN WRITEX=.TRUE. ELSE WRITEX=.FALSE. END IF NREQST=NREQBS+ILIST IF(IKEY.EQ.40.AND.ICHEAD.EQ.1) THEN K=LBASE+NINCR*ILIST+1 CALL LIST(IV,ICELL,ICELLV,IX(K),LINE,PRINTX,WRITEX,NREQST, . IXSIZ2) GO TO 96 ELSE IF(ICHEAD.EQ.1) THEN K=LBASE+NINCR*ILIST+1 CALL COVLST(IV,ICELL,ICELLV,IX(K),IV2INC,IV2END,PRINTX,WRITEX, . NREQST) GO TO 96 END IF 96 CONTINUE 99 CONTINUE IF(END13) THEN CLOSE(12) INQUIRE(UNIT=11,OPENED=WRITEX) IF(WRITEX)CLOSE(11) RETURN ELSE REWIND(12) NXPTI=NXPTIS NXPTD=NXPTDS CALL PREAMB SDCOEF=SDCOSV SDBYID=SDBYSV GO TO 1 END IF END SUBROUTINE LIST(IV,ICELL,ICELLV,IOPTN,LINE,PRINTX,WRITEX,NREQST, . IXSIZ2) IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) C PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) C PARAMETER (MDSZI=MSIZEI+6*MRANGE+2*MRNSET+3*MVAR) PARAMETER (IXFLLD=56+3*MAXIDS) PARAMETER (NPOPTN=5) PARAMETER (NINCR=NPOPTN+3) PARAMETER (MAXLST=20) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C C COMMON /STMBLK/IX,RSTPNT,RCTYPE,V1,V2,V3,MXSIZE INTEGER IX(MDSZI),RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD), . V2(MRECOD),V3(MRECOD),MXSIZE(MVAR) C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL C INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID, . SDWRK,VKEEPF,OUTFMT,IXFILL(IXFLLD) COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT, . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF, . OUTFMT,IXFILL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C DIMENSION IOPTN(NINCR) LOGICAL HFIRST,PRINTX,WRITEX INTEGER SI1,SI2,SI3,SI4 CHARACTER *11 VTYPE(7) CHARACTER *41 VLINE C DOUBLE PRECISION MISSNG C DATA MISSNG/-98765.432109D0/ DATA VTYPE / 'MEAN ','TOTAL ','PERCENTS ', . 'VALUE ','PROPORTION ','WEIGHTED N ','2-WAY PCNT '/ C 101 FORMAT('1 ') 105 FORMAT(5X,A24,':',3X,A24) 107 FORMAT(/,51X,'Estimate',6X,'Standard error',/) 110 FORMAT(/,' Sample N (wtd) for block',I4,10X,A41) 111 FORMAT(/,1X,A24,': ',A11,A41) 112 FORMAT(/,1X,A24,': ',A11) 113 FORMAT(4X,A24,11X,A41) 114 FORMAT(/,' Crossed values of ',A24,': ',A11) 115 FORMAT(4X,A24,': ',A24) 116 FORMAT(4X,A24) 117 FORMAT(7X,A24,8X,A41) 118 FORMAT(7X,A24,8X,A41) 124 FORMAT(/) 161 FORMAT(5X,A24,': TOTAL') 162 FORMAT(33X,A24) 163 FORMAT(33X,'TOTAL') 171 FORMAT('99',I4,I6,' 1',I2,2I4,2F22.8) SIVMAP=NXPTI I=2*NCLASS+1 CALL ROOMI(I) IDCELL=0 NICL1=IOPTN(2) IPAGE=IOPTN(8) ICL=1 301 CONTINUE ICHINC=0 DO 302 ICL2=ICL,NICL1 IF(V3(ICL2+IV).NE.V3(IV+ICL))GO TO 303 ICHINC=ICHINC+RSTPNT(IV+ICL2) 302 CONTINUE ICL2=NICL1+1 303 CONTINUE ICL2=ICL2-1 ICLSS=V3(IV+ICL) IF(ICLSS.GT.0) THEN ICLX=ICLSS+2 ELSE IX(SIVMAP)=0 ICLX=0 NCLV=0 END IF 305 CONTINUE IF(ICLX.GT.0) THEN N=IX(ICLX) SI1=NXPTI NCLV=IX(ICLX+1) IF(NCLV.EQ.0) GO TO 311 SI2=SI1+NCLV J=2*NCLV CALL ROOMI(J) DO 306 J=0,NCLV-1 IX(SI1+J)=0 306 CONTINUE IX(SI1)=-1 J=0 KICLX=ICLX+3 DO 310 JJ=1,N IF(JJ.LT.N) THEN IF(IX(KICLX+3).EQ.IX(KICLX))GO TO 309 END IF IF(IX(KICLX).EQ.0) THEN NCLV=0 ELSE IF(IX(KICLX+2).EQ.0) THEN IX(SI2+J)=MSIZE(IX(KICLX)) ELSE IX(SI2+J)=IX(KICLX+2) END IF J=J+1 309 CONTINUE KICLX=KICLX+3 310 CONTINUE 311 CONTINUE END IF 312 CONTINUE IF(NCLV.GT.0) THEN DO 315 I=1,NCLV IX(SI1+I-1)=IX(SI1+I-1)+1 IF(IX(SI1+I-1).LT.IX(SI2+I-1)) THEN IF(I.GT.1) THEN DO 314 J=1,I-1 IX(SI1+J-1)=0 314 CONTINUE END IF GO TO 316 END IF 315 CONTINUE GO TO 342 316 CONTINUE IF(LINE.GT.IPAGE-12) THEN IF(PRINTX)WRITE(U6,101) LINE=2 ELSE IF(PRINTX) THEN WRITE(U6,124) LINE=LINE+2 END IF N=IX(ICLX) L=SIVMAP DO 320 I=1,NCLV J=0 KICLX=ICLX+3 DO 319 JJ=1,N IF(JJ.EQ.1) THEN J=J+1 ELSE IF(IX(KICLX).NE.IX(KICLX-3)) THEN J=J+1 END IF IF(J.NE.I) GO TO 318 IF(IX(KICLX+2).NE.0) THEN IF(IX(KICLX+2).NE.IX(SI1+I-1)+1)GO TO 318 ICHECK=0 IF(JJ.GT.1) THEN IF(IX(KICLX).EQ.IX(KICLX-3).AND. . IX(KICLX+2).EQ.IX(KICLX-1)) THEN IF(IX(KICLX+1).EQ.0) THEN IF(PRINTX)WRITE(U6,163) ELSE IVC=IX(KICLX) IF(PRINTX) . WRITE(U6,162)LEVEL(LPOINT(IVC)+IX(KICLX+1)-1) END IF LINE=LINE+1 ICHECK=1 END IF END IF IF(ICHECK.EQ.0) THEN IVC=IX(KICLX) IX(L)=IVC-NVREG IX(L+1)=IX(KICLX+1) L=L+2 IF(IX(KICLX+1).EQ.0) THEN IF(PRINTX)WRITE(U6,161)LABEL(IVC) ELSE IF(PRINTX) THEN WRITE(U6,105)LABEL(IVC),LEVEL(LPOINT(IVC)+IX(KICLX+1)-1) END IF LINE=LINE+1 END IF ELSE IVC=IX(KICLX) IX(L)=IVC-NVREG IX(L+1)=IX(SI1+I-1)+1 L=L+2 IF(PRINTX) . WRITE(U6,105)LABEL(IVC),LEVEL(LPOINT(IVC)+IX(SI1+I-1)) LINE=LINE+1 END IF 318 CONTINUE KICLX=KICLX+3 319 CONTINUE 320 CONTINUE IX(L)=0 ELSE IF(LINE.GT.IPAGE-7) THEN IF(PRINTX)WRITE(U6,101) LINE=2 END IF END IF IF(PRINTX)WRITE(U6,107) LINE=LINE+3 DO 340 ICL1=ICL,ICL2 IF(LINE.GT.56) THEN IF(PRINTX)WRITE(U6,101) LINE=2 END IF IF(V2(IV+ICL1).EQ.9) THEN IF(PRINTX) THEN CALL FVLINE(DX(ICELL),DX(ICELLV),DX(ICELLV+IXSIZ2), . RCTYPE(IV+ICL1),VLINE) WRITE(U6,110)V1(IV+ICL1),VLINE END IF IF(WRITEX) THEN CALL CLWRTE IDCELL=IDCELL+1 II=NVTOT+V1(IV+ICL1) I=2 JJ=1 WRITE(11,171)NREQST,IDCELL,I,II,JJ,DX(ICELL),DX(ICELLV) END IF ICELLV=ICELLV+1 ICELL=ICELL+1 LINE=LINE+2 ELSE IVX=V1(IV+ICL1) ITTYPE=V2(IV+ICL1) MT=MTYPE(IVX) IF(ITTYPE.EQ.8) THEN IFLAG=6 ELSE IF(MT.EQ.11.OR.MT.EQ.13.OR.MT.EQ.19) THEN IFLAG=4 ELSE IF(ITTYPE.EQ.2.OR.ITTYPE.EQ.4) THEN IFLAG=2 ELSE IF(ITTYPE.EQ.5) THEN IFLAG=7 ELSE IF(ITTYPE.EQ.1.OR.ITTYPE.EQ.3) THEN IF(MT.EQ.3.OR.MT.EQ.9) THEN IFLAG=3 ELSE IFLAG=1 END IF ELSE IF(ITTYPE.EQ.6.OR.ITTYPE.EQ.7) THEN IFLAG=5 END IF IF(MT.EQ.1.OR.MT.EQ.2.OR.MT.EQ.11.OR. . (MT.EQ.3.AND.(ITTYPE.EQ.8.OR.MSIZE(IVX).EQ.1)).OR. . (MSIZE(IVX).EQ.2.AND.MT.EQ.3.AND. . (ITTYPE.EQ.3.OR.ITTYPE.EQ.4.OR.ITTYPE.EQ.7))) THEN IF(PRINTX) THEN CALL FVLINE(DX(ICELL),DX(ICELLV),DX(ICELLV+IXSIZ2), . RCTYPE(IV+ICL1),VLINE) WRITE(U6,111)LABEL(IVX),VTYPE(IFLAG),VLINE END IF IF(WRITEX) THEN CALL CLWRTE IDCELL=IDCELL+1 J=1 WRITE(11,171)NREQST,IDCELL,ITTYPE,IVX,J,DX(ICELL), . DX(ICELLV) END IF ICELLV=ICELLV+1 ICELL=ICELL+1 LINE=LINE+2 ELSE IF(MT.EQ.3.OR.MT.EQ.13) THEN IF(MSIZE(IVX).LE.6) THEN IF(LINE+MSIZE(IVX)+2.GT.IPAGE) THEN IF(PRINTX)WRITE(U6,101) LINE=2 END IF ELSE IF(LINE+5.GT.IPAGE) THEN IF(PRINTX)WRITE(U6,101) LINE=2 END IF END IF IF(PRINTX)WRITE(U6,112)LABEL(IVX),VTYPE(IFLAG) LINE=LINE+2 IF(ITTYPE.EQ.3.OR.ITTYPE.EQ.4.OR.ITTYPE.EQ.7) THEN II=MSIZE(IVX)-1 ELSE II=MSIZE(IVX) END IF DO 325 I=1,II IF(LINE.GE.IPAGE) THEN IF(PRINTX)WRITE(U6,101) LINE=2 END IF IF(PRINTX) THEN CALL FVLINE(DX(ICELL),DX(ICELLV),DX(ICELLV+IXSIZ2), . RCTYPE(IV+ICL1),VLINE) WRITE(U6,113)LEVEL(LPOINT(IVX)+I-1),VLINE END IF IF(WRITEX) THEN CALL CLWRTE IDCELL=IDCELL+1 WRITE(11,171)NREQST,IDCELL,ITTYPE,IVX,II,DX(ICELL), . DX(ICELLV) END IF LINE=LINE+1 ICELLV=ICELLV+1 ICELL=ICELL+1 325 CONTINUE ELSE IF(MT.EQ.8.OR.MT.EQ.9.OR.MT.EQ.19) THEN L=LPOINT(IVX) K=CDMPNT(IVX) HFIRST=.TRUE. IF(MT.EQ.8) THEN KSIZE=MSIZE(IVX)/2 KINCR=1 ELSE IF(ITTYPE.EQ.8) THEN KSIZE=MSIZE(IVX)/CROSSD(K+1) KINCR=1 ELSE IF(ITTYPE.EQ.3.OR.ITTYPE.EQ.4.OR.ITTYPE.EQ.7) THEN IF(CROSSD(K+1).EQ.1) THEN KINCR=1 KSIZE=MSIZE(IVX) ELSE KINCR=CROSSD(K+1)-1 KSIZE=KINCR*MSIZE(IVX)/CROSSD(K+1) END IF ELSE KSIZE=MSIZE(IVX) KINCR=CROSSD(K+1) END IF N=CROSSD(K) NM=CROSSD(K+N+1) SI3=NXPTI SI4=SI3+N I=2*N CALL ROOMI(I) DO 327 I=1,N IF(I.EQ.2) THEN IX(SI3+I-1)=0 ELSE IX(SI3+I-1)=1 END IF IX(SI4+I-1)=L L=L+1+CROSSD(K+I) 327 CONTINUE IF(KINCR.EQ.1) THEN IF(CROSSD(K+2).GT.6) THEN IF(LINE+N+4.GT.IPAGE) LINE=0 ELSE IF(LINE+N+1+CROSSD(K+2).GT.IPAGE) LINE=0 END IF ELSE IF(CROSSD(K+1).GT.6) THEN IF(LINE+N+4.GT.IPAGE) LINE=0 ELSE IF(LINE+N+1+CROSSD(K+1).GT.IPAGE) LINE=0 END IF END IF IF(LINE.EQ.0) THEN IF(PRINTX)WRITE(U6,101) LINE=2 END IF IF(PRINTX)WRITE(U6,114)LEVEL(IX(SI4)),VTYPE(IFLAG) LINE=LINE+2 328 CONTINUE J=2 330 CONTINUE IX(SI3+J-1)=IX(SI3+J-1)+1 IF(IX(SI3+J-1).GT.CROSSD(K+J)) THEN IF(J.LT.N) THEN IX(SI3+J-1)=1 J=J+1 GO TO 330 ELSE NXPTI=SI3 END IF ELSE IF(J.GT.2.OR.HFIRST) THEN IF(HFIRST) THEN JJ=N ELSE JJ=J END IF IF(KINCR.EQ.1) THEN IF(CROSSD(K+2).GT.6) THEN IF(LINE+JJ+2.GT.IPAGE) LINE=0 ELSE IF(LINE+JJ-1+CROSSD(K+2).GT.IPAGE) LINE=0 END IF ELSE IF(CROSSD(K+1).GT.6) THEN IF(LINE+JJ+2.GT.IPAGE) LINE=0 ELSE IF(LINE+JJ-1+CROSSD(K+1).GT.IPAGE) LINE=0 END IF END IF IF(LINE.EQ.0) THEN IF(PRINTX)WRITE(U6,101) LINE=2 END IF DO 331 I=JJ,3,-1 IF(PRINTX)WRITE(U6,115)LEVEL(IX(SI4+I-1)), . LEVEL(IX(SI4+I-1)+IX(SI3+I-1)) LINE=LINE+1 331 CONTINUE HFIRST=.FALSE. END IF IF(KINCR.EQ.1) THEN IF(LINE+2.GT.IPAGE) THEN IF(PRINTX)WRITE(U6,101) LINE=2 END IF IF(IX(SI3+1).EQ.1) THEN IF(PRINTX)WRITE(U6,116)LEVEL(IX(SI4+1)) LINE=LINE+1 END IF IF(PRINTX) THEN CALL FVLINE(DX(ICELL),DX(ICELLV),DX(ICELLV+IXSIZ2), . RCTYPE(IV+ICL1),VLINE) WRITE(U6,117)LEVEL(IX(SI4+1)+IX(SI3+1)),VLINE END IF IF(WRITEX) THEN CALL CLWRTE IDCELL=IDCELL+1 WRITE(11,171)NREQST,IDCELL,ITTYPE,IVX,RSTPNT(IV+ICL1), . DX(ICELL),DX(ICELLV) END IF LINE=LINE+1 ICELLV=ICELLV+1 ICELL=ICELL+1 ELSE IF(CROSSD(K+1).LE.6) THEN IF(LINE+CROSSD(K+1)+1.GT.IPAGE) THEN IF(PRINTX)WRITE(U6,101) LINE=2 END IF END IF IF(PRINTX)WRITE(U6,115)LEVEL(IX(SI4+1)), . LEVEL(IX(SI4+1)+IX(SI3+1)) LINE=LINE+1 DO 333 I=1,KINCR IF(LINE.GT.IPAGE) THEN IF(PRINTX)WRITE(U6,101) LINE=2 END IF IF(PRINTX) THEN CALL FVLINE(DX(ICELL),DX(ICELLV),DX(ICELLV+IXSIZ2), . RCTYPE(IV+ICL1),VLINE) WRITE(U6,118)LEVEL(IX(SI4)+I),VLINE END IF IF(WRITEX) THEN CALL CLWRTE IDCELL=IDCELL+1 WRITE(11,171)NREQST,IDCELL,ITTYPE,IVX,RSTPNT(IV+ICL1), . DX(ICELL),DX(ICELLV) END IF ICELLV=ICELLV+1 ICELL=ICELL+1 LINE=LINE+1 333 CONTINUE END IF GO TO 328 END IF END IF END IF 340 CONTINUE IF(NCLV.GT.0) GO TO 312 342 CONTINUE IF(ICLSS.GT.0) THEN ICLX=ICLX+3+3*IX(ICLX) IF(ICLX.LE.ICLSS+3*IX(ICLSS)+1) GO TO 305 END IF ICL=ICL2+1 IF(ICL.LE.NICL1) GO TO 301 IV=IV+NICL1 NXPTI=SIVMAP RETURN END SUBROUTINE FVLINE(V,SE,SEFLAG,ND,VLINE) DOUBLE PRECISION V,SE,SEFLAG INTEGER ND CHARACTER*41 VLINE CHARACTER*12 FLINE CHARACTER*1 STAR DOUBLE PRECISION MISSNG DATA MISSNG/-98765.432109D0/ 100 FORMAT('(2F20.',I1,',A1) ') 101 FORMAT('(2F20.',I2,',A1)') 102 FORMAT(17X,'(M)',19X,'- ') IF(DABS(V-MISSNG).LT..1D-06) THEN WRITE(VLINE,102) ELSE IF(ND.LT.10) THEN WRITE(FLINE,100)ND ELSE WRITE(FLINE,101)ND END IF IF(DABS(SEFLAG-3.0D0).LT..1D-06) THEN STAR='*' ELSE STAR=' ' END IF WRITE(VLINE,FMT=FLINE)V,SE,STAR END IF RETURN END SUBROUTINE COVLST(IV,ICELL,ICELLV,IOPTN,IV2INC,IV2END,PRINTX, . WRITEX,NREQST) IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) C PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) C PARAMETER (MDSZI=MSIZEI+6*MRANGE+2*MRNSET+3*MVAR) PARAMETER (IXFLLD=56+3*MAXIDS) PARAMETER (NPOPTN=5) PARAMETER (NINCR=NPOPTN+3) PARAMETER (MAXLST=20) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C C COMMON /STMBLK/IX,RSTPNT,RCTYPE,V1,V2,V3,MXSIZE INTEGER IX(MDSZI),RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD), . V2(MRECOD),V3(MRECOD),MXSIZE(MVAR) C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL C INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID, . SDWRK,VKEEPF,OUTFMT,IXFILL(IXFLLD) COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT, . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF, . OUTFMT,IXFILL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C C DIMENSION IOPTN(NINCR) LOGICAL HFIRST,PRINTX,WRITEX INTEGER SI1,SI2,SI3,SI4 CHARACTER *11 VTYPE(7) DOUBLE PRECISION SECOV EXTERNAL SECOV C C DOUBLE PRECISION MISSNG,SETEMP DOUBLE PRECISION SETEMP C DATA MISSNG/-98765.432109D0/ DATA VTYPE / 'MEAN ','TOTAL ','PERCENTS ', . 'VALUE ','PROPORTION ','WEIGHTED N ','2-WAY PCNT '/ C 105 FORMAT(5X,A24,':',3X,A24) 108 FORMAT(1X) 124 FORMAT(/) 127 FORMAT(/,31X,6(12X,I4)) 130 FORMAT(/,1X,I4,': Sample N for block',I4,2X,6D16.8) 131 FORMAT(/,5X,A24,': ',A11,/,1X,I4,26X,6D16.8) 132 FORMAT(/,5X,A24,': ',A11) 133 FORMAT(1X,I4,': ',A24,6D16.8) 134 FORMAT(/,5X,'Crossed values of ',A24,': ',A11) 135 FORMAT(8X,A24,': ',A24) 136 FORMAT(8X,A24) 137 FORMAT(1X,I4,': ',A24,6D16.8) 138 FORMAT(1X,I4,': ',A24,6D16.8) 147 FORMAT(/,31X,12(4X,I4)) 150 FORMAT(/,1X,I4,': Sample N for block',I4,2X,12F8.3) 151 FORMAT(/,5X,A24,': ',A11,/,1X,I4,26X,12F8.3) 153 FORMAT(1X,I4,': ',A24,12F8.3) 157 FORMAT(1X,I4,': ',A24,12F8.3) 158 FORMAT(1X,I4,': ',A24,12F8.3) 161 FORMAT(5X,A24,': TOTAL') 162 FORMAT(33X,A24) 163 FORMAT(33X,'TOTAL') 171 FORMAT('99',I4,I6,2I2,2I4,2F22.8) 200 FORMAT(1X) 227 FORMAT(/,39X,'Estimate',5(12X,I4)) 230 FORMAT(/,1X,I4,': Sample N for block',I4,2X,F16.4,5D16.8) 231 FORMAT(/,5X,A24,': ',A11,/,1X,I4,26X,F16.4,5D16.8) 233 FORMAT(1X,I4,': ',A24,F16.4,5D16.8) 237 FORMAT(1X,I4,': ',A24,F16.4,5D16.8) 238 FORMAT(1X,I4,': ',A24,F16.4,5D16.8) 247 FORMAT(/,39X,'Estimate',12(4X,I4)) 250 FORMAT(/,1X,I4,': Sample N for block',I4,2X,F16.4,10F8.3) 251 FORMAT(/,5X,A24,': ',A11,/,1X,I4,26X,F16.4,10F8.3) 253 FORMAT(1X,I4,': ',A24,F16.4,10F8.3) 257 FORMAT(1X,I4,': ',A24,F16.4,10F8.3) 258 FORMAT(1X,I4,': ',A24,F16.4,10F8.3) SIVMAP=NXPTI I=2*NCLASS+1 CALL ROOMI(I) NICL1=IOPTN(2) ILTOT=IOPTN(3) IKEY=IOPTN(1) IKEYC=(IKEY-37)/2 IV2=1 ICELLS=ICELL ICLLVS=ICELLV 400 CONTINUE ICL=1 ICELL=ICELLS ITOPW=0 IF(ITOPW.EQ.0) THEN IF(IV2.EQ.1) THEN IF(IKEY.EQ.41) THEN IV2TOP=IV2+IV2INC-2 IF(IV2TOP.GT.IV2END)IV2TOP=IV2END IF(PRINTX)WRITE(U6,227)(ID,ID=IV2,IV2TOP) ELSE IV2TOP=IV2+IV2INC-3 IF(IV2TOP.GT.IV2END)IV2TOP=IV2END IF(PRINTX)WRITE(U6,247)(ID,ID=IV2,IV2TOP) END IF ELSE IV2TOP=IV2+IV2INC-1 IF(IV2TOP.GT.IV2END)IV2TOP=IV2END IF(IKEY.EQ.41) THEN IF(PRINTX)WRITE(U6,127)(ID,ID=IV2,IV2TOP) ELSE IF(PRINTX)WRITE(U6,147)(ID,ID=IV2,IV2TOP) END IF END IF IF(PRINTX)WRITE(U6,200) END IF 401 CONTINUE ICHINC=0 DO 402 ICL2=ICL,NICL1 IF(V3(ICL2+IV).NE.V3(IV+ICL))GO TO 403 ICHINC=ICHINC+RSTPNT(IV+ICL2) 402 CONTINUE ICL2=NICL1+1 403 CONTINUE ICL2=ICL2-1 ICLSS=V3(IV+ICL) IF(ICLSS.GT.0) THEN ICLX=ICLSS+2 ELSE IX(SIVMAP)=0 ICLX=0 NCLV=0 END IF 405 CONTINUE IF(ICLX.GT.0) THEN N=IX(ICLX) IF(IX(ICLX+2).GT.0) THEN IMULTF=IX(ICLX+2) ELSE IMULTF=1 END IF IF(ICHINC*IMULTF+ICELL.LT.IV2+ICELLS) THEN ICELL=ICELL+ICHINC*IMULTF ICLX=ICLX+3+3*IX(ICLX) IF(ICLX.LE.ICLSS+3*IX(ICLSS)+1) GO TO 405 ICL=ICL2+1 IF(ICL.LE.NICL1) GO TO 401 END IF SI1=NXPTI NCLV=IX(ICLX+1) IF(NCLV.EQ.0) THEN ICLX=ICLX+3+3*N GO TO 411 END IF SI2=SI1+NCLV J=2*NCLV CALL ROOMI(J) DO 406 J=0,NCLV-1 IX(SI1+J)=0 406 CONTINUE IX(SI1)=-1 J=0 KICLX=ICLX+3 DO 410 JJ=1,N IF(JJ.LT.N) THEN IF(IX(KICLX+3).EQ.IX(KICLX))GO TO 409 END IF IF(IX(KICLX).EQ.0) THEN NCLV=0 ELSE IF(IX(KICLX+2).EQ.0) THEN IX(SI2+J)=MSIZE(IX(KICLX)) ELSE IX(SI2+J)=IX(KICLX+2) END IF J=J+1 409 CONTINUE KICLX=KICLX+3 410 CONTINUE 411 CONTINUE ELSE IF(ICHINC+ICELL.LT.IV2+ICELLS) THEN ICELL=ICELL+ICHINC ICL=ICL2+1 IF(ICL.LE.NICL1) GO TO 401 END IF END IF 412 CONTINUE IF(NCLV.GT.0) THEN DO 415 I=1,NCLV IX(SI1+I-1)=IX(SI1+I-1)+1 IF(IX(SI1+I-1).LT.IX(SI2+I-1)) THEN IF(I.GT.1) THEN DO 414 J=1,I-1 IX(SI1+J-1)=0 414 CONTINUE END IF GO TO 416 END IF 415 CONTINUE GO TO 442 416 CONTINUE IF(ICHINC+ICELL.LT.IV2+ICELLS) THEN ICELL=ICELL+ICHINC GO TO 412 END IF IF(PRINTX)WRITE(U6,124) N=IX(ICLX) L=SIVMAP DO 420 I=1,NCLV J=0 KICLX=ICLX+3 DO 419 JJ=1,N IF(JJ.EQ.1) THEN J=J+1 ELSE IF(IX(KICLX).NE.IX(KICLX-3)) THEN J=J+1 END IF IF(J.NE.I) GO TO 418 IF(IX(KICLX+2).NE.0) THEN IF(IX(KICLX+2).NE.IX(SI1+I-1)+1)GO TO 418 ICHECK=0 IF(JJ.GT.1) THEN IF(IX(KICLX).EQ.IX(KICLX-3).AND. . IX(KICLX+2).EQ.IX(KICLX-1)) THEN IF(IX(KICLX+1).EQ.0) THEN IF(PRINTX)WRITE(U6,163) ELSE IVC=IX(KICLX) IF(PRINTX) . WRITE(U6,162)LEVEL(LPOINT(IVC)+IX(KICLX+1)-1) END IF ICHECK=1 END IF END IF IF(ICHECK.EQ.0) THEN IVC=IX(KICLX) IX(L)=IVC-NVREG IX(L+1)=IX(KICLX+1) L=L+2 IF(IX(KICLX+1).EQ.0) THEN IF(PRINTX)WRITE(U6,161)LABEL(IVC) ELSE IF(PRINTX) THEN WRITE(U6,105)LABEL(IVC),LEVEL(LPOINT(IVC)+IX(KICLX+1)-1) END IF END IF ELSE IVC=IX(KICLX) IX(L)=IVC-NVREG IX(L+1)=IX(SI1+I-1)+1 L=L+2 IF(PRINTX) . WRITE(U6,105)LABEL(IVC),LEVEL(LPOINT(IVC)+IX(SI1+I-1)) END IF 418 CONTINUE KICLX=KICLX+3 419 CONTINUE 420 CONTINUE IX(L)=0 END IF IF(PRINTX)WRITE(U6,108) DO 440 ICL1=ICL,ICL2 IF(ICELL+RSTPNT(IV+ICL1).LT.IV2+ICELLS) THEN ICELL=ICELL+RSTPNT(IV+ICL1) GO TO 440 END IF IDCELL=ICELL-ICELLS+1 ILOC=(IDCELL*(IDCELL-1))/2-1+ICLLVS IF(IV2.EQ.1) THEN IF(IKEY.EQ.41) THEN IV2TOP=IV2+IV2INC-2 ELSE IV2TOP=IV2+IV2INC-3 END IF ELSE IV2TOP=IV2+IV2INC-1 END IF IF(IV2TOP.GT.IDCELL)IV2TOP=IDCELL IF(V2(IV+ICL1).EQ.9) THEN IF(IV2.EQ.1) THEN IF(IKEY.EQ.41.AND.PRINTX) THEN WRITE(U6,230)IDCELL,V1(IV+ICL1),DX(ICELL), . (DX(ILOC+IV2I),IV2I=IV2,IV2TOP) ELSE WRITE(U6,250)IDCELL,V1(IV+ICL1),DX(ICELL), . (DX(ILOC+IV2I),IV2I=IV2,IV2TOP) END IF IF(WRITEX) THEN CALL CLWRTE II=NVTOT+V1(IV+ICL1) I=2 JJ=1 J=1 SETEMP=SECOV(DX(ICLLVS),IDCELL) WRITE(11,171)NREQST,IDCELL,IKEYC,I,JJ,J,DX(ICELL),SETEMP CALL WRCOV(DX(ICLLVS),IDCELL,ILTOT,IKEY) END IF ELSE IF(PRINTX) THEN IF(IKEY.EQ.41) THEN WRITE(U6,130)IDCELL,V1(IV+ICL1), . (DX(ILOC+IV2I),IV2I=IV2,IV2TOP) ELSE WRITE(U6,150)IDCELL,V1(IV+ICL1), . (DX(ILOC+IV2I),IV2I=IV2,IV2TOP) END IF END IF ICELL=ICELL+1 ELSE IVX=V1(IV+ICL1) ITTYPE=V2(IV+ICL1) MT=MTYPE(IVX) IF(ITTYPE.EQ.8) THEN IFLAG=6 ELSE IF(MT.EQ.11.OR.MT.EQ.13.OR.MT.EQ.19) THEN IFLAG=4 ELSE IF(ITTYPE.EQ.2.OR.ITTYPE.EQ.4) THEN IFLAG=2 ELSE IF(ITTYPE.EQ.5) THEN IFLAG=7 ELSE IF(ITTYPE.EQ.1.OR.ITTYPE.EQ.3) THEN IF(MT.EQ.3.OR.MT.EQ.9) THEN IFLAG=3 ELSE IFLAG=1 END IF ELSE IF(ITTYPE.EQ.6.OR.ITTYPE.EQ.7) THEN IFLAG=5 END IF IF(MT.EQ.1.OR.MT.EQ.2.OR.MT.EQ.11.OR. . (MT.EQ.3.AND.(ITTYPE.EQ.8.OR.MSIZE(IVX).EQ.1)).OR. . (MSIZE(IVX).EQ.2.AND.MT.EQ.3.AND. . (ITTYPE.EQ.3.OR.ITTYPE.EQ.4.OR.ITTYPE.EQ.7))) THEN IF(IV2.EQ.1) THEN IF(IKEY.EQ.41.AND.PRINTX) THEN WRITE(U6,231)LABEL(IVX),VTYPE(IFLAG),IDCELL, . DX(ICELL),(DX(ILOC+IV2I),IV2I=IV2,IV2TOP) ELSE IF (PRINTX) THEN WRITE(U6,251)LABEL(IVX),VTYPE(IFLAG),IDCELL, . DX(ICELL),(DX(ILOC+IV2I),IV2I=IV2,IV2TOP) END IF IF(WRITEX) THEN CALL CLWRTE JJ=1 SETEMP=SECOV(DX(ICLLVS),IDCELL) WRITE(11,171)NREQST,IDCELL,IKEYC,ITTYPE,IVX,JJ,DX(ICELL), . SETEMP CALL WRCOV(DX(ICLLVS),IDCELL,ILTOT,IKEY) END IF ELSE IF(PRINTX) THEN IF(IKEY.EQ.41) THEN WRITE(U6,131)LABEL(IVX),VTYPE(IFLAG),IDCELL, . (DX(ILOC+IV2I),IV2I=IV2,IV2TOP) ELSE WRITE(U6,151)LABEL(IVX),VTYPE(IFLAG),IDCELL, . (DX(ILOC+IV2I),IV2I=IV2,IV2TOP) END IF END IF ICELL=ICELL+1 ELSE IF(MT.EQ.3.OR.MT.EQ.13) THEN IF(PRINTX)WRITE(U6,132)LABEL(IVX),VTYPE(IFLAG) IF(ITTYPE.EQ.3.OR.ITTYPE.EQ.4.OR.ITTYPE.EQ.7) THEN II=MSIZE(IVX)-1 ELSE II=MSIZE(IVX) END IF DO 425 I=1,II IDCELL=ICELL-ICELLS+1 IF(IDCELL.GE.IV2) THEN ILOC=(IDCELL*(IDCELL-1))/2-1+ICLLVS IF(IV2.EQ.1) THEN IF(WRITEX) THEN CALL CLWRTE SETEMP=SECOV(DX(ICLLVS),IDCELL) WRITE(11,171)NREQST,IDCELL,IKEYC,ITTYPE,IVX,II, . DX(ICELL),SETEMP CALL WRCOV(DX(ICLLVS),IDCELL,ILTOT,IKEY) END IF IF(IKEY.EQ.41) THEN IV2TOP=IV2+IV2INC-2 IF(IV2TOP.GT.IDCELL)IV2TOP=IDCELL IF(PRINTX)WRITE(U6,233)IDCELL,LEVEL(LPOINT(IVX)+I-1), . DX(ICELL),(DX(ILOC+IV2I),IV2I=IV2,IV2TOP) ELSE IV2TOP=IV2+IV2INC-3 IF(IV2TOP.GT.IDCELL)IV2TOP=IDCELL IF(PRINTX)WRITE(U6,253)IDCELL,LEVEL(LPOINT(IVX)+I-1), . DX(ICELL),(DX(ILOC+IV2I),IV2I=IV2,IV2TOP) END IF ELSE IF(PRINTX) THEN IV2TOP=IV2+IV2INC-1 IF(IV2TOP.GT.IDCELL)IV2TOP=IDCELL IF(IKEY.EQ.41) THEN WRITE(U6,133)IDCELL,LEVEL(LPOINT(IVX)+I-1), . (DX(ILOC+IV2I),IV2I=IV2,IV2TOP) ELSE WRITE(U6,153)IDCELL,LEVEL(LPOINT(IVX)+I-1), . (DX(ILOC+IV2I),IV2I=IV2,IV2TOP) END IF END IF END IF ICELL=ICELL+1 425 CONTINUE ELSE IF(MT.EQ.8.OR.MT.EQ.9.OR.MT.EQ.19) THEN L=LPOINT(IVX) K=CDMPNT(IVX) HFIRST=.TRUE. IF(MT.EQ.8) THEN KSIZE=MSIZE(IVX)/2 KINCR=1 ELSE IF(ITTYPE.EQ.8) THEN KSIZE=MSIZE(IVX)/CROSSD(K+1) KINCR=1 ELSE IF(ITTYPE.EQ.3.OR.ITTYPE.EQ.4.OR.ITTYPE.EQ.7) THEN IF(CROSSD(K+1).EQ.1) THEN KINCR=1 KSIZE=MSIZE(IVX) ELSE KINCR=CROSSD(K+1)-1 KSIZE=KINCR*MSIZE(IVX)/CROSSD(K+1) END IF ELSE KSIZE=MSIZE(IVX) KINCR=CROSSD(K+1) END IF N=CROSSD(K) NM=CROSSD(K+N+1) SI3=NXPTI SI4=SI3+N I=2*N CALL ROOMI(I) DO 427 I=1,N IF(I.EQ.2) THEN IX(SI3+I-1)=0 ELSE IX(SI3+I-1)=1 END IF IX(SI4+I-1)=L L=L+1+CROSSD(K+I) 427 CONTINUE IF(PRINTX)WRITE(U6,134)LEVEL(IX(SI4)),VTYPE(IFLAG) 428 CONTINUE J=2 430 CONTINUE IX(SI3+J-1)=IX(SI3+J-1)+1 IF(IX(SI3+J-1).GT.CROSSD(K+J)) THEN IF(J.LT.N) THEN IX(SI3+J-1)=1 J=J+1 GO TO 430 ELSE NXPTI=SI3 END IF ELSE IF(J.GT.2.OR.HFIRST) THEN IF(HFIRST) THEN JJ=N ELSE JJ=J END IF IF(ICELL-ICELLS+KINCR.GE.IV2.AND.PRINTX) THEN DO 431 I=JJ,3,-1 WRITE(U6,135)LEVEL(IX(SI4+I-1)), . LEVEL(IX(SI4+I-1)+IX(SI3+I-1)) 431 CONTINUE END IF END IF IF(KINCR.EQ.1) THEN IF(ICELL-ICELLS+CROSSD(K+2).GE.IV2) THEN IF(HFIRST.OR.IX(SI3+1).EQ.1) THEN IF(PRINTX)WRITE(U6,136)LEVEL(IX(SI4+1)) HFIRST=.FALSE. END IF END IF IF(ICELL-ICELLS+1.GE.IV2) THEN IDCELL=ICELL-ICELLS+1 ILOC=(IDCELL*(IDCELL-1))/2-1+ICLLVS IF(IV2.EQ.1) THEN IF(WRITEX) THEN CALL CLWRTE SETEMP=SECOV(DX(ICLLVS),IDCELL) WRITE(11,171)NREQST,IDCELL,IKEYC,ITTYPE,IVX,KSIZE, . DX(ICELL),SETEMP CALL WRCOV(DX(ICLLVS),IDCELL,ILTOT,IKEY) END IF IF(IKEY.EQ.41) THEN IV2TOP=IV2+IV2INC-2 IF(IV2TOP.GT.IDCELL)IV2TOP=IDCELL IF(PRINTX) THEN WRITE(U6,237)IDCELL,LEVEL(IX(SI4+1)+IX(SI3+1)), . DX(ICELL),(DX(ILOC+IV2I),IV2I=IV2,IV2TOP) END IF ELSE IV2TOP=IV2+IV2INC-3 IF(IV2TOP.GT.IDCELL)IV2TOP=IDCELL IF(PRINTX) THEN WRITE(U6,257)IDCELL,LEVEL(IX(SI4+1)+IX(SI3+1)), . DX(ICELL),(DX(ILOC+IV2I),IV2I=IV2,IV2TOP) END IF END IF ELSE IV2TOP=IV2+IV2INC-1 IF(IV2TOP.GT.IDCELL)IV2TOP=IDCELL IF(IKEY.EQ.41.AND.PRINTX) THEN WRITE(U6,137)IDCELL,LEVEL(IX(SI4+1)+IX(SI3+1)), . (DX(ILOC+IV2I),IV2I=IV2,IV2TOP) ELSE IF(PRINTX) THEN WRITE(U6,157)IDCELL,LEVEL(IX(SI4+1)+IX(SI3+1)), . (DX(ILOC+IV2I),IV2I=IV2,IV2TOP) END IF END IF END IF ICELL=ICELL+1 ELSE IF(ICELL-ICELLS+KINCR.GE.IV2) THEN IF(PRINTX)WRITE(U6,135)LEVEL(IX(SI4+1)), . LEVEL(IX(SI4+1)+IX(SI3+1)) DO 433 I=1,KINCR IDCELL=ICELL-ICELLS+1 ILOC=(IDCELL*(IDCELL-1))/2-1+ICLLVS IF(IDCELL.GE.IV2) THEN IF(IV2.EQ.1) THEN IF(WRITEX) THEN CALL CLWRTE SETEMP=SECOV(DX(ICLLVS),IDCELL) WRITE(11,171)NREQST,IDCELL,IKEYC,ITTYPE,IVX, . KSIZE,DX(ICELL),SETEMP CALL WRCOV(DX(ICLLVS),IDCELL,ILTOT,IKEY) END IF IF(IKEY.EQ.41) THEN IV2TOP=IV2+IV2INC-2 IF(IV2TOP.GT.IDCELL)IV2TOP=IDCELL IF(PRINTX)WRITE(U6,238)IDCELL,LEVEL(IX(SI4)+I), . DX(ICELL),(DX(ILOC+IV2I),IV2I=IV2,IV2TOP) ELSE IV2TOP=IV2+IV2INC-3 IF(IV2TOP.GT.IDCELL)IV2TOP=IDCELL IF(PRINTX)WRITE(U6,258)IDCELL,LEVEL(IX(SI4)+I), . DX(ICELL),(DX(ILOC+IV2I),IV2I=IV2,IV2TOP) END IF ELSE IF(PRINTX) THEN IV2TOP=IV2+IV2INC-1 IF(IV2TOP.GT.IDCELL)IV2TOP=IDCELL IF(IKEY.EQ.41) THEN WRITE(U6,138)IDCELL,LEVEL(IX(SI4)+I), . (DX(ILOC+IV2I),IV2I=IV2,IV2TOP) ELSE WRITE(U6,158)IDCELL,LEVEL(IX(SI4)+I), . (DX(ILOC+IV2I),IV2I=IV2,IV2TOP) END IF END IF END IF ICELL=ICELL+1 433 CONTINUE ELSE ICELL=ICELL+CROSSD(K+1) END IF END IF GO TO 428 END IF END IF END IF 440 CONTINUE IF(NCLV.GT.0) GO TO 412 442 CONTINUE IF(ICLSS.GT.0) THEN NXPTI=SI1 ICLX=ICLX+3+3*IX(ICLX) IF(ICLX.LE.ICLSS+3*IX(ICLSS)+1) GO TO 405 END IF ICL=ICL2+1 IF(ICL.LE.NICL1) GO TO 401 IF(IV2.EQ.1) THEN IF(IKEY.EQ.41) THEN IV2=IV2+IV2INC-1 ELSE IV2=IV2+IV2INC-2 END IF ELSE IV2=IV2+IV2INC END IF IF(IV2.LE.IV2END) GO TO 400 IV=IV+NICL1 ICELLV=ICLLVS+(IV2END*(IV2END+1))/2 NXPTI=SIVMAP RETURN END SUBROUTINE CLWRTE IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) C PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (MAXFMT=20) C PARAMETER (MDSZI=MSIZEI+6*MRANGE+2*MRNSET+3*MVAR) PARAMETER (IXFLLD=56+3*MAXIDS) PARAMETER (NPOPTN=5) PARAMETER (NINCR=NPOPTN+3) PARAMETER (MAXLST=20) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C C COMMON /STMBLK/IX,RSTPNT,RCTYPE,V1,V2,V3,MXSIZE INTEGER IX(MDSZI),RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD), . V2(MRECOD),V3(MRECOD),MXSIZE(MVAR) C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL C INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID, . SDWRK,VKEEPF,OUTFMT,IXFILL(IXFLLD) COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT, . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF, . OUTFMT,IXFILL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT C 101 FORMAT('99',78A1) 102 FORMAT('99',3F22.3) 141 FORMAT(I1) 142 FORMAT(I2) 143 FORMAT(I3) 144 FORMAT(I4) IF(NCLASS.GT.0) THEN I=3*NCLASS-2 NREC=IX(I) DO 10 IREC=1,NREC L=1 DO 2 I=1,NCLASS IF(IX(L).EQ.IREC)LEN=IX(L+1)+IX(L+2)-3 L=L+3 2 CONTINUE DO 4 I=1,LEN INFRMT(1)(I:I)=' ' 4 CONTINUE L=SIVMAP 6 CONTINUE IF(IX(L).EQ.0)GO TO 8 I=3*IX(L)-2 IF(IX(I).EQ.IREC) THEN J=IX(I+1)-2 JJ=J+IX(I+2)-1 IF(IX(I+2).EQ.1) THEN WRITE(INFRMT(1)(J:JJ),141)IX(L+1) ELSE IF(IX(I+2).EQ.2) THEN WRITE(INFRMT(1)(J:JJ),142)IX(L+1) ELSE IF(IX(I+2).EQ.3) THEN WRITE(INFRMT(1)(J:JJ),143)IX(L+1) ELSE IF(IX(I+2).EQ.4) THEN WRITE(INFRMT(1)(J:JJ),144)IX(L+1) END IF END IF L=L+2 GO TO 6 8 CONTINUE WRITE(11,101)(INFRMT(1)(I:I),I=1,LEN) 10 CONTINUE END IF IF(NBY.GT.0) THEN WRITE(11,102)(DX(I+SDBYID-1),I=1,NBY) END IF RETURN END DOUBLE PRECISION FUNCTION SECOV(DXM,IDCELL) DOUBLE PRECISION DXM(*) II=(IDCELL*(IDCELL+1))/2 IF(DXM(II).LE.0.) THEN SECOV=0. ELSE SECOV=DSQRT(DXM(II)) END IF RETURN END SUBROUTINE WRCOV(DXM,IDCELL,NCELL,IKEY) DOUBLE PRECISION DXM(*) DOUBLE PRECISION DT(6) 100 FORMAT('96',I4) 101 FORMAT('97',3D22.14) 102 FORMAT('98',6F11.8) WRITE(11,100)NCELL IF(IKEY.EQ.41) THEN INCR=3 ELSE INCR=6 END IF DO 20 I=1,NCELL,INCR II=I+INCR-1 IF(II.GT.NCELL)II=NCELL J=0 DO 10 JJ=I,II IF(IDCELL.GE.JJ) THEN K=(IDCELL*(IDCELL-1))/2+JJ ELSE K=(JJ*(JJ-1))/2+IDCELL END IF J=J+1 DT(J)=DXM(K) 10 CONTINUE IF(IKEY.EQ.41) THEN WRITE(11,101)(DT(JJ),JJ=1,J) ELSE WRITE(11,102)(DT(JJ),JJ=1,J) END IF 20 CONTINUE RETURN END C C Master routine for DISPLAY step, new syntax. C This routine is called from DSETUP. Unlike DSETUP, C the placement of IX in /STMBLK/ here is consistent with RECODX C and other routines used to implement the new syntax C SUBROUTINE NDISPL(IPOSSC,ITYPEF,IFILEF) C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C INTEGER ITYPEF(3),IFILEF(3) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (MAXFMT=20) C PARAMETER (IXFLLD=56+3*MAXIDS) PARAMETER (NPOPTN=9) PARAMETER (NOPTN=21) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C C COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1, . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX C DOUBLE PRECISION RANGE(2,MRANGE) INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET), . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD), . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI) C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL C INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID, . SDWRK,VKEEPF,OUTFMT,IXFILL(IXFLLD) COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT, . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF, . OUTFMT,IXFILL C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 CHARACTER*256 CARD COMMON /CRDBLK/CARD CHARACTER*256 CARDWK,CARDSV,CARDIM COMMON /CMBLK2/CARDWK,CARDSV,CARDIM C PARAMETER (MAXSUB=500,MAXSBL=2000,MAXSNL=24) PARAMETER (MAXSBC=6000) PARAMETER (MAXALT=5) INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI, . NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL), . U5LCSW COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI, . NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW C INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW, . OSCODE,NEWFNM COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE, . ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM C LOGICAL REFRSH,LTEMP EXTERNAL REFRSH C C TSWTCH=4 C ! indicates display step to CMPAR1 RCEIL(1)=MSIZEI C ! size of IX in this step CALL STBLNK(CARD,1,IPOSSC) IPOSSC=IPOSSC+1 U5LCSW=1 C ! Reset U5LCSW used by REFRSH CALL CMPAR1(IX,IPOSSC) CALL NDSETP(IX(NLINE+NLINE2+1),IX,IX(NLINE+1),ITYPEF,IFILEF) C RETURN END C C Parsing for DISPLAY step, new syntax C SUBROUTINE NDSETP(IXM,LNMAP,LNECHO,ITYPEF,IFILEF) C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C PARAMETER (IXDIM=13) INTEGER IXM(IXDIM,*),LNMAP(*),LNECHO(*) INTEGER ITYPEF(3),IFILEF(3) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (MAXFMT=20) C PARAMETER (IXFLLD=56+3*MAXIDS) PARAMETER (NPOPTN=9) PARAMETER (NOPTN=21) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C C COMMON /STMBLK/RANGE,RGROUP,RTYPE,NRNG,RNGPNT,RSTPNT,RCTYPE,V1, . V2,V3,MXSIZE,IOUT,IOUTL,MTSTRT,IX C DOUBLE PRECISION RANGE(2,MRANGE) INTEGER RGROUP(MRANGE),RTYPE(MRANGE),NRNG(MRNSET),RNGPNT(MRNSET), . RSTPNT(MRECOD),RCTYPE(MRECOD),V1(MRECOD),V2(MRECOD),V3(MRECOD), . MXSIZE(MVAR),IOUT(MVAR),IOUTL(MVAR),MTSTRT(MVAR),IX(MSIZEI) C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL C INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID, . SDWRK,VKEEPF,OUTFMT,IXFILL(IXFLLD) COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT, . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF, . OUTFMT,IXFILL C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 CHARACTER*256 CARD COMMON /CRDBLK/CARD CHARACTER*256 CARDWK,CARDSV,CARDIM COMMON /CMBLK2/CARDWK,CARDSV,CARDIM C PARAMETER (MAXSUB=500,MAXSBL=2000,MAXSNL=24) PARAMETER (MAXSBC=6000) PARAMETER (MAXALT=5) INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI, . NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL), . U5LCSW COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI, . NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW C INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW, . OSCODE,NEWFNM COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE, . ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM C LOGICAL REFRSH,LTEMP EXTERNAL REFRSH C INTEGER IOPTND(NPOPTN),IOPTNC(NPOPTN) INTEGER SICLSS,VTMPSZ CHARACTER*5 CWORK5 CHARACTER*4 CWORK4 INTEGER INDX(NOPTN) INTEGER IVALUE(NOPTN) CHARACTER*12 OPTNW(NOPTN) DATA OPTNW / 'PRINT ','NOPRINT ','WRITE ', . 'NOWRITE ','LINESIZE ','CLASSSTUB ','CLASS_STUB ', . 'CLASSHEAD ','CLASS_HEAD ','PAGESIZE ','CENTER ', . 'CENTERED ','UNCENTER ','UNCENTERED ','OUTFORMAT ', . 'NDECIMAL ','DECIMAL ','MEAN ','MEANS ', . 'TOTAL ','TOTALS '/ DATA INDX/1,1,2,2,3,4,4,4,4,5,6,6,6,6,8,9,9,7,7,7,7/ DATA IVALUE/1,2,1,2,0,2,2,1,1,0,1,1,2,2,0,4,4,1,1,2,2/ C C C C C C 101 FORMAT(/,1X) 103 FORMAT(/,5X,'OUTFORMAT SET PREVIOUSLY') 141 FORMAT(I1) 142 FORMAT(I2) 143 FORMAT(I3) 144 FORMAT(I4) 151 FORMAT('11',8I4) 152 FORMAT('12',I4,I2,I4,I2,I4,A12,A24) 153 FORMAT('13',I2,I4,A12,A24) 154 FORMAT('14',I4,A24) 155 FORMAT('15',I4,' 0 0 0 0_N_',A5,4X,'N (wtd) for block ',A4,2X) 156 FORMAT('16',I4,2I2,2I4) 157 FORMAT('17',2I4,I2) 158 FORMAT('18',2I4,2I2) 170 FORMAT(5X,'OUTFORMAT3 SWITCHED TO OUTFORMAT4') 171 FORMAT(/,5X,'Format of type 99 record for classes',/,5X,'Positions . Class') 172 FORMAT(/,5X,'Format of type 99 records for classes',/,5X,'Rec no .Positions Class') 173 FORMAT(7X,I2,'-',I2,4X,A12) 174 FORMAT(6X,I4,5X,I2,'-',I2,4X,A12) 175 FORMAT(/,5X,'MEAN SWITCHED TO TOTAL: ',A12) 176 FORMAT(/,5X,'NO N FOR: ',A12) 177 FORMAT(/,5X,'NO N FOR BLOCK:',I4) 200 FORMAT(' ERROR IN SPECIFICATION') 201 FORMAT(' UNRECOGNIZED VARIABLE NAME: ',A12) 202 FORMAT(' CLASS VARIABLE NOT ALLOWED ON LIST: ',A12) C RCEIL(1)=MSIZEI C ! size of IX in this step NVIN=NVTOT U5ECSV=U5ECHO U5ECHO=0 REWIND(14) U5=15 ILINE=1 READ(14)CARD C C Most of the routine falls within a loop to 1 CONTINUE. The loop C is over the statements identified and organized by CMPAR1. C The listing file has already been written to 13 (all as unformatted C character data of length 256). For each statement, the contents C of CARD will be read from 14 and written to 15, which will then C be the input read by REFRSH, etc. and parsed in detail here and C in related routines. C ENDMRG=.FALSE. DO 1 ISTATE=1,NSTATE C REWIND(15) U5END=0 C C If starting position for this statement is beyond the current C position of 14, read necessary records. Otherwise, restore C CARD from CARDSV C IF(ILINE.LT.IXM(8,ISTATE)) THEN DO 3 I=ILINE+1,IXM(8,ISTATE) READ(14)CARD 3 CONTINUE ILINE=IXM(8,ISTATE) ELSE IF(ISTATE.NE.1) THEN CARD=CARDSV END IF C C LNCNTR is set to the current position in the overall file C here. Calls to REFRSH increment LNCNTR as records are read C from 15. C LNCNTR=IXM(8,ISTATE) C C Construct the first line where parsing of the statement should C begin in CARDWK. For safety, blank out any characters leading C up to the starting point. C CARDWK=CARD I=IXM(9,ISTATE)-1 CALL STBLNK(CARDWK,1,I) C C If this is also the last line of the statement, blank out C anything following the ending ; C IF(ILINE.EQ.IXM(3,ISTATE)) THEN K=IXM(4,ISTATE)+1 CALL STBLNK(CARDWK,K,256) END IF WRITE(15)CARDWK C C Read and process remaining lines. In all cases, save the C current line from 14 in CARDSV C IF(ILINE.LT.IXM(3,ISTATE)) THEN DO 4 I=ILINE+1,IXM(3,ISTATE) READ(14)CARD IF(I.EQ.IXM(3,ISTATE)) THEN CARDSV=CARD K=IXM(4,ISTATE)+1 CARDWK=CARD CALL STBLNK(CARDWK,K,256) WRITE(15)CARDWK ELSE WRITE(15)CARD END IF 4 CONTINUE ILINE=IXM(3,ISTATE) ELSE CARDSV=CARD END IF REWIND(15) READ(15)CARD C C IPT is the starting position for parsing. In many cases, it C is the position beyond a key word. C IPT=IXM(9,ISTATE) C IF(IXM(5,ISTATE).NE.16) THEN C ! inappropriate key word, IF(ISTEPC.EQ.1) THEN C ! unexpected arithmetic statement IMERR1=130036 C ! etc. ELSE IMERR1=130037 END IF ILINE=IXM(1,ISTATE) IMERR2=IXM(2,ISTATE) CALL CMPRNT(IXM,LNMAP) END IF C C AS 8,6 C SELECT 7,1 C STEPOPTION 2,15 C STEP 2,14 C OPTION 2,11 C INCORPORATE 8,7 C OUTPUT CLASS 7,25 C DROP 7,6 C KEEP 2,7 C IGROUP=IXM(10,ISTATE) IKEY=IXM(11,ISTATE) 1 CONTINUE U5ECHO=U5ECSV REWIND(14) DO 92 ILINE2=1,NLINE2 U5ECHO=LNECHO(ILINE2) C write(*,*)iline2,u5echo READ(13)CARDIM IF(ILINE2.EQ.1) THEN CALL CRDPRN(1) ELSE CALL CRDPRN(0) END IF 92 CONTINUE REWIND(13) C VTMPSZ=MVAR-SVTEMP+1 C IF(NCLASS.GT.0) THEN C I=3*NCLASS C CALL ROOMI(I) C END IF C C For each variable store the number of the block in MXSIZE C C IV=0 C DO 7 ICLBLK=1,NCLBLK C IF(BLVSIZ(ICLBLK).GT.0) THEN C DO 6 I=1,BLVSIZ(ICLBLK) C IV=IV+1 C MXSIZE(IV)=ICLBLK C 6 CONTINUE C END IF C 7 CONTINUE C NXPTDS=NXPTD C NXPTIS=NXPTI C MAXVN=MVAR-NVIN C RETURN END C C Start of T1.FOR - Parsing for TRANSFORM Step C SUBROUTINE TSET1 IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (MAXFMT=20) C PARAMETER (MTRANS=1500,MRANGS=20) PARAMETER (MTRSZI=MSIZEI+6*MRANGE-6*MRANGS+2*MRNSET+MRECOD+MVAR) PARAMETER (IXFLLD=57+3*MAXIDS) PARAMETER (NOPTNG=2,NOPTNP=5,NOPTNM=8,NOPTNR=8,NOPTRS=1,NOPTNX=6) PARAMETER (NOPTNW=NOPTNR-2) PARAMETER (NOPTNT=2,NOPTNV=7) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT C INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C C COMMON /STMBLK/IX,RANGE,RGROUP,RTYPE,RSTPNT,V1,V2,V3,MXSIZE, . IOUT,IOUTL DOUBLE PRECISION RANGE(2,MRANGS) INTEGER IX(MTRSZI),RGROUP(MRANGS),RTYPE(MRANGS),RSTPNT(MRECOD), . V1(MRECOD),V2(MRECOD),V3(MRECOD),MXSIZE(MVAR),IOUT(MVAR), . IOUTL(MVAR) C C Usage in this subroutine: C V1 - Variable number C V2 - Transformation code C V3 - Pointer to CLASS specification C RSTPNT - Size of variable in V1 (ignoring CLASS specification) C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL INTEGER VTMPSZ C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*256 CARD COMMON /CRDBLK/CARD C LOGICAL REFRSH,ALPCHK,CLMTCH,ICHECK EXTERNAL REFRSH,ALPCHK,CLMTCH,ICHECK C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT C INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID, . SDWRK,VKEEPF,IXFILL(IXFLLD) COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT, . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF, . IXFILL C COMMON /VABLCK/AVERSN,ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT, . ATYPE,AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR,ANID,ANCRSS,ANCRVL, . AVNCRS,ANBYGR,ASDBID,ANRPTT,ASDCOF INTEGER AVERSN,ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT, . ATYPE,AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR,ANID,ANCRSS,ANCRVL, . AVNCRS,ANBYGR,ASDBID,ANRPTT,ASDCOF C C C Usage in this subroutine: C C BLVSTR - (Not used by TRANSFORM step) C BLVSIZ - read from incoming file only, used to record block numbers C in MXSIZE only. Not updated for new blocks. C BLNCLS - number of classes in block C BLCPNT - pointer for classes to CLTYPE C BLXSIZ - flag to indicate whether block is to be retained C Initialized to 1, set to 0 by REMOVE BLOCK C CLTYPE - used as pointers to class variables C INTEGER ITYPEF(3),IFILEF(3) LOGICAL NDEFLT,LTEMP,ENDTRN C INTEGER CMPFLG,U5ESAV,IALTSV,TSWTCH,U5ECSV,LNCNTR,ISSLVL,U5ENOW, . OSCODE,NEWFNM COMMON /CMBLK1/CMPFLG,U5ESAV,IALTSV,TSWTCH,NLINE,ILINE,NSTATE, . ISTATE,U5ECSV,LNCNTR,ISSLVL,NLINE2,U5ENOW,OSCODE,NEWFNM C CHARACTER*12 OPTNG(NOPTNG),OPTNP(NOPTNP),OPTNM(NOPTNM), . OPTNW(NOPTNR),OPTNRS(NOPTRS),OPTNX(NOPTNX),OPTNT(NOPTNT), . OPTNV(NOPTNV) INTEGER INDXG(NOPTNG),INDXP(NOPTNP),INDXM(NOPTNM),INDXW(NOPTNR), . INDXRS(NOPTRS),INDXX(NOPTNX),INDXT(NOPTNT),INDXV(NOPTNV) INTEGER IVALG(NOPTNG),IVALP(NOPTNP),IVALM(NOPTNM),IVALW(NOPTNR), . IVALRS(NOPTRS),IVALX(NOPTNX),IVALT(NOPTNT),IVALV(NOPTNV) DATA OPTNG / 'SLICE ','NSLICE '/ DATA OPTNP / 'NPRINT ','NREP ','WIDTH ', . 'NDECIMAL ','DECIMAL '/ DATA OPTNM / 'NROW1 ','NCOL1 ','NROW2 ', . 'NCOL2 ','ROW1 ','COL1 ', . 'ROW2 ','COL2 '/ DATA OPTNW / 'BYGROUP ','CONSTANTS ','REPLICATE ', . 'CONSTANT ','FULL ','NSLICE ', . 'BYREPEAT ','REPEAT '/ DATA OPTNRS/ 'NCELL '/ DATA OPTNX / 'PERCENT ','PERCENTILE ','NBELOW ', . 'BELOW ','NABOVE ','ABOVE '/ DATA OPTNT / 'INTERNAL ','EXTERNAL '/ DATA OPTNV / 'BYGROUP ','CONSTANTS ','REPLICATE ', . 'CONSTANT ','FULL ','BYREPEAT ', . 'REPEAT '/ DATA INDXG/1,1/ DATA INDXP/1,1,2,3,3/ DATA INDXM/1,2,3,4,1,2,3,4/ DATA INDXW/3,3,3,3,3,4,3,3/ DATA INDXX/1,1,2,2,3,3/ DATA INDXV/3,3,3,3,3,3,3/ DATA INDXRS/1/ DATA INDXT/1,1/ DATA IVALG/0,0/ DATA IVALP/0,0,0,0,0/ DATA IVALM/0,0,0,0,0,0,0,0/ DATA IVALW/1,2,3,2,1,0,4,4/ DATA IVALX/0,0,0,0,0,0/ DATA IVALRS/1/ DATA IVALT/0,1/ DATA IVALV/1,2,3,2,1,4,4/ C 102 FORMAT(/,5X,'(assigned to block',I4,')') 205 FORMAT(' UNRECOGNIZED VARIABLE NAME ',A12) 211 FORMAT(' THIS VARIABLE IS NOT OF TYPE CLASS OR CATEGORICAL - ',A12 .) 212 FORMAT(' VARIABLE OF INAPPROPRIATE TYPE - ',A12) 215 FORMAT(' Variable already exists - ',A12) 219 FORMAT(' N(BLOCK) WITH BLOCK OUT OF RANGE:',I8) 228 FORMAT(/,' **** BEGINNING OF SUBROUTINE',I5) 229 FORMAT(/,' DUPLICATED CLASS VARIABLE: ',A12) 230 FORMAT(/,' MEAN UNAVAILABLE: ',A12) 232 FORMAT(' WARNING: ONE OR MORE VALUES DID NOT APPEAR TO BE INTEGERS .') 233 FORMAT(' TEMPORARY ERROR: new syntax not yet implemented for thi', . 's step') C C Initializations. C RCEIL(1) - maximum size of integer array, set to parameter value C NKEEP - number of variables in KEEP or DROP statement(s) C VKEEPF - flag to indicate KEEP (1) or DROP (2) statement C encountered C NPASS - cumumlative number of variable arguments to subroutines C NTRANS - number of subroutines C NXTSTR - next available position in string (character) array C Note: reserve first string as work for REPPRINT. C (Multiple calls to REPPRINT may use the same string C as working space.) C IEXTRN = 1 use external storage for subroutines such as C SAVEFULL as default C = 0 use internal storage as default (which is the default C option for the step) C ISOPTN = 1 step options have been set C RCEIL(1)=MTRSZI NKEEP=0 VKEEPF=0 NPASS=0 NTRANS=0 ENDTRN=.FALSE. NXTSTR=2 IEXTRN=0 ISOPTN=0 C C C IX(NTRANS*12-11)= Starting location for integer constants C IX(NTRANS*12-10) = Starting string number C IX(NTRANS*12-9) = Transformation code C IX(NTRANS*12-8) = Number of old variables C IX(NTRANS*12-7) = Number of modified variables C IX(NTRANS*12-6) = Number of new variables C IX(NTRANS*12-5) = Starting location for constants C IX(NTRANS*12-4) = Number of constants C IX(NTRANS*12-3) = Number of strings C IX(NTRANS*12-2) = Number of integer constants C IX(NTRANS*12-1) = Starting value of NPASS C IX(NTRANS*12) = Pointer to storage for each variable, calculated C in TCREA1 (called subsequently) C C Error call if parameter MTRSZI is too small. C NXPTI=1+12*MTRANS IF(NXPTI+12.GT.MTRSZI) THEN CALL FESTOP(200001) END IF C C Contents of MTYPE, codes for transformations C 1 = real variable C 2 = real variable with missing checks C 3 = categorical variable C 4 = class variable, known dimension C 5 = by variable, known dimension C 6 = by variable, unknown dimension C 7 = select transformation (not variable type) C 8 = cross variable, real value C 9 = cross variable, categorical C 10 = copy (not variable type) C 11 = derived C 13 = crossed derived, single dimension C 19 = crossed variable, derived, more than one dimension C C In preparation to call FNREAD, set flags to expect binary input and C output. C ITYPEF(1)=2 ITYPEF(2)=2 ITYPEF(3)=0 CALL CRDPRN(3) CALL KYFIND(IKEY,IPT) CALL FNREAD(IPT,ITYPEF,IFILEF,1,IPOSSC) IF(IPOSSC.GT.0) THEN WRITE(U6,233) CALL FSTOP END IF IF(IMERR1.GT.0) THEN CALL FSTOP END IF C C Require that an output be specified. C IF(IFILEF(2).EQ.0) THEN CALL FESTOP(200002) END IF C C Before calling PREAMB to read the metadata on the input file, C initialize all blocks. (BLXSIZ is set to 0 by REMOVE BLOCK.) C DO 901 ICLBLK=1,MCLBLK BLXSIZ(ICLBLK)=1 901 CONTINUE CALL PREAMB IF(IPOSSC.GT.0) THEN WRITE(U6,233) CALL FSTOP END IF C C SVTEMP is set in PREAMB to be the next available position, after C variable names associated with crossed variables have been stored C in VTEMP. VTMPSZ stores the remaining working space in VTEMP. C VTMPSZ=MVAR-SVTEMP+1 SDCONS=NXPTD C C SDCONS records the starting position of any specified constants, C after space is allocated for input VPLX file. (PREAMB accesses C space for BYGROUP ids and the variance coefficients.) C NVIN=NVTOT IV=0 C C Store the number of the block for each variable in MXSIZE C DO 7 ICLBLK=1,NCLBLK IF(BLVSIZ(ICLBLK).GT.0) THEN DO 6 I=1,BLVSIZ(ICLBLK) IV=IV+1 MXSIZE(IV)=ICLBLK 6 CONTINUE END IF 7 CONTINUE C C NCLBLS saves the number of blocks on the incoming file. NCLBLK C is updated to reflect the total number of blocks as new variables C are created during the step. C NCLBLS=NCLBLK C 1 CONTINUE LTEMP=REFRSH(IPT) 2 CONTINUE C C If no more instructions remain, conclude specification for the step. C IF(U5END.GT.0) THEN IF(U5.GE.13.AND.U5.LE.17) THEN GO TO 1 ELSE GO TO 90 END IF END IF C CALL KYFIND(IKEY,IPT) IF(IKEY.EQ.33)IKEY=68 IF((IKEY.GE.1.AND.IKEY.LE.5).OR.IKEY.EQ.9.OR. . (IKEY.GE.11.AND.IKEY.LE.15).OR. . (IKEY.GE.23.AND.IKEY.LE.30).OR.IKEY.EQ.32.OR.IKEY.EQ.33.OR. . IKEY.EQ.35.OR. . (IKEY.GE.37.AND.IKEY.LE.47).OR.IKEY.EQ.49.OR. . (IKEY.GT.91.AND.IKEY.NE.112.AND.IKEY.NE.119.AND. . IKEY.NE.120.AND.((IKEY.LT.161.OR.IKEY.GT.170).AND. . (IKEY.LT.123.OR. . (IKEY.GT.155.AND.IKEY.LT.198)))))GO TO 90 C C If a beginning of a subroutine, skip to 77 to conclude processing C of any current subroutine and to begin set up for this one. C IF((IKEY.GE.58.AND.IKEY.LE.86).OR.IKEY.EQ.112.OR.IKEY.EQ.119.OR. . IKEY.EQ.120.OR.(IKEY.GE.123.AND.IKEY.LE.155).OR. . (IKEY.GE.161.AND.IKEY.LT.198).OR.IKEY.EQ.17) THEN GO TO 77 END IF CALL CRDPRN(1) C C If continuation line without keyword, read next record C IF(IKEY.EQ.-1) THEN GO TO 1 END IF C C CLASS, CATEGORICAL, CAT, MISSING, DERIVED, REAL, C CROSSED (REAL, CAT, CATEGORICAL, DERIVED), COUNT C IF((IKEY.GE.6.AND.IKEY.LE.10).OR.IKEY.EQ.31.OR. . (IKEY.GE.53.AND.IKEY.LE.56)) THEN IF(IKEY.NE.6) THEN IF(NTRANS.EQ.0) THEN CALL FESTOP(200004) ELSE IF(IX(NTRANS*12-9).EQ.-60) THEN CALL FESTOP(200073) END IF END IF C C Initializations: C IBEYND - indicates have read beyond first record. C INEXT - indicates that the first record of the next statement C has been read. C NDEFLT - logical variable to denote whether default option should C be used for characteristics of cat or crossed variable C IBEYND=0 INEXT=0 IBLOCK=0 ICLSS=0 NDEFLT=.FALSE. MAXVN=MVAR-NVIN+1 C C Check that it is possible to add at least 1 more variable. C CALL RCHECK(2,NVIN,1) CALL VNFIND(IPT,VNAME(NVIN+1),MAXVN,N,IPOS,2,VNAME,NVIN) IF(N.LE.0) THEN IF(IPT.GT.1) THEN CALL FPSTOP(200005,IPT) ELSE CALL FESTOP(200006) END IF END IF IF(IPT.EQ.1)IBEYND=1 IF(IPOS.EQ.0)INEXT=1 ISTART=1 C C For CROSS or CROSSED - C IF(IKEY.EQ.31.OR.IKEY.EQ.56) THEN ITYPE=0 CALL VNMTCH('REAL ',VNAME(NVIN+1),1,IPOS2) IF(IPOS2.GT.0)ITYPE=8 CALL VNMTCH('CAT ',VNAME(NVIN+1),1,IPOS2) IF(IPOS2.GT.0)ITYPE=9 CALL VNMTCH('CATEGORICAL ',VNAME(NVIN+1),1,IPOS2) IF(IPOS2.GT.0)ITYPE=9 CALL VNMTCH('DERIVED ',VNAME(NVIN+1),1,IPOS2) IF(IPOS2.GT.0)ITYPE=19 C C A CROSSED variable is treated as CROSSED REAL C IF(ITYPE.EQ.0) THEN ITYPE=8 C C Reposition variables in VNAME because first is REAL, CAT, etc. C ELSE IF(N.EQ.1) THEN CALL FESTOP(200006) END IF DO 13 I=2,N VNAME(NVIN+I-1)=VNAME(NVIN+I) 13 CONTINUE N=N-1 END IF C C CLASS C ELSE IF(IKEY.EQ.6) THEN ITYPE=4 C C CAT or CATEGORICAL C ELSE IF(IKEY.EQ.7.OR.IKEY.EQ.8) THEN ITYPE=3 C C MISSING C ELSE IF(IKEY.EQ.10) THEN ITYPE=2 IMSIZE=2 C C DERIVED C ELSE IF(IKEY.EQ.53) THEN ITYPE=11 IMSIZE=1 C C REAL C ELSE IF(IKEY.EQ.54) THEN ITYPE=1 IMSIZE=1 C C COUNT C ELSE IF(IKEY.EQ.55) THEN CALL VNMTCH('N ',VNAME(NVIN+1),1,IPOS2) IF(N.NE.1.OR.IPOS2.NE.1) THEN CALL FESTOP(200007) END IF ITYPE=0 IMSIZE=1 END IF C C For all cases except COUNT, check that variables have not been C previously defined. C IF(IKEY.NE.55) THEN DO 16 I=1,N CALL VNMTCH(VNAME(NVIN+I),VNAME,NVIN,K) IF(K.GT.0) THEN WRITE(U6,215)VNAME(NVIN+I) CALL FESTOP(200008) END IF C C Store variable name as default label. C LABEL(NVIN+I)(1:12)=VNAME(NVIN+I) LABEL(NVIN+I)(13:24)=' ' 16 CONTINUE END IF C C For CAT, CLASS, CROSSED REAL, CROSSED CAT, CROSSED DERIVED, COUNT C read in the dimensions, or set the dimensions under the default C option. C IF(ITYPE.EQ.3.OR.ITYPE.EQ.4.OR.ITYPE.EQ.8.OR.ITYPE.EQ.9.OR. . ITYPE.EQ.19.OR.IKEY.EQ.55) THEN C C If have already completed reading, must use default option. C IF(INEXT.EQ.1) THEN NDEFLT=.TRUE. ELSE C C If IPOS=0, have read all of statement and continuations. Set C INEXT and use default option. C IF(IPOS.EQ.0) THEN NDEFLT=.TRUE. INEXT=1 ELSE C C Use default option if encounter / C IF(CARD(IPOS:IPOS).EQ.'/') THEN NDEFLT=.TRUE. ELSE IF(CARD(IPOS:IPOS).EQ.'(') THEN IPOS=IPOS+1 IF(IPOS.GE.256) THEN IF(.NOT.REFRSH(IPOS)) THEN CALL FESTOP(200009) END IF IBEYND=1 END IF ELSE CALL FPSTOP(200010,IPOS) END IF END IF END IF C C Definitions of characteristics provided by the default option. C IF(NDEFLT) THEN C C COUNT and CLASS may not use the default option. C IF(IKEY.EQ.55) THEN CALL FESTOP(200011) ELSE IF(ITYPE.EQ.4) THEN CALL FESTOP(200012) END IF C C If the number of NEW variables, counting the ones specified in the C statement, exceeds the number of old variables, cannot use the C default option. C IF(IX(NTRANS*12-6)+N.GT.IX(NTRANS*12-8)) THEN CALL FESTOP(200013) END IF C C Save the number of previously defined arguments and the previous C number of variables. C NPASSV=NPASS NVINSV=NVIN DO 60 I=1,N CALL RINCR(2,NVIN,1) C C IPASSB points to the matching OLD variable from which the C characteristics are to be copied. C IPASSB=IX(NTRANS*12-1)+IX(NTRANS*12-6)+I-1 C C The size of the new variable should be copied from RSTPNT of C the matching variable. V2 is set to 0 because no transformation C applies to new variables. C MSIZE(NVIN)=RSTPNT(IPASSB) CALL RINCR(4,NPASS,1) V1(NPASS)=NVIN V2(NPASS)=0 RSTPNT(NPASS)=RSTPNT(IPASSB) ITRANB=V2(IPASSB) C C An error occurs if the matching old variable is N(block). C IF(ITRANB.EQ.9) THEN CALL FESTOP(200014) END IF IVB=V1(IPASSB) ITYPEB=MTYPE(IVB) ITYPET=ITYPE C C For CROSSED DERIVED, distinguish between single-dimensional version C (TYPE=13) and multiple dimensions. Note that N(cat) etc. produces C a different dimension from the original. C IF(ITYPE.EQ.19) THEN C C Except for N(cat), assign TYPE=13 for CAT or single-dimensional C CROSSED DERIVED. C IF((ITYPEB.EQ.3.OR.ITYPEB.EQ.13).AND.ITRANB.NE.8) THEN ITYPET=13 C C For N(crossed cat), N(crossed real) or value(crossed real), set C TYPE=13 if original dimension 2 => resulting dimension 1. C ELSE IF((ITYPEB.EQ.9.AND.ITRANB.EQ.8).OR. . (ITYPEB.EQ.8.AND.(ITRANB.EQ.8.OR.ITRANB.EQ.10))) THEN K=CDMPNT(IVB) IF(CROSSD(K).EQ.2)ITYPET=13 END IF END IF MTYPE(NVIN)=ITYPET C C Determination of dimensions for the new variable. C C For TYPE=3 or 13 (i.e., CAT or single-dimension CROSSED DERIVED): C IF(ITYPE.EQ.3.OR.ITYPET.EQ.13) THEN CDMPNT(NVIN)=0 C C For CAT or single-dimensional CROSSED DERIVED, except for N( ), C point to the level labels of the matching old variable. C IF((ITYPEB.EQ.3.OR.ITYPEB.EQ.13).AND.ITRANB.NE.8) THEN LPOINT(NVIN)=LPOINT(IVB) C C For N(crossed cat), N(crossed real) or value(crossed real), point C to the level labels of the second dimension. C ELSE IF((ITYPEB.EQ.9.AND.ITRANB.EQ.8).OR. . (ITYPEB.EQ.8.AND.(ITRANB.EQ.8.OR.ITRANB.EQ.10))) THEN K=CDMPNT(IVB) IF(CROSSD(K).NE.2) THEN CALL FESTOP(200015) END IF LPOINT(NVIN)=LPOINT(IVB)+CROSSD(K+1)+2 ELSE CALL FESTOP(200016) END IF C C For TYPE=9 or 19 (i.e., CROSSED CAT or multi-dimensional CROSSED C DERIVED): C ELSE IF(ITYPE.EQ.9.OR.ITYPE.EQ.19) THEN C C Case 1: matching OLD variable is also CROSSED CAT or DERIVED: C IF(ITYPEB.EQ.9.OR.ITYPEB.EQ.19) THEN C C For default trans., PERCENT, MEAN, TOTAL, PERCENT2, PROPORTION or C VALUE, copy information from matching OLD variable. C IF(ITRANB.LE.2.OR.ITRANB.EQ.5.OR.ITRANB.EQ.6.OR. . ITRANB.EQ.10) THEN LPOINT(NVIN)=LPOINT(IVB) CDMPNT(NVIN)=CDMPNT(IVB) C C For PERCENT1, TOTAL1, PROPORTION1, copy information out of matching C OLD variable, but adjust first dimension. C ELSE IF(ITRANB.EQ.3.OR.ITRANB.EQ.4.OR.ITRANB.EQ.7) THEN K=CDMPNT(IVB) CDMPNT(NVIN)=NCRSSD+1 CALL RINCR(10,NCRSSD,1) NK=CROSSD(K) CROSSD(NCRSSD)=NK LP=LPOINT(IVB) LPOINT(NVIN)=NCRVL+1 CALL RINCR(10,NCRSSD,1) CROSSD(NCRSSD)=CROSSD(K+1)-1 C C Exception: if the first dimension of the matching variable is 1, C set the outcome to 1. C IF(CROSSD(NCRSSD).LT.1)CROSSD(NCRSSD)=1 DO 61 II=1,CROSSD(NCRSSD)+1 CALL RINCR(7,NCRVL,1) LEVEL(NCRVL)=LEVEL(LP) LP=LP+1 61 CONTINUE LP=LPOINT(IVB)+CROSSD(K+1)+1 DO 63 II=2,NK CALL RINCR(10,NCRSSD,1) CROSSD(NCRSSD)=CROSSD(K+II) DO 62 III=1,CROSSD(K+II)+1 CALL RINCR(7,NCRVL,1) LEVEL(NCRVL)=LEVEL(LP) LP=LP+1 62 CONTINUE 63 CONTINUE CALL RINCR(10,NCRSSD,1) CROSSD(NCRSSD)=CROSSD(K+NK+1) C C For N( ), reduce the dimensions by 1, by copy renaming information. C ELSE IF(ITRANB.EQ.8) THEN K=CDMPNT(IVB) CDMPNT(NVIN)=NCRSSD+1 CALL RINCR(10,NCRSSD,1) NK=CROSSD(K) CROSSD(NCRSSD)=NK-1 LPOINT(NVIN)=LPOINT(IVB)+CROSSD(K+1)+1 DO 64 II=2,NK CALL RINCR(10,NCRSSD,1) CROSSD(NCRSSD)=CROSSD(K+II) 64 CONTINUE CALL RINCR(10,NCRSSD,1) CROSSD(NCRSSD)=CROSSD(K+NK+1)+1 ELSE C C Error message if wrong function. C CALL FESTOP(200017) END IF C C Case 2: matching variable is crossed real C ELSE IF(ITYPEB.EQ.8) THEN IF(ITRANB.EQ.1.OR.ITRANB.EQ.2.OR.ITRANB.EQ.8.OR. . ITRANB.EQ.10) THEN K=CDMPNT(IVB) CDMPNT(NVIN)=NCRSSD+1 CALL RINCR(10,NCRSSD,1) NK=CROSSD(K) C C Error message if CROSSED REAL has single categorical. C IF(NK.EQ.2) THEN CALL FESTOP(200018) END IF CROSSD(NCRSSD)=NK-1 LPOINT(NVIN)=LPOINT(IVB)+1 DO 65 II=2,NK CALL RINCR(10,NCRSSD,1) CROSSD(NCRSSD)=CROSSD(K+II) 65 CONTINUE CALL RINCR(10,NCRSSD,1) CROSSD(NCRSSD)=CROSSD(K+NK+1)+1 ELSE C C Error message if wrong function for CROSSED REAL. C CALL FESTOP(200019) END IF ELSE C C Error message if OLD variable is of wrong type, i.e., not CROSSED C DERIVED, CROSSED CAT, or CROSSED REAL C CALL FESTOP(200020) END IF C C For new CROSSED REAL, only accept if matching variable is CROSSED C real, no transformation C ELSE IF(ITYPEB.EQ.8.AND.ITRANB.EQ.0) THEN LPOINT(NVIN)=LPOINT(IVB) CDMPNT(NVIN)=CDMPNT(IVB) ELSE CALL FESTOP(200021) END IF END IF 60 CONTINUE C C At end of loop, restore NPASS and NVIN C NPASS=NPASSV NVIN=NVINSV C C Not the default option. C C At this point, have already read "(" and C therefore expect specification, e.g., number of levels. C ELSE CALL RNSCAN(IPOS,IPOS2,RANGE,MRANGS,RTYPE,RGROUP, . NR,3,LEVEL,1) IF(IPOS.EQ.1) THEN IBEYND=1 IF(IPOS2.EQ.0) THEN CALL FESTOP(200022) END IF ELSE IF(IPOS2.EQ.0) THEN CALL FPSTOP(200022,IPOS) END IF IPOS=IPOS2 IF(IPOS.GE.256) THEN IBEYND=1 IF(.NOT.REFRSH(IPOS))INEXT=1 END IF C C Distinguish between CROSSED DERIVED of single dimension C (TYPE=13) and multiple (TYPE=19) C IF(ITYPE.EQ.19.AND.NR.EQ.1)ITYPE=13 NCRVLS=NCRVL C C Determine block number for COUNT N(#) C IF(IKEY.EQ.55) THEN IF(NR.GT.1.OR.RTYPE(1).NE.1) THEN CALL FESTOP(200023) END IF CALL RINCR(4,NPASS,1) V1(NPASS)=RANGE(2,1) IF(V1(NPASS).LE.0) THEN CALL FESTOP(200023) END IF V2(NPASS)=9 IBLOCK=V1(NPASS) C C Determine dimension of categorical, class, and single-dimension C crossed derived C ELSE IF(ITYPE.EQ.3.OR.ITYPE.EQ.4.OR.ITYPE.EQ.13) THEN IF(NR.GT.1.OR.RTYPE(1).NE.1) THEN IF(ITYPE.EQ.13) THEN CALL FESTOP(200024) ELSE CALL FESTOP(200025) END IF END IF IMSIZE=RANGE(2,1) IF(IMSIZE.LE.0) THEN IF(ITYPE.EQ.13) THEN CALL FESTOP(200024) ELSE CALL FESTOP(200025) END IF END IF DO 17 I=1,IMSIZE CALL RINCR(7,NCRVL,1) LEVEL(NCRVL)(1:12)=' ' LEVEL(NCRVL)(13:24)=LEVEL(NCRVL)(1:12) 17 CONTINUE IF(INEXT.EQ.0) THEN CALL LEVELR(IPOS,IPOS2,NL,LEVEL(NCRVLS+1),IMSIZE) IF(IPOS.EQ.1)IBEYND=1 IF(IPOS2.EQ.0)INEXT=1 IPOS=IPOS2 END IF C C Provide default labels for levels if blank. C CALL LEVELD(LEVEL(NCRVLS+1),IMSIZE) C C CROSSED REAL, CROSSED CAT, and CROSSED DERIVED of more than one C dimension. Each of these forms requires entries in CROSSD C ELSE ICLSV=NCRSSD+1 IF(ITYPE.EQ.9.OR.ITYPE.EQ.19) THEN C C Compute in IMSIZE the size of the variable. Initialize IMSIZE to C 1 for CROSSED CAT and CROSSED DERIVED variables. The first entry C in CROSSD will be the dimension of the variable. C IMSIZE=1 CALL RINCR(10,NCRSSD,1) CROSSD(NCRSSD)=NR IF(ITYPE.EQ.9.AND.NR.LT.2) THEN CALL FESTOP(200026) END IF ELSE C C Initialize IMSIZE to 2 for a CROSSED REAL variable. CROSSED REAL C variables have an initial dimension of 2 and are crossed by each of C the specified levels, so store the number of specified levels plus C 1 as the first entry of CROSSD. C IMSIZE=2 CALL RINCR(10,NCRSSD,2) CROSSD(NCRSSD-1)=NR+1 CROSSD(NCRSSD)=0 END IF C C Store dimensions, etc. of new crossed variable(s) in CROSSD C DO 18 I=1,NR IF(RTYPE(I).NE.1) THEN CALL FESTOP(200027) END IF CALL RINCR(10,NCRSSD,1) CROSSD(NCRSSD)=RANGE(2,I) IF(CROSSD(NCRSSD).LE.0) THEN CALL FESTOP(200027) END IF IMSIZE=IMSIZE*CROSSD(NCRSSD) 18 CONTINUE CALL RINCR(10,NCRSSD,1) CROSSD(NCRSSD)=SVTEMP ICL=ICLSV ISVTMP=SVTEMP C C Loop to blank out labels for crossed variables C DO 20 I=1,CROSSD(ICLSV) ICL=ICL+1 VTEMP(SVTEMP)=' ' DO 19 J=1,CROSSD(ICL)+1 CALL RINCR(7,NCRVL,1) LEVEL(NCRVL)(1:12)=VTEMP(SVTEMP) LEVEL(NCRVL)(13:24)=VTEMP(SVTEMP) 19 CONTINUE CALL RINCR(13,SVTEMP,1) 20 CONTINUE C C VTMPSZ is computed as the remaining space available to VNFIND. C VTMPSZ=MVAR-SVTEMP+1 ICL=ICLSV NCRVL2=NCRVLS+1 C C Read in labels for crossed variables, if present C IF(INEXT.EQ.0) THEN DO 22 I=1,CROSSD(ICLSV) CALL VNFIND(IPOS,VTEMP(ISVTMP),VTMPSZ,NN,IPOS2,3,VNAME, . NVIN) C C Because SVTEMP was already checked, there is enough space to C increment ISVTMP without checking it. C ISVTMP=ISVTMP+1 IF(IPOS.EQ.1)IBEYND=1 IF(IPOS2.EQ.0)INEXT=1 IPOS=IPOS2 C C Leave loop if no more information provided. C IF(INEXT.EQ.1)GO TO 23 ICL=ICL+1 K=CROSSD(ICL)+1 CALL LEVELR(IPOS,IPOS2,NL,LEVEL(NCRVL2),K) NCRVL2=NCRVL2+K IF(IPOS.EQ.1)IBEYND=1 IF(IPOS2.EQ.0)INEXT=1 IPOS=IPOS2 C C Leave loop if no more information provided. C IF(INEXT.EQ.1)GO TO 23 22 CONTINUE END IF END IF END IF END IF C C Top of loop to look for /CLASS and /BLOCK statements C 23 CONTINUE IF(INEXT.EQ.0.AND.ITYPE.NE.4) THEN CALL NBFND2(IPOS,IPOS2) IF(IPOS.EQ.1)IBEYND=1 IF(IPOS2.LE.0) THEN INEXT=1 GO TO 23 END IF IPOS=IPOS2 IF(CARD(IPOS:IPOS).NE.'/') THEN CALL FPSTOP(200028,IPOS) END IF IPOS=IPOS+1 IF(IPOS.GT.256) THEN IBEYND=1 IF(.NOT.REFRSH(IPOS))INEXT=1 END IF END IF C C The seemingly redundant conditions recheck the current status C of INEXT, which could have been redefined within the previous C IF block. C IF(INEXT.EQ.0.AND.ITYPE.NE.4) THEN C C Use VNFIND to locate either CLASS or BLOCK. C CALL VNFIND(IPOS,VTEMP(SVTEMP),VTMPSZ,NN,IPOS2,3,VNAME, . NVIN) IF(NN.EQ.0.OR.IPOS2.EQ.0) THEN IF(IPOS.GT.1) THEN CALL FPSTOP(200029,IPOS) ELSE CALL FESTOP(200029) END IF END IF IF(IPOS.EQ.1)IBEYND=1 IPOS=IPOS2 CALL VNMTCH('CLASS ',VTEMP(SVTEMP),1,J) C C /CLASS C IF(J.EQ.1) THEN IF(ICLSS.GT.0) THEN CALL FESTOP(200030) END IF C C Setup for call to CLSCAN, ensuring that resources are available. C ICLSS=NXPTI MAXIA=(MTRSZI-ICLSS-1)/3 IF(MAXIA.LE.0) THEN CALL FESTOP(200031) END IF MAXRT=(MSIZED-NXPTD+1)/2 IB=NPASS+N+1 IF(MVAR-IB.LT.MAXRT)MAXRT=MRECOD-IB+1 IF(MAXRT.LE.0) THEN CALL FESTOP(200032) END IF CALL CLSCAN(IPOS,IPOS2,IX(ICLSS+2),MAXIA,IX(ICLSS), . VTEMP(SVTEMP),VTMPSZ,DX(NXPTD),MAXRT,V1(IB),V2(IB), . NVIN) C C The following check insures that a single "group" is defined - C that is, all class variables are linked as a single product by * C IF(IX(ICLSS).NE.IX(ICLSS+2)+1) THEN CALL FESTOP(200033) END IF C C Allocate space to save class specification. C K=3*IX(ICLSS)+2 CALL ROOMI(K) J=NXPTI K=ICLSS+2 C C Edit class specification to insure no duplicates C 24 CONTINUE NN=IX(K) K=K+3 DO 27 I=1,NN IF(I.LT.NN) THEN IF(IX(K).EQ.IX(K+3))GO TO 26 END IF C C We build up a list of class variables starting at NXPTI. Except C for an error call for overflow, this information is not subsequently C kept. C IX(J)=IX(K) IF(J.GT.NXPTI) THEN DO 25 JJ=NXPTI,J-1 IF(IX(JJ).EQ.IX(J)) THEN WRITE(U6,229)VNAME(IX(J)) CALL FESTOP(200034) END IF 25 CONTINUE END IF J=J+1 IF(J.GT.MTRSZI) THEN J=MTRSZI+2-NXPTI CALL ROOMI(J) END IF 26 CONTINUE K=K+3 27 CONTINUE C C Surviving but nonfunctional code? The next statement loops back C again if there is more to do. However, this should only occur if C there is more than one group, and a check has already been made to C ensure only a single group. C IF(K.LT.NXPTI)GO TO 24 C IF(IPOS.EQ.1)IBEYND=1 IF(IPOS2.EQ.0) INEXT=1 IPOS=IPOS2 GO TO 23 ELSE C C /BLOCK C CALL VNMTCH('BLOCK ',VTEMP(SVTEMP),1,J) IF(J.EQ.1) THEN IF(IBLOCK.GT.0) THEN CALL FPSTOP(200035,IPOS) END IF CALL NBFND2(IPOS,IPOS2) IF(IPOS.EQ.1)IBEYND=1 IPOS=IPOS2 IF(IPOS.EQ.0) THEN CALL FESTOP(200036) END IF CALL IFIND(CARD(IPOS:256),IPOS,256,IPOS2,IBLOCK) IF(IPOS2.LE.0) THEN CALL FPSTOP(200036,IPOS) END IF IPOS=IPOS2 GO TO 23 ELSE CALL FESTOP(200037) END IF END IF END IF C C Save the current position of NCLBAR C NCLBR2=NCLBAR C C Translate class specification into entries in BLNCLS, etc. C IF(ICLSS.GT.0.AND.ITYPE.NE.4) THEN CALL CLFORM(IX(ICLSS+2),IX(ICLSS)) C C If no /CLASS specification is given: C ELSE IF(ITYPE.NE.4) THEN CALL RINCR(8,NCLBLK,1) BLNCLS(NCLBLK)=0 BLTYPE(NCLBLK)=0 BLXINC(NCLBLK)=1 END IF C C If the block was not specified by /BLOCK, look for an existing block C matching the /CLASS specification. NCLBLS is the number of the C last block in the input VPLX file. C IF(IBLOCK.EQ.0.AND.ITYPE.NE.4) THEN IF(NCLBLK.EQ.NCLBLS+1) THEN IBLOCK=NCLBLK ELSE DO 28 ICLBLK=NCLBLS+1,NCLBLK-1 IF(CLMTCH(ICLBLK,NCLBLK)) THEN NCLBLK=NCLBLK-1 NCLBAR=NCLBR2 IBLOCK=ICLBLK GO TO 29 END IF 28 CONTINUE IBLOCK=NCLBLK 29 CONTINUE END IF IF(U5ECHO.EQ.1)WRITE(U6,102)IBLOCK C C If there is a /BLOCK specification, check. C ELSE IF(ITYPE.NE.4) THEN IF(IKEY.EQ.55)BLTYPE(IBLOCK)=1 IF(IBLOCK.GT.NCLBLK) THEN CALL FESTOP(200038) ELSE IF(IBLOCK.LT.NCLBLK) THEN IF(.NOT.CLMTCH(IBLOCK,NCLBLK)) THEN IF(ICLSS.GT.0) THEN CALL FESTOP(200039) ELSE CALL FESTOP(200040) END IF C C If the /BLOCK specification points to a compatible existing block, C adjust NCLBLK, NCLBAR to avoid creating a new block. C ELSE IF(IBLOCK.LT.NCLBLK) THEN NCLBLK=NCLBLK-1 NCLBAR=NCLBR2 END IF END IF END IF C C Adjust the number of new variables. C IF(ITYPE.NE.4)IX(NTRANS*12-6)=IX(NTRANS*12-6)+N C C For new COUNT variable C IF(IKEY.EQ.55) THEN V3(NPASS)=ICLSS RSTPNT(NPASS)=1 C C All other variables. C ELSE DO 30 I=1,N CALL RINCR(2,NVIN,1) C C Under the default option, MTYPE, etc. have already been determined. C In all other cases, set MTYPE etc. now. C IF(.NOT.NDEFLT) THEN MTYPE(NVIN)=ITYPE MSIZE(NVIN)=IMSIZE C C For all variables except CLASS C IF(ITYPE.NE.4) THEN CALL RINCR(4,NPASS,1) V1(NPASS)=NVIN V2(NPASS)=0 V3(NPASS)=ICLSS RSTPNT(NPASS)=IMSIZE MXSIZE(NVIN)=IBLOCK IF(ITYPE.EQ.3.OR.ITYPE.EQ.8.OR.ITYPE.EQ.9.OR. . ITYPE.EQ.13.OR.ITYPE.EQ.19) THEN LPOINT(NVIN)=NCRVLS+1 ELSE LPOINT(NVIN)=0 END IF IF(ITYPE.EQ.8.OR.ITYPE.EQ.9.OR.ITYPE.EQ.19) . THEN CDMPNT(NVIN)=ICLSV ELSE CDMPNT(NVIN)=0 END IF C C For CLASS variables. C ELSE MXSIZE(NVIN)=0 LPOINT(NVIN)=NCRVLS+1 CDMPNT(NVIN)=0 END IF C C For default variables, set only information about block placement and C /CLASS C ELSE CALL RINCR(4,NPASS,1) V3(NPASS)=ICLSS MXSIZE(NVIN)=IBLOCK END IF 30 CONTINUE END IF C C Go to 2 if do not need to read the next input record. C IF(U5END.EQ.1.OR.(ALPCHK(CARD(1:1)).AND.IBEYND.EQ.1))GO TO 2 GO TO 1 C C DROP, KEEP C ELSE IF(IKEY.EQ.18.OR.IKEY.EQ.19) THEN IF(VKEEPF.NE.0) THEN IF((IKEY.EQ.18.AND.VKEEPF.EQ.1).OR. . (IKEY.EQ.19.AND.VKEEPF.EQ.2)) THEN CALL FESTOP(200041) END IF ELSE IF(IKEY.EQ.18) THEN VKEEPF=2 ELSE VKEEPF=1 END IF J=MVAR-NKEEP IF(IPT.LE.0) THEN IPOS=IPT CALL NBFND2(IPOS,IPT) IF(IPT.LE.0) THEN CALL FESTOP(200042) END IF END IF CALL VNFIND(IPT,VNKEEP(NKEEP+1),J,N,IPOS,2,VNAME,NVIN) IF(N.LE.0) THEN CALL FESTOP(200042) END IF NKEEP=NKEEP+N IF(IPOS.GT.0) THEN CALL FPSTOP(200043,IPOS) END IF GO TO 2 C C LABEL, LABELS C ELSE IF(IKEY.EQ.20) THEN CALL RLABEL(IPT,VNAME,NVIN,VTEMP(SVTEMP),VTMPSZ,VTEMP, . MTYPE,LPOINT,CDMPNT,CROSSD,LABEL,LEVEL,NCRVL,MLEVEL,IPOS) IF(IPT.EQ.1) THEN GO TO 2 ELSE GO TO 1 END IF C C LEVEL, LEVELS C ELSE IF(IKEY.EQ.21) THEN CALL RLEVEL(IPT,VNAME,NVIN,VTEMP(SVTEMP),VTMPSZ,LPOINT,MSIZE, . LEVEL,NCRVL,MLEVEL,IPOS) IF(IPT.EQ.1) THEN GO TO 2 ELSE GO TO 1 END IF C C RENAME C ELSE IF(IKEY.EQ.22) THEN CALL RENAMV(IPT,VNAME,NVIN,VTEMP(SVTEMP),VTMPSZ,VTEMP, . VNKEEP,NKEEP,MTYPE,LPOINT,CDMPNT,CROSSD,LABEL,LEVEL,IPOS) IF(IPT.EQ.1) THEN GO TO 2 ELSE GO TO 1 END IF C C OLD, MODIFY C ELSE IF(IKEY.EQ.50.OR.IKEY.EQ.51) THEN IF(NTRANS.EQ.0) THEN CALL FESTOP(200004) ELSE IF(IX(NTRANS*12-9).EQ.-60) THEN CALL FESTOP(200073) END IF IBEYND=0 INEXT=0 ICLSS=0 MAXOUT=MRECOD-NPASS+1 IF(MAXOUT.LE.0) THEN CALL FESTOP(200067) END IF CALL VTSCAN(IPT,VNAME,MTYPE,MSIZE,CDMPNT,CROSSD,NVIN, . VTEMP(SVTEMP),VTMPSZ,V1(NPASS+1),V2(NPASS+1), . RSTPNT(NPASS+1),MAXOUT,N,LTOT,IPOS,IERR) IF(IERR.EQ.1) THEN CALL FESTOP(200044) ELSE IF(IERR.EQ.2) THEN CALL FESTOP(200045) ELSE IF(N.LE.0) THEN CALL FESTOP(200046) END IF IF(IPT.EQ.1)IBEYND=1 IF(IPOS.EQ.0)INEXT=1 C C Edit the list of variables. C DO 41 I=1,N IF(V2(NPASS+I).EQ.9) THEN IF(V1(NPASS+I).LE.0.OR.V1(NPASS+I).GT.NCLBLK) THEN WRITE(U6,219)V1(NPASS+I) CALL FESTOP(200047) END IF ELSE C C For MODIFY, do not permit any transformations C IF(IKEY.EQ.51) THEN IF(V2(NPASS+I).NE.0) THEN CALL FESTOP(200048) END IF ELSE C C For OLD, check that MEAN( ) can be computed based on N(block). C IF(V2(NPASS+I).EQ.1) THEN K=V1(NPASS+I) IF(MTYPE(K).EQ.1) THEN IF(BLTYPE(MXSIZE(K)).NE.1) THEN WRITE(U6,230)VNAME(K) CALL FESTOP(200049) END IF END IF END IF END IF END IF 41 CONTINUE 43 CONTINUE C C Check for a / CLASS specification. C IF(INEXT.EQ.0) THEN CALL NBFND2(IPOS,IPOS2) IF(IPOS.EQ.1)IBEYND=1 IF(IPOS2.LE.0) THEN INEXT=1 GO TO 43 END IF IPOS=IPOS2 IF(CARD(IPOS:IPOS).NE.'/') THEN CALL FPSTOP(200050,IPOS) END IF IPOS=IPOS+1 IF(IPOS.GT.256) THEN IBEYND=1 IF(.NOT.REFRSH(IPOS))INEXT=1 END IF END IF IF(INEXT.EQ.0) THEN CALL VNFIND(IPOS,VTEMP(SVTEMP),VTMPSZ,NN,IPOS2,3,VNAME, . NVIN) IF(NN.EQ.0.OR.IPOS2.EQ.0) THEN IF(IPOS.NE.1) THEN CALL FPSTOP(200051,IPOS) ELSE CALL FESTOP(200051) END IF END IF IF(IPOS.EQ.1)IBEYND=1 IPOS=IPOS2 CALL VNMTCH('CLASS ',VTEMP(SVTEMP),1,J) IF(J.EQ.1) THEN IF(ICLSS.GT.0) THEN CALL FESTOP(200030) END IF C C Set up arrays for call to CLSCAN C ICLSS=NXPTI MAXIA=(MTRSZI-ICLSS-1)/3 MAXRT=MSIZED-NXPTD+1 IB=NPASS+N+1 IF(MVAR-IB.LT.MAXRT)MAXRT=MRECOD-IB+1 IF(MAXRT.LE.0) THEN CALL FESTOP(200032) END IF CALL CLSCAN(IPOS,IPOS2,IX(ICLSS+2),MAXIA,IX(ICLSS), . VTEMP(SVTEMP),VTMPSZ,DX(NXPTD),MAXRT,V1(IB),V2(IB), . NVIN) C C Insure that the class specification is of the form of a single C product. C IF(IX(ICLSS).NE.IX(ICLSS+2)+1) THEN CALL FESTOP(200033) END IF K=3*IX(ICLSS)+2 CALL ROOMI(K) IF(IPOS.EQ.1)IBEYND=1 IF(IPOS2.EQ.0) INEXT=1 IPOS=IPOS2 C C Loop back just in case there is remaining unexpected information. C GO TO 43 ELSE CALL FESTOP(200051) END IF END IF C C Check if it is necessary to reposition variables. C C For OLD variables, define ISTART to be the first MODIFY variable C IF(IKEY.EQ.50) THEN IF(IX(NTRANS*12-7)+IX(NTRANS*12-6).GT.0) THEN ISTART=IX(NTRANS*12-1)+IX(NTRANS*12-8) ELSE ISTART=0 END IF C C For MODIFY variables, define ISTART to be the first new variable. C ELSE IF(IX(NTRANS*12-6).GT.0) THEN ISTART=IX(NTRANS*12-1)+IX(NTRANS*12-8)+IX(NTRANS*12-7) ELSE ISTART=0 END IF END IF C C Working backwards, shift all the pointers from NPASS+N back to ISTART C each up by N C IF(ISTART.GT.0) THEN IEND=NPASS+N CALL RCHECK(4,IEND,N) DO 45 I=IEND,ISTART,-1 V1(I+N)=V1(I) V2(I+N)=V2(I) V3(I+N)=V3(I) RSTPNT(I+N)=RSTPNT(I) 45 CONTINUE ISTART=ISTART-1 C C Now move the added variables into their proper place. C DO 46 I=1,N V1(I+ISTART)=V1(I+IEND) V2(I+ISTART)=V2(I+IEND) V3(I+ISTART)=V3(I+IEND) RSTPNT(I+ISTART)=RSTPNT(I+IEND) 46 CONTINUE ELSE ISTART=NPASS END IF C C Checking of class specifications. C DO 47 I=1,N K=I+ISTART V3(K)=ICLSS C C For OLD variables: C IF(IKEY.EQ.50) THEN IF(ICLSS.GT.0) THEN IF(V2(K).EQ.9) THEN CALL CLCHCK(V1(K),V1(K),V2(K),IX(ICLSS+2),IX(ICLSS+2)) ELSE CALL CLCHCK(MXSIZE(V1(K)),V1(K),V2(K),IX(ICLSS+2), . IX(ICLSS+2)) END IF ELSE IF(V2(K).EQ.9) THEN CALL CLCHCK(V1(K),V1(K),V2(K),IX,0) ELSE CALL CLCHCK(MXSIZE(V1(K)),V1(K),V2(K),IX,0) END IF END IF C C For MODIFY variables: C ELSE IF(ICLSS.GT.0) THEN IF(V2(K).EQ.9) THEN CALL CLCHK3(V1(K),V1(K),V2(K),IX(ICLSS+2),IX(ICLSS+2)) ELSE CALL CLCHK3(MXSIZE(V1(K)),V1(K),V2(K),IX(ICLSS+2), . IX(ICLSS+2)) END IF ELSE IF(V2(K).EQ.9) THEN CALL CLCHK3(V1(K),V1(K),V2(K),IX,0) ELSE CALL CLCHK3(MXSIZE(V1(K)),V1(K),V2(K),IX,0) END IF END IF END IF 47 CONTINUE C C Finally, increment NPASS. The range of NPASS has been previously C checked for validity through the computation of MAXOUT earlier and C screening by VTSCAN. C NPASS=NPASS+N IF(IKEY.EQ.50) THEN IX(NTRANS*12-8)=IX(NTRANS*12-8)+N ELSE IX(NTRANS*12-7)=IX(NTRANS*12-7)+N END IF IF(U5END.EQ.1.OR.(ALPCHK(CARD(1:1)).AND.IBEYND.EQ.1))GO TO 2 GO TO 1 C C REMOVE BLOCK C ELSE IF(IKEY.EQ.57) THEN IPOS=IPT CALL CMATCH(CARD(IPOS:256),IPOS,256,'BLOCK',5,IPOS3,1) IF(IPOS3.EQ.0) THEN CALL CMATCH(CARD(IPOS:256),IPOS,256,'BLOCKS',6,IPOS3,1) IF(IPOS3.EQ.0) THEN CALL FPSTOP(200052,IPOS) END IF END IF CALL NBFND2(IPOS3,IPOS) IF(IPOS3.EQ.1)IPT=1 IF(IPOS.EQ.0) THEN CALL FESTOP(200053) END IF CALL IFIND(CARD(IPOS:256),IPOS,256,IPOS2,IBLOCK) IF(IPOS2.GT.0) THEN C C This statement was changed in Jan. 1996 to allow REMOVE BLOCK to C apply to all blocks. Previously, an error occurred if IBLOCK was C greater than NCLBLS, the number of blocks on the incoming file. C IF(IBLOCK.LE.0.OR.IBLOCK.GT.NCLBLK) THEN CALL FPSTOP(200054,IPOS) END IF C C Setting BLXSIZ to 0 signals that the block is to be dropped. C BLXSIZ(IBLOCK)=0 CALL NBFND2(IPOS2,IPOS) IF(IPOS2.EQ.1)IPT=1 IF(IPOS.NE.0) THEN CALL FPSTOP(200055,IPOS) END IF C C REMOVE BLOCK (range) form: C ELSE IF(CARD(IPOS:IPOS).EQ.'(') THEN IPOS=IPOS+1 CALL RNSCAN(IPOS,IPOS2,RANGE,MRANGS,RTYPE,RGROUP, . NR,3,LEVEL,1) IF(IPOS.EQ.1)IPT=1 IF(IPOS2.EQ.0.OR.NR.EQ.0) THEN CALL FESTOP(200056) END IF DO 67 IBLOCK=1,NCLBLK DO 673 IR=1,NR IF(RTYPE(IR).EQ.5)GO TO 673 IF(RTYPE(IR).EQ.1.OR.RTYPE(IR).EQ.3.OR.RTYPE(IR).EQ.6) THEN IF(DBLE(FLOAT(IBLOCK)).LT.RANGE(1,IR)) GO TO 673 END IF IF(RTYPE(IR).EQ.1.OR.RTYPE(IR).EQ.2) THEN IF(DBLE(FLOAT(IBLOCK)).GT.RANGE(2,IR)) GO TO 673 END IF BLXSIZ(IBLOCK)=0 GO TO 67 673 CONTINUE 67 CONTINUE ELSE CALL FESTOP(200057) END IF END IF IF(IPT.GT.1) THEN GO TO 1 ELSE GO TO 2 END IF C C CONSTANT(S), INTEGER CONSTANT(S), SLICELENGTH, SLICE_LENGTH C ELSE IF(IKEY.EQ.52.OR.(IKEY.GE.89.AND.IKEY.LE.91)) THEN IF(NTRANS.EQ.0) THEN CALL FESTOP(200004) END IF C INEXT=0 C C For INTEGER CONSTANT(S) C IF(IKEY.EQ.89) THEN IF(IPT.LE.0) THEN CALL NBFND2(IPT,IPOS) IF(IPOS.GT.0) THEN IPT=IPOS ELSE CALL FESTOP(200061) END IF END IF CALL CMATCH(CARD(IPT:256),IPT,256,'CONSTANT',8,IPOS,1) IF(IPOS.GT.0) THEN IPT=IPOS ELSE CALL CMATCH(CARD(IPT:256),IPT,256,'CONSTANTS',9,IPOS,1) IF(IPOS.GT.0)IPT=IPOS END IF END IF I=IX(NTRANS*12-9) C C Force interpretation of CONSTANTS, ignoring INTEGER CONSTANTS, C for ADD, SUBTRACT, etc., and VPLX_APPEND C IF((I.GE.-14.AND.I.LE.-1).OR.I.EQ.-60) THEN IKEY=52 C C Force intepretation of INTEGER CONSTANTS for GLUE and REPPRINT. C ELSE IF(I.EQ.-15.OR.I.EQ.-16) THEN IKEY=89 END IF C C Constants: C IF(IKEY.EQ.52) THEN IF(IX(NTRANS*12-5).GT.0) THEN CALL FESTOP(200058) ELSE IX(NTRANS*12-5)=NXPTD END IF C C For REPREAD, REPWRITE, BINARYREAD, and BINARYWRITE, don't permit C specification of integer constants. C ELSE IF(IX(NTRANS*12-9).GE.-20.AND.IX(NTRANS*12-9).LE.-17) . THEN IF(IKEY.EQ.89.OR.IX(NTRANS*12-9).EQ.-19.OR. . IX(NTRANS*12-9).EQ.-20) THEN CALL FESTOP(200059) C C Space has already been allocated to integer constants to translate C options. Move previous values. C ELSE K=IX(NTRANS*12-11) IX(NTRANS*12-11)=NXPTI CALL ROOMI(4) IX(NXPTI-4)=IX(K) IX(NXPTI-3)=IX(K+1) IX(NXPTI-2)=IX(K+2) IX(NXPTI-1)=IX(K+3) END IF K=NXPTD C C Other instances of INTEGER CONSTANTS C ELSE IF(IX(NTRANS*12-2).GT.0) THEN CALL FESTOP(200060) ELSE IX(NTRANS*12-11)=NXPTI END IF K=NXPTD END IF L=SIZED-NXPTD+1 C C Read in values with DASCAN (double precision) regardless of whether C CONSTANTS or INTEGER CONSTANTS C CALL DASCAN(IPT,IPOS2,DX(NXPTD),L,N) IF(N.LE.0) THEN IF(IPOS2.GT.0) THEN CALL FPSTOP(200061,IPOS2) ELSE CALL FESTOP(200061) END IF END IF C C Translate double precision into integer values. C IF(IKEY.GE.89.AND.IKEY.LE.91) THEN NXPTD=K L=NXPTI CALL ROOMI(N) LL=0 DO 68 I=1,N IF(.NOT.ICHECK(DX(K),DVALU2))LL=1 IF(DX(K).LT.0.) THEN IX(L)=DX(K)-.5D-01 ELSE IX(L)=DX(K)+.5D-01 END IF K=K+1 L=L+1 68 CONTINUE IF(LL.EQ.1) THEN WRITE(U6,232) END IF IX(NTRANS*12-2)=IX(NTRANS*12-2)+N ELSE IX(NTRANS*12-4)=N CALL ROOMD(N) C C For SIPPCOL, CONSTANTS represent scale values. Allocate an C additional bank of 0's for calculation. C IF(IX(NTRANS*12-9).EQ.-24.OR.IX(NTRANS*12-9).EQ.-61) THEN CALL ROOMD(N) IX(NTRANS*12-4)=2*N K=IX(NTRANS*12-5)+N DO 69 I=1,N DX(K)=0. K=K+1 69 CONTINUE END IF END IF IF(IPT.EQ.1.OR.INEXT.EQ.1) THEN GO TO 2 ELSE GO TO 1 END IF C C STRING, FORMAT, LONGSTRING C ELSE IF(IKEY.EQ.16.OR.IKEY.EQ.87.OR.IKEY.EQ.88) THEN IF(NTRANS.EQ.0) THEN CALL FESTOP(200004) ELSE IF(IX(NTRANS*12-9).EQ.-60) THEN CALL FESTOP(200073) END IF C C If have run out of space, call RCHECK to generate fatal error. C IF(NXTSTR.EQ.0) THEN CALL RCHECK(11,MAXFMT,2) END IF DO 70 I=1,128 INFRMT(NXTSTR)(I:I)=' ' 70 CONTINUE K=1 71 CONTINUE CALL NBFND2(IPT,IPOS) IF(IPOS.LE.0) THEN NXTSTR=NXTSTR+1 IX(NTRANS*12-3)=IX(NTRANS*12-3)+1 IF(NXTSTR.GT.MAXFMT)NXTSTR=0 GO TO 2 END IF DO 72 J=256,IPOS,-1 IF(CARD(J:J).NE.' ')GO TO 73 72 CONTINUE 73 CONTINUE J=J+1 DO 75 I=IPOS,J IF(K.GT.128) THEN C C Fatal error for STRING if exceed 128 C IF(IKEY.EQ.87) THEN CALL FPSTOP(200062,I) ELSE NXTSTR=NXTSTR+1 IX(NTRANS*12-3)=IX(NTRANS*12-3)+1 C C Fatal error if out of space. C IF(NXTSTR.GT.MAXFMT) THEN CALL RCHECK(11,MAXFMT,2) END IF DO 74 K=1,128 INFRMT(NXTSTR)(K:K)=' ' 74 CONTINUE K=1 END IF END IF IF(I.LE.256) THEN INFRMT(NXTSTR)(K:K)=CARD(I:I) ELSE INFRMT(NXTSTR)(K:K)=' ' END IF K=K+1 75 CONTINUE IPT=J GO TO 71 C C OPTION C ELSE IF(IKEY.EQ.36) THEN IF(NTRANS.GT.0) THEN C C OPTIONS: GLUE C IF(IX(NTRANS*12-9).EQ.-15) THEN IX(NXPTI)=0 CALL OPTNTR(NOPTNG,INDXG,IVALG,OPTNG,IPT,IPOS,IX(NXPTI)) C C If SLICELENGTH or INTEGER CONSTANTS have already been established, C cannot also give NSLICE. C C The value originally stored is multiplied by -1. This was probably C used as a program signal but could now be done in a different way? C IF(IX(NXPTI).GT.0) THEN IF(IX(NTRANS*12-2).GT.0) THEN CALL FESTOP(200063) END IF IX(NTRANS*12-11)=NXPTI IX(NTRANS*12-2)=1 IX(NXPTI)=-IX(NXPTI) CALL ROOMI(1) END IF C C OPTIONS: REPPRINT C 1. NPRINT, NREP C 2. WIDTH C 3. NDECIMAL C ELSE IF(IX(NTRANS*12-9).EQ.-16) THEN IX(NXPTI)=-1 IX(NXPTI+1)=0 IX(NXPTI+2)=-1 CALL OPTNTR(NOPTNP,INDXP,IVALP,OPTNP,IPT,IPOS,IX(NXPTI)) IF(IX(NTRANS*12-2).GT.0) THEN CALL FESTOP(200063) END IF IX(NTRANS*12-11)=NXPTI IX(NTRANS*12-2)=3 CALL ROOMI(3) C C OPTIONS: REPREAD, REPWRITE, BINARYREAD, BINARYWRITE C ELSE IF(IX(NTRANS*12-9).GE.-20.AND.IX(NTRANS*12-9).LE.-17) . THEN I=IX(NTRANS*12-11) IF(IX(NTRANS*12-9).EQ.-17.OR.IX(NTRANS*12-9).EQ.-19) THEN K=NOPTNW ELSE K=NOPTNR END IF CALL OPTNTR(K,INDXW,IVALW,OPTNW,IPT,IPOS,IX(I)) C C OPTIONS: VPLXAPPEND, VPLX APPEND C ELSE IF(IX(NTRANS*12-9).EQ.-60) THEN I=IX(NTRANS*12-11) CALL OPTNTR(NOPTNV,INDXV,IVALV,OPTNV,IPT,IPOS,IX(I)) C C OPTIONS: MATRIX ALGEBRA ROUTINES C ELSE IF(IX(NTRANS*12-9).GE.-48.AND.IX(NTRANS*12-9).LE.-25) . THEN IX(NXPTI)=0 IX(NXPTI+1)=0 IX(NXPTI+2)=0 IX(NXPTI+3)=0 CALL OPTNTR(NOPTNM,INDXM,IVALM,OPTNM,IPT,IPOS,IX(NXPTI)) IF(IX(NXPTI)+IX(NXPTI+1)+IX(NXPTI+2)+IX(NXPTI+3).GT.0) . THEN IF(IX(NTRANS*12-2).GT.0) THEN CALL FESTOP(200063) END IF IX(NTRANS*12-11)=NXPTI IX(NTRANS*12-2)=4 CALL ROOMI(4) END IF C C OPTIONS: Rao-Shao C ELSE IF(IX(NTRANS*12-9).EQ.-52) THEN IX(NXPTI)=1 CALL OPTNTR(NOPTRS,INDXRS,IVALRS,OPTNRS,IPT,IPOS,IX(NXPTI)) IX(NTRANS*12-11)=NXPTI IX(NTRANS*12-2)=1 CALL ROOMI(1) C C OPTIONS: XMEDIAN C ELSE IF(IX(NTRANS*12-9).EQ.-56) THEN IX(NXPTI)=50 IX(NXPTI+1)=-1 IX(NXPTI+2)=-1 CALL OPTNTR(NOPTNX,INDXX,IVALX,OPTNX,IPT,IPOS,IX(NXPTI)) IX(NTRANS*12-11)=NXPTI IX(NTRANS*12-2)=3 CALL ROOMI(3) ELSE CALL FESTOP(200063) END IF ELSE CALL FESTOP(200004) END IF IF(IPT.EQ.1) THEN GO TO 2 ELSE GO TO 1 END IF C C STEPOPTION, STEP_OPTION C ELSE IF(IKEY.GE.198.AND.IKEY.LE.200) THEN IF(IKEY.EQ.198) THEN IF(IPT.LE.0) THEN CALL NBFND2(IPT,IPOS) IF(IPOS.GT.0) THEN IPT=IPOS ELSE CALL FESTOP(200070) END IF END IF CALL CMATCH(CARD(IPT:256),IPT,256,'OPTION',6,IPOS,1) IF(IPOS.GT.0) THEN IPT=IPOS ELSE CALL CMATCH(CARD(IPT:256),IPT,256,'OPTIONS',7,IPOS,1) IF(IPOS.GT.0) THEN IPT=IPOS ELSE CALL FESTOP(200070) END IF END IF END IF IF(ISOPTN.EQ.1.OR.NTRANS.GT.0) THEN CALL FESTOP(200069) END IF IX(NXPTI)=1 ISOPTN=1 CALL OPTNTR(NOPTNT,INDXT,IVALT,OPTNT,IPT,IPOS,IX(NXPTI)) IEXTRN=IX(NXPTI) IF(IPT.EQ.1) THEN GO TO 2 ELSE GO TO 1 END IF END IF C C USER1 - USER10, REFORMAT, ADD, SUBTRACT, MULTIPLY, DIVIDE, C POWER, RECIPROCAL, LOG, PAIRED (ADD, SUBTRACT, MULTIPLY, DIVIDE) C RMULTIPLY, SAVEFULL, GLUE, RPRINT, REPPRINT, REPWRITE, REPREAD, C BINARYWRITE, BINARYREAD, COLLAPSE, MODIFYREPF, COPY, CPSCOL C SIPPCOL, PINVERT, PSOLVE, XMEDIAN C 77 CONTINUE C C The first section of code is executed at the beginning of a C new subroutine, when encountering a COMPUTE statement or at the end C of the TRANSFORM specification to complete the specification for C any subroutine in progress. C IF(NTRANS.GT.0) THEN IF(IX(NTRANS*12-9).EQ.-60) THEN IF(NLIST.EQ.0) THEN CALL VAPSET(IX,NLIST,NPASS) ELSE CALL VAPSET(IX(ILISTX),NLIST,NPASS) END IF ELSE IF(IX(NTRANS*12-8)+IX(NTRANS*12-7)+IX(NTRANS*12-6).EQ.0) . THEN CALL FESTOP(200065) END IF C C Under INTERNAL step option, set aside 1 entry in constant array C to signal that subroutine should use internal storage, for C RAO_SHAO, SAVEFULL, MODIFYREPF, REPREAD (with CONSTANT option), C BINARYREAD (with CONSTANT option), VPLXAPPEND (with FULL option) C I=IX(NTRANS*12-9) IF(I.EQ.-52.OR.I.EQ.-14.OR.I.EQ.-22.OR.I.EQ.-18.OR.I.EQ.-20.OR. . I.EQ.-60) THEN IF(IEXTRN.EQ.0) THEN IF(IX(NTRANS*12-4).EQ.0) THEN IX(NTRANS*12-4)=1 IX(NTRANS*12-5)=NXPTD CALL ROOMD(1) END IF END IF END IF END IF C C Normal exit from the subroutine at this point. C IF(ENDTRN) THEN RETURN END IF IF((IKEY.GE.58.AND.IKEY.LE.86).OR.IKEY.EQ.112.OR. . IKEY.EQ.119.OR.IKEY.EQ.120.OR. .(IKEY.GE.123.AND.IKEY.LE.156).OR.IKEY.GE.161) THEN CALL RINCR(12,NTRANS,1) C C REFORMAT -1 C ADD -2 C SUBTRACT -3 C MULTIPLY -4 C DIVIDE -5 C POWER -6 C RECIPROCAL -7 C LOG -8 C PAIRED: C ADD -9 C SUBTRACT -10 C MULTIPLY -11 C DIVIDE -12 C RMULTIPLY -13 C SAVEFULL -14 C GLUE -15 C RPRINT -16 C REPPRINT -16 C REPWRITE -17 C REPREAD -18 C BINARYWRITE-19 C BINARYREAD -20 C COLLAPSE -21 C MODIFYREPF -22 C CPSCOL -23 C SIPPCOL -24 C PINVERT -25 C PSOLVE -26 C PMULTIPLYM -27 C PMULTIPLYP -28 C PSYMMULTM -29 C PSYMMULTP -30 C PPACK -31 C PUNPACK -32 C PTRACE -33 C PDIAG -34 C PEIGENVECTOR -35 C PEIGENVALUE -36 C PSQRT -37 C MINVERT -38 C MSOLVE -39 C MMULTIPLY -40 C MMULTIPLYM -40 C MSYMMULT -41 C MSYMMULTM -41 C MTRACE -42 C MDIAG -43 C PBMULTIPLYM -44 C PBMULTIPLYP -45 C PBSYMMULTM -46 C PBSYMMULTP -47 C PBDIAG -48 C CPSCHILDCOL -49 C CPSNICOL -50 C GRIDSEARCH -51 C RAO_SHAO -52 C NEWCPSCHCOL -53 C NPSCHILDCOL -54 C OLDCPSCHCOL -55 C XMEDIAN -56 C SIPPC_ROWCOL -57 C SIPPC_CLMCOL -58 C SIPPC_RAKE -59 C VPLXAPPEND -60 C SIPPC_NICOL -61 C C Beginning of a subroutine C IF(MOD(NTRANS,5).EQ.0) THEN IF(U5ECHO.EQ.1)WRITE(U6,228)NTRANS END IF CALL CRDPRN(1) C C For subroutines with a file specification or key words that must C be followed by additional information C IF(IKEY.LE.57.OR.(IKEY.GE.87.AND.IKEY.LE.91).OR. . (IKEY.GE.165.AND.IKEY.LE.167)) THEN IF(IPT.LE.0) THEN IPT=20 CALL NBFND2(IPT,IPOS) IF(IPOS.LE.0) THEN IF(IKEY.LE.57) THEN CALL FESTOP(200072) ELSE CALL FESTOP(200003) END IF END IF IPT=IPOS END IF END IF IF(IKEY.LE.67) THEN IX(NTRANS*12-9)=IKEY-57 ELSE IF(IKEY.LE.75) THEN IX(NTRANS*12-9)=-1*(IKEY-67) ELSE IF(IKEY.EQ.76) THEN CALL NBFIND(CARD(IPT:256),IPT,256,IPOS) IF(IPOS.EQ.0) THEN CALL FESTOP(200066) END IF CALL CMATCH(CARD(IPOS:256),IPOS,256,'ADD',3,IPOS2,1) IF(IPOS2.GT.0) THEN IX(NTRANS*12-9)=-9 ELSE CALL CMATCH(CARD(IPOS:256),IPOS,256,'SUBTRACT',8,IPOS2,1) IF(IPOS2.GT.0) THEN IX(NTRANS*12-9)=-10 ELSE CALL CMATCH(CARD(IPOS:256),IPOS,256,'MULTIPLY',8,IPOS2,1) IF(IPOS2.GT.0) THEN IX(NTRANS*12-9)=-11 ELSE CALL CMATCH(CARD(IPOS:256),IPOS,256,'DIVIDE',6,IPOS2,1) IF(IPOS2.GT.0) THEN IX(NTRANS*12-9)=-12 ELSE CALL FPSTOP(200066,IPOS) END IF END IF END IF END IF ELSE IF(IKEY.LE.80) THEN IX(NTRANS*12-9)=-1*(IKEY-64) ELSE IF(IKEY.LE.86) THEN IX(NTRANS*12-9)=-1*(IKEY-65) ELSE IF(IKEY.EQ.112) THEN IX(NTRANS*12-9)=-22 ELSE IF(IKEY.EQ.119) THEN IX(NTRANS*12-9)=-23 ELSE IF(IKEY.EQ.120) THEN IX(NTRANS*12-9)=-24 ELSE IF(IKEY.GE.123.AND.IKEY.LE.138) THEN IX(NTRANS*12-9)=98-IKEY ELSE IF(IKEY.EQ.139.OR.IKEY.EQ.140) THEN IX(NTRANS*12-9)=99-IKEY ELSE IF(IKEY.GE.141.AND.IKEY.LE.155) THEN IX(NTRANS*12-9)=100-IKEY ELSE IF(IKEY.GE.161.AND.IKEY.LE.164) THEN IX(NTRANS*12-9)=105-IKEY ELSE IF(IKEY.GE.165.AND.IKEY.LE.167) THEN IX(NTRANS*12-9)=-60 ELSE IF(IKEY.EQ.169) THEN IX(NTRANS*12-9)=-61 ELSE IF(IKEY.EQ.170) THEN IX(NTRANS*12-9)=-62 END IF C C For REPREAD, REPWRITE, etc., assign unit number here. C IF(IX(NTRANS*12-9).GE.-20.AND.IX(NTRANS*12-9).LE.-17) THEN IX(NTRANS*12-11)=NXPTI IX(NTRANS*12-2)=4 CALL ROOMI(4) IX(NXPTI-3)=1 IX(NXPTI-2)=0 IX(NXPTI-1)=0 IF(IX(NTRANS*12-9).EQ.-17) THEN ITYPEF(1)=0 ITYPEF(2)=1 CALL FNREAD(IPT,ITYPEF,IFILEF,2,IPOSSC) K=IFILEF(2) ELSE IF(IX(NTRANS*12-9).EQ.-18) THEN ITYPEF(1)=1 ITYPEF(2)=0 CALL FNREAD(IPT,ITYPEF,IFILEF,2,IPOSSC) K=IFILEF(1) ELSE IF(IX(NTRANS*12-9).EQ.-19) THEN ITYPEF(1)=0 ITYPEF(2)=2 CALL FNREAD(IPT,ITYPEF,IFILEF,2,IPOSSC) K=IFILEF(2) ELSE ITYPEF(1)=2 ITYPEF(2)=0 CALL FNREAD(IPT,ITYPEF,IFILEF,2,IPOSSC) K=IFILEF(1) END IF IF(IMERR1.GT.0) THEN CALL FSTOP END IF IX(IX(NTRANS*12-11))=K IF(K.EQ.0) THEN CALL FESTOP(200067) END IF C C VPLXAPPEND, VPLX APPEND, etc. C ELSE IF(IX(NTRANS*12-9).EQ.-60) THEN C C If first key word is VPLX, find APPEND C IF(IKEY.EQ.167) THEN IF(IPT.LE.0) THEN CALL NBFND2(IPT,IPOS) IF(IPOS.GT.0) THEN IPT=IPOS ELSE CALL FESTOP(200071) END IF END IF CALL CMATCH(CARD(IPT:256),IPT,256,'APPEND',6,IPOS,1) IF(IPOS.GT.0) THEN IPT=IPOS ELSE CALL FESTOP(200071) END IF END IF NLIST=0 ILISTX=0 IX(NTRANS*12-11)=NXPTI IX(NTRANS*12-2)=7 CALL ROOMI(7) IX(NXPTI-6)=1 IX(NXPTI-5)=0 IX(NXPTI-4)=0 ITYPEF(1)=2 ITYPEF(2)=0 CALL FNREAD(IPT,ITYPEF,IFILEF,2,IPOSSC) IF(IMERR1.GT.0) THEN CALL FSTOP END IF K=IFILEF(1) IX(IX(NTRANS*12-11))=K IF(K.EQ.0) THEN CALL FESTOP(200067) END IF CALL PREAMD(K) IX(NXPTI-3)=ANIDTT IX(NXPTI-2)=ATSIZE IX(NXPTI-1)=ANRPTT VTMPSZ=MVAR-SVTEMP+1 C C All other subroutines: C Starting position for integer constants given dummy value 1 and C number of integer constants set to 0. C ELSE IX(NTRANS*12-11)=1 IX(NTRANS*12-2)=0 END IF IF(NXTSTR.GT.0) THEN IX(NTRANS*12-10)=NXTSTR ELSE IX(NTRANS*12-10)=1 END IF IX(NTRANS*12-8)=0 IX(NTRANS*12-7)=0 IX(NTRANS*12-6)=0 IX(NTRANS*12-5)=0 IX(NTRANS*12-4)=0 IX(NTRANS*12-3)=0 IX(NTRANS*12-1)=NPASS+1 C C RPRINT, REPPRINT, allocate first string as working string. C IF(IKEY.EQ.80.OR.IKEY.EQ.81) THEN IX(NTRANS*12-3)=1 IX(NTRANS*12-10)=1 END IF C IF(IX(NTRANS*12-9).EQ.-60.AND.IPT.EQ.1) THEN C GO TO 2 C ELSE GO TO 1 C END IF C C COMPUTE C ELSE IF(IKEY.EQ.17) THEN C C write(*,*)u5,' ***' C CALL CRDPRN(1) C TSWTCH=1 CALL CMPAR1(IX,IPT) GO TO 1 END IF 90 CONTINUE ENDTRN=.TRUE. GO TO 77 C C Return to 77 to complete the processing of the last subroutine, C if any, before exiting the routine C END C SUBROUTINE CLFORM(IA,NSPTOT) C IMPLICIT DOUBLE PRECISION(A-H,O-Z) C INTEGER NSPTOT INTEGER IA(3,NSPTOT) C C Converts the specification in IA(3,*) into the class specifications C for the next block to be added during TRANSFORM. C C NSPTOT - dimension of IA(3,*) C IA(3,*) - specification of class cross-classification, provided C by CLSCAN. C PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT C INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 LOGICAL CLDONE C 100 FORMAT(' ERROR IN CLASS SPECIFICATION') CALL RINCR(8,NCLBLK,1) C C Until the end of the routine, work with NCLBR1, a temporary working C value of NCLBAR, the total number of class variables stored in C arrays defining blocks. C NCLBR1=NCLBAR C C BLCPNT points to the beginning of the block specification. C BLCPNT(NCLBLK)=NCLBR1+1 C C Initialize new blocks to not include a defined N. C BLTYPE(NCLBLK)=0 IS=1 10 CONTINUE N=IA(1,IS) CLDONE=.FALSE. DO 15 I=1,N IS=IS+1 C C If one or more classes have already been processed, check that C current class does not repeat an earlier class. C IF(NCLBR1.GE.BLCPNT(NCLBLK)) THEN DO 11 J=BLCPNT(NCLBLK),NCLBR1 IF(CLPNT(J).EQ.IA(1,IS)) THEN IS1=IS-1 IF(J.NE.NCLBR1) THEN CALL FESTOP(200101) ELSE IF(IA(2,IS1)+1.NE.IA(2,IS)) THEN CALL FESTOP(200102) ELSE IF(IA(3,IS1)+1.NE.IA(3,IS)) THEN CALL FESTOP(200103) C C CLTYPE has now already been defined in this case (code below). C Perform additional check that range conforms to (0-n) or (1-n) C rule. This check may be redundant, however, since CLSCAN C should have already checked that the class specification was within C range.? C ELSE IF(CLTYPE(NCLBR1).EQ.0) THEN IF(IA(3,IS).GT.MSIZE(CLPNT(NCLBR1))+1) THEN CALL FESTOP(200104) ELSE IF(IA(3,IS).EQ.MSIZE(CLPNT(NCLBR1))+1) THEN CLDONE=.TRUE. END IF ELSE IF(IA(3,IS).GT.MSIZE(CLPNT(NCLBR1))) THEN CALL FESTOP(200104) ELSE IF(IA(3,IS).EQ.MSIZE(CLPNT(NCLBR1))) THEN CLDONE=.TRUE. END IF END IF C C Transfer to 15 now skips processing to add a new class variable, C since only adding an additional level of a class. Further checks C are performed at 15. C GO TO 15 END IF 11 CONTINUE END IF C C The check based on CLDONE assures that no specifications of C class ranges are incomplete, e.g. sex (0-1) if sex is a class C variable with 2 levels. C IF(I.GT.1) THEN IF(CLDONE) THEN CLDONE=.FALSE. ELSE CALL FESTOP(200105) END IF END IF C C Add the class variable at this point. C IF(IA(1,IS).GT.0) THEN CALL RINCR(9,NCLBR1,1) CLPNT(NCLBR1)=IA(1,IS) C C CLTYPE = 0 margin present (nonsummable variables only) C = 1 no margin present C IF(IA(2,IS).EQ.0.AND.IA(3,IS).EQ.1) THEN CLTYPE(NCLBR1)=0 ELSE CLTYPE(NCLBR1)=1 C C If no range is present, set CLDONE to TRUE C IF(IA(2,IS).EQ.0.AND.IA(3,IS).EQ.0)CLDONE=.TRUE. END IF END IF 15 CONTINUE IF(N.GT.1.OR.IA(1,IS).NE.0) THEN IF(.NOT.CLDONE) THEN CALL FESTOP(200105) END IF END IF IS=IS+1 C C Loop if not in form of product (however, editing in TSET1 may C eliminate this case?) C IF(IS.LE.NSPTOT)GO TO 10 C C Calculation of number of class variables added. C BLNCLS(NCLBLK)=NCLBR1-NCLBAR C C Now make change to NCLBAR (in common block) C NCLBAR=NCLBR1 RETURN END C LOGICAL FUNCTION CLMTCH(ICLBL1,ICLBL2) C IMPLICIT DOUBLE PRECISION(A-H,O-Z) INTEGER ICLBL1,ICLBL2 C C Returns true if blocks ICLBL1 and ICLBL2 match identically (after C permutation), false otherwise. C PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C CLMTCH=.FALSE. IF(BLNCLS(ICLBL1).NE.BLNCLS(ICLBL2))GO TO 95 N=BLNCLS(ICLBL1) IF(N.EQ.0)GO TO 90 ICLBR1=BLCPNT(ICLBL1) ICLBR2=BLCPNT(ICLBL2) DO 20 I=1,N IV=CLPNT(ICLBR1+I-1) DO 10 J=1,N IF(CLPNT(ICLBR2+J-1).EQ.IV) THEN IF(CLTYPE(ICLBR1+I-1).EQ.CLTYPE(ICLBR2+J-1)) THEN GO TO 20 ELSE GO TO 95 END IF END IF 10 CONTINUE GO TO 95 20 CONTINUE 90 CONTINUE CLMTCH=.TRUE. 95 CONTINUE RETURN END C SUBROUTINE CLCHK3(ICLBLK,IV,IT,IA,NA) C C Subroutine to check the class specification used with C MODIFY variables C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C INTEGER ICLBLK,IV,IT,IA(3,*),NA C C ICLBLK - block number to be checked C IV - variable number (block number if N of block, redundantly) C IT - type - 9 for N of block C IA(3,*)- class specification (from CLSCAN) if any. May be dummy C matrix if no class specification C NA - second dimension of IA, but may be 0 if no class C specification C PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP LOGICAL DERIVD C 200 FORMAT(' NO COLLAPSING WITH MODIFY: ',A12) 201 FORMAT(' ERROR IN CLASS SPECIFICATION: ',A12) 202 FORMAT(' ERROR IN CLASS SPECIFICATION, BLOCK: ',I5) 203 FORMAT(' NO COLLAPSING WITH MODIFY, BLOCK: ',I5) C NIN=BLNCLS(ICLBLK) C C If the block has no class variables, then there should either be: C No class specification for the variable, or C A specification of "/CLASS TOTAL" C NOUT=0 C C Loop through specification to identify class variables C DERIVD distinguishes nonsummable variables. C DERIVD=.FALSE. IF(IT.NE.9) THEN IF(MTYPE(IV).GT.10)DERIVD=.TRUE. END IF IF(NA.GT.0) THEN K=1 7 CONTINUE N=IA(1,K) K=K+1 J=1 9 CONTINUE C C If the specification includes TOTAL, treat it simply as TOTAL C IF(IA(1,K).EQ.0) THEN NOUT=0 GO TO 20 ELSE NOUT=NOUT+1 IF(NIN.EQ.0) THEN IMERR1=200110 GO TO 98 END IF ICLBAR=BLCPNT(ICLBLK) DO 12 I=1,NIN IF(CLPNT(ICLBAR).EQ.IA(1,K))GO TO 13 ICLBAR=ICLBAR+1 12 CONTINUE IMERR1=200111 GO TO 98 13 CONTINUE C C Accept a margin only if the margin exists and the type of variable C is summable. C IF(IA(2,K).EQ.0.AND.IA(3,K).NE.0.AND. . (.NOT.DERIVD.OR.CLTYPE(ICLBAR).EQ.1)) THEN IF(.NOT.DERIVD) THEN IMERR1=200112 ELSE IMERR1=200113 END IF GO TO 97 END IF IF(J.LT.N) THEN K1=K+1 C C If the current variable appears again, check only to assure "+" C has not been used. C IF(IA(1,K1).EQ.IA(1,K)) THEN IF(IA(3,K).EQ.IA(3,K1)) THEN IMERR1=200114 GO TO 98 END IF K=K+1 J=J+1 GO TO 13 C C Else look ahead to ensure class variable does not appear a second C time. C ELSE DO 14 J1=J+1,N IF(IA(1,K1).EQ.IA(1,K)) THEN IMERR1=200115 GO TO 98 ELSE K1=K1+1 END IF 14 CONTINUE END IF END IF J=J+1 K=K+1 C C Loop back if not done with specification in IA(3,*) C IF(J.LE.N)GO TO 9 IF(K.LE.NA)GO TO 7 END IF END IF 20 CONTINUE C C Now perform checks to see that each class variable associated with C the block has been appropriately handled by the /CLASS specification. C IF(NIN.GT.0) THEN ICLBAR=BLCPNT(ICLBLK) DO 30 I=1,NIN IF(NOUT.GT.0) THEN K=1 23 CONTINUE N=IA(1,K) K=K+1 J=1 25 CONTINUE IF(IA(1,K).EQ.CLPNT(ICLBAR))GO TO 29 J=J+1 K=K+1 IF(J.LE.N)GO TO 25 IF(K.LE.NA)GO TO 23 END IF IF(.NOT.DERIVD.OR.CLTYPE(ICLBAR).EQ.1) THEN IF(.NOT.DERIVD) THEN IMERR1=200112 ELSE IMERR1=200113 END IF GO TO 97 END IF 29 CONTINUE ICLBAR=ICLBAR+1 30 CONTINUE END IF RETURN 97 CONTINUE IF(IT.NE.9) THEN WRITE(U6,200)VNAME(IV) ELSE WRITE(U6,203)IV END IF GO TO 99 98 CONTINUE IF(IT.NE.9) THEN WRITE(U6,201)VNAME(IV) ELSE WRITE(U6,202)IV END IF 99 CONTINUE CALL FSTOP END C SUBROUTINE PREAMD(IUNIT) C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C INTEGER IUNIT C PARAMETER (MSIZED=1000000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP,BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR, . BLVSIZ,BLNCLS,BLCPNT,CLTYPE,CLPNT,MTYPE,MSIZE,VMAPL,CROSSD, . CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C COMMON /VABLCK/AVERSN,ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT, . ATYPE,AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR,ANID,ANCRSS,ANCRVL, . AVNCRS,ANBYGR,ASDBID,ANRPTT,ASDCOF INTEGER AVERSN,ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT, . ATYPE,AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR,ANID,ANCRSS,ANCRVL, . AVNCRS,ANBYGR,ASDBID,ANRPTT,ASDCOF C LOGICAL ENDFLE C C All matrices from the file are read into the ends of the respective C allocated storage. Many pointer arrays are adjusted to the resulting C positions. C C Adjusted arrays: C BLCPNT - pointer for class information C CLPNT - pointer to class variables C CDMPNT - pointer to dimension information C LPOINT - pointer to level labels C C Unadjusted arrays, giving only relative positions: C BLXSTR - pointer to first cell of incoming data in X matrix C BLVSTR - pointer to first variable C VMAPL - pointer to starting location for variable C READ(IUNIT,END=99)AVERSN IF(AVERSN.NE.9004.AND.AVERSN.NE.9203) THEN CALL FESTOP(200120) END IF READ(IUNIT,END=99)ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT,ATYPE, . AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR CALL RCHECK(2,NVTOT,ANVTOT) ANID=ANVRID+ANBY IF(AVERSN.EQ.9004)ANIDTT=ANID C C ANVTOT - total number of variables on file C ANVREG - number of variables, excluding class, variance id's, C BY variables, and weight variable C ANCLSS - total number of class variables C ANVRID - number of variance id's, excluding BY variables C ANBY - number of BY variables C ANWGT - 0 or 1 indicating unweighted vs. weighted analysis C ATYPE - type of input used to create the file C AVROPT - variance option C ATSIZE - total size of matrix C ANCLBL - total number of class blocks C ANCLBR - total size of class block information arrays C C ATYPE= 3 Weighted obs. with cluster/replicate number C 4 Unweighted " C 5 Replicate weights C 6 Unweighted initial obs. followed by replicate weights C 7 Replicate factors multiplying initial weight C 8 Replicate factors of unweighted initial obs ( = VFTYPE 6) C 11 Replicate factors multiplying initial weight, including C factor for replicate 0, overall estimate C 12 Unweighted initial obs " (= VFTYPE 5) C 13 Weighted obs. with cluster code C 14 Unweighted " C 15 Weighted obs. Stratum no. cluster code C 16 Unweighted " C 17 Wtd. Stratum code, cluster code C 18 Unwtd " C 21 Wtd. Stratum no. 2nd stage no, cluster code C 22 Unwtd. " C 23 Wtd. Stratum no. 2nd stage cd, cluster code C 24 Unwtd. " C 25 Wtd. Stratum code 2nd stage no. cluster code C 26 Unwtd " C 27 Wtd. Stratum code 2nd stage cd, cluster code C 28 Unwtd. " C 29 Wtd 2nd stage number cluster code C 30 Unwtd. " C 31 Wtd 2nd stage code cluster code C 32 Unwtd " C 33 Wtd Replicate number governed by stratum counts C 34 Unwtd " C 35 Wtd Rep numb govrned by stratum and 2nd stage counts C 36 Unwtd " C 37 Wtd Rep number governed by 2nd stage counts C 38 Unwtd " C CALL RCHECK(8,NCLBLK,ANCLBL) CALL RCHECK(9,NCLBAR,ANCLBR) I=RCEIL(8)-ANCLBL+1 DO 1 J=1,ANCLBL READ(IUNIT,END=99)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I), . BLVSTR(I),BLVSIZ(I),BLNCLS(I),BLCPNT(I) IF(BLCPNT(I).GT.0) THEN BLCPNT(I)=BLCPNT(I)+RCEIL(9)-ANCLBR END IF I=I+1 1 CONTINUE C C Note that on input, CLPNT points to the relative positions of the C CLASS variables wrt the appended VPLX file. C IF(ANCLBR.GT.0) THEN I=RCEIL(9)-ANCLBR+1 CALL INTIN(IUNIT,CLTYPE(I),ANCLBR,ENDFLE) IF(ENDFLE) GO TO 99 CALL INTIN(IUNIT,CLPNT(I),ANCLBR,ENDFLE) C C Adjust CLPNT to point to actual positions of class variables. C DO 2 J=1,ANCLBR CLPNT(I)=CLPNT(I)+RCEIL(2)-ANVTOT I=I+1 2 CONTINUE C IF(ENDFLE) GO TO 99 END IF C C BLTYPE - 1 or 0 indicating row of (weighted) n vs. no row C BLXSTR - pointer to first cell of incoming data in X matrix C BLXINC - length of the X matrix for a single combination C of the class variables in the block C BLXSIZ - total size of block data in X matrix (integer multiple C of BLXINC) (TRANSFORM step uses differently) C BLVSTR - pointer to first variable C BLVSIZ - number of variables in block C BLNCLS - number of class variables in block C BLCPNT - pointer for class information C CLTYPE - type of class in array C CLPNT - pointer to class variables C I=RCEIL(2)-ANVTOT+1 IF(ANVTOT.GT.0) THEN CALL INTIN(IUNIT,MTYPE(I),ANVTOT,ENDFLE) IF(ENDFLE)GO TO 99 C C Variable types are read into MTYPE C C Contents of MTYPE C 1 = real variable (total) C 2 = real variable with missing checks C 3 = categorical variable C 4 = class variable, known dimension C 5 = by variable, known dimension C 6 = by variable, unknown dimension C 7 = select transformation (not variable type) C 8 = cross variable, real value C 9 = cross variable, categorical C 11 = derived variable C 13 = crossed derived variable, single dimension C 19 = crossed derived variable C C C Sizes are read into MSIZE C CALL INTIN(IUNIT,MSIZE(I),ANVTOT,ENDFLE) IF(ENDFLE)GO TO 99 END IF C C VMAPL contains pointers to the first ANVREG variables C These are relative positions; absolute positions not determined C here. C IF(ANVREG.GT.0) THEN CALL INTIN(IUNIT,VMAPL(I),ANVREG,ENDFLE) IF(ENDFLE)GO TO 99 END IF C READ(IUNIT,END=99)ANCRSS CALL RCHECK(10,NCRSSD,ANCRSS) ILC=RCEIL(10)-ANCRSS+1 IF(ANCRSS.GT.0) THEN CALL INTIN(IUNIT,CROSSD(ILC),ANCRSS,ENDFLE) IF(ENDFLE)GO TO 99 END IF C C Create an array of pointers, CDMPNT, from the variables to C the starting entries in CROSSD. These will point to actual, not C relative positions. C I=RCEIL(2)-ANVTOT+1 DO 3 II=1,ANVTOT J=MTYPE(I) IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN CDMPNT(I)=ILC ILC=CROSSD(ILC)+ILC+2 ELSE CDMPNT(I)=0 END IF I=I+1 3 CONTINUE C IF(RCEIL(10)+1.NE.ILC) THEN CALL FESTOP(200122) END IF ILC=0 C C Read variable names and labels, and create an array of pointers, C LPOINT, to labels for the levels of the variables. In this loop C store relative positions in LPOINT. C I=RCEIL(2)-ANVTOT+1 DO 6 II=1,ANVTOT READ(IUNIT,END=99)VNAME(I),LABEL(I) J=MTYPE(I) IF(J.EQ.3.OR.J.EQ.4.OR.J.EQ.5.OR.J.EQ.13) THEN LPOINT(I)=ILC+1 ILC=ILC+MSIZE(I) ELSE IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN LPOINT(I)=ILC+1 K=CDMPNT(I) L=CROSSD(K) DO 4 M=1,L K=K+1 ILC=ILC+CROSSD(K)+1 4 CONTINUE ELSE LPOINT(I)=0 END IF I=I+1 6 CONTINUE C C Read in labels for the levels C READ(IUNIT,END=99)ANCRVL CALL RCHECK(7,NCRVL,ANCRVL) IF(ILC.NE.ANCRVL) THEN CALL FESTOP(200122) END IF II=RCEIL(7)-ILC IF(ILC.GT.0) THEN C C This loop adjusts LPOINT to point to actual locations C DO 8 I=RCEIL(2)-ANVTOT+1,RCEIL(2) IF(LPOINT(I).GT.0)LPOINT(I)=LPOINT(I)+II 8 CONTINUE DO 10 I=II+1,RCEIL(7) READ(IUNIT,END=99)LEVEL(I) 10 CONTINUE END IF C READ(IUNIT,END=99)AVNCRS C C Read in variable names for crossed variables C CALL RCHECK(13,SVTEMP,AVNCRS) II=RCEIL(13)-AVNCRS IF(AVNCRS.GT.0) THEN DO 12 I=1,AVNCRS READ(IUNIT,END=99)VTEMP(II+I) 12 CONTINUE C C Adjust pointers in CROSSD C I=RCEIL(2)-ANVTOT+1 DO 14 K=1,ANVTOT J=MTYPE(I) IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN M=CDMPNT(I) M=CROSSD(M)+M+1 CROSSD(M)=CROSSD(M)+II END IF I=I+1 14 CONTINUE END IF IF(ANBY.GE.1) THEN READ(IUNIT,END=99)ANBYGR ASDBID=NXPTD K=ANBYGR*ANBY CALL ROOMD(K) K=ASDBID-1 DO 17 I=1,ANBYGR READ(IUNIT,END=99)(DX(K+J),J=1,ANBY) K=K+ANBY 17 CONTINUE ELSE ASDBID=0 ANBYGR=1 END IF READ(IUNIT,END=99)ANRPTT IF(ANRPTT.GT.0) THEN ASDCOF=NXPTD CALL ROOMD(ANRPTT) CALL UNFIN(IUNIT,DX(ASDCOF),ANRPTT,ENDFLE) IF(ENDFLE)GO TO 99 ELSE ASDCOF=0 END IF RETURN 99 CONTINUE CALL FESTOP(200121) END C SUBROUTINE VAPSET(ILIST,NLIST,NPASS) C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C INTEGER ILIST(*),NLIST C PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (MAXFMT=20) C PARAMETER (MTRANS=1500,MRANGS=20) PARAMETER (MTRSZI=MSIZEI+6*MRANGE-6*MRANGS+2*MRNSET+MRECOD+MVAR) PARAMETER (IXFLLD=57+3*MAXIDS) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP,BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR, . BLVSIZ,BLNCLS,BLCPNT,CLTYPE,CLPNT,MTYPE,MSIZE,VMAPL,CROSSD, . CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C COMMON /VABLCK/AVERSN,ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT, . ATYPE,AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR,ANID,ANCRSS,ANCRVL, . AVNCRS,ANBYGR,ASDBID,ANRPTT,ASDCOF INTEGER AVERSN,ANVTOT,ANVREG,ANCLSS,ANVRID,ANBY,ANWGT, . ATYPE,AVROPT,ANIDTT,ATSIZE,ANCLBL,ANCLBR,ANID,ANCRSS,ANCRVL, . AVNCRS,ANBYGR,ASDBID,ANRPTT,ASDCOF C INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID, . SDWRK,VKEEPF,IXFILL(IXFLLD) COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT, . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF, . IXFILL C COMMON /STMBLK/IX,RANGE,RGROUP,RTYPE,RSTPNT,V1,V2,V3,MXSIZE, . IOUT,IOUTL DOUBLE PRECISION RANGE(2,MRANGS) INTEGER IX(MTRSZI),RGROUP(MRANGS),RTYPE(MRANGS),RSTPNT(MRECOD), . V1(MRECOD),V2(MRECOD),V3(MRECOD),MXSIZE(MVAR),IOUT(MVAR), . IOUTL(MVAR) C 100 FORMAT(/,' Integration of blocks from appended file:',//, . ' Block in Internal',/, . ' appended file block') 101 FORMAT(1X,I7,8X,I7) 201 FORMAT(' CONFLICT - with variable ',A12) C C All matrices from the file are read into the ends of the respective C allocated storage. Many pointer arrays are adjusted to the resulting C positions. C C Adjusted arrays: C BLCPNT - pointer for class information C CLPNT - pointer to class variables C CDMPNT - pointer to dimension information C LPOINT - pointer to level labels C C Unadjusted arrays, giving only relative positions: C BLXSTR - pointer to first cell of incoming data in X matrix C BLVSTR - pointer to first variable C VMAPL - pointer to starting location for variable C C C ANVTOT - total number of variables on file C ANVREG - number of variables, excluding class, variance id's, C BY variables, and weight variable C ANCLSS - total number of class variables C ANVRID - number of variance id's, excluding BY variables C ANBY - number of BY variables C ANWGT - 0 or 1 indicating unweighted vs. weighted analysis C ATYPE - type of input used to create the file C AVROPT - variance option C ATSIZE - total size of matrix C ANCLBL - total number of class blocks C ANCLBR - total size of class block information arrays C IF(U5ECHO.GT.0)WRITE(U6,100) ICLBLK=RCEIL(8)-ANCLBL+1 C C Create matrix of starting positions and increments first. C Save NPASSV to find out how many new variables are created, C including N of block but excluding classes. C NPASSV=NPASS NXPTIS=NXPTI DO 50 IBLK=1,ANCLBL C C For NLIST > 0, include the block if listed in the EXTRACT statement C or if one or more of its associated variables is included. C IF(NLIST.GT.0) THEN IF(BLVSIZ(ICLBLK).GT.0) THEN ILOW=BLVSTR(ICLBLK) IHIGH=ILOW+BLVSIZ(ICLBLK)-1 ELSE ILOW=0 IHIGH=0 END IF DO 12 I=1,NLIST IF(ILIST(I).EQ.-IBLK.OR. . (ILIST(I).GE.ILOW.AND.ILIST(I).LE.IHIGH)) THEN GO TO 14 END IF 12 CONTINUE C C If arrive here, do not include the block C GO TO 49 14 CONTINUE END IF C C Inclusion of block C NCLBLK may be safely incremented here; adequate storage is available. C Similarly, NCLBAR is adequate because of previous checks. C NCLBLK=NCLBLK+1 BLNCLS(NCLBLK)=BLNCLS(ICLBLK) BLTYPE(NCLBLK)=BLTYPE(ICLBLK) BLCPNT(NCLBLK)=NCLBAR+1 WRITE(U6,101)IBLK,NCLBLK C C Just in case, reset BLXSIZ to 1 as a flag indicating that block C should be retained. C BLXSIZ(NCLBLK)=1 C C Transfer of N of the block C IF(BLTYPE(ICLBLK).EQ.1) THEN CALL RINCR(4,NPASS,1) V1(NPASS)=NCLBLK V2(NPASS)=9 RSTPNT(NPASS)=1 CALL ROOMI(3) IF(NXPTI+NLIST-1.GT.MTRSZI) THEN CALL ROOMI(NLIST) END IF IX(NXPTI-3)=BLXSTR(ICLBLK) IX(NXPTI-2)=BLXINC(ICLBLK) IX(NTRANS*12-2)=IX(NTRANS*12-2)+3 END IF C C Set up of class variables for block. Add class variables, as C necessary. C IF(BLNCLS(ICLBLK).GT.0) THEN DO 20 ICLBAR=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1 C C Space to increment NCLBAR has already been confirmed. C NCLBAR=NCLBAR+1 K=CLPNT(ICLBAR) CLTYPE(NCLBAR)=CLTYPE(ICLBAR) CALL VNMTCH(VNAME(K),VNAME,NVIN,J) C C If find matching variable in first NVIN, confirm attributes. C IF(J.GT.0) THEN IF(MTYPE(J).NE.4) THEN WRITE(U6,201)VNAME(J) CALL FESTOP(200130) ELSE IF(MSIZE(J).NE.MSIZE(K)) THEN WRITE(U6,201)VNAME(J) CALL FESTOP(200131) END IF CLPNT(NCLBAR)=J c write(6,*)nclblk,nclbar,blcpnt(nclblk),clpnt(nclbar) C C If the class variable does not match, add it as a new variable C ELSE NVIN=NVIN+1 IF(NVIN+ANVTOT.GT.MVAR) THEN CALL RCHECK(2,NVIN,ANVTOT) END IF VNAME(NVIN)=VNAME(K) MTYPE(NVIN)=MTYPE(K) MSIZE(NVIN)=MSIZE(K) LABEL(NVIN)=LABEL(K) MXSIZE(NVIN)=0 CDMPNT(NVIN)=0 L=LPOINT(K) LPOINT(NVIN)=NCRVL+1 DO 16 I=1,MSIZE(K) CALL RINCR(7,NCRVL,1) CALL RCHECK(7,NCRVL,ANCRVL) LEVEL(NCRVL)=LEVEL(L) L=L+1 16 CONTINUE c write(6,*)nvin,nclblk,nclbar,blcpnt(nclblk),clpnt(nclbar) CLPNT(NCLBAR)=NVIN END IF 20 CONTINUE END IF C C Search for variables to add. C IF(BLVSIZ(ICLBLK).GT.0) THEN DO 40 IVIN=BLVSTR(ICLBLK),BLVSTR(ICLBLK)+BLVSIZ(ICLBLK)-1 IF(NLIST.GT.0) THEN DO 22 I=1,NLIST IF(ILIST(I).EQ.IVIN)GO TO 24 22 CONTINUE GO TO 40 24 CONTINUE END IF K=RCEIL(2)-ANVTOT+IVIN NVIN=NVIN+1 IF(NVIN+ANVTOT.GT.MVAR) THEN CALL RCHECK(2,NVIN,ANVTOT) END IF VNAME(NVIN)=VNAME(K) MTYPE(NVIN)=MTYPE(K) MSIZE(NVIN)=MSIZE(K) LABEL(NVIN)=LABEL(K) MXSIZE(NVIN)=NCLBLK C C RSTPNT holds the size of the variable, after transformation, but C before considering effects of classes. In this case, this is always C the size of the variable. C CALL RINCR(4,NPASS,1) RSTPNT(NPASS)=MSIZE(K) V1(NPASS)=NVIN V2(NPASS)=0 CALL ROOMI(3) IF(NXPTI+NLIST-1.GT.MTRSZI) THEN CALL ROOMI(NLIST) END IF IX(NXPTI-3)=VMAPL(K) IX(NXPTI-2)=BLXINC(ICLBLK) IX(NTRANS*12-2)=IX(NTRANS*12-2)+3 ITYPE=MTYPE(NVIN) IF(ITYPE.EQ.3.OR.ITYPE.EQ.13) THEN LPOINT(NVIN)=NCRVL+1 L=LPOINT(K) DO 26 I=1,MSIZE(K) CALL RINCR(7,NCRVL,1) CALL RCHECK(7,NCRVL,ANCRVL) LEVEL(NCRVL)=LEVEL(L) L=L+1 26 CONTINUE CDMPNT(NVIN)=0 ELSE IF(ITYPE.EQ.8.OR.ITYPE.EQ.9.OR.ITYPE.EQ.19) THEN LPOINT(NVIN)=NCRVL+1 CDMPNT(NVIN)=NCRSSD+1 II=CDMPNT(K) L=LPOINT(K) DO 30 I=II,II+CROSSD(II) CALL RINCR(10,NCRSSD,1) CALL RCHECK(10,NCRSSD,ANCRSS) CROSSD(NCRSSD)=CROSSD(I) IF(I.GT.II) THEN DO 28 J=1,CROSSD(I)+1 CALL RINCR(7,NCRVL,1) CALL RCHECK(7,NCRVL,ANCRVL) LEVEL(NCRVL)=LEVEL(L) L=L+1 28 CONTINUE END IF 30 CONTINUE IJ=II+CROSSD(II)+1 IJ=CROSSD(IJ) CALL RINCR(10,NCRSSD,1) CALL RCHECK(10,NCRSSD,ANCRSS) CROSSD(NCRSSD)=SVTEMP+1 DO 32 I=IJ,IJ+CROSSD(II)-1 CALL RINCR(13,SVTEMP,1) VTEMP(SVTEMP)=VTEMP(I) 32 CONTINUE ELSE LPOINT(NVIN)=0 CDMPNT(NVIN)=0 END IF 40 CONTINUE END IF C C Set BLXINC now to 1, since this is done elsewhere in the TRANSFORM C step for added blocks. C BLXINC(NCLBLK)=1 C 49 CONTINUE ICLBLK=ICLBLK+1 50 CONTINUE IX(NTRANS*12-6)=NPASS-NPASSV C ICLSS=NXPTI C C Now set up pointers in ICLSS C LASTBL=0 II=NXPTIS DO 70 IPASS=NPASSV+1,NPASS IF(V2(IPASS).EQ.9) THEN ICLBLK=V1(IPASS) ELSE IV=V1(IPASS) ICLBLK=MXSIZE(IV) END IF c write(6,*)iclblk,blcpnt(iclblk),blncls(iclblk) IF(ICLBLK.EQ.LASTBL) THEN V3(IPASS)=V3(IPASS-1) IX(II+2)=ISIZE GO TO 69 ELSE LASTBL=ICLBLK END IF ISIZE=1 IF(BLNCLS(ICLBLK).GT.0) THEN ICLSSV=ICLSS K=ICLSSV+5 CALL ROOMI(5) DO 60 ICLBAR=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1 L=CLPNT(ICLBAR) IF(CLTYPE(ICLBAR).EQ.0) THEN ISIZE=ISIZE*(MSIZE(L)+1) DO 52 I=0,MSIZE(L) CALL ROOMI(3) IX(K)=L IX(K+1)=I IX(K+2)=I+1 K=K+3 52 CONTINUE ELSE ISIZE=ISIZE*MSIZE(L) CALL ROOMI(3) IX(K)=L IX(K+1)=0 IX(K+2)=0 K=K+3 END IF 60 CONTINUE ICLSS=K IX(ICLSSV+1)=ISIZE IX(ICLSSV)=(ICLSS-ICLSSV)/3-1 IX(ICLSSV+2)=IX(ICLSSV) IX(ICLSSV+3)=0 IX(ICLSSV+4)=0 V3(IPASS)=ICLSSV c c write(6,*)iclssv,(ix(i),i=iclssv,iclss-1) c ELSE V3(IPASS)=0 END IF IX(II+2)=ISIZE 69 CONTINUE II=II+3 70 CONTINUE RETURN END C C End of T1.FOR CC C Start of T2.FOR - Initial file setup and start of execution for C TRANSFORM step. C SUBROUTINE TCREA1 C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) C PARAMETER (MTRANS=1500,MRANGS=20) PARAMETER (MTRSZI=MSIZEI+6*MRANGE-6*MRANGS+2*MRNSET+MRECOD+MVAR) PARAMETER (IXFLLD=57+3*MAXIDS) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT C INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C COMMON /STMBLK/IX,RANGE,RGROUP,RTYPE,RSTPNT,V1,V2,V3,MXSIZE, . IOUT,IOUTL DOUBLE PRECISION RANGE(2,MRANGS) INTEGER IX(MTRSZI),RGROUP(MRANGS),RTYPE(MRANGS),RSTPNT(MRECOD), . V1(MRECOD),V2(MRECOD),V3(MRECOD),MXSIZE(MVAR),IOUT(MVAR), . IOUTL(MVAR) C C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL C LOGICAL REFRSH,ALPCHK,DGTCHK EXTERNAL REFRSH,ALPCHK,DGTCHK C INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID, . SDWRK,VKEEPF,IXFILL(IXFLLD) COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT, . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF, . IXFILL C INTEGER SIDMPT,SIDXPT,SIMSIZ,SIMTYP,SIDIM C 106 FORMAT(/,15X,'Reduction in Blocks',/,16X,'Old Retained as') 107 FORMAT(/,15X,I4,7X,I4) 205 FORMAT(' UNRECOGNIZED VARIABLE NAME ',A12) C C Edit VNKEEP for unrecognized names C IF(NKEEP.GT.0) THEN DO 1 I=1,NKEEP CALL VNMTCH(VNKEEP(I),VNAME,NVIN,J) IF(J.EQ.0) THEN WRITE(U6,205)VNKEEP(I) CALL FESTOP(200300) END IF 1 CONTINUE END IF C C IOUT - stores internal order of variables wrt outgoing order C IOUTL - stores variable order on outgoing file wrt internal order C IOUTC - index of outgoing variable C ILOC - computed position in output VPLX file C NCLBL2 - index of outgoing block C NCLBR2 - index of outgoing associated classes C SICLBK - starting location for pointers to original blocks, wrt C blocks on outgoing file C SIXINC - starting location for lengths of X vector for each C block, including N of block, if present C SICMUL - starting location for multipliers showing effect of C classes on total block size C SIXSTR - starting location for starting positions of each block C to be written to outgoing file. C SIVMAP - starting location for storage in outgoing VPLX file, C for outgoing variables C DO 75 I=1,NVIN IOUTL(I)=0 75 CONTINUE IOUTC=0 ILOC=1 NCLBL2=0 NCLBR2=0 SICLBK=NXPTI SIXINC=NXPTI+NCLBLK SICMUL=SIXINC+NCLBLK SIXSTR=SICMUL+NCLBLK K=4*NCLBLK CALL ROOMI(K) SIVMAP=NXPTI CALL ROOMI(NVIN) C C Loop over blocks, computing ICSIZE - multiplier from class variables C to be stored starting at SICMUL C DO 6 ICLBLK=1,NCLBLK ILOCSV=ILOC ICSIZE=1 IF(BLNCLS(ICLBLK).GE.1) THEN DO 2 I=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1 IF(CLTYPE(I).EQ.0) THEN ICSIZE=ICSIZE*(MSIZE(CLPNT(I))+1) ELSE ICSIZE=ICSIZE*(MSIZE(CLPNT(I))) END IF 2 CONTINUE END IF IX(SICMUL+ICLBLK-1)=ICSIZE C C Check for reduction in blocks C IF(BLXSIZ(ICLBLK).EQ.0)GO TO 5 C C Save space for N of block C IF(BLTYPE(ICLBLK).EQ.1)ILOC=ILOC+1 C C If KEEP statement, select variables in block on basis of block C number stored in MXSIZE by TSET1 C IF(NKEEP.GT.0.AND.VKEEPF.EQ.1) THEN DO 3 I=1,NKEEP CALL VNMTCH(VNKEEP(I),VNAME,NVIN,J) IF((J.LE.NVREG.OR.J.GT.NVTOT).AND.MTYPE(J).NE.4) THEN IF(MXSIZE(J).EQ.ICLBLK) THEN IX(SIVMAP+IOUTC)=ILOC IOUTC=IOUTC+1 IOUT(IOUTC)=J IOUTL(J)=IOUTC ILOC=ILOC+MSIZE(J) END IF END IF 3 CONTINUE C C Treatment of DROP and instances without either KEEP or DROP C ELSE DO 4 I=1,NVIN IF(MTYPE(I).EQ.4)GO TO 4 IF(I.LE.NVREG.OR.I.GT.NVTOT) THEN IF(NKEEP.GT.0) THEN CALL VNMTCH(VNAME(I),VNKEEP,NKEEP,J) IF(J.GT.0)GO TO 4 END IF IF(MXSIZE(I).EQ.ICLBLK) THEN IX(SIVMAP+IOUTC)=ILOC IOUTC=IOUTC+1 IOUT(IOUTC)=I IOUTL(I)=IOUTC ILOC=ILOC+MSIZE(I) END IF END IF 4 CONTINUE END IF C C Whether or not any variables from block on output, compute C position of internal storage C 5 CONTINUE IX(SIXINC+ICLBLK-1)=ILOC-ILOCSV C C Adjust ILOC for effect of class variables C ILOC=ILOC+(ICSIZE-1)*(ILOC-ILOCSV) C C If any part of the block is saved, save associated classes C IF(ILOC.GT.ILOCSV) THEN NCLBR2=NCLBR2+BLNCLS(ICLBLK) IX(SICLBK+NCLBL2)=ICLBLK NCLBL2=NCLBL2+1 END IF 6 CONTINUE C C Display for reduction in blocks C IF(NCLBL2.LT.NCLBLK.AND.U5ECHO.GT.0) THEN WRITE(U6,106) DO 7 I=1,NCLBL2 WRITE(U6,107)IX(SICLBK+I-1),I 7 CONTINUE END IF C C IOUTC3 - saves number of outgoing regular variables (excluding C class variables C NC - count of class variables on outgoing file. C IOUTC3=IOUTC NC=0 C C Identify class variables on output file C DO 12 I=1,NVIN IF(MTYPE(I).NE.4)GO TO 12 C C ICLBL2 loops over outgoing blocks. C DO 9 ICLBL2=1,NCLBL2 C C ICLBLK picks up corresponding internal block number C ICLBLK=IX(SICLBK+ICLBL2-1) IF(BLNCLS(ICLBLK).GT.0) THEN DO 8 I2=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1 IF(CLPNT(I2).EQ.I) THEN C C Inclusion of class variable on outgoing file. C NC=NC+1 IOUTC=IOUTC+1 IOUT(IOUTC)=I IOUTL(I)=IOUTC C C Once class variable is stored, end search over blocks. C GO TO 12 END IF 8 CONTINUE END IF 9 CONTINUE C C If the class variable is not used on any outgoing block, exclude C it from the outgoing file. C 12 CONTINUE C C IOUTC4 - saves total outgoing variables, including class variables C IOUTC4=IOUTC C C Continue to carry BY variables, weight variables, etc. C IF(NVARID+NBY+NWGT.GT.0) THEN DO 13 I=NVREG+NCLASS+1,NVTOT IOUTC=IOUTC+1 IOUT(IOUTC)=I 13 CONTINUE END IF C C IOUTSZ - total size of outgoing file C IOUTSZ=ILOC-1 C C Begin to write outgoing file here C WRITE(11)IVERSN WRITE(11)IOUTC,IOUTC3,NC,NVARID,NBY,NWGT,VFTYPE, . VROPTN,NIDTOT,IOUTSZ,NCLBL2,NCLBR2 C C IXST - for outgoing file, pointer to starting position of C block in X matrix. C IXST=1 IVS=1 J=1 IBLPNT=1 C C Assemble information on each outgoing block. There is an apparent C recalculation of information previously determined and stored C starting at SICMUL ? in loop to 15 C DO 17 ICLBL2=1,NCLBL2 C C ICLBLK picks up corresponding internal block number C ICLBLK=IX(SICLBK+ICLBL2-1) IXINC=0 IV=0 IF(BLTYPE(ICLBLK).EQ.1)IXINC=1 14 CONTINUE IF(J.LE.IOUTC3) THEN IF(MXSIZE(IOUT(J)).EQ.ICLBLK) THEN IXINC=IXINC+MSIZE(IOUT(J)) IV=IV+1 J=J+1 GO TO 14 END IF END IF IXSIZ=IXINC IF(BLNCLS(ICLBLK).GT.0) THEN DO 15 I=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1 IF(CLTYPE(I).EQ.0) THEN IXSIZ=IXSIZ*(MSIZE(CLPNT(I))+1) ELSE IXSIZ=IXSIZ*(MSIZE(CLPNT(I))) END IF 15 CONTINUE END IF WRITE(11)BLTYPE(ICLBLK),IXST,IXINC,IXSIZ,IVS,IV, . BLNCLS(ICLBLK),IBLPNT IX(SIXSTR+ICLBLK-1)=IXST IXST=IXST+IXSIZ IXINC=0 IVS=IVS+IV IV=0 IBLPNT=IBLPNT+BLNCLS(ICLBLK) 17 CONTINUE C C Class information for outgoing blocks C IF(NCLBR2.GT.0) THEN NXPTIS=NXPTI CALL ROOMI(NCLBR2) C C Loop to collect CLTYPE (presence of margin) C ICLBAR=0 DO 20 ICLBL2=1,NCLBL2 ICLBLK=IX(SICLBK+ICLBL2-1) IF(BLNCLS(ICLBLK).GT.0) THEN DO 18 I=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1 IX(NXPTIS+ICLBAR)=CLTYPE(I) ICLBAR=ICLBAR+1 18 CONTINUE END IF 20 CONTINUE CALL INTOUT(11,IX(NXPTIS),ICLBAR) C C Loop to construct pointers to class variables C ICLBAR=0 DO 22 ICLBL2=1,NCLBL2 ICLBLK=IX(SICLBK+ICLBL2-1) IF(BLNCLS(ICLBLK).GT.0) THEN DO 21 I=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1 IX(NXPTIS+ICLBAR)=IOUTL(CLPNT(I)) ICLBAR=ICLBAR+1 21 CONTINUE END IF 22 CONTINUE CALL INTOUT(11,IX(NXPTIS),ICLBAR) NXPTI=NXPTIS END IF C C Information on outgoing variables C IF(IOUTC.GT.0) THEN NXPTIS=NXPTI CALL ROOMI(IOUTC) C C Loop to collect variable types C IC=0 DO 24 I=1,IOUTC IX(NXPTIS+IC)=MTYPE(IOUT(I)) IC=IC+1 24 CONTINUE CALL INTOUT(11,IX(NXPTIS),IOUTC) C C Loop to collect variable sizes C IC=0 DO 26 I=1,IOUTC IX(NXPTIS+IC)=MSIZE(IOUT(I)) IC=IC+1 26 CONTINUE CALL INTOUT(11,IX(NXPTIS),IOUTC) NXPTI=NXPTIS END IF C C If any regular variables, output pointers to starting locations C IF(IOUTC3.GT.0) THEN CALL INTOUT(11,IX(SIVMAP),IOUTC3) END IF C C Dimensions of crossed variables. C ILC=0 IVC=0 DO 30 I=1,IOUTC3 J=MTYPE(IOUT(I)) IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN K=CDMPNT(IOUT(I)) L=CROSSD(K) IF(NXPTI+ILC+L.GT.MTRSZI) THEN L=L+ILC+2 CALL ROOMI(L) END IF IX(NXPTI+ILC)=L ILC=ILC+1 DO 28 M=1,L K=K+1 IX(NXPTI+ILC)=CROSSD(K) ILC=ILC+1 28 CONTINUE IX(NXPTI+ILC)=IVC+1 ILC=ILC+1 IVC=IVC+L END IF 30 CONTINUE WRITE(11)ILC IF(ILC.GT.0)CALL INTOUT(11,IX(NXPTI),ILC) C ILC=0 C C Output variable names and labels, and compute total number of output C levels, ILC C DO 33 I=1,IOUTC J=MTYPE(IOUT(I)) WRITE(11)VNAME(IOUT(I)),LABEL(IOUT(I)) IF(J.EQ.3.OR.J.EQ.4.OR.J.EQ.5.OR.J.EQ.13) THEN ILC=ILC+MSIZE(IOUT(I)) ELSE IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN K=CDMPNT(IOUT(I)) L=CROSSD(K) DO 32 M=1,L K=K+1 ILC=ILC+CROSSD(K)+1 32 CONTINUE END IF 33 CONTINUE WRITE(11)ILC C C Output level labels here. C DO 38 I=1,IOUTC J=MTYPE(IOUT(I)) IF(J.EQ.3.OR.J.EQ.4.OR.J.EQ.5.OR.J.EQ.13) THEN ILC=MSIZE(IOUT(I)) ELSE IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN K=CDMPNT(IOUT(I)) L=CROSSD(K) ILC=0 DO 36 M=1,L K=K+1 ILC=ILC+CROSSD(K)+1 36 CONTINUE ELSE GO TO 38 END IF L=LPOINT(IOUT(I)) DO 37 J=1,ILC WRITE(11)LEVEL(L) L=L+1 37 CONTINUE 38 CONTINUE C C IVC is number of associated variable names for crossed variables C WRITE(11)IVC C C Output crossed variable names. C DO 42 I=1,IOUTC J=MTYPE(IOUT(I)) IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN K=CDMPNT(IOUT(I)) L=CROSSD(K) K2=CROSSD(K+L+1) DO 41 M=1,L WRITE(11)VTEMP(K2) K2=K2+1 41 CONTINUE END IF 42 CONTINUE C C Output information on BY variables. C IF(NBY.GE.1) THEN WRITE(11)NBYGRP K=SDBYID-1 DO 44 I=1,NBYGRP WRITE(11)(DX(K+J),J=1,NBY) K=K+NBY 44 CONTINUE END IF C C Information on replicates C WRITE(11)NRPTOT IF(NRPTOT.GT.0) THEN CALL UNFOUT(11,DX(SDCOEF),NRPTOT) END IF C C From here to the end of the routine, determine use of double C precision array. C C Move any CONSTANTS to follow incoming matrix. C IF(NXPTD.GT.SDCONS) THEN IF(SDCONS.GT.TSIZE+1) THEN K=TSIZE+1 DO 45 I=SDCONS,NXPTD-1 DX(K)=DX(I) K=K+1 45 CONTINUE ELSE IF(SDCONS.LT.TSIZE+1) THEN K=TSIZE+NXPTD-SDCONS DO 46 I=NXPTD-1,SDCONS,-1 DX(K)=DX(I) K=K-1 46 CONTINUE END IF K=TSIZE-SDCONS+1 DO 47 I=1,NTRANS IF(IX(I*12-5).GT.0)IX(I*12-5)=IX(I*12-5)+K 47 CONTINUE END IF C C Reset the current use of double precision to accommodate the C incoming matrix and the constants. C I=TSIZE+NXPTD-SDCONS NXPTD=1 CALL ROOMD(I) ILOC=NXPTD C C Allocate space for new variables not output, just beyond incoming C variables and constants. These variables will be stored without C regard to block. C IF(NVIN.GT.NVTOT) THEN DO 50 I=NVTOT+1,NVIN IF(MTYPE(I).EQ.4)GO TO 50 IF(IOUTL(I).EQ.0) THEN VMAPL(I)=ILOC ICLBLK=MXSIZE(I) ILOC=ILOC+MSIZE(I)*IX(SICMUL+ICLBLK-1) END IF 50 CONTINUE END IF C C Allocate space for new N of block not included on outgoing file. C This code was added Jan. 1996 and expanded the scope of the C REMOVE BLOCK statement. Previously, REMOVE BLOCK was restricted C to blocks on the incoming file, but in Jan. 1996, the scope was C expanded to all blocks. C IF(NCLBLK.GT.NCLBLS) THEN DO 51 ICLBLK=NCLBLS+1,NCLBLK IF(BLXSIZ(ICLBLK).EQ.0.AND.BLTYPE(ICLBLK).EQ.1) THEN BLXSTR(ICLBLK)=ILOC BLXINC(ICLBLK)=1 ILOC=ILOC+IX(SICMUL+ICLBLK-1) END IF 51 CONTINUE END IF C C Readjust IX(SIVMAP) to point to actual locations. The resulting C order in DX will be: C 1) Incoming matrix c 2) Constants C 3) New variables not on output file C 4) Output matrix C NXPTD=1 SDTOUT=ILOC ILOC=ILOC-1+IOUTSZ CALL ROOMD(ILOC) ILOC=SDTOUT-1 IF(IOUTC3.GT.0) THEN DO 52 I=1,IOUTC3 IF(MTYPE(IOUT(I)).EQ.4) GO TO 52 IX(SIVMAP+I-1)=IX(SIVMAP+I-1)+ILOC 52 CONTINUE END IF C C Allocate space for ID of replicate C DX(SDID) will hold the number of the replicate, 0, 1, etc. C to be passed to subroutines, followed by the NIDTOT id's on the C incoming and outgoing file. C SDID=NXPTD IF(IVERSN.EQ.9004) THEN NID=NVARID+NBY+1 ELSE NID=NIDTOT+1 END IF CALL ROOMD(NID) IXBASE=1 C C SDWRK, in common, is start of work space. C SDWRK=NXPTD C C Final loop over all transformations to create pointers to variables C IF(NTRANS.GT.0) THEN DO 78 ITRANS=1,NTRANS IX(ITRANS*12)=NXPTI NV=IX(ITRANS*12-8)+IX(ITRANS*12-7)+IX(ITRANS*12-6) IX(NXPTI)=NV C C SIDMPT - starting location to pointer to dimensions of each passed C variable C SIDXPT - starting location to pointers to work space used to store C each variable C SIMSIZ - starting location to size attribute of each variable C SIMTYP - starting location to type attribute of each variable C SIDIM - starting location of arrays with dimensions of each variable C SIDMPT=NXPTI+2 SIDXPT=SIDMPT+NV SIMSIZ=SIDXPT+NV SIMTYP=SIMSIZ+NV SIDIM=SIMTYP+NV K=4*NV+2 CALL ROOMI(K) IPASS=IX(ITRANS*12-1) C C IDIM - relative position in dimension array C MDIM - maximum size of dimension array C IWKR - set to SDWRK and incremented to show storage of variables in C temporary space. This is a position in the DX array, not a C relative position C MXISIZ - maximum size of matrix with any one variable. C IDIM=0 MDIM=MTRSZI-NXPTI IWRK=SDWRK MXISIZ=1 DO 76 IV=1,NV IX(SIDMPT+IV-1)=IDIM+1 IX(SIDXPT+IV-1)=IWRK IDIMSV=IDIM IDIM=IDIM+1 C C Generate error message if out of room for dimensions. C IF(IDIM.GT.MDIM)CALL ROOMI(IDIM) C C Adjustments for N of block. C IF(V2(IPASS).EQ.9) THEN ICLBLK=V1(IPASS) IX(SIMSIZ+IV-1)=1 IX(SIMTYP+IV-1)=0 IF(IX(SICMUL+ICLBLK-1).GT.MXISIZ)MXISIZ=IX(SICMUL+ICLBLK-1) C C All other variable types. C ELSE IVAR=V1(IPASS) ICLBLK=MXSIZE(IVAR) IMTYPE=MTYPE(IVAR) IX(SIMTYP+IV-1)=IMTYPE C C OLD variables C IF(IPASS.LT.IX(ITRANS*12-1)+IX(ITRANS*12-8)) THEN C C The size of the variable was previously determined in TSET1 C IX(SIMSIZ+IV-1)=RSTPNT(IPASS) C C CAT or single-dimensioned DERIVED variable. C IF(IMTYPE.EQ.3.OR.IMTYPE.EQ.13) THEN C C default, TOTAL, PROPORTION C IF(V2(IPASS).LE.2.OR.V2(IPASS).EQ.6) THEN IX(SIDIM+IDIM)=MSIZE(IVAR) IDIM=IDIM+1 IF(IDIM.GT.MDIM)CALL ROOMI(IDIM) C C PERCENT1, TOTAL1, PROPORTION1 C ELSE IF(V2(IPASS).EQ.3.OR.V2(IPASS).EQ.4.OR. . V2(IPASS).EQ.7) THEN IX(SIDIM+IDIM)=MSIZE(IVAR)-1 IF(MSIZE(IVAR).EQ.1)IX(SIDIM+IDIM)=1 IDIM=IDIM+1 IF(IDIM.GT.MDIM)CALL ROOMI(IDIM) END IF C C CROSSED REAL variables C ELSE IF(IMTYPE.EQ.8) THEN J=CDMPNT(IVAR) N=CROSSD(J) J=J+1 DO 63 I=2,N J=J+1 IX(SIDIM+IDIM)=CROSSD(J) IDIM=IDIM+1 IF(IDIM.GT.MDIM)CALL ROOMI(IDIM) 63 CONTINUE C C CROSSED CAT, CROSSED DERIVED. C ELSE IF(IMTYPE.EQ.9.OR.IMTYPE.EQ.19) THEN J=CDMPNT(IVAR) N=CROSSD(J) C C N of variable C IF(V2(IPASS).EQ.8) THEN J=J+1 DO 64 I=2,N J=J+1 IX(SIDIM+IDIM)=CROSSD(J) IDIM=IDIM+1 IF(IDIM.GT.MDIM)CALL ROOMI(IDIM) 64 CONTINUE C C All other transformations. C ELSE DO 65 I=1,N J=J+1 IF(V2(IPASS).LE.2.OR.V2(IPASS).EQ.5.OR.V2(IPASS).EQ.6 . .OR.I.GT.1) THEN IX(SIDIM+IDIM)=CROSSD(J) ELSE IX(SIDIM+IDIM)=CROSSD(J)-1 IF(CROSSD(J).EQ.1)IX(SIDIM+IDIM)=1 END IF IDIM=IDIM+1 IF(IDIM.GT.MDIM)CALL ROOMI(IDIM) 65 CONTINUE END IF END IF C C MODIFY or new variables. C ELSE IX(SIMSIZ+IV-1)=MSIZE(IVAR) C C CAT or single-dimension CROSS DERIVED C IF(IMTYPE.EQ.3.OR.IMTYPE.EQ.13) THEN IX(SIDIM+IDIM)=MSIZE(IVAR) IDIM=IDIM+1 IF(IDIM.GT.MDIM)CALL ROOMI(IDIM) C C CROSSED REAL C ELSE IF(IMTYPE.EQ.8) THEN J=CDMPNT(IVAR) N=CROSSD(J) J=J+1 DO 66 I=2,N J=J+1 IX(SIDIM+IDIM)=CROSSD(J) IDIM=IDIM+1 IF(IDIM.GT.MDIM)CALL ROOMI(IDIM) 66 CONTINUE C C CROSSED CAT, CROSSED DERIVED C ELSE IF(IMTYPE.EQ.9.OR.IMTYPE.EQ.19) THEN J=CDMPNT(IVAR) N=CROSSD(J) DO 67 I=1,N J=J+1 IX(SIDIM+IDIM)=CROSSD(J) IDIM=IDIM+1 IF(IDIM.GT.MDIM)CALL ROOMI(IDIM) 67 CONTINUE END IF END IF C C Compute total original size of variable multiplied by effect of C classes, and update MXISIZ, if appropriate. C K=MSIZE(IVAR)*IX(SICMUL+ICLBLK-1) IF(K.GT.MXISIZ)MXISIZ=K END IF C C For all variable types, including N of block, work out effect of C class variables. C ISIZE=IX(SIMSIZ+IV-1) ICLSS=V3(IPASS) IF(ICLSS.GT.0) THEN NSPTOT=IX(ICLSS) IS=ICLSS+2 68 CONTINUE N=IX(IS) IS=IS+3 DO 70 I=1,N IF(IX(IS).EQ.0)GO TO 69 IF(I.LT.N) THEN IF(IX(IS).EQ.IX(IS+3))GO TO 69 END IF IF(IX(IS+2).EQ.0) THEN IG=MSIZE(IX(IS)) ELSE IG=IX(IS+2) END IF IX(SIDIM+IDIM)=IG IDIM=IDIM+1 IF(IDIM.GT.MDIM)CALL ROOMI(IDIM) ISIZE=ISIZE*IG 69 CONTINUE IS=IS+3 70 CONTINUE IF(IS.LT.ICLSS+NSPTOT*3+2)GO TO 68 END IF IWRK=IWRK+ISIZE C C Compute number of elements in dimension array for the variable C and store as first element C IX(SIDIM+IDIMSV)=IDIM-IDIMSV-1 IPASS=IPASS+1 76 CONTINUE CALL ROOMI(IDIM) IX(IX(ITRANS*12)+1)=IWRK-SDWRK IF(IWRK+MXISIZ.GT.MSIZED) THEN IWRK=IWRK-SDWRK+1+MXISIZ CALL ROOMD(IWRK) END IF 78 CONTINUE END IF RETURN END C C End of T2.FOR CC C Start of T3.FOR - TRANSFORM execution, and some of the associated C subroutines that it calls (others in UC.FOR) C SUBROUTINE TCREA2 IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) C PARAMETER (MTRANS=1500,MRANGS=20) PARAMETER (MTRSZI=MSIZEI+6*MRANGE-6*MRANGS+2*MRNSET+MRECOD+MVAR) PARAMETER (IXFLLD=57+3*MAXIDS) C PARAMETER (MAXFMT=20) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP C LOGICAL REFRSH,ALPCHK,DGTCHK EXTERNAL REFRSH,ALPCHK,DGTCHK C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT C C NVARID (NID1) C INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C COMMON /STMBLK/IX,RANGE,RGROUP,RTYPE,RSTPNT,V1,V2,V3,MXSIZE, . IOUT,IOUTL DOUBLE PRECISION RANGE(2,MRANGS) INTEGER IX(MTRSZI),RGROUP(MRANGS),RTYPE(MRANGS),RSTPNT(MRECOD), . V1(MRECOD),V2(MRECOD),V3(MRECOD),MXSIZE(MVAR),IOUT(MVAR), . IOUTL(MVAR) C INTEGER SIDMPT,SIDXPT,SIMSIZ,SIMTYP,SIDIM C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT C LOGICAL ENDFLE C INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID, . SDWRK,VKEEPF,IXFILL(IXFLLD) COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT, . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF, . IXFILL C 200 FORMAT(' FATAL ERROR ON FIRST CALL TO SUBROUTINE',I6) 201 FORMAT(' FATAL ERROR, SUBROUTINE',I6,', REPLICATE',I6) 202 FORMAT(' FATAL ERROR, SUBROUTINE',I6,', REPLICATE',I6, . ', BY GROUP #',I6) 203 FORMAT(' (WARNING FROM FIRST CALL TO SUBROUTINE',I6,')',/) 204 FORMAT(' (WARNING FROM SUBROUTINE',I6,', REPLICATE',I6,')',/) 205 FORMAT(' (WARNING FROM SUBROUTINE',I6,', REPLICATE',I6, . ', BY GROUP #',I6,')',/) 206 FORMAT(/,5X,'Additional space allocated by subroutine',I6) C CALL SCOPEN(13) IFIRST=1 IERROR=0 C C Loop over each BY group and each replicate C DO 90 IGRP=1,NBYGRP DO 89 IREP=0,NRPTOT DX(SDID)=IREP C C Read ID record from input file and copy directly to output C READ(12)(DX(SDID+J),J=1,NID-1) WRITE(11)(DX(SDID+J),J=1,NID-1) C C Read incoming variables. C CALL UNFIN(12,DX,TSIZE,ENDFLE) C C Move incoming variables that will be retained on output C DO 25 I=1,NVREG K=IOUTL(I) IF(K.GT.0) THEN ICLBLK=MXSIZE(I) II=VMAPL(I) KK=IX(SIVMAP+K-1) N=IX(SICMUL+ICLBLK-1) I1=BLXINC(ICLBLK) K1=IX(SIXINC+ICLBLK-1) DO 23 J=1,N DO 22 M=0,MSIZE(I)-1 DX(KK+M)=DX(II+M) 22 CONTINUE II=II+I1 KK=KK+K1 23 CONTINUE END IF 25 CONTINUE C C Move block n's that will be retained on output C DO 28 ICLBLK=1,NCLBLS IF(BLXSIZ(ICLBLK).GT.0.AND.BLTYPE(ICLBLK).EQ.1) THEN II=BLXSTR(ICLBLK) KK=IX(SIXSTR+ICLBLK-1)+SDTOUT-1 N=IX(SICMUL+ICLBLK-1) I1=BLXINC(ICLBLK) K1=IX(SIXINC+ICLBLK-1) DO 26 J=1,N DX(KK)=DX(II) II=II+I1 KK=KK+K1 26 CONTINUE END IF 28 CONTINUE C C Loop over subroutines. C IF(NTRANS.GT.0) THEN DO 85 ITRANS=1,NTRANS NV=IX(IX(ITRANS*12)) NXPTD=SDWRK CALL ROOMD(IX(IX(ITRANS*12)+1)) NXPTDS=NXPTD C C Same usage as in TCREA1: C C SIDMPT - starting location to pointer to dimensions of each passed C variable C SIDXPT - starting location to pointers to work space used to store C each variable C SIMSIZ - starting location to size attribute of each variable C SIMTYP - starting location to type attribute of each variable C SIDIM - starting location of arrays with dimensions of each variable C SIDMPT=IX(ITRANS*12)+2 SIDXPT=SIDMPT+NV SIMSIZ=SIDXPT+NV SIMTYP=SIMSIZ+NV SIDIM=SIMTYP+NV IPASS=IX(ITRANS*12-1) C C Loop over OLD and MODIFY variables to copy information C DO 35 IV=1,IX(ITRANS*12-8)+IX(ITRANS*12-7) C C ICLBLK is block of variable. Distinguish between N of a block and C all other transformations. C IF(V2(IPASS).EQ.9) THEN ICLBLK=V1(IPASS) ELSE ICLBLK=MXSIZE(V1(IPASS)) END IF C C BLXSIZ is set to 0 in TSET1 for reduce blocks. Find location of C N of block. C IF(BLXSIZ(ICLBLK).GT.0) THEN ISN=IX(SIXSTR+ICLBLK-1)+SDTOUT-1 INCN=IX(SIXINC+ICLBLK-1) ELSE ISN=BLXSTR(ICLBLK) INCN=BLXINC(ICLBLK) END IF C C For N of block, location and increment has already been determined. C Otherwise, find location and increment of variable. C IF(V2(IPASS).EQ.9) THEN IS=ISN INC=INCN ELSE C C For a variable on the outgoing file: C IF(IOUTL(V1(IPASS)).GT.0) THEN K=IOUTL(V1(IPASS))-1 IS=IX(SIVMAP+K) INC=IX(SIXINC+ICLBLK-1) C C For other variables. New variables have an increment of 1. C ELSE IS=VMAPL(V1(IPASS)) IF(V1(IPASS).LE.NVTOT) THEN INC=BLXINC(ICLBLK) ELSE INC=1 END IF END IF END IF ICLSS=V3(IPASS) IF(ICLSS.GT.0) THEN CALL TMOVE1(IS,INC,ISN,INCN,IX(SIDXPT+IV-1),1, . IX(ICLSS+2),IX(ICLSS),ICLBLK,V1(IPASS),V2(IPASS)) ELSE CALL TMOVE1(IS,INC,ISN,INCN,IX(SIDXPT+IV-1),1,IX,0, . ICLBLK,V1(IPASS),V2(IPASS)) END IF C C If TMOVE1 returned in error, print error message identifying C subroutine number. C IF(IMERR1.GT.0)GO TO 36 IPASS=IPASS+1 35 CONTINUE C C Set up call to subroutine C IKEY=IX(ITRANS*12-9) IPASS=IX(ITRANS*12-1) IFMT=IX(ITRANS*12-10) INT=IX(ITRANS*12-11) IF(IKEY.EQ.1) THEN CALL USER1(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),ITRANS,IERROR) ELSE IF(IKEY.EQ.2) THEN CALL USER2(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),ITRANS,IERROR) ELSE IF(IKEY.EQ.3) THEN CALL USER3(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),ITRANS,IERROR) ELSE IF(IKEY.EQ.4) THEN CALL USER4(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),ITRANS,IERROR) ELSE IF(IKEY.EQ.5) THEN CALL USER5(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),ITRANS,IERROR) ELSE IF(IKEY.EQ.6) THEN CALL USER6(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),ITRANS,IERROR) ELSE IF(IKEY.EQ.7) THEN CALL USER7(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),ITRANS,IERROR) ELSE IF(IKEY.EQ.8) THEN CALL USER8(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),ITRANS,IERROR) ELSE IF(IKEY.EQ.9) THEN CALL USER9(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),ITRANS,IERROR) ELSE IF(IKEY.EQ.10) THEN CALL USER10(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),ITRANS,IERROR) ELSE IF(IKEY.EQ.-1) THEN CALL REFRMT(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMTYP),V2(IPASS),IERROR) ELSE IF((IKEY.GE.-13.AND.IKEY.LE.-2).OR.IKEY.EQ.-21) THEN CALL ARITHM(IKEY,DX(SDID),NID,IFIRST,IX(ITRANS*12-8), . IX(SIDMPT),IX(SIDIM),IX(SIDXPT),DX,IX(SIMTYP),V2(IPASS), . IERROR) ELSE IF(IKEY.EQ.-14.OR.IKEY.EQ.-22) THEN CALL SAVEFL(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMTYP),V2(IPASS),IKEY,ITRANS, . IERROR) ELSE IF(IKEY.EQ.-15) THEN CALL GLUE(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMTYP),V2(IPASS),IX(INT), . IERROR) ELSE IF(IKEY.EQ.-16) THEN CALL RPRINT(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),V1(IPASS),IERROR) ELSE IF(IKEY.GE.-20.AND.IKEY.LE.-17) THEN CALL RWRITE(IKEY,DX(SDID),NID,IFIRST,IX(ITRANS*12-8), . IX(SIDMPT),IX(SIDIM),IX(SIDXPT),DX,IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),ITRANS,IERROR) ELSE IF(IKEY.EQ.-23) THEN CALL CPSCOL(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),IERROR) ELSE IF(IKEY.EQ.-24) THEN CALL SIPCOL(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),IERROR) ELSE IF(IKEY.LE.-25.AND.IKEY.GE.-34) THEN CALL PSOLVE(IKEY,DX(SDID),NID,IFIRST,IX(ITRANS*12-8), . IX(SIDMPT),IX(SIDIM),IX(SIDXPT),DX,IX(SIMTYP),V2(IPASS), . IX(INT),IERROR) ELSE IF(IKEY.LE.-35.AND.IKEY.GE.-37) THEN CALL PEIGEN(IKEY,DX(SDID),NID,IFIRST,IX(ITRANS*12-8), . IX(SIDMPT),IX(SIDIM),IX(SIDXPT),DX,IX(SIMTYP),V2(IPASS), . IX(INT),IERROR) ELSE IF(IKEY.LE.-38.AND.IKEY.GE.-43) THEN CALL MSOLVE(IKEY,DX(SDID),NID,IFIRST,IX(ITRANS*12-8), . IX(SIDMPT),IX(SIDIM),IX(SIDXPT),DX,IX(SIMTYP),V2(IPASS), . IX(INT),IERROR) ELSE IF(IKEY.LE.-44.AND.IKEY.GE.-48) THEN CALL PBDIAG(IKEY,DX(SDID),NID,IFIRST,IX(ITRANS*12-8), . IX(SIDMPT),IX(SIDIM),IX(SIDXPT),DX,IX(SIMTYP),V2(IPASS), . IX(INT),IERROR) ELSE IF(IKEY.EQ.-49) THEN CALL CPSCHL(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),IERROR) ELSE IF(IKEY.EQ.-50) THEN CALL CPSNIC(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),IERROR) ELSE IF(IKEY.EQ.-51) THEN CALL GRIDSC(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),IERROR) ELSE IF(IKEY.EQ.-52) THEN CALL RAOSH(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMTYP),V2(IPASS), . IX(INT),ITRANS,IERROR) ELSE IF(IKEY.EQ.-53) THEN CALL NCPSCH(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),IERROR) ELSE IF(IKEY.EQ.-54) THEN CALL NPSCHL(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),IERROR) ELSE IF(IKEY.EQ.-55) THEN CALL OCPSCH(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),IERROR) ELSE IF(IKEY.EQ.-56) THEN CALL XMEDN(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),IERROR) ELSE IF(IKEY.EQ.-57) THEN CALL SCRCOL(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),IERROR) ELSE IF(IKEY.EQ.-58) THEN CALL SCCCOL(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),IERROR) ELSE IF(IKEY.EQ.-59) THEN CALL SCRAKE(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),IERROR) ELSE IF(IKEY.EQ.-60) THEN CALL VAPPND(DX(SDID),NID,IFIRST,IX(ITRANS*12-8), . IX(SIDXPT),DX,IX(SIMSIZ), . IX(INT),ITRANS,IERROR) ELSE IF(IKEY.EQ.-61) THEN CALL SCNCOL(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),IERROR) ELSE IF(IKEY.EQ.-62) THEN CALL CMPCOL(DX(SDID),NID,IFIRST,IX(ITRANS*12-8),IX(SIDMPT), . IX(SIDIM),IX(SIDXPT),DX,IX(SIMSIZ),IX(SIMTYP),V2(IPASS), . INFRMT(IFMT),IX(INT),IERROR) END IF 36 CONTINUE C C Printing of error messages, if any C IF(IERROR.EQ.1.OR.IMERR1.GT.0) THEN IF(IFIRST.EQ.1) THEN WRITE(U6,200)ITRANS ELSE IF(NBYGRP.EQ.1) THEN WRITE(U6,201)ITRANS,IREP ELSE WRITE(U6,202)ITRANS,IREP,IGRP END IF CALL FSTOP ELSE IF(IERROR.EQ.2) THEN IF(IFIRST.EQ.1) THEN WRITE(U6,203)ITRANS ELSE IF(NBYGRP.EQ.1) THEN WRITE(U6,204)ITRANS,IREP ELSE WRITE(U6,205)ITRANS,IREP,IGRP END IF IERROR=0 END IF C C Store MODIFY and new variables into locations. C IPASS=IX(ITRANS*12-1)+IX(ITRANS*12-8) DO 45 IV=IX(ITRANS*12-8)+1,NV C C Determine location for N of block C IF(V2(IPASS).EQ.9) THEN ICLBLK=V1(IPASS) IF(BLXSIZ(ICLBLK).GT.0) THEN IS=IX(SIXSTR+ICLBLK-1)+SDTOUT-1 INC=IX(SIXINC+ICLBLK-1) ELSE IS=BLXSTR(ICLBLK) INC=BLXINC(ICLBLK) END IF C C Determine location for all other variables. C ELSE ICLBLK=MXSIZE(V1(IPASS)) IF(IOUTL(V1(IPASS)).GT.0) THEN K=IOUTL(V1(IPASS))-1 IS=IX(SIVMAP+K) INC=IX(SIXINC+ICLBLK-1) ELSE IS=VMAPL(V1(IPASS)) IF(V1(IPASS).LE.NVTOT) THEN INC=BLXINC(ICLBLK) ELSE INC=1 END IF END IF END IF c if(ikey.eq.-60) then c write(6,*)iclblk,is,inc,ix(sidxpt+iv-1),dx(ix(sidxpt+iv-1)), c . v3(ipass),(ix(v3(ipass)+iz),iz=0,4) c end if CALL TMOVE2(IPASS,IS,INC,IX(SIDXPT+IV-1),1,ICLBLK) c write(6,*)dx(is),dx(is+3) IPASS=IPASS+1 45 CONTINUE C C If the subroutine changed NXPTD, assume that the constants have been C specified/respecified. Change the pointer to the start of the C constants matrix, and move the resulting constants below SDWRK, the C start of the working arrays to be passed to the subroutines. C Readjust all pointers starting at SIDXPT. C IF(NXPTDS.NE.NXPTD) THEN IX(12*ITRANS-5)=SDWRK WRITE(U6,206)ITRANS DO 50 I=NXPTDS,NXPTD-1 DX(SDWRK)=DX(I) SDWRK=SDWRK+1 50 CONTINUE K=NXPTD-NXPTDS DO 55 I=1,NTRANS NV=IX(IX(I*12)) SIDXPT=IX(I*12)+2+NV DO 53 IV=1,NV IX(SIDXPT+IV-1)=IX(SIDXPT+IV-1)+K 53 CONTINUE 55 CONTINUE END IF 85 CONTINUE END IF CALL UNFOUT(11,DX(SDTOUT),IOUTSZ) IFIRST=0 REWIND(13) 89 CONTINUE 90 CONTINUE CALL FCLALL RETURN END C SUBROUTINE TMOVE2(IPASS,IS,INC1,IP,INC2,ICLBLK) IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) C PARAMETER (MTRANS=1500,MRANGS=20) PARAMETER (MTRSZI=MSIZEI+6*MRANGE-6*MRANGS+2*MRNSET+MRECOD+MVAR) PARAMETER (IXFLLD=57+3*MAXIDS) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT C C NVARID (NID1) C INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C COMMON /STMBLK/IX,RANGE,RGROUP,RTYPE,RSTPNT,V1,V2,V3,MXSIZE, . IOUT,IOUTL DOUBLE PRECISION RANGE(2,MRANGS) INTEGER IX(MTRSZI),RGROUP(MRANGS),RTYPE(MRANGS),RSTPNT(MRECOD), . V1(MRECOD),V2(MRECOD),V3(MRECOD),MXSIZE(MVAR),IOUT(MVAR), . IOUTL(MVAR) C INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID, . SDWRK,VKEEPF,IXFILL(IXFLLD) COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT, . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF, . IXFILL C INTEGER SI1,SI2,SI3,SI4,SI7,SI8,SI10 C ICLSS=V3(IPASS) NIN=BLNCLS(ICLBLK) C C IVLEN is the length to be passed, for each combination of class C variables C IF(V2(IPASS).EQ.9) THEN IVLEN=1 ELSE IVLEN=MSIZE(V1(IPASS)) END IF IS1=IS C C If there is no class specification, then copy the values and return C IF(ICLSS.EQ.0) THEN IF(IVLEN.EQ.1) THEN C C Copy for single element C DX(IS1)=DX(IP) c write(6,*)is1,dx(is1),iclss ELSE C C Copy for multiple elements C K=IP DO 2 I=1,IVLEN DX(IS1)=DX(K) c write(6,*)is1,dx(is1),iclss IS1=IS1+1 K=K+1 2 CONTINUE END IF RETURN END IF C C Code when a class specification is provided. C C Determine the increment for the temporary matrix C IF(INC2.EQ.1) THEN IS2INC=IVLEN ELSE IS2INC=INC2 END IF C C This next section of code closely parallels SUBROUTINE TM1 C The object is to discover whether the transfer can be handled C under the special case, beginning at statement 55, or the general C case, starting at 10. C K=ICLSS+2 ICLBAR=BLCPNT(ICLBLK) 4 CONTINUE N=IX(K) K=K+3 DO 6 J=1,N C C The next statement assures that ICLBAR, which is incremented in C statements below, has not stepped beyond the appropriate range for C the block C c write(6,*)iclblk,blcpnt(iclblk),nin,iclbar IF(BLCPNT(ICLBLK)+NIN.LE.ICLBAR)GO TO 10 C C The next statement checks that the CLASS specification points to C the right class variable. C C write(6,*)k,ix(k),clpnt(iclbar) IF(IX(K).NE.CLPNT(ICLBAR))GO TO 10 C C If no range is given for the class variable, then the block C cannot be of type 0, with separate marginal total. C IF(IX(K+2).EQ.0) THEN C write(6,*)ix(k+2),cltype(iclbar) IF(CLTYPE(ICLBAR).EQ.0)GO TO 10 ICLBAR=ICLBAR+1 C C If a range is given for the class variable, then check that the C levels are specified in the right order. For blocks of type 0, C level 0 must be specified first. C ELSE IF(CLTYPE(ICLBAR).EQ.1) THEN IF(IX(K+1).NE.IX(K+2))GO TO 10 C C If the last level has been listed, then increment ICLBAR C IF(IX(K+2).EQ.MSIZE(CLPNT(ICLBAR))) THEN ICLBAR=ICLBAR+1 END IF ELSE IF(IX(K+1)+1.NE.IX(K+2))GO TO 10 C C If the last level has been listed, then increment ICLBAR C IF(IX(K+2).EQ.MSIZE(CLPNT(ICLBAR))+1) THEN ICLBAR=ICLBAR+1 END IF END IF END IF K=K+3 6 CONTINUE C C Loop back to 4 if more remains on the specification C c write(6,*)k,iclss,ix(iclss) IF(K.LE.ICLSS+3*IX(ICLSS)+1) GO TO 4 C C This last check insures that all classes have matched, which will C be the case if ICLBAR has been incremented to just beyond the C range for the block. C C write(6,*)iclbar,blcpnt(iclblk),nin IF(ICLBAR.EQ.BLCPNT(ICLBLK)+NIN)GO TO 55 C C Creating the output is handled either here or at statement 55 C Treatment of the general case begins here. C 10 CONTINUE C C Internal matrices: C C IX(SI1+ ) - output dimensions C IX(SI2+ ) - output class C IX(SI3+ ) - pointer to first cell of output class C IX(SI4+ ) - ICLBAR for corresponding output class C IX(SI7+ ) - outgoing indices C IX(SI8+ ) - increments for input, in output order C IX(SI10+ ) - coordinate array for output cells, starts at 0 C NOUT=0 NC=0 SI1=NXPTI SI2=SI1+NIN SI3=SI2+NIN SI4=SI3+NIN SI8=SI4+NIN SI10=SI8+NIN K=6*NIN C C Call ROOMI to allocate space C CALL ROOMI(K) C C Loop through specification to identify class variables C K=ICLSS+2 L=0 IX(SI2)=0 IS2=IP 12 CONTINUE N=IX(K) K=K+3 C C The loop to 14 establishes the following C NOUT - the number of explicitly referenced class variables in the C specification C IX(SI1+ ) - output dimensions C IX(SI2+ ) - output class C IX(SI3+ ) - pointer to first cell of output class C DO 14 J=1,N IF(IX(K).NE.IX(SI2+NOUT)) THEN IF(IX(SI2).GT.0)NOUT=NOUT+1 IX(SI2+NOUT)=IX(K) END IF C C Unless at the end of the specification, look ahead. C If the current part of the specification gives a level of a class C variable to be followed by other levels, do not store into IX(SI1+ C yet. C IF(J.LT.N) THEN K1=K+3 IF(IX(K1).EQ.IX(K)) GO TO 13 END IF C C If this the last (possibly only) part of the specification to C refer to a class variable, store the number of outgoing levels C in IX(SI1+ C IF(IX(K+2).EQ.0) THEN IX(SI1+NOUT)=MSIZE(IX(K)) ELSE IX(SI1+NOUT)=IX(K+2) END IF IX(SI3+NOUT)=NC NC=NC+IX(SI1+NOUT) 13 CONTINUE K=K+3 14 CONTINUE IF(K.LE.ICLSS+3*IX(ICLSS)+1)GO TO 12 C C The loop to 20 establishes the following: C IX(SI4+ ) - ICLBAR for corresponding output class C IX(SI8+ ) - increments for input, in output order C and initializes to 0 C IX(SI10+ ) - coordinate array for output cells C NOUT=NOUT+1 ICLBAR=BLCPNT(ICLBLK) I1=INC1 DO 20 I=1,NIN IX(SI10+I-1)=0 DO 18 J=1,NOUT IF(IX(SI2+J-1).EQ.CLPNT(ICLBAR)) THEN IX(SI4+J-1)=ICLBAR IX(SI8+J-1)=I1 GO TO 19 END IF 18 CONTINUE 19 CONTINUE IF(CLTYPE(ICLBAR).EQ.1) THEN I1=I1*MSIZE(CLPNT(ICLBAR)) ELSE I1=I1*(MSIZE(CLPNT(ICLBAR))+1) END IF ICLBAR=ICLBAR+1 20 CONTINUE C SI7=SI10+NIN CALL ROOMI(NC) K=ICLSS+2 LOUT=0 ICL=0 22 CONTINUE N=IX(K) K=K+3 C C The loop to 24 computes: C IX(SI7+ ) - outgoing indices C LOUT points to current class variable in IX(SI2+ ) C DO 24 J=1,N IF(IX(K).NE.IX(SI2+LOUT)) THEN IF(ICL.GT.0)LOUT=LOUT+1 END IF IF(IX(K+2).EQ.0) THEN DO 23 JJ=1,MSIZE(IX(K)) IF(CLTYPE(IX(SI4+LOUT)).EQ.1) THEN IX(SI7+ICL)=JJ-1 ELSE IX(SI7+ICL)=JJ END IF ICL=ICL+1 23 CONTINUE ELSE IF(CLTYPE(IX(SI4+LOUT)).EQ.1) THEN IX(SI7+ICL)=IX(K+1)-1 ICL=ICL+1 ELSE IX(SI7+ICL)=IX(K+1) ICL=ICL+1 END IF K=K+3 24 CONTINUE IF(K.LE.ICLSS+3*IX(ICLSS)+1)GO TO 22 C IX(SI10)=-1 32 CONTINUE C C The loop to 34 increments the indices of output cells and C determines if done. C DO 34 I=1,NOUT IX(SI10+I-1)=IX(SI10+I-1)+1 IF(IX(SI10+I-1).LT.IX(SI1+I-1)) THEN IF(I.GT.1) THEN DO 33 J=1,I-1 IX(SI10+J-1)=0 33 CONTINUE END IF GO TO 36 END IF 34 CONTINUE NXPTI=SI1 RETURN 36 CONTINUE IS1=IS C C The loop to 38 computes the index in the outgoing table. C DO 38 I=1,NOUT ICL=IX(SI3+I-1)+IX(SI10+I-1) IS1=IS1+IX(SI8+I-1)*IX(SI7+ICL) 38 CONTINUE C C Store input into output C IF(IVLEN.EQ.1) THEN DX(IS1)=DX(IS2) C write(6,*)is1,dx(is1) ELSE K=IS2 DO 40 I=1,IVLEN DX(IS1)=DX(K) C write(6,*)is1,dx(is1) K=K+1 IS1=IS1+1 40 CONTINUE END IF IF(INC2.EQ.1) THEN IS2=IS2+IVLEN ELSE IS2=IS2+INC2 END IF GO TO 32 55 CONTINUE IS1=IS IS2=IP DO 50 I=1,IX(SICMUL+ICLBLK-1) IF(IVLEN.EQ.1) THEN DX(IS1)=DX(IS2) C write(6,*)is1,is2,dx(is1) ELSE J=IS1 K=IS2 DO 44 L=1,IVLEN DX(J)=DX(K) C write(6,*)is1,k,dx(is1) J=J+1 K=K+1 44 CONTINUE END IF IF(INC2.EQ.1) THEN IS2=IS2+IVLEN ELSE IS2=IS2+INC2 END IF IS1=IS1+INC1 50 CONTINUE RETURN END C C Summary of general calling conventions from TCREA2 to subroutines. C C Example calling sequence. C C SUBROUTINE REFRMT(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, C . DX,MTYPE,MTRAN,IERROR) C INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*), C . MTYPE(*),MTRAN(*),IERROR C DOUBLE PRECISION DID(NID),DX(*) C SUBROUTINE REFRMT(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MTYPE,MTRAN,IERROR) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*), . MTYPE(*),MTRAN(*),IERROR DOUBLE PRECISION DID(NID),DX(*) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 INTEGER ILIST(3),ISIZE(3) INTEGER MATSIZ EXTERNAL MATSIZ 100 FORMAT(' COPY/REFORMAT ERROR:',/ ,' MUST BE CALLED WITH EITHER OLD . VARIABLES OR CONSTANTS') 101 FORMAT (' COPY/REFORMAT ERROR: MUST BE CALLED WITH EITHER MODIFIED .OR NEW VARIABLES') 102 FORMAT(' COPY/REFORMAT ERROR: MISMATCH OF LIST LENGTHS') 103 FORMAT(' COPY/REFORMAT ERROR: MISMATCH OF SIZES, OLD VARIABLE',3I7 .) C C Checks performed for full sample C IF(DID(1).EQ.0.) THEN C C Call must use either OLD variables or constants, but not both C IF((IVLIST(1).EQ.0.AND.IVLIST(5).EQ.0).OR. . (IVLIST(1).GT.0.AND.IVLIST(5).GT.0)) THEN WRITE(U6,100) GO TO 99 END IF C C Call must use either MODIFY or new variables, but not both C IF((IVLIST(2).EQ.0.AND.IVLIST(3).EQ.0).OR. . (IVLIST(2).GT.0.AND.IVLIST(3).GT.0)) THEN WRITE(U6,101) GO TO 99 END IF END IF C C IOLD - index for old variable C INEW - index for new variables C IOLD=1 INEW=IVLIST(1)+1 5 CONTINUE C C If called with OLD variable(s) C IF(IVLIST(1).GT.0) THEN C C Check for done C IF(INEW.GT.IVLIST(1)+IVLIST(2)+IVLIST(3).OR. . IOLD.GT.IVLIST(1)) THEN C C OK if both list of MODIFY/new variables and OLD variables C exhausted at same time, else error C IF(INEW.EQ.IVLIST(1)+IVLIST(2)+IVLIST(3)+1.AND. . IOLD.EQ.IVLIST(1)+1) RETURN WRITE(U6,102) GO TO 99 END IF C C Special handling of MISSING and CROSSED REAL variables, set NOLD=2 C if OLD variable of these types. C IF((MTYPE(IOLD).EQ.2.OR.MTYPE(IOLD).EQ.8).AND.MTRAN(IOLD).EQ.0) . THEN NOLD=2 ELSE NOLD=1 END IF C C Begin analogous checks for CONSTANTS (in place of OLD) C ELSE C C Check for done C IF(INEW.GT.IVLIST(2)+IVLIST(3).OR.IOLD.GT.IVLIST(5)) THEN C C OK if both list of MODIFY/new variables and CONSTANTS C exhausted at same time (or #CONSTANTS=1), else error C IF(INEW.EQ.IVLIST(2)+IVLIST(3)+1.AND. . (IOLD.EQ.IVLIST(5)+1.OR.IVLIST(5).EQ.1)) THEN RETURN END IF WRITE(U6,102) GO TO 99 END IF C C Always set NOLD=1 for CONSTANTS C NOLD=1 END IF C C Now check for special handling of MISSING/CROSSED REAL for new C variable C IF((MTYPE(INEW).EQ.2.OR.MTYPE(INEW).EQ.8).AND.MTRAN(INEW).EQ.0) . THEN NNEW=2 ELSE NNEW=1 END IF C C If NOLD=2 or CONSTANTS, and NNEW=2, then don't use special rules for C handling MISSING/CROSSED REAL - instead, make a straight copy. C IF((NOLD.EQ.2.OR.IVLIST(5).GT.0).AND.NNEW.EQ.2) THEN NOLD=1 NNEW=1 END IF C C Assemble in ILIST a list of variables, in order to call MATSIZ, below C C If OLD variable, always obtain its length C IF(IVLIST(1).GT.0) THEN ILIST(1)=IOLD NILIST=1 C C If full sample, get additional lengths C IF(DID(1).EQ.0.) THEN C C If NOLD=2, get length of next OLD variable C IF(NOLD.EQ.2) THEN ILIST(2)=IOLD+1 NILIST=2 END IF C C Get length of new variable C NILIST=NILIST+1 ILIST(NILIST)=INEW C C If NNEW=2, get length of next MODIFY/NEW variable C IF(NNEW.EQ.2) THEN NILIST=NILIST+1 ILIST(NILIST)=INEW+1 END IF END IF ELSE C C Build up comparable list of variables for CONSTANTS C C Always get length of new variable C ILIST(1)=INEW NILIST=1 END IF C C Loop to get variable lengths. C DO 10 I=1,NILIST J=ILIST(I) ISIZE(I)=MATSIZ(DIMX(DIMPNT(J)),MTYPE(J),MTRAN(J)) 10 CONTINUE C C Further checks for full sample with OLD variables C IF(DID(1).EQ.0..AND.IVLIST(1).GT.0) THEN C C When NNEW=1 and NOLD=1, matrices should be of same size C IF(NNEW.EQ.1.AND.NOLD.EQ.1) THEN IF(ISIZE(1).NE.ISIZE(2)) THEN WRITE(U6,103)IOLD,ISIZE(1),ISIZE(2) GO TO 99 END IF C C When NNEW=1 and NOLD=2, second OLD matrix must be same size as C first, and matrix for MODIFY/new variable must be twice as large C as each OLD matrix C ELSE IF(NOLD.EQ.2) THEN IF(ISIZE(1).NE.ISIZE(2).OR.2*ISIZE(1).NE.ISIZE(3)) THEN WRITE(U6,103)IOLD GO TO 99 END IF ELSE C C When NNEW=2 and NOLD=1, second MODIFY/new matrix must be same size C as first, and matrix of OLD variable must be twice as large as each C MODIFY/new matrix. C IF(ISIZE(2).NE.ISIZE(3).OR.ISIZE(1).NE.2*ISIZE(3)) THEN WRITE(U6,103)IOLD GO TO 99 END IF END IF END IF C C Actual copy when NOLD=1, NNEW=1 C IF(NOLD.EQ.1.AND.NNEW.EQ.1) THEN C C K - location of OLD variable or CONSTANT C IK - location of new variable C IF(IVLIST(1).GT.0) THEN K=DXPNT(IOLD) ELSE K=IVLIST(4)+IOLD-1 END IF IK=DXPNT(INEW) C C Special loop to copy single CONSTANT into each cell C IF(IVLIST(5).EQ.1) THEN DO 12 I=1,ISIZE(1) DX(IK)=DX(K) IK=IK+1 12 CONTINUE C C Loop for remaining COPY C ELSE DO 15 I=1,ISIZE(1) DX(IK)=DX(K) K=K+1 IK=IK+1 15 CONTINUE END IF C C For CONSTANT, increment INEW, and also IOLD unless there is only C one contant C IF(IVLIST(5).GT.0) THEN INEW=INEW+1 IF(IVLIST(5).GT.1) THEN IOLD=IOLD+ISIZE(1) END IF END IF C C For NNEW=1, NOLD=2 C K - index for first OLD variable C IK - index for second OLD variable C J - index for output C ELSE IF(NOLD.EQ.2) THEN K=DXPNT(IOLD) IK=DXPNT(IOLD+1) J=DXPNT(INEW) DO 20 I=1,ISIZE(1) DX(J)=DX(K) DX(J+1)=DX(IK) K=K+1 IK=IK+1 J=J+2 20 CONTINUE C C For NNEW=2, NOLD=1 C J - index for OLD variable C K - index for first MODIFY/new variable C IK - index for second MODIFY/new variable C ELSE J=DXPNT(IOLD) K=DXPNT(INEW) IK=DXPNT(INEW+1) DO 25 I=1,ISIZE(1),2 DX(K)=DX(J) DX(IK)=DX(J+1) K=K+1 IK=IK+1 J=J+2 25 CONTINUE END IF C C For all cases using OLD variables, increment OLD and new variables C IF(IVLIST(1).GT.0) THEN IOLD=IOLD+NOLD INEW=INEW+NNEW END IF GO TO 5 C 99 CONTINUE IERROR=1 RETURN END C SUBROUTINE ARITHM(IKEY,DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MTYPE,MTRAN,IERROR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*), . MTYPE(*),MTRAN(*),IERROR DOUBLE PRECISION DID(NID),DX(*) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 INTEGER ILIST(3),ISIZE(3) INTEGER MATSIZ LOGICAL ICHECK EXTERNAL MATSIZ,ICHECK DOUBLE PRECISION MISSNG DATA MISSNG/-98765.432109D0/ 100 FORMAT(' INAPPROPRIATE MIXING OF MODIFY AND NEW') 102 FORMAT(' MISMATCH OF LIST LENGTHS') 103 FORMAT(' CONSTANTS NOT ALLOWED') 104 FORMAT(' MODIFIED OR NEW VARIABLES REQUIRED') 105 FORMAT(' MATCH ON SIZE REQUIRED',2I6) 106 FORMAT (' SIZE OF FIRST OPERAND MUST BE AN INTEGER MULTIPLE OF THE . SECOND') 107 FORMAT(' NONINTEGER IN COLLAPSE:',F10.4) C C IKEY = -2 add C = -3 subtract C = -4 multiply C = -5 divide C = -6 power C = -7 reciprocal C = -8 log C = -9 paired add C = -10 " subtract C = -11 " multiply C = -12 " divide C = -13 rmultiply C = -21 collapse C C C IV23 is sum of new and MODIFY variables (only one will be >0) C IV23=IVLIST(2)+IVLIST(3) C C Checks on first call: C IF(IFIRST.EQ.1) THEN C C Check that MODIFY and new variables don't appear together, but that C one type does C IF(IVLIST(2).GT.0.AND.IVLIST(3).GT.0)GO TO 90 IF(IV23.EQ.0)GO TO 94 C C Checks for ADD, SUBTRACT, MULTIPLY, DIVIDE, POWER, RMULTIPLY, C COLLAPSE (which each involve 2 operators) C IF((IKEY.GE.-6.AND.IKEY.LE.-2).OR.IKEY.EQ.-13.OR.IKEY.EQ.-21) . THEN C C If CONSTANTS are given, then if #OLD >0, #OLD must agree with IV23 C (number of new/MODIFY variables) C IF(IVLIST(4).GT.0) THEN IF(IVLIST(1).GT.0.AND.IVLIST(1).NE.IV23)GO TO 92 ELSE C C If no CONSTANTS, then: C 1) if #OLD = 1, then #new must be 0 C 2) #OLD must be 1 or more C 3) #OLD must = #new/MODIFY + 1 C IF((IVLIST(1).EQ.1.AND.IVLIST(3).GT.0).OR.IVLIST(1).EQ.0.OR. . (IVLIST(1).GT.1.AND.IVLIST(1).NE.IV23+1)) GO TO 92 END IF C C Check for RECIPROCAL and LOG (usually single operator): C # old var must= # new/MODIFY or MODIFY only C ELSE IF(IKEY.EQ.-8.OR.IKEY.EQ.-7) THEN IF(IVLIST(1).NE.IV23.AND. . (IVLIST(1).NE.0.OR.IVLIST(2).EQ.0))GO TO 92 C C Check for PAIRED ADD, SUBTRACT, MULTIPLY, DIVIDE, that either C 1) #OLD = 2 * #new C 2) #OLD = #MODIFY C ELSE IF(IKEY.GE.-12.AND.IKEY.LE.-9) THEN IF(IVLIST(1).NE.2*IVLIST(3).AND. . IVLIST(1).NE.IVLIST(2))GO TO 92 END IF C C Check for PAIRED ADD, SUBTRACT, MULTIPLY, DIVIDE, and LOG that there C are no CONSTANTS C IF(IKEY.GE.-12.AND.IKEY.LE.-8) THEN IF(IVLIST(4).GT.0)GO TO 93 END IF END IF C C End of dimension checks on first call C C INEW - index for outcome variable C IOLD1 - index for first operator variable C IOLD2 - index for second operator variable C INEW=IVLIST(1)+1 C C For ADD, SUBTRACT, MULTIPLY, DIVIDE, POWER, RMULTIPLY, C COLLAPSE (which each involve 2 operators): C IF((IKEY.GE.-6.AND.IKEY.LE.-2).OR.IKEY.EQ.-13.OR.IKEY.EQ.-21) . THEN C C If CONSTANTS, set IOLD2=0 C IF(IVLIST(4).GT.0) THEN IOLD2=0 IOLD1=1 ELSE C C If no CONSTANTS, IOLD2 is last OLD variable C IOLD2=IVLIST(1) IF(IVLIST(1).GT.1) THEN IOLD1=1 ELSE IOLD1=IVLIST(1)+1 END IF END IF C C For RECIPROCAL and LOG (usually single operator): C ELSE IF(IKEY.EQ.-8.OR.IKEY.EQ.-7) THEN IOLD1=1 IOLD2=0 C C For PAIRED ADD, SUBTRACT, MULTIPLY, DIVIDE: C ELSE IF(IKEY.GE.-12.AND.IKEY.LE.-9) THEN IF(IVLIST(2).GT.0) THEN IOLD1=IVLIST(1)+1 IOLD2=1 ELSE IOLD1=1 IOLD2=(IVLIST(1)/2)+1 END IF END IF 5 CONTINUE C C Check for return C IF(INEW.GT.IVLIST(1)+IV23) RETURN C C Build a list in ILIST of variables whose size is required C JOLD1 - cell index for first operator C JOLD2 - cell index for second operator, if present C JNEW - cell index for output C ILIST(1)=IOLD1 JOLD1=DXPNT(IOLD1) JNEW=DXPNT(INEW) C C For all combinations except LOG and reciprocal without CONSTANTS, C set values for second operator C IF((IKEY.GE.-13.AND.IKEY.LE.-9).OR.IKEY.EQ.-21.OR. . (IKEY.GE.-6.AND.IKEY.LE.-2).OR. . (IKEY.EQ.-7.AND.IVLIST(4).GT.0)) THEN ILIST(2)=IOLD2 NILIST=2 C C If CONSTANTS, set JOLD2 to location of constants C IF(IOLD2.EQ.0) THEN JOLD2=IVLIST(4) ELSE JOLD2=DXPNT(IOLD2) END IF C C Temporarily set INCR to 0, to be recomputed below C INCR=0 ELSE C C For LOG or RECIPROCAL without CONSTANTS C NILIST=1 JOLD2=0 INCR=1 END IF C C On first call, add new variable to ILIST C IF(IFIRST.EQ.1) THEN NILIST=NILIST+1 ILIST(NILIST)=INEW END IF C C Loop to determine lengths C DO 10 I=1,NILIST J=ILIST(I) C C J=0 present for CONSTANTS, in which case set ISIZE to the number C of constants. C IF(J.EQ.0) THEN ISIZE(I)=IVLIST(5) ELSE ISIZE(I)=MATSIZ(DIMX(DIMPNT(J)),MTYPE(J),MTRAN(J)) END IF 10 CONTINUE C C ADD, SUBTRACT, MULTIPLY, DIVIDE, PAIRED versions, RMULTIPLY C POWER, and COLLAPSE C IF((IKEY.GE.-13.AND.IKEY.LE.-9).OR.IKEY.EQ.-21.OR. . (IKEY.GE.-6.AND.IKEY.LE.-2)) THEN C C Adjust lengths of array for MISSING or CROSSED REAL C IF(IOLD2.GT.0) THEN IF((MTYPE(IOLD2).EQ.2.OR.MTYPE(IOLD2).EQ.8).AND. . MTRAN(IOLD2).EQ.0) THEN ISIZE(2)=ISIZE(2)/2 INCR2=2 ELSE INCR2=1 END IF ELSE INCR2=1 END IF END IF C C Checks on first call C IF(IFIRST.EQ.1) THEN C C Check that size of first operator matches size of target, unless C REAL with MISSING or CROSSED REAL are involved. C IF(ISIZE(NILIST).NE.ISIZE(1)) THEN IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND. . MTRAN(IOLD1).EQ.0) THEN IF(ISIZE(1).EQ.2*ISIZE(NILIST)) THEN IF(MTYPE(INEW).EQ.2.OR.MTYPE(INEW).EQ.8)GO TO 95 ELSE GO TO 95 END IF ELSE GO TO 95 END IF END IF C C If there is a second operator, then check the value of INCR2 C and size of the second operator, for COLLAPSE C IF(NILIST.EQ.3) THEN IF(IKEY.EQ.-21) THEN IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND. . MTRAN(IOLD1).EQ.0) THEN IF(INCR2*ISIZE(1).NE.2*ISIZE(2))GO TO 95 ELSE IF(INCR2*ISIZE(1).NE.ISIZE(2))GO TO 95 END IF ELSE IF(ISIZE(1).NE.(ISIZE(1)/ISIZE(2))*ISIZE(2)) GO TO 96 END IF END IF END IF C C End of full sample checks C C If INCR has not been previously determined, compute it here C Generally, INCR determines the number of cells of the first C operator to be operated on by the second C IF(INCR.EQ.0)INCR=ISIZE(1)/ISIZE(2) C C JINCR - increment for JOLD1 C JINCR2 - increment for JNEW C IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND.MTRAN(IOLD1).EQ.0) . THEN JINCR=2 IF(MTYPE(INEW).EQ.2.OR.MTYPE(INEW).EQ.8) THEN JINCR2=2 ELSE JINCR2=1 END IF ELSE JINCR=1 JINCR2=1 END IF C C ADD, SUBTRACT, MULTIPLY, DIVIDE, PAIRED versions, POWER C and RMULTIPLY C IF((IKEY.GE.-6.AND.IKEY.LE.-2).OR. . (IKEY.GE.-13.AND.IKEY.LE.-9)) THEN DO 15 I=1,ISIZE(1),INCR DO 12 J=1,INCR,JINCR C C Handling of missing values, with special rules for MULTIPLY, C PAIRED MULTIPLY, and RMULTIPLY C IF(DABS(DX(JOLD1)-MISSNG).LT..1D-06.OR. . DABS(DX(JOLD2)-MISSNG).LT..1D-06) THEN IF(IKEY.EQ.-4.OR.IKEY.EQ.-11.OR.IKEY.EQ.-13) THEN IF(DX(JOLD1).EQ.0..OR.DX(JOLD2).EQ.0.) THEN DX(JNEW)=0. ELSE DX(JNEW)=MISSNG END IF ELSE DX(JNEW)=MISSNG END IF C C ADD and PAIRED ADD C ELSE IF(IKEY.EQ.-2.OR.IKEY.EQ.-9) THEN DX(JNEW)=DX(JOLD1)+DX(JOLD2) C C MULTIPLY, PAIRED MULTIPLY, and RMULTIPLY C ELSE IF(IKEY.EQ.-4.OR.IKEY.EQ.-11.OR.IKEY.EQ.-13) THEN DX(JNEW)=DX(JOLD1)*DX(JOLD2) C C SUBTRACT, PAIRED SUBTRACT C ELSE IF(IKEY.EQ.-3.OR.IKEY.EQ.-10) THEN DX(JNEW)=DX(JOLD1)-DX(JOLD2) C C DIVIDE, PAIRED DIVIDE C ELSE IF(IKEY.EQ.-5.OR.IKEY.EQ.-12) THEN IF(DX(JOLD2).NE.0.) THEN DX(JNEW)=DX(JOLD1)/DX(JOLD2) ELSE DX(JNEW)=MISSNG END IF C C POWER C ELSE IF(IKEY.EQ.-6) THEN IF(DX(JOLD1).GT.0.) THEN IF(DABS(DX(JOLD2)-.5D0).LT..1D-12) THEN DX(JNEW)=DSQRT(DX(JOLD1)) ELSE IF(DABS(DX(JOLD2)-2.D0).LT.1.D-12) THEN DX(JNEW)=DX(JOLD1)*DX(JOLD1) ELSE DX(JNEW)=DX(JOLD1)**DX(JOLD2) END IF ELSE IF(DX(JOLD1).EQ.0.) THEN IF(DX(JOLD2).GT.0.) THEN DX(JNEW)=0. ELSE DX(JNEW)=MISSNG END IF ELSE DX(JNEW)=MISSNG END IF END IF C C Handling of second cell if JINCR (increment for JOLD1) is 2 C IF(JINCR.EQ.2) THEN IF(JINCR2.EQ.2) THEN C C RMULTIPLY C IF(IKEY.EQ.-13) THEN IF(DABS(DX(JOLD1+1)-MISSNG).LT..1D-06.OR. . DABS(DX(JOLD2)-MISSNG).LT..1D-06) THEN IF(DX(JOLD1+1).EQ.0..OR.DX(JOLD2).EQ.0.) THEN DX(JNEW+1)=0. ELSE DX(JNEW+1)=MISSNG END IF ELSE DX(JNEW+1)=DX(JOLD1+1)*DX(JOLD2) END IF ELSE DX(JNEW+1)=DX(JOLD1+1) END IF END IF C C Increment of JNEW and JOLD1 C JNEW=JNEW+JINCR2 JOLD1=JOLD1+2 ELSE JNEW=JNEW+1 JOLD1=JOLD1+1 END IF 12 CONTINUE JOLD2=JOLD2+INCR2 15 CONTINUE C C LOG and RECIPROCAL without CONSTANTS C ELSE IF(IKEY.EQ.-8.OR.(IKEY.EQ.-7.AND.IVLIST(4).EQ.0)) THEN DO 20 I=1,ISIZE(1),JINCR IF(DABS(DX(JOLD1)-MISSNG).LT..1D-06) THEN DX(JNEW)=MISSNG ELSE IF(IKEY.EQ.-7) THEN IF(DX(JOLD1).NE.0.) THEN DX(JNEW)=1.D0/DX(JOLD1) ELSE DX(JNEW)=MISSNG END IF ELSE IF(DX(JOLD1).GT.0.) THEN DX(JNEW)=DLOG(DX(JOLD1)) ELSE DX(JNEW)=MISSNG END IF END IF IF(JINCR2.EQ.2) THEN DX(JNEW+1)=DX(JOLD1+1) END IF JNEW=JNEW+JINCR2 JOLD1=JOLD1+JINCR 20 CONTINUE C C RECIPROCAL with CONSTANTS C ELSE IF(IKEY.EQ.-7) THEN DO 25 I=1,ISIZE(1),INCR DO 22 J=1,INCR,JINCR IF(DX(JOLD1).NE.0.AND.DABS(DX(JOLD2)-MISSNG).GT..1D-06) THEN DX(JNEW)=DX(JOLD2)/DX(JOLD1) ELSE DX(JNEW)=MISSNG END IF IF(JINCR2.EQ.2) THEN DX(JNEW+1)=DX(JOLD1+1) END IF JNEW=JNEW+JINCR2 JOLD1=JOLD1+JINCR 22 CONTINUE JOLD2=JOLD2+1 25 CONTINUE C C COLLAPSE C ELSE IF(IKEY.EQ.-21) THEN C C First, save current indices C JOLD1S=JOLD1 JOLD2S=JOLD2 JNEWS=JNEW J2TOP=JOLD2+INCR2*ISIZE(2)-1 DO 40 I=1,ISIZE(1),INCR DO 38 J=1,INCR,JINCR IF(.NOT.ICHECK(DX(JOLD2),X1))GO TO 97 C C First check if cell does not need collapsing, including instances C where second variable is negative, and copy C IF(DABS(DX(JOLD2)-MISSNG).LT..1D-06.OR. . DX(JOLD2).LT..1D-06) THEN DX(JNEW)=DX(JOLD1) IF(JINCR.EQ.2.AND.JINCR2.EQ.2) THEN DX(JNEW+1)=DX(JOLD1+1) END IF ELSE C C Next, check if previously collapsed C IF(JOLD2S.LT.JOLD2) THEN DO 27 K=JOLD2S,JOLD2-1,INCR2 IF(DABS(DX(JOLD2)-DX(K)).LT..1D-06)GO TO 35 27 CONTINUE END IF C C Accumulate sum(s) of matching cells, including sign flips C e.g., -1 with 1 etc. C XV1=DX(JOLD1) IF(JINCR.EQ.2)XV2=DX(JOLD1+1) DO 29 K=JOLD2S,J2TOP,INCR2 IF(K.EQ.JOLD2)GO TO 29 IF(DABS(DX(JOLD2)-DX(K)).LT..1D-06.OR. . DABS(DX(JOLD2)+DX(K)).LT..1D-06) THEN L=((K-JOLD2S)/INCR2)*JINCR+JOLD1S IF(DABS(DX(L)-MISSNG).LT..1D-06) THEN XV1=MISSNG XV2=0 ELSE IF(DABS(XV1-MISSNG).GT..1D-06) THEN XV1=XV1+DX(L) IF(JINCR.EQ.2)XV2=XV2+DX(L+1) END IF END IF 29 CONTINUE C C Store sum in matching cells, positive signs only C DO 31 K=JOLD2S,J2TOP,INCR2 IF(DABS(DX(JOLD2)-DX(K)).LT..1D-06) THEN L=((K-JOLD2S)/INCR2)*JINCR2+JNEWS DX(L)=XV1 IF(JINCR.EQ.2.AND.JINCR2.EQ.2)DX(L+1)=XV2 END IF 31 CONTINUE 35 CONTINUE END IF JNEW=JNEW+JINCR2 JOLD1=JOLD1+JINCR 38 CONTINUE JOLD2=JOLD2+INCR2 40 CONTINUE END IF C C Increment IOLD1, INEW, and, C for PAIRED ADD, SUBTRACT, MULTIPY, and DIVIDE - IOLD2 C IOLD1=IOLD1+1 INEW=INEW+1 IF(IKEY.GE.-12.AND.IKEY.LE.-9)IOLD2=IOLD2+1 GO TO 5 90 CONTINUE WRITE(U6,100) GO TO 99 92 CONTINUE WRITE(U6,102) GO TO 99 93 CONTINUE WRITE(U6,103) GO TO 99 94 CONTINUE WRITE(U6,104) GO TO 99 95 CONTINUE WRITE(U6,105)ISIZE(1),ISIZE(NILIST) GO TO 99 96 CONTINUE WRITE(U6,106) GO TO 99 97 CONTINUE WRITE(U6,107) 99 CONTINUE IERROR=1 RETURN END C SUBROUTINE RAOSH(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT,DX, . MTYPE,MTRAN,IX,ITRANS,IERROR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*), . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR DOUBLE PRECISION DID(NID),DX(*) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL INTEGER MATSIZ EXTERNAL MATSIZ DOUBLE PRECISION MISSNG LOGICAL ENDFLE DATA MISSNG/-98765.432109D0/ 200 FORMAT(' RAO_SHAO: MUST CALL WITH MODIFY AND OLD VARIABLES') 201 FORMAT(' RAO_SHAO: MISMATCHING MATRICES') 202 FORMAT(' RAO_SHAO: FINAL DIMENSION MUST BE 2') 203 FORMAT(' RAO_SHAO: WRONG OLD VARIABLE TYPE') C C Establish NCELL, the number of imputation cells. C IF(IVLIST(7).GE.1) THEN NCELL=IX(1) ELSE NCELL=1 END IF IF(IFIRST.EQ.1) THEN C C Check for OLD and MODIFY variables only. C IF(IVLIST(3).GT.0.OR.IVLIST(1).EQ.0.OR.IVLIST(2).EQ.0) THEN WRITE(U6,200) GO TO 99 END IF IF(IVLIST(1).NE.1.AND.IVLIST(1).NE.IVLIST(2)) THEN GO TO 98 END IF C C Check that each final dimension is 2 C DO 2 I=1,IVLIST(1)+IVLIST(2) J=DIMPNT(I)+DIMX(DIMPNT(I)) IF(DIMX(J).NE.2) THEN WRITE(U6,202) GO TO 99 END IF 2 CONTINUE C C Now check that the sizes of matrices appear appropriate. C Determine the total storage that will be needed. C IOLD=1 INEW=IVLIST(1)+1 N=0 DO 4 I=1,IVLIST(2) NOLD=MATSIZ(DIMX(DIMPNT(IOLD)),MTYPE(IOLD),MTRAN(IOLD)) NNEW=MATSIZ(DIMX(DIMPNT(INEW)),MTYPE(INEW),MTRAN(INEW)) IF((MTYPE(IOLD).EQ.2.OR.MTYPE(IOLD).EQ.8).AND. . MTRAN(IOLD).EQ.0) THEN WRITE(U6,203) GO TO 99 END IF IF((MTYPE(INEW).EQ.2.OR.MTYPE(INEW).EQ.8).AND. . MTRAN(INEW).EQ.0.AND.NOLD*2.EQ.NNEW) THEN NNEW=NNEW/2 END IF IF(NCELL*2*(NOLD/(NCELL*2)).NE.NOLD)GO TO 98 IF(NCELL*2*(NNEW/(NCELL*2)).NE.NNEW)GO TO 98 IF(NOLD*(NNEW/NOLD).NE.NNEW)GO TO 98 N=N+NCELL*(NNEW/NOLD) INEW=INEW+1 IF(IVLIST(1).GT.1)IOLD=IOLD+1 4 CONTINUE C C If constants have been specified, check available space and C reallocate, if necessary. C IF(IVLIST(5).GT.0) THEN IF(IVLIST(5).LT.N) THEN IVLIST(4)=NXPTD IVLIST(5)=N CALL ROOMD(N) END IF END IF END IF IF(IVLIST(5).EQ.0) THEN C C If IVLIST(5)=0, then allocate temporary storage, and, if not full C sample, obtain the stored means from the scratch file. C IVLIST(4)=NXPTD NXPTDS=NXPTD IF(DID(1).NE.0.) THEN CALL SCPOSN(ITRANS,N) CALL ROOMD(N) CALL UNFIN(13,DX(IVLIST(4)),N,ENDFLE) END IF END IF C IOLD=1 INEW=IVLIST(1)+1 C C N is recomputed here, in case DID(1)=0 but IFIRST is not 1. C N=0 J=IVLIST(4) C DO 40 IV=1,IVLIST(2) NOLD=MATSIZ(DIMX(DIMPNT(IOLD)),MTYPE(IOLD),MTRAN(IOLD)) NNEW=MATSIZ(DIMX(DIMPNT(INEW)),MTYPE(INEW),MTRAN(INEW)) IF((MTYPE(INEW).EQ.2.OR.MTYPE(INEW).EQ.8).AND. . MTRAN(INEW).EQ.0.AND.NOLD*2.EQ.NNEW) THEN INCR=2 ELSE INCR=1 END IF C C For full sample, allocate the space if not already allocated. C NVAL is the number of values that need to be computed and C stored. C NVAL=NCELL*(NNEW/(NOLD*INCR)) N=N+NVAL IF(DID(1).EQ.0.) THEN IF(IVLIST(5).EQ.0) THEN CALL ROOMD(NVAL) END IF END IF C C NNEWC represents the length of the vector of values to be C stored for each imputation cell. NC is the number of cells C of the modified variable that are imputed from the same C imputation cell. C NNEWC=NVAL/NCELL NC=NOLD/(NCELL*2) JOLD=DXPNT(IOLD) DO 37 ICELL=1,NCELL JNEW=DXPNT(INEW)+(ICELL-1)*NNEW/(2*NCELL) DO 35 NEWC=1,NNEWC JOLDT=JOLD JNEWT=JNEW TV=0.D0 TN=0.D0 DO 8 I=1,NC IF(DABS(TV-MISSNG).GT..1D-6) THEN IF(DABS(DX(JNEWT)-MISSNG).GT..1D-6) THEN TV=TV+DX(JNEWT) ELSE TV=MISSNG END IF END IF IF(DABS(TN-MISSNG).GT..1D-6) THEN IF(DABS(DX(JOLDT)-MISSNG).GT..1D-6) THEN TN=TN+DX(JOLDT) ELSE TN=MISSNG END IF END IF JNEWT=JNEWT+INCR*NNEWC JOLDT=JOLDT+1 8 CONTINUE C C Compute the mean within the imputation cell. C IF(DABS(TV-MISSNG).GT..1D-6) THEN IF(DABS(TN-MISSNG).GT..1D-6) THEN IF(TN.EQ.0.) THEN TV=MISSNG ELSE TV=TV/TN END IF ELSE TV=MISSNG END IF END IF C C For the full sample, simply store the mean. C IF(DID(1).EQ.0.) THEN DX(J)=TV ELSE C C For other replicates, subtract the full sample mean for the C imputation cell from the mean for this replicate, then C adjust each of the corresponding cells. C IF(DABS(TV-MISSNG).GT..1D-6) THEN IF(DABS(DX(J)-MISSNG).GT..1D-6) THEN TV=TV-DX(J) ELSE TV=MISSNG END IF END IF JOLDT=JOLD+NOLD/2 JNEWT=JNEW+NNEW/2 DO 18 I=1,NC IF(DX(JOLDT).NE.0.) THEN IF(DABS(DX(JNEWT)-MISSNG).GT..1D-6) THEN IF(DABS(TV-MISSNG).GT..1D-6) THEN DX(JNEWT)=DX(JNEWT)+DX(JOLDT)*TV ELSE DX(JNEWT)=MISSNG END IF END IF END IF JNEWT=JNEWT+INCR*NNEWC JOLDT=JOLDT+1 18 CONTINUE END IF J=J+1 JNEW=JNEW+INCR 35 CONTINUE JOLD=JOLD+NC 37 CONTINUE INEW=INEW+1 IF(IVLIST(1).GT.1)IOLD=IOLD+1 40 CONTINUE IF(DID(1).EQ.0.) THEN IF(IVLIST(5).EQ.0) THEN WRITE(13)ITRANS,N CALL UNFOUT(13,DX(IVLIST(4)),N) END IF END IF C C If IVLIST(5)=0, have been reusing temporary storage. Setting C NXPTD=NXPTDS frees up temporary space. C IF(IVLIST(5).EQ.0) THEN NXPTD=NXPTDS END IF RETURN 98 CONTINUE WRITE(U6,201) 99 CONTINUE IERROR=1 RETURN END C SUBROUTINE SAVEFL(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MTYPE,MTRAN,IKEY,ITRANS,IERROR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*), . MTYPE(*),MTRAN(*),IKEY,ITRANS,IERROR DOUBLE PRECISION DID(NID),DX(*) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL INTEGER MATSIZ EXTERNAL MATSIZ DOUBLE PRECISION MISSNG LOGICAL ENDFLE DATA MISSNG/-98765.432109D0/ 100 FORMAT(' SAVEFULL/MODIFYREPF ERROR: MUST CALL WITH MODIFY ' .,'VARIABLES') 102 FORMAT(' MODIFYREPF REQUIRES REAL OR DERIVED') C C Check for MODIFY variables only. C IF(IFIRST.EQ.1) THEN IF(IVLIST(1)+IVLIST(3).GT.0.OR.IVLIST(2).EQ.0) THEN WRITE(U6,100) GO TO 99 END IF END IF C C Obtain the total length, N, of the matrices. C IF(IFIRST.EQ.1.OR.IVLIST(5).EQ.0) THEN N=0 DO 5 I=1,IVLIST(2) N=N+MATSIZ(DIMX(DIMPNT(I)),MTYPE(I),MTRAN(I)) 5 CONTINUE END IF C C If there has been an attempt to allocate some storage for them, C revise the storage for constants, if necessary. C IF(IFIRST.EQ.1) THEN IF(IVLIST(5).GT.0) THEN IF(N.GT.IVLIST(5)) THEN IVLIST(5)=N IVLIST(4)=NXPTD CALL ROOMD(N) END IF END IF C C Check the variable types for MODIFYREP C IF(IKEY.EQ.-22) THEN DO 7 I=1,IVLIST(2) IF(MTYPE(I).NE.1.AND.MTYPE(I).NE.11) THEN WRITE(U6,102) GO TO 99 END IF 7 CONTINUE END IF END IF IF(IVLIST(5).EQ.0) THEN NXPTDS=NXPTD CALL ROOMD(N) IVLIST(4)=NXPTDS IF(DID(1).GT.0.) THEN CALL SCPOSN(ITRANS,NCELL) CALL UNFIN(13,DX(IVLIST(4)),NCELL,ENDFLE) END IF END IF J=IVLIST(4) C C N is recomputed here, in case DID(1)=0 but IFIRST is not 1. C N=0 DO 20 I=1,IVLIST(2) K=MATSIZ(DIMX(DIMPNT(I)),MTYPE(I),MTRAN(I)) JJ=DXPNT(I) IF(DID(1).EQ.0) THEN C C Storage of full-sample values C N=N+K DO 12 L=1,K DX(J)=DX(JJ) J=J+1 JJ=JJ+1 12 CONTINUE ELSE IF(IKEY.EQ.-14) THEN C C Restoration of full-sample values for SAVEFULL C DO 14 L=1,K DX(JJ)=DX(J) JJ=JJ+1 J=J+1 14 CONTINUE ELSE C C Adjustment for MODIFYREPF C DO 16 L=1,K IF(DABS(DX(J)-MISSNG).LT..1D-6.OR.DABS(DX(JJ)-MISSNG).LT. . .1D-6.OR.DX(J).EQ.0.) THEN DX(JJ)=MISSNG ELSE DX(JJ)=DX(JJ)/DX(J) END IF JJ=JJ+1 J=J+1 16 CONTINUE END IF 20 CONTINUE IF(DID(1).EQ.0.) THEN IF(IVLIST(5).EQ.0) THEN WRITE(13)ITRANS,N CALL UNFOUT(13,DX(IVLIST(4)),N) END IF END IF C C If IVLIST(5)=0, have been reusing temporary storage. Setting C NXPTD=NXPTDS frees up temporary space. C IF(IVLIST(5).EQ.0) THEN NXPTD=NXPTDS END IF RETURN 99 CONTINUE IERROR=1 RETURN END SUBROUTINE GLUE(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MTYPE,MTRAN,IX,IERROR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*), . MTYPE(*),MTRAN(*),IX(*) DOUBLE PRECISION DID(NID),DX(*) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 INTEGER MATSIZ EXTERNAL MATSIZ 100 FORMAT(' GLUE ERROR: CALL WITH OLD VARS AND ONE NEW OR MODIFY VAR' .) 101 FORMAT(' GLUE ERROR: WRONG NUMBER OF CONSTANTS') 102 FORMAT(' GLUE ERROR: MISSING, CROSSED REAL MUST NOT BE MIXED WITH' .,' OTHER TYPES') 103 FORMAT(' GLUE ERROR: CONSTANTS NOT PROPORTIONAL') 104 FORMAT(' GLUE ERROR: SIZE MISMATCH') IF((MTYPE(1).EQ.2.OR.MTYPE(1).EQ.8).AND.MTRAN(1).EQ.0) THEN IMULT=2 ELSE IMULT=1 END IF NSLICE=0 IF(IVLIST(7).EQ.1) THEN IF(IX(1).LT.0)NSLICE=-IX(1) END IF IF(IFIRST.EQ.1) THEN IF(IVLIST(1).LE.1.OR.IVLIST(2)+IVLIST(3).NE.1) THEN WRITE(U6,100) GO TO 98 END IF IF(NSLICE.EQ.0.AND.IVLIST(7).GT.0.AND.IVLIST(1).NE.IVLIST(7)) . THEN WRITE(U6,101) GO TO 98 END IF K=0 DO 2 I=1,IVLIST(1) K=K+MATSIZ(DIMX(DIMPNT(I)),MTYPE(I),MTRAN(I)) IF(IMULT.EQ.2) THEN IF((MTYPE(I).EQ.2.OR.MTYPE(I).EQ.8).AND.MTRAN(I).EQ.0)GO TO 2 ELSE IF((MTYPE(I).NE.2.AND.MTYPE(I).NE.8).OR.MTRAN(I).NE.0)GO TO 2 END IF WRITE(U6,102) GO TO 98 2 CONTINUE I=IVLIST(1)+1 IF(K.NE.MATSIZ(DIMX(DIMPNT(I)),MTYPE(I),MTRAN(I))) THEN WRITE(U6,104) GO TO 98 END IF IF(IVLIST(7).GT.0) THEN KK=MATSIZ(DIMX(DIMPNT(1)),MTYPE(1),MTRAN(1)) IF(NSLICE.GT.0) THEN IF((KK/(IMULT*NSLICE))*NSLICE*IMULT.NE.KK)GO TO 93 IK=NSLICE ELSE IC=IMULT*IX(1) IF(IC.LE.0) GO TO 93 IK=KK/IC IF(IK*IC.NE.KK) GO TO 93 END IF DO 4 I=2,IVLIST(1) KK=MATSIZ(DIMX(DIMPNT(I)),MTYPE(I),MTRAN(I)) IF(NSLICE.GT.0) THEN IF((KK/(IMULT*NSLICE))*NSLICE*IMULT.NE.KK)GO TO 93 ELSE IC=IMULT*IX(I) IF(IK*IC.NE.KK)GO TO 93 END IF 4 CONTINUE END IF END IF I=IVLIST(1)+1 J=DXPNT(I) IF(IVLIST(7).GT.0) THEN IF(NSLICE.GT.0) THEN IK=NSLICE ELSE KK=MATSIZ(DIMX(DIMPNT(1)),MTYPE(1),MTRAN(1)) IC=IMULT*IX(1) IK=KK/IC END IF DO 10 II=1,IK DO 8 I=1,IVLIST(1) IF(NSLICE.GT.0) THEN IC=MATSIZ(DIMX(DIMPNT(I)),MTYPE(I),MTRAN(I))/NSLICE ELSE IC=IMULT*IX(I) END IF JJ=IC*(II-1)+DXPNT(I) DO 6 L=1,IC DX(J)=DX(JJ) J=J+1 JJ=JJ+1 6 CONTINUE 8 CONTINUE 10 CONTINUE ELSE DO 20 I=1,IVLIST(1) K=MATSIZ(DIMX(DIMPNT(I)),MTYPE(I),MTRAN(I)) JJ=DXPNT(I) DO 15 L=1,K DX(J)=DX(JJ) J=J+1 JJ=JJ+1 15 CONTINUE 20 CONTINUE END IF RETURN 93 CONTINUE WRITE(U6,103) 98 CONTINUE IERROR=1 RETURN END SUBROUTINE RPRINT(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,INFRMT,IX,MV,IERROR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MVAR=10000) PARAMETER (MLEVEL=10000) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),MV(*),IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 INFRMT(*) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 INTEGER MATSIZ EXTERNAL MATSIZ C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP C CHARACTER*11 VTYPE(7) CHARACTER*26 CTEMP DOUBLE PRECISION MISSNG,T DATA MISSNG/-98765.432109D0/ DATA VTYPE / 'MEAN ','TOTAL ','PERCENTS ', . 'VALUE ','PROPORTION ','WEIGHTED N ','2-WAY PCNT '/ 100 FORMAT(' RPRINT ERROR: MUST BE CALLED WITH OLD VARIABLES') 101 FORMAT(/,' RPRINT: REPLICATE',I5) 102 FORMAT(12X,A12,': ',A11,2X) 103 FORMAT('Sample N (wtd) for block',I4,12X) 104 FORMAT(I1) 105 FORMAT(I2) 106 FORMAT(1X,A80) 107 FORMAT(1X,A40) IF(IVLIST(7).GT.0) THEN IF(IX(1).GE.0) THEN IF(DID(1).GT.IX(1)) RETURN END IF END IF IF(IFIRST.EQ.1) THEN IF(IVLIST(1).EQ.0.OR.IVLIST(2)+IVLIST(3).GT.0) THEN WRITE(U6,100) IERROR=1 RETURN END IF END IF I=DID(1)+.5D-1 WRITE(U6,101)I IF(IVLIST(7).GT.1) THEN IF(IX(2).GT.0) THEN LDEFLT=IX(2) IF(LDEFLT.GT.26) THEN LDEFLT=26 ELSE IF(LDEFLT.LT.4) THEN LDEFLT=4 END IF ELSE LDEFLT=8 END IF ELSE LDEFLT=8 END IF DO 50 I=1,IVLIST(1) N=MATSIZ(DIMX(DIMPNT(I)),MTYPE(I),MTRAN(I)) IP=1 T=1.D01 J=DXPNT(I) DO 4 K=1,N 2 CONTINUE IF(DABS(DX(J)-MISSNG).GT..1D-6) THEN IF(DABS(DX(J)).GE.T) THEN IF(IP.LT.23) THEN IP=IP+1 T=T*1.D01 GO TO 2 END IF END IF END IF J=J+1 4 CONTINUE IF(IP+3.GT.LDEFLT) THEN LEN=IP+3 ELSE LEN=LDEFLT END IF IF(IVLIST(7).GT.0) THEN IF(IX(3).GE.0) THEN IF(IP+IX(3)+3.GT.LEN) THEN LEN=IP+IX(3)+3 IF(LEN.GT.26)LEN=26 END IF END IF END IF ITTYPE=MTRAN(I) IF(ITTYPE.NE.9) THEN MT=MTYPE(I) IF(ITTYPE.EQ.8) THEN IFLAG=6 ELSE IF(MT.EQ.11.OR.MT.EQ.13.OR.MT.EQ.19) THEN IFLAG=4 ELSE IF(ITTYPE.EQ.0.OR.ITTYPE.EQ.2.OR.ITTYPE.EQ.4) THEN IFLAG=2 ELSE IF(ITTYPE.EQ.5) THEN IFLAG=7 ELSE IF(ITTYPE.EQ.1.OR.ITTYPE.EQ.3) THEN IF(MT.EQ.3.OR.MT.EQ.9) THEN IFLAG=3 ELSE IFLAG=1 END IF ELSE IF(ITTYPE.EQ.6.OR.ITTYPE.EQ.7) THEN IFLAG=5 ELSE IF(ITTYPE.EQ.10) THEN IFLAG=4 END IF WRITE(INFRMT(1)(1:40),102)VNAME(MV(I)),VTYPE(IFLAG) ELSE WRITE(INFRMT(1)(1:40),103)MV(I) END IF INFRMT(1)(81:82)='(F' IPOS=83 IF(LEN.GE.10) THEN WRITE(INFRMT(1)(83:84),105)LEN IPOS=85 ELSE WRITE(INFRMT(1)(83:83),104)LEN IPOS=84 END IF INFRMT(1)(IPOS:IPOS)='.' IPOS=IPOS+1 K=LEN-IP-3 IF(IVLIST(7).GT.0) THEN IF(IX(3).GE.0) THEN K=IX(3) END IF END IF IF(K.LE.9) THEN WRITE(INFRMT(1)(IPOS:IPOS),104)K IPOS=IPOS+1 ELSE WRITE(INFRMT(1)(IPOS:IPOS+1),105)K IPOS=IPOS+2 END IF INFRMT(1)(IPOS:IPOS)=')' IFEND=IPOS IF(N*LEN.LE.40) THEN IPOS=41 DO 6 K=0,N-1 IF(DABS(DX(DXPNT(I)+K)-MISSNG).LE..1D-06) THEN DO 5 IC=1,LEN-3 INFRMT(1)(IPOS:IPOS)=' ' IPOS=IPOS+1 5 CONTINUE INFRMT(1)(IPOS:IPOS+2)='(M)' IPOS=IPOS+3 ELSE WRITE(CTEMP,FMT=INFRMT(1)(81:IFEND))DX(DXPNT(I)+K) INFRMT(1)(IPOS:IPOS+LEN-1)=CTEMP(1:LEN) C WRITE(INFRMT(1)(IPOS:IPOS+LEN-1),FMT=INFRMT(1)(81:IFEND)) C . DX(DXPNT(I)+K) IPOS=IPOS+LEN END IF 6 CONTINUE IF(IPOS.LT.81) THEN K=IPOS DO 7 IPOS=K,80 INFRMT(1)(IPOS:IPOS)=' ' 7 CONTINUE END IF WRITE(U6,106)INFRMT(1)(1:80) ELSE WRITE(U6,107)INFRMT(1)(1:40) NC=N/MSIZE(I) J=DXPNT(I) IF(MSIZE(I)*LEN.GE.81) THEN NC2=1 NLINE2=80/LEN ELSE NC2=80/(MSIZE(I)*LEN) NLINE2=MSIZE(I)*NC2 END IF DO 25 IL=1,NC,NC2 IF(IL+NC2.GT.NC) THEN NC3=NC-IL+1 ELSE NC3=NC2 END IF NLINE=MSIZE(I)*NC3 DO 20 IC2=1,NLINE,NLINE2 IPOS=1 IF(IC2+NLINE2.GT.NLINE) THEN NLINE3=NLINE-IC2+1 ELSE NLINE3=NLINE2 END IF DO 14 M=1,NLINE3 IF(DABS(DX(J)-MISSNG).LE..1D-06) THEN DO 12 IC=1,LEN-3 INFRMT(1)(IPOS:IPOS)=' ' IPOS=IPOS+1 12 CONTINUE INFRMT(1)(IPOS:IPOS+2)='(M)' IPOS=IPOS+3 ELSE WRITE(CTEMP,FMT=INFRMT(1)(81:IFEND))DX(J) INFRMT(1)(IPOS:IPOS+LEN-1)=CTEMP(1:LEN) C WRITE(INFRMT(1)(IPOS:IPOS+LEN-1),FMT=INFRMT(1)(81:IFEND)) C . DX(J) IPOS=IPOS+LEN END IF J=J+1 14 CONTINUE IF(IPOS.LT.81) THEN K=IPOS DO 16 IPOS=K,80 INFRMT(1)(IPOS:IPOS)=' ' 16 CONTINUE END IF WRITE(U6,106)INFRMT(1)(1:80) 20 CONTINUE 25 CONTINUE END IF 50 CONTINUE RETURN END C SUBROUTINE RWRITE(IKEY,DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MTYPE,MTRAN,INFRMT,IX,ITRANS,IERROR) C IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*), . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR CHARACTER *128 INFRMT(*) DOUBLE PRECISION DID(NID),DX(*) C DOUBLE PRECISION DTEMP(3) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL INTEGER MATSIZ EXTERNAL MATSIZ LOGICAL ENDFLE C 100 FORMAT(3D22.14) 202 FORMAT(/,' PREMATURE END OF FILE',I3) 203 FORMAT(/,' NSLICE IGNORED') 204 FORMAT(/,' NSLICE/SLICELENGTH ERROR') C C If a format is not specified, or if BINARYREAD or BINARYWRITE C then some options do not apply. Distinguish by IPATH=1 C vs. IPATH=2 C IF(IVLIST(6).EQ.0.OR.IKEY.EQ.-19.OR.IKEY.EQ.-20) THEN IF(IFIRST.EQ.1) THEN IF(IX(4).GT.0) THEN WRITE(U6,203) IERROR=2 IX(4)=0 END IF END IF IPATH=1 NSLICE=0 C C Until version 95.08, binaryread and binarywrite used to output C an initial ID record. In practice, this made the subroutines C less flexible. The code is commented below C C IF(IKEY.EQ.-17) THEN C WRITE(UNIT=IX(1),FMT=100)(DID(I),I=1,NID) C ELSE C DO 1 I=1,NID,3 C IF(I+2.GT.NID) THEN C J=NID-I+1 C ELSE C J=3 C END IF C IF(IKEY.EQ.-18) THEN C READ(UNIT=IX(1),FMT=100)(DTEMP(K),K=1,J) C ELSE IF(IKEY.EQ.-19) THEN C I2=I+J-1 C WRITE(UNIT=IX(1))(DID(K),K=I,I2) C ELSE C READ(UNIT=IX(1))(DTEMP(K),K=1,J) C END IF C 1 CONTINUE C END IF C ELSE IPATH=2 END IF IF(IKEY.EQ.-17.OR.IKEY.EQ.-19) THEN C C For REPWRITE or BINARYWRITE, reference the OLD variables. C IV1=1 IV2=IVLIST(1) ELSE C C For REPREAD or BINARYREAD, reference MODIFY or new variables. C IV1=IVLIST(1)+1 IV2=IV1+IVLIST(2)+IVLIST(3)-1 END IF C C Compute in N the total length for all variables. C N=0 IF(IPATH.EQ.2) THEN C C For formatted output, determine nslice C NSLICE=IX(4) IF(IFIRST.EQ.1) THEN C C If SLICELENGTH has been specified, check that the number of C lengths matches the number of variables. C IF(IVLIST(7).GT.4) THEN IF(IV2-IV1+1.NE.IVLIST(7)-4)GO TO 94 END IF END IF IF(IVLIST(7).GT.4.AND.NSLICE.EQ.0) THEN C C If SLICELENGTH has been specified, compute NSLICE from the first C matrix. C IF(IX(5).LE.0)GO TO 94 NSLICE=MATSIZ(DIMX(DIMPNT(IV1)),MTYPE(IV1),MTRAN(IV1))/IX(5) IF(NSLICE.LE.0)GO TO 94 END IF END IF DO 25 IV=IV1,IV2 I=MATSIZ(DIMX(DIMPNT(IV)),MTYPE(IV),MTRAN(IV)) N=N+I IF(IFIRST.EQ.1.AND.IPATH.EQ.2) THEN IF(NSLICE.GT.0) THEN IF(NSLICE*(I/NSLICE).NE.I)GO TO 94 IF(IVLIST(7).GT.4) THEN C C If SLICELENGTH has been specified, check that the length is C consistent with NSLICE. C IF(IX(IV-IV1+5)*NSLICE.NE.I)GO TO 94 END IF END IF END IF 25 CONTINUE C C IWRITE - keeps track of whether this case should be written C IREAD - for path=1, keeps track of read status C IWRITE=0 IREAD=0 NXPTDS=NXPTD IF(NSLICE.EQ.0)NSLICE=1 C C For IPATH=1, will need N space if reading and CONSTANTS or C FULL options are used. C On the first call, check that enough space has been set aside. C If there was an attempt to allocate space, reallocate if REPREAD. C IF(IPATH.EQ.2.OR.(IPATH.EQ.1.AND.(IKEY.EQ.-18.OR.IKEY.EQ.-20) . .AND.(IX(3).EQ.1.OR.IX(3).EQ.2))) THEN IF(IFIRST.EQ.1) THEN IF(N.GT.IVLIST(5)) THEN IF(IVLIST(5).GT.0.AND.(IKEY.EQ.-18.OR.IKEY.EQ.-20)) THEN IVLIST(5)=N IVLIST(4)=NXPTD CALL ROOMD(N) ELSE C C For REPWRITE, reset IVLIST(5)=0 if not enough space in CONSTANTS, C so that temporary space will be allocated each time. C IVLIST(5)=0 END IF END IF END IF C C If IVLIST(5)=0, allocate temporary storage C IF(IVLIST(5).EQ.0) THEN CALL ROOMD(N) IVLIST(4)=NXPTDS END IF END IF C C If OPTION CONSTANT, then either read here or set IWRITE. C IF(IFIRST.EQ.1.AND.IX(3).EQ.2) THEN IF(IKEY.EQ.-18.OR.IKEY.EQ.-20) THEN IF(IPATH.EQ.1) THEN IREAD=1 ELSE CALL DREAD(IX(1),DX(IVLIST(4)),N,INFRMT,IVLIST(6),IX(2)) END IF IF(IVLIST(5).EQ.0) THEN IVLIST(5)=N END IF ELSE IF(IKEY.EQ.-17.OR.IKEY.EQ.-19) THEN IWRITE=1 END IF ELSE IF(IX(3).EQ.0.OR.IX(3).EQ.3.OR.IX(3).EQ.4) THEN C C OPTION REPLICATE (default) read/write for each replicate. C IF(IX(2).EQ.1) THEN IF(IKEY.EQ.-18.OR.IKEY.EQ.-20) THEN C C OPTION BYREPEAT - rewind file if replicate 0 of second or C later BY group. C IF(IX(3).EQ.4) THEN IF(IFIRST.EQ.0.AND.DID(1).EQ.0.) THEN REWIND(UNIT=IX(1)) END IF END IF IF(IPATH.EQ.1) THEN IREAD=1 ELSE CALL DREAD(IX(1),DX(IVLIST(4)),N,INFRMT,IVLIST(6),IX(2)) C C If attempt read but hit end of file, then error off C IF(IX(2).EQ.0) THEN WRITE(U6,202) IERROR=1 RETURN END IF END IF ELSE IF(IKEY.EQ.-17.OR.IKEY.EQ.-19) THEN IWRITE=1 END IF END IF ELSE IF(IX(3).EQ.1) THEN C C Under FULL, read/write only for full samples. C IF(IX(2).EQ.1.AND.DID(1).EQ.0.D0) THEN IF(IKEY.EQ.-18.OR.IKEY.EQ.-20) THEN IF(IPATH.EQ.1) THEN IREAD=1 ELSE CALL DREAD(IX(1),DX(IVLIST(4)),N,INFRMT,IVLIST(6),IX(2)) C C If only temporary storage is used for REPREAD, then write the matrix C to the scratch file, for each set of full sample values. C IF(IVLIST(5).EQ.0) THEN WRITE(13)ITRANS,N CALL UNFOUT(13,DX(IVLIST(4)),N) END IF END IF ELSE IF(IKEY.EQ.-17.OR.IKEY.EQ.-19) THEN IWRITE=1 END IF IF(IX(2).EQ.0) THEN WRITE(U6,202) IERROR=1 RETURN END IF ELSE IF((IKEY.EQ.-18.OR.IKEY.EQ.-20).AND.IVLIST(5).EQ.0) THEN C C If only temporary storage is used for REPREAD, then read the matrix C for the full sample values back in from the scratch file. C CALL SCPOSN(ITRANS,NCELL) CALL UNFIN(13,DX(IVLIST(4)),N,ENDFLE) END IF END IF C C IF(IPATH.EQ.1.AND.(IREAD.EQ.1.OR.IWRITE.EQ.1)) THEN IF(IREAD.EQ.1.AND.(IX(3).EQ.1.OR.IX(3).EQ.2)) THEN J=IVLIST(4) END IF DO 20 IV=IV1,IV2 IBASE=DXPNT(IV)-1 NM=MATSIZ(DIMX(DIMPNT(IV)),MTYPE(IV),MTRAN(IV)) C C For REPWRITE or REPREAD, can input or output in single line C IF(IKEY.EQ.-17) THEN WRITE(UNIT=IX(1),FMT=100)(DX(IBASE+I),I=1,NM) ELSE IF(IKEY.EQ.-18) THEN READ(UNIT=IX(1),FMT=100)(DX(IBASE+I),I=1,NM) ELSE C C Under BINARYREAD or BINARYWRITE, output is broken into segments of C length 32. C DO 15 I1=1,NM,32 IF(I1+31.GT.NM) THEN I2=NM ELSE I2=I1+31 END IF IF(IKEY.EQ.-19) THEN WRITE(UNIT=IX(1))(DX(IBASE+I),I=I1,I2) ELSE READ(UNIT=IX(1))(DX(IBASE+I),I=I1,I2) END IF 15 CONTINUE END IF IF(IREAD.EQ.1.AND.(IX(3).EQ.1.OR.IX(3).EQ.2)) THEN DO 17 I1=1,NM DX(J)=DX(IBASE+I1) J=J+1 17 CONTINUE END IF 20 CONTINUE IF(IREAD.EQ.1.AND.IX(3).EQ.1) THEN C C Under FULL, read/write only for full samples. C IF(IVLIST(5).EQ.0) THEN WRITE(13)ITRANS,N CALL UNFOUT(13,DX(IVLIST(4)),N) END IF END IF END IF C C For REPREAD under format, always copy values back to matrices, C whether or not they have just been read. C IF((IKEY.EQ.-18.OR.IKEY.EQ.-20).AND. . (IPATH.EQ.2.OR.(IPATH.EQ.1.AND.IREAD.EQ.0))) THEN IF(NSLICE.EQ.0)NSLICE=1 I=IVLIST(4) DO 48 ISLICE=1,NSLICE DO 45 IV=IV1,IV2 N1=MATSIZ(DIMX(DIMPNT(IV)),MTYPE(IV),MTRAN(IV))/NSLICE J=DXPNT(IV)+N1*(ISLICE-1) DO 40 K=1,N1 DX(J)=DX(I) I=I+1 J=J+1 40 CONTINUE 45 CONTINUE 48 CONTINUE ELSE IF(IWRITE.EQ.1.AND.IPATH.EQ.2) THEN C C Under REPWRITE, write only if appropriate. C I=IVLIST(4) DO 58 ISLICE=1,NSLICE DO 55 IV=IV1,IV2 N1=MATSIZ(DIMX(DIMPNT(IV)),MTYPE(IV),MTRAN(IV))/NSLICE J=DXPNT(IV)+N1*(ISLICE-1) DO 50 K=1,N1 DX(I)=DX(J) I=I+1 J=J+1 50 CONTINUE 55 CONTINUE 58 CONTINUE CALL DWRITE(IX(1),DX(IVLIST(4)),N,INFRMT,IVLIST(6)) END IF C C If IVLIST(5) is still 0, only temporary storage has been used. C By resetting NXPTD, the temporary storage will be freed by C TCREA2. Otherwise, changes to NXPTD will result in permanent C storage. C IF(IVLIST(5).EQ.0) THEN NXPTD=NXPTDS END IF RETURN 94 CONTINUE WRITE(U6,204) IERROR=1 RETURN END C INTEGER FUNCTION MATSIZ(DIMX,MTYPE,MTRAN) INTEGER DIMX(*),MTYPE,MTRAN IF((MTYPE.EQ.2.OR.MTYPE.EQ.8).AND.MTRAN.EQ.0) THEN MATSIZ=2 ELSE MATSIZ=1 END IF NK=DIMX(1) IF(NK.GT.0) THEN DO 7 IK=2,NK+1 MATSIZ=MATSIZ*DIMX(IK) 7 CONTINUE END IF RETURN END SUBROUTINE DREAD(IU,DX,N,INFRMT,NF,IFLAG) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER IU,N,NF,IFLAG DOUBLE PRECISION DX(N) CHARACTER*128 INFRMT(NF) READ(UNIT=IU,FMT=INFRMT,END=2)DX GO TO 3 2 CONTINUE IFLAG=0 3 CONTINUE RETURN END C SUBROUTINE DWRITE(IU,DX,N,INFRMT,NF) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER IU,N,NF DOUBLE PRECISION DX(N) CHARACTER*128 INFRMT(NF) WRITE(UNIT=IU,FMT=INFRMT)DX RETURN END C SUBROUTINE VAPPND(DID,NID,IFIRST,IVLIST,DXPNT, . DX,MSIZE,IX,ITRANS,IERROR) C IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IFIRST,IVLIST(7),DXPNT(*),MSIZE(*), . IX(*),ITRANS,IERROR DOUBLE PRECISION DID(NID),DX(*) C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C LOGICAL ENDFLE C 204 FORMAT(/,' PREMATURE END OF FILE',I3) C C IX(1) - FORTRAN unit C IX(2) - 1 unit on end of file (not used) C IX(3) - read option C 0 = not given (i.e., default option) C 1 = FULL C 2 = CONSTANTS C 3 = REPLICATE C 4 = BYREPEAT C IX(4) - ID checking option C IX(5) - ANIDTT - length of ID on file C IX(6) - ATSIZE - total size of matrix C IX(7) - ANRPTT - number of replicates C C N the size of the incoming VPLX data matrix. C N=IX(6) IF(IX(5).GT.N) THEN NSAVE=IX(5) ELSE NSAVE=N END IF NXPTDS=NXPTD C C Will need NSAVE space if reading and CONSTANTS or C FULL options are used. C C On the first call, check that enough space has been set aside. C If there was an attempt to allocate space, reallocate if REPREAD. C IF(IX(3).EQ.1.OR.IX(3).EQ.2) THEN IF(IFIRST.EQ.1) THEN IF(NSAVE.GT.IVLIST(5)) THEN IF(IVLIST(5).GT.0.OR.IX(3).EQ.2) THEN IVLIST(5)=NSAVE IVLIST(4)=NXPTD CALL ROOMD(NSAVE) END IF END IF END IF END IF C C If NSAVE > IVLIST(5), allocate temporary storage C IF(NSAVE.GT.IVLIST(5)) THEN CALL ROOMD(NSAVE) IVLIST(4)=NXPTDS END IF C C IREAD - keeps track of read status C = 0 use previously read values C = 1 read from VPLX file C IREAD=0 C IF(IFIRST.EQ.1.AND.IX(3).EQ.2) THEN C C If OPTION CONSTANT, read only if IFIRST C IREAD=1 ELSE IF(IX(3).EQ.1) THEN C C Under FULL, read only for full samples. C IF(DID(1).EQ.0.D0) THEN IREAD=1 IF(IFIRST.NE.1.AND.IX(7).GT.0) THEN C C SPACE VPLX FILE TO NEXT BY GROUP HERE C DO 2 I=1,IX(7) READ(IX(1),END=94)(DX(IVLIST(4)+J-1),J=1,IX(5)) CALL UNFIN(IX(1),DX(IVLIST(4)),IX(6),ENDFLE) IF(ENDFLE)GO TO 94 2 CONTINUE END IF ELSE IF(NSAVE.GT.IVLIST(5)) THEN C C If only temporary storage is used for REPREAD, then read the matrix C for the full sample values back in from the scratch file. C CALL SCPOSN(ITRANS,NCELL) CALL UNFIN(13,DX(IVLIST(4)),N,ENDFLE) END IF ELSE IF(IX(3).EQ.0.OR.IX(3).EQ.3.OR.IX(3).EQ.4) THEN C C OPTION REPLICATE (default), or BYREPEAT - read for each replicate. C IREAD=1 C C OPTION BYREPEAT - rewind file if replicate 0 of second or C later BY group. PREAMD will allocate space for ids and coefficients: C free up the space. C IF(IX(3).EQ.4) THEN IF(IFIRST.EQ.0.AND.DID(1).EQ.0.) THEN REWIND(UNIT=IX(1)) NXPTD2=NXPTD CALL PREAMD(IX(1)) NXPTD=NXPTD2 END IF END IF END IF C C IF(IREAD.EQ.1) THEN C C READ VPLX FILE C READ(IX(1),END=94)(DX(IVLIST(4)+J-1),J=1,IX(5)) c write(6,*)(DX(IVLIST(4)+J-1),J=1,IX(5)) CALL UNFIN(IX(1),DX(IVLIST(4)),N,ENDFLE) c write(6,*)(dx(j),j=ivlist(4),ivlist(4)+n-1) IF(ENDFLE)GO TO 94 IF(IX(3).EQ.1) THEN C C Under FULL, write full sample. C IF(NSAVE.GT.IVLIST(5)) THEN WRITE(13)ITRANS,N CALL UNFOUT(13,DX(IVLIST(4)),N) END IF END IF END IF K=8 DO 20 IV=1,IVLIST(3) c write(6,*)ix(k),ix(k+1),ix(k+2) KK=DXPNT(IV) L=IVLIST(4)+IX(K)-1 IF(MSIZE(IV).EQ.1) THEN DO 12 J=1,IX(K+2) DX(KK)=DX(L) c write(6,*)kk,l,dx(l) KK=KK+1 L=L+IX(K+1) 12 CONTINUE ELSE DO 16 J=1,IX(K+2) DO 14 JJ=1,MSIZE(IV) DX(KK)=DX(L+JJ-1) c write(6,*)kk,l,dx(l+jj-1) KK=KK+1 14 CONTINUE L=L+IX(K+1) 16 CONTINUE END IF K=K+3 20 CONTINUE C C If NSAVE > IVLIST(5), only temporary storage has been used. C By resetting NXPTD, the temporary storage will be freed by C TCREA2. Otherwise, changes to NXPTD will result in permanent C storage. C IF(NSAVE.GT.IVLIST(5)) THEN NXPTD=NXPTDS END IF RETURN 94 CONTINUE WRITE(U6,204) IERROR=1 RETURN END C C C End of T3.FOR C SUBROUTINE TMOVE1(IS,INC1,ISN,INCN,IP,INC2,IA,NA,ICLBLK,IVP, . ITRANP) IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MAXIDS=10) PARAMETER (IXFLLD=72+3*MAXIDS) C INTEGER NA,IA(3,*) DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) INTEGER SICMUL,IFILL(IXFLLD) COMMON /STPBLK/SICMUL,IFILL C DOUBLE PRECISION TOT,MISSNG DATA MISSNG/-98765.432109D0/ C C Function type C C 0 - Default C 1 - Percent or Mean C 2 - Total C 3 - Percent1 C 4 - Total1 C 5 - Percent2 C 6 - Proportion C 7 - Proportion1 C 8 - N of a variable C 9 - N of a block C 10 - Value of variable, i.e., without indicators C ITRAN=ITRANP IV=IVP IS0=IS INC0=INC1 IF(ITRAN.EQ.8) THEN IF(MTYPE(IV).EQ.1.OR.(MTYPE(IV).EQ.3.AND.MSIZE(IV).EQ.1)) THEN ITRAN=9 IV=ICLBLK IS0=ISN INC0=INCN END IF END IF IF(ITRAN.EQ.9) THEN IS2=IP IC2=INC2 MT=0 ELSE MT=MTYPE(IV) IF(ITRAN.EQ.0.OR.ITRAN.EQ.5.OR.ITRAN.EQ.6.OR.ITRAN.EQ.10.OR. . ((ITRAN.EQ.1.OR.ITRAN.EQ.2).AND. . (MT.EQ.1.OR.MT.EQ.3.OR.MT.EQ.9))) THEN IS2=IP IF(INC2.GT.1) THEN IC2=INC2 ELSE IC2=MSIZE(IV) END IF ELSE IS2=NXPTD IC2=MSIZE(IV) END IF END IF CALL TMOV1A(IS0,INC0,IS2,IC2,ICLBLK,IV,ITRAN,IA,NA,ISIZE) IF(IMERR1.GT.0)RETURN IF(ITRAN.EQ.0.OR.ITRAN.EQ.9.OR.ITRAN.EQ.10.OR. . (ITRAN.EQ.2.AND.(MT.EQ.1.OR.MT.EQ.3.OR.MT.EQ.9))) RETURN IF(ITRAN.EQ.1.OR.ITRAN.EQ.5.OR.ITRAN.EQ.6) THEN IF(MT.EQ.1.OR.(MT.EQ.3.AND.MSIZE(IV).EQ.1)) THEN IS2=NXPTD CALL TMOV1A(ISN,INCN,IS2,1,ICLBLK,ICLBLK,9,IA,NA, . ISIZE1) IF(IMERR1.GT.0)RETURN K=IP KK=NXPTD DO 3 I=1,ISIZE,IC2 IF(DABS(DX(KK)-MISSNG).LT..1D-6) THEN DX(K)=MISSNG ELSE IF(DX(KK).GT.0..AND.DABS(DX(K)-MISSNG).GT..1D-6) THEN DX(K)=DX(K)/DX(KK) IF(MT.EQ.3.AND.ITRAN.EQ.1)DX(K)=100.D0*DX(K) ELSE DX(K)=MISSNG END IF K=K+IC2 KK=KK+1 3 CONTINUE ELSE IF(MT.EQ.2) THEN K=IP IF(INC2.GT.1) THEN IC2P=INC2 ELSE IC2P=1 END IF KK=NXPTD DO 5 I=1,ISIZE,IC2 IF(DABS(DX(KK)-MISSNG).LT..1D-6.AND. . DABS(DX(K)-MISSNG).GT..1D-6) THEN DX(K)=MISSNG ELSE IF(DX(KK+1).GT.0.) THEN DX(K)=DX(KK)/DX(KK+1) ELSE DX(K)=MISSNG END IF K=K+IC2P KK=KK+2 5 CONTINUE ELSE IF(MT.EQ.3) THEN K=IP-1 MS=MSIZE(IV) DO 8 I=1,ISIZE,IC2 TOT=0. DO 6 J=1,MS IF(DABS(DX(K+J)-MISSNG).GT..1D-6) THEN IF(DABS(TOT-MISSNG).GT..1D-6) THEN TOT=TOT+DX(K+J) END IF ELSE TOT=MISSNG END IF 6 CONTINUE DO 7 J=1,MS IF(TOT.LE.0.) THEN DX(K+J)=MISSNG ELSE IF(ITRAN.EQ.1) THEN DX(K+J)=100.D0*DX(K+J)/TOT ELSE DX(K+J)=DX(K+J)/TOT END IF END IF 7 CONTINUE K=K+IC2 8 CONTINUE ELSE IF(MT.EQ.8) THEN K=IP IF(INC2.GT.1) THEN IC2P=INC2 ELSE IC2P=IC2/2 END IF KK=NXPTD DO 12 I=1,ISIZE,IC2 KL=K DO 10 J=1,MSIZE(IV),2 IF(DABS(DX(KK)-MISSNG).LE..1D-6) THEN DX(KL)=MISSNG ELSE IF(DX(KK+1).GT.0.) THEN DX(KL)=DX(KK)/DX(KK+1) ELSE DX(KL)=MISSNG END IF KK=KK+2 KL=KL+1 10 CONTINUE K=K+IC2P 12 CONTINUE ELSE IF(MT.EQ.9) THEN IF(ITRAN.EQ.5) THEN L=CROSSD(CDMPNT(IV)+1)*CROSSD(CDMPNT(IV)+2) ELSE L=CROSSD(CDMPNT(IV)+1) END IF K=IP MS=MSIZE(IV) DO 20 I=1,ISIZE,IC2 KK=K-1 DO 18 LL=1,MS,L TOT=0. DO 14 J=1,L IF(DABS(DX(KK+J)-MISSNG).GT..1D-6) THEN IF(DABS(TOT-MISSNG).GT..1D-6) THEN TOT=TOT+DX(KK+J) END IF ELSE TOT=MISSNG END IF 14 CONTINUE DO 16 J=1,L IF(TOT.LE.0.) THEN DX(KK+J)=MISSNG ELSE IF(ITRAN.EQ.1.OR.ITRAN.EQ.5) THEN DX(KK+J)=100.D0*DX(KK+J)/TOT ELSE DX(KK+J)=DX(KK+J)/TOT END IF END IF 16 CONTINUE KK=KK+L 18 CONTINUE K=K+IC2 20 CONTINUE END IF ELSE IF(ITRAN.EQ.3.OR.ITRAN.EQ.4.OR.ITRAN.EQ.7) THEN IF(MT.EQ.3) THEN MS=MSIZE(IV) K=IP-1 IF(INC2.GT.1) THEN IC2P=INC2 ELSE IC2P=MS-1 END IF KK=NXPTD-1 DO 25 I=1,ISIZE,IC2 IF(ITRAN.EQ.3.OR.ITRAN.EQ.7) THEN TOT=0. DO 22 J=1,MS IF(DABS(DX(KK+J)-MISSNG).GT..1D-6) THEN IF(DABS(TOT-MISSNG).GT..1D-6) THEN TOT=TOT+DX(KK+J) END IF ELSE TOT=MISSNG END IF 22 CONTINUE END IF DO 24 J=1,MS-1 IF(ITRAN.EQ.4) THEN DX(K+J)=DX(KK+J) ELSE IF(TOT.LE.0.) THEN DX(K+J)=MISSNG ELSE IF(ITRAN.EQ.3) THEN DX(K+J)=100.D0*DX(KK+J)/TOT ELSE DX(K+J)=DX(KK+J)/TOT END IF END IF 24 CONTINUE K=K+IC2P KK=KK+MS 25 CONTINUE ELSE IF(MT.EQ.9) THEN L=CROSSD(CDMPNT(IV)+1) MS=MSIZE(IV) IF(INC2.GT.1) THEN IC2P=INC2 ELSE IC2P=((L-1)*MS)/L END IF K=IP-1 KK=NXPTD-1 MS=MSIZE(IV) DO 30 I=1,ISIZE,IC2 KL=K DO 29 LL=1,MS,L IF(ITRAN.EQ.3.OR.ITRAN.EQ.7) THEN TOT=0. DO 26 J=1,L IF(DABS(DX(KK+J)-MISSNG).GT..1D-6) THEN IF(DABS(TOT-MISSNG).GT..1D-6) THEN TOT=TOT+DX(KK+J) END IF ELSE TOT=MISSNG END IF 26 CONTINUE END IF DO 27 J=1,L-1 IF(ITRAN.EQ.4) THEN DX(KL+J)=DX(KK+J) ELSE IF(TOT.LE.0.) THEN DX(KL+J)=MISSNG ELSE IF(ITRAN.EQ.3) THEN DX(KL+J)=100.D0*DX(KK+J)/TOT ELSE DX(KL+J)=DX(KK+J)/TOT END IF END IF 27 CONTINUE KK=KK+L KL=KL+L-1 29 CONTINUE K=K+IC2P 30 CONTINUE END IF ELSE IF(ITRAN.EQ.8) THEN IF(MT.EQ.2) THEN K=IP KK=NXPTD+1 IF(INC2.GT.1) THEN IC2P=INC2 ELSE IC2P=1 END IF DO 31 I=1,ISIZE,IC2 DX(K)=DX(KK) K=K+IC2P KK=KK+2 31 CONTINUE ELSE IF(MT.EQ.3) THEN K=IP KK=NXPTD-1 MS=MSIZE(IV) IF(INC2.GT.1) THEN IC2P=INC2 ELSE IC2P=1 END IF DO 33 I=1,ISIZE,IC2 TOT=0. DO 32 J=1,MS IF(DABS(DX(KK+J)-MISSNG).GT..1D-6) THEN IF(DABS(TOT-MISSNG).GT..1D-6) THEN TOT=TOT+DX(KK+J) END IF ELSE TOT=MISSNG END IF 32 CONTINUE DX(K)=TOT K=K+IC2P KK=KK+MS 33 CONTINUE ELSE IF(MT.EQ.8) THEN IF(INC2.GT.1) THEN IC2P=INC2 ELSE IC2P=MSIZE(IV)/2 END IF K=IP KK=NXPTD+1 DO 35 I=1,ISIZE,IC2 KL=K DO 34 J=1,MSIZE(IV),2 DX(KL)=DX(KK) KK=KK+2 KL=KL+1 34 CONTINUE K=K+IC2P 35 CONTINUE ELSE IF(MT.EQ.9) THEN L=CROSSD(CDMPNT(IV)+1) K=IP KK=NXPTD-1 MS=MSIZE(IV) IF(INC2.GT.1) THEN IC2P=INC2 ELSE IC2P=MS/L END IF DO 40 I=1,ISIZE,IC2 KL=K DO 39 LL=1,MS,L TOT=0. DO 36 J=1,L IF(DABS(DX(KK+J)-MISSNG).GT..1D-6) THEN IF(DABS(TOT-MISSNG).GT..1D-6) THEN TOT=TOT+DX(KK+J) END IF ELSE TOT=MISSNG END IF 36 CONTINUE DX(KL)=TOT KK=KK+L KL=KL+1 39 CONTINUE K=K+IC2P 40 CONTINUE END IF ELSE IF(ITRAN.EQ.2) THEN IF(MT.EQ.2) THEN K=IP KK=NXPTD IF(INC2.GT.1) THEN IC2P=INC2 ELSE IC2P=1 END IF DO 45 I=1,ISIZE,IC2 DX(K)=DX(KK) K=K+IC2P KK=KK+2 45 CONTINUE ELSE IF(MT.EQ.8) THEN IF(INC2.GT.1) THEN IC2P=INC2 ELSE IC2P=MSIZE(IV)/2 END IF K=IP KK=NXPTD DO 48 I=1,ISIZE,IC2 KL=K DO 47 J=1,MSIZE(IV),2 DX(KL)=DX(KK) KK=KK+2 KL=KL+1 47 CONTINUE K=K+IC2P 48 CONTINUE END IF END IF RETURN END SUBROUTINE TMOV1A(IS,INC1,IP,INC2,ICLBLK,IV1,IV2,IA,NA,ISIZE) IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (MIXFLL=6*MRANGE+2*MRNSET+5*MRECOD+4*MVAR+MSIZEI) PARAMETER (IXFLLD=72+3*MAXIDS) C INTEGER IS,INC1,IP,INC2,ICLBLK,IV1,IV2,IA(3,*),NA,ISIZE DOUBLE PRECISION DX(MSIZED) INTEGER IX(MIXFLL) COMMON /DBLOCK/DX COMMON /STMBLK/IX C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C INTEGER SICMUL,IFILL(IXFLLD) COMMON /STPBLK/SICMUL,IFILL INTEGER SI1,SI2,SI3,SI4,SI5,SI6,SI7,SI8,SI10,SI11 C DOUBLE PRECISION MISSNG DATA MISSNG/-98765.432109D0/ C 200 FORMAT(' TMOV1A: ERROR IN COLLAPSING') 201 FORMAT(' TMOV1A: J=',I6,' NL=',I6) 202 FORMAT(' TMOV1A: L=',I6,' NOUT=',I6,' NIN=',I6) C C Internal matrices: C C IX(SI1+ ) - output dimensions C IX(SI2+ ) - output class variables C IX(SI3+ ) - pointer to first level of output class, C for use with SI5 and SI6, starts at 0 C IX(SI4+ ) - ICLBAR for corresponding output class C IX(SI5+ ) - pointer to first cell, starts at 0 C IX(SI6+ ) - number of cells C IX(SI7+ ) - individual cells, numbered from 0 C IX(SI8+ ) - increments for input, in output order C IX(SI10+ ) - coordinate array for output cells, starts at 0 C IX(SI11+ ) - coordinate array for input cells used to form output C starts at 0 C NIN=BLNCLS(ICLBLK) SI1=NXPTI C C IVLEN is number of cells for each combination of class variables C IF(IV2.EQ.9) THEN IVLEN=1 ELSE IVLEN=MSIZE(IV1) END IF C C Determine the increment for the temporary matrix C IF(INC2.EQ.1) THEN IS2INC=IVLEN ELSE IS2INC=INC2 END IF C C Check whether specified class variables match, in identical order, C those for the block, a special case handled at statement 55 C If the block has no class variables, then there should either be: C No class specification for the variable, or C A specification of "/CLASS TOTAL" C IF(NIN.EQ.0) THEN IF(NA.EQ.0)GO TO 55 IF(IA(1,1).EQ.1.AND.IA(1,2).EQ.0)GO TO 55 C C If the block has class variables, check whether the class variables C match. All instances of failure are sent to statement 6. C ELSE IF(NA.EQ.0)GO TO 6 K=1 ICLBAR=BLCPNT(ICLBLK) 1 CONTINUE N=IA(1,K) K=K+1 DO 3 J=1,N C C The next statement assures that ICLBAR, which is incremented in C statements below, has not stepped beyond the appropriate range for C the block C IF(BLCPNT(ICLBLK)+NIN.LE.ICLBAR)GO TO 6 C C The next statement checks that the CLASS specification points to C the right class variable. C IF(IA(1,K).NE.CLPNT(ICLBAR))GO TO 6 C C If no range is given for the class variable, then the block C cannot be of type 0, with separate marginal total. C IF(IA(3,K).EQ.0) THEN IF(CLTYPE(ICLBAR).EQ.0)GO TO 6 ICLBAR=ICLBAR+1 C C If a range is given for the class variable, then check that the C levels are specified in the right order. For blocks of type 0, C level 0 must be specified first. C ELSE IF(CLTYPE(ICLBAR).EQ.1) THEN IF(IA(2,K).NE.IA(3,K))GO TO 6 C C If the last level has been listed, then increment ICLBAR C IF(IA(3,K).EQ.MSIZE(CLPNT(ICLBAR))) THEN ICLBAR=ICLBAR+1 END IF ELSE IF(IA(2,K)+1.NE.IA(3,K))GO TO 6 IF(IA(3,K).EQ.MSIZE(CLPNT(ICLBAR))+1) THEN ICLBAR=ICLBAR+1 END IF END IF END IF K=K+1 3 CONTINUE C C Loop back to 1 if more remains on the specification C IF(K.LE.NA) GO TO 1 C C This last check insures that all classes have matched, which will C be the case if ICLBAR has been incremented to just beyond the C range for the block. C IF(ICLBAR.EQ.BLCPNT(ICLBLK)+NIN)GO TO 55 END IF C C Creating the output is handled either here or at statement 55 C Treatment of the general case begins here. C 6 CONTINUE C C The code from here to statement 15 calculates the three variables: C NL - upper bound on number of cells of input to be placed on list C to form output C NC - index of levels for output C NOUT- number of output classes C It also computes entries for arrays starting with SI1, SI2, SI3, SI4 C IX(SI1+ ) - output dimensions C IX(SI2+ ) - output class variables C IX(SI3+ ) - pointer to first level of output class, C for use with SI5 and SI6, starts at 0 C IX(SI4+ ) - ICLBAR for corresponding output class C NOUT=0 NC=0 NL=0 SI2=NXPTI+NIN SI3=SI2+NIN SI4=SI3+NIN K=4*NIN C C Call ROOMI to allocate space C IF(K.GT.0)CALL ROOMI(K) C C Loop through specification to identify class variables C IF(NA.GT.0) THEN K=1 7 CONTINUE N=IA(1,K) K=K+1 DO 9 J=1,N C C If the specification includes TOTAL, treat it simply as TOTAL C IF(IA(1,K).EQ.0) THEN NOUT=0 NC=0 NL=0 GO TO 10 END IF C C Unless at the end of the specification, look ahead. C If the current part of the specification gives a level of a class C variable to be followed by other levels, adjust NL but do not C store into IX(SI1+ ) yet. C IF(J.LT.N) THEN K1=K+1 IF(IA(1,K1).EQ.IA(1,K)) THEN IF(IA(2,K).EQ.0) THEN NL=NL+MSIZE(IA(1,K)) ELSE NL=NL+1 END IF GO TO 8 END IF END IF C C If this the last (possibly only) part of the specification to C refer to a class variable, store the number of outgoing levels C in IX(SI1+ C IF(IA(3,K).EQ.0) THEN IX(SI1+NOUT)=MSIZE(IA(1,K)) NL=NL+MSIZE(IA(1,K)) ELSE IX(SI1+NOUT)=IA(3,K) IF(IA(2,K).EQ.0) THEN NL=NL+MSIZE(IA(1,K)) ELSE NL=NL+1 END IF END IF C C Store the variable number of the class variable in IX(SI2+ C and a cumulative total of IX(SI1+ into IX(SI3+ C IX(SI2+NOUT)=IA(1,K) IX(SI3+NOUT)=NC NC=NC+IX(SI1+NOUT) NOUT=NOUT+1 8 CONTINUE K=K+1 9 CONTINUE C C If not done with the specification, return to statement 7 C IF(K.LE.NA)GO TO 7 END IF 10 CONTINUE L=NOUT ICLBAR=BLCPNT(ICLBLK) C C Complete arrays for input class variables not output. C Loop over all variables in the block. C DO 15 I=1,NIN IF(NOUT.GT.0) THEN DO 12 J=1,NOUT IF(IX(SI2+J-1).EQ.CLPNT(ICLBAR)) THEN C C The class variable has already appeared in the specification C IX(SI4+J-1)=ICLBAR GO TO 14 END IF 12 CONTINUE END IF C C For class variables not mentioned in the specification. C IX(SI1+L)=1 IX(SI2+L)=CLPNT(ICLBAR) IX(SI3+L)=NC IX(SI4+L)=ICLBAR NC=NC+1 L=L+1 IF(CLTYPE(ICLBAR).EQ.0) THEN NL=NL+1 ELSE NL=NL+MSIZE(CLPNT(ICLBAR)) END IF 14 CONTINUE ICLBAR=ICLBAR+1 15 CONTINUE C C The following statement performs a check that class variables C have been properly accounted for. C IF(L.NE.NIN) THEN WRITE(U6,202)L,NOUT,NIN IMERR1=50001 RETURN END IF C C From here to just beyond statement 27, compute entries for C arrays starting with SI5, SI6, SI7 C IX(SI5+ ) - pointer to first cell, starts at 0 C IX(SI6+ ) - number of cells C IX(SI7+ ) - individual cells, numbered from 0 C Note that their lengths, NC, NC, and NL, respectively, were C computed in the previous code. C SI5=SI4+NIN SI6=SI5+NC SI7=SI6+NC K=2*NC+NL CALL ROOMI(K) C C ICL - index for output levels C J - index for output cells C LOUT- index for output classes C ICL=0 J=0 LOUT=0 C C Loop over class variables in specification C IF(NOUT.GT.0) THEN K=1 17 CONTINUE N=IA(1,K) K=K+1 DO 24 L=1,N C C In performing loop, always look backwards 1 C IF(L.GT.1) THEN K1=K-1 C C If the current part of the specification is the first mention C of the class, increment LOUT C IF(IA(1,K).NE.IA(1,K1)) THEN LOUT=LOUT+1 C C Else if the same class was mentioned in the previous part of the C specification: C ELSE C C Check to see if this level is included in the + condition, in C which case IA(3,K) and IA(3,K1) will agree C IF(IA(3,K).EQ.IA(3,K1)) THEN C C a. If this is a case +TOTAL and the class type is 1, add all C the levels of the class into IX(SI7+ and increment IX(SI6+ C IF(IA(2,K).EQ.0.AND.CLTYPE(IX(SI4+LOUT)).EQ.1) THEN DO 18 I=1,MSIZE(IA(1,K)) IX(SI7+J)=I-1 J=J+1 18 CONTINUE IX(SI6+ICL)=IX(SI6+ICL)+MSIZE(IA(1,K)) C C b. In other cases, add the appropriate cell to IX(SI7+ and C increment IX(SI6+ by 1. C ELSE IF(CLTYPE(IX(SI4+LOUT)).EQ.1) THEN IX(SI7+J)=IA(2,K)-1 ELSE IX(SI7+J)=IA(2,K) END IF J=J+1 IX(SI6+ICL-1)=IX(SI6+ICL-1)+1 END IF C C Handling of + case completed C GO TO 22 END IF END IF C C In addition to L > 1, increment LOUT if K > 2, which can C happen if the * was omitted between classes. C ELSE IF(K.GT.2) THEN LOUT=LOUT+1 END IF C C Processing for first mention of an outgoing level. C First, set pointer in IX(SI5+ to current value of J to C retain start of cells for the outgoing level. C C C a. If the specification doesn't include a range, fill C in implied 1-n range into IX(SI7+, store 1 in IX(SI6+ C IF(IA(3,K).EQ.0) THEN DO 19 I=1,MSIZE(IA(1,K)) IF(CLTYPE(IX(SI4+LOUT)).EQ.1) THEN IX(SI7+J)=I-1 ELSE IX(SI7+J)=I END IF IX(SI5+ICL)=J IX(SI6+ICL)=1 J=J+1 ICL=ICL+1 19 CONTINUE C C b. Fill in cells for /CLASS TOTAL, for class type 1 C ELSE IF(IA(2,K).EQ.0.AND.CLTYPE(IX(SI4+LOUT)).EQ.1) THEN IX(SI5+ICL)=J IX(SI6+ICL)=MSIZE(IA(1,K)) ICL=ICL+1 DO 20 I=1,MSIZE(IA(1,K)) IX(SI7+J)=I-1 J=J+1 20 CONTINUE C C c. Otherwise, enter single cell, including case of /CLASS TOTAL C for class type 0 C ELSE IX(SI5+ICL)=J IX(SI6+ICL)=1 ICL=ICL+1 IF(CLTYPE(IX(SI4+LOUT)).EQ.1) THEN IX(SI7+J)=IA(2,K)-1 ELSE IX(SI7+J)=IA(2,K) END IF J=J+1 END IF 22 CONTINUE K=K+1 24 CONTINUE C C If more remains in the specification, loop back to 17 C IF(K.LE.NA)GO TO 17 END IF C C Complete arrays for input class variables not output C IF(NOUT.LT.NIN) THEN DO 27 I=NOUT+1,NIN IX(SI5+ICL)=J C C For class type 0, reference the marginal C IF(CLTYPE(IX(SI4+I-1)).EQ.0) THEN IX(SI6+ICL)=1 ICL=ICL+1 IX(SI7+J)=0 J=J+1 C C For class type 1, compute the marginal by summation C ELSE IX(SI6+ICL)=MSIZE(IX(SI2+I-1)) ICL=ICL+1 DO 25 M=1,MSIZE(IX(SI2+I-1)) IX(SI7+J)=M-1 J=J+1 25 CONTINUE END IF 27 CONTINUE END IF C C Another "just in case" check to detect an error in indexing C Note that NL was an upper bound, so that J < NL is OK C IF(J.GT.NL) THEN WRITE(U6,201)J,NL IMERR1=50002 RETURN END IF C C Compute entries for arrays starting with S8, and C initialize S10 and S11. C IX(SI8+ ) - increments for input, in output order C IX(SI10+ ) - coordinate array for output cells, starts at 0 C IX(SI11+ ) - coordinate array for input cells used to form output C starts at 0 C SI8=SI7+NL SI10=SI8+NIN SI11=SI10+NIN K=3*NIN CALL ROOMI(K) C C C I1=INC1 ICLBAR=BLCPNT(ICLBLK) C C Loop through the class variables for the block, in their C initial order. Find the position of the class variable in the C outgoing order and store I1 (the increment) in IX(SI8 C DO 33 I=1,NIN DO 30 J=1,NIN IF(IX(SI4+J-1).EQ.ICLBAR) THEN IX(SI8+J-1)=I1 END IF 30 CONTINUE C C Now multiply I1 by the number of levels (including total, if C present) for the class variable. C IF(CLTYPE(ICLBAR).EQ.1) THEN I1=I1*MSIZE(CLPNT(ICLBAR)) ELSE I1=I1*(MSIZE(CLPNT(ICLBAR))+1) END IF IX(SI10+I-1)=0 ICLBAR=ICLBAR+1 33 CONTINUE C C IS2 - cell for the outgoing matrix C IS2=IP C C Before entering the loop, set the first element of IX(SI10 to -1 C IX(SI10)=-1 35 CONTINUE C C Loop to increment IX(SI10 over class levels for the outgoing C matrix. Systematically increment the elements of IX(SI10 over C combinations with IX(SI1 as the upper bound. C DO 38 I=1,NIN IX(SI10+I-1)=IX(SI10+I-1)+1 IF(IX(SI10+I-1).LT.IX(SI1+I-1)) THEN IF(I.GT.1) THEN DO 37 J=1,I-1 IX(SI10+J-1)=0 37 CONTINUE END IF C C Enter zeroes into the outgoing matrix about to be created C IF(IVLEN.EQ.1) THEN DX(IS2)=0. ELSE J=IS2 DO 36 II=1,IVLEN DX(J)=0. J=J+1 36 CONTINUE END IF GO TO 40 END IF 38 CONTINUE C C If fall through to here, done with all outgoing cells. C GO TO 60 40 CONTINUE C C Ready to begin tally for outgoing cell(s) for given levels C of outgoing classes. First, initialize IX(SI11+, which will C be used to control the loop over all incoming cells involved in C the summation. C IF(NIN.GT.1) THEN DO 41 I=2,NIN IX(SI11+I-1)=0 41 CONTINUE END IF IX(SI11)=-1 42 CONTINUE C C Loop to systematically vary the elements of IX(SI11+ to sum over C all appropriate levels of incoming classes. C DO 46 I=1,NIN IX(SI11+I-1)=IX(SI11+I-1)+1 ICL=IX(SI3+I-1)+IX(SI10+I-1) IF(IX(SI11+I-1).LT.IX(SI6+ICL)) THEN IF(I.GT.1) THEN DO 44 J=1,I-1 IX(SI11+J-1)=0 44 CONTINUE END IF C C After completing IX(SI11+ go to 48 for summation over the relevant C incoming values C GO TO 48 END IF 46 CONTINUE C C If we get to here, all the appropriate values of incoming classes C have now been summed. Return to 35 to check if there are more C outgoing cells to be considered. C increment IS2 by IS2INC determined at beginning C IS2=IS2+IS2INC GO TO 35 48 CONTINUE IS1=IS C C The loop to 50 calculates in IS1 the necessary offset for the C current levels of the incoming classes. C DO 50 I=1,NIN C C ICL combines a starting position given by IX(SI3+ with the current C level of the outgoing class in IX(SI10+ C ICL=IX(SI3+I-1)+IX(SI10+I-1) C C J is determined by a lookup in IX(SI5 with an offset of ICL, plus C the current value in IX(SI11+, which is indexing the number of C levels. C J=IX(SI5+ICL)+IX(SI11+I-1) C C Use J to look up the index of the incoming class variable, in C IX(SI7+ , multiply this by the increment in IX(SI8+ for the class C and add this to IS1 C IS1=IS1+IX(SI7+J)*IX(SI8+I-1) 50 CONTINUE C C When we get to here, we are ready to sum into the outgoing cell(s) C There are separate loops for 1 cell vs. multiple cells. C The sum is missing if either component is missing. C IF(IVLEN.EQ.1) THEN IF(DABS(DX(IS2)-MISSNG).GT..1D-6) THEN IF(DABS(DX(IS1)-MISSNG).GT..1D-6) THEN DX(IS2)=DX(IS2)+DX(IS1) ELSE DX(IS2)=MISSNG END IF END IF ELSE K=IS2 DO 52 I=1,IVLEN IF(DABS(DX(K)-MISSNG).GT..1D-6) THEN IF(DABS(DX(IS1)-MISSNG).GT..1D-6) THEN DX(K)=DX(K)+DX(IS1) ELSE DX(K)=MISSNG END IF END IF K=K+1 IS1=IS1+1 52 CONTINUE END IF C C Loop back to 42 to see if another combination of incoming classes C should be summed. C GO TO 42 55 CONTINUE C C This code is for the special case only. C IS2 serves as index for outgoing matrix. C IS1 serves as index for incoming matrix. C IS2=IP IS1=IS C C This code makes use of the contents of IX(SICMUL+ to determine the C total number of cells. C IF(IVLEN.EQ.1) THEN DO 56 J=1,IX(SICMUL+ICLBLK-1) DX(IS2)=DX(IS1) IS1=IS1+INC1 IS2=IS2+IS2INC 56 CONTINUE ELSE DO 58 J=1,IX(SICMUL+ICLBLK-1) M=IS1 M2=IS2 DO 57 I=1,IVLEN DX(M2)=DX(M) M2=M2+1 M=M+1 57 CONTINUE IS1=IS1+INC1 IS2=IS2+IS2INC 58 CONTINUE END IF C C Normal end under either special or general cases. C 60 CONTINUE ISIZE=IS2-IP NXPTI=SI1 RETURN END C C CN.FOR C SUBROUTINE CONTNT IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MAXFMT=20) PARAMETER (MAXSUB=500,MAXSBL=2000) PARAMETER (NOPTN=2) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 CHARACTER*256 CARD COMMON /CRDBLK/CARD C CHARACTER*12 VNMIN(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNMIN,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI, . NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL), . U5LCSW COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI, . NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT C INTEGER ITYPEF(3),IFILEF(3) C DOUBLE PRECISION RVALUE(5) CHARACTER*6 RMULT(5) C LOGICAL REFRSH,LTEMP EXTERNAL REFRSH CHARACTER*15 CTYPE(11) CHARACTER*12 OPTNW(NOPTN) INTEGER INDX(NOPTN),IVALUE(NOPTN),IOPTN(1) DATA CTYPE /'Real ','Real w/missing ', . 'Categorical ','Class ', . 'BY ','Crossed real ', . 'Crossed cat ','Var identifier ', . 'Weight ','Derived ', . 'Crossed derived'/ DATA OPTNW / 'PRINT ','NOPRINT '/ DATA INDX/1,1/ DATA IVALUE/1,2/ 101 FORMAT('1 ') 102 FORMAT(/,15X,'CONTENTS OF FILE ',A40) 103 FORMAT(/,11X,'Total number of variables',I8) 104 FORMAT(11X,'Number of basic variables',I8) 105 FORMAT(11X,'Number of CLASS variables',I8) 106 FORMAT(11X,'Number of variance identifiers',I3) 107 FORMAT(11X,'Number of BY variables',9X,I2) 108 FORMAT(11X,'Weighted analysis') 109 FORMAT(11X,'Unweighted analysis') 110 FORMAT(//,' NUMB VAR NAME LEVEL VAR/LEVEL LABEL',11X,'TYPE', .11X,'SIZE',4X,'LOC') 111 FORMAT(/,1X,I4,2X,A12,5X,A24,1X,A15,I5,I7) 112 FORMAT(16X,I4,4X,A24) 113 FORMAT(7X,A12,5X,A24) 114 FORMAT(/,5X,'COMBINATIONS OF BY VARIABLES ON THE FILE') 115 FORMAT(/,1X,5F15.3,/,1X,5F15.3) 116 FORMAT(/,5X,'NUMBER OF REPLICATES',I6) 117 FORMAT(/,5X,'COEFFICIENTS USED IN ESTIMATION OF VARIANCE',/) 118 FORMAT(2X,4(1X,A6,F12.9)) 119 FORMAT(/,5X,'VALUES OF THE BY VARIABLE ON THE FILE') 120 FORMAT(11X,'Number of blocks',12X,I5) 121 FORMAT(//,20X,'CONTENTS OF BLOCK',I5,', SIZE =',I6) 122 FORMAT(/,7X,'N(',I5,')',34X,'Weighted N',9X,'1',I7) 123 FORMAT(/,7X,'N(',I5,')',34X,'Sample N',11X,'1',I7) 124 FORMAT(I5,'*') 125 FORMAT(//) 126 FORMAT(19X,'0',4X,'Total') IOPTN(1)=1 ITYPEF(1)=2 ITYPEF(2)=1 ITYPEF(3)=0 CALL KYFIND(IKEY,IPT) WRITE(U6,101) CALL CRDPRN(3) CALL FNREAD(IPT,ITYPEF,IFILEF,1,IPOSSC) IF(IMERR1.GT.0) THEN CALL FSTOP END IF IF(IPOSSC.GT.0) THEN U5LCSW=1 C ! Reset U5LCSW for REFRSH, etc. IPOS=IPOSSC+1 CALL NBFND2(IPOS,IPT) IF(IPT.GT.0) THEN CALL KYCHK2(IPT,IGROUP,IKEY,IPOS) IF(IGROUP.NE.2.OR.IKEY.NE.11) THEN IMERR2=IPT CALL FESTOP(39001) END IF IPT=IPOS CALL OPTNTR(NOPTN,INDX,IVALUE,OPTNW,IPT,IPOS,IOPTN) IF(IPOS.EQ.0) THEN CALL FESTOP(39002) ELSE IF(CARD(IPOS:IPOS).NE.';') THEN IMERR2=IPOS CALL FESTOP(39002) END IF IPT=IPOS+1 ELSE IF(U5END.GT.0) THEN GO TO 60 ELSE GO TO 4 END IF END IF END IF 3 CONTINUE IF(U5END.GT.0)GO TO 60 LTEMP=REFRSH(IPT) 4 CONTINUE IF(U5END.GT.0)GO TO 60 CALL KYFIND(IKEY,IPT) IF(IKEY.EQ.-1) THEN CALL CRDPRN(1) GO TO 4 END IF IF(IKEY.EQ.36) THEN CALL CRDPRN(1) CALL OPTNTR(NOPTN,INDX,IVALUE,OPTNW,IPT,IPOS,IOPTN) IF(IPT.EQ.1) THEN GO TO 4 ELSE GO TO 3 END IF END IF 60 CONTINUE CALL PREAMB IF(IOPTN(1).NE.2) THEN WRITE(U6,102)LSTVPL(1:60) WRITE(U6,103)NVTOT IF(NVREG.GT.0)WRITE(U6,104)NVREG IF(NCLASS.GT.0)WRITE(U6,105)NCLASS IF(NVARID.GT.0)WRITE(U6,106)NVARID IF(NBY.GT.0)WRITE(U6,107)NBY WRITE(U6,120)NCLBLK IF(NWGT.GT.0) THEN WRITE(U6,108) ELSE WRITE(U6,109) END IF DO 20 ICLBLK=1,NCLBLK WRITE(U6,121)ICLBLK,BLXSIZ(ICLBLK) WRITE(U6,110) IF(BLTYPE(ICLBLK).EQ.1) THEN IF(NWGT.GT.0) THEN WRITE(U6,122)ICLBLK,BLXSTR(ICLBLK) ELSE WRITE(U6,123)ICLBLK,BLXSTR(ICLBLK) END IF END IF IF(BLVSIZ(ICLBLK).GT.0) THEN DO 10 I=BLVSTR(ICLBLK),BLVSTR(ICLBLK)+BLVSIZ(ICLBLK)-1 IF(MTYPE(I).LE.5) THEN J=MTYPE(I) ELSE IF(MTYPE(I).EQ.8) THEN J=6 ELSE IF(MTYPE(I).EQ.9) THEN J=7 ELSE IF(MTYPE(I).EQ.11) THEN J=10 ELSE IF(MTYPE(I).EQ.13.OR.MTYPE(I).EQ.19) THEN J=11 END IF WRITE(U6,111)I,VNMIN(I),LABEL(I),CTYPE(J),MSIZE(I),VMAPL(I) IF(MTYPE(I).EQ.8.OR.MTYPE(I).EQ.9.OR.MTYPE(I).EQ.19) THEN L=LPOINT(I) K=CDMPNT(I) N=CROSSD(K) NM=CROSSD(K+N+1) DO 6 J=1,N WRITE(U6,113)VTEMP(NM),LEVEL(L) NM=NM+1 L=L+1 IF(CROSSD(K+J).GT.0) THEN DO 5 JJ=1,CROSSD(K+J) WRITE(U6,112)JJ,LEVEL(L) L=L+1 5 CONTINUE END IF 6 CONTINUE ELSE IF(MTYPE(I).EQ.3.OR.MTYPE(I).EQ.13) THEN L=LPOINT(I) DO 8 J=1,MSIZE(I) WRITE(U6,112)J,LEVEL(L) L=L+1 8 CONTINUE END IF 10 CONTINUE END IF IF(BLNCLS(ICLBLK).GT.0) THEN DO 18 II=1,BLNCLS(ICLBLK) I=CLPNT(BLCPNT(ICLBLK)+II-1) ICSIZE=MSIZE(I) IF(CLTYPE(BLCPNT(ICLBLK)+II-1).EQ.0)ICSIZE=ICSIZE+1 WRITE(U6,111)I,VNMIN(I),LABEL(I),CTYPE(4),ICSIZE L=LPOINT(I) IF(CLTYPE(BLCPNT(ICLBLK)+II-1).EQ.0)WRITE(U6,126) DO 12 J=1,MSIZE(I) WRITE(U6,112)J,LEVEL(L+J-1) 12 CONTINUE 18 CONTINUE END IF 20 CONTINUE WRITE(U6,125) DO 30 I=NVREG+NCLASS+1,NVTOT IF(MTYPE(I).EQ.5) THEN WRITE(U6,111)I,VNMIN(I),LABEL(I),CTYPE(5),MSIZE(I) ELSE IF(MTYPE(I).EQ.6) THEN WRITE(U6,111)I,VNMIN(I),LABEL(I),CTYPE(5) ELSE IF((VFTYPE.GE.5.AND.VFTYPE.LE.12.AND. . I.LE.NVREG+NCLASS+NVARID-1).OR. . ((VFTYPE.LE.4.OR.VFTYPE.GE.13).AND.I.LE.NVREG+NCLASS+NVARID)) . THEN WRITE(U6,111)I,VNMIN(I),LABEL(I),CTYPE(8) ELSE IF(I.EQ.NVTOT.AND.NWGT.EQ.1) THEN WRITE(U6,111)I,VNMIN(I),LABEL(I),CTYPE(9) END IF 30 CONTINUE IF(NBY.GE.1) THEN IF(NBY.GT.1) THEN WRITE(U6,114) ELSE WRITE(U6,119) END IF K=SDBYID-1 DO 35 I=1,NBYGRP WRITE(U6,115)(DX(K+J),J=1,NBY) K=K+NBY 35 CONTINUE END IF END IF IF(NRPTOT.GT.0) THEN IF(IOPTN(1).NE.2) THEN WRITE(U6,116)NRPTOT WRITE(U6,117) END IF RVALUE(1)=DX(SDCOEF) K=1 L=1 IF(NRPTOT.GT.1) THEN DO 40 I=1,NRPTOT-1 IF(DABS(DX(SDCOEF+I)-RVALUE(L)).LT..1D-12) THEN K=K+1 ELSE IF(K.EQ.1) THEN RMULT(L)=' ' ELSE WRITE(RMULT(L),124)K END IF K=1 L=L+1 IF(L.GT.4) THEN IF(IOPTN(1).NE.2) THEN WRITE(U6,118)(RMULT(J),RVALUE(J),J=1,4) END IF IF(IFILEF(2).EQ.1) THEN WRITE(11,118)(RMULT(J),RVALUE(J),J=1,4) END IF L=1 END IF RVALUE(L)=DX(SDCOEF+I) END IF 40 CONTINUE END IF IF(K.EQ.1) THEN RMULT(L)=' ' ELSE WRITE(RMULT(L),124)K END IF IF(IOPTN(1).NE.2) THEN WRITE(U6,118)(RMULT(J),RVALUE(J),J=1,L) END IF IF(IFILEF(2).EQ.1) THEN WRITE(11,118)(RMULT(J),RVALUE(J),J=1,L) END IF END IF CLOSE(12) RETURN END C SUBROUTINE EXPORT IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MAXSUB=500,MAXSBL=2000) PARAMETER (MAXFMT=20) PARAMETER (NOPTN=3) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 CHARACTER*256 CARD COMMON /CRDBLK/CARD C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT C INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI, . NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL), . U5LCSW COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI, . NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW C INTEGER ITYPEF(3),IFILEF(3) C C LOGICAL REFRSH,LTEMP,ENDFLE EXTERNAL REFRSH CHARACTER*12 OPTNW(NOPTN) INTEGER INDX(NOPTN),IVALUE(NOPTN),IOPTN(2) DATA OPTNW / 'PRINT ','NOPRINT ','NREP '/ DATA INDX/1,1,2/ DATA IVALUE/1,2,0/ 102 FORMAT(10I8) 103 FORMAT(3D24.16) 104 FORMAT(//,' IVERSN',/,1X,I7,//,' NVTOT NVREG NCLASS NVARID N .BY NWGT TYPE VROPTN NIDTOT TSIZE NCLBLK',/,1X,11I7,/,' NCLBA .R',/,1X,I7) 105 FORMAT(/,' BLTYPE BLXSTR BLXINC BLXSIZ BLVSTR BLVSIZ BLNCLS BLCPN .T',(/,1X,8I7)) 106 FORMAT(/,' Class type flags (margins)',(/,1X,10I7)) 107 FORMAT(/,' Class pointers',(/,1X,10I7)) 108 FORMAT(/,' Variable types',(/,1X,10I7)) 109 FORMAT(/,' Variable sizes',(/,1X,10I7)) 110 FORMAT(/,' Variable locations',(/,1X,10I7)) 111 FORMAT(/,' Crossed dimensions',/,1X,I7) 112 FORMAT(/,1X,10I7) 113 FORMAT(/,' Variable names and labels') 114 FORMAT(A12,A24) 115 FORMAT(1X,A12,1X,A24) 116 FORMAT(/,' Level labels',/,1X,I7) 117 FORMAT(A24) 118 FORMAT(1X,A24) 119 FORMAT(/,' Variable names in crossings',/,1X,I7) 120 FORMAT(/,' BY groups',/,1X,I7) 121 FORMAT(/,' Number of replicates',/,1X,I7) 122 FORMAT(/,' Coefficients',(/,10F7.3)) 124 FORMAT(1X,(/,5F14.4)) 201 FORMAT(' ERROR IN SPECIFICATION') ITYPEF(1)=2 ITYPEF(2)=1 ITYPEF(3)=0 CALL KYFIND(IKEY,IPT) CALL CRDPRN(3) CALL FNREAD(IPT,ITYPEF,IFILEF,1,IPOSSC) IF(IMERR1.GT.0) THEN CALL FSTOP END IF IF(IFILEF(2).EQ.0) THEN IOPTN(1)=1 ELSE IOPTN(1)=2 END IF IOPTN(2)=-2 IF(IPOSSC.GT.0) THEN U5LCSW=1 C ! Reset U5LCSW for REFRSH, etc. IPOS=IPOSSC+1 CALL NBFND2(IPOS,IPT) IF(IPT.GT.0) THEN CALL KYCHK2(IPT,IGROUP,IKEY,IPOS) IF(IGROUP.NE.2.OR.IKEY.NE.11) THEN IMERR2=IPT CALL FESTOP(39011) END IF IPT=IPOS CALL OPTNTR(NOPTN,INDX,IVALUE,OPTNW,IPT,IPOS,IOPTN) IF(IPOS.EQ.0) THEN CALL FESTOP(39012) ELSE IF(CARD(IPOS:IPOS).NE.';') THEN IMERR2=IPOS CALL FESTOP(39012) END IF IPT=IPOS+1 ELSE IF(U5END.GT.0) THEN GO TO 60 ELSE GO TO 4 END IF END IF END IF 3 CONTINUE IF(U5END.GT.0)GO TO 60 LTEMP=REFRSH(IPT) 4 CONTINUE IF(U5END.GT.0)GO TO 60 CALL KYFIND(IKEY,IPT) IF(IKEY.EQ.-1) THEN CALL CRDPRN(1) GO TO 4 END IF IF(IKEY.EQ.36) THEN CALL CRDPRN(1) CALL OPTNTR(NOPTN,INDX,IVALUE,OPTNW,IPT,IPOS,IOPTN) IF(IPT.EQ.1) THEN GO TO 4 ELSE GO TO 3 END IF END IF 60 CONTINUE IF(IOPTN(1).NE.1.AND.IFILEF(2).EQ.0)GO TO 94 READ(12)IVERSN IF(IVERSN.NE.9004.AND.IVERSN.NE.9203)STOP READ(12)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE, . VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR CALL RCHECK(2,NVTOT,0) NID=NVARID+NBY IF(IVERSN.EQ.9004)NIDTOT=NID IF(IFILEF(2).NE.0) THEN WRITE(11,102)IVERSN WRITE(11,102)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE, . VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR END IF IF(IOPTN(1).EQ.1) THEN WRITE(U6,104)IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR END IF C C NVTOT - total number of variables on file C NVREG - number of variables, excluding class, variance id's, C BY variables, and weight variable C NCLASS - total number of class variables C NVARID - number of variance id's, excluding BY variables C NBY - number of BY variables C NWGT - 0 or 1 indicating unweighted vs. weighted analysis C VFTYPE - type of input used to create the file C VROPTN - variance option C TSIZE - total size of matrix C NCLBLK - total number of class blocks C NCLBAR - total size of class block information arrays C C VFTYPE = 3 Weighted obs. with cluster/replicate number C 4 Unweighted " C 5 Replicate weights C 6 Unweighted initial obs. followed by replicate weights C 7 Replicate factors multiplying initial weight C 8 Replicate factors of unweighted initial obs ( = VFTYPE 6) C 11 Replicate factors multiplying initial weight, including C factor for replicate 0, overall estimate C 12 Unweighted initial obs " (= VFTYPE 5) C 13 Weighted obs. with cluster code C 14 Unweighted " C 15 Weighted obs. Stratum no. cluster code C 16 Unweighted " C 17 Wtd. Stratum code, cluster code C 18 Unwtd " C 21 Wtd. Stratum no. 2nd stage no, cluster code C 22 Unwtd. " C 23 Wtd. Stratum no. 2nd stage cd, cluster code C 24 Unwtd. " C 25 Wtd. Stratum code 2nd stage no. cluster code C 26 Unwtd " C 27 Wtd. Stratum code 2nd stage cd, cluster code C 28 Unwtd. " C 29 Wtd 2nd stage number cluster code C 30 Unwtd. " C 31 Wtd 2nd stage code cluster code C 32 Unwtd " C 33 Wtd Replicate number governed by stratum counts C 34 Unwtd " C 35 Wtd Rep numb govrned by stratum and 2nd stage counts C 36 Unwtd " C 37 Wtd Rep number governed by 2nd stage counts C 38 Unwtd " C CALL RCHECK(8,NCLBLK,0) CALL RCHECK(9,NCLBAR,0) DO 11 I=1,NCLBLK READ(12)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I), . BLVSIZ(I),BLNCLS(I),BLCPNT(I) IF(IFILEF(2).NE.0) THEN WRITE(11,102)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I), . BLVSIZ(I),BLNCLS(I),BLCPNT(I) END IF 11 CONTINUE IF(IOPTN(1).EQ.1) THEN WRITE(U6,105)(BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I), . BLVSIZ(I),BLNCLS(I),BLCPNT(I),I=1,NCLBLK) END IF IF(NCLBAR.GT.0) THEN CALL INTIN(12,CLTYPE,NCLBAR,ENDFLE) CALL INTIN(12,CLPNT,NCLBAR,ENDFLE) IF(IFILEF(2).NE.0) THEN WRITE(11,102)(CLTYPE(I),I=1,NCLBAR) WRITE(11,102)(CLPNT(I),I=1,NCLBAR) END IF IF(IOPTN(1).EQ.1) THEN WRITE(U6,106)(CLTYPE(I),I=1,NCLBAR) WRITE(U6,107)(CLPNT(I),I=1,NCLBAR) END IF END IF C C BLTYPE - 1 or 0 indicating row of (weighted) n vs. no row C BLXSTR - pointer to first cell of incoming data in X matrix C BLXINC - length of the X matrix for a single combination C of the class variables in the block C BLXSIZ - total size of block data in X matrix (integer multiple C of BLXINC) C BLVSTR - pointer to first variable C BLVSIZ - number of variables in block C BLNCLS - number of class variables in block C BLCPNT - pointer for class information C CLTYPE - type of class in array C CLPNT - pointer to class variables C IF(NVTOT.GT.0) THEN CALL INTIN(12,MTYPE,NVTOT,ENDFLE) CALL INTIN(12,MSIZE,NVTOT,ENDFLE) IF(IFILEF(2).NE.0) THEN WRITE(11,102)(MTYPE(I),I=1,NVTOT) WRITE(11,102)(MSIZE(I),I=1,NVTOT) END IF IF(IOPTN(1).EQ.1) THEN WRITE(U6,108)(MTYPE(I),I=1,NVTOT) WRITE(U6,109)(MSIZE(I),I=1,NVTOT) END IF END IF C C Variable types are read into MTYPE C C Contents of MTYPE C 1 = real variable (total) C 2 = real variable with missing checks C 3 = categorical variable C 4 = class variable, known dimension C 5 = by variable, known dimension C 6 = by variable, unknown dimension C 7 = select transformation (not variable type) C 8 = cross variable, real value C 9 = cross variable, categorical C 11 = derived variable C 13 = crossed derived variable, single dimension C 19 = crossed derived variable C C C Sizes are read into MSIZE C IF(NVREG.GT.0) THEN CALL INTIN(12,VMAPL,NVREG,ENDFLE) IF(IFILEF(2).NE.0) THEN WRITE(11,102)(VMAPL(I),I=1,NVREG) END IF IF(IOPTN(1).EQ.1) THEN WRITE(U6,110)(VMAPL(I),I=1,NVREG) END IF END IF C C VMAPL contains pointers to the first NVREG variables C READ(12)NCRSSD IF(IFILEF(2).NE.0) THEN WRITE(11,102)NCRSSD END IF IF(IOPTN(1).EQ.1) THEN WRITE(U6,111)NCRSSD END IF CALL RCHECK(10,NCRSSD,0) IF(NCRSSD.GT.0) THEN CALL INTIN(12,CROSSD,NCRSSD,ENDFLE) IF(IFILEF(2).NE.0) THEN WRITE(11,102)(CROSSD(I),I=1,NCRSSD) END IF IF(IOPTN(1).EQ.1) THEN WRITE(U6,112)(CROSSD(I),I=1,NCRSSD) END IF END IF ILC=1 C C Create an array of pointers, CDMPNT, from the variables to C the starting entries in CROSSD C DO 13 I=1,NVTOT J=MTYPE(I) IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN CDMPNT(I)=ILC ILC=CROSSD(ILC)+ILC+2 ELSE CDMPNT(I)=0 END IF 13 CONTINUE IF(NCRSSD+1.NE.ILC) THEN WRITE(U6,201) GO TO 95 END IF ILC=0 C C Read variable names and labels, and create an array of pointers, C LPOINT, to labels for the levels of the variables C IF(IOPTN(1).EQ.1) THEN WRITE(U6,113) END IF DO 16 I=1,NVTOT READ(12)VNAME(I),LABEL(I) IF(IFILEF(2).NE.0) THEN WRITE(11,114)VNAME(I),LABEL(I) END IF IF(IOPTN(1).EQ.1) THEN WRITE(U6,115)VNAME(I),LABEL(I) END IF J=MTYPE(I) IF(J.EQ.3.OR.J.EQ.4.OR.J.EQ.5.OR.J.EQ.13) THEN LPOINT(I)=ILC+1 ILC=ILC+MSIZE(I) ELSE IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN LPOINT(I)=ILC+1 K=CDMPNT(I) L=CROSSD(K) DO 14 M=1,L K=K+1 ILC=ILC+CROSSD(K)+1 14 CONTINUE ELSE LPOINT(I)=0 END IF 16 CONTINUE C C Read in labels for the levels C READ(12)NCRVL CALL RCHECK(7,NCRVL,0) IF(IFILEF(2).NE.0) THEN WRITE(11,102)NCRVL END IF IF(IOPTN(1).EQ.1) THEN WRITE(U6,116)NCRVL END IF IF(ILC.NE.NCRVL) THEN WRITE(U6,201) GO TO 95 END IF IF(ILC.GT.0) THEN DO 20 I=1,ILC READ(12)LEVEL(I) IF(IFILEF(2).NE.0) THEN WRITE(11,117)LEVEL(I) END IF IF(IOPTN(1).EQ.1) THEN WRITE(U6,118)LEVEL(I) END IF 20 CONTINUE END IF READ(12)ILC IF(IFILEF(2).NE.0) THEN WRITE(11,102)ILC END IF IF(IOPTN(1).EQ.1) THEN WRITE(U6,119)ILC END IF C C Read in variable names for crossed variables C CALL RCHECK(13,ILC,0) SVTEMP=ILC+1 IF(ILC.GT.0) THEN DO 22 I=1,ILC READ(12)VTEMP(I) IF(IFILEF(2).NE.0) THEN WRITE(11,114)VTEMP(I) END IF IF(IOPTN(1).EQ.1) THEN WRITE(U6,115)VTEMP(I) END IF 22 CONTINUE END IF IF(NBY.GE.1) THEN READ(12)NBYGRP IF(IFILEF(2).NE.0) THEN WRITE(11,102)NBYGRP END IF IF(IOPTN(1).EQ.1) THEN WRITE(U6,120)NBYGRP END IF SDBYID=NXPTD K=NBYGRP*NBY CALL ROOMD(K) K=SDBYID-1 DO 27 I=1,NBYGRP READ(12)(DX(K+J),J=1,NBY) IF(IFILEF(2).NE.0) THEN WRITE(11,103)(DX(K+J),J=1,NBY) END IF IF(IOPTN(1).EQ.1) THEN WRITE(U6,124)(DX(K+J),J=1,NBY) END IF K=K+NBY 27 CONTINUE ELSE SDBYID=0 NBYGRP=1 END IF READ(12)NRPTOT IF(IFILEF(2).NE.0) THEN WRITE(11,102)NRPTOT END IF IF(IOPTN(1).EQ.1) THEN WRITE(U6,121)NRPTOT END IF IF(NRPTOT.GT.0) THEN SDCOEF=NXPTD CALL ROOMD(NRPTOT) CALL UNFIN(12,DX(SDCOEF),NRPTOT,ENDFLE) K=SDCOEF+NRPTOT-1 IF(IFILEF(2).NE.0) THEN WRITE(11,103)(DX(I),I=SDCOEF,K) END IF IF(IOPTN(1).EQ.1) THEN WRITE(U6,122)(DX(I),I=SDCOEF,K) END IF ELSE SDCOEF=0 END IF IF(IOPTN(2).LE.-2) THEN IOPTN(2)=NRPTOT END IF K1=NXPTD K2=NXPTD+NIDTOT I=NIDTOT+TSIZE CALL ROOMD(I) DO 50 IBY=1,NBYGRP DO 40 IREP=0,NRPTOT READ(12)(DX(K1+I-1),I=1,NIDTOT) CALL UNFIN(12,DX(K2),TSIZE,ENDFLE) IF(IFILEF(2).NE.0) THEN WRITE(11,103)(DX(K1+I-1),I=1,NIDTOT) WRITE(11,103)(DX(K2+I-1),I=1,TSIZE) END IF IF(IOPTN(1).EQ.1) THEN IF(IREP.LE.IOPTN(2)) THEN WRITE(U6,124)(DX(K1+I-1),I=1,NIDTOT) WRITE(U6,124)(DX(K2+I-1),I=1,TSIZE) ELSE IF(IBY.EQ.NBYGRP)GO TO 50 END IF END IF 40 CONTINUE 50 CONTINUE 94 CONTINUE CLOSE(12) IF(IFILEF(2).NE.0) THEN CLOSE(11) END IF RETURN 95 CONTINUE WRITE(U6,201) CALL FSTOP END SUBROUTINE IMPORT IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MAXSUB=500,MAXSBL=2000) PARAMETER (MAXFMT=20) PARAMETER (NOPTN=3) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 CHARACTER*256 CARD COMMON /CRDBLK/CARD C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT C INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI, . NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL), . U5LCSW COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI, . NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW C INTEGER ITYPEF(3),IFILEF(3) C LOGICAL REFRSH,LTEMP EXTERNAL REFRSH 102 FORMAT(10I8) 103 FORMAT(3D24.16) 114 FORMAT(A12,A24) 117 FORMAT(A24) 200 FORMAT(' NO VPLX FILE') 201 FORMAT(' ERROR IN SPECIFICATION') ITYPEF(1)=1 ITYPEF(2)=2 ITYPEF(3)=0 CALL KYFIND(IKEY,IPT) CALL CRDPRN(3) CALL FNREAD(IPT,ITYPEF,IFILEF,1,IPOSSC) IF(IMERR1.GT.0) THEN CALL FSTOP END IF IF(IFILEF(2).EQ.0) THEN WRITE(U6,200) CALL FSTOP END IF IF(IPOSSC.GT.0) THEN U5LCSW=1 C ! Reset U5LCSW used by REFRSH, etc. END IF 3 CONTINUE IF(U5END.GT.0)GO TO 60 LTEMP=REFRSH(IPT) 4 CONTINUE IF(U5END.GT.0)GO TO 60 CALL KYFIND(IKEY,IPT) IF(IKEY.EQ.-1) THEN CALL CRDPRN(1) GO TO 4 END IF 60 CONTINUE READ(12,102)IVERSN IF(IVERSN.NE.9203)CALL FSTOP READ(12,102)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE, . VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR WRITE(11)IVERSN WRITE(11)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE, . VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR CALL RCHECK(2,NVTOT,0) NID=NVARID+NBY C C NVTOT - total number of variables on file C NVREG - number of variables, excluding class, variance id's, C BY variables, and weight variable C NCLASS - total number of class variables C NVARID - number of variance id's, excluding BY variables C NBY - number of BY variables C NWGT - 0 or 1 indicating unweighted vs. weighted analysis C VFTYPE - type of input used to create the file C VROPTN - variance option C TSIZE - total size of matrix C NCLBLK - total number of class blocks C NCLBAR - total size of class block information arrays C C VFTYPE = 3 Weighted obs. with cluster/replicate number C 4 Unweighted " C 5 Replicate weights C 6 Unweighted initial obs. followed by replicate weights C 7 Replicate factors multiplying initial weight C 8 Replicate factors of unweighted initial obs ( = VFTYPE 6) C 11 Replicate factors multiplying initial weight, including C factor for replicate 0, overall estimate C 12 Unweighted initial obs " (= VFTYPE 5) C 13 Weighted obs. with cluster code C 14 Unweighted " C 15 Weighted obs. Stratum no. cluster code C 16 Unweighted " C 17 Wtd. Stratum code, cluster code C 18 Unwtd " C 21 Wtd. Stratum no. 2nd stage no, cluster code C 22 Unwtd. " C 23 Wtd. Stratum no. 2nd stage cd, cluster code C 24 Unwtd. " C 25 Wtd. Stratum code 2nd stage no. cluster code C 26 Unwtd " C 27 Wtd. Stratum code 2nd stage cd, cluster code C 28 Unwtd. " C 29 Wtd 2nd stage number cluster code C 30 Unwtd. " C 31 Wtd 2nd stage code cluster code C 32 Unwtd " C 33 Wtd Replicate number governed by stratum counts C 34 Unwtd " C 35 Wtd Rep numb govrned by stratum and 2nd stage counts C 36 Unwtd " C 37 Wtd Rep number governed by 2nd stage counts C 38 Unwtd " C CALL RCHECK(8,NCLBLK,0) CALL RCHECK(9,NCLBAR,0) DO 11 I=1,NCLBLK READ(12,102)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I), . BLVSIZ(I),BLNCLS(I),BLCPNT(I) WRITE(11)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I), . BLVSIZ(I),BLNCLS(I),BLCPNT(I) 11 CONTINUE IF(NCLBAR.GT.0) THEN READ(12,102)(CLTYPE(I),I=1,NCLBAR) READ(12,102)(CLPNT(I),I=1,NCLBAR) CALL INTOUT(11,CLTYPE,NCLBAR) CALL INTOUT(11,CLPNT,NCLBAR) END IF C C BLTYPE - 1 or 0 indicating row of (weighted) n vs. no row C BLXSTR - pointer to first cell of incoming data in X matrix C BLXINC - length of the X matrix for a single combination C of the class variables in the block C BLXSIZ - total size of block data in X matrix (integer multiple C of BLXINC) C BLVSTR - pointer to first variable C BLVSIZ - number of variables in block C BLNCLS - number of class variables in block C BLCPNT - pointer for class information C CLTYPE - type of class in array C CLPNT - pointer to class variables C IF(NVTOT.GT.0) THEN READ(12,102)(MTYPE(I),I=1,NVTOT) READ(12,102)(MSIZE(I),I=1,NVTOT) CALL INTOUT(11,MTYPE,NVTOT) CALL INTOUT(11,MSIZE,NVTOT) END IF C C Variable types are read into MTYPE C C Contents of MTYPE C 1 = real variable (total) C 2 = real variable with missing checks C 3 = categorical variable C 4 = class variable, known dimension C 5 = by variable, known dimension C 6 = by variable, unknown dimension C 7 = select transformation (not variable type) C 8 = cross variable, real value C 9 = cross variable, categorical C 11 = derived variable C 13 = crossed derived variable, single dimension C 19 = crossed derived variable C C C Sizes are read into MSIZE C IF(NVREG.GT.0) THEN READ(12,102)(VMAPL(I),I=1,NVREG) CALL INTOUT(11,VMAPL,NVREG) END IF C C VMAPL contains pointers to the first NVREG variables C READ(12,102)NCRSSD WRITE(11)NCRSSD CALL RCHECK(10,NCRSSD,0) IF(NCRSSD.GT.0) THEN READ(12,102)(CROSSD(I),I=1,NCRSSD) CALL INTOUT(11,CROSSD,NCRSSD) END IF ILC=1 C C Create an array of pointers, CDMPNT, from the variables to C the starting entries in CROSSD C DO 13 I=1,NVTOT J=MTYPE(I) IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN CDMPNT(I)=ILC ILC=CROSSD(ILC)+ILC+2 ELSE CDMPNT(I)=0 END IF 13 CONTINUE IF(NCRSSD+1.NE.ILC) THEN WRITE(U6,201) GO TO 95 END IF ILC=0 C C Read variable names and labels, and create an array of pointers, C LPOINT, to labels for the levels of the variables C DO 16 I=1,NVTOT READ(12,114)VNAME(I),LABEL(I) WRITE(11)VNAME(I),LABEL(I) J=MTYPE(I) IF(J.EQ.3.OR.J.EQ.4.OR.J.EQ.5.OR.J.EQ.13) THEN LPOINT(I)=ILC+1 ILC=ILC+MSIZE(I) ELSE IF(J.EQ.8.OR.J.EQ.9.OR.J.EQ.19) THEN LPOINT(I)=ILC+1 K=CDMPNT(I) L=CROSSD(K) DO 14 M=1,L K=K+1 ILC=ILC+CROSSD(K)+1 14 CONTINUE ELSE LPOINT(I)=0 END IF 16 CONTINUE C C Read in labels for the levels C READ(12,102)NCRVL WRITE(11)NCRVL CALL RCHECK(7,NCRVL,0) IF(ILC.NE.NCRVL) THEN WRITE(U6,201) GO TO 95 END IF IF(ILC.GT.0) THEN DO 20 I=1,ILC READ(12,117)LEVEL(I) WRITE(11)LEVEL(I) 20 CONTINUE END IF READ(12,102)ILC WRITE(11)ILC C C Read in variable names for crossed variables C CALL RCHECK(13,ILC,0) SVTEMP=ILC+1 IF(ILC.GT.0) THEN DO 22 I=1,ILC READ(12,114)VTEMP(I) WRITE(11)VTEMP(I) 22 CONTINUE END IF IF(NBY.GE.1) THEN READ(12,102)NBYGRP WRITE(11)NBYGRP SDBYID=NXPTD K=NBYGRP*NBY CALL ROOMD(K) K=SDBYID-1 DO 27 I=1,NBYGRP READ(12,103)(DX(K+J),J=1,NBY) WRITE(11)(DX(K+J),J=1,NBY) K=K+NBY 27 CONTINUE ELSE SDBYID=0 NBYGRP=1 END IF READ(12,102)NRPTOT WRITE(11)NRPTOT IF(NRPTOT.GT.0) THEN SDCOEF=NXPTD CALL ROOMD(NRPTOT) K=SDCOEF+NRPTOT-1 READ(12,103)(DX(I),I=SDCOEF,K) CALL UNFOUT(11,DX(SDCOEF),NRPTOT) ELSE SDCOEF=0 END IF K1=NXPTD K2=NXPTD+NIDTOT I=NIDTOT+TSIZE CALL ROOMD(I) DO 50 IBY=1,NBYGRP DO 40 IREP=0,NRPTOT READ(12,103)(DX(K1+I-1),I=1,NIDTOT) READ(12,103)(DX(K2+I-1),I=1,TSIZE) WRITE(11)(DX(K1+I-1),I=1,NIDTOT) CALL UNFOUT(11,DX(K2),TSIZE) 40 CONTINUE 50 CONTINUE 94 CONTINUE CLOSE(11) CLOSE(12) RETURN 95 CONTINUE WRITE(U6,201) CALL FSTOP END C C End of CN.FOR C SUBROUTINE JACKKN IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MSIZEI=100000) PARAMETER (MVAR=10000,MLEVEL=10000,MCRSSD=500) PARAMETER (MCLBLK=200,MCLBAR=1000) PARAMETER (MRANGE=10000,MRECOD=50000,MRNSET=2000,MAXIDS=10) PARAMETER (MAXSUB=500,MAXSBL=2000) PARAMETER (MAXFMT=20) C PARAMETER (MTRANS=1500,MRANGS=20) PARAMETER (MTRSZI=MSIZEI+6*MRANGE-6*MRANGS+2*MRNSET+MRECOD) PARAMETER (IXFLLD=32+3*MAXIDS) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX C COMMON /VBLOCK/IVERSN,NVTOT,NVREG,NCLASS,NVARID,NBY,NID,NWGT, . VFTYPE,VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR,NCRSSD,NCRVL,NBYGRP, . SDBYID,NRPTOT,SDCOEF,SVTEMP, . BLTYPE,BLXSTR,BLXINC,BLXSIZ,BLVSTR,BLVSIZ,BLNCLS,BLCPNT,CLTYPE, . CLPNT,MTYPE,MSIZE,VMAPL,CROSSD,CDMPNT,LPOINT C C NVARID (NID1) C INTEGER VFTYPE,VROPTN,TSIZE,SDBYID,SDCOEF,SVTEMP INTEGER BLTYPE(MCLBLK),BLXSTR(MCLBLK),BLXINC(MCLBLK), . BLXSIZ(MCLBLK),BLVSTR(MCLBLK),BLVSIZ(MCLBLK),BLNCLS(MCLBLK), . BLCPNT(MCLBLK),CLTYPE(MCLBAR),CLPNT(MCLBAR) INTEGER MTYPE(MVAR),MSIZE(MVAR),VMAPL(MVAR),CROSSD(MCRSSD), . CDMPNT(MVAR),LPOINT(MVAR) C INTEGER NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI, . NSUBLN(MAXSUB),IPTSBL(MAXSUB),NSBCHR(MAXSBL),IPTSBC(MAXSBL), . U5LCSW COMMON /SUBBLK/NSUB,NSUBLM,NSUBCM,ISUBCN,ILNCNT,ICHCNT,CININI, . NSUBLN,IPTSBL,NSBCHR,IPTSBC,U5LCSW C C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL C CHARACTER*12 VNAME(MVAR),VTEMP(MVAR),VNKEEP(MVAR) CHARACTER*24 LABEL(MVAR),LEVEL(MLEVEL) COMMON /VNBLCK/VNAME,VTEMP,VNKEEP COMMON /VLBLCK/LABEL,LEVEL C LOGICAL REFRSH,ALPCHK,CLMTCH EXTERNAL REFRSH,ALPCHK,CLMTCH C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 C CHARACTER*256 CARD COMMON /CRDBLK/CARD C INTEGER ITYPEF(3),IFILEF(3) LOGICAL LTEMP,ENDFLE INTEGER SDTOT,SDREP,SDCONS C DOUBLE PRECISION MISSNG,T DATA MISSNG/-98765.432109D0/ C 200 FORMAT(' INCOMPLETE FILE SPECIFICATION') C ITYPEF(1)=2 ITYPEF(2)=2 ITYPEF(3)=0 CALL CRDPRN(3) CALL KYFIND(IKEY,IPT) CALL FNREAD(IPT,ITYPEF,IFILEF,1,IPOSSC) IF(IMERR1.GT.0) THEN CALL FSTOP END IF IF(IFILEF(2).EQ.0) GO TO 95 ISOPEN=0 CALL PREAMB IF(IVERSN.EQ.9004) THEN NIDOUT=NID ELSE NIDOUT=NIDTOT END IF IF(IPOSSC.GT.0) THEN U5LCSW=1 C ! Reset U5LCSW used by REFRSH, etc. END IF 1 CONTINUE LTEMP=REFRSH(IPT) 2 CONTINUE IF(U5END.GT.0)GO TO 7 CALL KYFIND(IKEY,IPT) IF(IKEY.EQ.-1) THEN CALL CRDPRN(1) GO TO 2 END IF 7 CONTINUE IF(ISOPEN.EQ.0.AND.NBY.GE.1) THEN I=13 CALL SCOPEN(I) END IF WRITE(11)IVERSN WRITE(11)NVTOT,NVREG,NCLASS,NVARID,NBY,NWGT,VFTYPE, . VROPTN,NIDTOT,TSIZE,NCLBLK,NCLBAR DO 11 I=1,NCLBLK WRITE(11)BLTYPE(I),BLXSTR(I),BLXINC(I),BLXSIZ(I),BLVSTR(I), . BLVSIZ(I),BLNCLS(I),BLCPNT(I) 11 CONTINUE IF(NCLBAR.GT.0) THEN CALL INTOUT(11,CLTYPE,NCLBAR) CALL INTOUT(11,CLPNT,NCLBAR) END IF IF(NVTOT.GT.0) THEN CALL INTOUT(11,MTYPE,NVTOT) CALL INTOUT(11,MSIZE,NVTOT) END IF IF(NVREG.GT.0)CALL INTOUT(11,VMAPL,NVREG) WRITE(11)NCRSSD IF(NCRSSD.GT.0)CALL INTOUT(11,CROSSD,NCRSSD) DO 12 I=1,NVTOT WRITE(11)VNAME(I),LABEL(I) 12 CONTINUE WRITE(11)NCRVL IF(NCRVL.GT.0) THEN DO 13 I=1,NCRVL WRITE(11)LEVEL(I) 13 CONTINUE END IF ILC=SVTEMP-1 WRITE(11)ILC DO 14 I=1,ILC WRITE(11)VTEMP(I) 14 CONTINUE IF(NBY.GE.1) THEN WRITE(11)NBYGRP K=SDBYID-1 DO 15 I=1,NBYGRP WRITE(11)(DX(K+J),J=1,NBY) K=K+NBY 15 CONTINUE ELSE NBYGRP=1 END IF WRITE(11)NRPTOT IF(NRPTOT.GT.0) THEN CALL UNFOUT(11,DX(SDCOEF),NRPTOT) END IF SDTOT=NXPTD CALL ROOMD(TSIZE) SDREP=NXPTD CALL ROOMD(TSIZE) SDCONS=NXPTD CALL ROOMD(TSIZE) DO 25 IBYGRP=1,NBYGRP DO 20 IREP=0,NRPTOT READ(12)(DX(NXPTD+I-1),I=1,NIDOUT) IF(IREP.EQ.0) THEN K=SDTOT DO 16 I=1,TSIZE DX(SDCONS+I-1)=0. 16 CONTINUE ELSE K=SDREP T=DX(SDCOEF+IREP-1) END IF CALL UNFIN(12,DX(K),TSIZE,ENDFLE) IF(IREP.GT.0) THEN DO 18 I=1,TSIZE IF(DABS(DX(SDREP+I-1)-MISSNG).GT..1D-6) THEN DX(SDCONS+I-1)=DX(SDCONS+I-1)+T*(DX(SDREP+I-1)-DX(SDTOT+I-1)) END IF 18 CONTINUE END IF 20 CONTINUE DO 22 I=1,TSIZE IF(DABS(DX(SDTOT+I-1)-MISSNG).GT..1D-6) THEN DX(SDTOT+I-1)=DX(SDTOT+I-1)-DX(SDCONS+I-1) END IF 22 CONTINUE IF(NBY.GE.1) THEN CALL UNFOUT(13,DX(SDTOT),TSIZE) END IF 25 CONTINUE IF(NBY.GE.1)REWIND(13) REWIND(12) NXPTD=SDREP CALL PREAMB IF(NBYGRP.EQ.0)NBYGRP=1 NXPTD=SDREP DO 35 IBYGRP=1,NBYGRP IF(NBY.GE.1)CALL UNFIN(13,DX(SDTOT),TSIZE,ENDFLE) DO 32 IREP=0,NRPTOT READ(12)(DX(NXPTD+I-1),I=1,NIDOUT) WRITE(11)(DX(NXPTD+I-1),I=1,NIDOUT) IF(IREP.EQ.0) THEN CALL UNFIN(12,DX(SDREP),TSIZE,ENDFLE) ELSE CALL UNFIN(12,DX(SDTOT),TSIZE,ENDFLE) END IF CALL UNFOUT(11,DX(SDTOT),TSIZE) 32 CONTINUE 35 CONTINUE REWIND(12) CLOSE (11) RETURN 95 CONTINUE WRITE(U6,200) 99 CONTINUE CALL FSTOP END C C Arrays in calling sequences - Transform step execution C C The USER routines have a common calling sequence for arrays. The C built-in subroutines in the TRANSFORM step also employ the same C conventions, although often one or more of the arguments will be C omitted from the list if they are not used. C C The arguments of USER1 have the following interpretations: C C DID - A double precision array with the identifiers for the C replicate. Generally, these vary with the replication C method, and they are not fully documented here. C C The first element, DID(1), provides a number for the C replicate, starting with DID(1)=0 for the full sample, C regardless of the replication method. Thus, DID(1) C is useful to subroutines that must perform a different C action depending on whether it is being called with C the full sample values or for replicate values. C C NID - The integer dimension of DID. C C IFIRST - An integer flag set to 1 if DID(1)=0 and if this is C the first BY group when one or more BY variables are C defined. If there are no BY variables, then it is C simply set to 1 for DID(1)=0. In either case, it C identifies the first call to the subroutine from the C user's application. C C IVLIST - An array of integer constants with the following meanings: C IVLIST(1) - The number of old variables C IVLIST(2) - The number of modified variables C IVLIST(3) - The number of new variables C Note: Arrays such as DIMPNT are ordered with C respect to old variables first, followed by C modify variables and then new variables. C IVLIST(4) - = 0 - no double precision constants are C provided C > 0 - the starting location, in DX, of C double precision constants. C IVLIST(5) - The number of double precision constants C provided. It is =0 if no constants are C provided. C Note: Subroutines may check either IVLIST(4) C or IVLIST(5) to establish whether constants C are provided. C IVLIST(6) - The number of strings of length 128 that C have been passed. C IVLIST(7) - The number of integer constants passed in IX. C C DIMPNT - An integer array, of dimension NVAR=IVLIST(1)+IVLIST(2)+ C IVLIST(3), which points to starting positions in DIMX. C DIMPNT(1)=1, that is, entries for the first variable C begin in DIMX(1), but other values of DIMPNT may vary. C C DIMX - An integer array with information about the dimensions of C each variable. DIMPNT provides pointers to each variable's C first position in DIMX. C C The first element, DIMX(DIMPNT(IV)), provides the dimension C of variable IV. It may be 0. Otherwise, the number of C levels of each dimension follow in DIMX. A real variable C crossed by 2 class variables thus would have 3 elements in C DIMX, the first of which is 2, followed by the number of C levels from each class. C C DXPNT - An integer array pointing to starting locations in DX for C each variable. DXPNT(1) is typically >1, that is, DXPNT C will point to locations somewhere in DX, not necessarily C at the beginning. C Note: Application subroutines must take care not to C address locations other than those indicated through C DXPNT. C C DX - The general double precision array. Space in this array C is pointed to through IVLIST(4) and DXPNT. C C MSIZE - An integer array giving the total size of each variable. C C MTYPE - An integer array indicating the type of each variable. C =1 for real variables. C C MTRAN - A code indicating whether the variable has been transformed. C C STRING - An array of character*128 constants, used for formats, etc. C C IX - An integer array of constants, beginning with IX(1). C IVLIST(7) indicates their number. IVLIST(7) may be 0. C C ITRANS - An integer indicating the subroutine number. ITRANS may be C used for error messages and is used by subroutines C employing unit 13 to read and write scratch data. C C IERROR - A flag indicating whether a warning or error condition C occurred. C C SUBROUTINE USER1(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,ITRANS,IERROR) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) 100 FORMAT(' REPLICATE',I3,', V1=',F8.2,', V2=',F8.2,' RATIO=',F8.4) IF(DX(DXPNT(1)).GT.1.D0) THEN DX(DXPNT(1))=1.D0 END IF RETURN END SUBROUTINE USER2(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,ITRANS,IERROR) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) 100 FORMAT(' REPLICATE',I3,', V1=',F8.2,', V2=',F8.2,' RATIO=',F8.4) IF(DX(DXPNT(2)).GT.0.) THEN DX(DXPNT(3))=DX(DXPNT(1))/DX(DXPNT(2)) ELSE DX(DXPNT(3))=0. END IF K=DID(1)+.05D0 WRITE(6,100)K,DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3)) RETURN END SUBROUTINE USER3(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,ITRANS,IERROR) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) 100 FORMAT(' USER3 NOT AVAILABLE') WRITE(6,100) IERROR=1 RETURN END SUBROUTINE USER4(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,ITRANS,IERROR) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) 100 FORMAT(' USER4 NOT AVAILABLE') WRITE(6,100) IERROR=1 RETURN END SUBROUTINE USER5(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,ITRANS,IERROR) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) 100 FORMAT(' USER5 NOT AVAILABLE') WRITE(6,100) IERROR=1 RETURN END SUBROUTINE USER6(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,ITRANS,IERROR) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) 100 FORMAT(' USER6 NOT AVAILABLE') WRITE(6,100) IERROR=1 RETURN END SUBROUTINE USER7(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,ITRANS,IERROR) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) 100 FORMAT(' USER7 NOT AVAILABLE') WRITE(6,100) IERROR=1 RETURN END SUBROUTINE USER8(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,ITRANS,IERROR) implicit double precision (a-h,o-z) double precision y(396),v(396),ysum(396),y2sum(396),vsum(396), . cisum(396),en(2,2,2),bval(6,2,2) double precision ymean(396) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) integer icf(396),iv(396) common /iblck8/iex,icf,iv common /dblck8/y,v,ysum,y2sum,vsum,cisum,ymx,csum,ycsum,ymean character*11 fname,fnamea,fnameb,fnamec data (((bval(i,j,k),i=1,6),j=1,2),k=1,2)/ . -.15,-.45,.00159,.00711,.01938,-.02808, . -.15,.45,.05625,-.01920,-.02310,-.01395, . .15,.45,-.00159,-.00711,-.01938,.02808, . .15,-.45,-.05625,.01920,.02310,.01395/ data fname/'mars '/ data fnamea/'taba '/ data fnameb/'tabb '/ data fnamec/'tabc '/ 100 format(i3) 101 format(12x,2f22.8) 102 format(14x,3d22.14,/,14x,3d22.14) 201 format(i1,'.dat') 202 format(i2,'.dat') 203 format(i3,'.dat') 204 format(d21.14,2d20.14,2i4,d20.14) 205 format(3d22.14,/,3d22.14) if(ifirst.ne.1)return open(30,file='batchnum.dat') read(30,100)ibatch ibatch=ibatch+1 rewind (30) write(30,100)ibatch close (30) if(ibatch.le.9) then write(fname(5:9),201)ibatch else if(ibatch.le.99) then write(fname(5:10),202)ibatch else write(fname(5:11),203)ibatch end if do 5 i=1,396 ysum(i)=0. y2sum(i)=0. vsum(i)=0. icf(i)=0 cisum(i)=0. iv(i)=0 5 continue open(34,file=fname) do 80 irep=1,50 if(irep.le.9) then write(fnamea(5:9),201)irep write(fnameb(5:9),201)irep write(fnamec(5:9),201)irep else if(irep.le.99) then write(fnamea(5:10),202)irep write(fnameb(5:10),202)irep write(fnamec(5:10),202)irep else write(fnamea(5:11),203)irep write(fnameb(5:11),203)irep write(fnamec(5:11),203)irep end if open(31,file=fnamea) open(32,file=fnameb) open(33,file=fnamec) do 7 i=1,66 read(33,101)ymean(i) ymean(i+66)=ymean(i) ymean(i+132)=ymean(i) ymean(i+198)=ymean(i) ymean(i+264)=0. 7 continue do 10 k=1,2 do 9 i=1,2 do 8 j=1,2 read(33,101)en(i,j,k) 8 continue 9 continue 10 continue close(33) do 20 j=1,2 indj=265+j*18 do 14 k=1,2 jj=3-j ind=indj+k*6 do 12 i=1,6 ymean(ind)=bval(i,k,j)*en(jj,k,1)*en(j,k,2)/ . (.15d0 * (en(1,k,1) + en(2,k,1))) ind=ind+1 12 continue 14 continue ind=indj do 16 i=1,6 ymean(ind)=(ymean(ind+6)+ymean(ind+12))/ . ( en(j,1,1)+en(j,2,1)+en(j,1,2)+en(j,2,2) ) ind=ind+1 16 continue do 19 k=1,2 ind=indj+k*6 do 18 i=1,6 ymean(ind)=ymean(ind)/(en(j,k,1)+en(j,k,2)) ind=ind+1 18 continue 19 continue 20 continue ymean(320)=ymean(283)-ymean(301) ymean(322)=ymean(284)-ymean(302) ymean(327)=ymean(285)-ymean(303) ymean(328)=ymean(286)-ymean(304) ymean(329)=ymean(287)-ymean(305) ymean(330)=ymean(288)-ymean(306) c write(*,*)(((en(i,j,k),i=1,2),j=1,2),k=1,2) do 22 i=1,66 ymean(i+330)=ymean(i+264) c write(*,*)ymean(i+264) 22 continue do 62 i=1,396 if(i.le.66) then read(31,101)y(i),v(i) else read(32,101)y(i),v(i) end if if(dabs(y(i)+98765.432109d0).gt.1.d0) then iv(i)=iv(i)+1 ysum(i)=ysum(i)+y(i) y2sum(i)=y2sum(i)+(y(i)-ymean(i))*(y(i)-ymean(i)) cisum(i)=cisum(i)+1.96d0*v(i) vsum(i)=vsum(i)+v(i)*v(i) if(dabs(y(i)-ymean(i)).lt.1.96d0*v(i)) then icf(i)=icf(i)+1 end if end if 62 continue 79 continue close(31) close(32) 80 continue do 82 i=1,396 write(34,204)ysum(i),y2sum(i),vsum(i),icf(i),iv(i),cisum(i) 82 continue close (34) RETURN END SUBROUTINE USER9(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZEM,MTYPE,MTRAN,STRING,IX,ITRANS,IERROR) parameter (mpsize=150,mm=5,nrep=1,mstsiz=25) parameter (ns=100,msize=100,npstrt=6,nstrt=4) parameter (nrepf=200) implicit double precision (a-h,o-z) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZEM(*), . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) double precision y(mpsize),yobs(mstsiz,nstrt) double precision fpc(nstrt) integer rf(mpsize),mx1(mpsize),mxa(mpsize) double precision yix(mpsize,mm),w1(msize),w2(msize) integer iclus(mpsize),irepf(nrepf),istrat(mpsize) double precision normal,drand external drand,normal integer nclusm(npstrt),mclszm(npstrt),nobs(npstrt) common /dblck9/y,yobs,fpc,yix,w1,w2 common /iblck9/rf,mx1,mxa data nclusm/6*25/ data mclszm/6*1/ 100 format(i12) 101 format(i5,3i2,i4,f8.6,f10.6) 102 format(4f10.7) 201 format(i5,5i2,i4,' 0',f4.1,f10.6,200i1) 202 format(i5,5i2,i4,i2,f4.1,f10.6,200i1) 203 format(i5,' 2',4i2,i4,i2,f4.1,f10.6,200i1) 301 format(i5,4i2,f10.6) if(ifirst.ne.1)return open(31,file='ex1.dat') open(32,file='ex2.dat') open(33,file='ex3.dat') open(30,file='rand.dat') read(30,100)iseed read(30,100)iseed2 close(30) do 2 i=1,nrepf irepf(i)=1 2 continue do 90 irep=1,nrep C C This loop determines missing/observed and the counts in the C 4-cell table cross-classifying the 2 categorical variables. C i=0 ic=0 do 10 ist=1,npstrt nobs(ist)=0 icsize=mclszm(ist) do 8 k = 1, nclusm(ist) ic=ic+1 if(drand(iseed).le..7d0) then irf=1 else irf=0 end if clval=normal (iseed2) do 6 ii=1,icsize i=i+1 rf(i)=irf iclus(i)=ic istrat(i)=ist if(ist.eq.2.or.ist.eq.4) then w1(i)=2. else w1(i)=1. end if if(drand(iseed).le..5d0) then mx1(i)=1 else mx1(i)=2 end if if(ist.le.2.or.ist.eq.5) then mxa(i)=1 else mxa(i)=2 end if y (i) = clval if(mx1(i).eq.1) then if(mxa(i).eq.1) then c y(i)=y(i)+2.d0 c c y(i)=y(i) else c y(i)=y(i)-1.d0 c c y(i)=y(i) end if else if(mxa(i).eq.1) then c y(i)=y(i)+1.d0 c c y(i)=y(i) else c y(i)=y(i)-2.d0 c c y(i)=y(i) end if end if if(rf(i).eq.1) then if(ist.le.4) then nobs(ist)=nobs(ist)+1 yobs(nobs(ist),ist)=y(i) end if end if 6 continue 8 continue 10 continue C C Fractionally weighted imputation. C i=0 do 20 ist=1,nstrt icsize=mclszm(ist) wadj=dble(float(icsize*nclusm(ist)))/dble(float(nobs(ist))) if(ist.eq.1.or.ist.eq.3) then fpc(ist)=dble(float(nobs(ist))) . /dble(float(icsize*nclusm(ist))) else fpc(ist)=dble(float(nobs(ist))) . /dble(float(2*icsize*nclusm(ist))) end if do 18 k = 1, nclusm(ist) do 16 ii=1,icsize i=i+1 w2(i)=wadj*w1(i) 16 continue 18 continue 20 continue i=0 do 30 ist=1,nstrt icsize=mclszm(ist) dn = nobs(ist) do 28 kk = 1, nclusm(ist) do 26 ii=1,icsize i=i+1 do 24 m=1,mm k = drand (iseed) * dn +1.d0 if(k.gt.nobs(ist)) k = nobs(ist) yix(i,m)= yobs(k,ist) 24 continue 26 continue 28 continue 30 continue do 32 i=1,ns if(rf(i).eq.1) then write(31,101)irep,mxa(i),mx1(i),istrat(i),iclus(i),w2(i),y(i) end if 32 continue open(30,file='fpctemp.dat') write(30,102)fpc close(30) ipanl=0 do 40 i=1,ns w3=.2d0*w1(i) irepf(50+i)=0 if(i.gt.25.and.i.le.50) then irepf(i-25)=0 else if(i.gt.75.and.i.le.100) then irepf(i-50)=0 end if if(rf(i).eq.1) then write(32,201)irep,rf(i),mxa(i),mx1(i),istrat(i),ipanl,iclus(i), . w1(i),y(i),irepf do 34 m=1,mm write(32,203)irep,mxa(i),mx1(i),istrat(i),ipanl,iclus(i), . m,w3,yix(i,m),irepf 34 continue else ipanl=ipanl+1 if(ipanl.gt.10)ipanl=1 do 36 m=1,mm k=145+5*ipanl+m irepf(k)=0 write(32,202)irep,rf(i),mxa(i),mx1(i),istrat(i),ipanl,iclus(i), . m,w3,yix(i,m),irepf irepf(k)=1 36 continue end if irepf(50+i)=1 if(i.gt.25.and.i.le.50) then irepf(i-25)=1 else if(i.gt.75.and.i.le.100) then irepf(i-50)=1 end if 40 continue do 42 i=1,mpsize write(33,301)irep,rf(i),mxa(i),mx1(i),istrat(i),y(i) 42 continue 90 continue open(30,file='rand.dat') write(30,100)iseed write(30,100)iseed2 close(30) close(31) close(32) close(33) RETURN END function normal(iseed) double precision normal integer iseed double precision drand,temp external drand temp=0. do 5 i=1,48 temp=temp+drand(iseed) 5 continue normal=(temp-24.d0)/2.d0 return end function drand(iseed) double precision drand integer iseed double precision dtemp,dtwo16,drmod,div double precision dm1,dm2,dseed1,dseed2 integer two16,iseed1,iseed2 c c multiplier = 742938285 c data two16/65536/,dtwo16/.65536d+05/ data dm1/.11336d+05/,dm2/.22189d+05/ div=.65536d+05*.32768d+05 drmod=div-1.0d0 iseed1=iseed/two16 iseed2=mod(iseed,two16) dseed1=iseed1 dseed2=iseed2 dtemp=dmod(dm2*dseed2,drmod)+dmod(dm1*dtwo16*dseed2,drmod) . +dmod(dm2*dtwo16*dseed1,drmod)+2.d0*dm1*dseed1 dtemp=dmod(dtemp,drmod) iseed=dtemp+.5 drand=dtemp/div return end SUBROUTINE USER10(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,ITRANS,IERROR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),ITRANS,IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL INTEGER MATSIZ EXTERNAL MATSIZ DOUBLE PRECISION MISSNG LOGICAL ENDFLE DATA MISSNG/-98765.432109D0/ 200 FORMAT(' RAO_SHAO: MUST CALL WITH MODIFY AND OLD VARIABLES') 201 FORMAT(' RAO_SHAO: MISMATCHING MATRICES') 202 FORMAT(' RAO_SHAO: FINAL DIMENSION MUST BE 2') 203 FORMAT(' RAO_SHAO: WRONG OLD VARIABLE TYPE') C C Establish NCELL, the number of imputation cells. C IREP=DABS(DID(1))+.5D0 IF(IVLIST(7).GE.1) THEN NCELL=IX(1) IF(IVLIST(7).GE.3) THEN NREP1=IX(2) NREP2=IX(3) C C Immediate return for final replicates, which are to estimate C prediction error of model for finite population values. C IF(IREP.GT.NREP1+NREP2) RETURN ELSE NREP1=IREP NREP2=0 END IF ELSE NCELL=1 NREP1=IREP NREP2=0 END IF IF(IFIRST.EQ.1) THEN C C Check for OLD and MODIFY variables only. C IF(IVLIST(3).GT.0.OR.IVLIST(1).EQ.0.OR.IVLIST(2).EQ.0) THEN WRITE(U6,200) GO TO 99 END IF IF(IVLIST(1).NE.1.AND.IVLIST(1).NE.IVLIST(2)) THEN GO TO 98 END IF C C Check that each final dimension is 2 C DO 2 I=1,IVLIST(1)+IVLIST(2) J=DIMPNT(I)+DIMX(DIMPNT(I)) IF(DIMX(J).NE.2) THEN WRITE(U6,202) GO TO 99 END IF 2 CONTINUE C C Now check that the sizes of matrices appear appropriate. C Determine the total storage that will be needed. C IOLD=1 INEW=IVLIST(1)+1 N=0 DO 4 I=1,IVLIST(2) NOLD=MATSIZ(DIMX(DIMPNT(IOLD)),MTYPE(IOLD),MTRAN(IOLD)) NNEW=MATSIZ(DIMX(DIMPNT(INEW)),MTYPE(INEW),MTRAN(INEW)) IF((MTYPE(IOLD).EQ.2.OR.MTYPE(IOLD).EQ.8).AND. . MTRAN(IOLD).EQ.0) THEN WRITE(U6,203) GO TO 99 END IF IF((MTYPE(INEW).EQ.2.OR.MTYPE(INEW).EQ.8).AND. . MTRAN(INEW).EQ.0.AND.NOLD*2.EQ.NNEW) THEN NNEW=NNEW/2 END IF IF(NCELL*2*(NOLD/(NCELL*2)).NE.NOLD)GO TO 98 IF(NCELL*2*(NNEW/(NCELL*2)).NE.NNEW)GO TO 98 IF(NOLD*(NNEW/NOLD).NE.NNEW)GO TO 98 N=N+NCELL*(NNEW/NOLD)+NNEW IF(I.EQ.1.OR.IVLIST(1).GT.1) THEN N=N+NOLD END IF INEW=INEW+1 IF(IVLIST(1).GT.1)IOLD=IOLD+1 4 CONTINUE C C If constants have been specified, check available space and C reallocate, if necessary. C IF(IVLIST(5).GT.0) THEN IF(IVLIST(5).LT.N) THEN IVLIST(4)=NXPTD IVLIST(5)=N CALL ROOMD(N) END IF END IF END IF IF(IVLIST(5).EQ.0) THEN C C If IVLIST(5)=0, then allocate temporary storage, and, if not full C sample, obtain the stored values from the scratch file. C IVLIST(4)=NXPTD NXPTDS=NXPTD IF(IREP.NE.0) THEN CALL SCPOSN(ITRANS,N) CALL ROOMD(N) CALL UNFIN(13,DX(IVLIST(4)),N,ENDFLE) END IF END IF C IOLD=1 INEW=IVLIST(1)+1 C C N is recomputed here, in case DID(1)=0 but IFIRST is not 1. C N=0 DO 40 IV=1,IVLIST(2) NOLD=MATSIZ(DIMX(DIMPNT(IOLD)),MTYPE(IOLD),MTRAN(IOLD)) NNEW=MATSIZ(DIMX(DIMPNT(INEW)),MTYPE(INEW),MTRAN(INEW)) IF((MTYPE(INEW).EQ.2.OR.MTYPE(INEW).EQ.8).AND. . MTRAN(INEW).EQ.0.AND.NOLD*2.EQ.NNEW) THEN INCR=2 ELSE INCR=1 END IF NVAL=NCELL*(NNEW/(NOLD*INCR)) C C For full sample, allocate the space if not already allocated. C NVAL is the number of values that need to be computed and C stored. C IF(IV.EQ.1.OR.IVLIST(1).GT.1) THEN J1=IVLIST(4)+N J2=J1+NOLD J=J2+NNEW NUSED=NOLD+NNEW+NVAL ELSE J1=IVLIST(4) J2=IVLIST(4)+N J=J2+NNEW NUSED=NNEW+NVAL END IF N=N+NUSED IF(DID(1).EQ.0.) THEN IF(IVLIST(5).EQ.0) THEN CALL ROOMD(NUSED) END IF IF(IV.EQ.1.OR.IVLIST(1).GT.1) THEN JOLD=DXPNT(IOLD) DO 6 I=1,NOLD DX(J1)=DX(JOLD) J1=J1+1 JOLD=JOLD+1 6 CONTINUE END IF JNEW=DXPNT(INEW) DO 8 I=1,NNEW DX(J2)=DX(JNEW) J2=J2+1 JNEW=JNEW+1 8 CONTINUE END IF C C NNEWC represents the length of the vector of values to be C stored for each imputation cell. NC is the number of cells C of the modified variable that are imputed from the same C imputation cell. C NNEWC=NVAL/NCELL NC=NOLD/(NCELL*2) JOLD=DXPNT(IOLD) DO 37 ICELL=1,NCELL JNEW=DXPNT(INEW)+(ICELL-1)*NNEW/(2*NCELL) JNEW2=J2+(ICELL-1)*NNEW/(2*NCELL) DO 35 NEWC=1,NNEWC JOLDT=JOLD JNEWT=JNEW JNEWT2=JNEW2 TV=0.D0 TN=0.D0 DO 14 I=1,NC IF(DABS(TV-MISSNG).GT..1D-6) THEN IF(DABS(DX(JNEWT)-MISSNG).GT..1D-6) THEN TV=TV+DX(JNEWT) ELSE TV=MISSNG END IF END IF IF(DABS(TN-MISSNG).GT..1D-6) THEN IF(DABS(DX(JOLDT)-MISSNG).GT..1D-6) THEN TN=TN+DX(JOLDT) ELSE TN=MISSNG END IF END IF C C This section restores the values for the replicate to the full C sample values for observed cases, for IREP > NREP1. C IF(NREP2.GT.0.AND.IREP.GT.NREP1) THEN DX(JNEWT)=DX(JNEWT2) IF(INCR.EQ.2) THEN DX(JNEWT+1)=DX(JNEWT2+1) END IF JNEWT2=JNEWT2+INCR*NNEWC END IF JNEWT=JNEWT+INCR*NNEWC JOLDT=JOLDT+1 14 CONTINUE C C Compute the mean within the imputation cell. C IF(DABS(TV-MISSNG).GT..1D-6) THEN IF(DABS(TN-MISSNG).GT..1D-6) THEN IF(TN.EQ.0.) THEN TV=MISSNG ELSE TV=TV/TN END IF ELSE TV=MISSNG END IF END IF C C For the full sample, simply store the mean. C IF(DID(1).EQ.0.) THEN DX(J)=TV ELSE C C For other replicates, subtract the full sample mean for the C imputation cell from the mean for this replicate, then C adjust each of the corresponding cells. C IF(DABS(TV-MISSNG).GT..1D-6) THEN IF(DABS(DX(J)-MISSNG).GT..1D-6) THEN TV=TV-DX(J) ELSE TV=MISSNG END IF END IF C C For replicates up through NREP1, multiply mean adjustment by C numbers of cases in this replicate. For IREP > NREP1, multiply C by full-sample N. C IF(IREP.LE.NREP1) THEN JOLDT=JOLD+NOLD/2 ELSE JOLDT=J1+NOLD/2 END IF JNEWT=JNEW+NNEW/2 JNEWT2=JNEW2+NNEW/2 DO 18 I=1,NC C C At this point, restore full sample (imputed) values for missing C cases if IREP > NREP1. C IF(IREP.GT.NREP1) THEN DX(JNEWT)=DX(JNEWT2) IF(INCR.EQ.2) THEN DX(JNEWT+1)=DX(JNEWT2+1) END IF JNEWT2=JNEWT2+INCR*NNEWC END IF IF(DX(JOLDT).NE.0.) THEN IF(DABS(DX(JNEWT)-MISSNG).GT..1D-6) THEN IF(DABS(TV-MISSNG).GT..1D-6) THEN DX(JNEWT)=DX(JNEWT)+DX(JOLDT)*TV ELSE DX(JNEWT)=MISSNG END IF END IF END IF JNEWT=JNEWT+INCR*NNEWC JOLDT=JOLDT+1 18 CONTINUE END IF J=J+1 JNEW=JNEW+INCR JNEW2=JNEW2+INCR 35 CONTINUE JOLD=JOLD+NC J1=J1+NC 37 CONTINUE INEW=INEW+1 IF(IVLIST(1).GT.1)IOLD=IOLD+1 40 CONTINUE IF(DID(1).EQ.0.) THEN IF(IVLIST(5).EQ.0) THEN WRITE(13)ITRANS,N CALL UNFOUT(13,DX(IVLIST(4)),N) END IF END IF C C If IVLIST(5)=0, have been reusing temporary storage. Setting C NXPTD=NXPTDS frees up temporary space. C IF(IVLIST(5).EQ.0) THEN NXPTD=NXPTDS END IF RETURN 98 CONTINUE WRITE(U6,201) 99 CONTINUE IERROR=1 RETURN END C SUBROUTINE SCRCOL(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL INTEGER MATSIZ EXTERNAL MATSIZ DOUBLE PRECISION MISSNG DATA MISSNG/-98765.432109D0/ C 200 FORMAT(' SIPPC_ROWCOL: WRONG NUMBER OF VARIABLES') 201 FORMAT(' SIPPC_ROWCOL: UNEXPECTED DIMENSIONS') 202 FORMAT(' SIPPC_ROWCOL: DISAGREEING SIZES') C IF(IFIRST.EQ.1) THEN C C Check that 3-4 old variables specified, 1 modify or new variable. C C First old variable - weighted counts C Second old variable - controls C Third old variable - unweighted counts C Fourth old variable or constants - scale values. C IF(((IVLIST(1).NE.3.OR.IVLIST(5).EQ.0).AND. . (IVLIST(1).NE.4.OR.IVLIST(5).NE.0)).OR. . (IVLIST(2)+IVLIST(3).NE.1)) THEN WRITE(U6,200) GO TO 99 END IF ITOP=IVLIST(1)+IVLIST(2)+IVLIST(3) ELSE ITOP=1 END IF C C Determine whether subroutine has been called for a single number of C rows or whether more than one rotation group is present C NROT=1 NROW=1 DO 2 I=1,ITOP J=DIMPNT(I)+1 JJ=DIMX(J-1) K=0 DO 1 IJ=1,JJ IF(DIMX(J).GT.1) THEN K=K+1 IF(K.EQ.1) THEN IF(I.EQ.1) THEN NROW=DIMX(J) ELSE IF(DIMX(J).NE.NROW) THEN WRITE(U6,202) GO TO 99 END IF END IF ELSE IF(K.EQ.2) THEN IF(I.EQ.1) THEN NROT=DIMX(J) ELSE IF(DIMX(J).NE.NROT) THEN WRITE(U6,202) GO TO 99 END IF ELSE WRITE(U6,201) GO TO 99 END IF END IF J=J+1 1 CONTINUE 2 CONTINUE C C Allocate space for constants C If scale values have been specified as constants, then move C them to new space and establish an additional space of NROW C as scratch. If the scale values are in an OLD variable, C establish temporary storage of NROW C IF(IFIRST.EQ.1) THEN J=IVLIST(4) IF(IVLIST(5).GT.0) THEN IVLIST(4)=NXPTD IF(IVLIST(5).NE.NROW) THEN WRITE(U6,202) GO TO 99 END IF JJ=NXPTD K=2*NROW CALL ROOMD(K) DO 3 K=1,NROW DX(JJ)=DX(J) J=J+1 JJ=JJ+1 3 CONTINUE END IF END IF IF(IVLIST(5).GT.0) THEN ISSCAL=IVLIST(4)+NROW ELSE NXPTDS=NXPTD ISSCAL=NXPTDS CALL ROOMD(NROW) END IF INEW=IVLIST(1)+1 DO 90 IROT=1,NROT IF(IVLIST(5).GT.0) THEN DO 4 K=IVLIST(4),IVLIST(4)+NROW-1 DX(K+NROW)=DX(K) 4 CONTINUE ELSE J=DXPNT(4) DO 6 K=1,NROW DX(K+ISSCAL-1)=DX(J) J=J+1 6 CONTINUE END IF ISTALL=DXPNT(1)+NROW*(IROT-1) ISCONT=DXPNT(2)+NROW*(IROT-1) ISUNWT=DXPNT(3)+NROW*(IROT-1) C ISCOL=DXPNT(INEW)+NROW*(IROT-1) DO 8 K=1,NROW DX(ISCOL+K-1)=0. 8 CONTINUE C DO 80 IROW=1,NROW IF(DX(ISCOL+IROW-1).EQ.0.) THEN T=DX(ISTALL+IROW-1) TC=DX(ISCONT+IROW-1) IUNWT=DX(ISUNWT+IROW-1)+.5D-1 10 CONTINUE IF(T.GT.0.) THEN R=TC/T ELSE R=0. END IF IF(R.LE..6700D+0.OR.R.GE.2.D0.OR.IUNWT.LT.35) THEN IROWC=0 SVNOW=DX(ISSCAL+IROW-1) DO 12 I=1,NROW SVD=DABS(DX(ISSCAL+I-1)-SVNOW) IF(SVD.GT..1D-06) THEN IF(IROWC.EQ.0) THEN IROWC=I SVDIFF=SVD ELSE IF(SVD.LT.SVDIFF) THEN IROWC=I SVDIFF=SVD END IF END IF 12 CONTINUE IF(IROWC.NE.0) THEN SVC=DX(ISSCAL+IROWC-1) SVSUM=0. T=0. TC=0. DIUNWT=0. DO 14 I=1,NROW IF(DABS(DX(ISSCAL+I-1)-SVNOW).LT..1D-06.OR. . DABS(DX(ISSCAL+I-1)-SVC).LT..1D-06) THEN T=T+DX(ISTALL+I-1) TC=TC+DX(ISCONT+I-1) DIUNWT=DIUNWT+DX(ISUNWT+I-1) SVSUM=SVSUM+DX(ISUNWT+I-1)*DX(ISSCAL+I-1) END IF 14 CONTINUE IUNWT=DIUNWT+.5D-1 IF(DIUNWT.GT.0.) THEN SVNEW=SVSUM/DIUNWT ELSE SVNEW=SVNOW END IF DO 16 I=1,NROW IF(DABS(DX(ISSCAL+I-1)-SVNOW).LT..1D-06.OR. . DABS(DX(ISSCAL+I-1)-SVC).LT..1D-06) THEN DX(ISSCAL+I-1)=SVNEW DX(ISCOL+I-1)=IROW+(IROT-1)*NROW END IF 16 CONTINUE GO TO 10 END IF END IF END IF 80 CONTINUE 90 CONTINUE C C C If IVLIST(5)=0, have been reusing temporary storage. Setting C NXPTD=NXPTDS frees up temporary space. C IF(IVLIST(5).EQ.0) THEN NXPTD=NXPTDS END IF RETURN 99 CONTINUE IERROR=1 RETURN END C SUBROUTINE SCCCOL(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR) C IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL INTEGER MATSIZ EXTERNAL MATSIZ DOUBLE PRECISION MISSNG INTEGER IPAIR(2,3) DATA ((IPAIR(I,J),I=1,2),J=1,3)/1,3,2,5,4,6/ DATA MISSNG/-98765.432109D0/ 200 FORMAT(' SIPPC_CLMCOL: WRONG NUMBER OF VARIABLES') 201 FORMAT(' SIPPC_CLMCOL: UNEXPECTED DIMENSIONS') 202 FORMAT(' SIPPC_CLMCOL: DISAGREEING SIZES') C IF(IFIRST.EQ.1) THEN C C Check that 3 old variables specified, 1 modify or new variable. C C First old variable - weighted counts C Second old variable - controls C Third old variable - unweighted counts C IF(IVLIST(1).NE.3.OR.IVLIST(2)+IVLIST(3).NE.1) THEN WRITE(U6,200) GO TO 99 END IF ITOP=IVLIST(1)+IVLIST(2)+IVLIST(3) ELSE ITOP=1 END IF C C Determine whether subroutine has been called for a single number of C columns or whether more than one rotation group is present C NROT=1 DO 2 I=1,ITOP J=DIMPNT(I)+1 JJ=DIMX(J-1) K=0 DO 1 IJ=1,JJ IF(DIMX(J).GT.1) THEN K=K+1 IF(K.EQ.1) THEN IF(DIMX(J).NE.6) THEN WRITE(U6,202) GO TO 99 END IF ELSE IF(K.EQ.2) THEN IF(I.EQ.1) THEN NROT=DIMX(J) ELSE IF(DIMX(J).NE.NROT) THEN WRITE(U6,202) GO TO 99 END IF ELSE WRITE(U6,201) GO TO 99 END IF END IF J=J+1 1 CONTINUE 2 CONTINUE C INEW=IVLIST(1)+1 DO 90 IROT=1,NROT ISTALL=DXPNT(1)+6*(IROT-1) ISCONT=DXPNT(2)+6*(IROT-1) ISUNWT=DXPNT(3)+6*(IROT-1) C ISCOL=DXPNT(INEW)+6*(IROT-1) DO 8 K=1,6 DX(ISCOL+K-1)=0. 8 CONTINUE C DO 20 IP=1,3 DO 15 IK=1,2 I=IPAIR(IK,IP) IF(DX(ISCOL+I-1).EQ.0.) THEN T=DX(ISTALL+I-1) TC=DX(ISCONT+I-1) IUNWT=DX(ISUNWT+I-1)+.5D-1 IF(T.GT.0.) THEN R=TC/T ELSE R=0. END IF IF(R.LE..6700D+0.OR.R.GE.2.D0.OR.IUNWT.LT.35) THEN DX(ISCOL+I-1)=IP+6*(IROT-1) IF(IK.EQ.1) THEN I=IPAIR(2,IP) ELSE I=IPAIR(1,IP) END IF DX(ISCOL+I-1)=IP+6*(IROT-1) END IF END IF 15 CONTINUE 20 CONTINUE 90 CONTINUE C RETURN 99 CONTINUE IERROR=1 RETURN END C SUBROUTINE SCRAKE(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR) C IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL INTEGER MATSIZ EXTERNAL MATSIZ DOUBLE PRECISION MISSNG DATA MISSNG/-98765.432109D0/ 200 FORMAT(' SIPPC_RAKE: WRONG NUMBER OF VARIABLES') 201 FORMAT(' SIPPC_RAKE: UNEXPECTED DIMENSIONS') 202 FORMAT(' SIPPC_RAKE: DISAGREEING SIZES') C IF(IFIRST.EQ.1) THEN C C Check that 3 old variables specified, at least one C modify variable and a total of 3 modify or new variables. C C First old variable - row controls C Second old variable - column controls C Third old variable - collapsing for rows C Fourth old variable - collapsing for columns C First modify variable - Sample counts to be raked C Second modify/first new - Row factors C Third modify/second new - Column factors C IF(IVLIST(1).NE.4.OR.IVLIST(2)+IVLIST(3).NE.3) THEN WRITE(U6,200) GO TO 99 END IF IF(IVLIST(2).NE.1.AND.IVLIST(2).NE.3) THEN WRITE(U6,200) GO TO 99 END IF ITOP=IVLIST(1)+IVLIST(2)+IVLIST(3) ELSE ITOP=1 END IF C C Determine whether subroutine has been called for a single number of C columns or whether more than one rotation group is present C NROT=1 NROW=1 DO 2 I=1,ITOP J=DIMPNT(I)+1 JJ=DIMX(J-1) K=0 DO 1 IJ=1,JJ IF(DIMX(J).GT.1) THEN K=K+1 IF(K.EQ.1) THEN IF(I.EQ.1) THEN NROW=DIMX(J) ELSE IF(I.EQ.3.OR.I.EQ.5.OR.I.EQ.6) THEN IF(DIMX(J).NE.NROW) THEN WRITE(U6,202) GO TO 99 END IF ELSE IF(DIMX(J).NE.6) THEN WRITE(U6,201) GO TO 99 END IF END IF ELSE IF(K.EQ.2) THEN IF(I.EQ.1) THEN NROT=DIMX(J) ELSE IF(I.EQ.5) THEN IF(DIMX(J).NE.6) THEN WRITE(U6,201) GO TO 99 END IF ELSE IF(DIMX(J).NE.NROT) THEN WRITE(U6,202) GO TO 99 END IF ELSE IF(K.EQ.3) THEN IF(I.EQ.5) THEN IF(DIMX(J).NE.NROT) THEN WRITE(U6,202) GO TO 99 END IF ELSE WRITE(U6,201) GO TO 99 END IF ELSE WRITE(U6,201) GO TO 99 END IF END IF J=J+1 1 CONTINUE 2 CONTINUE C C Allocate space for constants C IF(IFIRST.EQ.1) THEN J=IVLIST(4) IVLIST(4)=NXPTD JJ=NXPTD K=2+NROT+NROW CALL ROOMD(K) IF(IVLIST(5).GT.0) THEN DO 3 K=1,IVLIST(5) DX(JJ)=DX(J) J=J+1 JJ=JJ+1 3 CONTINUE END IF IF(IVLIST(5).EQ.0) THEN DX(IVLIST(4))=2500.D0 END IF IF(IVLIST(5).LT.2) THEN DX(IVLIST(4)+1)=21.D0 END IF DO 4 K=1,NROT KK=IVLIST(4)+K+1 DX(KK)=0. 4 CONTINUE IVLIST(5)=2+NROT+NROW END IF C MXITER=DX(IVLIST(4)+1)+.1D-1 ISSCRT=IVLIST(4)+2+NROT DO 90 IROT=1,NROT ISRCNT=DXPNT(1)+NROW*(IROT-1) ISCCNT=DXPNT(2)+6*(IROT-1) ISRCOL=DXPNT(3)+NROW*(IROT-1) ISCCOL=DXPNT(4)+6*(IROT-1) ISTALL=DXPNT(5)+NROW*6*(IROT-1) ISRFCT=DXPNT(6)+NROW*(IROT-1) ISCFCT=DXPNT(7)+6*(IROT-1) ISITER=IVLIST(4)+1+IROT CALL SCRAK2(NROW,DX(ISRCNT),DX(ISCCNT),DX(ISRCOL),DX(ISCCOL), . DX(ISTALL),DX(ISRFCT),DX(ISCFCT),MXITER,DX(IVLIST(4)),DX(ISITER), . DX(IVLIST(4)+2+NROT)) C 90 CONTINUE C RETURN 99 CONTINUE IERROR=1 RETURN END C SUBROUTINE SCRAK2(NROW,RCONT,CCONT,RCOL,CCOL,TABLE,RFACT,CFACT, . MXITER,DEV,DITER,DWORK) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NROW,MXITER DOUBLE PRECISION RCONT(NROW),CCONT(6),RCOL(NROW),CCOL(6), . TABLE(NROW,6),RFACT(NROW),CFACT(6),DEV,DITER,DWORK(NROW) NWITER=DITER+.05D0 DO 1 I=1,NROW RFACT(I)=1.D0 1 CONTINUE DO 2 I=1,6 CFACT(I)=1.D0 2 CONTINUE IF(NWITER.GT.0) THEN ITOP=NWITER ELSE ITOP=MXITER END IF DO 90 ITER=1,ITOP,2 DO 20 IR=1,NROW IF(RCOL(IR).GT.0.) THEN IF(IR.GT.1) THEN DO 4 I=1,IR-1 IF(DABS(RCOL(IR)-RCOL(I)).LT..1D-02)GO TO 20 4 CONTINUE END IF CTOT=0. TTOT=0. DO 8 I=IR,NROW IF(DABS(RCOL(IR)-RCOL(I)).LT..1D-02) THEN CTOT=CTOT+RCONT(I) DO 6 K=1,6 TTOT=TTOT+TABLE(I,K) 6 CONTINUE END IF 8 CONTINUE IF(TTOT.GT.0.) THEN CTOT=CTOT/TTOT DO 12 I=IR,NROW IF(DABS(RCOL(IR)-RCOL(I)).LT..1D-02) THEN DO 10 K=1,6 TABLE(I,K)=CTOT*TABLE(I,K) 10 CONTINUE RFACT(I)=CTOT*RFACT(I) END IF 12 CONTINUE END IF ELSE CTOT=0. TTOT=0. CTOT=CTOT+RCONT(IR) DO 14 K=1,6 TTOT=TTOT+TABLE(IR,K) 14 CONTINUE IF(TTOT.GT.0.) THEN CTOT=CTOT/TTOT DO 16 K=1,6 TABLE(IR,K)=CTOT*TABLE(IR,K) 16 CONTINUE RFACT(IR)=CTOT*RFACT(IR) END IF END IF 20 CONTINUE IF(ITER.EQ.ITOP) GO TO 90 IF(NWITER.EQ.0.AND.ITER.GE.3) THEN DO 40 IR=1,6 IF(CCOL(IR).GT.0.) THEN IF(IR.GT.1) THEN DO 24 I=1,IR-1 IF(DABS(CCOL(IR)-CCOL(I)).LT..1D-02)GO TO 40 24 CONTINUE END IF CTOT=0. TTOT=0. DO 28 I=IR,6 IF(DABS(CCOL(IR)-CCOL(I)).LT..1D-02) THEN CTOT=CTOT+CCONT(I) DO 26 K=1,NROW TTOT=TTOT+TABLE(K,I) 26 CONTINUE END IF 28 CONTINUE IF(DABS(CTOT-TTOT).GT.DEV) GO TO 42 ELSE TTOT=0. DO 34 K=1,NROW TTOT=TTOT+TABLE(K,IR) 34 CONTINUE IF(DABS(CCONT(IR)-TTOT).GT.DEV) GO TO 42 END IF 40 CONTINUE DITER=ITER GO TO 92 END IF 42 CONTINUE DO 60 IR=1,6 IF(CCOL(IR).GT.0.) THEN IF(IR.GT.1) THEN DO 44 I=1,IR-1 IF(DABS(CCOL(IR)-CCOL(I)).LT..1D-02)GO TO 60 44 CONTINUE END IF CTOT=0. TTOT=0. DO 48 I=IR,6 IF(DABS(CCOL(IR)-CCOL(I)).LT..1D-02) THEN CTOT=CTOT+CCONT(I) DO 46 K=1,NROW TTOT=TTOT+TABLE(K,I) 46 CONTINUE END IF 48 CONTINUE IF(TTOT.GT.0.) THEN CTOT=CTOT/TTOT DO 52 I=IR,6 IF(DABS(CCOL(IR)-CCOL(I)).LT..1D-02) THEN DO 50 K=1,NROW TABLE(K,I)=CTOT*TABLE(K,I) 50 CONTINUE CFACT(I)=CTOT*CFACT(I) END IF 52 CONTINUE END IF ELSE TTOT=0. DO 54 K=1,NROW TTOT=TTOT+TABLE(K,IR) 54 CONTINUE IF(TTOT.GT.0.) THEN CTOT=CCONT(IR)/TTOT DO 56 K=1,NROW TABLE(K,IR)=CTOT*TABLE(K,IR) 56 CONTINUE CFACT(IR)=CTOT*CFACT(IR) END IF END IF 60 CONTINUE 90 CONTINUE 92 CONTINUE RETURN END SUBROUTINE CPSCOL(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 100 FORMAT(' CPSCOL: UNEXPECTED SPECIFICATION') IF(DID(1).EQ.0.) THEN IF(IVLIST(1).NE.2.OR.IVLIST(2)+IVLIST(3).NE.1)GO TO 99 ITOP=3 ELSE ITOP=1 END IF NSEX=1 DO 10 I=1,ITOP J=DIMPNT(I)+1 JJ=DIMX(J-1) K=0 DO 7 IJ=1,JJ IF(DIMX(J).GT.1) THEN K=K+1 IF(K.EQ.1) THEN IF(I.EQ.1) THEN NCELL=DIMX(J) ELSE IF(DIMX(J).NE.NCELL)GO TO 99 END IF ELSE IF(K.EQ.2) THEN IF(DIMX(J).NE.2)GO TO 99 IF(I.EQ.1)NSEX=2 ELSE GO TO 99 END IF END IF J=J+1 7 CONTINUE IF(I.GT.1) THEN IF(K.GT.2)GO TO 99 IF((NSEX.EQ.1.AND.K.EQ.2).OR.(NSEX.EQ.2.AND.K.EQ.1))GO TO 99 END IF 10 CONTINUE IF(IVLIST(4).GT.0.AND.IVLIST(5).EQ.2) THEN BOUNDL=DX(IVLIST(4)) BOUNDH=DX(IVLIST(4)+1) ELSE BOUNDL=.6D0 BOUNDH=2.0D0 END IF CALL CPSCL2(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3)),NCELL,NSEX, . BOUNDL,BOUNDH) RETURN 99 CONTINUE WRITE(U6,100) IERROR=1 RETURN END SUBROUTINE CPSCL2(H,CH,FH,NCELL,NSEX,BOUNDL,BOUNDH) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NCELL,NSEX DOUBLE PRECISION H(NCELL,NSEX),CH(NCELL,NSEX),FH(NCELL,NSEX) C C Subroutine to determine CPS collapsing, following rules in C December 22, 1992 draft memorandum. C C H - matrix of estimated CPS Hispanic totals C CH - matrix of controls C FH - matrix created by CPSCOL to contain collapsing instructions to C be passed to COLLAPSE C IC=0 C C Loop to 80 is over sex, which is never collapsed. C DO 80 J=1,NSEX C C First fill in 0's consistent with no collapsing. C DO 2 I=1,NCELL FH(I,J)=0. 2 CONTINUE C C Now work backwards from the oldest age group C I=NCELL 4 CONTINUE C C If the cell does not need collapsing, loop either back to 4 to check C additional younger ages or to 8 instead, without checking cell 1 yet. C IF(H(I,J).GT.0) THEN R=CH(I,J)/H(I,J) IF(R.GE.BOUNDL.AND.R.LE.BOUNDH) THEN IF(I.GE.3) THEN I=I-1 GO TO 4 ELSE GO TO 8 END IF END IF END IF C C Come here if need collapsing. Collapsed downward by age until the C conditions are met. C T=H(I,J) TC=CH(I,J) IC=IC+1 FH(I,J)=IC DO 6 II=I-1,1,-1 FH(II,J)=IC T=T+H(II,J) TC=TC+CH(II,J) IF(T.GT.0.) THEN C C If the conditions are met, either go back to 4 to check younger ages C or on to 8 C IF(TC/T.GE.BOUNDL.AND.TC/T.LE.BOUNDH) THEN IF(II.GE.3) THEN I=II-1 GO TO 4 ELSE GO TO 8 END IF END IF END IF 6 CONTINUE C C If we get to here, we need to begin to collapse back upward, therefore C skip this step. C GO TO 10 C C If all conditions are met down to the first cell, check it here. C If it is OK, we are done with Hispanics. C 8 CONTINUE IF(H(1,J).GT.0.) THEN R=CH(1,J)/H(1,J) IF(R.GE.BOUNDL.AND.R.LE.BOUNDH)GO TO 18 END IF C C We come to 10 if we need to collapse the first cell. C Collapse upward, keeping together cells already collapsed, although C possibly assigning them a new number in FH C 10 CONTINUE T=H(1,J) TC=CH(1,J) IC=IC+1 FH(1,J)=IC I=2 12 CONTINUE T=T+H(I,J) TC=TC+CH(I,J) FOLD=FH(I,J) FH(I,J)=IC IF(I.LT.NCELL) THEN II=I+1 IF(DABS(FH(II,J)-FOLD).LT..1D0.AND.FH(II,J).GT.0.) THEN I=I+1 GO TO 12 END IF END IF IF(T.GT.0) THEN IF(TC/T.GE.BOUNDL.AND.TC/T.LE.BOUNDH) GO TO 18 END IF IF(I.LT.NCELL) THEN I=I+1 GO TO 12 END IF 18 CONTINUE 80 CONTINUE RETURN END C SUBROUTINE CMPCOL(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 100 FORMAT(' CMPCOL: UNEXPECTED SPECIFICATION') IF(DID(1).EQ.0.) THEN IF(IVLIST(1).EQ.3) THEN IF(IVLIST(2)+IVLIST(3).NE.1.OR.IVLIST(5).NE.3)GO TO 99 ITOP=3 ELSE IF(IVLIST(1).EQ.6) THEN IF(IVLIST(2)+IVLIST(3).NE.2.OR.IVLIST(2).EQ.1.OR. . IVLIST(3).EQ.1.OR. . (IVLIST(5).NE.3.AND.IVLIST(5).NE.6))GO TO 99 ITOP=6 ELSE GO TO 99 END IF ELSE ITOP=1 END IF NSEX=1 DO 10 I=1,ITOP J=DIMPNT(I)+1 JJ=DIMX(J-1) K=0 DO 7 IJ=1,JJ IF(DIMX(J).GT.1) THEN K=K+1 IF(K.EQ.1) THEN IF(I.EQ.1) THEN NCELL=DIMX(J) ELSE IF(DIMX(J).NE.NCELL)GO TO 99 END IF ELSE IF(K.EQ.2) THEN IF(DIMX(J).NE.2)GO TO 99 IF(I.EQ.1)NSEX=2 ELSE GO TO 99 END IF END IF J=J+1 7 CONTINUE IF(I.GT.1) THEN IF(K.GT.2)GO TO 99 IF((NSEX.EQ.1.AND.K.EQ.2).OR.(NSEX.EQ.2.AND.K.EQ.1))GO TO 99 END IF 10 CONTINUE J=IVLIST(4) IF(IVLIST(1).EQ.3) THEN CALL CPSCL8(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3)),DX(DXPNT(4)), . NCELL,NSEX,DX(J),DX(J+1),DX(J+2)) ELSE IF(IVLIST(5).EQ.3) THEN CALL CPSCL9(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3)),DX(DXPNT(4)), . DX(DXPNT(5)),DX(DXPNT(6)),DX(DXPNT(7)),DX(DXPNT(8)), . NCELL,NSEX,DX(J),DX(J+1),DX(J+2),DX(J),DX(J+1),DX(J+2)) ELSE CALL CPSCL9(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3)),DX(DXPNT(4)), . DX(DXPNT(5)),DX(DXPNT(6)),DX(DXPNT(7)),DX(DXPNT(8)), . NCELL,NSEX,DX(J),DX(J+1),DX(J+2),DX(J+3),DX(J+4),DX(J+5)) END IF RETURN 99 CONTINUE WRITE(U6,100) IERROR=1 RETURN END C SUBROUTINE CPSCL8(H,CH,UNH,FH,NCELL,NSEX,UNMIN,FLOW,FHIGH) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NCELL,NSEX DOUBLE PRECISION H(NCELL,NSEX),CH(NCELL,NSEX),UNH(NCELL,NSEX), . FH(NCELL,NSEX),UNMIN,FLOW,FHIGH C C Subroutine to determine CPS composite collapsing. C C H - matrix of estimated CPS Hispanic totals C CH - matrix of controls C UNH - matrix of unweighted counts C FH - matrix created by CPSCOL to contain collapsing instructions to C be passed to COLLAPSE C MINIMM - minimum not to collapse C FLOW - minimum acceptable factor C FHIGH - maximum acceptable factor C IC=0 C C Loop to 80 is over sex, which is never collapsed. C DO 80 J=1,NSEX C C First fill in 0's consistent with no collapsing. C DO 2 I=1,NCELL FH(I,J)=0. 2 CONTINUE C C Now work backwards from the oldest age group C I=NCELL 4 CONTINUE C C If the cell does not need collapsing, loop either back to 4 to check C additional younger ages or to 8 instead, without checking cell 1 yet. C IF(H(I,J).GT.0.AND.UNH(I,J).GT.UNMIN-.5D0) THEN R=CH(I,J)/H(I,J) IF(R.GE.FLOW.AND.R.LE.FHIGH) THEN IF(I.GE.3) THEN I=I-1 GO TO 4 ELSE GO TO 8 END IF END IF END IF C C Come here if need collapsing. Collapsed downward by age until the C conditions are met. C T=H(I,J) TC=CH(I,J) TUN=UNH(I,J) IC=IC+1 FH(I,J)=IC DO 6 II=I-1,1,-1 FH(II,J)=IC T=T+H(II,J) TC=TC+CH(II,J) TUN=TUN+UNH(II,J) IF(T.GT.0..AND.TUN.GT.UNMIN-.5D0) THEN C C If the conditions are met, either go back to 4 to check younger ages C or on to 8 C IF(TC/T.GE.FLOW.AND.TC/T.LE.FHIGH) THEN IF(II.GE.3) THEN I=II-1 GO TO 4 ELSE GO TO 8 END IF END IF END IF 6 CONTINUE C C If we get to here, we need to begin to collapse back upward, therefore C skip this step. C GO TO 10 C C If all conditions are met down to the first cell, check it here. C If it is OK, we are done with Hispanics. C 8 CONTINUE IF(H(1,J).GT.0.AND.UNH(1,J).GT.UNMIN-.5D0) THEN R=CH(1,J)/H(1,J) IF(R.GE.FLOW.AND.R.LE.FHIGH)GO TO 18 END IF C C We come to 10 if we need to collapse the first cell. C Collapse upward, keeping together cells already collapsed, although C possibly assigning them a new number in FH C 10 CONTINUE T=H(1,J) TC=CH(1,J) TUN=UNH(1,J) IC=IC+1 FH(1,J)=IC I=2 12 CONTINUE T=T+H(I,J) TC=TC+CH(I,J) TUN=TUN+UNH(I,J) FOLD=FH(I,J) FH(I,J)=IC IF(I.LT.NCELL) THEN II=I+1 IF(DABS(FH(II,J)-FOLD).LT..1D0.AND.FH(II,J).GT.0.) THEN I=I+1 GO TO 12 END IF END IF IF(T.GT.0.AND.TUN.GT.UNMIN-.5D0) THEN IF(TC/T.GE.FLOW.AND.TC/T.LE.FHIGH) GO TO 18 END IF IF(I.LT.NCELL) THEN I=I+1 GO TO 12 END IF 18 CONTINUE 80 CONTINUE RETURN END C SUBROUTINE CPSCL9(P,CP,UNP,H,CH,UNH,FP,FH,NCELL,NSEX,UNMIN1,FLOW1, . FHIGH1,UNMIN2,FLOW2,FHIGH2) C C Subroutine to determine revised CPS composite collapsing, first C looking for any collapsing for employed, which should be rare. C IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NCELL,NSEX DOUBLE PRECISION P(NCELL,NSEX),CP(NCELL,NSEX),UNP(NCELL,NSEX), . H(NCELL,NSEX),CH(NCELL,NSEX),UNH(NCELL,NSEX),FP(NCELL,NSEX), . FH(NCELL,NSEX),UNMIN1,FLOW1,FHIGH1,UNMIN2,FLOW2,FHIGH2 C C H - matrix of estimated CPS Hispanic totals C CH - matrix of controls C UNH - matrix of unweighted counts C FH - matrix created by CPSCOL to contain collapsing instructions to C be passed to COLLAPSE C MINIMM - minimum not to collapse C FLOW - minimum acceptable factor C FHIGH - maximum acceptable factor C IC=0 C C Loop to 20 is over sex, which is never collapsed. C DO 20 J=1,NSEX C C First fill in 0's consistent with no collapsing. C DO 2 I=1,NCELL FP(I,J)=0. 2 CONTINUE C C Now work backwards from the oldest age group C I=NCELL 4 CONTINUE C C If the cell does not need collapsing, loop either back to 4 to check C additional younger ages or to 8 instead, without checking cell 1 yet. C IF(P(I,J).GT.0.AND.UNP(I,J).GT.UNMIN1-.5D0) THEN R=CP(I,J)/P(I,J) IF(R.GE.FLOW1.AND.R.LE.FHIGH1) THEN IF(I.GE.3) THEN I=I-1 GO TO 4 ELSE GO TO 8 END IF END IF END IF C C Come here if need collapsing. Collapsed downward by age until the C conditions are met. C T=P(I,J) TC=CP(I,J) TUN=UNP(I,J) IC=IC+1 FP(I,J)=IC DO 6 II=I-1,1,-1 FP(II,J)=IC T=T+P(II,J) TC=TC+CP(II,J) TUN=TUN+UNP(II,J) IF(T.GT.0..AND.TUN.GT.UNMIN1-.5D0) THEN C C If the conditions are met, either go back to 4 to check younger ages C or on to 8 C IF(TC/T.GE.FLOW1.AND.TC/T.LE.FHIGH1) THEN IF(II.GE.3) THEN I=II-1 GO TO 4 ELSE GO TO 8 END IF END IF END IF 6 CONTINUE C C If we get to here, we need to begin to collapse back upward, therefore C skip this step. C GO TO 10 C C If all conditions are met down to the first cell, check it here. C If it is OK, we are done. C 8 CONTINUE IF(P(1,J).GT.0.AND.UNP(1,J).GT.UNMIN1-.5D0) THEN R=CP(1,J)/P(1,J) IF(R.GE.FLOW1.AND.R.LE.FHIGH1)GO TO 18 END IF C C We come to 10 if we need to collapse the first cell. C Collapse upward, keeping together cells already collapsed, although C possibly assigning them a new number in FH. C 10 CONTINUE T=P(1,J) TC=CP(1,J) TUN=UNP(1,J) IC=IC+1 FP(1,J)=IC I=2 12 CONTINUE T=T+P(I,J) TC=TC+CP(I,J) TUN=TUN+UNP(I,J) FOLD=FP(I,J) FP(I,J)=IC IF(I.LT.NCELL) THEN II=I+1 IF(DABS(FP(II,J)-FOLD).LT..1D0.AND.FP(II,J).GT.0.) THEN I=I+1 GO TO 12 END IF END IF IF(T.GT.0.AND.TUN.GT.UNMIN1-.5D0) THEN IF(TC/T.GE.FLOW1.AND.TC/T.LE.FHIGH1) GO TO 18 END IF IF(I.LT.NCELL) THEN I=I+1 GO TO 12 END IF 18 CONTINUE 20 CONTINUE C DO 50 J=1,NSEX C C First fill FH with the results from FP C DO 22 I=1,NCELL FH(I,J)=FP(I,J) 22 CONTINUE C C Now work backwards from the oldest age group C I=NCELL 34 CONTINUE C C If the cell does not need collapsing, loop either back to 4 to check C additional younger ages or to 8 instead, without checking cell 1 yet. C IF(H(I,J).GT.0.AND.UNH(I,J).GT.UNMIN2-.5D0.AND.FH(I,J).EQ.0.) THEN R=CH(I,J)/H(I,J) IF(R.GE.FLOW2.AND.R.LE.FHIGH2) THEN IF(I.GE.3) THEN I=I-1 GO TO 34 ELSE GO TO 38 END IF END IF END IF C C Come here if need collapsing. Collapsed downward by age until the C conditions are met. C T=H(I,J) TC=CH(I,J) TUN=UNH(I,J) IC=IC+1 FH(I,J)=IC DO 36 II=I-1,1,-1 FH(II,J)=IC T=T+H(II,J) TC=TC+CH(II,J) TUN=TUN+UNH(II,J) IF(T.GT.0..AND.TUN.GT.UNMIN2-.5D0) THEN C C If the conditions are met, either go back to 4 to check younger ages C or on to 8 C K=0 IF(FP(II,J).EQ.0) THEN K=1 ELSE IF(II.EQ.1) THEN K=1 ELSE IF(FP(II,J).NE.FP(II-1,J)) THEN K=1 END IF IF(TC/T.GE.FLOW2.AND.TC/T.LE.FHIGH2.AND.K.EQ.1) THEN IF(II.GE.3) THEN I=II-1 GO TO 34 ELSE GO TO 38 END IF END IF END IF 36 CONTINUE C C If we get to here, we need to begin to collapse back upward, therefore C skip this step. C GO TO 40 C C If all conditions are met down to the first cell, check it here. C If it is OK, we are done. C 38 CONTINUE IF(H(1,J).GT.0.AND.UNH(1,J).GT.UNMIN2-.5D0.AND.FH(1,J).EQ.0.) THEN R=CH(1,J)/H(1,J) IF(R.GE.FLOW2.AND.R.LE.FHIGH2)GO TO 48 END IF C C We come to 40 if we need to collapse the first cell. C Collapse upward, keeping together cells already collapsed, although C possibly assigning them a new number in FH C 40 CONTINUE T=H(1,J) TC=CH(1,J) TUN=UNH(1,J) IC=IC+1 FH(1,J)=IC I=2 42 CONTINUE T=T+H(I,J) TC=TC+CH(I,J) TUN=TUN+UNH(I,J) FOLD=FH(I,J) FH(I,J)=IC IF(I.LT.NCELL) THEN II=I+1 IF(DABS(FH(II,J)-FOLD).LT..1D0.AND.FH(II,J).GT.0.) THEN I=I+1 GO TO 42 END IF END IF IF(T.GT.0.AND.TUN.GT.UNMIN2-.5D0) THEN IF(TC/T.GE.FLOW2.AND.TC/T.LE.FHIGH2) GO TO 48 END IF IF(I.LT.NCELL) THEN I=I+1 GO TO 42 END IF 48 CONTINUE 50 CONTINUE RETURN END C SUBROUTINE CPSCHL(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 100 FORMAT(' CPSCHILDCOL: UNEXPECTED SPECIFICATION') IF(IFIRST.EQ.1) THEN IF(IVLIST(1).NE.2.OR.IVLIST(2)+IVLIST(3).NE.1)GO TO 99 DO 10 I=1,3 J=DIMPNT(I)+1 JJ=DIMX(J-1) K=0 DO 7 IJ=1,JJ IF(DIMX(J).GT.1) THEN K=K+1 IF(K.EQ.1) THEN IF(DIMX(J).NE.4)GO TO 99 ELSE IF(K.EQ.2) THEN IF(DIMX(J).NE.2)GO TO 99 ELSE GO TO 99 END IF END IF J=J+1 7 CONTINUE IF(K.NE.2)GO TO 99 10 CONTINUE END IF CALL CPSCL3(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3))) RETURN 99 CONTINUE WRITE(U6,100) IERROR=1 RETURN END SUBROUTINE CPSCL3(H,CH,FH) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION H(4,2),CH(4,2),FH(4,2) C C Subroutine to determine CPS collapsing for Hispanic and C Other Races children, following rules in C December 22, 1992 draft memorandum. C C H - matrix of estimated CPS Hispanic totals C CH - matrix of controls C FH - matrix created by CPSCOL to contain collapsing instructions to C be passed to COLLAPSE C C Fill in initial collapsing by sex of 14- and 15-year olds. C Use 100, 101, etc., to fill collapsing matrix, to allow later C GLUEing of these collapsing flags with those for adults. C DO 2 J=1,2 FH(1,J)=0. FH(2,J)=0. FH(3,J)=1.D2 FH(4,J)=1.01D2 2 CONTINUE TC=CH(4,1)+CH(4,2) T=H(4,1)+H(4,2) IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN C C Collapsing for 15-year olds C FH(4,1)=1.D2 FH(4,2)=1.D2 TC=TC+CH(3,1)+CH(3,2) T=T+H(3,1)+H(3,2) IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN FH(2,1)=1.D2 FH(2,2)=1.D2 TC=TC+CH(2,1)+CH(2,2) T=T+H(2,1)+H(2,2) IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN FH(1,1)=1.D2 FH(1,2)=1.D2 END IF END IF ELSE C C Collapsing for 14-year olds C TC=CH(3,1)+CH(3,2) T=H(3,1)+H(3,2) IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN FH(2,1)=1.D2 FH(2,2)=1.D2 TC=TC+CH(2,1)+CH(2,2) T=T+H(2,1)+H(2,2) IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN FH(1,1)=1.D2 FH(1,2)=1.D2 TC=TC+CH(1,1)+CH(1,2) T=T+H(1,1)+H(1,2) IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN FH(4,1)=1.D2 FH(4,2)=1.D2 END IF END IF END IF END IF C C If not already collapsed, check collapsing for 6-13 year olds C DO 20 IALTER=1,2 I=3-IALTER DO 15 J=1,2 IF(FH(I,J).LE.0.) THEN TC=CH(I,J) T=H(I,J) IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN C C If the cell fails, first check to see if the cell C for the opposite age is already collapsed C (possible for i=1, if i=2 already collapsed with C i=3). If not already collapsed, collapse cells (i,j) and C (ialter,j). C IF(FH(IALTER,J).LE.0.D0) THEN FH(I,J)=1.01D2+DBLE(FLOAT(2*I+J)) FH(IALTER,J)=FH(I,J) TC=TC+CH(IALTER,J) T=T+H(IALTER,J) C C Now check if further collapsing of entire 0-13 group C is required. C IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN JALTER=3-J FH(1,JALTER)=FH(I,J) FH(2,JALTER)=FH(I,J) TC=TC+CH(1,JALTER)+CH(2,JALTER) T=T+H(1,JALTER)+H(2,JALTER) C C Check if 0-13 now needs to be collapsed with 14 or 14-15 C IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN FH(1,1)=1.D2 FH(2,1)=1.D2 FH(1,2)=1.D2 FH(2,2)=1.D2 C C If 0-14 collapsed, do final check to see whether should C now collapse with 15 C IF(DABS(FH(4,1)-FH(3,1)).GT..1D-6) THEN TC=TC+CH(3,1)+CH(3,2) T=T+H(3,1)+H(3,2) IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN FH(4,1)=1.D2 FH(4,2)=1.D2 END IF END IF END IF END IF ELSE C C Consider case of i=1 where i=2 is already collapsed. C First, attempt collapse of 0-5 across sex. C FH(1,1)=1.02D2 FH(1,2)=1.02D2 TC=CH(1,1)+CH(1,2) T=H(1,1)+H(1,2) IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN FH(1,1)=1.D2 FH(1,2)=1.D2 C C The only question: do we still have to consider a C collapse with age 15? C IF(DABS(FH(4,1)-FH(3,1)).GT..1D-6) THEN TC=CH(1,1)+CH(2,1)+CH(3,1) . +CH(1,2)+CH(2,2)+CH(3,2) T=H(1,1)+H(2,1)+H(3,1) . +H(1,2)+H(2,2)+H(3,2) IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN FH(4,1)=1.D2 FH(4,2)=1.D2 END IF END IF END IF END IF END IF END IF 15 CONTINUE 20 CONTINUE RETURN END SUBROUTINE OCPSCH(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 100 FORMAT(' CPSCHILDCOL: UNEXPECTED SPECIFICATION') IF(IFIRST.EQ.1) THEN IF(IVLIST(1).NE.2.OR.IVLIST(2)+IVLIST(3).NE.1)GO TO 99 DO 10 I=1,3 J=DIMPNT(I)+1 JJ=DIMX(J-1) K=0 DO 7 IJ=1,JJ IF(DIMX(J).GT.1) THEN K=K+1 IF(K.EQ.1) THEN IF(DIMX(J).NE.4)GO TO 99 ELSE IF(K.EQ.2) THEN IF(DIMX(J).NE.2)GO TO 99 ELSE GO TO 99 END IF END IF J=J+1 7 CONTINUE IF(K.NE.2)GO TO 99 10 CONTINUE END IF IF(IVLIST(5).GE.1) THEN FLOW=DX(IVLIST(4)) IF(IVLIST(5).GE.2) THEN FHIGH=DX(IVLIST(4)+1) ELSE FHIGH=2.D0 END IF ELSE FLOW=.6D0 FHIGH=2.D0 END IF CALL CPSCL7(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3)),FLOW,FHIGH) RETURN 99 CONTINUE WRITE(U6,100) IERROR=1 RETURN END SUBROUTINE CPSCL7(H,CH,FH,FLOW,FHIGH) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION H(4,2),CH(4,2),FH(4,2),FLOW,FHIGH C C Subroutine to determine CPS collapsing for Hispanic and C Other Races children, for use with 1993 March Supplement, C and possibly other historic CPS data files. C C H - matrix of estimated CPS Hispanic totals C CH - matrix of controls C FH - matrix created by CPSCOL to contain collapsing instructions to C be passed to COLLAPSE C C Fill in initial collapsing by sex of 14- and 15-year olds. C Use 100, 101, etc., to fill collapsing matrix, to allow later C GLUEing of these collapsing flags with those for adults. C DO 2 J=1,2 FH(1,J)=0. FH(2,J)=0. FH(3,J)=1.D2 FH(4,J)=1.01D2 2 CONTINUE TC=CH(4,1)+CH(4,2) T=H(4,1)+H(4,2) IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN C C Collapsing for 15-year olds C FH(4,1)=1.D2 FH(4,2)=1.D2 TC=TC+CH(3,1)+CH(3,2) T=T+H(3,1)+H(3,2) IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN FH(2,1)=1.D2 FH(2,2)=1.D2 TC=TC+CH(2,1)+CH(2,2) T=T+H(2,1)+H(2,2) IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN FH(1,1)=1.D2 FH(1,2)=1.D2 END IF END IF ELSE C C Collapsing for 14-year olds, which collapses up to 15 first C TC=CH(3,1)+CH(3,2) T=H(3,1)+H(3,2) IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN FH(3,1)=1.01D2 FH(3,2)=1.01D2 TC=TC+CH(4,1)+CH(4,2) T=T+H(4,1)+H(4,2) IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN FH(2,1)=1.01D2 FH(2,2)=1.01D2 TC=TC+CH(2,1)+CH(2,2) T=T+H(2,1)+H(2,2) IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN FH(1,1)=1.01D2 FH(1,2)=1.01D2 END IF END IF END IF END IF C C If not already collapsed, check collapsing for 6-13 year olds C DO 20 IALTER=1,2 I=3-IALTER DO 15 J=1,2 IF(FH(I,J).LE.0.) THEN TC=CH(I,J) T=H(I,J) IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN C C If the cell fails, first check to see if the cell C for the opposite age is already collapsed C (possible for i=1, if i=2 already collapsed with C i=3). If not already collapsed, collapse cells (i,j) and C (ialter,j). C IF(FH(IALTER,J).LE.0.D0) THEN FH(I,J)=1.01D2+DBLE(FLOAT(2*I+J)) FH(IALTER,J)=FH(I,J) TC=TC+CH(IALTER,J) T=T+H(IALTER,J) C C Now check if further collapsing of entire 0-13 group C is required. C IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN JALTER=3-J FH(1,JALTER)=FH(I,J) FH(2,JALTER)=FH(I,J) TC=TC+CH(1,JALTER)+CH(2,JALTER) T=T+H(1,JALTER)+H(2,JALTER) C C Check if 0-13 now needs to be collapsed with 14 or 14-15 C IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN FH(1,1)=1.D2 FH(2,1)=1.D2 FH(1,2)=1.D2 FH(2,2)=1.D2 C C If 0-14 collapsed, do final check to see whether should C now collapse with 15 C IF(DABS(FH(4,1)-FH(3,1)).GT..1D-6) THEN TC=TC+CH(3,1)+CH(3,2) T=T+H(3,1)+H(3,2) IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN FH(4,1)=1.D2 FH(4,2)=1.D2 END IF END IF END IF END IF ELSE C C Consider case of i=1 where i=2 is already collapsed. C First, attempt collapse of 0-5 across sex. C FH(1,1)=1.02D2 FH(1,2)=1.02D2 TC=CH(1,1)+CH(1,2) T=H(1,1)+H(1,2) IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN FH(1,1)=1.D2 FH(1,2)=1.D2 C C The only question: do we still have to consider a C collapse with age 15? C IF(DABS(FH(4,1)-FH(3,1)).GT..1D-6) THEN TC=CH(1,1)+CH(2,1)+CH(3,1) . +CH(1,2)+CH(2,2)+CH(3,2) T=H(1,1)+H(2,1)+H(3,1) . +H(1,2)+H(2,2)+H(3,2) IF(TC/T.LT.FLOW.OR.TC/T.GT.FHIGH) THEN FH(4,1)=1.D2 FH(4,2)=1.D2 END IF END IF END IF END IF END IF END IF 15 CONTINUE 20 CONTINUE RETURN END SUBROUTINE NCPSCH(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 100 FORMAT(' CPSCHILDCOL: UNEXPECTED SPECIFICATION') IF(IFIRST.EQ.1) THEN IF(IVLIST(1).NE.2.OR.IVLIST(2)+IVLIST(3).NE.1)GO TO 99 DO 10 I=1,3 J=DIMPNT(I)+1 JJ=DIMX(J-1) K=0 DO 7 IJ=1,JJ IF(DIMX(J).GT.1) THEN K=K+1 IF(K.EQ.1) THEN IF(DIMX(J).NE.4)GO TO 99 ELSE IF(K.EQ.2) THEN IF(DIMX(J).NE.2)GO TO 99 ELSE GO TO 99 END IF END IF J=J+1 7 CONTINUE IF(K.NE.2)GO TO 99 10 CONTINUE END IF CALL CPSCL5(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3))) RETURN 99 CONTINUE WRITE(U6,100) IERROR=1 RETURN END SUBROUTINE CPSCL5(H,CH,FH) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION H(4,2),CH(4,2),FH(4,2) C C Subroutine to determine CPS collapsing for Hispanic and C Other Races children, for use starting in January, 1994 C Children age 15 are always collapsed into a single cell, C but not collapsed further. C C H - matrix of estimated CPS Hispanic (or other races) totals C CH - matrix of controls C FH - matrix created by CPSCOL to contain collapsing instructions to C be passed to COLLAPSE C C Fill in initial collapsing by sex of 14- and 15-year olds. C Use 100, 101, etc., to fill collapsing matrix, to allow later C GLUEing of these collapsing flags with those for adults. C Collapsing of age 15 is accomplished by filling in 101. C DO 2 J=1,2 FH(1,J)=0. FH(2,J)=0. FH(3,J)=1.D2 FH(4,J)=1.01D2 2 CONTINUE C C Collapsing for 14-year olds C TC=CH(3,1)+CH(3,2) T=H(3,1)+H(3,2) IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN C C If 14-year olds require collapsing, collapse first with 13-year C olds, collapsed across sex. C FH(2,1)=1.D2 FH(2,2)=1.D2 C C Check whether the combined 6-13/14 cell requires collapsing C TC=TC+CH(2,1)+CH(2,2) T=T+H(2,1)+H(2,2) IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN C C 0-14 become collapsed into a single cell here. No further C checks are performed. C FH(1,1)=1.D2 FH(1,2)=1.D2 END IF END IF C C If not already collapsed, check collapsing for 6-13 year olds C Two situations are checked: C IALTER =1 I=2 (Thus, the 6-13 group is the first checked.) C IALTER =2 I=1 C DO 20 IALTER=1,2 I=3-IALTER DO 15 J=1,2 C C Checks are performed in this loop only if the cell is not already C collapsed. C IF(FH(I,J).LE.0.) THEN TC=CH(I,J) T=H(I,J) IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN C C If the cell fails, first check to see if the cell for the C opposite age is already collapsed C (possible for i=1, if i=2 is already collapsed with C i=3, a case handled below). C If not already collapsed, collapse cells (i,j) and (ialter,j). C IF(FH(IALTER,J).LE.0.D0) THEN FH(I,J)=1.01D2+DBLE(FLOAT(2*I+J)) FH(IALTER,J)=FH(I,J) TC=TC+CH(IALTER,J) T=T+H(IALTER,J) C C Now check if the 0-13 cell for the one sex passes, else further C collapsing of entire 0-13 group is required. C IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN C C JALTER is the proverbial "opposite sex" C JALTER=3-J FH(1,JALTER)=FH(I,J) FH(2,JALTER)=FH(I,J) TC=TC+CH(1,JALTER)+CH(2,JALTER) T=T+H(1,JALTER)+H(2,JALTER) C C Check if the single 0-13 cell now needs to be collapsed with 14. C IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN FH(1,1)=1.D2 FH(2,1)=1.D2 FH(1,2)=1.D2 FH(2,2)=1.D2 END IF END IF ELSE C C Consider case of i=1 where i=2 is already collapsed with age 14. C First, attempt collapse of 0-5 across sex. C FH(1,1)=1.02D2 FH(1,2)=1.02D2 TC=CH(1,1)+CH(1,2) T=H(1,1)+H(1,2) IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN C C If the 0-5 cell requires further collapsing in this case (6-14 C already collapsed), 0-14 becomes collapsed into a single cell. C FH(1,1)=1.D2 FH(1,2)=1.D2 END IF END IF END IF END IF 15 CONTINUE 20 CONTINUE RETURN END SUBROUTINE NPSCHL(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 100 FORMAT(' NPSCHILDCOL: UNEXPECTED SPECIFICATION') IF(IFIRST.EQ.1) THEN IF(IVLIST(1).NE.2.OR.IVLIST(2)+IVLIST(3).NE.1)GO TO 99 DO 10 I=1,3 J=DIMPNT(I)+1 JJ=DIMX(J-1) K=0 DO 7 IJ=1,JJ IF(DIMX(J).GT.1) THEN K=K+1 IF(K.EQ.1) THEN IF(DIMX(J).NE.4)GO TO 99 ELSE IF(K.EQ.2) THEN IF(DIMX(J).NE.2)GO TO 99 ELSE GO TO 99 END IF END IF J=J+1 7 CONTINUE IF(K.NE.2)GO TO 99 10 CONTINUE END IF CALL CPSCL6(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3))) RETURN 99 CONTINUE WRITE(U6,100) IERROR=1 RETURN END SUBROUTINE CPSCL6(H,CH,FH) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION H(4,2),CH(4,2),FH(4,2) C C Subroutine to determine CPS collapsing for Hispanic and C Other Races children, following rules in C December 22, 1992 draft memorandum. C C H - matrix of estimated CPS Hispanic totals C CH - matrix of controls C FH - matrix created by CPSCOL to contain collapsing instructions to C be passed to COLLAPSE C C Fill in initial collapsing by sex of 14- and 15-year olds. C Use 100, 101, etc., to fill collapsing matrix, to allow later C GLUEing of these collapsing flags with those for adults. C FH(3,1)=1.D2 FH(4,1)=1.D2 FH(3,2)=1.03D2 FH(4,2)=1.03D2 C C For the New Parallel Survey (MLS), never collapse across sex. C Therefore, the primary loop is over sex (index J). C DO 20 J=1,2 FH(1,J)=0. FH(2,J)=0. C C First, check if the 14+15 year old cell needs collapsing. C TC=CH(3,J)+CH(4,J) T=H(3,J)+H(4,J) IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN C C Collapsing for 14/15-year olds C FH(2,J)=FH(4,J) TC=TC+CH(2,J) T=T+H(2,J) C C Check if the 6-15 cell stands - if not, collapse with 0-6 and C do no further checks. C IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN FH(1,J)=FH(4,J) END IF ELSE C C Collapsing for 6-13-year olds C TC=CH(2,J) T=H(2,J) IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN FH(2,J)=FH(4,J)+1.D0 FH(1,J)=FH(2,J) TC=TC+CH(1,J) T=T+H(1,J) IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN FH(2,J)=FH(4,J) FH(1,J)=FH(4,J) END IF END IF END IF C C If not already collapsed, check collapsing for 0-5 year olds C IF(FH(1,J).LE.0.) THEN TC=CH(1,J) T=H(1,J) IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN C C C If 0-5 needs collapsing, then if 6-13 is not already collapsed, C collapse there first. C IF(FH(2,J).LE.0.) THEN FH(1,J)=FH(4,J)+2.D0 FH(2,J)=FH(1,J) TC=TC+CH(2,J) T=T+H(2,J) IF(TC/T.LT..6D0.OR.TC/T.GT.2.D0) THEN FH(1,J)=FH(4,J) FH(2,J)=FH(3,J) END IF C C If 0-5 needs collapsing, but 6-15 has already been collapsed, then C they all become one cell. C ELSE FH(1,J)=FH(2,J) END IF END IF END IF 20 CONTINUE RETURN END C SUBROUTINE CPSNIC(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 100 FORMAT(' CPSNICOL: UNEXPECTED SPECIFICATION') IF(IFIRST.EQ.1) THEN IF(IVLIST(1).NE.2.OR.IVLIST(2)+IVLIST(3).NE.1)GO TO 99 ITOP=3 ELSE ITOP=1 END IF DO 10 I=1,ITOP J=DIMPNT(I)+1 JJ=DIMX(J-1) K=0 IF(I.EQ.1) THEN NCELL=1 ELSE NCELL2=1 END IF DO 7 IJ=1,JJ IF(DIMX(J).GT.1) THEN K=K+1 IF(IFIRST.EQ.1) THEN IF(K.EQ.1) THEN IF(DIMX(J).NE.2)GO TO 99 ELSE IF(K.EQ.2) THEN IF(I.EQ.1) THEN IF(DIMX(J).NE.2)GO TO 99 ELSE NCELL2=DIMX(J) END IF ELSE IF(I.EQ.1) THEN NCELL=DIMX(J)*NCELL ELSE NCELL2=DIMX(J)*NCELL2 END IF ELSE IF(K.GE.3) THEN NCELL=DIMX(J)*NCELL END IF END IF J=J+1 7 CONTINUE IF(IFIRST.EQ.1) THEN IF(I.EQ.1) THEN IF(K.EQ.1)GO TO 99 ELSE IF(NCELL.EQ.1.AND.K.NE.1)GO TO 99 IF(NCELL.GT.1.AND.K.LT.2)GO TO 99 IF(NCELL2.NE.NCELL)GO TO 99 END IF END IF 10 CONTINUE CALL CPSCL4(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3)),NCELL) RETURN 99 CONTINUE WRITE(U6,100) IERROR=1 RETURN END SUBROUTINE CPSCL4(W,UNW,F,NCELL) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION W(2,2,*),UNW(2,*),F(2,*) LOGICAL NICOLP C C Subroutine to determine CPS collapsing for noninterview C adjustment C DO 10 J=1,NCELL F(1,J)=0. F(2,J)=0. NICOLP=.FALSE. DO 5 I=1,2 IF(W(2,I,J).GT.0.AND.W(2,I,J).GE.W(1,I,J))NICOLP=.TRUE. IF(UNW(I,J).LT.49.5D0)NICOLP=.TRUE. 5 CONTINUE IF(NICOLP) THEN F(1,J)=J F(2,J)=J END IF 10 CONTINUE RETURN END C SUBROUTINE SCNCOL(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL INTEGER MATSIZ EXTERNAL MATSIZ INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 100 FORMAT(' SCNCOL: UNEXPECTED SPECIFICATION') C C Subroutine for SIPPC_NICOL C First old variable: weighted matrix 2 x ncell of interviewed/ C noninterviewed households C Second old variable: unweighted matrix of ncell counts of C interviewed hh C Third old variable: scale values (if no constants) C Constants: scale values (if only 2 old variables) C New or modified variable: collapsing matrix. C IF(DID(1).EQ.0.) THEN IF(IVLIST(4).NE.0) THEN IF(IVLIST(1).NE.2.OR.IVLIST(2)+IVLIST(3).NE.1) GO TO 99 ELSE IF(IVLIST(1).NE.3.OR.IVLIST(2)+IVLIST(3).NE.1) GO TO 99 END IF END IF NCELL=MATSIZ(DIMX(DIMPNT(1)),MTYPE(1),MTRAN(1))/2 C C On first call, check consistency of dimensions. C IF(DID(1).EQ.0.) THEN KK=DIMX(DIMPNT(1)) C C Insure that first dimension of first old variable is 2 C DO 2 I=1,KK IP=DIMX(DIMPNT(I)+I) IF(IP.EQ.2)GO TO 3 IF(IP.NE.1)GO TO 99 2 CONTINUE 3 CONTINUE C C Check consistency with other arrays. C DO 10 J=2,IVLIST(1)+1 IF(MATSIZ(DIMX(DIMPNT(J)),MTYPE(J),MTRAN(J)).NE.NCELL) . GO TO 99 KK=DIMX(DIMPNT(J)) IP=1 DO 5 I=1,KK IP2=DIMX(DIMPNT(J)+I) IP=IP*IP2 IF(IP.EQ.NCELL)GO TO 10 5 CONTINUE GO TO 99 10 CONTINUE C C If constants have been provided, array should have been set aside C as twice NCELL C IF(IVLIST(4).NE.0) THEN IF(IVLIST(5).NE.2*NCELL)GO TO 99 END IF END IF IF(IVLIST(5).EQ.0) THEN NXPTDS=NXPTD CALL ROOMD(NCELL) IVLIST(4)=NXPTDS CALL SCNCL2(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3)),DX(DXPNT(4)), . DX(NXPTDS),NCELL) NXPTD=NXPTDS IVLIST(4)=0 ELSE CALL SCNCL2(DX(DXPNT(1)),DX(DXPNT(2)),DX(IVLIST(4)), . DX(DXPNT(3)),DX(IVLIST(4)+NCELL),NCELL) END IF RETURN 99 CONTINUE WRITE(U6,100) IERROR=1 RETURN END C SUBROUTINE SCNCL2(W,UNWTIN,SVAL,F,SCR,NCELL) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION W(2,NCELL),UNWTIN(NCELL) DOUBLE PRECISION F(NCELL) DOUBLE PRECISION SVAL(NCELL),SCR(NCELL) C DOUBLE PRECISION MISSNG DATA MISSNG/-98765.432109D0/ C C Subroutine to determine SIPP NI collapsing, based on scale values C and criteria of 30 unweighted interview cases in each cell. C C W - matrix of estimated SIPP totals interview * ncell C UNWTIN - unweighted matrix of interviewed households C SVAL - ncell scale values C F - matrix created by SCNCOL to contain collapsing instructions to C be passed to COLLAPSE C SCR - working matrix of scale values C NCELL - number of cells C IC=0 C C First fill in 0's consistent with no collapsing, and copy C SVAL into SCR C DO 2 I=1,NCELL F(I)=0. IF(DABS(SVAL(I)-MISSNG).LE..1D-06) THEN SCR(I)=0. ELSE SCR(I)=SVAL(I) END IF 2 CONTINUE C C Next, establish collapsing if already implied by scale values. If C all cells have unique scale values, no collapsing will occur here. C DO 8 I=1,NCELL-1 IF(F(I).GT.0.)GO TO 8 DO 5 II=I+1,NCELL IF(DABS(SCR(I)-SCR(II)).LT..1D-02) THEN IF(F(I).EQ.0) THEN IC=IC+1 F(I)=IC END IF F(II)=F(I) END IF 5 CONTINUE 8 CONTINUE C C There is a major loop to process the cells in increasing order C of scale value, returning to 10 each time to find the next cell, C after continuing to collapse the current case until the conditions C are met before proceeding to the next i. C SVLAST=-1.D0 10 CONTINUE I=0 DO 12 II=1,NCELL IF(SCR(II).GT.SVLAST+.1D-2) THEN IF(I.EQ.0) THEN I=II ELSE IF(SCR(II).LT.SCR(I)-.1D-2) THEN I=II END IF END IF END IF 12 CONTINUE IF(I.EQ.0) THEN GO TO 80 ELSE SVLAST=SCR(I) END IF C C If the cell has not been previously collapsed, check whether C it meets both conditions by itself. C IF(F(I).EQ.0) THEN C IF(W(2,I).GT.0.) THEN IF(UNWTIN(I).GE.29.95D0.AND.W(2,I).LE.W(1,I))GO TO 10 C END IF END IF C C Return point if more collapsing is necessary C 15 CONTINUE C C First find the index, K, of the closest matching scale value, C while summing up the current values to check whether more C collapsing is necessary. C K=0 TOT1=0. TOT2=0. TOTUN=0. DO 20 II=1,NCELL IF(DABS(SCR(II)-SCR(I)).GT..1D-02) THEN IF(K.EQ.0) THEN K=II ELSE IF(DABS(SCR(II)-SCR(I)).LT. . DABS(SCR(K)-SCR(I))) THEN K=II ELSE IF(DABS(DABS(SCR(II)-SCR(I)) . -DABS(SCR(K) -SCR(I))).LT..1D-2) THEN IF(UNWTIN(II).LT.UNWTIN(K)) THEN K=II END IF END IF END IF ELSE TOTUN=TOTUN+UNWTIN(II) TOT1=TOT1+W(1,II) TOT2=TOT2+W(2,II) END IF 20 CONTINUE IF(K.EQ.0)GO TO 80 C IF(TOT2.GT.0.) THEN IF(TOTUN.GE.29.95D0.AND.TOT1.GE.TOT2)GO TO 10 C END IF C C COMPUTE THE NEW SCALE VALUE C C TOTUN=0. C TOT1=0. TCELL=0. TSUM3=0. IC=IC+1 DO 25 II=1,NCELL IF(DABS(SCR(II)-SCR(I)).LT..1D-02.OR. . DABS(SCR(II)-SCR(K)).LT..1D-02) THEN C TOTUN=TOTUN+UNWTIN(II) C TOT1=TOT1+UNWTIN(II)*SCR(II) TCELL=TCELL+SCR(II) TSUM3=TSUM3+1.D0 F(II)=IC END IF 25 CONTINUE C IF(TOTUN.GT.0) THEN C SCR(I)=TOT1/TOTUN C ELSE SCR(I)=TCELL/TSUM3 C END IF C C Apply the new scale values and return to 15 to check whether C this collapsing was enough or more is needed C DO 30 II=1,NCELL IF(DABS(F(II)-F(I)).LT..1D-02) THEN SCR(II)=SCR(I) END IF 30 CONTINUE GO TO 15 C C Restore the scratch array to 0's C 80 CONTINUE C DO 82 I=1,NCELL SCR(I)=0. 82 CONTINUE RETURN END C SUBROUTINE SIPCOL(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) INTEGER MATSIZ EXTERNAL MATSIZ INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 100 FORMAT(' SIPCOL: UNEXPECTED SPECIFICATION') IF(DID(1).EQ.0.) THEN IF(IVLIST(1).NE.3.OR.IVLIST(2)+IVLIST(3).NE.1.OR. . IVLIST(4).EQ.0) GO TO 99 END IF DO 1 NCELL=1,IVLIST(5) IF(DABS(DX(IVLIST(4)+NCELL-1)).LT..1D0) GO TO 2 1 CONTINUE GO TO 99 2 CONTINUE NCELL=NCELL-1 IF(NCELL.LE.1)GO TO 99 IF(NCELL*2.GT.IVLIST(5))GO TO 99 NROT=MATSIZ(DIMX(DIMPNT(1)),MTYPE(1),MTRAN(1))/NCELL IF(DID(1).EQ.0.) THEN DO 10 J=1,4 IF(MATSIZ(DIMX(DIMPNT(J)),MTYPE(J),MTRAN(J)).NE.NROT*NCELL) . GO TO 99 KK=DIMX(DIMPNT(J))+.05D0 IP=1 DO 5 I=1,KK IP2=DIMX(DIMPNT(J)+I)+.05D0 IP=IP*IP2 IF(IP.EQ.NCELL)GO TO 10 5 CONTINUE GO TO 99 10 CONTINUE END IF CALL SIPCL2(DX(DXPNT(1)),DX(DXPNT(2)),DX(DXPNT(3)),DX(DXPNT(4)), . DX(IVLIST(4)),DX(IVLIST(4)+NCELL),NCELL,NROT) RETURN 99 CONTINUE WRITE(U6,100) IERROR=1 RETURN END SUBROUTINE SIPCL2(E,C,UN,F,SVAL,SCR,NCELL,NROT) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION E(NCELL,NROT),C(NCELL,NROT),UN(NCELL,NROT) DOUBLE PRECISION F(NCELL,NROT) DOUBLE PRECISION SVAL(NCELL),SCR(NCELL) C C Subroutine to determine SIPP collapsing, based on scale values and C criteria of 35 in each cell. C C E - matrix of estimated SIPP totals C C - matrix of controls C UN - matrix of unweighted counts C F - matrix created by SIPCOL to contain collapsing instructions to C be passed to COLLAPSE C IC=0 C C Loop to 80 is over rotation, which is never collapsed. C DO 80 J=1,NROT C C First fill in 0's consistent with no collapsing, and copy C SVAL into SCR C DO 2 I=1,NCELL F(I,J)=0. SCR(I)=SVAL(I) 2 CONTINUE C C Next, establish collapsing if already implied by scale values C DO 8 I=1,NCELL-1 IF(F(I,J).GT.0.)GO TO 10 DO 5 II=I+1,NCELL IF(DABS(SCR(I)-SCR(II)).LT..1D-02) THEN IF(F(I,J).EQ.0) THEN IC=IC+1 F(I,J)=IC END IF F(II,J)=F(I,J) END IF 5 CONTINUE 8 CONTINUE C C There is a major loop to process the cells in increasing order C of scale value, returning to 10 each time to find the next cell, C after continuing to collapse the current case until the conditions C are met before proceeding to the next i. C SVLAST=0. 10 CONTINUE I=0 DO 12 II=1,NCELL IF(SCR(II).GT.SVLAST+.1D-2) THEN IF(I.EQ.0) THEN I=II ELSE IF(SCR(II).LT.SCR(I)-.1D-2) THEN I=II END IF END IF END IF 12 CONTINUE IF(I.EQ.0) THEN GO TO 80 ELSE SVLAST=SCR(I) END IF C C If the cell has not been previously collapsed, check whether C it meets both conditions by itself. C IF(F(I,J).EQ.0) THEN IF(E(I,J).GT.0.) THEN IF(UN(I,J).GE.35.AND.C(I,J)/E(I,J).LT.2.D0.AND. . C(I,J)/E(I,J).GT..67D0) GO TO 10 END IF END IF C C Return point if more collapsing is necessary C 15 CONTINUE C C First find the index, K, of the closest matching scale value, C while summing up the current values to check whether more C collapsing is necessary. C K=0 TOT1=0. TOT2=0. TOTUN=0. DO 20 II=1,NCELL IF(DABS(SCR(II)-SCR(I)).GT..1D-02) THEN IF(K.EQ.0) THEN K=II ELSE IF(DABS(SCR(II)-SCR(I)).LT. . DABS(SCR(K)-SCR(I))) THEN K=II END IF END IF ELSE TOTUN=TOTUN+UN(II,J) TOT1=TOT1+C(II,J) TOT2=TOT2+E(II,J) END IF 20 CONTINUE IF(K.EQ.0)GO TO 80 IF(TOT2.GT.0.) THEN IF(TOTUN.GE.34.95D0.AND.TOT1/TOT2.GT..67D0.AND. . TOT1/TOT2.LT.2.D0) GO TO 10 END IF C C COMPUTE THE NEW SCALE VALUE C TOTUN=0. TOT1=0. IC=IC+1 DO 25 II=1,NCELL IF(DABS(SCR(II)-SCR(I)).LT..1D-02.OR. . DABS(SCR(II)-SCR(K)).LT..1D-02) THEN TOTUN=TOTUN+UN(II,J) TOT1=TOT1+UN(II,J)*SCR(II) F(II,J)=IC END IF 25 CONTINUE SCR(I)=TOT1/TOTUN C C Apply the new scale values and return to 15 to check whether C this collapsing was enough or more is needed C DO 30 II=1,NCELL IF(DABS(F(II,J)-F(I,J)).LT..1D-02) THEN SCR(II)=SCR(I) END IF 30 CONTINUE GO TO 15 80 CONTINUE C C Restore the scratch array to 0's C DO 82 I=1,NCELL SCR(I)=0. 82 CONTINUE RETURN END C SUBROUTINE GRIDSC(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) DOUBLE PRECISION PM(6),B(3) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 201 FORMAT(1X,' SEARCH NOT DONE') IF(IVLIST(1).NE.1.OR.IVLIST(2).NE.1.OR.IVLIST(3).NE.0) THEN IERROR=1 RETURN END IF Y1=DX(DXPNT(1)) Y2=DX(DXPNT(1)+1) Y3=DX(DXPNT(1)+2) X1=DX(DXPNT(2)) X2=DX(DXPNT(2)+1) X3=DX(DXPNT(2)+2) YM=(Y1+Y2+Y3)/3.D0 XM=(X1+X2+X3)/3.D0 XC1=X1-XM XC2=X2-XM XC3=X3-XM PM(1)=3.D0 PM(2)=0.D0 PM(3)=XC1**2+XC2**2+XC3**2 PM(4)=PM(3) PM(5)=XC1**3+XC2**3+XC3**3 PM(6)=XC1**4+XC2**4+XC3**4 CALL DPPTRF('U',3,PM,INFO) IF(INFO.NE.0) THEN WRITE(U6,201) IERROR=2 RETURN END IF B(1)=0. B(2)=XC1*(Y1-YM)+XC2*(Y2-YM)+XC3*(Y3-YM) B(3)=XC1*XC1*(Y1-YM)+XC2*XC2*(Y2-YM)+XC3*XC3*(Y3-YM) CALL DPPTRS('U',3,1,PM,B,3,INFO) ISTEP=0 R=X3-X1 IF(B(3).LT.0) THEN XBEST=-.5D0*B(2)/B(3)+XM IF(XBEST.GE.X1.AND.XBEST.LE.X3) THEN DX(DXPNT(2)+1)=XBEST XMISS=DABS(X2-XBEST) IF(.1D0*R.LT.XMISS) THEN XMISS=.1D0*R END IF IF(XMISS.GT.XBEST) THEN DX(DXPNT(2))=0.D0 ELSE DX(DXPNT(2))=XBEST-XMISS END IF DX(DXPNT(2)+2)=XBEST+XMISS ISTEP=1 END IF END IF IF(ISTEP.EQ.0) THEN IF(Y1.GT.Y3) THEN IF(X1.LE.0.) THEN DX(DXPNT(2)+1)=.125D0*X2 DX(DXPNT(2)+2)=.25*X2 ELSE IF(X1-R.LE.0.) THEN DX(DXPNT(2))=0. DX(DXPNT(2)+1)=X1 DX(DXPNT(2)+2)=X2 ELSE DX(DXPNT(2))=X1-R DX(DXPNT(2)+1)=X1 END IF ELSE DX(DXPNT(2)+1)=X3 DX(DXPNT(2)+2)=X3+R END IF END IF RETURN END SUBROUTINE XMEDN(DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MSIZE,MTYPE,MTRAN,STRING,IX,IERROR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MSIZE(*), . MTYPE(*),MTRAN(*),IX(*),IERROR DOUBLE PRECISION DID(NID),DX(*) CHARACTER*128 STRING(*) INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 INTEGER MATSIZ EXTERNAL MATSIZ INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL 201 FORMAT(1X,' XMEDN ERROR') IF(IFIRST.EQ.1) THEN NCELL=IVLIST(5) IF(IVLIST(1).NE.1.OR.IVLIST(2)+IVLIST(3).NE.1) GO TO 99 IF(NCELL.LT.2)GO TO 99 IF(DIMX(DIMPNT(1)).EQ.0) GO TO 99 IF(DIMX(DIMPNT(1)+1).NE.NCELL) GO TO 99 DO 1 I=1,NCELL-1 IF(DX(IVLIST(4)+I-1).GE.DX(IVLIST(4)+I))GO TO 99 1 CONTINUE ELSE NCELL=DIMX(DIMPNT(1)+1) END IF I=MATSIZ(DIMX(DIMPNT(1)),MTYPE(1),MTRAN(1)) NROW=I/NCELL IF(IFIRST.EQ.1) THEN IF(NROW*NCELL.NE.I)GO TO 99 IF(MATSIZ(DIMX(DIMPNT(2)),MTYPE(2),MTRAN(2)).NE.NROW)GO TO 99 I=NCELL+4*NROW IVLIST(5)=I K=IVLIST(4) KK=NXPTD IVLIST(4)=NXPTD CALL ROOMD(I) DO 2 I=1,NCELL DX(KK)=DX(K) K=K+1 KK=KK+1 2 CONTINUE END IF K=IVLIST(4)+NCELL CALL XMEDN2(DID(1),DX(DXPNT(1)),DX(DXPNT(2)),DX(IVLIST(4)),DX(K), . NCELL,NROW,IX,IVLIST(7)) RETURN 99 CONTINUE WRITE(U6,201) IERROR=1 RETURN END SUBROUTINE XMEDN2(DFLAG,DA,DMED,DINTRV,DSV,NCELL,NROW,IX,IV7) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION DA(NCELL,NROW),DMED(NROW),DINTRV(NROW) DOUBLE PRECISION DSV(4,NROW) DOUBLE PRECISION MISSNG INTEGER IX(3) DATA MISSNG/-98765.432109D0/ IF(IV7.EQ.0) THEN PERCNL=.5D0 ELSE IF(IX(1).GE.1.AND.IX(1).LE.99) THEN PERCNL=DBLE(FLOAT(IX(1)))/1.D2 ELSE PERCNL=.5D0 END IF END IF IF(DFLAG.EQ.0.) THEN DO 10 IR=1,NROW SM=0.D0 DMED(IR)=MISSNG DSV(1,IR)=MISSNG DO 1 I=1,NCELL SM=SM+DA(I,IR) 1 CONTINUE IF(SM.LE.0.)GO TO 10 CSUM=0. CUT=SM*PERCNL DO 5 I=1,NCELL-1 CSUM=CSUM+DA(I,IR) IF(CSUM.GE.CUT) THEN DMED(IR)=DINTRV(I+1) . -(CSUM-CUT)*(DINTRV(I+1)-DINTRV(I))/DA(I,IR) DSV(1,IR)=DMED(IR) DSV(3,IR)=I DSV(4,IR)=(CSUM-CUT)/DA(I,IR) IW=0 IF(IV7.EQ.0) THEN IW=1 ELSE IF(IX(2).EQ.-1.AND.IX(3).EQ.-1) THEN IW=1 END IF IF(IW.EQ.1) THEN IW=NCELL/8 K1=I-IW K2=I+IW ELSE IF(IX(2).GE.1) THEN K1=I-IX(2) ELSE K1=I END IF IF(IX(3).GE.1) THEN K2=I+IX(3) ELSE K2=I END IF END IF IF(K1.LE.0)K1=1 IF(K2.GE.NCELL)K2=NCELL-1 CSUM=0. DO 4 K=K1,K2 CSUM=CSUM+DA(K,IR) 4 CONTINUE DSV(2,IR)=SM*(DINTRV(K2+1)-DINTRV(K1))/CSUM GO TO 10 END IF 5 CONTINUE 10 CONTINUE ELSE DO 20 IR=1,NROW DMED(IR)=MISSNG IF(DABS(DSV(1,IR)-MISSNG).GT..1D-6) THEN SM=0. DO 11 I=1,NCELL SM=SM+DA(I,IR) 11 CONTINUE IF(SM.LE.0.)GO TO 20 K=DSV(3,IR)+.5D-1 CSUM=0. DO 12 I=1,K CSUM=CSUM+DA(I,IR) 12 CONTINUE CUT=(DSV(4,IR)*(CSUM-DA(K,IR))+(1.D0-DSV(4,IR))*CSUM)/SM DMED(IR)=DSV(1,IR)-(CUT-PERCNL)*DSV(2,IR) END IF 20 CONTINUE END IF RETURN END C SUBROUTINE MSOLVE(IKEY,DID,NID,IFIRST,IVLIST,DIMPNT,DIMX,DXPNT, . DX,MTYPE,MTRAN,IX,IERROR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER NID,IFIRST,IVLIST(7),DIMPNT(*),DIMX(*),DXPNT(*),MTYPE(*), . MTRAN(*),IX(*),IERROR DOUBLE PRECISION DID(NID),DX(*) C INTEGER U5,U6,U5END,U5ECHO COMMON /UBLOCK/ U5,U6,U5END,U5ECHO,IMERR1,IMERR2,IMERR3 INTEGER ILIST(3),ISIZE(3) INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL INTEGER MATSIZ EXTERNAL MATSIZ DOUBLE PRECISION MISSNG DATA MISSNG/-98765.432109D0/ C 100 FORMAT(' INAPPROPRIATE MIXING OF MODIFY AND NEW') 101 FORMAT(' INAPPROPRIATE LEADING DIMENSION FOR PACKED MATRIX:',I6) 102 FORMAT(' MISMATCH OF LIST LENGTHS') 103 FORMAT(' INAPPROPRIATE CALL WITH CONSTANTS') 104 FORMAT(' MODIFIED OR NEW VARIABLES REQUIRED') 105 FORMAT(' MATCH ON SIZE REQUIRED',2I6) 107 FORMAT(' MISMATCHING ARRAY DIMENSIONS') 108 FORMAT(' INAPPROPRIATE VARIABLE TYPE FOR NEW/MODIFY') 111 FORMAT(' SPECIFIED DIMENSION DOES NOT MATCH MATRIX') C C C IKEY = -38 minvert C = -39 msolve C = -40 mmultiply, mmultiplym C = -41 msymmult, msymmultm C = -42 mtrace C = -43 mdiag C C IV23 is sum of new and MODIFY variables (only one will be >0) C IV23=IVLIST(2)+IVLIST(3) C C Checks for full sample, number and type of variables: C IF(DID(1).EQ.0.) THEN C C Check that MODIFY and new variables don't appear together, but that C one type does C IF(IVLIST(2).GT.0.AND.IVLIST(3).GT.0)GO TO 90 IF(IV23.EQ.0)GO TO 94 C C Checks for MSOLVE, MMULTIPLY, which involve 2 operators C IF(IKEY.LE.-39.OR.IKEY.EQ.-40) THEN IF(IVLIST(4).GT.0) THEN C C If CONSTANTS are given, then #OLD must=1 and IV23 must=1 C IF(IVLIST(1).NE.1.OR.IV23.NE.1)GO TO 93 ELSE C C If no CONSTANTS, then: C 1) if #OLD = 1, then #new must be 0 C 2) #OLD must be 1 or more C 3) if #OLD > 1, then #OLD must = #new/MODIFY + 1 C IF((IVLIST(1).EQ.1.AND.IVLIST(3).GT.0).OR.IVLIST(1).EQ.0.OR. . (IVLIST(1).GT.1.AND.IVLIST(1).NE.IV23+1)) GO TO 92 END IF C C Checks for MINVERT, MTRACE, and MDIAG, which involve C 1 operator C ELSE IF(IVLIST(4).GT.0) THEN C C If CONSTANTS are given