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, then C 1) #OLD must=0 C 2) #new/MODIFY must=1 C IF(IVLIST(1).NE.0.OR.IV23.NE.1)GO TO 93 ELSE C C If no CONSTANTS, then: C 1) if #OLD >0, #OLD = #new/MODIFY C 2) if #OLD =0, #new=0 C IF((IVLIST(1).GT.0.AND.IVLIST(1).NE.IV23).OR. . (IVLIST(1).EQ.0.AND.IVLIST(3).GT.0)) GO TO 92 END IF END IF END IF C C End of full sample checks for number/type of variables 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 MSOLVE, MMULTIPLYM C IF(IKEY.EQ.-39.OR.IKEY.EQ.-40) THEN C C IOLD2 is always the first old variable C IOLD2=1 C C If CONSTANTS, set IOLD1=0 C IF(IVLIST(4).GT.0) THEN IOLD1=0 ELSE C C If no CONSTANTS, IOLD1=2, regardless of whether this is an OLD, C MODIFY, or new variable. C IOLD1=2 END IF C C For MINVERT, MSYMMULT, MTRACE, MDIAG: C ELSE IOLD2=0 C C If CONSTANTS, set IOLD1=0 C IF(IVLIST(4).GT.0) THEN IOLD1=0 ELSE IOLD1=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 (actually, "second" operator is really primary/first C matrix in MSOLVE, MMULTIPLY) C JNEW - cell index for output C NPUSE - number of times "second" operator should be used in C looping through columns of "first" operator; >1 only C for MSOLVE, MMULTIPLYM; =1 otherwise. C ILIST(1)=IOLD1 IF(IOLD1.EQ.0) THEN JOLD1=IVLIST(4) ELSE JOLD1=DXPNT(IOLD1) END IF JNEW=DXPNT(INEW) C C For MSOLVE, MMULTIPLY, C set values for the primary matrix (1st old variable) C IF(IKEY.EQ.-39.OR.IKEY.EQ.-40) THEN ILIST(2)=IOLD2 NILIST=2 JOLD2=DXPNT(IOLD2) IF((MTYPE(IOLD2).EQ.2.OR.MTYPE(IOLD2).EQ.8).AND. . MTRAN(IOLD2).EQ.0)GO TO 98 ELSE C C For MINVERT, MSYMMULT, MTRACE, and MDIAG C NILIST=1 JOLD2=0 END IF C C For full sample, MSOLVE, MMULTIPLY, MSYMMULT, and MDIAG, C add new variable to ILIST C IF(DID(1).EQ.0..OR.IKEY.EQ.-39.OR.IKEY.EQ.-40.OR.IKEY.EQ.-41.OR. . IKEY.EQ.-43) 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 For MSOLVE, MMULTIPLY C adjust lengths of array for MISSING or CROSSED REAL C IF(IKEY.EQ.-39.OR.IKEY.EQ.-40) THEN IF(IOLD1.GT.0) THEN IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND. . MTRAN(IOLD1).EQ.0) THEN ISIZE(1)=ISIZE(1)/2 END IF END IF END IF IROW1=0 ICOL1=0 IROW2=0 ICOL2=0 C C Establish the dimensions, if any OPTIONS nrow1= etc. given C IF(IVLIST(7).GT.0) THEN IF(IKEY.EQ.-39.OR.IKEY.EQ.-40) THEN C C First consider case where direct information about IOLD2 is C specified, i.e., IROW1, ICOL1, or IROW2 C IF(IX(1).GT.0.OR.IX(2).GT.0.OR.IX(3).GT.0) THEN IF(IFIRST.EQ.1) THEN IF(IKEY.EQ.-39) THEN IF(IX(1).GT.0.AND.IX(2).GT.0.AND.IX(1).NE.IX(2)) . GO TO 97 IF(IX(1).GT.0.AND.IX(3).GT.0.AND.IX(1).NE.IX(3)) . GO TO 97 END IF IF(IX(2).GT.0.AND.IX(3).GT.0.AND.IX(2).NE.IX(3))GO TO 97 IF(IX(1).LT.0.OR.IX(2).LT.0.OR.IX(3).LT.0)GO TO 97 IF(IX(1).GT.0) THEN IF(IX(2).GT.0) THEN IF((IX(1)*IX(2))*(ISIZE(2)/(IX(1)*IX(2))).NE.ISIZE(2)) . GO TO 97 ELSE IF(IX(3).GT.0) THEN IF((IX(1)*IX(3))*(ISIZE(2)/(IX(1)*IX(3))).NE.ISIZE(2)) . GO TO 97 ELSE IF(IX(1)*(ISIZE(2)/IX(1)).NE.ISIZE(2))GO TO 97 END IF ELSE IF(IX(2).GT.0) THEN IF(IX(2)*(ISIZE(2)/IX(2)).NE.ISIZE(2))GO TO 97 ELSE IF(IX(3)*(ISIZE(2)/IX(3)).NE.ISIZE(2))GO TO 97 END IF END IF IROW1=IX(1) IF(IX(2).GT.0) THEN ICOL1=IX(2) ELSE ICOL1=IX(3) END IF C C If IKEY=-39, can determine all values C IF(IKEY.EQ.-39) THEN IF(IROW1.GT.0) THEN ICOL1=IROW1 ELSE IROW1=ICOL1 END IF END IF C C Fill in missing column from row information (IKEY=-40 only) C IF(ICOL1.EQ.0) THEN IF(IROW1.EQ.ISIZE(2)) THEN ICOL1=1 ELSE IF(IROW1.EQ.1) THEN ICOL1=DIMX(DIMPNT(IOLD2)+1) ELSE J=1 DO 11 I=1,DIMX(DIMPNT(IOLD2)) J=J*DIMX(DIMPNT(IOLD2)+I) IF(J.EQ.IROW1)GO TO 12 11 CONTINUE GO TO 97 12 CONTINUE ICOL1=DIMX(DIMPNT(IOLD2)+I+1) END IF C C Fill in missing row from column information/dimensions C (IKEY=-40 only) C ELSE IF(IROW1.EQ.0) THEN IF(DIMX(DIMPNT(IOLD2)).EQ.0) THEN IROW1=1 ELSE IF(ICOL1.EQ.ISIZE(2)) THEN IROW1=1 ELSE IROW1=DIMX(DIMPNT(IOLD2)+1) END IF END IF IF(IFIRST.EQ.1) THEN IF(IROW1*ICOL1*(ISIZE(2)/(IROW1*ICOL1)).NE.ISIZE(2)) . GO TO 97 END IF END IF C C Next, consider the case where some information about IOLD1 C is given, i.e, ICOL1, IROW2, or ICOL2 C IF(IX(2).GT.0.OR.IX(3).GT.0.OR.IX(4).GT.0) THEN IF(IFIRST.EQ.1) THEN C C (Note this first check already done above) C C IF(IX(2).GT.0.AND.IX(3).GT.0.AND.IX(2).NE.IX(3))GO TO 97 C IF(IX(2).LT.0.OR.IX(3).LT.0.OR.IX(4).LT.0)GO TO 97 IF(IX(4).GT.0) THEN IF(IX(2).GT.0) THEN IF((IX(4)*IX(2))*(ISIZE(1)/(IX(4)*IX(2))).NE.ISIZE(1)) . GO TO 97 ELSE IF(IX(3).GT.0) THEN IF((IX(4)*IX(3))*(ISIZE(1)/(IX(4)*IX(3))).NE.ISIZE(1)) . GO TO 97 ELSE IF(IX(4)*(ISIZE(1)/IX(4)).NE.ISIZE(1))GO TO 97 END IF ELSE IF(IX(2).GT.0) THEN IF(IX(2)*(ISIZE(1)/IX(2)).NE.ISIZE(1))GO TO 97 ELSE IF(IX(3)*(ISIZE(1)/IX(3)).NE.ISIZE(1))GO TO 97 END IF END IF ICOL2=IX(4) IF(IX(2).GT.0) THEN IROW2=IX(2) ELSE IROW2=IX(3) END IF C C Fill in missing column from row information C IF(ICOL2.EQ.0) THEN IF(IROW2.EQ.ISIZE(1)) THEN ICOL2=1 ELSE IF(IOLD1.EQ.0) THEN ICOL2=ISIZE(1)/IROW2 ELSE IF(IROW2.EQ.1) THEN ICOL2=DIMX(DIMPNT(IOLD1)+1) ELSE J=1 DO 13 I=1,DIMX(DIMPNT(IOLD1)) J=J*DIMX(DIMPNT(IOLD1)+I) IF(J.EQ.IROW2)GO TO 14 13 CONTINUE GO TO 97 14 CONTINUE ICOL2=DIMX(DIMPNT(IOLD1)+I+1) END IF C C In this case, we know that IROW1, ICOL1, and IROW2 have C all been established. Consequently, check if the value of ICOL2 C just computed "works" in terms of ISIZE(3) - else consider C inner product (when IROW1=1) or other reason for ICOL2=1 C NPUSE=(ISIZE(1)/(IROW2*ICOL2))/(ISIZE(2)/(IROW1*ICOL1)) IF(NPUSE*IROW1*(ISIZE(1)/IROW2).NE.ISIZE(3)) THEN NPUSE=(ISIZE(1)/IROW2)/(ISIZE(2)/(IROW1*ICOL1)) IF(NPUSE*IROW1*(ISIZE(1)/IROW2).NE.ISIZE(3)) THEN GO TO 97 ELSE ICOL2=1 END IF END IF C C Fill in missing row information C ELSE IF(IROW2.EQ.0) THEN IF(ICOL2.EQ.ISIZE(1)) THEN IROW2=1 ELSE IF(IOLD1.EQ.0) THEN IROW2=ISIZE(1)/ICOL2 ELSE IROW2=DIMX(DIMPNT(IOLD1)+1) END IF END IF IF(IFIRST.EQ.1) THEN IF(IROW2*ICOL2*(ISIZE(1)/(IROW2*ICOL2)).NE.ISIZE(1)) . GO TO 97 END IF END IF C C By this point, have established dimensions of one or both C matrices. If one is missing, fill in the other here. C IF(IROW1.EQ.0) THEN ICOL1=IROW2 IF(IKEY.EQ.-39) THEN IROW1=ICOL1 ELSE IF(DIMX(DIMPNT(IOLD2)).EQ.0) THEN IROW1=1 ELSE IF(ICOL1.EQ.ISIZE(2)) THEN IROW1=1 ELSE IROW1=DIMX(DIMPNT(IOLD2)+1) END IF IF(IFIRST.EQ.1) THEN IF(IROW1*ICOL1*(ISIZE(2)/(IROW1*ICOL1)).NE.ISIZE(2)) . GO TO 97 IF(IKEY.EQ.-39) THEN IF(IROW1.NE.ICOL1)GO TO 97 END IF END IF ELSE IF(IROW2.EQ.0) THEN IROW2=ICOL1 IF(IROW2.EQ.ISIZE(1)) THEN ICOL2=1 ELSE IF(IOLD1.EQ.0) THEN ICOL2=ISIZE(1)/IROW2 ELSE IF(IROW2.EQ.1) THEN ICOL2=DIMX(DIMPNT(IOLD1)+1) ELSE J=1 DO 15 I=1,DIMX(DIMPNT(IOLD1)) J=J*DIMX(DIMPNT(IOLD1)+I) IF(J.EQ.IROW2)GO TO 16 15 CONTINUE GO TO 97 16 CONTINUE ICOL2=DIMX(DIMPNT(IOLD1)+I+1) END IF C C Again, if ICOL2 is last to be established, verify that this C value "works" rather than ICOL2=1. C NPUSE=(ISIZE(1)/(IROW2*ICOL2))/(ISIZE(2)/(IROW1*ICOL1)) IF(NPUSE*IROW1*(ISIZE(1)/IROW2).NE.ISIZE(3)) THEN NPUSE=(ISIZE(1)/IROW2)/(ISIZE(2)/(IROW1*ICOL1)) IF(NPUSE*IROW1*(ISIZE(1)/IROW2).NE.ISIZE(3)) THEN GO TO 97 ELSE ICOL2=1 END IF END IF IF(IFIRST.EQ.1) THEN IF(IROW2*ICOL2*(ISIZE(1)/(IROW2*ICOL2)).NE.ISIZE(1)) . GO TO 97 END IF END IF NPUSE=(ISIZE(1)/(IROW2*ICOL2))/(ISIZE(2)/(IROW1*ICOL1)) IF(NPUSE*IROW1*(ISIZE(1)/IROW2).NE.ISIZE(3))GO TO 97 C C Establish dimensions for MINVERT, etc., when dimensions specified C ELSE C C Under all conditions, establish the preliminary dimensions of C the matrix indexed by IOLD1 C C BEGIN TRANSPLANTED CODE. C IF(IOLD1.EQ.0) THEN IROW2=0 ICOL2=0 IF(IVLIST(7).GT.0) THEN IF(IKEY.EQ.-39.OR.IKEY.EQ.-40) THEN IF(IX(3).GT.0) THEN IROW2=IX(3) END IF IF(IX(4).GT.0) THEN ICOL2=IX(4) END IF ELSE IF(IX(1).GT.0) THEN IROW2=IX(1) ELSE IF(IX(3).GT.0) THEN IROW2=IX(3) END IF IF(IX(2).GT.0) THEN ICOL2=IX(2) ELSE IF(IX(4).GT.0) THEN ICOL2=IX(4) END IF END IF IF(IFIRST.EQ.1.AND.IROW2.GT.0) THEN IF(IROW2*(ISIZE(1)/IROW2).NE.ISIZE(1))GO TO 911 END IF IF(IFIRST.EQ.1.AND.ICOL2.GT.0) THEN IF(ICOL2*(ISIZE(1)/ICOL2).NE.ISIZE(1))GO TO 911 END IF END IF IF(IROW2.EQ.0) THEN IF(IOLD1.EQ.0) THEN IF(ICOL2.EQ.ISIZE(1)) THEN IROW2=1 ELSE ICOL2=1 IROW2=ISIZE(1) END IF ELSE IF(DIMX(DIMPNT(IOLD1)).EQ.0) THEN IROW2=1 ELSE IF(IVLIST(7).GT.0) THEN IROW2=DIMX(DIMPNT(IOLD1)+1) END IF END IF IF(ICOL2.EQ.0) THEN IF(IOLD1.EQ.0) THEN IF(IROW2.EQ.1) THEN ICOL2=ISIZE(1) ELSE ICOL2=1 IROW2=ISIZE(1) END IF ELSE IF(DIMX(DIMPNT(IOLD1)).LE.1) THEN ICOL2=1 ELSE ICOL2=DIMX(DIMPNT(IOLD1)+2) END IF END IF IF((ISIZE(1)/(IROW2*ICOL2))*IROW2*ICOL2.NE.ISIZE(1))GO TO 97 END IF C C END OF TRANSPLANTED CODE C IROW2=1 END IF ELSE C C Establish dimensions for MSOLVE, MMULTIPLY, when no dimensions C specified C IF(IKEY.EQ.-39.OR.IKEY.EQ.-40) THEN IF(DIMX(DIMPNT(IOLD2)).EQ.0) THEN IROW1=1 ICOL1=1 ELSE IF(DIMX(DIMPNT(IOLD2)).EQ.1) THEN IF(IKEY.EQ.-39)GO TO 97 IROW1=DIMX(DIMPNT(IOLD2)+1) ICOL1=1 ELSE IROW1=DIMX(DIMPNT(IOLD2)+1) ICOL1=DIMX(DIMPNT(IOLD2)+2) END IF IF(IOLD1.EQ.0) THEN IROW2=ISIZE(1) ICOL2=1 ELSE IF(DIMX(DIMPNT(IOLD1)).EQ.0) THEN IROW2=ISIZE(1) ICOL2=1 ELSE IF(DIMX(DIMPNT(IOLD1)).EQ.1) THEN IROW2=ISIZE(1) ICOL2=1 ELSE IROW2=DIMX(DIMPNT(IOLD1)+1) ICOL2=DIMX(DIMPNT(IOLD1)+2) END IF MATCH=1 C C Regular product C IF(IKEY.EQ.-40) THEN IF(IROW2.NE.ICOL1)MATCH=0 IF(IROW1*ISIZE(1)/IROW2.NE.ISIZE(3))MATCH=0 NPUSE=(ISIZE(3)*ICOL1)/(ICOL2*ISIZE(2)) IF(NPUSE*(ICOL2*ISIZE(2))/ICOL1.NE.ISIZE(3))MATCH=0 END IF MATCH2=1 C C Outer product C IF(IKEY.EQ.-40) THEN IF(IROW1*ISIZE(1).NE.ISIZE(3))MATCH2=0 NPUSE2=ISIZE(3)/(IROW2*ISIZE(2)) IF(NPUSE2*(IROW2*ISIZE(2)).NE.ISIZE(3))MATCH2=0 END IF MATCH3=1 C C Inner product C IF(IKEY.EQ.-40) THEN IF(IROW1.NE.IROW2)MATCH3=0 IF(ISIZE(1)/IROW2.NE.ISIZE(3))MATCH3=0 NPUSE3=(ISIZE(3)*IROW1)/(ISIZE(2)) IF(NPUSE3*(ISIZE(2))/IROW1.NE.ISIZE(3))MATCH3=0 END IF IF(MATCH.EQ.1) THEN IF(MATCH2.EQ.1.OR.MATCH3.EQ.1)GO TO 97 ELSE IF(MATCH2.EQ.1) THEN IF(MATCH3.EQ.1)GO TO 97 ICOL1=1 ICOL2=IROW2 IROW2=1 NPUSE=NPUSE2 ELSE IF(MATCH3.EQ.1) THEN ICOL1=IROW1 IROW1=1 ICOL2=1 NPUSE=NPUSE3 ELSE GO TO 97 END IF C C Establish dimensions for MINVERT, etc., when no dimensions specified C ELSE ICOL1=1 END IF END IF C C Temporarily set INCR to 0, to be recomputed below C C INCR=0 C C For PPACK, PUNPACK, and PDIAG, redefine IEDGE on the basis of matrix C size. C IF(IKEY.EQ.-31.OR.IKEY.EQ.-32.OR.IKEY.EQ.-34) THEN IF( ((IKEY.EQ.-31.OR.IKEY.EQ.-32).AND.ISIZE(1).GT.ISIZE(2)) . .OR.(IKEY.EQ.-34.AND.ISIZE(2).GT.ISIZE(1))) THEN IF(DIMX(DIMPNT(INEW)).EQ.0) THEN IEDGE=1 ELSE IEDGE=DIMX(DIMPNT(INEW)+1) END IF ILEN=DSQRT(2.D0*DBLE(FLOAT(IEDGE))) C C Redefinition of INCR here. C IF(IKEY.EQ.-31.OR.IKEY.EQ.-32) THEN INCR=ILEN*ILEN ELSE INCR=ILEN END IF END IF END IF C ILEN=DSQRT(2.D0*DBLE(FLOAT(IEDGE))) C C Full sample checks for sizes and dimensions of matrices C IF(IFIRST.EQ.1.AND.IKEY.NE.-40) THEN C C For PINVERT, PSOLVE, PMULTIPYM, and PSYMMULTP, C check that size of first operator matches size of target, unless C REAL with MISSING or CROSSED REAL are involved. C IF((IKEY.LE.-25.AND.IKEY.GE.-27).OR.IKEY.EQ.-30) THEN IF(ISIZE(NILIST).NE.ISIZE(1)) GO TO 95 C C For PMULTIPLYP, check that output size reflects a square matrix of C correct size C ELSE IF(IKEY.EQ.-28) THEN IF(ILEN*ILEN*ISIZE(1).NE.IEDGE*ISIZE(NILIST))GO TO 95 C C Check dimensions for PSYMMULTM C ELSE IF(IKEY.EQ.-29) THEN IF(IEDGE2*ISIZE(1).NE.ICOL2*ILEN*ISIZE(NILIST))GO TO 97 C C Check dimensions for PPACK, PUNPACK C ELSE IF(IKEY.EQ.-31.OR.IKEY.EQ.-32) THEN IF(ISIZE(1).GT.ISIZE(2)) THEN IF(IEDGE*ISIZE(1).NE.ILEN*ILEN*ISIZE(2))GO TO 97 ELSE IF(ILEN*ILEN*ISIZE(1).NE.IEDGE*ISIZE(2))GO TO 97 END IF C C Check dimensions for PTRACE C ELSE IF(IKEY.EQ.-33) THEN IF(ISIZE(1).NE.IEDGE*ISIZE(2))GO TO 95 C C Check dimensions for PDIAG C ELSE IF(IKEY.EQ.-34) THEN IF(ISIZE(1).GT.ISIZE(2)) THEN IF(ILEN*ISIZE(1).NE.IEDGE*ISIZE(2)) GO TO 95 ELSE IF(IEDGE*ISIZE(1).NE.ILEN*ISIZE(2)) GO TO 95 END IF END IF IF(MTYPE(INEW).EQ.2.OR.MTYPE(INEW).EQ.8)GO TO 98 C C Check that IEDGE is a valid value for a packed matrix C IF(ILEN*(ILEN+1).NE.2*IEDGE)GO TO 91 C C Check that the dimensions of the matrices appear appropriate C IF(ILEN.GT.1) THEN C C For PSOLVE, PMULTIPLYM, PMULTIPLYP, and PSYMMULTM C IF(IKEY.LE.-26.AND.IKEY.GE.-29) THEN IF(IKEY.EQ.-28) THEN IF(IEDGE*(ISIZE(1)/IEDGE).NE.ISIZE(1))GO TO 97 ELSE IF(ILEN*(ISIZE(1)/ILEN).NE.ISIZE(1))GO TO 97 END IF J=1 DO 22 I=DIMPNT(INEW)+1,DIMPNT(INEW)+DIMX(DIMPNT(INEW)) J=J*DIMX(I) IF(IKEY.EQ.-29) THEN IF(J.EQ.IEDGE2) THEN GO TO 23 ELSE IF(J.GT.IEDGE2) THEN GO TO 97 END IF ELSE IF(J.EQ.ILEN) THEN IF(IKEY.EQ.-28) THEN IF(ITEMP.EQ.0) THEN ITEMP=1 J=1 ELSE GO TO 23 END IF ELSE GO TO 23 END IF ELSE IF(J.GT.ILEN) THEN GO TO 97 END IF END IF 22 CONTINUE GO TO 97 23 CONTINUE IF(IOLD1.GT.0) THEN J=1 DO 24 I=DIMPNT(IOLD1)+1,DIMPNT(IOLD1)+DIMX(DIMPNT(IOLD1)) IF(I.EQ.DIMPNT(IOLD1)+1) THEN IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND. . MTRAN(IOLD1).EQ.0) GO TO 24 END IF J=J*DIMX(I) IF(IKEY.EQ.-28) THEN IF(J.EQ.IEDGE) THEN GO TO 25 ELSE IF(J.GT.IEDGE) THEN GO TO 97 END IF ELSE IF(J.EQ.ILEN) THEN GO TO 25 ELSE IF(J.GT.ILEN) THEN GO TO 97 END IF END IF 24 CONTINUE GO TO 97 25 CONTINUE END IF ELSE IF(IKEY.EQ.-30) THEN C C For PSYMMULTP C IF(IEDGE*(ISIZE(1)/IEDGE).NE.ISIZE(1))GO TO 97 J=1 DO 27 I=DIMPNT(INEW)+1,DIMPNT(INEW)+DIMX(DIMPNT(INEW)) J=J*DIMX(I) IF(J.EQ.IEDGE) THEN GO TO 28 ELSE IF(J.GT.IEDGE) THEN GO TO 97 END IF 27 CONTINUE GO TO 97 28 CONTINUE IF(IOLD1.GT.0) THEN J=1 DO 29 I=DIMPNT(IOLD1)+1,DIMPNT(IOLD1)+DIMX(DIMPNT(IOLD1)) IF(I.EQ.DIMPNT(IOLD1)+1) THEN IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND. . MTRAN(IOLD1).EQ.0) GO TO 29 END IF J=J*DIMX(I) IF(J.EQ.IEDGE) THEN GO TO 30 ELSE IF(J.GT.IEDGE) THEN GO TO 97 END IF 29 CONTINUE GO TO 97 30 CONTINUE END IF END IF END IF END IF C C End of full sample checks for sizes and dimensions of matrices. 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(IKEY.EQ.-40) THEN INCR=ISIZE(1)/(ISIZE(2)/(IROW1*ICOL1)) IEDGE=IROW1*ICOL1 END IF C C Determine NPUSE here C IF(IKEY.LE.-26.AND.IKEY.GE.-30) THEN IF(IKEY.EQ.-26.OR.IKEY.EQ.-27.OR.IKEY.EQ.-29) THEN NPUSE=INCR/(ILEN*ICOL2) ELSE NPUSE=INCR/IEDGE END IF IF(IFIRST.EQ.1) THEN IF(INCR.NE.(INCR/NPUSE)*NPUSE)GO TO 95 END IF ELSE IF(IKEY.NE.-40) THEN NPUSE=1 END IF C C JINCR - increment for JOLD1 C JINCR2 - increment for JNEW C IF((IKEY.LE.-25.AND.IKEY.GE.-27).OR.IKEY.EQ.-30) THEN JINCR2=INCR/NPUSE ELSE IF(IKEY.EQ.-28) THEN JINCR2=ILEN*ILEN ELSE IF(IKEY.EQ.-29) THEN JINCR2=IEDGE2 ELSE IF(IKEY.EQ.-31.OR.IKEY.EQ.-32) THEN IF(ISIZE(1).GT.ISIZE(2)) THEN JINCR2=IEDGE ELSE JINCR2=ILEN*ILEN END IF ELSE IF(IKEY.EQ.-33) THEN JINCR2=1 ELSE IF(IKEY.EQ.-34) THEN IF(ISIZE(1).GT.ISIZE(2)) THEN JINCR2=ILEN ELSE JINCR2=IEDGE END IF ELSE IF(IKEY.EQ.-40) THEN JINCR2=IROW1*ICOL2 END IF IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND.MTRAN(IOLD1).EQ.0) . THEN JINCR=2 ELSE JINCR=1 END IF C INCRN=INCR/NPUSE DO 80 I=1,ISIZE(1),INCR DO 79 IPUSE=1,NPUSE INFO=0 IF(IKEY.LE.-26.AND.IKEY.GE.-30) THEN DO 32 J=1,IEDGE IF(DABS(DX(JOLD2+J-1)-MISSNG).LE..1D-06)INFO=-1 32 CONTINUE END IF IF(INFO.EQ.0) THEN JOLD1T=JOLD1 DO 34 J=1,INCRN IF(DABS(DX(JOLD1T)-MISSNG).LE..1D-06)INFO=-1 JOLD1T=JOLD1T+JINCR 34 CONTINUE END IF IF(INFO.EQ.0) THEN IF(IKEY.EQ.-39.OR.IKEY.EQ.-40) THEN NXPTDS=NXPTD IF(JNEW.EQ.JOLD1.OR.JINCR.NE.1) THEN CALL ROOMD(INCRN) JNEWT=NXPTDS JOLD1T=JOLD1 DO 36 J=1,INCRN DX(JNEWT)=DX(JOLD1T) JNEWT=JNEWT+1 JOLD1T=JOLD1T+JINCR 36 CONTINUE JOLD1T=NXPTDS ELSE JOLD1T=JOLD1 END IF IF(IKEY.EQ.-40) THEN CALL DGEMM('N','N',IROW1,ICOL2,ICOL1,1.D0,DX(JOLD2),IROW1, . DX(JOLD1T),IROW2,0.D0,DX(JNEW),IROW1) NXPTD=NXPTDS END IF IF(IKEY.EQ.-26) THEN IF(IPUSE.EQ.1) THEN CALL DPPTRF('U',ILEN,DX(JOLD2),INFO) END IF ELSE IF(IKEY.NE.-40) THEN CALL DPPTRF('U',ILEN,DX(JNEW),INFO) END IF IF(INFO.EQ.0) THEN IF(IKEY.EQ.-26) THEN CALL DPPTRS('U',ILEN,ICOL2,DX(JOLD2),DX(JNEW),ILEN,INFO) ELSE IF(IKEY.NE.-40) THEN CALL DPPTRI('U',ILEN,DX(JNEW),INFO) END IF END IF ELSE IF(IKEY.LE.-27.AND.IKEY.GE.-30) THEN NXPTDS=NXPTD IF(JNEW.EQ.JOLD1.OR.JINCR.EQ.2) THEN CALL ROOMD(INCRN) JNEWT=NXPTDS JOLD1T=JOLD1 DO 42 J=1,INCRN DX(JNEWT)=DX(JOLD1T) JNEWT=JNEWT+1 JOLD1T=JOLD1T+JINCR 42 CONTINUE JOLD1T=NXPTDS ELSE JOLD1T=JOLD1 END IF IF(IKEY.EQ.-27) THEN CALL DSPMM('U','N',ILEN,ICOL2,1.D0,DX(JOLD2),DX(JOLD1T), . ILEN,0.0D0,DX(JNEW),ILEN) ELSE IF(IKEY.EQ.-28) THEN CALL DSPMP('U',ILEN,1.D0,DX(JOLD2),DX(JOLD1T),0.0D0, . DX(JNEW),ILEN) ELSE ITEMP=NXPTD IF(IKEY.EQ.-29) THEN J=ILEN*ICOL2+ICOL2*ICOL2 ELSE J=2*ILEN*ILEN END IF CALL ROOMD(J) JNEWT=JNEW IF(IKEY.EQ.-29) THEN CALL DSPMM('U','N',ILEN,ICOL2,1.D0,DX(JOLD2),DX(JOLD1T), . ILEN,0.0D0,DX(ITEMP),ILEN) ITEMP2=ITEMP+ILEN*ICOL2 CALL DGEMM('T','N',ICOL2,ICOL2,ILEN,1.0D0,DX(JOLD1T), . ILEN,DX(ITEMP),ILEN,0.0D0,DX(ITEMP2),ICOL2) ILEN2=ICOL2 ELSE CALL DSPMP('U',ILEN,1.D0,DX(JOLD2),DX(JOLD1T),0.0D0, . DX(ITEMP),ILEN) ITEMP2=ITEMP+ILEN*ILEN CALL DSPMM('U','N',ILEN,ILEN,1.D0,DX(JOLD1T),DX(ITEMP), . ILEN,0.0D0,DX(ITEMP2),ILEN) ILEN2=ILEN END IF DO 46 J1=1,ILEN2 DO 44 J2=1,J1 DX(JNEWT)=DX(ITEMP2) ITEMP2=ITEMP2+1 JNEWT=JNEWT+1 44 CONTINUE ITEMP2=ITEMP2+ILEN2-J1 46 CONTINUE END IF NXPTD=NXPTDS ELSE IF(IKEY.EQ.-31.OR.IKEY.EQ.-32) THEN JNEWT=JNEW ITEMP=JOLD1 IF(ISIZE(1).GT.ISIZE(2)) THEN DO 48 J1=1,ILEN DO 47 J2=1,J1 DX(JNEWT)=DX(ITEMP) ITEMP=ITEMP+1 JNEWT=JNEWT+1 47 CONTINUE ITEMP=ITEMP+ILEN-J1 48 CONTINUE ELSE DO 54 J1=1,ILEN DO 52 J2=1,J1 DX(JNEWT)=DX(ITEMP) ITEMP=ITEMP+1 JNEWT=JNEWT+1 52 CONTINUE JNEWT=JNEWT+ILEN-J1 54 CONTINUE IF(ILEN.GT.1) THEN JNEWT=JNEW+1 DO 58 J1=1,ILEN ITEMP=JOLD1+(J1*(J1+1))/2+J1-1 DO 56 J2=J1+1,ILEN DX(JNEWT)=DX(ITEMP) JNEWT=JNEWT+1 ITEMP=ITEMP+J2 56 CONTINUE JNEWT=JNEWT+J1+1 58 CONTINUE END IF END IF ELSE IF(IKEY.EQ.-33) THEN DX(JNEW)=DX(JOLD1) IF(ILEN.GT.1) THEN ITEMP=JOLD1+2 DO 62 J1=2,ILEN DX(JNEW)=DX(JNEW)+DX(ITEMP) ITEMP=ITEMP+J1+1 62 CONTINUE END IF ELSE IF(IKEY.EQ.-34) THEN JNEWT=JNEW ITEMP=JOLD1 IF(ISIZE(1).GT.ISIZE(2)) THEN DO 64 J1=1,ILEN DX(JNEWT)=DX(ITEMP) JNEWT=JNEWT+1 ITEMP=ITEMP+J1+1 64 CONTINUE ELSE DX(JNEWT)=DX(ITEMP) JNEWT=JNEWT+1 ITEMP=ITEMP+1 IF(ILEN.GT.1) THEN DO 68 J1=2,ILEN DO 66 J2=1,J1-1 DX(JNEWT)=0.D0 JNEWT=JNEWT+1 66 CONTINUE DX(JNEWT)=DX(ITEMP) ITEMP=ITEMP+1 JNEWT=JNEWT+1 68 CONTINUE END IF END IF END IF END IF IF(INFO.NE.0) THEN JNEWT=JNEW DO 78 J=1,JINCR2 DX(JNEWT)=MISSNG JNEWT=JNEWT+1 78 CONTINUE END IF JNEW=JNEW+JINCR2 JOLD1=JOLD1+INCRN*JINCR 79 CONTINUE IF(JOLD2.GT.0)JOLD2=JOLD2+IEDGE 80 CONTINUE C C Increment IOLD1, INEW C IOLD1=IOLD1+1 INEW=INEW+1 GO TO 5 90 CONTINUE WRITE(U6,100) GO TO 99 91 CONTINUE WRITE(U6,101)IEDGE 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 97 CONTINUE WRITE(U6,107) GO TO 99 98 CONTINUE WRITE(U6,108) GO TO 99 911 CONTINUE WRITE(U6,111) 99 CONTINUE IERROR=1 RETURN C C End of SUBROUTINE MSOLVE C END C C SUBROUTINE PBDIAG(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(*) 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/ 100 FORMAT(' INAPPROPRIATE MIXING OF MODIFY AND NEW') 101 FORMAT(' INAPPROPRIATE LEADING DIMENSION FOR PACKED MATRIX') 102 FORMAT(' PBDIAG: SPECIFIED OPTION IGNORED') 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') 109 FORMAT(' ONLY ONE NEW/MODIFY VARIABLE ALLOWED') 111 FORMAT(' OLD VARIABLE(S) REQUIRED') C C IKEY = -44 pbmultiplym C = -45 pbmultiplyp C = -46 pbsymmultm C = -47 pbsymmultp C = -48 pbdiag 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(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 DO 1 I=IVLIST(1)+1,IVLIST(1)+IV23 IF((MTYPE(I).EQ.2.OR.MTYPE(I).EQ.8).AND.MTRAN(I).EQ.0) . GO TO 98 1 CONTINUE C C At least one old variable must be present C IF(IVLIST(1).EQ.0)GO TO 911 C C Check for PBMULTIPLYM, PBMULTIPLYP, PBSYMMULTM, and PBSYMMULTP, C which involve 2 operators C IF(IKEY.GE.-47) THEN C C Only one target variable must be present C IF(IV23.NE.1)GO TO 99 C C Check for PBDIAG, which does not accept constants C ELSE IF(IVLIST(4).GT.0)GO TO 93 IF(IVLIST(1).GT.1.AND.IV23.GT.1)GO TO 97 IF(IVLIST(7).NE.0) THEN WRITE(U6,102) IERROR=2 END IF END IF END IF C C End of full sample checks for number/type of variables C C IPACKV will denote the single packed matrix in unblocked form C IF(IKEY.EQ.-48) THEN IF(IVLIST(1).GT.1) THEN IPACKV=IVLIST(1)+1 ELSE IF(IV23.GT.1) THEN IPACKV=1 ELSE ISIZE1=MATSIZ(DIMX(DIMPNT(1)),MTYPE(1),MTRAN(1)) ISIZE2=MATSIZ(DIMX(DIMPNT(2)),MTYPE(2),MTRAN(2)) IF(ISIZE1.GT.ISIZE2) THEN IPACKV=1 ELSE IF(ISIZE2.GT.ISIZE1) THEN IPACKV=2 ELSE GO TO 97 END IF END IF C C Full sample checks for dimensions of target variable C IF(IFIRST.EQ.1) THEN IF(DIMX(DIMPNT(IPACKV)).EQ.0)GO TO 91 END IF IEDGE=DIMX(DIMPNT(IPACKV)+1) ILEN=DSQRT(2.D0*DBLE(FLOAT(IEDGE))) ISIZE2=MATSIZ(DIMX(DIMPNT(IPACKV)),MTYPE(IPACKV),MTRAN(IPACKV)) NITER=ISIZE2/IEDGE IF(IFIRST.EQ.1) THEN IF((ILEN*(ILEN+1))/2.NE.IEDGE)GO TO 91 END IF C C If IPACKV > 1, then subroutine is to pack blocked matrices into C IPACKV C IF(IPACKV.GT.1) THEN JNEW=DXPNT(IPACKV) DO 20 ITER=1,NITER ILENC=0 DO 18 J=1,IVLIST(1) IF((MTYPE(J).EQ.2.OR.MTYPE(J).EQ.8).AND.MTRAN(J).EQ.0) THEN JINCR=2 ELSE JINCR=1 END IF ISIZE1=MATSIZ(DIMX(DIMPNT(J)),MTYPE(J),MTRAN(J))/JINCR IF(DIMX(DIMPNT(J)).GT.0) THEN IF(JINCR.EQ.1) THEN IEDGE1=DIMX(DIMPNT(J)+1) ELSE IF(DIMX(DIMPNT(J)).GT.1) THEN IEDGE1=DIMX(DIMPNT(J)+2) ELSE IEDGE1=1 END IF END IF ILEN1=DSQRT(2.D0*DBLE(FLOAT(IEDGE1))) ELSE IEDGE1=1 ILEN1=1 END IF IF(IFIRST.EQ.1.AND.ITER.EQ.1) THEN IF((ILEN1*(ILEN1+1))/2.NE.IEDGE1)GO TO 91 IF((ISIZE1/(IEDGE1*NITER))*NITER.NE.ISIZE1/IEDGE1)GO TO 91 END IF JOLD1=DXPNT(J)+JINCR*((ISIZE1/NITER)*(ITER-1)) NK=ISIZE1/(IEDGE1*NITER) IF(ILENC+NK*ILEN1.GT.ILEN)GO TO 91 DO 16 K=1,NK DO 14 KK=1,ILEN1 IF(ILENC.GT.0) THEN DO 8 I=1,ILENC DX(JNEW)=0. JNEW=JNEW+1 8 CONTINUE END IF DO 10 I=1,KK DX(JNEW)=DX(JOLD1) JNEW=JNEW+1 JOLD1=JOLD1+JINCR 10 CONTINUE 14 CONTINUE ILENC=ILENC+ILEN1 16 CONTINUE 18 CONTINUE IF(ILENC.NE.ILEN)GO TO 91 20 CONTINUE ELSE C C If IPACKV=1, then subroutine is to unpack the full matrix into C a series of matrices. C JOLD1=DXPNT(1) IF((MTYPE(1).EQ.2.OR.MTYPE(1).EQ.8).AND.MTRAN(1).EQ.0) THEN JINCR=2 ELSE JINCR=1 END IF DO 40 ITER=1,NITER ILENC=0 DO 38 J=2,IV23+1 ISIZE1=MATSIZ(DIMX(DIMPNT(J)),MTYPE(J),MTRAN(J))/JINCR IF(DIMX(DIMPNT(J)).GT.0) THEN IF(JINCR.EQ.1) THEN IEDGE1=DIMX(DIMPNT(J)+1) ELSE IF(DIMX(DIMPNT(J)).GT.1) THEN IEDGE1=DIMX(DIMPNT(J)+2) ELSE IEDGE1=1 END IF END IF ILEN1=DSQRT(2.D0*DBLE(FLOAT(IEDGE1))) ELSE IEDGE1=1 ILEN1=1 END IF IF(DID(1).EQ.0.AND.ITER.EQ.1) THEN IF((ILEN1*(ILEN1+1))/2.NE.IEDGE1)GO TO 91 IF((ISIZE1/(IEDGE1*NITER))*NITER.NE.ISIZE1/IEDGE1)GO TO 91 END IF JNEW=DXPNT(J)+(ISIZE1/NITER)*(ITER-1) NK=ISIZE1/(IEDGE1*NITER) IF(ILENC+NK*ILEN1.GT.ILEN)GO TO 91 DO 36 K=1,NK DO 34 KK=1,ILEN1 JOLD1=JOLD1+JINCR*ILENC DO 28 I=1,KK DX(JNEW)=DX(JOLD1) JNEW=JNEW+1 JOLD1=JOLD1+JINCR 28 CONTINUE 34 CONTINUE ILENC=ILENC+ILEN1 36 CONTINUE 38 CONTINUE IF(ILENC.NE.ILEN)GO TO 91 40 CONTINUE END IF ELSE IF(IKEY.EQ.-44) THEN IOUT=IVLIST(1)+IV23 IF(DIMX(DIMPNT(IOUT)).EQ.0) GO TO 97 ILEN1=DIMX(DIMPNT(IOUT)+1) END IF END IF RETURN 90 CONTINUE WRITE(U6,100) GO TO 999 91 CONTINUE WRITE(U6,101) GO TO 999 93 CONTINUE WRITE(U6,103) GO TO 999 94 CONTINUE WRITE(U6,104) GO TO 999 97 CONTINUE WRITE(U6,107) GO TO 999 98 CONTINUE WRITE(U6,108) GO TO 999 99 CONTINUE WRITE(U6,109) GO TO 99 911 CONTINUE WRITE(U6,111) 999 CONTINUE IERROR=1 RETURN C C End of SUBROUTINE PBDIAG C END C SUBROUTINE PEIGEN(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(*) 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/ 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') C C IKEY = -35 peigenvector C = -36 peigenvalue C = -37 psqrt 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(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 IF(IVLIST(4).GT.0)GO TO 93 C C Check for PEIGENVECTOR,which produces paired outputs C IF(IKEY.EQ.-35) THEN IF(2*IVLIST(1).NE.IV23) GO TO 92 C C Check for PEIGENVALUE, PSQRT C ELSE IF(IVLIST(1).NE.IV23.AND. . (IKEY.NE.-37.OR.IVLIST(1).NE.0.OR.IVLIST(2).EQ.0))GO TO 92 END IF END IF C C End of full sample checks for number of variables C C INEW - index for first outcome variable C IOLD - index for packed matrix variable C INEW=IVLIST(1)+1 IOLD=1 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 JOLD - cell index for old operator C JNEW1 - cell index for first output C JNEW2 - cell index for second output (EIGENVECTOR) C IEDGE - leading edge of packed matrix C ILIST(1)=IOLD JOLD=DXPNT(IOLD) JNEW1=DXPNT(INEW) IF(IKEY.EQ.-35) THEN JNEW2=DXPNT(INEW+1) ELSE JNEW2=0 END IF NILIST=1 IF((MTYPE(IOLD).EQ.2.OR.MTYPE(IOLD).EQ.8).AND. . MTRAN(IOLD).EQ.0)GO TO 98 IF(DIMX(DIMPNT(IOLD)).EQ.0) THEN IEDGE=1 ELSE IEDGE=DIMX(DIMPNT(IOLD)+1) END IF C C For full sample, add new variable(s) to ILIST C IF(DID(1).EQ.0.) THEN ILIST(2)=INEW IF(IKEY.EQ.-35) THEN NILIST=3 ILIST(3)=INEW+1 ELSE NILIST=2 END IF END IF C C Loop to determine lengths C DO 10 I=1,NILIST J=ILIST(I) ISIZE(I)=MATSIZ(DIMX(DIMPNT(J)),MTYPE(J),MTRAN(J)) 10 CONTINUE ILEN=DSQRT(2.D0*DBLE(FLOAT(IEDGE))) C C Establish temporary storage - 3*ILEN in all cases, plus C ILEN*(ILEN+1) for PSQRT C NXPTDS=NXPTD IF(IKEY.EQ.-37) THEN I=ILEN*(ILEN+4) ELSE I=3*ILEN END IF CALL ROOMD(I) C C Full sample checks for sizes and dimensions of matrices C IF(IFIRST.EQ.1) THEN IF(MTYPE(INEW).EQ.2.OR.MTYPE(INEW).EQ.8)GO TO 98 C C Check that IEDGE is a valid value for a packed matrix C IF(ILEN*(ILEN+1).NE.2*IEDGE)GO TO 91 C C For PSQRT, check that size of first operator matches size of target. C IF(IKEY.EQ.-37) THEN IF(ISIZE(NILIST).NE.ISIZE(1)) GO TO 95 C C For PEIGENVALUE and PEIGENVECTOR, check that size of (first) output C matrix reflects space for eigenvalues. C ELSE IF(ILEN*ISIZE(1).NE.IEDGE*ISIZE(2))GO TO 97 C C Check dimension of second output matrix for PEIGENVECTOR. C IF(IKEY.EQ.-35) THEN IF(IEDGE*ISIZE(3).NE.ILEN*ILEN*ISIZE(1))GO TO 97 END IF END IF END IF C C End of full sample checks for sizes and dimensions of matrices. C C C IEDGE - increment for JOLD C JINCR1 - increment for JNEW1 C JINCR2 - increment for JNEW2 C JINCR2=0 IF(IKEY.EQ.-37) THEN JINCR1=IEDGE ELSE JINCR1=ILEN IF(IKEY.EQ.-35) THEN JINCR2=ILEN*ILEN END IF END IF DO 80 I=1,ISIZE(1),IEDGE INFO=0 DO 22 J=1,IEDGE IF(DABS(DX(JOLD+J-1)-MISSNG).LE..1D-06)INFO=-1 22 CONTINUE IF(INFO.EQ.0) THEN IF(IKEY.EQ.-35) THEN CALL DSPEV('V','U',ILEN,DX(JOLD),DX(JNEW1),DX(JNEW2),ILEN, . DX(NXPTDS),INFO) ELSE IF(IKEY.EQ.-36) THEN CALL DSPEV('N','U',ILEN,DX(JOLD),DX(JNEW1),DX(JNEW1),ILEN, . DX(NXPTDS),INFO) C rad=dsqrt((dx(jold)-dx(jold+2))**2+4.d0*dx(jold+1)*dx(jold+1)) C dx(jnew1)=(dx(jold)+dx(jold+2)+rad)/2.d0 C dx(jnew1+1)=(dx(jold)+dx(jold+2)-rad)/2.d0 ELSE K=NXPTDS+3*ILEN KK=K+ILEN CALL DSPEV('V','U',ILEN,DX(JOLD),DX(K),DX(KK),ILEN, . DX(NXPTDS),INFO) IF(INFO.EQ.0) THEN DO 24 J=1,ILEN IF(DX(K+J-1).GT.0) THEN DX(K+J-1)=DSQRT(DX(K+J-1)) ELSE IF(DX(K+J-1).LT.0) THEN INFO=-1 END IF 24 CONTINUE END IF IF(INFO.EQ.0) THEN DO 25 J=1,IEDGE DX(JNEW1+J-1)=0. 25 CONTINUE KK=KK-1 DO 40 L=1,ILEN CMULT=DX(K) II=JNEW1 DO 35 J=1,ILEN DO 30 JJ=1,J DX(II)=DX(II)+CMULT*DX(KK+J)*DX(KK+JJ) II=II+1 30 CONTINUE 35 CONTINUE K=K+1 KK=KK+ILEN 40 CONTINUE END IF END IF END IF IF(INFO.NE.0) THEN JNEWT=JNEW1 DO 78 J=1,JINCR1 DX(JNEWT)=MISSNG JNEWT=JNEWT+1 78 CONTINUE IF(IKEY.EQ.-37) THEN JNEWT=JNEW2 DO 79 J=1,JINCR2 DX(JNEWT)=MISSNG JNEWT=JNEWT+1 79 CONTINUE END IF END IF JNEW1=JNEW1+JINCR1 JNEW2=JNEW2+JINCR2 JOLD=JOLD+IEDGE 80 CONTINUE C C Increment IOLD, INEW C IOLD=IOLD+1 IF(IKEY.EQ.-35) THEN INEW=INEW+2 ELSE INEW=INEW+1 END IF NXPTD=NXPTDS GO TO 5 90 CONTINUE WRITE(U6,100) GO TO 99 91 CONTINUE WRITE(U6,101)IEDGE 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 97 CONTINUE WRITE(U6,107) GO TO 99 98 CONTINUE WRITE(U6,108) 99 CONTINUE IERROR=1 C C End of SUBROUTINE PEIGEN C RETURN END SUBROUTINE PSOLVE(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(*) 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/ 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 IKEY = -25 pinvert C = -26 psolve C = -27 pmultiplym C = -28 pmultiplyp C = -29 psymmultm C = -30 psymmultp C = -31 ppack C = -32 punpack C = -33 ptrace C = -34 pdiag 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 PSOLVE, PMULTIPLYM, PMULTIPLYP, PSYMMULTM, and PSYMMULTP, C which involve 2 operators C IF(IKEY.LE.-26.AND.IKEY.GE.-30) 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 PINVERT, PPACK, PUNPACK, PTRACE, PDIAG, which involve C 1 operator C ELSE IF(IVLIST(4).GT.0) THEN C C If CONSTANTS are given, then C 1) #OLD must=0 C 2) #new/MODIFY must=1 C IF(IVLIST(1).NE.0.OR.IV23.NE.1)GO TO 93 ELSE C C If no CONSTANTS, then: C 1) if #OLD >0, #OLD = #new/MODIFY C 2) if #OLD =0, #new=0 C IF((IVLIST(1).GT.0.AND.IVLIST(1).NE.IV23).OR. . (IVLIST(1).EQ.0.AND.IVLIST(3).GT.0)) GO TO 92 END IF END IF END IF C C End of full sample checks for number/type of variables 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 PSOLVE, PMULTIPLYM, PMULTIPLYP, PSYMMULTM, and PSYMMULTP C IF(IKEY.LE.-26.AND.IKEY.GE.-30) THEN C C IOLD2 is always the first old variable C IOLD2=1 C C If CONSTANTS, set IOLD1=0 C IF(IVLIST(4).GT.0) THEN IOLD1=0 ELSE C C If no CONSTANTS, IOLD1=2, regardless of whether this is an old, MODIFY, C or new variable. C IOLD1=2 END IF C C For PINVERT, PPACK, PUNPACK, PTRACE, PDIAG: C ELSE IOLD2=0 C C If CONSTANTS, set IOLD1=0 C IF(IVLIST(4).GT.0) THEN IOLD1=0 ELSE IOLD1=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 (actually, "second" operator is really primary packed C matrix in PSOLVE, PMULTIPLYM, etc.) C JNEW - cell index for output C IEDGE - leading edge of packed matrix C NPUSE - number of times "second" operator should be used in C looping through columns of "first" operator; >1 only C for PSOLVE, PMULTIPLYM, PSYMMMULTM; =1 otherwise. C ILIST(1)=IOLD1 IF(IOLD1.EQ.0) THEN JOLD1=IVLIST(4) ELSE JOLD1=DXPNT(IOLD1) END IF JNEW=DXPNT(INEW) C C For PSOLVE, PMULTIPLYM, PMULTIPLYP, PSYMMULTM, and PSYMMULTP C set values for the packed matrix (1st old variable) C IF(IKEY.LE.-26.AND.IKEY.GE.-30) THEN ILIST(2)=IOLD2 NILIST=2 JOLD2=DXPNT(IOLD2) IF((MTYPE(IOLD2).EQ.2.OR.MTYPE(IOLD2).EQ.8).AND. . MTRAN(IOLD2).EQ.0)GO TO 98 IF(DIMX(DIMPNT(IOLD2)).EQ.0) THEN IEDGE=1 ELSE IF(IVLIST(7).GT.0) THEN IF(IX(3).GT.0) THEN IEDGE=IX(3) ELSE IEDGE=DIMX(DIMPNT(IOLD2)+1) END IF ELSE IEDGE=DIMX(DIMPNT(IOLD2)+1) END IF C C For PSOLVE, PMULTIPLYM, PSYMMULTM, obtain column dimension of C M matrix, represented by IOLD1 C IF(IKEY.EQ.-26.OR.IKEY.EQ.-27.OR.IKEY.EQ.-29) THEN IF(IOLD1.EQ.0) THEN ILEN=DSQRT(2.D0*DBLE(FLOAT(IEDGE))) ICOL2=IVLIST(5)/ILEN IF(IVLIST(7).GT.0) THEN IF(IX(4).GT.0) THEN IF(IFIRST.EQ.1) THEN IF(ICOL2.NE.(ICOL2/IX(4))*IX(4))GO TO 911 END IF ICOL2=IX(4) END IF END IF ELSE IF(DIMX(DIMPNT(IOLD1)).LE.1) THEN ICOL2=1 ELSE ICOL2=DIMX(DIMPNT(IOLD1)+2) IF(IVLIST(7).GT.0) THEN IF(IX(4).GT.0) THEN IF(IFIRST.EQ.1) THEN IF(ICOL2.NE.(ICOL2/IX(4))*IX(4))GO TO 911 END IF ICOL2=IX(4) END IF END IF END IF END IF C C IEDGE2 - edge of output matrix for PSYMMULTM C IF(IKEY.EQ.-29) THEN IEDGE2=(ICOL2*(ICOL2+1))/2 END IF END IF C C Temporarily set INCR to 0, to be recomputed below C INCR=0 ELSE C C For PINVERT, PPACK, PUNPACK, PTRACE, PDIAG: C NILIST=1 JOLD2=0 IF(IOLD1.EQ.0) THEN IEDGE=IVLIST(5) ELSE IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD2).EQ.8).AND. . MTRAN(IOLD1).EQ.0)GO TO 98 IF(DIMX(DIMPNT(IOLD1)).EQ.0) THEN IEDGE=1 ELSE IEDGE=DIMX(DIMPNT(IOLD1)+1) END IF END IF INCR=IEDGE END IF C C For full sample, PPACK, PUNPACK, and PDIAG, add new variable to ILIST C IF(DID(1).EQ.0..OR.IKEY.EQ.-31.OR.IKEY.EQ.-32.OR.IKEY.EQ.-34) . 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 For PSOLVE, PMULTIPLYM, PMULTIPLYP, PSYMMULTM, and PSYMMULTP: C adjust lengths of array for MISSING or CROSSED REAL C IF(IKEY.LE.-26.AND.IKEY.GE.-30) THEN IF(IOLD1.GT.0) THEN IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND. . MTRAN(IOLD1).EQ.0) THEN ISIZE(1)=ISIZE(1)/2 END IF END IF END IF C C For PPACK, PUNPACK, and PDIAG, redefine IEDGE on the basis of matrix C size. C IF(IKEY.EQ.-31.OR.IKEY.EQ.-32.OR.IKEY.EQ.-34) THEN IF( ((IKEY.EQ.-31.OR.IKEY.EQ.-32).AND.ISIZE(1).GT.ISIZE(2)) . .OR.(IKEY.EQ.-34.AND.ISIZE(2).GT.ISIZE(1))) THEN IF(DIMX(DIMPNT(INEW)).EQ.0) THEN IEDGE=1 ELSE IEDGE=DIMX(DIMPNT(INEW)+1) END IF ILEN=DSQRT(2.D0*DBLE(FLOAT(IEDGE))) C C Redefinition of INCR here. C IF(IKEY.EQ.-31.OR.IKEY.EQ.-32) THEN INCR=ILEN*ILEN ELSE INCR=ILEN END IF END IF END IF ILEN=DSQRT(2.D0*DBLE(FLOAT(IEDGE))) C C Full sample checks for sizes and dimensions of matrices C IF(IFIRST.EQ.1) THEN C C For PINVERT, PSOLVE, PMULTIPYM, and PSYMMULTP, C check that size of first operator matches size of target, unless C REAL with MISSING or CROSSED REAL are involved. C IF((IKEY.LE.-25.AND.IKEY.GE.-27).OR.IKEY.EQ.-30) THEN IF(ISIZE(NILIST).NE.ISIZE(1)) GO TO 95 C C For PMULTIPLYP, check that output size reflects a square matrix of C correct size C ELSE IF(IKEY.EQ.-28) THEN IF(ILEN*ILEN*ISIZE(1).NE.IEDGE*ISIZE(NILIST))GO TO 95 C C Check dimensions for PSYMMULTM C ELSE IF(IKEY.EQ.-29) THEN IF(IEDGE2*ISIZE(1).NE.ICOL2*ILEN*ISIZE(NILIST))GO TO 97 C C Check dimensions for PPACK, PUNPACK C ELSE IF(IKEY.EQ.-31.OR.IKEY.EQ.-32) THEN IF(ISIZE(1).GT.ISIZE(2)) THEN IF(IEDGE*ISIZE(1).NE.ILEN*ILEN*ISIZE(2))GO TO 97 ELSE IF(ILEN*ILEN*ISIZE(1).NE.IEDGE*ISIZE(2))GO TO 97 END IF C C Check dimensions for PTRACE C ELSE IF(IKEY.EQ.-33) THEN IF(ISIZE(1).NE.IEDGE*ISIZE(2))GO TO 95 C C Check dimensions for PDIAG C ELSE IF(IKEY.EQ.-34) THEN IF(ISIZE(1).GT.ISIZE(2)) THEN IF(ILEN*ISIZE(1).NE.IEDGE*ISIZE(2)) GO TO 95 ELSE IF(IEDGE*ISIZE(1).NE.ILEN*ISIZE(2)) GO TO 95 END IF END IF IF(MTYPE(INEW).EQ.2.OR.MTYPE(INEW).EQ.8)GO TO 98 C C Check that IEDGE is a valid value for a packed matrix C IF(ILEN*(ILEN+1).NE.2*IEDGE)GO TO 91 C C Check that the dimensions of the matrices appear appropriate C IF(ILEN.GT.1) THEN C C For PSOLVE, PMULTIPLYM, PMULTIPLYP, and PSYMMULTM C IF(IKEY.LE.-26.AND.IKEY.GE.-29) THEN IF(IKEY.EQ.-28) THEN IF(IEDGE*(ISIZE(1)/IEDGE).NE.ISIZE(1))GO TO 97 ELSE IF(ILEN*(ISIZE(1)/ILEN).NE.ISIZE(1))GO TO 97 END IF J=1 IF(DIMX(DIMPNT(INEW)).GT.0.AND.ICOL2.NE.1) THEN DO 12 I=DIMPNT(INEW)+1,DIMPNT(INEW)+DIMX(DIMPNT(INEW)) J=J*DIMX(I) IF(IKEY.EQ.-29) THEN IF(J.EQ.IEDGE2) THEN GO TO 13 ELSE IF(J.GT.IEDGE2) THEN GO TO 97 END IF ELSE IF(J.EQ.ILEN) THEN IF(IKEY.EQ.-28) THEN IF(ITEMP.EQ.0) THEN ITEMP=1 J=1 ELSE GO TO 13 END IF ELSE GO TO 13 END IF ELSE IF(J.GT.ILEN) THEN GO TO 97 END IF END IF 12 CONTINUE GO TO 97 13 CONTINUE END IF IF(IOLD1.GT.0) THEN J=1 DO 14 I=DIMPNT(IOLD1)+1,DIMPNT(IOLD1)+DIMX(DIMPNT(IOLD1)) IF(I.EQ.DIMPNT(IOLD1)+1) THEN IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND. . MTRAN(IOLD1).EQ.0) GO TO 14 END IF J=J*DIMX(I) IF(IKEY.EQ.-28) THEN IF(J.EQ.IEDGE) THEN GO TO 15 ELSE IF(J.GT.IEDGE) THEN GO TO 97 END IF ELSE IF(J.EQ.ILEN) THEN GO TO 15 ELSE IF(J.GT.ILEN) THEN GO TO 97 END IF END IF 14 CONTINUE GO TO 97 15 CONTINUE END IF ELSE IF(IKEY.EQ.-30) THEN C C For PSYMMULTP C IF(IEDGE*(ISIZE(1)/IEDGE).NE.ISIZE(1))GO TO 97 J=1 DO 17 I=DIMPNT(INEW)+1,DIMPNT(INEW)+DIMX(DIMPNT(INEW)) J=J*DIMX(I) IF(J.EQ.IEDGE) THEN GO TO 18 ELSE IF(J.GT.IEDGE) THEN GO TO 97 END IF 17 CONTINUE GO TO 97 18 CONTINUE IF(IOLD1.GT.0) THEN J=1 DO 19 I=DIMPNT(IOLD1)+1,DIMPNT(IOLD1)+DIMX(DIMPNT(IOLD1)) IF(I.EQ.DIMPNT(IOLD1)+1) THEN IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND. . MTRAN(IOLD1).EQ.0) GO TO 19 END IF J=J*DIMX(I) IF(J.EQ.IEDGE) THEN GO TO 20 ELSE IF(J.GT.IEDGE) THEN GO TO 97 END IF 19 CONTINUE GO TO 97 20 CONTINUE END IF END IF END IF END IF C C End of full sample checks for sizes and dimensions of matrices. 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)/IEDGE) C C Determine NPUSE here C IF(IKEY.LE.-26.AND.IKEY.GE.-30) THEN IF(IKEY.EQ.-26.OR.IKEY.EQ.-27.OR.IKEY.EQ.-29) THEN NPUSE=INCR/(ILEN*ICOL2) C C At this point, allow alternative ICOL2=1 if that works. C IF(NPUSE.EQ.0) THEN IF(IVLIST(7).EQ.0) THEN ICOL2=1 NPUSE=INCR/ILEN ELSE IF(IX(4).EQ.0) THEN ICOL2=1 NPUSE=INCR/ILEN END IF END IF ELSE NPUSE=INCR/IEDGE END IF IF(IFIRST.EQ.1) THEN IF(INCR.NE.(INCR/NPUSE)*NPUSE)GO TO 95 END IF ELSE NPUSE=1 END IF C C JINCR - increment for JOLD1 C JINCR2 - increment for JNEW C IF((IKEY.LE.-25.AND.IKEY.GE.-27).OR.IKEY.EQ.-30) THEN JINCR2=INCR/NPUSE ELSE IF(IKEY.EQ.-28) THEN JINCR2=ILEN*ILEN ELSE IF(IKEY.EQ.-29) THEN JINCR2=IEDGE2 ELSE IF(IKEY.EQ.-31.OR.IKEY.EQ.-32) THEN IF(ISIZE(1).GT.ISIZE(2)) THEN JINCR2=IEDGE ELSE JINCR2=ILEN*ILEN END IF ELSE IF(IKEY.EQ.-33) THEN JINCR2=1 ELSE IF(IKEY.EQ.-34) THEN IF(ISIZE(1).GT.ISIZE(2)) THEN JINCR2=ILEN ELSE JINCR2=IEDGE END IF END IF IF((MTYPE(IOLD1).EQ.2.OR.MTYPE(IOLD1).EQ.8).AND.MTRAN(IOLD1).EQ.0) . THEN JINCR=2 ELSE JINCR=1 END IF C INCRN=INCR/NPUSE DO 80 I=1,ISIZE(1),INCR DO 79 IPUSE=1,NPUSE INFO=0 IF(IKEY.LE.-26.AND.IKEY.GE.-30) THEN DO 22 J=1,IEDGE IF(DABS(DX(JOLD2+J-1)-MISSNG).LE..1D-06)INFO=-1 22 CONTINUE END IF IF(INFO.EQ.0) THEN JOLD1T=JOLD1 DO 24 J=1,INCRN IF(DABS(DX(JOLD1T)-MISSNG).LE..1D-06)INFO=-1 JOLD1T=JOLD1T+JINCR 24 CONTINUE END IF IF(INFO.EQ.0) THEN IF(IKEY.EQ.-25.OR.IKEY.EQ.-26) THEN IF(JNEW.NE.JOLD1) THEN JNEWT=JNEW JOLD1T=JOLD1 DO 26 J=1,INCRN DX(JNEWT)=DX(JOLD1T) JNEWT=JNEWT+1 JOLD1T=JOLD1T+JINCR 26 CONTINUE END IF IF(IKEY.EQ.-26) THEN IF(IPUSE.EQ.1) THEN CALL DPPTRF('U',ILEN,DX(JOLD2),INFO) END IF ELSE CALL DPPTRF('U',ILEN,DX(JNEW),INFO) END IF IF(INFO.EQ.0) THEN IF(IKEY.EQ.-26) THEN CALL DPPTRS('U',ILEN,ICOL2,DX(JOLD2),DX(JNEW),ILEN,INFO) ELSE CALL DPPTRI('U',ILEN,DX(JNEW),INFO) END IF END IF ELSE IF(IKEY.LE.-27.AND.IKEY.GE.-30) THEN NXPTDS=NXPTD IF(JNEW.EQ.JOLD1.OR.JINCR.EQ.2) THEN CALL ROOMD(INCRN) JNEWT=NXPTDS JOLD1T=JOLD1 DO 32 J=1,INCRN DX(JNEWT)=DX(JOLD1T) JNEWT=JNEWT+1 JOLD1T=JOLD1T+JINCR 32 CONTINUE JOLD1T=NXPTDS ELSE JOLD1T=JOLD1 END IF IF(IKEY.EQ.-27) THEN CALL DSPMM('U','N',ILEN,ICOL2,1.D0,DX(JOLD2),DX(JOLD1T), . ILEN,0.0D0,DX(JNEW),ILEN) ELSE IF(IKEY.EQ.-28) THEN CALL DSPMP('U',ILEN,1.D0,DX(JOLD2),DX(JOLD1T),0.0D0, . DX(JNEW),ILEN) ELSE ITEMP=NXPTD IF(IKEY.EQ.-29) THEN J=ILEN*ICOL2+ICOL2*ICOL2 ELSE J=2*ILEN*ILEN END IF CALL ROOMD(J) JNEWT=JNEW IF(IKEY.EQ.-29) THEN CALL DSPMM('U','N',ILEN,ICOL2,1.D0,DX(JOLD2),DX(JOLD1T), . ILEN,0.0D0,DX(ITEMP),ILEN) ITEMP2=ITEMP+ILEN*ICOL2 CALL DGEMM('T','N',ICOL2,ICOL2,ILEN,1.0D0,DX(JOLD1T), . ILEN,DX(ITEMP),ILEN,0.0D0,DX(ITEMP2),ICOL2) ILEN2=ICOL2 ELSE CALL DSPMP('U',ILEN,1.D0,DX(JOLD2),DX(JOLD1T),0.0D0, . DX(ITEMP),ILEN) ITEMP2=ITEMP+ILEN*ILEN CALL DSPMM('U','N',ILEN,ILEN,1.D0,DX(JOLD1T),DX(ITEMP), . ILEN,0.0D0,DX(ITEMP2),ILEN) ILEN2=ILEN END IF DO 36 J1=1,ILEN2 DO 34 J2=1,J1 DX(JNEWT)=DX(ITEMP2) ITEMP2=ITEMP2+1 JNEWT=JNEWT+1 34 CONTINUE ITEMP2=ITEMP2+ILEN2-J1 36 CONTINUE END IF NXPTD=NXPTDS ELSE IF(IKEY.EQ.-31.OR.IKEY.EQ.-32) THEN JNEWT=JNEW ITEMP=JOLD1 IF(ISIZE(1).GT.ISIZE(2)) THEN DO 48 J1=1,ILEN DO 46 J2=1,J1 DX(JNEWT)=DX(ITEMP) ITEMP=ITEMP+1 JNEWT=JNEWT+1 46 CONTINUE ITEMP=ITEMP+ILEN-J1 48 CONTINUE ELSE DO 54 J1=1,ILEN DO 52 J2=1,J1 DX(JNEWT)=DX(ITEMP) ITEMP=ITEMP+1 JNEWT=JNEWT+1 52 CONTINUE JNEWT=JNEWT+ILEN-J1 54 CONTINUE IF(ILEN.GT.1) THEN JNEWT=JNEW+1 DO 58 J1=1,ILEN ITEMP=JOLD1+(J1*(J1+1))/2+J1-1 DO 56 J2=J1+1,ILEN DX(JNEWT)=DX(ITEMP) JNEWT=JNEWT+1 ITEMP=ITEMP+J2 56 CONTINUE JNEWT=JNEWT+J1+1 58 CONTINUE END IF END IF ELSE IF(IKEY.EQ.-33) THEN DX(JNEW)=DX(JOLD1) IF(ILEN.GT.1) THEN ITEMP=JOLD1+2 DO 62 J1=2,ILEN DX(JNEW)=DX(JNEW)+DX(ITEMP) ITEMP=ITEMP+J1+1 62 CONTINUE END IF ELSE IF(IKEY.EQ.-34) THEN JNEWT=JNEW ITEMP=JOLD1 IF(ISIZE(1).GT.ISIZE(2)) THEN DO 64 J1=1,ILEN DX(JNEWT)=DX(ITEMP) JNEWT=JNEWT+1 ITEMP=ITEMP+J1+1 64 CONTINUE ELSE DX(JNEWT)=DX(ITEMP) JNEWT=JNEWT+1 ITEMP=ITEMP+1 IF(ILEN.GT.1) THEN DO 68 J1=2,ILEN DO 66 J2=1,J1-1 DX(JNEWT)=0.D0 JNEWT=JNEWT+1 66 CONTINUE DX(JNEWT)=DX(ITEMP) ITEMP=ITEMP+1 JNEWT=JNEWT+1 68 CONTINUE END IF END IF END IF END IF IF(INFO.NE.0) THEN JNEWT=JNEW DO 78 J=1,JINCR2 DX(JNEWT)=MISSNG JNEWT=JNEWT+1 78 CONTINUE END IF JNEW=JNEW+JINCR2 JOLD1=JOLD1+INCRN*JINCR 79 CONTINUE IF(JOLD2.GT.0)JOLD2=JOLD2+IEDGE 80 CONTINUE C C Increment IOLD1, INEW C IOLD1=IOLD1+1 INEW=INEW+1 GO TO 5 90 CONTINUE WRITE(U6,100) GO TO 99 91 CONTINUE WRITE(U6,101)IEDGE 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 97 CONTINUE WRITE(U6,107) GO TO 99 98 CONTINUE WRITE(U6,108) GO TO 99 911 CONTINUE WRITE(U6,111) 99 CONTINUE IERROR=1 RETURN C C End of SUBROUTINE PSOLVE C END C SUBROUTINE HADAMG IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (MSIZED=1000000) PARAMETER (MAXIDS=10) PARAMETER (IXFLLD=5) 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 /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 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) C INTEGER IRPOLY(3) C 202 FORMAT(' HADAMARD SIZE NOT OFFERED') C IF(NHADAM.EQ.0) THEN SDHADM=0 RETURN END IF SDHADM=NXPTD I=NHADAM*NHADAM CALL ROOMD(I) K=NHADAM 22 CONTINUE IF(K.EQ.2*(K/2).AND.K.NE.0) THEN K=K/2 GO TO 22 END IF IF(K.EQ.1) THEN DX(SDHADM)=1.D0 DX(SDHADM+1)=1.D0 DX(SDHADM+2)=1.D0 DX(SDHADM+3)=-1.D0 K=2 ELSE C C Unable to provide replicates for 92, 116, 156, 172, or 184 C IF(NHADAM/K.LT.4.OR.K.GT.50.OR.K.EQ.23.OR.K.EQ.29.OR. . K.EQ.39.OR.K.EQ.43) THEN WRITE(U6,202) GO TO 99 END IF C C Special rule for multiples of 48, to preserve method used in C 1987 replicate variances, based on 4k = p + 1 for k=12 C IF(K.EQ.3) THEN IF(NHADAM/K.GE.16)K=12 C C Special rule for multiples of 72, to furnish an initial row of C 1's through 4k = p + 1 C ELSE IF(K.EQ.9) THEN IF(NHADAM/K.GE.8)K=18 C C Special rule for multiples of 104, to furnish an initial row of C 1's through 4k = p + 1 C ELSE IF(K.EQ.13) THEN IF(NHADAM/K.GE.8)K=26 C C Special rule for multiples of 152, to furnish an initial row of C 1's through 4k = p + 1 C ELSE IF(K.EQ.19) THEN IF(NHADAM/K.GE.8)K=38 END IF IF(K.NE.7.AND.K.NE.13.AND.K.NE.25) THEN C C For 36, 76, 124, 148, 184, or 196, must use 4k = 2 (p + 1) C IF(K.EQ.9.OR.K.EQ.19.OR.K.EQ.31.OR.K.EQ.37.OR.K.EQ.46.OR. . K.EQ.49) THEN I=4*K*K SDVPIN=NXPTD CALL ROOMD(I) IPRIME=2*K-1 ELSE C C In most cases, using 4k = p + 1 C SDVPIN=SDHADM IPRIME=4*K-1 END IF ISD=NXPTD CALL ROOMD(IPRIME) I=IPRIME+1 CALL METHD1(DX(SDVPIN),I,DX(ISD)) NXPTD=ISD C C For 52, 100, and 200, using 4k = 2 ( p**2 + 1) C ELSE IF(K.EQ.13.OR.K.EQ.25) THEN SDVPIN=NXPTD I=4*K*K CALL ROOMD(I) IF(K.EQ.13) THEN IPRIME=5 IRPOLY(2)=1 IRPOLY(1)=2 ELSE IPRIME=7 IRPOLY(2)=3 IRPOLY(1)=1 END IF I=2*K-1 ISD=NXPTD CALL ROOMD(I) I=K*2 CALL METHD2(IPRIME,DX(SDVPIN),I,DX(ISD),IRPOLY) NXPTD=ISD C C For 28, using 4k = p**3 + 1 C ELSE IPRIME=3 I=4*K-1 ISD=NXPTD CALL ROOMD(I) IRPOLY(3)=0 IRPOLY(2)=2 IRPOLY(1)=1 I=4*K CALL METHD3(IPRIME,DX(SDHADM),I,DX(ISD),IRPOLY) NXPTD=ISD END IF IF(K.EQ.9.OR.K.EQ.13.OR.K.EQ.19.OR.K.EQ.25.OR. . K.EQ.31.OR.K.EQ.37.OR.K.EQ.49) THEN IPRIME=K*2 IW=4*K L=SDVPIN J1=SDHADM DO 25 J=1,IPRIME DO 24 I=1,IPRIME IF(I.EQ.J) THEN DX(J1)=1.D0 DX(J1+1)=-1.D0 DX(J1+IW)=-1.D0 DX(J1+IW+1)=-1.D0 ELSE IF(DX(L).GT.0.) THEN DX(J1)=1.D0 DX(J1+1)=1.D0 DX(J1+IW)=1.D0 DX(J1+IW+1)=-1.D0 ELSE DX(J1)=-1.D0 DX(J1+1)=-1.D0 DX(J1+IW)=-1.D0 DX(J1+IW+1)=1.D0 END IF L=L+1 J1=J1+2 24 CONTINUE J1=J1+IW 25 CONTINUE NXPTD=SDVPIN END IF K=K*4 END IF 27 CONTINUE IF(K.LT.NHADAM) THEN CALL DDBLE(DX(SDHADM),K) GO TO 27 END IF RETURN 99 CONTINUE CALL FSTOP END SUBROUTINE DDBLE(DX,N) DOUBLE PRECISION DX(*) J1=2*N*N+1 J2=J1+N K=1 DO 10 I=1,N DO 5 J=1,N DX(J1)=DX(K) DX(J2)=-DX(K) J1=J1+1 J2=J2+1 K=K+1 5 CONTINUE J1=J1+N J2=J2+N 10 CONTINUE J1=1 J2=N+1 K=2*N*N+1 DO 20 I=1,N DO 15 J=1,N DX(J1)=DX(K) DX(J2)=DX(K) J1=J1+1 J2=J2+1 K=K+1 15 CONTINUE J1=J1+N J2=J2+N K=K+N 20 CONTINUE N=2*N RETURN END SUBROUTINE METHD1(DX,K,D) DOUBLE PRECISION DX(K,K),D(*) C C GENERATION OF HADAMARD MATRIX OF ORDER K=4T, C WHERE K=IPRIME+1, WITH IPRIME A PRIME NUMBER C FOR EXAMPLE, IPRIME=47 IS USED TO GENERATE THE C HADAMARD MATRIX OF ORDER 48 C C C FIRST, FIND ALL PERFECT SQUARES, MOD IPRIME C D(I+1) WILL CONTAIN 1 IF I IS A PERFECT SQUARE, -1 OTHERWISE C IPRIME=K-1 DO 1 I=1,IPRIME D(I)=-1.D0 1 CONTINUE DO 10 J=0,IPRIME-1 IC=J*J IC=MOD(IC,IPRIME) D(IC+1)=1.D0 10 CONTINUE C C NEXT, PLACE 1'S IN THE FIRST ROWS AND COLUMNS OF DX C PLACE -1 ALONG THE REST OF THE MAIN DIAGONAL C DX(1,1)=1.D0 DO 20 I=2,K DX(I,1)=1.D0 DX(1,I)=1.D0 DX(I,I)=-1.D0 20 CONTINUE C C NEXT, COMPLETE DX BY ASSIGNING +1 IF J-I IS A PERFECT C SQUARE, -1 OTHERWISE C DO 30 I=2,K DO 29 J=2,K IF(I.NE.J) THEN L=MOD(J-I+IPRIME,IPRIME) DX(I,J)=D(L+1) END IF 29 CONTINUE 30 CONTINUE RETURN END SUBROUTINE METHD2(IPRIME,DX,KX,D,IRPOLY) INTEGER A(2),B(2),C(2),IRPOLY(2) DOUBLE PRECISION DX(KX,KX),D(*) IP2=IPRIME*IPRIME DO 1 I=1,IP2 1 D(I)=-1.D0 DO 10 J=0,IPRIME-1 A(2)=J DO 9 I=0,IPRIME-1 A(1)=I CALL MULT2(IPRIME,A,A,C,IRPOLY) INDEX=IPRIME*C(2)+C(1)+1 D(INDEX)=1.D0 9 CONTINUE 10 CONTINUE DX(1,1)=1.D0 DO 12 I=2,KX DX(I,I)=-1.D0 DX(I,1)=1.D0 DX(1,I)=1.D0 12 CONTINUE DO 20 J=0,IPRIME-1 A(2)=J DO 19 I=0,IPRIME-1 A(1)=I DO 18 L=J,IPRIME-1 B(2)=L DO 17 K=0,IPRIME-1 IF(L.EQ.J.AND.K.LE.I) GO TO 17 B(1)=K C(2)=MOD(A(2)-B(2)+IPRIME,IPRIME) C(1)=MOD(A(1)-B(1)+IPRIME,IPRIME) INDEX=IPRIME*C(2)+C(1)+1 I1=A(1)+IPRIME*A(2)+2 I2=B(1)+IPRIME*B(2)+2 DX(I1,I2)=D(INDEX) DX(I2,I1)=D(INDEX) 17 CONTINUE 18 CONTINUE 19 CONTINUE 20 CONTINUE RETURN END SUBROUTINE MULT2(IPRIME,A,B,C,IRPOLY) INTEGER A(2),B(2),C(2),IRPOLY(2),C3 C(1)=MOD(A(1)*B(1),IPRIME) C(2)=MOD(A(1)*B(2)+A(2)*B(1),IPRIME) C3=MOD(A(2)*B(2),IPRIME) IF(C3.EQ.0)RETURN C(2)=MOD(IRPOLY(2)*(IPRIME-C3)+C(2),IPRIME) C(1)=MOD(IRPOLY(1)*(IPRIME-C3)+C(1),IPRIME) RETURN END SUBROUTINE METHD3(IPRIME,DX,KX,D,IRPOLY) INTEGER A(3),B(3),C(3),IRPOLY(3) DOUBLE PRECISION DX(KX,KX),D(*) IP2=IPRIME*IPRIME IP3=IPRIME*IP2 DO 1 I=1,IP3 1 D(I)=-1.D0 DO 11 K=0,IPRIME-1 A(3)=K DO 10 J=0,IPRIME-1 A(2)=J DO 9 I=0,IPRIME-1 A(1)=I CALL MULT3(IPRIME,A,A,C,IRPOLY) INDEX=IP2*C(3)+IPRIME*C(2)+C(1)+1 D(INDEX)=1.D0 9 CONTINUE 10 CONTINUE 11 CONTINUE DX(1,1)=1.D0 DO 12 I=2,KX DX(I,I)=-1.D0 DX(I,1)=1.D0 DX(1,I)=1.D0 12 CONTINUE DO 21 K=0,IPRIME-1 A(3)=K DO 20 J=0,IPRIME-1 A(2)=J DO 19 I=0,IPRIME-1 A(1)=I DO 18 K1=0,IPRIME-1 B(3)=K1 DO 17 J1=0,IPRIME-1 B(2)=J1 DO 16 II=0,IPRIME-1 IF(K.EQ.K1.AND.J.EQ.J1.AND.II.EQ.I)GO TO 16 B(1)=II C(3)=MOD(A(3)-B(3)+IPRIME,IPRIME) C(2)=MOD(A(2)-B(2)+IPRIME,IPRIME) C(1)=MOD(A(1)-B(1)+IPRIME,IPRIME) INDEX=IP2*C(3)+IPRIME*C(2)+C(1)+1 I1=A(1)+IPRIME*A(2)+IP2*A(3)+2 I2=B(1)+IPRIME*B(2)+IP2*B(3)+2 DX(I1,I2)=D(INDEX) 16 CONTINUE 17 CONTINUE 18 CONTINUE 19 CONTINUE 20 CONTINUE 21 CONTINUE RETURN END SUBROUTINE MULT3(IPRIME,A,B,C,IRPOLY) INTEGER A(3),B(3),C(3),IRPOLY(3),C4,C5 C(1)=MOD(A(1)*B(1),IPRIME) C(2)=MOD(A(1)*B(2)+A(2)*B(1),IPRIME) C(3)=MOD(A(1)*B(3)+A(2)*B(2)+A(3)*B(1),IPRIME) C4=MOD(A(2)*B(3)+A(3)*B(2),IPRIME) C5=MOD(A(3)*B(3),IPRIME) IF(C5.EQ.0.AND.C4.EQ.0)RETURN C4=MOD(IRPOLY(3)*(IPRIME-C5)+C4,IPRIME) C(3)=MOD(IRPOLY(2)*(IPRIME-C5)+C(3),IPRIME) C(2)=MOD(IRPOLY(1)*(IPRIME-C5)+C(2),IPRIME) IF(C4.EQ.0)RETURN C(3)=MOD(IRPOLY(3)*(IPRIME-C4)+C(3),IPRIME) C(2)=MOD(IRPOLY(2)*(IPRIME-C4)+C(2),IPRIME) C(1)=MOD(IRPOLY(1)*(IPRIME-C4)+C(1),IPRIME) RETURN END SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) C C constant times a vector plus a vector. C uses unrolled loops for increments equal to one. C jack dongarra, linpack, 3/11/78. C DOUBLE PRECISION DX(1),DY(1),DA INTEGER I,INCX,INCY,IX,IY,M,MP1,N C IF(N.LE.0)RETURN IF (DA .EQ. 0.0D0) RETURN IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 C C code for unequal increments or equal increments C not equal to 1 C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DY(IY) = DY(IY) + DA*DX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C code for both increments equal to 1 C C C clean-up loop C 20 M = MOD(N,4) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DY(I) = DY(I) + DA*DX(I) 30 CONTINUE IF( N .LT. 4 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,4 DY(I) = DY(I) + DA*DX(I) DY(I + 1) = DY(I + 1) + DA*DX(I + 1) DY(I + 2) = DY(I + 2) + DA*DX(I + 2) DY(I + 3) = DY(I + 3) + DA*DX(I + 3) 50 CONTINUE RETURN END DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) C C forms the dot product of two vectors. C uses unrolled loops for increments equal to one. C jack dongarra, linpack, 3/11/78. C DOUBLE PRECISION DX(*),DY(*),DTEMP INTEGER I,INCX,INCY,IX,IY,M,MP1,N C DDOT = 0.0D0 DTEMP = 0.0D0 IF(N.LE.0)RETURN IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 C C code for unequal increments or equal increments C not equal to 1 C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DTEMP = DTEMP + DX(IX)*DY(IY) IX = IX + INCX IY = IY + INCY 10 CONTINUE DDOT = DTEMP RETURN C C code for both increments equal to 1 C C C clean-up loop C 20 M = MOD(N,5) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DTEMP = DTEMP + DX(I)*DY(I) 30 CONTINUE IF( N .LT. 5 ) GO TO 60 40 MP1 = M + 1 DO 50 I = MP1,N,5 DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) + * DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) 50 CONTINUE 60 DDOT = DTEMP RETURN END SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) C .. Scalar Arguments .. CHARACTER*1 TRANSA, TRANSB INTEGER M, N, K, LDA, LDB, LDC DOUBLE PRECISION ALPHA, BETA C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) C .. C C Purpose C ======= C C DGEMM performs one of the matrix-matrix operations C C C := alpha*op( A )*op( B ) + beta*C, C C where op( X ) is one of C C op( X ) = X or op( X ) = X', C C alpha and beta are scalars, and A, B and C are matrices, with op( A ) C an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. C C Parameters C ========== C C TRANSA - CHARACTER*1. C On entry, TRANSA specifies the form of op( A ) to be used in C the matrix multiplication as follows: C C TRANSA = 'N' or 'n', op( A ) = A. C C TRANSA = 'T' or 't', op( A ) = A'. C C TRANSA = 'C' or 'c', op( A ) = A'. C C Unchanged on exit. C C TRANSB - CHARACTER*1. C On entry, TRANSB specifies the form of op( B ) to be used in C the matrix multiplication as follows: C C TRANSB = 'N' or 'n', op( B ) = B. C C TRANSB = 'T' or 't', op( B ) = B'. C C TRANSB = 'C' or 'c', op( B ) = B'. C C Unchanged on exit. C C M - INTEGER. C On entry, M specifies the number of rows of the matrix C op( A ) and of the matrix C. M must be at least zero. C Unchanged on exit. C C N - INTEGER. C On entry, N specifies the number of columns of the matrix C op( B ) and the number of columns of the matrix C. N must be C at least zero. C Unchanged on exit. C C K - INTEGER. C On entry, K specifies the number of columns of the matrix C op( A ) and the number of rows of the matrix op( B ). K must C be at least zero. C Unchanged on exit. C C ALPHA - DOUBLE PRECISION. C On entry, ALPHA specifies the scalar alpha. C Unchanged on exit. C C A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is C k when TRANSA = 'N' or 'n', and is m otherwise. C Before entry with TRANSA = 'N' or 'n', the leading m by k C part of the array A must contain the matrix A, otherwise C the leading k by m part of the array A must contain the C matrix A. C Unchanged on exit. C C LDA - INTEGER. C On entry, LDA specifies the first dimension of A as declared C in the calling (sub) program. When TRANSA = 'N' or 'n' then C LDA must be at least max( 1, m ), otherwise LDA must be at C least max( 1, k ). C Unchanged on exit. C C B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is C n when TRANSB = 'N' or 'n', and is k otherwise. C Before entry with TRANSB = 'N' or 'n', the leading k by n C part of the array B must contain the matrix B, otherwise C the leading n by k part of the array B must contain the C matrix B. C Unchanged on exit. C C LDB - INTEGER. C On entry, LDB specifies the first dimension of B as declared C in the calling (sub) program. When TRANSB = 'N' or 'n' then C LDB must be at least max( 1, k ), otherwise LDB must be at C least max( 1, n ). C Unchanged on exit. C C BETA - DOUBLE PRECISION. C On entry, BETA specifies the scalar beta. When BETA is C supplied as zero then C need not be set on input. C Unchanged on exit. C C C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). C Before entry, the leading m by n part of the array C must C contain the matrix C, except when beta is zero, in which C case C need not be set on entry. C On exit, the array C is overwritten by the m by n matrix C ( alpha*op( A )*op( B ) + beta*C ). C C LDC - INTEGER. C On entry, LDC specifies the first dimension of C as declared C in the calling (sub) program. LDC must be at least C max( 1, m ). C Unchanged on exit. C C C Level 3 Blas routine. C C -- Written on 8-February-1989. C Jack Dongarra, Argonne National Laboratory. C Iain Duff, AERE Harwell. C Jeremy Du Croz, Numerical Algorithms Group Ltd. C Sven Hammarling, Numerical Algorithms Group Ltd. C C C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Local Scalars .. LOGICAL NOTA, NOTB INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB DOUBLE PRECISION TEMP C .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. C .. Executable Statements .. C C Set NOTA and NOTB as true if A and B respectively are not C transposed and set NROWA, NCOLA and NROWB as the number of rows C and columns of A and the number of rows of B respectively. C NOTA = LSAME( TRANSA, 'N' ) NOTB = LSAME( TRANSB, 'N' ) IF( NOTA )THEN NROWA = M NCOLA = K ELSE NROWA = K NCOLA = M END IF IF( NOTB )THEN NROWB = K ELSE NROWB = N END IF C C Test the input parameters. C INFO = 0 IF( ( .NOT.NOTA ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTB ).AND. $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN INFO = 2 ELSE IF( M .LT.0 )THEN INFO = 3 ELSE IF( N .LT.0 )THEN INFO = 4 ELSE IF( K .LT.0 )THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 8 ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN INFO = 10 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 13 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DGEMM ', INFO ) RETURN END IF C C Quick return if possible. C IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN C C And if alpha.eq.zero. C IF( ALPHA.EQ.ZERO )THEN IF( BETA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, M C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE END IF RETURN END IF C C Start the operations. C IF( NOTB )THEN IF( NOTA )THEN C C Form C := alpha*A*B + beta*C. C DO 90, J = 1, N IF( BETA.EQ.ZERO )THEN DO 50, I = 1, M C( I, J ) = ZERO 50 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 60, I = 1, M C( I, J ) = BETA*C( I, J ) 60 CONTINUE END IF DO 80, L = 1, K IF( B( L, J ).NE.ZERO )THEN TEMP = ALPHA*B( L, J ) DO 70, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 70 CONTINUE END IF 80 CONTINUE 90 CONTINUE ELSE C C Form C := alpha*A'*B + beta*C C DO 120, J = 1, N DO 110, I = 1, M TEMP = ZERO DO 100, L = 1, K TEMP = TEMP + A( L, I )*B( L, J ) 100 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 110 CONTINUE 120 CONTINUE END IF ELSE IF( NOTA )THEN C C Form C := alpha*A*B' + beta*C C DO 170, J = 1, N IF( BETA.EQ.ZERO )THEN DO 130, I = 1, M C( I, J ) = ZERO 130 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 140, I = 1, M C( I, J ) = BETA*C( I, J ) 140 CONTINUE END IF DO 160, L = 1, K IF( B( J, L ).NE.ZERO )THEN TEMP = ALPHA*B( J, L ) DO 150, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 150 CONTINUE END IF 160 CONTINUE 170 CONTINUE ELSE C C Form C := alpha*A'*B' + beta*C C DO 200, J = 1, N DO 190, I = 1, M TEMP = ZERO DO 180, L = 1, K TEMP = TEMP + A( L, I )*B( J, L ) 180 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 190 CONTINUE 200 CONTINUE END IF END IF C RETURN C C End of DGEMM . C END SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, $ BETA, Y, INCY ) C .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA INTEGER INCX, INCY, LDA, M, N CHARACTER*1 TRANS C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) C .. C C Purpose C ======= C C DGEMV performs one of the matrix-vector operations C C y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, C C where alpha and beta are scalars, x and y are vectors and A is an C m by n matrix. C C Parameters C ========== C C TRANS - CHARACTER*1. C On entry, TRANS specifies the operation to be performed as C follows: C C TRANS = 'N' or 'n' y := alpha*A*x + beta*y. C C TRANS = 'T' or 't' y := alpha*A'*x + beta*y. C C TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. C C Unchanged on exit. C C M - INTEGER. C On entry, M specifies the number of rows of the matrix A. C M must be at least zero. C Unchanged on exit. C C N - INTEGER. C On entry, N specifies the number of columns of the matrix A. C N must be at least zero. C Unchanged on exit. C C ALPHA - DOUBLE PRECISION. C On entry, ALPHA specifies the scalar alpha. C Unchanged on exit. C C A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). C Before entry, the leading m by n part of the array A must C contain the matrix of coefficients. C Unchanged on exit. C C LDA - INTEGER. C On entry, LDA specifies the first dimension of A as declared C in the calling (sub) program. LDA must be at least C max( 1, m ). C Unchanged on exit. C C X - DOUBLE PRECISION array of DIMENSION at least C ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' C and at least C ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. C Before entry, the incremented array X must contain the C vector x. C Unchanged on exit. C C INCX - INTEGER. C On entry, INCX specifies the increment for the elements of C X. INCX must not be zero. C Unchanged on exit. C C BETA - DOUBLE PRECISION. C On entry, BETA specifies the scalar beta. When BETA is C supplied as zero then Y need not be set on input. C Unchanged on exit. C C Y - DOUBLE PRECISION array of DIMENSION at least C ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' C and at least C ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. C Before entry with BETA non-zero, the incremented array Y C must contain the vector y. On exit, Y is overwritten by the C updated vector y. C C INCY - INTEGER. C On entry, INCY specifies the increment for the elements of C Y. INCY must not be zero. C Unchanged on exit. C C C Level 2 Blas routine. C C -- Written on 22-October-1986. C Jack Dongarra, Argonne National Lab. C Jeremy Du Croz, Nag Central Office. C Sven Hammarling, Nag Central Office. C Richard Hanson, Sandia National Labs. C C C .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 IF ( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 1 ELSE IF( M.LT.0 )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( LDA.LT.MAX( 1, M ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 ELSE IF( INCY.EQ.0 )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DGEMV ', INFO ) RETURN END IF C C Quick return if possible. C IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN C C Set LENX and LENY, the lengths of the vectors x and y, and set C up the start points in X and Y. C IF( LSAME( TRANS, 'N' ) )THEN LENX = N LENY = M ELSE LENX = M LENY = N END IF IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( LENX - 1 )*INCX END IF IF( INCY.GT.0 )THEN KY = 1 ELSE KY = 1 - ( LENY - 1 )*INCY END IF C C Start the operations. In this version the elements of A are C accessed sequentially with one pass through A. C C First form y := beta*y. C IF( BETA.NE.ONE )THEN IF( INCY.EQ.1 )THEN IF( BETA.EQ.ZERO )THEN DO 10, I = 1, LENY Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, LENY Y( I ) = BETA*Y( I ) 20 CONTINUE END IF ELSE IY = KY IF( BETA.EQ.ZERO )THEN DO 30, I = 1, LENY Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, LENY Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE END IF END IF END IF IF( ALPHA.EQ.ZERO ) $ RETURN IF( LSAME( TRANS, 'N' ) )THEN C C Form y := alpha*A*x + y. C JX = KX IF( INCY.EQ.1 )THEN DO 60, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) DO 50, I = 1, M Y( I ) = Y( I ) + TEMP*A( I, J ) 50 CONTINUE END IF JX = JX + INCX 60 CONTINUE ELSE DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) IY = KY DO 70, I = 1, M Y( IY ) = Y( IY ) + TEMP*A( I, J ) IY = IY + INCY 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF ELSE C C Form y := alpha*A'*x + y. C JY = KY IF( INCX.EQ.1 )THEN DO 100, J = 1, N TEMP = ZERO DO 90, I = 1, M TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 100 CONTINUE ELSE DO 120, J = 1, N TEMP = ZERO IX = KX DO 110, I = 1, M TEMP = TEMP + A( I, J )*X( IX ) IX = IX + INCX 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 120 CONTINUE END IF END IF C RETURN C C End of DGEMV . C END SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) C .. Scalar Arguments .. DOUBLE PRECISION ALPHA INTEGER INCX, INCY, LDA, M, N C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) C .. C C Purpose C ======= C C DGER performs the rank 1 operation C C A := alpha*x*y' + A, C C where alpha is a scalar, x is an m element vector, y is an n element C vector and A is an m by n matrix. C C Parameters C ========== C C M - INTEGER. C On entry, M specifies the number of rows of the matrix A. C M must be at least zero. C Unchanged on exit. C C N - INTEGER. C On entry, N specifies the number of columns of the matrix A. C N must be at least zero. C Unchanged on exit. C C ALPHA - DOUBLE PRECISION. C On entry, ALPHA specifies the scalar alpha. C Unchanged on exit. C C X - DOUBLE PRECISION array of dimension at least C ( 1 + ( m - 1 )*abs( INCX ) ). C Before entry, the incremented array X must contain the m C element vector x. C Unchanged on exit. C C INCX - INTEGER. C On entry, INCX specifies the increment for the elements of C X. INCX must not be zero. C Unchanged on exit. C C Y - DOUBLE PRECISION array of dimension at least C ( 1 + ( n - 1 )*abs( INCY ) ). C Before entry, the incremented array Y must contain the n C element vector y. C Unchanged on exit. C C INCY - INTEGER. C On entry, INCY specifies the increment for the elements of C Y. INCY must not be zero. C Unchanged on exit. C C A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). C Before entry, the leading m by n part of the array A must C contain the matrix of coefficients. On exit, A is C overwritten by the updated matrix. C C LDA - INTEGER. C On entry, LDA specifies the first dimension of A as declared C in the calling (sub) program. LDA must be at least C max( 1, m ). C Unchanged on exit. C C C Level 2 Blas routine. C C -- Written on 22-October-1986. C Jack Dongarra, Argonne National Lab. C Jeremy Du Croz, Nag Central Office. C Sven Hammarling, Nag Central Office. C Richard Hanson, Sandia National Labs. C C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) C .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JY, KX C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 IF ( M.LT.0 )THEN INFO = 1 ELSE IF( N.LT.0 )THEN INFO = 2 ELSE IF( INCX.EQ.0 )THEN INFO = 5 ELSE IF( INCY.EQ.0 )THEN INFO = 7 ELSE IF( LDA.LT.MAX( 1, M ) )THEN INFO = 9 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DGER ', INFO ) RETURN END IF C C Quick return if possible. C IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) $ RETURN C C Start the operations. In this version the elements of A are C accessed sequentially with one pass through A. C IF( INCY.GT.0 )THEN JY = 1 ELSE JY = 1 - ( N - 1 )*INCY END IF IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( Y( JY ).NE.ZERO )THEN TEMP = ALPHA*Y( JY ) DO 10, I = 1, M A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE END IF JY = JY + INCY 20 CONTINUE ELSE IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( M - 1 )*INCX END IF DO 40, J = 1, N IF( Y( JY ).NE.ZERO )THEN TEMP = ALPHA*Y( JY ) IX = KX DO 30, I = 1, M A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE END IF JY = JY + INCY 40 CONTINUE END IF C RETURN C C End of DGER . C END DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX) INTEGER I, INCX, IX, J, N, NEXT DOUBLE PRECISION DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE DATA ZERO, ONE /0.0D0, 1.0D0/ C C euclidean norm of the n-vector stored in dx() with storage C increment incx . C if n .le. 0 return with result = 0. C if n .ge. 1 then incx must be .ge. 1 C C c.l.lawson, 1978 jan 08 C modified to correct problem with negative increment, 8/21/90. C modified to correct failure to update ix, 1/25/92. C C four phase method using two built-in constants that are C hopefully applicable to all machines. C cutlo = maximum of dsqrt(u/eps) over all known machines. C cuthi = minimum of dsqrt(v) over all known machines. C where C eps = smallest no. such that eps + 1. .gt. 1. C u = smallest positive no. (underflow limit) C v = largest no. (overflow limit) C C brief outline of algorithm.. C C phase 1 scans zero components. C move to phase 2 when a component is nonzero and .le. cutlo C move to phase 3 when a component is .gt. cutlo C move to phase 4 when a component is .ge. cuthi/m C where m = n for x() real and m = 2*n for complex. C C values for cutlo and cuthi.. C from the environmental parameters listed in the imsl converter C document the limiting values are as follows.. C cutlo, s.p. u/eps = 2**(-102) for honeywell. close seconds are C univac and dec at 2**(-103) C thus cutlo = 2**(-51) = 4.44089e-16 C cuthi, s.p. v = 2**127 for univac, honeywell, and dec. C thus cuthi = 2**(63.5) = 1.30438e19 C cutlo, d.p. u/eps = 2**(-67) for honeywell and dec. C thus cutlo = 2**(-33.5) = 8.23181d-11 C cuthi, d.p. same as s.p. cuthi = 1.30438d19 C data cutlo, cuthi / 8.232d-11, 1.304d19 / C data cutlo, cuthi / 4.441e-16, 1.304e19 / DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / C IF(N .GT. 0) GO TO 10 DNRM2 = ZERO GO TO 300 C 10 ASSIGN 30 TO NEXT SUM = ZERO I = 1 IF( INCX .LT. 0 )I = (-N+1)*INCX + 1 IX = 1 C BEGIN MAIN LOOP 20 GO TO NEXT,(30, 50, 70, 110) 30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 ASSIGN 50 TO NEXT XMAX = ZERO C C PHASE 1. SUM IS ZERO C 50 IF( DX(I) .EQ. ZERO) GO TO 200 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 C C PREPARE FOR PHASE 2. ASSIGN 70 TO NEXT GO TO 105 C C PREPARE FOR PHASE 4. C 100 CONTINUE IX = J ASSIGN 110 TO NEXT SUM = (SUM / DX(I)) / DX(I) 105 XMAX = DABS(DX(I)) GO TO 115 C C PHASE 2. SUM IS SMALL. C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. C 70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75 C C COMMON CODE FOR PHASES 2 AND 4. C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. C 110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115 SUM = ONE + SUM * (XMAX / DX(I))**2 XMAX = DABS(DX(I)) GO TO 200 C 115 SUM = SUM + (DX(I)/XMAX)**2 GO TO 200 C C C PREPARE FOR PHASE 3. C 75 SUM = (SUM * XMAX) * XMAX C C C FOR REAL OR D.P. SET HITEST = CUTHI/N C FOR COMPLEX SET HITEST = CUTHI/(2*N) C 85 HITEST = CUTHI/FLOAT( N ) C C PHASE 3. SUM IS MID-RANGE. NO SCALING. C DO 95 J = IX,N IF(DABS(DX(I)) .GE. HITEST) GO TO 100 SUM = SUM + DX(I)**2 I = I + INCX 95 CONTINUE DNRM2 = DSQRT( SUM ) GO TO 300 C 200 CONTINUE IX = IX + 1 I = I + INCX IF( IX .LE. N ) GO TO 20 C C END OF MAIN LOOP. C C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. C DNRM2 = XMAX * DSQRT(SUM) 300 CONTINUE RETURN END SUBROUTINE DSCAL(N,DA,DX,INCX) C C scales a vector by a constant. C uses unrolled loops for increment equal to one. C jack dongarra, linpack, 3/11/78. C modified to correct problem with negative increment, 8/21/90. C DOUBLE PRECISION DA,DX(*) INTEGER I,INCX,IX,M,MP1,N C IF(N.LE.0)RETURN IF(INCX.EQ.1)GO TO 20 C C code for increment not equal to 1 C IX = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 DO 10 I = 1,N DX(IX) = DA*DX(IX) IX = IX + INCX 10 CONTINUE RETURN C C code for increment equal to 1 C C C clean-up loop C 20 M = MOD(N,5) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DX(I) = DA*DX(I) 30 CONTINUE IF( N .LT. 5 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 DX(I) = DA*DX(I) DX(I + 1) = DA*DX(I + 1) DX(I + 2) = DA*DX(I + 2) DX(I + 3) = DA*DX(I + 3) DX(I + 4) = DA*DX(I + 4) 50 CONTINUE RETURN END SUBROUTINE DSPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) C .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA INTEGER INCX, INCY, N CHARACTER*1 UPLO C .. Array Arguments .. DOUBLE PRECISION AP( * ), X( * ), Y( * ) C .. C C Purpose C ======= C C DSPMV performs the matrix-vector operation C C y := alpha*A*x + beta*y, C C where alpha and beta are scalars, x and y are n element vectors and C A is an n by n symmetric matrix, supplied in packed form. C C Parameters C ========== C C UPLO - CHARACTER*1. C On entry, UPLO specifies whether the upper or lower C triangular part of the matrix A is supplied in the packed C array AP as follows: C C UPLO = 'U' or 'u' The upper triangular part of A is C supplied in AP. C C UPLO = 'L' or 'l' The lower triangular part of A is C supplied in AP. C C Unchanged on exit. C C N - INTEGER. C On entry, N specifies the order of the matrix A. C N must be at least zero. C Unchanged on exit. C C ALPHA - DOUBLE PRECISION. C On entry, ALPHA specifies the scalar alpha. C Unchanged on exit. C C AP - DOUBLE PRECISION array of DIMENSION at least C ( ( n*( n + 1 ) )/2 ). C Before entry with UPLO = 'U' or 'u', the array AP must C contain the upper triangular part of the symmetric matrix C packed sequentially, column by column, so that AP( 1 ) C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) C and a( 2, 2 ) respectively, and so on. C Before entry with UPLO = 'L' or 'l', the array AP must C contain the lower triangular part of the symmetric matrix C packed sequentially, column by column, so that AP( 1 ) C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) C and a( 3, 1 ) respectively, and so on. C Unchanged on exit. C C X - DOUBLE PRECISION array of dimension at least C ( 1 + ( n - 1 )*abs( INCX ) ). C Before entry, the incremented array X must contain the n C element vector x. C Unchanged on exit. C C INCX - INTEGER. C On entry, INCX specifies the increment for the elements of C X. INCX must not be zero. C Unchanged on exit. C C BETA - DOUBLE PRECISION. C On entry, BETA specifies the scalar beta. When BETA is C supplied as zero then Y need not be set on input. C Unchanged on exit. C C Y - DOUBLE PRECISION array of dimension at least C ( 1 + ( n - 1 )*abs( INCY ) ). C Before entry, the incremented array Y must contain the n C element vector y. On exit, Y is overwritten by the updated C vector y. C C INCY - INTEGER. C On entry, INCY specifies the increment for the elements of C Y. INCY must not be zero. C Unchanged on exit. C C C Level 2 Blas routine. C C -- Written on 22-October-1986. C Jack Dongarra, Argonne National Lab. C Jeremy Du Croz, Nag Central Office. C Sven Hammarling, Nag Central Office. C Richard Hanson, Sandia National Labs. C C C .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. Local Scalars .. DOUBLE PRECISION TEMP1, TEMP2 INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 IF ( .NOT.LSAME( UPLO, 'U' ).AND. $ .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE IF( N.LT.0 )THEN INFO = 2 ELSE IF( INCX.EQ.0 )THEN INFO = 6 ELSE IF( INCY.EQ.0 )THEN INFO = 9 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DSPMV ', INFO ) RETURN END IF C C Quick return if possible. C IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN C C Set up the start points in X and Y. C IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( N - 1 )*INCX END IF IF( INCY.GT.0 )THEN KY = 1 ELSE KY = 1 - ( N - 1 )*INCY END IF C C Start the operations. In this version the elements of the array AP C are accessed sequentially with one pass through AP. C C First form y := beta*y. C IF( BETA.NE.ONE )THEN IF( INCY.EQ.1 )THEN IF( BETA.EQ.ZERO )THEN DO 10, I = 1, N Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, N Y( I ) = BETA*Y( I ) 20 CONTINUE END IF ELSE IY = KY IF( BETA.EQ.ZERO )THEN DO 30, I = 1, N Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, N Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE END IF END IF END IF IF( ALPHA.EQ.ZERO ) $ RETURN KK = 1 IF( LSAME( UPLO, 'U' ) )THEN C C Form y when AP contains the upper triangle. C IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN DO 60, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO K = KK DO 50, I = 1, J - 1 Y( I ) = Y( I ) + TEMP1*AP( K ) TEMP2 = TEMP2 + AP( K )*X( I ) K = K + 1 50 CONTINUE Y( J ) = Y( J ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 KK = KK + J 60 CONTINUE ELSE JX = KX JY = KY DO 80, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO IX = KX IY = KY DO 70, K = KK, KK + J - 2 Y( IY ) = Y( IY ) + TEMP1*AP( K ) TEMP2 = TEMP2 + AP( K )*X( IX ) IX = IX + INCX IY = IY + INCY 70 CONTINUE Y( JY ) = Y( JY ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY KK = KK + J 80 CONTINUE END IF ELSE C C Form y when AP contains the lower triangle. C IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN DO 100, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO Y( J ) = Y( J ) + TEMP1*AP( KK ) K = KK + 1 DO 90, I = J + 1, N Y( I ) = Y( I ) + TEMP1*AP( K ) TEMP2 = TEMP2 + AP( K )*X( I ) K = K + 1 90 CONTINUE Y( J ) = Y( J ) + ALPHA*TEMP2 KK = KK + ( N - J + 1 ) 100 CONTINUE ELSE JX = KX JY = KY DO 120, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO Y( JY ) = Y( JY ) + TEMP1*AP( KK ) IX = JX IY = JY DO 110, K = KK + 1, KK + N - J IX = IX + INCX IY = IY + INCY Y( IY ) = Y( IY ) + TEMP1*AP( K ) TEMP2 = TEMP2 + AP( K )*X( IX ) 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY KK = KK + ( N - J + 1 ) 120 CONTINUE END IF END IF C RETURN C C End of DSPMV . C END SUBROUTINE DSPR ( UPLO, N, ALPHA, X, INCX, AP ) C .. Scalar Arguments .. DOUBLE PRECISION ALPHA INTEGER INCX, N CHARACTER*1 UPLO C .. Array Arguments .. DOUBLE PRECISION AP( * ), X( * ) C .. C C Purpose C ======= C C DSPR performs the symmetric rank 1 operation C C A := alpha*x*x' + A, C C where alpha is a real scalar, x is an n element vector and A is an C n by n symmetric matrix, supplied in packed form. C C Parameters C ========== C C UPLO - CHARACTER*1. C On entry, UPLO specifies whether the upper or lower C triangular part of the matrix A is supplied in the packed C array AP as follows: C C UPLO = 'U' or 'u' The upper triangular part of A is C supplied in AP. C C UPLO = 'L' or 'l' The lower triangular part of A is C supplied in AP. C C Unchanged on exit. C C N - INTEGER. C On entry, N specifies the order of the matrix A. C N must be at least zero. C Unchanged on exit. C C ALPHA - DOUBLE PRECISION. C On entry, ALPHA specifies the scalar alpha. C Unchanged on exit. C C X - DOUBLE PRECISION array of dimension at least C ( 1 + ( n - 1 )*abs( INCX ) ). C Before entry, the incremented array X must contain the n C element vector x. C Unchanged on exit. C C INCX - INTEGER. C On entry, INCX specifies the increment for the elements of C X. INCX must not be zero. C Unchanged on exit. C C AP - DOUBLE PRECISION array of DIMENSION at least C ( ( n*( n + 1 ) )/2 ). C Before entry with UPLO = 'U' or 'u', the array AP must C contain the upper triangular part of the symmetric matrix C packed sequentially, column by column, so that AP( 1 ) C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) C and a( 2, 2 ) respectively, and so on. On exit, the array C AP is overwritten by the upper triangular part of the C updated matrix. C Before entry with UPLO = 'L' or 'l', the array AP must C contain the lower triangular part of the symmetric matrix C packed sequentially, column by column, so that AP( 1 ) C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) C and a( 3, 1 ) respectively, and so on. On exit, the array C AP is overwritten by the lower triangular part of the C updated matrix. C C C Level 2 Blas routine. C C -- Written on 22-October-1986. C Jack Dongarra, Argonne National Lab. C Jeremy Du Croz, Nag Central Office. C Sven Hammarling, Nag Central Office. C Richard Hanson, Sandia National Labs. C C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) C .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JX, K, KK, KX C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 IF ( .NOT.LSAME( UPLO, 'U' ).AND. $ .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE IF( N.LT.0 )THEN INFO = 2 ELSE IF( INCX.EQ.0 )THEN INFO = 5 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DSPR ', INFO ) RETURN END IF C C Quick return if possible. C IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) $ RETURN C C Set the start point in X if the increment is not unity. C IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF C C Start the operations. In this version the elements of the array AP C are accessed sequentially with one pass through AP. C KK = 1 IF( LSAME( UPLO, 'U' ) )THEN C C Form A when upper triangle is stored in AP. C IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( X( J ).NE.ZERO )THEN TEMP = ALPHA*X( J ) K = KK DO 10, I = 1, J AP( K ) = AP( K ) + X( I )*TEMP K = K + 1 10 CONTINUE END IF KK = KK + J 20 CONTINUE ELSE JX = KX DO 40, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) IX = KX DO 30, K = KK, KK + J - 1 AP( K ) = AP( K ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE END IF JX = JX + INCX KK = KK + J 40 CONTINUE END IF ELSE C C Form A when lower triangle is stored in AP. C IF( INCX.EQ.1 )THEN DO 60, J = 1, N IF( X( J ).NE.ZERO )THEN TEMP = ALPHA*X( J ) K = KK DO 50, I = J, N AP( K ) = AP( K ) + X( I )*TEMP K = K + 1 50 CONTINUE END IF KK = KK + N - J + 1 60 CONTINUE ELSE JX = KX DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) IX = JX DO 70, K = KK, KK + N - J AP( K ) = AP( K ) + X( IX )*TEMP IX = IX + INCX 70 CONTINUE END IF JX = JX + INCX KK = KK + N - J + 1 80 CONTINUE END IF END IF C RETURN C C End of DSPR . C END C SUBROUTINE DSPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP ) C .. Scalar Arguments .. DOUBLE PRECISION ALPHA INTEGER INCX, INCY, N CHARACTER*1 UPLO C .. Array Arguments .. DOUBLE PRECISION AP( * ), X( * ), Y( * ) C .. C C Purpose C ======= C C DSPR2 performs the symmetric rank 2 operation C C A := alpha*x*y' + alpha*y*x' + A, C C where alpha is a scalar, x and y are n element vectors and A is an C n by n symmetric matrix, supplied in packed form. C C Parameters C ========== C C UPLO - CHARACTER*1. C On entry, UPLO specifies whether the upper or lower C triangular part of the matrix A is supplied in the packed C array AP as follows: C C UPLO = 'U' or 'u' The upper triangular part of A is C supplied in AP. C C UPLO = 'L' or 'l' The lower triangular part of A is C supplied in AP. C C Unchanged on exit. C C N - INTEGER. C On entry, N specifies the order of the matrix A. C N must be at least zero. C Unchanged on exit. C C ALPHA - DOUBLE PRECISION. C On entry, ALPHA specifies the scalar alpha. C Unchanged on exit. C C X - DOUBLE PRECISION array of dimension at least C ( 1 + ( n - 1 )*abs( INCX ) ). C Before entry, the incremented array X must contain the n C element vector x. C Unchanged on exit. C C INCX - INTEGER. C On entry, INCX specifies the increment for the elements of C X. INCX must not be zero. C Unchanged on exit. C C Y - DOUBLE PRECISION array of dimension at least C ( 1 + ( n - 1 )*abs( INCY ) ). C Before entry, the incremented array Y must contain the n C element vector y. C Unchanged on exit. C C INCY - INTEGER. C On entry, INCY specifies the increment for the elements of C Y. INCY must not be zero. C Unchanged on exit. C C AP - DOUBLE PRECISION array of DIMENSION at least C ( ( n*( n + 1 ) )/2 ). C Before entry with UPLO = 'U' or 'u', the array AP must C contain the upper triangular part of the symmetric matrix C packed sequentially, column by column, so that AP( 1 ) C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) C and a( 2, 2 ) respectively, and so on. On exit, the array C AP is overwritten by the upper triangular part of the C updated matrix. C Before entry with UPLO = 'L' or 'l', the array AP must C contain the lower triangular part of the symmetric matrix C packed sequentially, column by column, so that AP( 1 ) C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) C and a( 3, 1 ) respectively, and so on. On exit, the array C AP is overwritten by the lower triangular part of the C updated matrix. C C C Level 2 Blas routine. C C -- Written on 22-October-1986. C Jack Dongarra, Argonne National Lab. C Jeremy Du Croz, Nag Central Office. C Sven Hammarling, Nag Central Office. C Richard Hanson, Sandia National Labs. C C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) C .. Local Scalars .. DOUBLE PRECISION TEMP1, TEMP2 INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 IF ( .NOT.LSAME( UPLO, 'U' ).AND. $ .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE IF( N.LT.0 )THEN INFO = 2 ELSE IF( INCX.EQ.0 )THEN INFO = 5 ELSE IF( INCY.EQ.0 )THEN INFO = 7 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DSPR2 ', INFO ) RETURN END IF C C Quick return if possible. C IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) $ RETURN C C Set up the start points in X and Y if the increments are not both C unity. C IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( N - 1 )*INCX END IF IF( INCY.GT.0 )THEN KY = 1 ELSE KY = 1 - ( N - 1 )*INCY END IF JX = KX JY = KY END IF C C Start the operations. In this version the elements of the array AP C are accessed sequentially with one pass through AP. C KK = 1 IF( LSAME( UPLO, 'U' ) )THEN C C Form A when upper triangle is stored in AP. C IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN DO 20, J = 1, N IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN TEMP1 = ALPHA*Y( J ) TEMP2 = ALPHA*X( J ) K = KK DO 10, I = 1, J AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 K = K + 1 10 CONTINUE END IF KK = KK + J 20 CONTINUE ELSE DO 40, J = 1, N IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN TEMP1 = ALPHA*Y( JY ) TEMP2 = ALPHA*X( JX ) IX = KX IY = KY DO 30, K = KK, KK + J - 1 AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 IX = IX + INCX IY = IY + INCY 30 CONTINUE END IF JX = JX + INCX JY = JY + INCY KK = KK + J 40 CONTINUE END IF ELSE C C Form A when lower triangle is stored in AP. C IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN DO 60, J = 1, N IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN TEMP1 = ALPHA*Y( J ) TEMP2 = ALPHA*X( J ) K = KK DO 50, I = J, N AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 K = K + 1 50 CONTINUE END IF KK = KK + N - J + 1 60 CONTINUE ELSE DO 80, J = 1, N IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN TEMP1 = ALPHA*Y( JY ) TEMP2 = ALPHA*X( JX ) IX = JX IY = JY DO 70, K = KK, KK + N - J AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 IX = IX + INCX IY = IY + INCY 70 CONTINUE END IF JX = JX + INCX JY = JY + INCY KK = KK + N - J + 1 80 CONTINUE END IF END IF C RETURN C C End of DSPR2 . C END SUBROUTINE DSWAP (N,DX,INCX,DY,INCY) C C interchanges two vectors. C uses unrolled loops for increments equal one. C jack dongarra, linpack, 3/11/78. C DOUBLE PRECISION DX(1),DY(1),DTEMP INTEGER I,INCX,INCY,IX,IY,M,MP1,N C IF(N.LE.0)RETURN IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 C C code for unequal increments or equal increments not equal C to 1 C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DTEMP = DX(IX) DX(IX) = DY(IY) DY(IY) = DTEMP IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C code for both increments equal to 1 C C C clean-up loop C 20 M = MOD(N,3) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DTEMP = DX(I) DX(I) = DY(I) DY(I) = DTEMP 30 CONTINUE IF( N .LT. 3 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,3 DTEMP = DX(I) DX(I) = DY(I) DY(I) = DTEMP DTEMP = DX(I + 1) DX(I + 1) = DY(I + 1) DY(I + 1) = DTEMP DTEMP = DX(I + 2) DX(I + 2) = DY(I + 2) DY(I + 2) = DTEMP 50 CONTINUE RETURN END SUBROUTINE DTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) C .. Scalar Arguments .. INTEGER INCX, N CHARACTER*1 DIAG, TRANS, UPLO C .. Array Arguments .. DOUBLE PRECISION AP( * ), X( * ) C .. C C Purpose C ======= C C DTPMV performs one of the matrix-vector operations C C x := A*x, or x := A'*x, C C where x is an n element vector and A is an n by n unit, or non-unit, C upper or lower triangular matrix, supplied in packed form. C C Parameters C ========== C C UPLO - CHARACTER*1. C On entry, UPLO specifies whether the matrix is an upper or C lower triangular matrix as follows: C C UPLO = 'U' or 'u' A is an upper triangular matrix. C C UPLO = 'L' or 'l' A is a lower triangular matrix. C C Unchanged on exit. C C TRANS - CHARACTER*1. C On entry, TRANS specifies the operation to be performed as C follows: C C TRANS = 'N' or 'n' x := A*x. C C TRANS = 'T' or 't' x := A'*x. C C TRANS = 'C' or 'c' x := A'*x. C C Unchanged on exit. C C DIAG - CHARACTER*1. C On entry, DIAG specifies whether or not A is unit C triangular as follows: C C DIAG = 'U' or 'u' A is assumed to be unit triangular. C C DIAG = 'N' or 'n' A is not assumed to be unit C triangular. C C Unchanged on exit. C C N - INTEGER. C On entry, N specifies the order of the matrix A. C N must be at least zero. C Unchanged on exit. C C AP - DOUBLE PRECISION array of DIMENSION at least C ( ( n*( n + 1 ) )/2 ). C Before entry with UPLO = 'U' or 'u', the array AP must C contain the upper triangular matrix packed sequentially, C column by column, so that AP( 1 ) contains a( 1, 1 ), C AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) C respectively, and so on. C Before entry with UPLO = 'L' or 'l', the array AP must C contain the lower triangular matrix packed sequentially, C column by column, so that AP( 1 ) contains a( 1, 1 ), C AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) C respectively, and so on. C Note that when DIAG = 'U' or 'u', the diagonal elements of C A are not referenced, but are assumed to be unity. C Unchanged on exit. C C X - DOUBLE PRECISION array of dimension at least C ( 1 + ( n - 1 )*abs( INCX ) ). C Before entry, the incremented array X must contain the n C element vector x. On exit, X is overwritten with the C tranformed vector x. C C INCX - INTEGER. C On entry, INCX specifies the increment for the elements of C X. INCX must not be zero. C Unchanged on exit. C C C Level 2 Blas routine. C C -- Written on 22-October-1986. C Jack Dongarra, Argonne National Lab. C Jeremy Du Croz, Nag Central Office. C Sven Hammarling, Nag Central Office. C Richard Hanson, Sandia National Labs. C C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) C .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JX, K, KK, KX LOGICAL NOUNIT C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 IF ( .NOT.LSAME( UPLO , 'U' ).AND. $ .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. $ .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( INCX.EQ.0 )THEN INFO = 7 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DTPMV ', INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN C NOUNIT = LSAME( DIAG, 'N' ) C C Set up the start point in X if the increment is not unity. This C will be ( N - 1 )*INCX too small for descending loops. C IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF C C Start the operations. In this version the elements of AP are C accessed sequentially with one pass through AP. C IF( LSAME( TRANS, 'N' ) )THEN C C Form x:= A*x. C IF( LSAME( UPLO, 'U' ) )THEN KK =1 IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( X( J ).NE.ZERO )THEN TEMP = X( J ) K = KK DO 10, I = 1, J - 1 X( I ) = X( I ) + TEMP*AP( K ) K = K + 1 10 CONTINUE IF( NOUNIT ) $ X( J ) = X( J )*AP( KK + J - 1 ) END IF KK = KK + J 20 CONTINUE ELSE JX = KX DO 40, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = X( JX ) IX = KX DO 30, K = KK, KK + J - 2 X( IX ) = X( IX ) + TEMP*AP( K ) IX = IX + INCX 30 CONTINUE IF( NOUNIT ) $ X( JX ) = X( JX )*AP( KK + J - 1 ) END IF JX = JX + INCX KK = KK + J 40 CONTINUE END IF ELSE KK = ( N*( N + 1 ) )/2 IF( INCX.EQ.1 )THEN DO 60, J = N, 1, -1 IF( X( J ).NE.ZERO )THEN TEMP = X( J ) K = KK DO 50, I = N, J + 1, -1 X( I ) = X( I ) + TEMP*AP( K ) K = K - 1 50 CONTINUE IF( NOUNIT ) $ X( J ) = X( J )*AP( KK - N + J ) END IF KK = KK - ( N - J + 1 ) 60 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 80, J = N, 1, -1 IF( X( JX ).NE.ZERO )THEN TEMP = X( JX ) IX = KX DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1 X( IX ) = X( IX ) + TEMP*AP( K ) IX = IX - INCX 70 CONTINUE IF( NOUNIT ) $ X( JX ) = X( JX )*AP( KK - N + J ) END IF JX = JX - INCX KK = KK - ( N - J + 1 ) 80 CONTINUE END IF END IF ELSE C C Form x := A'*x. C IF( LSAME( UPLO, 'U' ) )THEN KK = ( N*( N + 1 ) )/2 IF( INCX.EQ.1 )THEN DO 100, J = N, 1, -1 TEMP = X( J ) IF( NOUNIT ) $ TEMP = TEMP*AP( KK ) K = KK - 1 DO 90, I = J - 1, 1, -1 TEMP = TEMP + AP( K )*X( I ) K = K - 1 90 CONTINUE X( J ) = TEMP KK = KK - J 100 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 120, J = N, 1, -1 TEMP = X( JX ) IX = JX IF( NOUNIT ) $ TEMP = TEMP*AP( KK ) DO 110, K = KK - 1, KK - J + 1, -1 IX = IX - INCX TEMP = TEMP + AP( K )*X( IX ) 110 CONTINUE X( JX ) = TEMP JX = JX - INCX KK = KK - J 120 CONTINUE END IF ELSE KK = 1 IF( INCX.EQ.1 )THEN DO 140, J = 1, N TEMP = X( J ) IF( NOUNIT ) $ TEMP = TEMP*AP( KK ) K = KK + 1 DO 130, I = J + 1, N TEMP = TEMP + AP( K )*X( I ) K = K + 1 130 CONTINUE X( J ) = TEMP KK = KK + ( N - J + 1 ) 140 CONTINUE ELSE JX = KX DO 160, J = 1, N TEMP = X( JX ) IX = JX IF( NOUNIT ) $ TEMP = TEMP*AP( KK ) DO 150, K = KK + 1, KK + N - J IX = IX + INCX TEMP = TEMP + AP( K )*X( IX ) 150 CONTINUE X( JX ) = TEMP JX = JX + INCX KK = KK + ( N - J + 1 ) 160 CONTINUE END IF END IF END IF C RETURN C C End of DTPMV . C END SUBROUTINE DTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) C .. Scalar Arguments .. INTEGER INCX, N CHARACTER*1 DIAG, TRANS, UPLO C .. Array Arguments .. DOUBLE PRECISION AP( * ), X( * ) C .. C C Purpose C ======= C C DTPSV solves one of the systems of equations C C A*x = b, or A'*x = b, C C where b and x are n element vectors and A is an n by n unit, or C non-unit, upper or lower triangular matrix, supplied in packed form. C C No test for singularity or near-singularity is included in this C routine. Such tests must be performed before calling this routine. C C Parameters C ========== C C UPLO - CHARACTER*1. C On entry, UPLO specifies whether the matrix is an upper or C lower triangular matrix as follows: C C UPLO = 'U' or 'u' A is an upper triangular matrix. C C UPLO = 'L' or 'l' A is a lower triangular matrix. C C Unchanged on exit. C C TRANS - CHARACTER*1. C On entry, TRANS specifies the equations to be solved as C follows: C C TRANS = 'N' or 'n' A*x = b. C C TRANS = 'T' or 't' A'*x = b. C C TRANS = 'C' or 'c' A'*x = b. C C Unchanged on exit. C C DIAG - CHARACTER*1. C On entry, DIAG specifies whether or not A is unit C triangular as follows: C C DIAG = 'U' or 'u' A is assumed to be unit triangular. C C DIAG = 'N' or 'n' A is not assumed to be unit C triangular. C C Unchanged on exit. C C N - INTEGER. C On entry, N specifies the order of the matrix A. C N must be at least zero. C Unchanged on exit. C C AP - DOUBLE PRECISION array of DIMENSION at least C ( ( n*( n + 1 ) )/2 ). C Before entry with UPLO = 'U' or 'u', the array AP must C contain the upper triangular matrix packed sequentially, C column by column, so that AP( 1 ) contains a( 1, 1 ), C AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) C respectively, and so on. C Before entry with UPLO = 'L' or 'l', the array AP must C contain the lower triangular matrix packed sequentially, C column by column, so that AP( 1 ) contains a( 1, 1 ), C AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) C respectively, and so on. C Note that when DIAG = 'U' or 'u', the diagonal elements of C A are not referenced, but are assumed to be unity. C Unchanged on exit. C C X - DOUBLE PRECISION array of dimension at least C ( 1 + ( n - 1 )*abs( INCX ) ). C Before entry, the incremented array X must contain the n C element right-hand side vector b. On exit, X is overwritten C with the solution vector x. C C INCX - INTEGER. C On entry, INCX specifies the increment for the elements of C X. INCX must not be zero. C Unchanged on exit. C C C Level 2 Blas routine. C C -- Written on 22-October-1986. C Jack Dongarra, Argonne National Lab. C Jeremy Du Croz, Nag Central Office. C Sven Hammarling, Nag Central Office. C Richard Hanson, Sandia National Labs. C C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) C .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JX, K, KK, KX LOGICAL NOUNIT C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 IF ( .NOT.LSAME( UPLO , 'U' ).AND. $ .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. $ .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( INCX.EQ.0 )THEN INFO = 7 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DTPSV ', INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN C NOUNIT = LSAME( DIAG, 'N' ) C C Set up the start point in X if the increment is not unity. This C will be ( N - 1 )*INCX too small for descending loops. C IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF C C Start the operations. In this version the elements of AP are C accessed sequentially with one pass through AP. C IF( LSAME( TRANS, 'N' ) )THEN C C Form x := inv( A )*x. C IF( LSAME( UPLO, 'U' ) )THEN KK = ( N*( N + 1 ) )/2 IF( INCX.EQ.1 )THEN DO 20, J = N, 1, -1 IF( X( J ).NE.ZERO )THEN IF( NOUNIT ) $ X( J ) = X( J )/AP( KK ) TEMP = X( J ) K = KK - 1 DO 10, I = J - 1, 1, -1 X( I ) = X( I ) - TEMP*AP( K ) K = K - 1 10 CONTINUE END IF KK = KK - J 20 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 40, J = N, 1, -1 IF( X( JX ).NE.ZERO )THEN IF( NOUNIT ) $ X( JX ) = X( JX )/AP( KK ) TEMP = X( JX ) IX = JX DO 30, K = KK - 1, KK - J + 1, -1 IX = IX - INCX X( IX ) = X( IX ) - TEMP*AP( K ) 30 CONTINUE END IF JX = JX - INCX KK = KK - J 40 CONTINUE END IF ELSE KK = 1 IF( INCX.EQ.1 )THEN DO 60, J = 1, N IF( X( J ).NE.ZERO )THEN IF( NOUNIT ) $ X( J ) = X( J )/AP( KK ) TEMP = X( J ) K = KK + 1 DO 50, I = J + 1, N X( I ) = X( I ) - TEMP*AP( K ) K = K + 1 50 CONTINUE END IF KK = KK + ( N - J + 1 ) 60 CONTINUE ELSE JX = KX DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN IF( NOUNIT ) $ X( JX ) = X( JX )/AP( KK ) TEMP = X( JX ) IX = JX DO 70, K = KK + 1, KK + N - J IX = IX + INCX X( IX ) = X( IX ) - TEMP*AP( K ) 70 CONTINUE END IF JX = JX + INCX KK = KK + ( N - J + 1 ) 80 CONTINUE END IF END IF ELSE C C Form x := inv( A' )*x. C IF( LSAME( UPLO, 'U' ) )THEN KK = 1 IF( INCX.EQ.1 )THEN DO 100, J = 1, N TEMP = X( J ) K = KK DO 90, I = 1, J - 1 TEMP = TEMP - AP( K )*X( I ) K = K + 1 90 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/AP( KK + J - 1 ) X( J ) = TEMP KK = KK + J 100 CONTINUE ELSE JX = KX DO 120, J = 1, N TEMP = X( JX ) IX = KX DO 110, K = KK, KK + J - 2 TEMP = TEMP - AP( K )*X( IX ) IX = IX + INCX 110 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/AP( KK + J - 1 ) X( JX ) = TEMP JX = JX + INCX KK = KK + J 120 CONTINUE END IF ELSE KK = ( N*( N + 1 ) )/2 IF( INCX.EQ.1 )THEN DO 140, J = N, 1, -1 TEMP = X( J ) K = KK DO 130, I = N, J + 1, -1 TEMP = TEMP - AP( K )*X( I ) K = K - 1 130 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/AP( KK - N + J ) X( J ) = TEMP KK = KK - ( N - J + 1 ) 140 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 160, J = N, 1, -1 TEMP = X( JX ) IX = KX DO 150, K = KK, KK - ( N - ( J + 1 ) ), -1 TEMP = TEMP - AP( K )*X( IX ) IX = IX - INCX 150 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/AP( KK - N + J ) X( JX ) = TEMP JX = JX - INCX KK = KK - (N - J + 1 ) 160 CONTINUE END IF END IF END IF C RETURN C C End of DTPSV . C END SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ B, LDB ) C .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDB DOUBLE PRECISION ALPHA C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) C .. C C Purpose C ======= C C DTRMM performs one of the matrix-matrix operations C C B := alpha*op( A )*B, or B := alpha*B*op( A ), C C where alpha is a scalar, B is an m by n matrix, A is a unit, or C non-unit, upper or lower triangular matrix and op( A ) is one of C C op( A ) = A or op( A ) = A'. C C Parameters C ========== C C SIDE - CHARACTER*1. C On entry, SIDE specifies whether op( A ) multiplies B from C the left or right as follows: C C SIDE = 'L' or 'l' B := alpha*op( A )*B. C C SIDE = 'R' or 'r' B := alpha*B*op( A ). C C Unchanged on exit. C C UPLO - CHARACTER*1. C On entry, UPLO specifies whether the matrix A is an upper or C lower triangular matrix as follows: C C UPLO = 'U' or 'u' A is an upper triangular matrix. C C UPLO = 'L' or 'l' A is a lower triangular matrix. C C Unchanged on exit. C C TRANSA - CHARACTER*1. C On entry, TRANSA specifies the form of op( A ) to be used in C the matrix multiplication as follows: C C TRANSA = 'N' or 'n' op( A ) = A. C C TRANSA = 'T' or 't' op( A ) = A'. C C TRANSA = 'C' or 'c' op( A ) = A'. C C Unchanged on exit. C C DIAG - CHARACTER*1. C On entry, DIAG specifies whether or not A is unit triangular C as follows: C C DIAG = 'U' or 'u' A is assumed to be unit triangular. C C DIAG = 'N' or 'n' A is not assumed to be unit C triangular. C C Unchanged on exit. C C M - INTEGER. C On entry, M specifies the number of rows of B. M must be at C least zero. C Unchanged on exit. C C N - INTEGER. C On entry, N specifies the number of columns of B. N must be C at least zero. C Unchanged on exit. C C ALPHA - DOUBLE PRECISION. C On entry, ALPHA specifies the scalar alpha. When alpha is C zero then A is not referenced and B need not be set before C entry. C Unchanged on exit. C C A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m C when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. C Before entry with UPLO = 'U' or 'u', the leading k by k C upper triangular part of the array A must contain the upper C triangular matrix and the strictly lower triangular part of C A is not referenced. C Before entry with UPLO = 'L' or 'l', the leading k by k C lower triangular part of the array A must contain the lower C triangular matrix and the strictly upper triangular part of C A is not referenced. C Note that when DIAG = 'U' or 'u', the diagonal elements of C A are not referenced either, but are assumed to be unity. C Unchanged on exit. C C LDA - INTEGER. C On entry, LDA specifies the first dimension of A as declared C in the calling (sub) program. When SIDE = 'L' or 'l' then C LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' C then LDA must be at least max( 1, n ). C Unchanged on exit. C C B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). C Before entry, the leading m by n part of the array B must C contain the matrix B, and on exit is overwritten by the C transformed matrix. C C LDB - INTEGER. C On entry, LDB specifies the first dimension of B as declared C in the calling (sub) program. LDB must be at least C max( 1, m ). C Unchanged on exit. C C C Level 3 Blas routine. C C -- Written on 8-February-1989. C Jack Dongarra, Argonne National Laboratory. C Iain Duff, AERE Harwell. C Jeremy Du Croz, Numerical Algorithms Group Ltd. C Sven Hammarling, Numerical Algorithms Group Ltd. C C C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Local Scalars .. LOGICAL LSIDE, NOUNIT, UPPER INTEGER I, INFO, J, K, NROWA DOUBLE PRECISION TEMP C .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. C .. Executable Statements .. C C Test the input parameters. C LSIDE = LSAME( SIDE , 'L' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF NOUNIT = LSAME( DIAG , 'N' ) UPPER = LSAME( UPLO , 'U' ) C INFO = 0 IF( ( .NOT.LSIDE ).AND. $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND. $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 2 ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN INFO = 4 ELSE IF( M .LT.0 )THEN INFO = 5 ELSE IF( N .LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DTRMM ', INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN C C And when alpha.eq.zero. C IF( ALPHA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE RETURN END IF C C Start the operations. C IF( LSIDE )THEN IF( LSAME( TRANSA, 'N' ) )THEN C C Form B := alpha*A*B. C IF( UPPER )THEN DO 50, J = 1, N DO 40, K = 1, M IF( B( K, J ).NE.ZERO )THEN TEMP = ALPHA*B( K, J ) DO 30, I = 1, K - 1 B( I, J ) = B( I, J ) + TEMP*A( I, K ) 30 CONTINUE IF( NOUNIT ) $ TEMP = TEMP*A( K, K ) B( K, J ) = TEMP END IF 40 CONTINUE 50 CONTINUE ELSE DO 80, J = 1, N DO 70 K = M, 1, -1 IF( B( K, J ).NE.ZERO )THEN TEMP = ALPHA*B( K, J ) B( K, J ) = TEMP IF( NOUNIT ) $ B( K, J ) = B( K, J )*A( K, K ) DO 60, I = K + 1, M B( I, J ) = B( I, J ) + TEMP*A( I, K ) 60 CONTINUE END IF 70 CONTINUE 80 CONTINUE END IF ELSE C C Form B := alpha*B*A'. C IF( UPPER )THEN DO 110, J = 1, N DO 100, I = M, 1, -1 TEMP = B( I, J ) IF( NOUNIT ) $ TEMP = TEMP*A( I, I ) DO 90, K = 1, I - 1 TEMP = TEMP + A( K, I )*B( K, J ) 90 CONTINUE B( I, J ) = ALPHA*TEMP 100 CONTINUE 110 CONTINUE ELSE DO 140, J = 1, N DO 130, I = 1, M TEMP = B( I, J ) IF( NOUNIT ) $ TEMP = TEMP*A( I, I ) DO 120, K = I + 1, M TEMP = TEMP + A( K, I )*B( K, J ) 120 CONTINUE B( I, J ) = ALPHA*TEMP 130 CONTINUE 140 CONTINUE END IF END IF ELSE IF( LSAME( TRANSA, 'N' ) )THEN C C Form B := alpha*B*A. C IF( UPPER )THEN DO 180, J = N, 1, -1 TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 150, I = 1, M B( I, J ) = TEMP*B( I, J ) 150 CONTINUE DO 170, K = 1, J - 1 IF( A( K, J ).NE.ZERO )THEN TEMP = ALPHA*A( K, J ) DO 160, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 160 CONTINUE END IF 170 CONTINUE 180 CONTINUE ELSE DO 220, J = 1, N TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 190, I = 1, M B( I, J ) = TEMP*B( I, J ) 190 CONTINUE DO 210, K = J + 1, N IF( A( K, J ).NE.ZERO )THEN TEMP = ALPHA*A( K, J ) DO 200, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 200 CONTINUE END IF 210 CONTINUE 220 CONTINUE END IF ELSE C C Form B := alpha*B*A'. C IF( UPPER )THEN DO 260, K = 1, N DO 240, J = 1, K - 1 IF( A( J, K ).NE.ZERO )THEN TEMP = ALPHA*A( J, K ) DO 230, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 230 CONTINUE END IF 240 CONTINUE TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( K, K ) IF( TEMP.NE.ONE )THEN DO 250, I = 1, M B( I, K ) = TEMP*B( I, K ) 250 CONTINUE END IF 260 CONTINUE ELSE DO 300, K = N, 1, -1 DO 280, J = K + 1, N IF( A( J, K ).NE.ZERO )THEN TEMP = ALPHA*A( J, K ) DO 270, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 270 CONTINUE END IF 280 CONTINUE TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( K, K ) IF( TEMP.NE.ONE )THEN DO 290, I = 1, M B( I, K ) = TEMP*B( I, K ) 290 CONTINUE END IF 300 CONTINUE END IF END IF END IF C RETURN C C End of DTRMM . C END SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) C .. Scalar Arguments .. INTEGER INCX, LDA, N CHARACTER*1 DIAG, TRANS, UPLO C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ) C .. C C Purpose C ======= C C DTRMV performs one of the matrix-vector operations C C x := A*x, or x := A'*x, C C where x is an n element vector and A is an n by n unit, or non-unit, C upper or lower triangular matrix. C C Parameters C ========== C C UPLO - CHARACTER*1. C On entry, UPLO specifies whether the matrix is an upper or C lower triangular matrix as follows: C C UPLO = 'U' or 'u' A is an upper triangular matrix. C C UPLO = 'L' or 'l' A is a lower triangular matrix. C C Unchanged on exit. C C TRANS - CHARACTER*1. C On entry, TRANS specifies the operation to be performed as C follows: C C TRANS = 'N' or 'n' x := A*x. C C TRANS = 'T' or 't' x := A'*x. C C TRANS = 'C' or 'c' x := A'*x. C C Unchanged on exit. C C DIAG - CHARACTER*1. C On entry, DIAG specifies whether or not A is unit C triangular as follows: C C DIAG = 'U' or 'u' A is assumed to be unit triangular. C C DIAG = 'N' or 'n' A is not assumed to be unit C triangular. C C Unchanged on exit. C C N - INTEGER. C On entry, N specifies the order of the matrix A. C N must be at least zero. C Unchanged on exit. C C A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). C Before entry with UPLO = 'U' or 'u', the leading n by n C upper triangular part of the array A must contain the upper C triangular matrix and the strictly lower triangular part of C A is not referenced. C Before entry with UPLO = 'L' or 'l', the leading n by n C lower triangular part of the array A must contain the lower C triangular matrix and the strictly upper triangular part of C A is not referenced. C Note that when DIAG = 'U' or 'u', the diagonal elements of C A are not referenced either, but are assumed to be unity. C Unchanged on exit. C C LDA - INTEGER. C On entry, LDA specifies the first dimension of A as declared C in the calling (sub) program. LDA must be at least C max( 1, n ). C Unchanged on exit. C C X - DOUBLE PRECISION array of dimension at least C ( 1 + ( n - 1 )*abs( INCX ) ). C Before entry, the incremented array X must contain the n C element vector x. On exit, X is overwritten with the C tranformed vector x. C C INCX - INTEGER. C On entry, INCX specifies the increment for the elements of C X. INCX must not be zero. C Unchanged on exit. C C C Level 2 Blas routine. C C -- Written on 22-October-1986. C Jack Dongarra, Argonne National Lab. C Jeremy Du Croz, Nag Central Office. C Sven Hammarling, Nag Central Office. C Richard Hanson, Sandia National Labs. C C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) C .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JX, KX LOGICAL NOUNIT C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 IF ( .NOT.LSAME( UPLO , 'U' ).AND. $ .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. $ .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DTRMV ', INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN C NOUNIT = LSAME( DIAG, 'N' ) C C Set up the start point in X if the increment is not unity. This C will be ( N - 1 )*INCX too small for descending loops. C IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF C C Start the operations. In this version the elements of A are C accessed sequentially with one pass through A. C IF( LSAME( TRANS, 'N' ) )THEN C C Form x := A*x. C IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( X( J ).NE.ZERO )THEN TEMP = X( J ) DO 10, I = 1, J - 1 X( I ) = X( I ) + TEMP*A( I, J ) 10 CONTINUE IF( NOUNIT ) $ X( J ) = X( J )*A( J, J ) END IF 20 CONTINUE ELSE JX = KX DO 40, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = X( JX ) IX = KX DO 30, I = 1, J - 1 X( IX ) = X( IX ) + TEMP*A( I, J ) IX = IX + INCX 30 CONTINUE IF( NOUNIT ) $ X( JX ) = X( JX )*A( J, J ) END IF JX = JX + INCX 40 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 60, J = N, 1, -1 IF( X( J ).NE.ZERO )THEN TEMP = X( J ) DO 50, I = N, J + 1, -1 X( I ) = X( I ) + TEMP*A( I, J ) 50 CONTINUE IF( NOUNIT ) $ X( J ) = X( J )*A( J, J ) END IF 60 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 80, J = N, 1, -1 IF( X( JX ).NE.ZERO )THEN TEMP = X( JX ) IX = KX DO 70, I = N, J + 1, -1 X( IX ) = X( IX ) + TEMP*A( I, J ) IX = IX - INCX 70 CONTINUE IF( NOUNIT ) $ X( JX ) = X( JX )*A( J, J ) END IF JX = JX - INCX 80 CONTINUE END IF END IF ELSE C C Form x := A'*x. C IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 100, J = N, 1, -1 TEMP = X( J ) IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 90, I = J - 1, 1, -1 TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE X( J ) = TEMP 100 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 120, J = N, 1, -1 TEMP = X( JX ) IX = JX IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 110, I = J - 1, 1, -1 IX = IX - INCX TEMP = TEMP + A( I, J )*X( IX ) 110 CONTINUE X( JX ) = TEMP JX = JX - INCX 120 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 140, J = 1, N TEMP = X( J ) IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 130, I = J + 1, N TEMP = TEMP + A( I, J )*X( I ) 130 CONTINUE X( J ) = TEMP 140 CONTINUE ELSE JX = KX DO 160, J = 1, N TEMP = X( JX ) IX = JX IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 150, I = J + 1, N IX = IX + INCX TEMP = TEMP + A( I, J )*X( IX ) 150 CONTINUE X( JX ) = TEMP JX = JX + INCX 160 CONTINUE END IF END IF END IF C RETURN C C End of DTRMV . C END SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ B, LDB ) C .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDB DOUBLE PRECISION ALPHA C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) C .. C C Purpose C ======= C C DTRSM solves one of the matrix equations C C op( A )*X = alpha*B, or X*op( A ) = alpha*B, C C where alpha is a scalar, X and B are m by n matrices, A is a unit, or C non-unit, upper or lower triangular matrix and op( A ) is one of C C op( A ) = A or op( A ) = A'. C C The matrix X is overwritten on B. C C Parameters C ========== C C SIDE - CHARACTER*1. C On entry, SIDE specifies whether op( A ) appears on the left C or right of X as follows: C C SIDE = 'L' or 'l' op( A )*X = alpha*B. C C SIDE = 'R' or 'r' X*op( A ) = alpha*B. C C Unchanged on exit. C C UPLO - CHARACTER*1. C On entry, UPLO specifies whether the matrix A is an upper or C lower triangular matrix as follows: C C UPLO = 'U' or 'u' A is an upper triangular matrix. C C UPLO = 'L' or 'l' A is a lower triangular matrix. C C Unchanged on exit. C C TRANSA - CHARACTER*1. C On entry, TRANSA specifies the form of op( A ) to be used in C the matrix multiplication as follows: C C TRANSA = 'N' or 'n' op( A ) = A. C C TRANSA = 'T' or 't' op( A ) = A'. C C TRANSA = 'C' or 'c' op( A ) = A'. C C Unchanged on exit. C C DIAG - CHARACTER*1. C On entry, DIAG specifies whether or not A is unit triangular C as follows: C C DIAG = 'U' or 'u' A is assumed to be unit triangular. C C DIAG = 'N' or 'n' A is not assumed to be unit C triangular. C C Unchanged on exit. C C M - INTEGER. C On entry, M specifies the number of rows of B. M must be at C least zero. C Unchanged on exit. C C N - INTEGER. C On entry, N specifies the number of columns of B. N must be C at least zero. C Unchanged on exit. C C ALPHA - DOUBLE PRECISION. C On entry, ALPHA specifies the scalar alpha. When alpha is C zero then A is not referenced and B need not be set before C entry. C Unchanged on exit. C C A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m C when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. C Before entry with UPLO = 'U' or 'u', the leading k by k C upper triangular part of the array A must contain the upper C triangular matrix and the strictly lower triangular part of C A is not referenced. C Before entry with UPLO = 'L' or 'l', the leading k by k C lower triangular part of the array A must contain the lower C triangular matrix and the strictly upper triangular part of C A is not referenced. C Note that when DIAG = 'U' or 'u', the diagonal elements of C A are not referenced either, but are assumed to be unity. C Unchanged on exit. C C LDA - INTEGER. C On entry, LDA specifies the first dimension of A as declared C in the calling (sub) program. When SIDE = 'L' or 'l' then C LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' C then LDA must be at least max( 1, n ). C Unchanged on exit. C C B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). C Before entry, the leading m by n part of the array B must C contain the right-hand side matrix B, and on exit is C overwritten by the solution matrix X. C C LDB - INTEGER. C On entry, LDB specifies the first dimension of B as declared C in the calling (sub) program. LDB must be at least C max( 1, m ). C Unchanged on exit. C C C Level 3 Blas routine. C C C -- Written on 8-February-1989. C Jack Dongarra, Argonne National Laboratory. C Iain Duff, AERE Harwell. C Jeremy Du Croz, Numerical Algorithms Group Ltd. C Sven Hammarling, Numerical Algorithms Group Ltd. C C C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA C .. Intrinsic Functions .. INTRINSIC MAX C .. Local Scalars .. LOGICAL LSIDE, NOUNIT, UPPER INTEGER I, INFO, J, K, NROWA DOUBLE PRECISION TEMP C .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. C .. Executable Statements .. C C Test the input parameters. C LSIDE = LSAME( SIDE , 'L' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF NOUNIT = LSAME( DIAG , 'N' ) UPPER = LSAME( UPLO , 'U' ) C INFO = 0 IF( ( .NOT.LSIDE ).AND. $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND. $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 2 ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN INFO = 4 ELSE IF( M .LT.0 )THEN INFO = 5 ELSE IF( N .LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DTRSM ', INFO ) RETURN END IF C C Quick return if possible. C IF( N.EQ.0 ) $ RETURN C C And when alpha.eq.zero. C IF( ALPHA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE RETURN END IF C C Start the operations. C IF( LSIDE )THEN IF( LSAME( TRANSA, 'N' ) )THEN C C Form B := alpha*inv( A )*B. C IF( UPPER )THEN DO 60, J = 1, N IF( ALPHA.NE.ONE )THEN DO 30, I = 1, M B( I, J ) = ALPHA*B( I, J ) 30 CONTINUE END IF DO 50, K = M, 1, -1 IF( B( K, J ).NE.ZERO )THEN IF( NOUNIT ) $ B( K, J ) = B( K, J )/A( K, K ) DO 40, I = 1, K - 1 B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) 40 CONTINUE END IF 50 CONTINUE 60 CONTINUE ELSE DO 100, J = 1, N IF( ALPHA.NE.ONE )THEN DO 70, I = 1, M B( I, J ) = ALPHA*B( I, J ) 70 CONTINUE END IF DO 90 K = 1, M IF( B( K, J ).NE.ZERO )THEN IF( NOUNIT ) $ B( K, J ) = B( K, J )/A( K, K ) DO 80, I = K + 1, M B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) 80 CONTINUE END IF 90 CONTINUE 100 CONTINUE END IF ELSE C C Form B := alpha*inv( A' )*B. C IF( UPPER )THEN DO 130, J = 1, N DO 120, I = 1, M TEMP = ALPHA*B( I, J ) DO 110, K = 1, I - 1 TEMP = TEMP - A( K, I )*B( K, J ) 110 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( I, I ) B( I, J ) = TEMP 120 CONTINUE 130 CONTINUE ELSE DO 160, J = 1, N DO 150, I = M, 1, -1 TEMP = ALPHA*B( I, J ) DO 140, K = I + 1, M TEMP = TEMP - A( K, I )*B( K, J ) 140 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( I, I ) B( I, J ) = TEMP 150 CONTINUE 160 CONTINUE END IF END IF ELSE IF( LSAME( TRANSA, 'N' ) )THEN C C Form B := alpha*B*inv( A ). C IF( UPPER )THEN DO 210, J = 1, N IF( ALPHA.NE.ONE )THEN DO 170, I = 1, M B( I, J ) = ALPHA*B( I, J ) 170 CONTINUE END IF DO 190, K = 1, J - 1 IF( A( K, J ).NE.ZERO )THEN DO 180, I = 1, M B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) 180 CONTINUE END IF 190 CONTINUE IF( NOUNIT )THEN TEMP = ONE/A( J, J ) DO 200, I = 1, M B( I, J ) = TEMP*B( I, J ) 200 CONTINUE END IF 210 CONTINUE ELSE DO 260, J = N, 1, -1 IF( ALPHA.NE.ONE )THEN DO 220, I = 1, M B( I, J ) = ALPHA*B( I, J ) 220 CONTINUE END IF DO 240, K = J + 1, N IF( A( K, J ).NE.ZERO )THEN DO 230, I = 1, M B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) 230 CONTINUE END IF 240 CONTINUE IF( NOUNIT )THEN TEMP = ONE/A( J, J ) DO 250, I = 1, M B( I, J ) = TEMP*B( I, J ) 250 CONTINUE END IF 260 CONTINUE END IF ELSE C C Form B := alpha*B*inv( A' ). C IF( UPPER )THEN DO 310, K = N, 1, -1 IF( NOUNIT )THEN TEMP = ONE/A( K, K ) DO 270, I = 1, M B( I, K ) = TEMP*B( I, K ) 270 CONTINUE END IF DO 290, J = 1, K - 1 IF( A( J, K ).NE.ZERO )THEN TEMP = A( J, K ) DO 280, I = 1, M B( I, J ) = B( I, J ) - TEMP*B( I, K ) 280 CONTINUE END IF 290 CONTINUE IF( ALPHA.NE.ONE )THEN DO 300, I = 1, M B( I, K ) = ALPHA*B( I, K ) 300 CONTINUE END IF 310 CONTINUE ELSE DO 360, K = 1, N IF( NOUNIT )THEN TEMP = ONE/A( K, K ) DO 320, I = 1, M B( I, K ) = TEMP*B( I, K ) 320 CONTINUE END IF DO 340, J = K + 1, N IF( A( J, K ).NE.ZERO )THEN TEMP = A( J, K ) DO 330, I = 1, M B( I, J ) = B( I, J ) - TEMP*B( I, K ) 330 CONTINUE END IF 340 CONTINUE IF( ALPHA.NE.ONE )THEN DO 350, I = 1, M B( I, K ) = ALPHA*B( I, K ) 350 CONTINUE END IF 360 CONTINUE END IF END IF END IF C RETURN C C End of DTRSM . C END INTEGER FUNCTION IDAMAX(N,DX,INCX) C C finds the index of element having max. absolute value. C jack dongarra, linpack, 3/11/78. C modified to correct problem with negative increment, 8/21/90. C DOUBLE PRECISION DX(1),DMAX INTEGER I,INCX,IX,N C IDAMAX = 0 IF( N .LT. 1 ) RETURN IDAMAX = 1 IF(N.EQ.1)RETURN IF(INCX.EQ.1)GO TO 20 C C code for increment not equal to 1 C IX = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 DMAX = DABS(DX(IX)) IX = IX + INCX DO 10 I = 2,N IF(DABS(DX(IX)).LE.DMAX) GO TO 5 IDAMAX = I DMAX = DABS(DX(IX)) 5 IX = IX + INCX 10 CONTINUE RETURN C C code for increment equal to 1 C 20 DMAX = DABS(DX(1)) DO 30 I = 2,N IF(DABS(DX(I)).LE.DMAX) GO TO 30 IDAMAX = I DMAX = DABS(DX(I)) 30 CONTINUE RETURN END LOGICAL FUNCTION LSAME( CA, CB ) C C -- LAPACK auxiliary routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. C C Modified by Bob Fay May 11, 1993 to enable ICHAR call C C CHARACTER CA, CB C CHARACTER CA, CB, CZ C .. C C Purpose C ======= C C LSAME returns .TRUE. if CA is the same letter as CB regardless of C case. C C Arguments C ========= C C CA (input) CHARACTER*1 C CB (input) CHARACTER*1 C CA and CB specify the single characters to be compared. C C .. Intrinsic Functions .. INTRINSIC ICHAR C .. C .. Local Scalars .. INTEGER INTA, INTB, ZCODE C .. C C Added by Bob Fay May 11, 1993 C DATA CZ/'Z'/ C C .. Executable Statements .. C C Test if the characters are equal C LSAME = CA.EQ.CB IF( LSAME ) $ RETURN C C Now test for equivalence if both characters are alphabetic. C ZCODE = ICHAR( CZ ) C C Use 'Z' rather than 'A' so that ASCII can be detected on Prime C machines, on which ICHAR returns a value with bit 8 set. C ICHAR('A') on Prime machines returns 193 which is the same as C ICHAR('A') on an EBCDIC machine. C INTA = ICHAR( CA ) INTB = ICHAR( CB ) C IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN C C ASCII is assumed - ZCODE is the ASCII code of either lower or C upper case 'Z'. C IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 C ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN C C EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or C upper case 'Z'. C IF( INTA.GE.129 .AND. INTA.LE.137 .OR. $ INTA.GE.145 .AND. INTA.LE.153 .OR. $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 IF( INTB.GE.129 .AND. INTB.LE.137 .OR. $ INTB.GE.145 .AND. INTB.LE.153 .OR. $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 C ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN C C ASCII is assumed, on Prime machines - ZCODE is the ASCII code C plus 128 of either lower or upper case 'Z'. C IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 END IF LSAME = INTA.EQ.INTB C C RETURN C C End of LSAME C END SUBROUTINE XERBLA( SRNAME, INFO ) C C -- LAPACK auxiliary routine (preliminary version) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. CHARACTER*6 SRNAME INTEGER INFO C .. C C Purpose C ======= C C XERBLA is an error handler for the LAPACK routines. C It is called by an LAPACK routine if an input parameter has an C invalid value. A message is printed and execution stops. C C Installers may consider modifying the STOP statement in order to C call system-specific exception-handling facilities. C C Arguments C ========= C C SRNAME (input) CHARACTER*6 C The name of the routine which called XERBLA. C C INFO (input) INTEGER C The position of the invalid parameter in the parameter list C of the calling routine. C C WRITE( *, FMT = 9999 )SRNAME, INFO C STOP C 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', $ 'an illegal value' ) C C End of XERBLA C END SUBROUTINE DSPMM ( UPLO, TRANSB, M, N, ALPHA, AP, B, LDB, BETA, C, . LDC ) C .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA INTEGER M, N, LDB, LDC CHARACTER*1 UPLO, TRANSB C .. Array Arguments .. DOUBLE PRECISION AP( * ), B( LDB, * ), C( LDC, * ) C .. C C Purpose C ======= C C DSPMM performs one of the matrix-matrix operations C C C := alpha*A*op( B ) + beta*C, C C where op( B ) is one of C C op( B ) = B or op( B ) = B', C C where alpha and beta are scalars, B and C are matrices, and C A is an n by n symmetric matrix, supplied in packed form. C C Parameters C ========== C C UPLO - CHARACTER*1. C On entry, UPLO specifies whether the upper or lower C triangular part of the matrix A is supplied in the packed C array AP as follows: C C UPLO = 'U' or 'u' The upper triangular part of A is C supplied in AP. C C UPLO = 'L' or 'l' The lower triangular part of A is C supplied in AP. C C Unchanged on exit. C C TRANSB - CHARACTER*1. C On entry, TRANSB specifies the form of op( B ) to be used in C the matrix multiplication as follows: C C TRANSB = 'N' or 'n', op( B ) = B. C C TRANSB = 'T' or 't', op( B ) = B'. C C TRANSB = 'C' or 'c', op( B ) = B'. C C Unchanged on exit. C C M - INTEGER. C On entry, M specifies the order of the matrix A and C the number of rows of op( B ). C M must be at least zero. C Unchanged on exit. C C N - INTEGER C On entry, N specifies the number of columns of the matrix C op( B ) and the number of columns of the matrix C. C N must be at least zero. C Unchanged on exit. C C ALPHA - DOUBLE PRECISION. C On entry, ALPHA specifies the scalar alpha. C Unchanged on exit. C C AP - DOUBLE PRECISION array of DIMENSION at least C ( ( m*( m + 1 ) )/2 ). C Before entry with UPLO = 'U' or 'u', the array AP must C contain the upper triangular part of the symmetric matrix C packed sequentially, column by column, so that AP( 1 ) C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) C and a( 2, 2 ) respectively, and so on. C Before entry with UPLO = 'L' or 'l', the array AP must C contain the lower triangular part of the symmetric matrix C packed sequentially, column by column, so that AP( 1 ) C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) C and a( 3, 1 ) respectively, and so on. C Unchanged on exit. C C B - DOUBLE PRECISION array of DIMENSION ( LDB, kb), where C kb is n when TRANSB = 'N' or 'n', and is m otherwise. C Before entry with TRANSB = 'N' or 'n', the leading C m by n part of the array B must contain the matrix B, C otherwise, the leading n by m part of the array B must C contain the matrix B. C Unchanged on exit. C C LDB - INTEGER. C On entry, LDB specifies the first dimension of the array B C as declared in the calling (sub) program. C When TRANSB = 'N' or 'n' then LDB must be at least C max( 1, m ), otherwise LDB must be at least max( 1, n). C Unchanged on exit. C C BETA - DOUBLE PRECISION. C On entry, BETA specifies the scalar beta. When BETA is C supplied as zero then C need not be set on input. C Unchanged on exit. C C C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). C Before entry, the leading m by n part of the array C must C contain the matrix C, except when beta is zero, in which C case C need not be set on entry. C On exit, the array C is overwritten by the m by n matrix C ( alpha*A*op( B ) + beta*C ). C C LDC - INTEGER. C On entry, LDC specifies the first dimension of C as declared C in the calling (sub) program. LDC must be at least C max( 1, m ). C Unchanged on exit. C C C C C Modified version of DSPMV, a Level 2 Blas routine. C C C C -- DSPMV was written on 22-October-1986. C Jack Dongarra, Argonne National Lab. C Jeremy Du Croz, Nag Central Office. C Sven Hammarling, Nag Central Office. C Richard Hanson, Sandia National Labs. C C Modified on 4-August-1993. C Bob Fay, U.S. Bureau of the Census C C .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. Local Scalars .. LOGICAL NOTB DOUBLE PRECISION TEMP1, TEMP2 INTEGER I, INFO, J, K, KK, L, NROWB C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA C .. C .. Executable Statements .. C C Test the input parameters. C NOTB = LSAME( TRANSB, 'N' ) IF( NOTB )THEN NROWB = M ELSE NROWB = N END IF INFO = 0 IF ( .NOT.LSAME( UPLO, 'U' ).AND. $ .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTB ).AND. . ( .NOT.LSAME( TRANSB, 'C') ).AND. . ( .NOT.LSAME( TRANSB, 'T') ) )THEN INFO = 2 ELSE IF( M .LT.0 )THEN INFO = 3 ELSE IF( N .LT.0 )THEN INFO = 4 ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN INFO = 8 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DSPMM ', INFO ) RETURN END IF C C Quick return if possible. C IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN C C And if alpha.eq.zero. C IF( ALPHA.EQ.ZERO )THEN IF( BETA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, M C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE END IF RETURN END IF C C Start the operations. The elements of the array AP are accessed C sequentially with one pass through AP for each column of C. C IF( LSAME( UPLO, 'U' ) )THEN C C Form C when AP contains the upper triangle. C IF( NOTB )THEN C C Form C := alpha*A*B + beta*C C DO 90, J = 1, N KK = 1 IF( BETA.EQ.ZERO )THEN DO 50, I = 1, M C( I, J ) = ZERO 50 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 60, I = 1, M C( I, J ) = BETA*C( I, J ) 60 CONTINUE END IF DO 80, L = 1, M TEMP1 = ALPHA*B( L, J ) TEMP2 = ZERO K = KK DO 70, I = 1, L - 1 C( I, J ) = C( I, J ) + TEMP1*AP( K ) TEMP2 = TEMP2 + AP( K )*B( I, J ) K = K + 1 70 CONTINUE C( L, J ) = C( L, J ) + TEMP1*AP( KK + L - 1 ) . + ALPHA*TEMP2 KK = KK + L 80 CONTINUE 90 CONTINUE ELSE C C Form C := alpha*A*B' + beta*C C DO 140, J = 1, N KK = 1 IF( BETA.EQ.ZERO )THEN DO 100, I = 1, M C( I, J ) = ZERO 100 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 110, I = 1, M C( I, J ) = BETA*C( I, J ) 110 CONTINUE END IF DO 130, L = 1, M TEMP1 = ALPHA*B( J, L ) TEMP2 = ZERO K = KK DO 120, I = 1, L - 1 C( I, J ) = C( I, J ) + TEMP1*AP( K ) TEMP2 = TEMP2 + AP( K )*B( J, I ) K = K + 1 120 CONTINUE C( L, J ) = C( L, J ) + TEMP1*AP( KK + L - 1 ) . + ALPHA*TEMP2 KK = KK + L 130 CONTINUE 140 CONTINUE END IF ELSE C C Form C when AP contains the lower triangle. C IF( NOTB )THEN C C Form C := alpha*A*B + beta*C C DO 190, J = 1, N KK = 1 IF( BETA.EQ.ZERO )THEN DO 150, I = 1, M C( I, J ) = ZERO 150 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 160, I = 1, M C( I, J ) = BETA*C( I, J ) 160 CONTINUE END IF DO 180, L = 1, M TEMP1 = ALPHA*B( L, J ) TEMP2 = ZERO C( L, J ) = C( L, J ) + TEMP1*AP(KK) K = KK + 1 DO 170, I = L + 1, N C( I, J ) = C( I, J ) + TEMP1*AP( K ) TEMP2 = TEMP2 + AP( K )*B( I, J ) K = K + 1 170 CONTINUE C( L, J ) = C( L, J ) + ALPHA*TEMP2 KK = KK + ( M - L + 1 ) 180 CONTINUE 190 CONTINUE ELSE C C Form C := alpha*A*B' + beta*C C DO 240, J = 1, N KK = 1 IF( BETA.EQ.ZERO )THEN DO 200, I = 1, M C( I, J ) = ZERO 200 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 210, I = 1, M C( I, J ) = BETA*C( I, J ) 210 CONTINUE END IF DO 230, L = 1, M TEMP1 = ALPHA*B( J, L ) TEMP2 = ZERO C( L, J ) = C( L, J ) + TEMP1*AP(KK) K = KK + 1 DO 220, I = L + 1, N C( I, J ) = C( I, J ) + TEMP1*AP( K ) TEMP2 = TEMP2 + AP( K )*B( J, I ) K = K + 1 220 CONTINUE C( L, J ) = C( L, J ) + ALPHA*TEMP2 KK = KK + ( M - L + 1 ) 230 CONTINUE 240 CONTINUE END IF END IF C RETURN C C End of DSPMM . C END C SUBROUTINE DSPMP ( UPLO, N, ALPHA, AP, BP, BETA, C, LDC ) C .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA INTEGER N, LDC CHARACTER*1 UPLO C .. Array Arguments .. DOUBLE PRECISION AP( * ), BP( * ), C( LDC, * ) C .. C C Purpose C ======= C C DSPMP performs the matrix-matrix operation C C C := alpha*A*B + beta*C, C C where alpha and beta are scalars, C is a matrix, and C A and B are n by n symmetric matrices, supplied in packed form. C C Parameters C ========== C C UPLO - CHARACTER*1. C On entry, UPLO specifies whether the upper or lower C triangular parts of the matrices A and B are supplied C in the packed arrays AP and BP as follows: C C UPLO = 'U' or 'u' The upper triangular parts of A C and B are supplied in AP, BP C C UPLO = 'L' or 'l' The lower triangular parts of A C and B are supplied in AP, BP C C Unchanged on exit. C C N - INTEGER. C On entry, N specifies the order of the matrices A and B. C N must be at least zero. C Unchanged on exit. C C ALPHA - DOUBLE PRECISION. C On entry, ALPHA specifies the scalar alpha. C Unchanged on exit. C C AP - DOUBLE PRECISION array of DIMENSION at least C ( ( n*( n + 1 ) )/2 ). C Before entry with UPLO = 'U' or 'u', the array AP must C contain the upper triangular part of the symmetric matrix C packed sequentially, column by column, so that AP( 1 ) C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) C and a( 2, 2 ) respectively, and so on. C Before entry with UPLO = 'L' or 'l', the array AP must C contain the lower triangular part of the symmetric matrix C packed sequentially, column by column, so that AP( 1 ) C contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) C and a( 3, 1 ) respectively, and so on. C Unchanged on exit. C C BP - DOUBLE PRECISION array of DIMENSION at least C ( ( n*( n + 1 ) )/2 ). C Before entry with UPLO = 'U' or 'u', the array BP must C contain the upper triangular part of the symmetric matrix C packed sequentially, column by column, so that BP( 1 ) C contains b( 1, 1 ), BP( 2 ) and BP( 3 ) contain b( 1, 2 ) C and b( 2, 2 ) respectively, and so on. C Before entry with UPLO = 'L' or 'l', the array BP must C contain the lower triangular part of the symmetric matrix C packed sequentially, column by column, so that BP( 1 ) C contains b( 1, 1 ), BP( 2 ) and BP( 3 ) contain b( 2, 1 ) C and b( 3, 1 ) respectively, and so on. C Unchanged on exit. C C BETA - DOUBLE PRECISION. C On entry, BETA specifies the scalar beta. When BETA is C supplied as zero then C need not be set on input. C Unchanged on exit. C C C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). C Before entry, the leading n by n part of the array C must C contain the matrix C, except when beta is zero, in which C case C need not be set on entry. C On exit, the array C is overwritten by the n by n matrix C ( alpha*A*B + beta*C ). C C LDC - INTEGER. C On entry, LDC specifies the first dimension of C as declared C in the calling (sub) program. LDC must be at least C max( 1, n ). C Unchanged on exit. C C C C C Modified version of DSPMV, a Level 2 Blas routine. C C C C -- DSPMV was written on 22-October-1986. C Jack Dongarra, Argonne National Lab. C Jeremy Du Croz, Nag Central Office. C Sven Hammarling, Nag Central Office. C Richard Hanson, Sandia National Labs. C C Modified on 4-August-1993. C Bob Fay, U.S. Bureau of the Census C C .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. Local Scalars .. DOUBLE PRECISION TEMP1, TEMP2 INTEGER I, INFO, J, K, KB, KBB, KK, L C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL XERBLA C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 IF ( .NOT.LSAME( UPLO, 'U' ).AND. $ .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE IF( N .LT.0 )THEN INFO = 2 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 8 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DSPMP ', INFO ) RETURN END IF C C Quick return if possible. C IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN C C And if alpha.eq.zero. C IF( ALPHA.EQ.ZERO )THEN IF( BETA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, N C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, N C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE END IF RETURN END IF C C Start the operations. The elements of the array AP are accessed C sequentially with one pass through AP for each column of C. C IF( LSAME( UPLO, 'U' ) )THEN C C Form C when AP contains the upper triangle. C DO 90, J = 1, N KK = 1 KBB = ( J * (J-1))/2 + 1 IF( BETA.EQ.ZERO )THEN DO 50, I = 1, N C( I, J ) = ZERO 50 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 60, I = 1, N C( I, J ) = BETA*C( I, J ) 60 CONTINUE END IF DO 80, L = 1, N IF(L .LT. J)THEN KB = KBB + L - 1 ELSE KB = (L * (L - 1))/2 + J END IF TEMP1 = ALPHA*BP( KB ) KB = KBB TEMP2 = ZERO K = KK DO 70, I = 1, L - 1 C( I, J ) = C( I, J ) + TEMP1*AP( K ) TEMP2 = TEMP2 + AP( K )*BP( KB ) K = K + 1 IF( I .LT. J)THEN KB = KB + 1 ELSE KB = KB + I END IF 70 CONTINUE C( L, J ) = C( L, J ) + TEMP1*AP( KK + L - 1 ) . + ALPHA*TEMP2 KK = KK + L 80 CONTINUE 90 CONTINUE ELSE C C Form C when AP contains the lower triangle. C DO 140, J = 1, N KK = 1 IF( BETA.EQ.ZERO )THEN DO 100, I = 1, N C( I, J ) = ZERO 100 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 110, I = 1, N C( I, J ) = BETA*C( I, J ) 110 CONTINUE END IF DO 130, L = 1, N IF(L .LT. J) THEN KB = ( (L-1) * ( 2*N - L + 2 ) ) /2 + J - L + 1 ELSE KB = ( (J-1) * ( 2*N - J + 2 ) ) /2 + L - J + 1 END IF TEMP1 = ALPHA*BP( KB ) TEMP2 = ZERO C( L, J ) = C( L, J ) + TEMP1*AP( KK ) K = KK + 1 IF(L+1 .LT. J) THEN KB = ( L * ( 2*N - L + 1 ) ) /2 + J - L ELSE KB = ( (J-1) * ( 2*N - J + 2 ) ) /2 + L - J + 2 END IF DO 120, I = L + 1, N C( I, J ) = C( I, J ) + TEMP1*AP( K ) TEMP2 = TEMP2 + AP( K )*BP( KB ) K = K + 1 IF( I .LT. J)THEN KB = KB + N - I ELSE KB = KB + 1 END IF 120 CONTINUE C( L, J ) = C( L, J ) + ALPHA*TEMP2 KK = KK + ( N - L + 1 ) 130 CONTINUE 140 CONTINUE END IF C RETURN C C End of DSPMP . C END SUBROUTINE DPPTRF( UPLO, N, AP, INFO ) C C -- LAPACK routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, N C .. C .. Array Arguments .. DOUBLE PRECISION AP( * ) C .. C C Purpose C ======= C C DPPTRF computes the Cholesky factorization of a real symmetric C positive definite matrix A stored in packed format. C C The factorization has the form C A = U' * U , if UPLO = 'U', or C A = L * L', if UPLO = 'L', C where U is an upper triangular matrix and L is lower triangular. C C Arguments C ========= C C UPLO (input) CHARACTER*1 C Specifies whether the upper or lower triangular part of the C symmetric matrix A is stored: C = 'U': Upper triangular C = 'L': Lower triangular C C N (input) INTEGER C The order of the matrix A. N >= 0. C C AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) C On entry, the upper or lower triangle of the symmetric matrix C A, packed columnwise in a linear array. The j-th column of A C is stored in the array AP as follows: C if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; C if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. C See below for further details. C C On exit, if INFO = 0, the triangular factor U or L from the C Cholesky factorization A = U'*U or A = L*L', in the same C storage format as A. C C INFO (output) INTEGER C = 0: successful exit C < 0: if INFO = -k, the k-th argument had an illegal value C > 0: if INFO = k, the leading minor of order k is not C positive definite, and the factorization could not be C completed. C C Further Details C ======= ======= C C The packed storage scheme is illustrated by the following example C when N = 4, UPLO = 'U': C C Two-dimensional storage of the symmetric matrix A: C C a11 a12 a13 a14 C a22 a23 a24 C a33 a34 (aij = aji) C a44 C C Packed storage of the upper triangle of A: C C AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] C C ===================================================================== C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. C .. Local Scalars .. LOGICAL UPPER INTEGER J, JC, JJ DOUBLE PRECISION AJJ C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL LSAME, DDOT C .. C .. External Subroutines .. EXTERNAL DSCAL, DSPR, DTPSV, XERBLA C .. C .. Intrinsic Functions .. C INTRINSIC SQRT C .. changed by Bob Fay INTRINSIC DSQRT C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPPTRF', -INFO ) RETURN END IF C C Quick return if possible C IF( N.EQ.0 ) $ RETURN C IF( UPPER ) THEN C C Compute the Cholesky factorization A = U'*U. C JJ = 0 DO 10 J = 1, N JC = JJ + 1 JJ = JJ + J C C Compute elements 1:J-1 of column J. C IF( J.GT.1 ) $ CALL DTPSV( 'Upper', 'Transpose', 'Non-unit', J-1, AP, $ AP( JC ), 1 ) C C Compute U(J,J) and test for non-positive-definiteness. C AJJ = AP( JJ ) - DDOT( J-1, AP( JC ), 1, AP( JC ), 1 ) IF( AJJ.LE.ZERO ) THEN AP( JJ ) = AJJ GO TO 30 END IF AP( JJ ) = DSQRT( AJJ ) 10 CONTINUE ELSE C C Compute the Cholesky factorization A = LCL'. C JJ = 1 DO 20 J = 1, N C C Compute L(J,J) and test for non-positive-definiteness. C AJJ = AP( JJ ) IF( AJJ.LE.ZERO ) THEN AP( JJ ) = AJJ GO TO 30 END IF AJJ = DSQRT( AJJ ) AP( JJ ) = AJJ C C Compute elements J+1:N of column J and update the trailing C submatrix. C IF( J.LT.N ) THEN CALL DSCAL( N-J, ONE / AJJ, AP( JJ+1 ), 1 ) CALL DSPR( 'Lower', N-J, -ONE, AP( JJ+1 ), 1, $ AP( JJ+N-J+1 ) ) JJ = JJ + N - J + 1 END IF 20 CONTINUE END IF GO TO 40 C 30 CONTINUE INFO = J C 40 CONTINUE RETURN C C End of DPPTRF C END SUBROUTINE DPPTRI( UPLO, N, AP, INFO ) C C -- LAPACK routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, N C .. C .. Array Arguments .. DOUBLE PRECISION AP( * ) C .. C C Purpose C ======= C C DPPTRI computes the inverse of a real symmetric positive definite C matrix A using the Cholesky factorization A = U'*U or A = L*L' C computed by DPPTRF. C C Arguments C ========= C C UPLO (input) CHARACTER*1 C Specifies whether the factor stored in AP is upper or lower C triangular. C = 'U': Upper triangular C = 'L': Lower triangular C C N (input) INTEGER C The order of the matrix A. N >= 0. C C AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) C On entry, the triangular factor U or L from the Cholesky C factorization A = U'*U or A = L*L', packed columnwise as a C linear array. The j-th column of U or L is stored in the C array AP as follows: C if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; C if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. C C On exit, the upper or lower triangle of the (symmetric) C inverse of A, overwriting the input factor U or L. C C INFO (output) INTEGER C = 0: successful exit C < 0: if INFO = -k, the k-th argument had an illegal value C > 0: if INFO = k, the (k,k) element of the factor U or L is C zero, and the inverse could not be computed. C C ===================================================================== C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) C .. C .. Local Scalars .. LOGICAL UPPER INTEGER J, JC, JJ, JJN DOUBLE PRECISION AJJ C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL LSAME, DDOT C .. C .. External Subroutines .. EXTERNAL DSCAL, DSPR, DTPMV, DTPTRI, XERBLA C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPPTRI', -INFO ) RETURN END IF C C Quick return if possible C IF( N.EQ.0 ) $ RETURN C C Invert the triangular Cholesky factor U or L. C CALL DTPTRI( UPLO, 'Non-unit', N, AP, INFO ) IF( INFO.GT.0 ) $ RETURN C IF( UPPER ) THEN C C Compute the product inv(U) * inv(U)'. C JJ = 0 DO 10 J = 1, N JC = JJ + 1 JJ = JJ + J IF( J.GT.1 ) $ CALL DSPR( 'Upper', J-1, ONE, AP( JC ), 1, AP ) AJJ = AP( JJ ) CALL DSCAL( J, AJJ, AP( JC ), 1 ) 10 CONTINUE C ELSE C C Compute the product inv(L)' * inv(L). C JJ = 1 DO 20 J = 1, N JJN = JJ + N - J + 1 AP( JJ ) = DDOT( N-J+1, AP( JJ ), 1, AP( JJ ), 1 ) IF( J.LT.N ) $ CALL DTPMV( 'Lower', 'Transpose', 'Non-unit', N-J, $ AP( JJN ), AP( JJ+1 ), 1 ) JJ = JJN 20 CONTINUE END IF C RETURN C C End of DPPTRI C END SUBROUTINE DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO ) C C -- LAPACK routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDB, N, NRHS C .. C .. Array Arguments .. DOUBLE PRECISION AP( * ), B( LDB, * ) C .. C C Purpose C ======= C C DPPTRS solves a system of linear equations A*X = B with a symmetric C positive definite matrix A in packed storage using the Cholesky C factorization A = U'*U or A = L*L' computed by DPPTRF. C C Arguments C ========= C C UPLO (input) CHARACTER*1 C Specifies whether the factor stored in A is upper or lower C triangular. C = 'U': Upper triangular C = 'L': Lower triangular C C N (input) INTEGER C The order of the matrix A. N >= 0. C C NRHS (input) INTEGER C The number of right hand sides, i.e., the number of columns C of the matrix B. NRHS >= 0. C C AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) C The triangular factor U or L from the Cholesky factorization C A = U'*U or A = L*L', packed columnwise in a linear array. C The j-th column of U or L is stored in the array AP as C follows: C if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; C if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. C C B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) C On entry, the right hand side vectors B for the system of C linear equations. C On exit, the solution vectors, X. C C LDB (input) INTEGER C The leading dimension of the array B. LDB >= max(1,N). C C INFO (output) INTEGER C = 0: successful exit C < 0: if INFO = -k, the k-th argument had an illegal value C C ===================================================================== C C .. Local Scalars .. LOGICAL UPPER INTEGER I C .. C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. C .. External Subroutines .. EXTERNAL DTPSV, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPPTRS', -INFO ) RETURN END IF C C Quick return if possible C IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN C IF( UPPER ) THEN C C Solve A*X = B where A = U'*U. C DO 10 I = 1, NRHS C C Solve U'*X = B, overwriting B with X. C CALL DTPSV( 'Upper', 'Transpose', 'Non-unit', N, AP, $ B( 1, I ), 1 ) C C Solve U*X = B, overwriting B with X. C CALL DTPSV( 'Upper', 'No transpose', 'Non-unit', N, AP, $ B( 1, I ), 1 ) 10 CONTINUE ELSE C C Solve A*X = B where A = L*L'. C DO 20 I = 1, NRHS C C Solve L*Y = B, overwriting B with X. C CALL DTPSV( 'Lower', 'No transpose', 'Non-unit', N, AP, $ B( 1, I ), 1 ) C C Solve L'*X = Y, overwriting B with X. C CALL DTPSV( 'Lower', 'Transpose', 'Non-unit', N, AP, $ B( 1, I ), 1 ) 20 CONTINUE END IF C RETURN C C End of DPPTRS C END SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO ) C C -- LAPACK routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. CHARACTER DIAG, UPLO INTEGER INFO, N C .. C .. Array Arguments .. DOUBLE PRECISION AP( * ) C .. C C Purpose C ======= C C DTPTRI computes the inverse of a real upper or lower triangular C matrix A stored in packed format. C C Arguments C ========= C C UPLO (input) CHARACTER*1 C Specifies whether the matrix A is upper or lower triangular. C = 'U': Upper triangular C = 'L': Lower triangular C C DIAG (input) CHARACTER*1 C Specifies whether or not the matrix A is unit triangular. C = 'N': Non-unit triangular C = 'U': Unit triangular C C N (input) INTEGER C The order of the matrix A. N >= 0. C C AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) C C On entry, the upper or lower triangular matrix A, stored C columnwise in a linear array. The j-th column of A is stored C in the array AP as follows: C if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; C if UPLO = 'L', C AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. C See below for further details. C C On exit, the (triangular) inverse of the original matrix, in C the same packed storage format. C C INFO (output) INTEGER C = 0: successful exit C > 0: if INFO = k, A(k,k) is exactly zero. The triangular C matrix is singular and its inverse can not be computed. C < 0: if INFO = -k, the k-th argument had an illegal value C C Further Details C =============== C C A triangular matrix A can be transferred to packed storage using one C of the following program segments: C C UPLO = 'U': UPLO = 'L': C C JC = 1 JC = 1 C DO 2 J = 1, N DO 2 J = 1, N C DO 1 I = 1, J DO 1 I = J, N C AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) C 1 CONTINUE 1 CONTINUE C JC = JC + J JC = JC + N - J + 1 C 2 CONTINUE 2 CONTINUE C C ===================================================================== C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. C .. Local Scalars .. LOGICAL NOUNIT, UPPER INTEGER J, JC, JCLAST, JJ DOUBLE PRECISION AJJ C .. C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. C .. External Subroutines .. EXTERNAL DSCAL, DTPMV, XERBLA C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOUNIT = LSAME( DIAG, 'N' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTPTRI', -INFO ) RETURN END IF C C Check for singularity if non-unit. C IF( NOUNIT ) THEN IF( UPPER ) THEN JJ = 0 DO 10 INFO = 1, N JJ = JJ + INFO IF( AP( JJ ).EQ.ZERO ) $ RETURN 10 CONTINUE ELSE JJ = 1 DO 20 INFO = 1, N IF( AP( JJ ).EQ.ZERO ) $ RETURN JJ = JJ + N - INFO + 1 20 CONTINUE END IF INFO = 0 END IF C IF( UPPER ) THEN C C Compute inverse of upper triangular matrix. C JC = 1 DO 30 J = 1, N IF( NOUNIT ) THEN AP( JC+J-1 ) = ONE / AP( JC+J-1 ) AJJ = -AP( JC+J-1 ) ELSE AJJ = -ONE END IF C C Compute elements 1:j-1 of j-th column. C CALL DTPMV( 'Upper', 'No transpose', DIAG, J-1, AP, $ AP( JC ), 1 ) CALL DSCAL( J-1, AJJ, AP( JC ), 1 ) JC = JC + J 30 CONTINUE C ELSE C C Compute inverse of lower triangular matrix. C JC = N*( N+1 ) / 2 DO 40 J = N, 1, -1 IF( NOUNIT ) THEN AP( JC ) = ONE / AP( JC ) AJJ = -AP( JC ) ELSE AJJ = -ONE END IF IF( J.LT.N ) THEN C C Compute elements j+1:n of j-th column. C CALL DTPMV( 'Lower', 'No transpose', DIAG, N-J, $ AP( JCLAST ), AP( JC+1 ), 1 ) CALL DSCAL( N-J, AJJ, AP( JC+1 ), 1 ) END IF JCLAST = JC JC = JC - N + J - 2 40 CONTINUE END IF C RETURN C C End of DTPTRI C END SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) C C -- LAPACK auxiliary routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. DOUBLE PRECISION A, B, C, RT1, RT2 C .. C C Purpose C ======= C C DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix C [ A B ] C [ B C ]. C On return, RT1 is the eigenvalue of larger absolute value, and RT2 C is the eigenvalue of smaller absolute value. C C Arguments C ========= C C A (input) DOUBLE PRECISION C The (1,1) entry of the 2-by-2 matrix. C C B (input) DOUBLE PRECISION C The (1,2) and (2,1) entries of the 2-by-2 matrix. C C C (input) DOUBLE PRECISION C The (2,2) entry of the 2-by-2 matrix. C C RT1 (output) DOUBLE PRECISION C The eigenvalue of larger absolute value. C C RT2 (output) DOUBLE PRECISION C The eigenvalue of smaller absolute value. C C Further Details C =============== C C RT1 is accurate to a few ulps barring over/underflow. C C RT2 may be inaccurate if there is massive cancellation in the C determinant A*C-B*B; higher precision or correctly rounded or C correctly truncated arithmetic would be needed to compute RT2 C accurately in all cases. C C Overflow is possible only if RT1 is within a factor of 5 of overflow. C Underflow is harmless if the input data is 0 or exceeds C underflow_threshold / macheps. C C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = 0.5D0 ) C .. C .. Local Scalars .. DOUBLE PRECISION AB, ACMN, ACMX, ADF, DF, RT, SM, TB C .. C .. Intrinsic Functions .. INTRINSIC ABS, SQRT C .. C .. Executable Statements .. C C Compute the eigenvalues C SM = A + C DF = A - C ADF = ABS( DF ) TB = B + B AB = ABS( TB ) IF( ABS( A ).GT.ABS( C ) ) THEN ACMX = A ACMN = C ELSE ACMX = C ACMN = A END IF IF( ADF.GT.AB ) THEN RT = ADF*SQRT( ONE+( AB / ADF )**2 ) ELSE IF( ADF.LT.AB ) THEN RT = AB*SQRT( ONE+( ADF / AB )**2 ) ELSE C C Includes case AB=ADF=0 C RT = AB*SQRT( TWO ) END IF IF( SM.LT.ZERO ) THEN RT1 = HALF*( SM-RT ) C C Order of execution important. C To get fully accurate smaller eigenvalue, C next line needs to be executed in higher precision. C RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE IF( SM.GT.ZERO ) THEN RT1 = HALF*( SM+RT ) C C Order of execution important. C To get fully accurate smaller eigenvalue, C next line needs to be executed in higher precision. C RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE C C Includes case RT1 = RT2 = 0 C RT1 = HALF*RT RT2 = -HALF*RT END IF RETURN C C End of DLAE2 C END SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) C C -- LAPACK auxiliary routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 C .. C C Purpose C ======= C C DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix C [ A B ] C [ B C ]. C On return, RT1 is the eigenvalue of larger absolute value, RT2 is the C eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right C eigenvector for RT1, giving the decomposition C C [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] C [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. C C Arguments C ========= C C A (input) DOUBLE PRECISION C The (1,1) entry of the 2-by-2 matrix. C C B (input) DOUBLE PRECISION C The (1,2) entry and the conjugate of the (2,1) entry of the C 2-by-2 matrix. C C C (input) DOUBLE PRECISION C The (2,2) entry of the 2-by-2 matrix. C C RT1 (output) DOUBLE PRECISION C The eigenvalue of larger absolute value. C C RT2 (output) DOUBLE PRECISION C The eigenvalue of smaller absolute value. C C CS1 (output) DOUBLE PRECISION C SN1 (output) DOUBLE PRECISION C The vector (CS1, SN1) is a unit right eigenvector for RT1. C C Further Details C =============== C C RT1 is accurate to a few ulps barring over/underflow. C C RT2 may be inaccurate if there is massive cancellation in the C determinant A*C-B*B; higher precision or correctly rounded or C correctly truncated arithmetic would be needed to compute RT2 C accurately in all cases. C C CS1 and SN1 are accurate to a few ulps barring over/underflow. C C Overflow is possible only if RT1 is within a factor of 5 of overflow. C Underflow is harmless if the input data is 0 or exceeds C underflow_threshold / macheps. C C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = 0.5D0 ) C .. C .. Local Scalars .. INTEGER SGN1, SGN2 DOUBLE PRECISION AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM, $ TB, TN C .. C .. Intrinsic Functions .. INTRINSIC ABS, SQRT C .. C .. Executable Statements .. C C Compute the eigenvalues C SM = A + C DF = A - C ADF = ABS( DF ) TB = B + B AB = ABS( TB ) IF( ABS( A ).GT.ABS( C ) ) THEN ACMX = A ACMN = C ELSE ACMX = C ACMN = A END IF IF( ADF.GT.AB ) THEN RT = ADF*SQRT( ONE+( AB / ADF )**2 ) ELSE IF( ADF.LT.AB ) THEN RT = AB*SQRT( ONE+( ADF / AB )**2 ) ELSE C C Includes case AB=ADF=0 C RT = AB*SQRT( TWO ) END IF IF( SM.LT.ZERO ) THEN RT1 = HALF*( SM-RT ) SGN1 = -1 C C Order of execution important. C To get fully accurate smaller eigenvalue, C next line needs to be executed in higher precision. C RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE IF( SM.GT.ZERO ) THEN RT1 = HALF*( SM+RT ) SGN1 = 1 C C Order of execution important. C To get fully accurate smaller eigenvalue, C next line needs to be executed in higher precision. C RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE C C Includes case RT1 = RT2 = 0 C RT1 = HALF*RT RT2 = -HALF*RT SGN1 = 1 END IF C C Compute the eigenvector C IF( DF.GE.ZERO ) THEN CS = DF + RT SGN2 = 1 ELSE CS = DF - RT SGN2 = -1 END IF ACS = ABS( CS ) IF( ACS.GT.AB ) THEN CT = -TB / CS SN1 = ONE / SQRT( ONE+CT*CT ) CS1 = CT*SN1 ELSE IF( AB.EQ.ZERO ) THEN CS1 = ONE SN1 = ZERO ELSE TN = -CS / TB CS1 = ONE / SQRT( ONE+TN*TN ) SN1 = TN*CS1 END IF END IF IF( SGN1.EQ.SGN2 ) THEN TN = CS1 CS1 = -SN1 SN1 = TN END IF RETURN C C End of DLAEV2 C END DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) C C -- LAPACK auxiliary routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. CHARACTER CMACH C .. C C Purpose C ======= C C DLAMCH determines double precision machine parameters. C C Arguments C ========= C C CMACH (input) CHARACTER*1 C Specifies the value to be returned by DLAMCH: C = 'E' or 'e', DLAMCH := eps C = 'S' or 's , DLAMCH := sfmin C = 'B' or 'b', DLAMCH := base C = 'P' or 'p', DLAMCH := eps*base C = 'N' or 'n', DLAMCH := t C = 'R' or 'r', DLAMCH := rnd C = 'M' or 'm', DLAMCH := emin C = 'U' or 'u', DLAMCH := rmin C = 'L' or 'l', DLAMCH := emax C = 'O' or 'o', DLAMCH := rmax C C where C C eps = relative machine precision C sfmin = safe minimum, such that 1/sfmin does not overflow C base = base of the machine C prec = eps*base C t = number of (base) digits in the mantissa C rnd = 1.0 when rounding occurs in addition, 0.0 otherwise C emin = minimum exponent before (gradual) underflow C rmin = underflow threshold - base**(emin-1) C emax = largest exponent before overflow C rmax = overflow threshold - (base**emax)*(1-eps) C C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. C .. Local Scalars .. LOGICAL FIRST, LRND INTEGER BETA, IMAX, IMIN, IT DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, $ RND, SFMIN, SMALL, T C .. C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. C .. External Subroutines .. EXTERNAL DLAMC2 C .. C .. Save statement .. SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, $ EMAX, RMAX, PREC C .. C .. Data statements .. DATA FIRST / .TRUE. / C .. C .. Executable Statements .. C IF( FIRST ) THEN FIRST = .FALSE. CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) BASE = BETA T = IT IF( LRND ) THEN RND = ONE EPS = ( BASE**( 1-IT ) ) / 2 ELSE RND = ZERO EPS = BASE**( 1-IT ) END IF PREC = EPS*BASE EMIN = IMIN EMAX = IMAX SFMIN = RMIN SMALL = ONE / RMAX IF( SMALL.GE.SFMIN ) THEN C C Use SMALL plus a bit, to avoid the possibility of rounding C causing overflow when computing 1/sfmin. C SFMIN = SMALL*( ONE+EPS ) END IF END IF C IF( LSAME( CMACH, 'E' ) ) THEN RMACH = EPS ELSE IF( LSAME( CMACH, 'S' ) ) THEN RMACH = SFMIN ELSE IF( LSAME( CMACH, 'B' ) ) THEN RMACH = BASE ELSE IF( LSAME( CMACH, 'P' ) ) THEN RMACH = PREC ELSE IF( LSAME( CMACH, 'N' ) ) THEN RMACH = T ELSE IF( LSAME( CMACH, 'R' ) ) THEN RMACH = RND ELSE IF( LSAME( CMACH, 'M' ) ) THEN RMACH = EMIN ELSE IF( LSAME( CMACH, 'U' ) ) THEN RMACH = RMIN ELSE IF( LSAME( CMACH, 'L' ) ) THEN RMACH = EMAX ELSE IF( LSAME( CMACH, 'O' ) ) THEN RMACH = RMAX END IF C DLAMCH = RMACH RETURN C C End of DLAMCH C END C C*********************************************************************** C SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) C C -- LAPACK auxiliary routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. LOGICAL IEEE1, RND INTEGER BETA, T C .. C C Purpose C ======= C C DLAMC1 determines the machine parameters given by BETA, T, RND, and C IEEE1. C C Arguments C ========= C C BETA (output) INTEGER C The base of the machine. C C T (output) INTEGER C The number of ( BETA ) digits in the mantissa. C C RND (output) LOGICAL C Specifies whether proper rounding ( RND = .TRUE. ) or C chopping ( RND = .FALSE. ) occurs in addition. This may not C be a reliable guide to the way in which the machine performs C its arithmetic. C C IEEE1 (output) LOGICAL C Specifies whether rounding appears to be done in the IEEE C 'round to nearest' style. C C Further Details C =============== C C The routine is based on the routine ENVRON by Malcolm and C incorporates suggestions by Gentleman and Marovich. See C C Malcolm M. A. (1972) Algorithms to reveal properties of C floating-point arithmetic. Comms. of the ACM, 15, 949-951. C C Gentleman W. M. and Marovich S. B. (1974) More on algorithms C that reveal properties of floating point arithmetic units. C Comms. of the ACM, 17, 276-277. C C C .. Local Scalars .. LOGICAL FIRST, LIEEE1, LRND INTEGER LBETA, LT DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2 C .. C .. External Functions .. DOUBLE PRECISION DLAMC3 EXTERNAL DLAMC3 C .. C .. Save statement .. SAVE FIRST, LIEEE1, LBETA, LRND, LT C .. C .. Data statements .. DATA FIRST / .TRUE. / C .. C .. Executable Statements .. C IF( FIRST ) THEN FIRST = .FALSE. ONE = 1 C C LBETA, LIEEE1, LT and LRND are the local values of BETA, C IEEE1, T and RND. C C Throughout this routine we use the function DLAMC3 to ensure C that relevant values are stored and not held in registers, or C are not affected by optimizers. C C Compute a = 2.0**m with the smallest positive integer m such C that C C fl( a + 1.0 ) = a. C A = 1 C = 1 C C+ WHILE( C.EQ.ONE )LOOP 10 CONTINUE C C Change by Bob Fay, Dec. 1, 1993, for consistency with the change just C after statement 20 below. On the Microsoft PowerStation compiler, this C first change does not appear to make a difference. The original was: C IF( C.EQ.ONE ) THEN C IF(DLAMC3( C, -ONE).EQ.0.) THEN A = 2*A C = DLAMC3( A, ONE ) C = DLAMC3( C, -A ) GO TO 10 END IF C+ END WHILE C C Now compute b = 2.0**m with the smallest positive integer m C such that C C fl( a + b ) .gt. a. C B = 1 C = DLAMC3( A, B ) C C+ WHILE( C.EQ.A )LOOP 20 CONTINUE C C Change by Bob Fay, Dec. 1, 1993, to allow floating point optimization C for speed on the Microsoft PowerStation compiler. The original version C resulted in LBETA=0 below, causing an infinite loop to 30. C The original was: C IF( C.EQ.A ) THEN C IF( DLAMC3( C, -A).EQ.0. ) THEN B = 2*B C = DLAMC3( A, B ) GO TO 20 END IF C+ END WHILE C C Now compute the base. a and c are neighbouring floating point C numbers in the interval ( beta**t, beta**( t + 1 ) ) and so C their difference is beta. Adding 0.25 to c is to ensure that it C is truncated to beta and not ( beta - 1 ). C QTR = ONE / 4 SAVEC = C C = DLAMC3( C, -A ) LBETA = C + QTR C C Now determine whether rounding or chopping occurs, by adding a C bit less than beta/2 and a bit more than beta/2 to a. C B = LBETA F = DLAMC3( B / 2, -B / 100 ) C = DLAMC3( F, A ) IF( C.EQ.A ) THEN LRND = .TRUE. ELSE LRND = .FALSE. END IF F = DLAMC3( B / 2, B / 100 ) C = DLAMC3( F, A ) IF( ( LRND ) .AND. ( C.EQ.A ) ) $ LRND = .FALSE. C C Try and decide whether rounding is done in the IEEE 'round to C nearest' style. B/2 is half a unit in the last place of the two C numbers A and SAVEC. Furthermore, A is even, i.e. has last bit C zero, and SAVEC is odd. Thus adding B/2 to A should not change C A, but adding B/2 to SAVEC should change SAVEC. C T1 = DLAMC3( B / 2, A ) T2 = DLAMC3( B / 2, SAVEC ) LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND C C Now find the mantissa, t. It should be the integer part of C log to the base beta of a, however it is safer to determine t C by powering. So we find t as the smallest positive integer for C which C C fl( beta**t + 1.0 ) = 1.0. C LT = 0 A = 1 C = 1 C C+ WHILE( C.EQ.ONE )LOOP 30 CONTINUE C C Change by Bob Fay, Dec. 1, 1993, for consistency with the change just C after statement 20 above. On the Microsoft PowerStation compiler, this C third change does not appear to make a difference. The original was: C IF( C.EQ.ONE ) THEN C IF(DLAMC3( C, -ONE).EQ.0.) THEN LT = LT + 1 A = A*LBETA C = DLAMC3( A, ONE ) C = DLAMC3( C, -A ) GO TO 30 END IF C+ END WHILE C END IF C BETA = LBETA T = LT RND = LRND IEEE1 = LIEEE1 RETURN C C End of DLAMC1 C END C C*********************************************************************** C SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) C C -- LAPACK auxiliary routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. LOGICAL RND INTEGER BETA, EMAX, EMIN, T DOUBLE PRECISION EPS, RMAX, RMIN C .. C C Purpose C ======= C C DLAMC2 determines the machine parameters specified in its argument C list. C C Arguments C ========= C C BETA (output) INTEGER C The base of the machine. C C T (output) INTEGER C The number of ( BETA ) digits in the mantissa. C C RND (output) LOGICAL C Specifies whether proper rounding ( RND = .TRUE. ) or C chopping ( RND = .FALSE. ) occurs in addition. This may not C be a reliable guide to the way in which the machine performs C its arithmetic. C C EPS (output) DOUBLE PRECISION C The smallest positive number such that C C fl( 1.0 - EPS ) .LT. 1.0, C C where fl denotes the computed value. C C EMIN (output) INTEGER C The minimum exponent before (gradual) underflow occurs. C C RMIN (output) DOUBLE PRECISION C The smallest normalized number for the machine, given by C BASE**( EMIN - 1 ), where BASE is the floating point value C of BETA. C C EMAX (output) INTEGER C The maximum exponent before overflow occurs. C C RMAX (output) DOUBLE PRECISION C The largest positive number for the machine, given by C BASE**EMAX * ( 1 - EPS ), where BASE is the floating point C value of BETA. C C Further Details C =============== C C The computation of EPS is based on a routine PARANOIA by C W. Kahan of the University of California at Berkeley. C C C .. Local Scalars .. LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, $ NGNMIN, NGPMIN DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, $ SIXTH, SMALL, THIRD, TWO, ZERO C .. C .. External Functions .. DOUBLE PRECISION DLAMC3 EXTERNAL DLAMC3 C .. C .. External Subroutines .. EXTERNAL DLAMC1, DLAMC4, DLAMC5 C .. C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN C .. C .. Save statement .. SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, $ LRMIN, LT C .. C .. Data statements .. DATA FIRST / .TRUE. / , IWARN / .FALSE. / C .. C .. Executable Statements .. C IF( FIRST ) THEN FIRST = .FALSE. ZERO = 0 ONE = 1 TWO = 2 C C LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of C BETA, T, RND, EPS, EMIN and RMIN. C C Throughout this routine we use the function DLAMC3 to ensure C that relevant values are stored and not held in registers, or C are not affected by optimizers. C C DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. C CALL DLAMC1( LBETA, LT, LRND, LIEEE1 ) C C Start to find EPS. C B = LBETA A = B**( -LT ) LEPS = A C C Try some tricks to see whether or not this is the correct EPS. C B = TWO / 3 HALF = ONE / 2 SIXTH = DLAMC3( B, -HALF ) THIRD = DLAMC3( SIXTH, SIXTH ) B = DLAMC3( THIRD, -HALF ) B = DLAMC3( B, SIXTH ) B = ABS( B ) IF( B.LT.LEPS ) $ B = LEPS C LEPS = 1 C C+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP 10 CONTINUE IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN LEPS = B C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) C = DLAMC3( HALF, -C ) B = DLAMC3( HALF, C ) C = DLAMC3( HALF, -B ) B = DLAMC3( HALF, C ) GO TO 10 END IF C+ END WHILE C IF( A.LT.LEPS ) $ LEPS = A C C Computation of EPS complete. C C Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). C Keep dividing A by BETA until (gradual) underflow occurs. This C is detected when we cannot recover the previous A. C RBASE = ONE / LBETA SMALL = ONE DO 20 I = 1, 3 SMALL = DLAMC3( SMALL*RBASE, ZERO ) 20 CONTINUE A = DLAMC3( ONE, SMALL ) CALL DLAMC4( NGPMIN, ONE, LBETA ) CALL DLAMC4( NGNMIN, -ONE, LBETA ) CALL DLAMC4( GPMIN, A, LBETA ) CALL DLAMC4( GNMIN, -A, LBETA ) IEEE = .FALSE. C IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN IF( NGPMIN.EQ.GPMIN ) THEN LEMIN = NGPMIN C ( Non twos-complement machines, no gradual underflow; C e.g., VAX ) ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN LEMIN = NGPMIN - 1 + LT IEEE = .TRUE. C ( Non twos-complement machines, with gradual underflow; C e.g., IEEE standard followers ) ELSE LEMIN = MIN( NGPMIN, GPMIN ) C ( A guess; no known machine ) IWARN = .TRUE. END IF C ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN LEMIN = MAX( NGPMIN, NGNMIN ) C ( Twos-complement machines, no gradual underflow; C e.g., CYBER 205 ) ELSE LEMIN = MIN( NGPMIN, NGNMIN ) C ( A guess; no known machine ) IWARN = .TRUE. END IF C ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. $ ( GPMIN.EQ.GNMIN ) ) THEN IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT C ( Twos-complement machines with gradual underflow; C no known machine ) ELSE LEMIN = MIN( NGPMIN, NGNMIN ) C ( A guess; no known machine ) IWARN = .TRUE. END IF C ELSE LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) C ( A guess; no known machine ) IWARN = .TRUE. END IF C** C Comment out this if block if EMIN is ok IF( IWARN ) THEN FIRST = .TRUE. WRITE( 6, FMT = 9999 )LEMIN END IF C** C C Assume IEEE arithmetic if we found denormalised numbers above, C or if arithmetic seems to round in the IEEE style, determined C in routine DLAMC1. A true IEEE machine should have both things C true; however, faulty machines may have one or the other. C IEEE = IEEE .OR. LIEEE1 C C Compute RMIN by successive division by BETA. We could compute C RMIN as BASE**( EMIN - 1 ), but some machines underflow during C this computation. C LRMIN = 1 DO 30 I = 1, 1 - LEMIN LRMIN = DLAMC3( LRMIN*RBASE, ZERO ) 30 CONTINUE C C Finally, call DLAMC5 to compute EMAX and RMAX. C CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) END IF C BETA = LBETA T = LT RND = LRND EPS = LEPS EMIN = LEMIN RMIN = LRMIN EMAX = LEMAX RMAX = LRMAX C RETURN C 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', $ ' EMIN = ', I8, / $ ' If, after inspection, the value EMIN looks', $ ' acceptable please comment out ', $ / ' the IF block as marked within the code of routine', $ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / ) C C End of DLAMC2 C END C C*********************************************************************** C DOUBLE PRECISION FUNCTION DLAMC3( A, B ) C C -- LAPACK auxiliary routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. DOUBLE PRECISION A, B C .. C C Purpose C ======= C C DLAMC3 is intended to force A and B to be stored prior to doing C the addition of A and B , for use in situations where optimizers C might hold one of these in a register. C C Arguments C ========= C C A, B (input) DOUBLE PRECISION C The values A and B. C C C .. Executable Statements .. C DLAMC3 = A + B C RETURN C C End of DLAMC3 C END C C*********************************************************************** C SUBROUTINE DLAMC4( EMIN, START, BASE ) C C -- LAPACK auxiliary routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. INTEGER BASE, EMIN DOUBLE PRECISION START C .. C C Purpose C ======= C C DLAMC4 is a service routine for DLAMC2. C C Arguments C ========= C C EMIN (output) EMIN C The minimum exponent before (gradual) underflow, computed by C setting A = START and dividing by BASE until the previous A C can not be recovered. C C START (input) DOUBLE PRECISION C The starting point for determining EMIN. C C BASE (input) INTEGER C The base of the machine. C C C .. Local Scalars .. INTEGER I DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO C .. C .. External Functions .. DOUBLE PRECISION DLAMC3 EXTERNAL DLAMC3 C .. C .. Executable Statements .. C A = START ONE = 1 RBASE = ONE / BASE ZERO = 0 EMIN = 1 B1 = DLAMC3( A*RBASE, ZERO ) C1 = A C2 = A D1 = A D2 = A C+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. C $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP 10 CONTINUE IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. $ ( D2.EQ.A ) ) THEN EMIN = EMIN - 1 A = B1 B1 = DLAMC3( A / BASE, ZERO ) C1 = DLAMC3( B1*BASE, ZERO ) D1 = ZERO DO 20 I = 1, BASE D1 = D1 + B1 20 CONTINUE B2 = DLAMC3( A*RBASE, ZERO ) C2 = DLAMC3( B2 / RBASE, ZERO ) D2 = ZERO DO 30 I = 1, BASE D2 = D2 + B2 30 CONTINUE GO TO 10 END IF C+ END WHILE C RETURN C C End of DLAMC4 C END C C*********************************************************************** C SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) C C -- LAPACK auxiliary routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. LOGICAL IEEE INTEGER BETA, EMAX, EMIN, P DOUBLE PRECISION RMAX C .. C C Purpose C ======= C C DLAMC5 attempts to compute RMAX, the largest machine floating-point C number, without overflow. It assumes that EMAX + abs(EMIN) sum C approximately to a power of 2. It will fail on machines where this C assumption does not hold, for example, the Cyber 205 (EMIN = -28625, C EMAX = 28718). It will also fail if the value supplied for EMIN is C too large (i.e. too close to zero), probably with overflow. C C Arguments C ========= C C BETA (input) INTEGER C The base of floating-point arithmetic. C C P (input) INTEGER C The number of base BETA digits in the mantissa of a C floating-point value. C C EMIN (input) INTEGER C The minimum exponent before (gradual) underflow. C C IEEE (input) LOGICAL C A logical flag specifying whether or not the arithmetic C system is thought to comply with the IEEE standard. C C EMAX (output) INTEGER C The largest exponent before overflow C C RMAX (output) DOUBLE PRECISION C The largest machine floating-point number. C C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. C .. Local Scalars .. INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP DOUBLE PRECISION OLDY, RECBAS, Y, Z C .. C .. External Functions .. DOUBLE PRECISION DLAMC3 EXTERNAL DLAMC3 C .. C .. Intrinsic Functions .. INTRINSIC MOD C .. C .. Executable Statements .. C C First compute LEXP and UEXP, two powers of 2 that bound C abs(EMIN). We then assume that EMAX + abs(EMIN) will sum C approximately to the bound that is closest to abs(EMIN). C (EMAX is the exponent of the required number RMAX). C LEXP = 1 EXBITS = 1 10 CONTINUE TRY = LEXP*2 IF( TRY.LE.( -EMIN ) ) THEN LEXP = TRY EXBITS = EXBITS + 1 GO TO 10 END IF IF( LEXP.EQ.-EMIN ) THEN UEXP = LEXP ELSE UEXP = TRY EXBITS = EXBITS + 1 END IF C C Now -LEXP is less than or equal to EMIN, and -UEXP is greater C than or equal to EMIN. EXBITS is the number of bits needed to C store the exponent. C IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN EXPSUM = 2*LEXP ELSE EXPSUM = 2*UEXP END IF C C EXPSUM is the exponent range, approximately equal to C EMAX - EMIN + 1 . C EMAX = EXPSUM + EMIN - 1 NBITS = 1 + EXBITS + P C C NBITS is the total number of bits needed to store a C floating-point number. C IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN C C Either there are an odd number of bits used to store a C floating-point number, which is unlikely, or some bits are C not used in the representation of numbers, which is possible, C (e.g. Cray machines) or the mantissa has an implicit bit, C (e.g. IEEE machines, Dec Vax machines), which is perhaps the C most likely. We have to assume the last alternative. C If this is true, then we need to reduce EMAX by one because C there must be some way of representing zero in an implicit-bit C system. On machines like Cray, we are reducing EMAX by one C unnecessarily. C EMAX = EMAX - 1 END IF C IF( IEEE ) THEN C C Assume we are on an IEEE machine which reserves one exponent C for infinity and NaN. C EMAX = EMAX - 1 END IF C C Now create RMAX, the largest machine number, which should C be equal to (1.0 - BETA**(-P)) * BETA**EMAX . C C First compute 1.0 - BETA**(-P), being careful that the C result is less than 1.0 . C RECBAS = ONE / BETA Z = BETA - ONE Y = ZERO DO 20 I = 1, P Z = Z*RECBAS IF( Y.LT.ONE ) $ OLDY = Y Y = DLAMC3( Y, Z ) 20 CONTINUE IF( Y.GE.ONE ) $ Y = OLDY C C Now multiply by BETA**EMAX to get RMAX. C DO 30 I = 1, EMAX Y = DLAMC3( Y*BETA, ZERO ) 30 CONTINUE C RMAX = Y RETURN C C End of DLAMC5 C END DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK ) C C -- LAPACK auxiliary routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER N C .. C .. Array Arguments .. DOUBLE PRECISION AP( * ), WORK( * ) C .. C C Purpose C ======= C C DLANSP returns the value of the one norm, or the Frobenius norm, or C the infinity norm, or the element of largest absolute value of a C real symmetric matrix A, supplied in packed form. C C Description C =========== C C DLANSP returns the value C C DLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm' C ( C ( norm1(A), NORM = '1', 'O' or 'o' C ( C ( normI(A), NORM = 'I' or 'i' C ( C ( normF(A), NORM = 'F', 'f', 'E' or 'e' C C where norm1 denotes the one norm of a matrix (maximum column sum), C normI denotes the infinity norm of a matrix (maximum row sum) and C normF denotes the Frobenius norm of a matrix (square root of sum of C squares). Note that max(abs(A(i,j))) is not a matrix norm. C C Arguments C ========= C C NORM (input) CHARACTER*1 C Specifies the value to be returned in DLANSP as described C above. C C UPLO (input) CHARACTER*1 C Specifies whether the upper or lower triangular part of the C symmetric matrix A is supplied. C = 'U': Upper triangular part of A is supplied C = 'L': Lower triangular part of A is supplied C C N (input) INTEGER C The order of the matrix A. N >= 0. When N = 0, DLANSP is C set to zero. C C AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) C The upper or lower triangle of the symmetric matrix A, packed C columnwise in a linear array. The j-th column of A is stored C in the array AP as follows: C if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; C if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. C C WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), C where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, C WORK is not referenced. C C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. C .. Local Scalars .. INTEGER I, J, K DOUBLE PRECISION ABSA, SCALE, SUM, VALUE C .. C .. External Subroutines .. EXTERNAL DLASSQ C .. C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT C .. C .. Executable Statements .. C IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN C C Find max(abs(A(i,j))). C VALUE = ZERO IF( LSAME( UPLO, 'U' ) ) THEN K = 1 DO 20 J = 1, N DO 10 I = K, K + J - 1 VALUE = MAX( VALUE, ABS( AP( I ) ) ) 10 CONTINUE K = K + J 20 CONTINUE ELSE K = 1 DO 40 J = 1, N DO 30 I = K, K + N - J VALUE = MAX( VALUE, ABS( AP( I ) ) ) 30 CONTINUE K = K + N - J + 1 40 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. $ ( NORM.EQ.'1' ) ) THEN C C Find normI(A) ( = norm1(A), since A is symmetric). C VALUE = ZERO K = 1 IF( LSAME( UPLO, 'U' ) ) THEN DO 60 J = 1, N SUM = ZERO DO 50 I = 1, J - 1 ABSA = ABS( AP( K ) ) SUM = SUM + ABSA WORK( I ) = WORK( I ) + ABSA K = K + 1 50 CONTINUE WORK( J ) = SUM + ABS( AP( K ) ) K = K + 1 60 CONTINUE DO 70 I = 1, N VALUE = MAX( VALUE, WORK( I ) ) 70 CONTINUE ELSE DO 80 I = 1, N WORK( I ) = ZERO 80 CONTINUE DO 100 J = 1, N SUM = WORK( J ) + ABS( AP( K ) ) K = K + 1 DO 90 I = J + 1, N ABSA = ABS( AP( K ) ) SUM = SUM + ABSA WORK( I ) = WORK( I ) + ABSA K = K + 1 90 CONTINUE VALUE = MAX( VALUE, SUM ) 100 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN C C Find normF(A). C SCALE = ZERO SUM = ONE K = 2 IF( LSAME( UPLO, 'U' ) ) THEN DO 110 J = 2, N CALL DLASSQ( J-1, AP( K ), 1, SCALE, SUM ) K = K + J 110 CONTINUE ELSE DO 120 J = 1, N - 1 CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM ) K = K + N - J + 1 120 CONTINUE END IF SUM = 2*SUM K = 1 DO 130 I = 1, N IF( AP( K ).NE.ZERO ) THEN ABSA = ABS( AP( K ) ) IF( SCALE.LT.ABSA ) THEN SUM = ONE + SUM*( SCALE / ABSA )**2 SCALE = ABSA ELSE SUM = SUM + ( ABSA / SCALE )**2 END IF END IF IF( LSAME( UPLO, 'U' ) ) THEN K = K + I + 1 ELSE K = K + N - I + 1 END IF 130 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF C DLANSP = VALUE RETURN C C End of DLANSP C END DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) C C -- LAPACK auxiliary routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. DOUBLE PRECISION X, Y C .. C C Purpose C ======= C C DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary C overflow. C C Arguments C ========= C C X (input) DOUBLE PRECISION C Y (input) DOUBLE PRECISION C X and Y specify the values x and y. C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. C .. Local Scalars .. DOUBLE PRECISION W, XABS, YABS, Z C .. C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT C .. C .. Executable Statements .. C XABS = ABS( X ) YABS = ABS( Y ) W = MAX( XABS, YABS ) Z = MIN( XABS, YABS ) IF( Z.EQ.ZERO ) THEN DLAPY2 = W ELSE DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) END IF RETURN C C End of DLAPY2 C END C SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) C C -- LAPACK auxiliary routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. CHARACTER SIDE INTEGER INCV, LDC, M, N DOUBLE PRECISION TAU C .. C .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) C .. C C Purpose C ======= C C DLARF applies a real elementary reflector H to a real m by n matrix C C, from either the left or the right. H is represented in the form C C H = I - tau * v * v' C C where tau is a real scalar and v is a real vector. C C If tau = 0, then H is taken to be the unit matrix. C C Arguments C ========= C C SIDE (input) CHARACTER*1 C = 'L': form H * C C = 'R': form C * H C C M (input) INTEGER C The number of rows of the matrix C. C C N (input) INTEGER C The number of columns of the matrix C. C C V (input) DOUBLE PRECISION array, dimension C (1 + (M-1)*abs(INCV)) if SIDE = 'L' C or (1 + (N-1)*abs(INCV)) if SIDE = 'R' C The vector v in the representation of H. V is not used if C TAU = 0. C C INCV (input) INTEGER C The increment between elements of v. INCV <> 0. C C TAU (input) DOUBLE PRECISION C The value tau in the representation of H. C C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) C On entry, the m by n matrix C. C On exit, C is overwritten by the matrix H * C if SIDE = 'L', C or C * H if SIDE = 'R'. C C LDC (input) INTEGER C The leading dimension of the array C. LDC >= max(1,M). C C WORK (workspace) DOUBLE PRECISION array, dimension C (N) if SIDE = 'L' C or (M) if SIDE = 'R' C C ===================================================================== C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. C .. External Subroutines .. EXTERNAL DGEMV, DGER C .. C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. C .. Executable Statements .. C IF( LSAME( SIDE, 'L' ) ) THEN C C Form H * C C IF( TAU.NE.ZERO ) THEN C C w := C' * v C CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO, $ WORK, 1 ) C C C := C - v * w' C CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC ) END IF ELSE C C Form C * H C IF( TAU.NE.ZERO ) THEN C C w := C * v C CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV, $ ZERO, WORK, 1 ) C C C := C - w * v' C CALL DGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC ) END IF END IF RETURN C C End of DLARF C END SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) C C -- LAPACK auxiliary routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. INTEGER INCX, N DOUBLE PRECISION ALPHA, TAU C .. C .. Array Arguments .. DOUBLE PRECISION X( * ) C .. C C Purpose C ======= C C DLARFG generates a real elementary reflector H of order n, such C that C C H * ( alpha ) = ( beta ), H' * H = I. C ( x ) ( 0 ) C C where alpha and beta are scalars, and x is an (n-1)-element real C vector. H is represented in the form C C H = I - tau * ( 1 ) * ( 1 v' ) , C ( v ) C C where tau is a real scalar and v is a real (n-1)-element C vector. C C If the elements of x are all zero, then tau = 0 and H is taken to be C the unit matrix. C C Otherwise 1 <= tau <= 2. C C Arguments C ========= C C N (input) INTEGER C The order of the elementary reflector. C C ALPHA (input/output) DOUBLE PRECISION C On entry, the value alpha. C On exit, it is overwritten with the value beta. C C X (input/output) DOUBLE PRECISION array, dimension C (1+(N-2)*abs(INCX)) C On entry, the vector x. C On exit, it is overwritten with the vector v. C C INCX (input) INTEGER C The increment between elements of X. INCX <> 0. C C TAU (output) DOUBLE PRECISION C The value tau. C C ===================================================================== C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. C .. Local Scalars .. INTEGER J, KNT DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM C .. C .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 EXTERNAL DLAMCH, DLAPY2, DNRM2 C .. C .. Intrinsic Functions .. INTRINSIC ABS, SIGN C .. C .. External Subroutines .. EXTERNAL DSCAL C .. C .. Executable Statements .. C IF( N.LE.1 ) THEN TAU = ZERO RETURN END IF C XNORM = DNRM2( N-1, X, INCX ) C IF( XNORM.EQ.ZERO ) THEN C C H = I C TAU = ZERO ELSE C C general case C BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) SAFMIN = DLAMCH( 'S' ) IF( ABS( BETA ).LT.SAFMIN ) THEN C C XNORM, BETA may be inaccurate; scale X and recompute them C RSAFMN = ONE / SAFMIN KNT = 0 10 CONTINUE KNT = KNT + 1 CALL DSCAL( N-1, RSAFMN, X, INCX ) BETA = BETA*RSAFMN ALPHA = ALPHA*RSAFMN IF( ABS( BETA ).LT.SAFMIN ) $ GO TO 10 C C New BETA is at most 1, at least SAFMIN C XNORM = DNRM2( N-1, X, INCX ) BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) TAU = ( BETA-ALPHA ) / BETA CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) C C If ALPHA is subnormal, it may lose relative accuracy C ALPHA = BETA DO 20 J = 1, KNT ALPHA = ALPHA*SAFMIN 20 CONTINUE ELSE TAU = ( BETA-ALPHA ) / BETA CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) ALPHA = BETA END IF END IF C RETURN C C End of DLARFG C END SUBROUTINE DLARTG( F, G, CS, SN, R ) C C -- LAPACK auxiliary routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. DOUBLE PRECISION CS, F, G, R, SN C .. C C Purpose C ======= C C DLARTG generate a plane rotation so that C C [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. C [ -SN CS ] [ G ] [ 0 ] C C This is a faster version of the BLAS1 routine DROTG, except for C the following differences: C F and G are unchanged on return. C If G=0, then CS=1 and SN=0. C If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any C floating point operations (saves work in DBDSQR when C there are zeros on the diagonal). C C Arguments C ========= C C F (input) DOUBLE PRECISION C The first component of vector to be rotated. C C G (input) DOUBLE PRECISION C The second component of vector to be rotated. C C CS (output) DOUBLE PRECISION C The cosine of the rotation. C C SN (output) DOUBLE PRECISION C The sine of the rotation. C C R (output) DOUBLE PRECISION C The nonzero component of the rotated vector. C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) C .. C .. Local Scalars .. DOUBLE PRECISION T, TT C .. C .. Intrinsic Functions .. INTRINSIC ABS, SQRT C .. C .. Executable Statements .. C IF( F.EQ.ZERO ) THEN IF( G.EQ.ZERO ) THEN CS = ONE SN = ZERO R = ZERO ELSE CS = ZERO SN = ONE R = G END IF ELSE IF( ABS( F ).GT.ABS( G ) ) THEN T = G / F TT = SQRT( ONE+T*T ) CS = ONE / TT SN = T*CS R = F*TT ELSE T = F / G TT = SQRT( ONE+T*T ) SN = ONE / TT CS = T*SN R = G*TT END IF END IF RETURN C C End of DLARTG C END SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) C C -- LAPACK auxiliary routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE INTEGER LDA, M, N C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) C .. C C Purpose C ======= C C DLASR performs the transformation C C A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) C C A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) C C where A is an m by n real matrix and P is an orthogonal matrix, C consisting of a sequence of plane rotations determined by the C parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l' C and z = n when SIDE = 'R' or 'r' ): C C When DIRECT = 'F' or 'f' ( Forward sequence ) then C C P = P( z - 1 )*...*P( 2 )*P( 1 ), C C and when DIRECT = 'B' or 'b' ( Backward sequence ) then C C P = P( 1 )*P( 2 )*...*P( z - 1 ), C C where P( k ) is a plane rotation matrix for the following planes: C C when PIVOT = 'V' or 'v' ( Variable pivot ), C the plane ( k, k + 1 ) C C when PIVOT = 'T' or 't' ( Top pivot ), C the plane ( 1, k + 1 ) C C when PIVOT = 'B' or 'b' ( Bottom pivot ), C the plane ( k, z ) C C c( k ) and s( k ) must contain the cosine and sine that define the C matrix P( k ). The two by two plane rotation part of the matrix C P( k ), R( k ), is assumed to be of the form C C R( k ) = ( c( k ) s( k ) ). C ( -s( k ) c( k ) ) C C This version vectorises across rows of the array A when SIDE = 'L'. C C Arguments C ========= C C SIDE (input) CHARACTER*1 C Specifies whether the plane rotation matrix P is applied to C A on the left or the right. C = 'L': Left, compute A := P*A C = 'R': Right, compute A:= A*P' C C DIRECT (input) CHARACTER*1 C Specifies whether P is a forward or backward sequence of C plane rotations. C = 'F': Forward, P = P( z - 1 )*...*P( 2 )*P( 1 ) C = 'B': Backward, P = P( 1 )*P( 2 )*...*P( z - 1 ) C C PIVOT (input) CHARACTER*1 C Specifies the plane for which P(k) is a plane rotation C matrix. C = 'V': Variable pivot, the plane (k,k+1) C = 'T': Top pivot, the plane (1,k+1) C = 'B': Bottom pivot, the plane (k,z) C C M (input) INTEGER C The number of rows of the matrix A. If m <= 1, an immediate C return is effected. C C N (input) INTEGER C The number of columns of the matrix A. If n <= 1, an C immediate return is effected. C C C, S (input) DOUBLE PRECISION arrays, dimension C (M-1) if SIDE = 'L' C (N-1) if SIDE = 'R' C c(k) and s(k) contain the cosine and sine that define the C matrix P(k). The two by two plane rotation part of the C matrix P(k), R(k), is assumed to be of the form C R( k ) = ( c( k ) s( k ) ). C ( -s( k ) c( k ) ) C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C The m by n matrix A. On exit, A is overwritten by P*A if C SIDE = 'R' or by A*P' if SIDE = 'L'. C C LDA (input) INTEGER C The leading dimension of the array A. LDA >= max(1,M). C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. C .. Local Scalars .. INTEGER I, INFO, J DOUBLE PRECISION CTEMP, STEMP, TEMP C .. C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. C .. External Subroutines .. EXTERNAL XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Test the input parameters C INFO = 0 IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN INFO = 1 ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN INFO = 2 ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) $ THEN INFO = 3 ELSE IF( M.LT.0 ) THEN INFO = 4 ELSE IF( N.LT.0 ) THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = 9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASR ', INFO ) RETURN END IF C C Quick return if possible C IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN C C Form P * A C IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 20 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 10 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 10 CONTINUE END IF 20 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 40 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 30 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 30 CONTINUE END IF 40 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 60 J = 2, M CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 50 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 50 CONTINUE END IF 60 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 80 J = M, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 70 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 70 CONTINUE END IF 80 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 100 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 90 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 90 CONTINUE END IF 100 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 120 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 110 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 110 CONTINUE END IF 120 CONTINUE END IF END IF ELSE IF( LSAME( SIDE, 'R' ) ) THEN C C Form A * P' C IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 140 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 130 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 130 CONTINUE END IF 140 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 160 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 150 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 150 CONTINUE END IF 160 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 180 J = 2, N CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 170 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 170 CONTINUE END IF 180 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 200 J = N, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 190 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 190 CONTINUE END IF 200 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 220 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 210 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 210 CONTINUE END IF 220 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 240 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 230 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 230 CONTINUE END IF 240 CONTINUE END IF END IF END IF C RETURN C C End of DLASR C END SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) C C -- LAPACK auxiliary routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. INTEGER INCX, N DOUBLE PRECISION SCALE, SUMSQ C .. C .. Array Arguments .. DOUBLE PRECISION X( * ) C .. C C Purpose C ======= C C DLASSQ returns the values scl and smsq such that C C ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, C C where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is C assumed to be non-negative and scl returns the value C C scl = max( scale, abs( x( i ) ) ). C C scale and sumsq must be supplied in SCALE and SUMSQ and C scl and smsq are overwritten on SCALE and SUMSQ respectively. C C The routine makes only one pass through the vector x. C C Arguments C ========= C C N (input) INTEGER C The number of elements to be used from the vector X. C C X (input) DOUBLE PRECISION C The vector for which a scaled sum of squares is computed. C x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. C C INCX (input) INTEGER C The increment between successive values of the vector X. C INCX > 0. C C SCALE (input/output) DOUBLE PRECISION C On entry, the value scale in the equation above. C On exit, SCALE is overwritten with scl , the scaling factor C for the sum of squares. C C SUMSQ (input/output) DOUBLE PRECISION C On entry, the value sumsq in the equation above. C On exit, SUMSQ is overwritten with smsq , the basic sum of C squares from which scl has been factored out. C C C .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) C .. C .. Local Scalars .. INTEGER IX DOUBLE PRECISION ABSXI C .. C .. Intrinsic Functions .. INTRINSIC ABS C .. C .. Executable Statements .. C IF( N.GT.0 ) THEN DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX IF( X( IX ).NE.ZERO ) THEN ABSXI = ABS( X( IX ) ) IF( SCALE.LT.ABSXI ) THEN SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 SCALE = ABSXI ELSE SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 END IF END IF 10 CONTINUE END IF RETURN C C End of DLASSQ C END SUBROUTINE DLAZRO( M, N, ALPHA, BETA, A, LDA ) C C -- LAPACK auxiliary routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. INTEGER LDA, M, N DOUBLE PRECISION ALPHA, BETA C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) C .. C C Purpose C ======= C C DLAZRO initializes a 2-D array A to BETA on the diagonal and C ALPHA on the offdiagonals. C C Arguments C ========= C C M (input) INTEGER C The number of rows of the matrix A. M >= 0. C C N (input) INTEGER C The number of columns of the matrix A. N >= 0. C C ALPHA (input) DOUBLE PRECISION C The constant to which the offdiagonal elements are to be set. C C BETA (input) DOUBLE PRECISION C The constant to which the diagonal elements are to be set. C C A (output) DOUBLE PRECISION array, dimension (LDA,N) C On exit, the leading m by n submatrix of A is set such that C A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i <> j C A(i,i) = BETA, 1 <= i <= min(m,n). C C LDA (input) INTEGER C The leading dimension of the array A. LDA >= max(1,M). C C .. Local Scalars .. INTEGER I, J C .. C .. Intrinsic Functions .. INTRINSIC MIN C .. C .. Executable Statements .. C DO 20 J = 1, N DO 10 I = 1, M A( I, J ) = ALPHA 10 CONTINUE 20 CONTINUE C DO 30 I = 1, MIN( M, N ) A( I, I ) = BETA 30 CONTINUE C RETURN C C End of DLAZRO C END SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) C C -- LAPACK routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, LDQ, N C .. C .. Array Arguments .. DOUBLE PRECISION AP( * ), Q( LDQ, * ), TAU( * ), WORK( * ) C .. C C Purpose C ======= C C DOPGTR generates a real orthogonal matrix Q which is defined as the C product of n-1 elementary reflectors of order n, as returned by C DSPTRD using packed storage: C C if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), C C if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). C C Arguments C ========= C C UPLO (input) CHARACTER*1 C Specifies the storage scheme used in the previous call of C DSPTRD: C = 'U': Upper triangular packed storage; C = 'L': Lower triangular packed storage. C C N (input) INTEGER C The order of the matrix Q. N >= 0. C C AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) C The vectors which define the elementary reflectors, as C returned by DSPTRD. C C TAU (input) DOUBLE PRECISION array, dimension (N-1) C TAU(i) must contain the scalar factor of the elementary C reflector H(i), as returned by DSPTRD. C C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) C The n by n orthogonal matrix Q. C C LDQ (input) INTEGER C The leading dimension of the array Q. LDQ >= max(1,N). C C WORK (workspace) DOUBLE PRECISION array, dimension (N-1) C C INFO (output) INTEGER C = 0: successful exit C < 0: if INFO = -i, the i-th argument had an illegal value C C ===================================================================== C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. C .. Local Scalars .. LOGICAL UPPER INTEGER I, IINFO, IJ, J C .. C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. C .. External Subroutines .. EXTERNAL DORG2L, DORG2R, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Test the input arguments C INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DOPGTR', -INFO ) RETURN END IF C C Quick return if possible C IF( N.EQ.0 ) $ RETURN C IF( UPPER ) THEN C C Q was determined by a call to DSPTRD with UPLO = 'U' C C Unpack the vectors which define the elementary reflectors and C set the last row and column of Q equal to those of the unit C matrix C IJ = 2 DO 20 J = 1, N - 1 DO 10 I = 1, J - 1 Q( I, J ) = AP( IJ ) IJ = IJ + 1 10 CONTINUE IJ = IJ + 2 Q( N, J ) = ZERO 20 CONTINUE DO 30 I = 1, N - 1 Q( I, N ) = ZERO 30 CONTINUE Q( N, N ) = ONE C C Generate Q(1:n-1,1:n-1) C CALL DORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO ) C ELSE C C Q was determined by a call to DSPTRD with UPLO = 'L'. C C Unpack the vectors which define the elementary reflectors and C set the first row and column of Q equal to those of the unit C matrix C Q( 1, 1 ) = ONE DO 40 I = 2, N Q( I, 1 ) = ZERO 40 CONTINUE IJ = 3 DO 60 J = 2, N Q( 1, J ) = ZERO DO 50 I = J + 1, N Q( I, J ) = AP( IJ ) IJ = IJ + 1 50 CONTINUE IJ = IJ + 2 60 CONTINUE IF( N.GT.1 ) THEN C C Generate Q(2:n,2:n) C CALL DORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK, $ IINFO ) END IF END IF RETURN C C End of DOPGTR C END SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) C C -- LAPACK routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) C .. C C Purpose C ======= C C DORG2L generates an m by n real matrix Q with orthonormal columns, C which is defined as the last n columns of a product of k elementary C reflectors of order m C C Q = H(k) . . . H(2) H(1) C C as returned by DGEQLF. C C Arguments C ========= C C M (input) INTEGER C The number of rows of the matrix Q. M >= 0. C C N (input) INTEGER C The number of columns of the matrix Q. M >= N >= 0. C C K (input) INTEGER C The number of elementary reflectors whose product defines the C matrix Q. N >= K >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the (n-k+i)-th column must contain the vector which C defines the elementary reflector H(i), for i = 1,2,...,k, as C returned by DGEQLF in the last k columns of its array C argument A. C On exit, the m by n matrix Q. C C LDA (input) INTEGER C The first dimension of the array A. LDA >= max(1,M). C C TAU (input) DOUBLE PRECISION array, dimension (K) C TAU(i) must contain the scalar factor of the elementary C reflector H(i), as returned by DGEQLF. C C WORK (workspace) DOUBLE PRECISION array, dimension (N) C C INFO (output) INTEGER C = 0: successful exit C < 0: if INFO = -i, the i-th argument has an illegal value C C ===================================================================== C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. C .. Local Scalars .. INTEGER I, II, J, L C .. C .. External Subroutines .. EXTERNAL DLARF, DSCAL, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Test the input arguments C INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORG2L', -INFO ) RETURN END IF C C Quick return if possible C IF( N.LE.0 ) $ RETURN C C Initialise columns 1:n-k to columns of the unit matrix C DO 20 J = 1, N - K DO 10 L = 1, M A( L, J ) = ZERO 10 CONTINUE A( M-N+J, J ) = ONE 20 CONTINUE C DO 40 I = 1, K II = N - K + I C C Apply H(i) to A(1:m-k+i,1:n-k+i) from the left C A( M-N+II, II ) = ONE CALL DLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, $ LDA, WORK ) CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) A( M-N+II, II ) = ONE - TAU( I ) C C Set A(m-k+i+1:m,n-k+i) to zero C DO 30 L = M - N + II + 1, M A( L, II ) = ZERO 30 CONTINUE 40 CONTINUE RETURN C C End of DORG2L C END SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) C C -- LAPACK routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. INTEGER INFO, K, LDA, M, N C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) C .. C C Purpose C ======= C C DORG2R generates an m by n real matrix Q with orthonormal columns, C which is defined as the first n columns of a product of k elementary C reflectors of order m C C Q = H(1) H(2) . . . H(k) C C as returned by DGEQRF. C C Arguments C ========= C C M (input) INTEGER C The number of rows of the matrix Q. M >= 0. C C N (input) INTEGER C The number of columns of the matrix Q. M >= N >= 0. C C K (input) INTEGER C The number of elementary reflectors whose product defines the C matrix Q. N >= K >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the i-th column must contain the vector which C defines the elementary reflector H(i), for i = 1,2,...,k, as C returned by DGEQRF in the first k columns of its array C argument A. C On exit, the m-by-n matrix Q. C C LDA (input) INTEGER C The first dimension of the array A. LDA >= max(1,M). C C TAU (input) DOUBLE PRECISION array, dimension (K) C TAU(i) must contain the scalar factor of the elementary C reflector H(i), as returned by DGEQRF. C C WORK (workspace) DOUBLE PRECISION array, dimension (N) C C INFO (output) INTEGER C = 0: successful exit C < 0: if INFO = -i, the i-th argument has an illegal value C C ===================================================================== C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. C .. Local Scalars .. INTEGER I, J, L C .. C .. External Subroutines .. EXTERNAL DLARF, DSCAL, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Test the input arguments C INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 .OR. N.GT.M ) THEN INFO = -2 ELSE IF( K.LT.0 .OR. K.GT.N ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORG2R', -INFO ) RETURN END IF C C Quick return if possible C IF( N.LE.0 ) $ RETURN C C Initialise columns k+1:n to columns of the unit matrix C DO 20 J = K + 1, N DO 10 L = 1, M A( L, J ) = ZERO 10 CONTINUE A( J, J ) = ONE 20 CONTINUE C DO 40 I = K, 1, -1 C C Apply H(i) to A(i:m,i:n) from the left C IF( I.LT.N ) THEN A( I, I ) = ONE CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK ) END IF IF( I.LT.M ) $ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) A( I, I ) = ONE - TAU( I ) C C Set A(1:i-1,i) to zero C DO 30 L = 1, I - 1 A( L, I ) = ZERO 30 CONTINUE 40 CONTINUE RETURN C C End of DORG2R C END SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO ) C C -- LAPACK driver routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER INFO, LDZ, N C .. C .. Array Arguments .. DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * ) C .. C C Purpose C ======= C C DSPEV computes all eigenvalues and, optionally, eigenvectors of a C real symmetric matrix A in packed storage by calling the recommended C sequence of LAPACK routines. C C Arguments C ========= C C JOBZ (input) CHARACTER*1 C Specifies whether or not to compute the eigenvectors: C = 'N': Compute eigenvalues only. C = 'V': Compute eigenvalues and eigenvectors. C C UPLO (input) CHARACTER*1 C Specifies whether the upper or lower triangular part of the C symmetric matrix A is stored: C = 'U': Upper triangular C = 'L': Lower triangular C C N (input) INTEGER C The number of rows and columns of the matrix A. N >= 0. C C AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) C On entry, the upper or lower triangle of the symmetric matrix C A, packed columnwise in a linear array. The j-th column of A C is stored in the array AP as follows: C if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; C if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. C C On exit, AP is overwritten by values generated during the C reduction to tridiagonal form. If UPLO = 'U', the diagonal C and first superdiagonal of the tridiagonal matrix T overwrite C the corresponding elements of A, and if UPLO = 'L', the C diagonal and first subdiagonal of T overwrite the C corresponding elements of A. C C W (output) DOUBLE PRECISION array, dimension (N) C On exit, if INFO = 0, W contains the eigenvalues in ascending C order. If INFO > 0, the eigenvalues are correct for indices C 1, 2, ..., INFO-1, but they are unordered and may not be the C smallest eigenvalues of the matrix. C C Z (output) DOUBLE PRECISION array, dimension (LDZ, N) C If JOBZ = 'V', then if INFO = 0 on exit, Z contains the C orthonormal eigenvectors of the matrix A. If INFO > 0, Z C contains the eigenvectors associated with only the stored C eigenvalues. C If JOBZ = 'N', then Z is not referenced. C C LDZ (input) INTEGER C The leading dimension of the array Z. LDZ >= 1, and if C JOBZ = 'V', LDZ >= max(1,N). C C WORK (workspace) DOUBLE PRECISION array, dimension (3*N) C C INFO (output) INTEGER C = 0: successful exit. C < 0: if INFO = -i, the i-th argument had an illegal value. C > 0: if INFO = +i, the algorithm terminated before finding C the i-th eigenvalue. C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. C .. Local Scalars .. LOGICAL WANTZ INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, $ SMLNUM C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANSP EXTERNAL LSAME, DLAMCH, DLANSP C .. C .. External Subroutines .. EXTERNAL DOPGTR, DSCAL, DSPTRD, DSTEQR, DSTERF, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC SQRT C .. C .. Executable Statements .. C C Test the input parameters. C WANTZ = LSAME( JOBZ, 'V' ) C INFO = 0 IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN INFO = -1 ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) $ THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN INFO = -7 END IF C IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPEV ', -INFO ) RETURN END IF C C Quick return if possible C IF( N.EQ.0 ) $ RETURN C IF( N.EQ.1 ) THEN W( 1 ) = AP( 1 ) IF( WANTZ ) $ Z( 1, 1 ) = ONE RETURN END IF C C Get machine constants. C SAFMIN = DLAMCH( 'Safe minimum' ) EPS = DLAMCH( 'Precision' ) SMLNUM = SAFMIN / EPS BIGNUM = ONE / SMLNUM RMIN = SQRT( SMLNUM ) RMAX = SQRT( BIGNUM ) C C Scale matrix to allowable range, if necessary. C ANRM = DLANSP( 'M', UPLO, N, AP, WORK ) ISCALE = 0 IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN ISCALE = 1 SIGMA = RMAX / ANRM END IF IF( ISCALE.EQ.1 ) THEN CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 ) END IF C C Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. C INDE = 1 INDTAU = INDE + N CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO ) C C For eigenvalues only, call DSTERF. For eigenvectors, first call C DOPGTR to generate the orthogonal matrix, then call DSTEQR. C IF( .NOT.WANTZ ) THEN CALL DSTERF( N, W, WORK( INDE ), INFO ) ELSE INDWRK = INDTAU + N CALL DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ, $ WORK( INDWRK ), IINFO ) CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDTAU ), $ INFO ) END IF C C If matrix was scaled, then rescale eigenvalues appropriately. C IF( ISCALE.EQ.1 ) THEN IF( INFO.EQ.0 ) THEN IMAX = N ELSE IMAX = INFO - 1 END IF CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) END IF C RETURN C C End of DSPEV C END SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO ) C C -- LAPACK routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. CHARACTER UPLO INTEGER INFO, N C .. C .. Array Arguments .. DOUBLE PRECISION AP( * ), D( * ), E( * ), TAU( * ) C .. C C Purpose C ======= C C DSPTRD reduces a real symmetric matrix A stored in packed form to C symmetric tridiagonal form T by an orthogonal similarity C transformation: Q' * A * Q = T. C C Arguments C ========= C C UPLO (input) CHARACTER*1 C Specifies whether the upper or lower triangular part of the C symmetric matrix A is stored: C = 'U': Upper triangular C = 'L': Lower triangular C C N (input) INTEGER C The order of the matrix A. N >= 0. C C AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) C On entry, the upper or lower triangle of the symmetric matrix C A, packed columnwise in a linear array. The j-th column of A C is stored in the array AP as follows: C if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; C if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. C On exit, if UPLO = 'U', the diagonal and first superdiagonal C of A are overwritten by the corresponding elements of the C tridiagonal matrix T, and the elements above the first C superdiagonal, with the array TAU, represent the orthogonal C matrix Q as a product of elementary reflectors; if UPLO C = 'L', the diagonal and first subdiagonal of A are over- C written by the corresponding elements of the tridiagonal C matrix T, and the elements below the first subdiagonal, with C the array TAU, represent the orthogonal matrix Q as a product C of elementary reflectors. See Further Details. C C D (output) DOUBLE PRECISION array, dimension (N) C The diagonal elements of the tridiagonal matrix T: C D(i) = A(i,i). C C E (output) DOUBLE PRECISION array, dimension (N-1) C The off-diagonal elements of the tridiagonal matrix T: C E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. C C TAU (output) DOUBLE PRECISION array, dimension (N) C The scalar factors of the elementary reflectors (see Further C Details). C C INFO (output) INTEGER C = 0: successful exit. C < 0: if INFO = -i, the i-th argument had an illegal value. C C Further Details C =============== C C If UPLO = 'U', the matrix Q is represented as a product of elementary C reflectors C C Q = H(n-1) . . . H(2) H(1). C C Each H(i) has the form C C H(i) = I - tau * v * v' C C where tau is a real scalar, and v is a real vector with C v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP, C overwriting A(1:i-1,i+1), and tau is stored in TAU(i). C C If UPLO = 'L', the matrix Q is represented as a product of elementary C reflectors C C Q = H(1) H(2) . . . H(n-1). C C Each H(i) has the form C C H(i) = I - tau * v * v' C C where tau is a real scalar, and v is a real vector with C v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP, C overwriting A(i+2:n,i), and tau is stored in TAU(i). C C ===================================================================== C C .. Parameters .. DOUBLE PRECISION ONE, ZERO, HALF PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, $ HALF = 1.0D0 / 2.0D0 ) C .. C .. Local Scalars .. LOGICAL UPPER INTEGER I, I1, I1I1, II DOUBLE PRECISION ALPHA, TAUI C .. C .. External Subroutines .. EXTERNAL DAXPY, DLARFG, DSPMV, DSPR2, XERBLA C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT EXTERNAL LSAME, DDOT C .. C .. Executable Statements .. C C Test the input parameters C INFO = 0 UPPER = LSAME( UPLO, 'U' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSPTRD', -INFO ) RETURN END IF C C Quick return if possible C IF( N.LE.0 ) $ RETURN C IF( UPPER ) THEN C C Reduce the upper triangle of A. C I1 is the index in AP of A(1,I+1). C I1 = N*( N-1 ) / 2 + 1 DO 10 I = N - 1, 1, -1 C C Generate elementary reflector H(i) = I - tau * v * v' C to annihilate A(1:i-1,i+1) C CALL DLARFG( I, AP( I1+I-1 ), AP( I1 ), 1, TAUI ) E( I ) = AP( I1+I-1 ) C IF( TAUI.NE.ZERO ) THEN C C Apply H(i) from both sides to A(1:i,1:i) C AP( I1+I-1 ) = ONE C C Compute y := tau * A * v storing y in TAU(1:i) C CALL DSPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU, $ 1 ) C C Compute w := y - 1/2 * tau * (y'*v) * v C ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, AP( I1 ), 1 ) CALL DAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 ) C C Apply the transformation as a rank-2 update: C A := A - v * w' - w * v' C CALL DSPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP ) C AP( I1+I-1 ) = E( I ) END IF D( I+1 ) = AP( I1+I ) TAU( I ) = TAUI I1 = I1 - I 10 CONTINUE D( 1 ) = AP( 1 ) ELSE C C Reduce the lower triangle of A. II is the index in AP of C A(i,i) and I1I1 is the index of A(i+1,i+1). C II = 1 DO 20 I = 1, N - 1 I1I1 = II + N - I + 1 C C Generate elementary reflector H(i) = I - tau * v * v' C to annihilate A(i+2:n,i) C CALL DLARFG( N-I, AP( II+1 ), AP( II+2 ), 1, TAUI ) E( I ) = AP( II+1 ) C IF( TAUI.NE.ZERO ) THEN C C Apply H(i) from both sides to A(i+1:n,i+1:n) C AP( II+1 ) = ONE C C Compute y := tau * A * v storing y in TAU(i+1:n) C CALL DSPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1, $ ZERO, TAU( I+1 ), 1 ) C C Compute w := y - 1/2 * tau * (y'*v) * v C ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I+1 ), 1, AP( II+1 ), $ 1 ) CALL DAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I+1 ), 1 ) C C Apply the transformation as a rank-2 update: C A := A - v * w' - w * v' C CALL DSPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I+1 ), $ 1, AP( I1I1 ) ) C AP( II+1 ) = E( I ) END IF D( I ) = AP( II ) TAU( I ) = TAUI II = I1I1 20 CONTINUE D( N ) = AP( II ) END IF TAU( N ) = ZERO C RETURN C C End of DSPTRD C END SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) C C -- LAPACK routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. CHARACTER COMPZ INTEGER INFO, LDZ, N C .. C .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) C .. C C Purpose C ======= C C DSTEQR computes all eigenvalues and, optionally, eigenvectors of a C symmetric tridiagonal matrix using the implicit QL or QR method. C The eigenvectors of a full or band symmetric matrix can also be found C if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to C tridiagonal form. C C Arguments C ========= C C COMPZ (input) CHARACTER*1 C Specifies whether eigenvectors are to be computed C as follows C C COMPZ = 'N' or 'n' Compute eigenvalues only. C C COMPZ = 'V' or 'v' Compute eigenvectors of original C symmetric matrix also. C Array Z contains the orthogonal C matrix used to reduce the original C matrix to tridiagonal form. C C COMPZ = 'I' or 'i' Compute eigenvectors of C tridiagonal matrix also. C C N (input) INTEGER C The number of rows and columns in the matrix. N >= 0. C C D (input/output) DOUBLE PRECISION array, dimension (N) C On entry, D contains the diagonal elements of the C tridiagonal matrix. C On exit, D contains the eigenvalues, in ascending order. C If an error exit is made, the eigenvalues are correct C for indices 1,2,...,INFO-1, but they are unordered and C may not be the smallest eigenvalues of the matrix. C C E (input/output) DOUBLE PRECISION array, dimension (N) C On entry, E contains the subdiagonal elements of the C tridiagonal matrix in positions 1 through N-1. C E(N) is arbitrary. C On exit, E has been destroyed. C C Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) C If COMPZ = 'V' or 'v', then: C On entry, Z contains the orthogonal matrix used in the C reduction to tridiagonal form. C If COMPZ = 'V' or 'v' or 'I' or 'i', then: C On exit, Z contains the orthonormal eigenvectors of the C symmetric tridiagonal (or full) matrix. If an error exit C is made, Z contains the eigenvectors associated with the C stored eigenvalues. C C If COMPZ = 'N' or 'n', then Z is not referenced. C C LDZ (input) INTEGER C The leading dimension of the array Z. If eigenvectors are C desired, then LDZ >= max( 1, N ). In any case, LDZ >= 1. C C WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) C Workspace used in computing eigenvectors. C If COMPZ = 'N' or 'n', then WORK is not referenced. C C INFO (output) INTEGER C = 0: successful exit. C < 0: if INFO = -i, the i-th argument had an illegal value. C > 0: if INFO = +i, the i-th eigenvalue has not converged C after a total of 30*N iterations. C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) INTEGER MAXIT PARAMETER ( MAXIT = 30 ) C .. C .. Local Scalars .. INTEGER I, ICOMPZ, II, J, JTOT, K, L, L1, LEND, LENDM1, $ LENDP1, LM1, M, MM, MM1, NCONV, NM1, NMAXIT DOUBLE PRECISION B, C, EPS, F, G, P, R, RT1, RT2, S, TST C .. C .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLAPY2 EXTERNAL LSAME, DLAMCH, DLAPY2 C .. C .. External Subroutines .. EXTERNAL DLAE2, DLAEV2, DLARTG, DLASR, DLAZRO, DSWAP, $ XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 C IF( LSAME( COMPZ, 'N' ) ) THEN ICOMPZ = 0 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ICOMPZ = 2 ELSE ICOMPZ = -1 END IF IF( ICOMPZ.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, $ N ) ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSTEQR', -INFO ) RETURN END IF C C Quick return if possible C IF( N.EQ.0 ) $ RETURN C IF( N.EQ.1 ) THEN IF( ICOMPZ.GT.0 ) $ Z( 1, 1 ) = ONE RETURN END IF C C Determine the unit roundoff for this environment. C EPS = DLAMCH( 'E' ) C C Compute the eigenvalues and eigenvectors of the tridiagonal C matrix. C IF( ICOMPZ.EQ.2 ) $ CALL DLAZRO( N, N, ZERO, ONE, Z, LDZ ) C E( N ) = ZERO NMAXIT = N*MAXIT JTOT = 0 NCONV = 0 C C Determine where the matrix splits and choose QL or QR iteration C for each block, according to whether top or bottom diagonal C element is smaller. C L1 = 1 NM1 = N - 1 C 10 CONTINUE IF( L1.GT.N ) $ GO TO 150 IF( L1.LE.NM1 ) THEN DO 20 M = L1, NM1 TST = ABS( E( M ) ) IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) ) $ GO TO 30 20 CONTINUE END IF M = N C 30 CONTINUE L = L1 LEND = M IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN L = LEND LEND = L1 END IF L1 = M + 1 C IF( LEND.GE.L ) THEN C C QL Iteration C C Look for small subdiagonal element. C 40 CONTINUE IF( L.NE.LEND ) THEN LENDM1 = LEND - 1 DO 50 M = L, LENDM1 TST = ABS( E( M ) ) IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) ) $ GO TO 60 50 CONTINUE END IF C M = LEND C 60 CONTINUE P = D( L ) IF( M.EQ.L ) $ GO TO 80 C C If remaining matrix is 2 by 2, use DLAE2 or DLAEV2 C to compute its eigensystem. C IF( M.EQ.L+1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) WORK( L ) = C WORK( N-1+L ) = S CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ), $ WORK( N-1+L ), Z( 1, L ), LDZ ) ELSE CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) END IF D( L ) = RT1 D( L+1 ) = RT2 NCONV = NCONV + 2 L = L + 2 IF( L.LE.LEND ) $ GO TO 40 GO TO 10 END IF C IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 C C Form shift. C G = ( D( L+1 )-P ) / ( TWO*E( L ) ) R = DLAPY2( G, ONE ) G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) C S = ONE C = ONE P = ZERO C C Inner loop C MM1 = M - 1 DO 70 I = MM1, L, -1 F = S*E( I ) B = C*E( I ) CALL DLARTG( G, F, C, S, R ) E( I+1 ) = R G = D( I+1 ) - P R = ( D( I )-G )*S + TWO*C*B P = S*R D( I+1 ) = G + P G = C*R - B C C If eigenvectors are desired, then save rotations. C IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = -S END IF C 70 CONTINUE C C If eigenvectors are desired, then apply saved rotations. C IF( ICOMPZ.GT.0 ) THEN MM = M - L + 1 CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), $ Z( 1, L ), LDZ ) END IF C D( L ) = D( L ) - P E( L ) = G E( M ) = ZERO GO TO 40 C C Eigenvalue found. C 80 CONTINUE D( L ) = P NCONV = NCONV + 1 C L = L + 1 IF( L.LE.LEND ) $ GO TO 40 GO TO 10 C ELSE C C QR Iteration C C Look for small superdiagonal element. C 90 CONTINUE IF( L.NE.LEND ) THEN LENDP1 = LEND + 1 DO 100 M = L, LENDP1, -1 TST = ABS( E( M-1 ) ) IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M-1 ) ) ) ) $ GO TO 110 100 CONTINUE END IF C M = LEND C 110 CONTINUE P = D( L ) IF( M.EQ.L ) $ GO TO 130 C C If remaining matrix is 2 by 2, use DLAE2 or DLAEV2 C to compute its eigensystem. C IF( M.EQ.L-1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) WORK( M ) = C WORK( N-1+M ) = S CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ), $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) ELSE CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) END IF D( L-1 ) = RT1 D( L ) = RT2 NCONV = NCONV + 2 L = L - 2 IF( L.GE.LEND ) $ GO TO 90 GO TO 10 END IF C IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 C C Form shift. C G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) R = DLAPY2( G, ONE ) G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) C S = ONE C = ONE P = ZERO C C Inner loop C LM1 = L - 1 DO 120 I = M, LM1 F = S*E( I ) B = C*E( I ) CALL DLARTG( G, F, C, S, R ) IF( I.NE.1 ) $ E( I-1 ) = R G = D( I ) - P R = ( D( I+1 )-G )*S + TWO*C*B P = S*R D( I ) = G + P G = C*R - B C C If eigenvectors are desired, then save rotations. C IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = S END IF C 120 CONTINUE C C If eigenvectors are desired, then apply saved rotations. C IF( ICOMPZ.GT.0 ) THEN MM = L - M + 1 CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), $ Z( 1, M ), LDZ ) END IF C D( L ) = D( L ) - P E( LM1 ) = G IF( M.NE.1 ) $ E( M-1 ) = ZERO GO TO 90 C C Eigenvalue found. C 130 CONTINUE D( L ) = P NCONV = NCONV + 1 C L = L - 1 IF( L.GE.LEND ) $ GO TO 90 GO TO 10 C END IF C C Set error -- no convergence to an eigenvalue after a total C of N*MAXIT iterations. C 140 CONTINUE INFO = NCONV RETURN C C Order eigenvalues and eigenvectors. C 150 CONTINUE DO 170 II = 2, N I = II - 1 K = I P = D( I ) DO 160 J = II, N IF( D( J ).LT.P ) THEN K = J P = D( J ) END IF 160 CONTINUE IF( K.NE.I ) THEN D( K ) = D( I ) D( I ) = P IF( ICOMPZ.GT.0 ) $ CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) END IF 170 CONTINUE C RETURN C C End of DSTEQR C END SUBROUTINE DSTERF( N, D, E, INFO ) C C -- LAPACK routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. INTEGER INFO, N C .. C .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) C .. C C Purpose C ======= C C DSTERF computes all eigenvalues of a symmetric tridiagonal matrix C using the Pal-Walker-Kahan variant of the QL or QR algorithm. C C Arguments C ========= C C N (input) INTEGER C The number of rows and columns in the matrix. N >= 0. C C D (input/output) DOUBLE PRECISION array, dimension (N) C On entry, D contains the diagonal elements of the C tridiagonal matrix. C On exit, D contains the eigenvalues in ascending order. C If an error exit is made, the eigenvalues are correct C but unordered for indices 1,2,...,INFO-1. C C E (input/output) DOUBLE PRECISION array, dimension (N) C On entry, E contains the subdiagonal elements of the C tridiagonal matrix in positions 1 through N-1. C E(N) is arbitrary. C On exit, E has been destroyed. C C INFO (output) INTEGER C = 0: successful exit. C < 0: if INFO = -i, the i-th argument had an illegal value. C > 0: if INFO = +i, the i-th eigenvalue has not converged C after a total of 30*N iterations. C C .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) INTEGER MAXIT PARAMETER ( MAXIT = 30 ) C .. C .. Local Scalars .. INTEGER I, II, J, JTOT, K, L, L1, LEND, LENDM1, LENDP1, $ LM1, M, MM1, NCONV, NM1, NMAXIT DOUBLE PRECISION ALPHA, BB, C, EPS, GAMMA, OLDC, OLDGAM, P, R, $ RT1, RT2, RTE, S, SIGMA, TST C .. C .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2 EXTERNAL DLAMCH, DLAPY2 C .. C .. External Subroutines .. EXTERNAL DLAE2, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC ABS, SIGN, SQRT C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 C C Quick return if possible C IF( N.LT.0 ) THEN INFO = -1 CALL XERBLA( 'DSTERF', -INFO ) RETURN END IF IF( N.LE.1 ) $ RETURN C C Determine the unit roundoff for this environment. C EPS = DLAMCH( 'E' ) C C Compute the eigenvalues of the tridiagonal matrix. C DO 10 I = 1, N - 1 E( I ) = E( I )**2 10 CONTINUE E( N ) = ZERO C NMAXIT = N*MAXIT SIGMA = ZERO JTOT = 0 NCONV = 0 C C Determine where the matrix splits and choose QL or QR iteration C for each block, according to whether top or bottom diagonal C element is smaller. C L1 = 1 NM1 = N - 1 C 20 CONTINUE IF( L1.GT.N ) $ GO TO 160 IF( L1.LE.NM1 ) THEN DO 30 M = L1, NM1 TST = SQRT( ABS( E( M ) ) ) IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) ) $ GO TO 40 30 CONTINUE END IF M = N C 40 CONTINUE L = L1 LEND = M IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN L = LEND LEND = L1 END IF L1 = M + 1 C IF( LEND.GE.L ) THEN C C QL Iteration C C Look for small subdiagonal element. C 50 CONTINUE IF( L.NE.LEND ) THEN LENDM1 = LEND - 1 DO 60 M = L, LENDM1 TST = SQRT( ABS( E( M ) ) ) IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) ) $ GO TO 70 60 CONTINUE END IF C M = LEND C 70 CONTINUE P = D( L ) IF( M.EQ.L ) $ GO TO 90 C C If remaining matrix is 2 by 2, use DLAE2 to compute its C eigenvalues. C IF( M.EQ.L+1 ) THEN RTE = SQRT( E( L ) ) CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 ) D( L ) = RT1 D( L+1 ) = RT2 NCONV = NCONV + 2 L = L + 2 IF( L.LE.LEND ) $ GO TO 50 GO TO 20 END IF C IF( JTOT.EQ.NMAXIT ) $ GO TO 150 JTOT = JTOT + 1 C C Form shift. C RTE = SQRT( E( L ) ) SIGMA = ( D( L+1 )-P ) / ( TWO*RTE ) R = DLAPY2( SIGMA, ONE ) SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) C C = ONE S = ZERO GAMMA = D( M ) - SIGMA P = GAMMA*GAMMA C C Inner loop C MM1 = M - 1 DO 80 I = MM1, L, -1 BB = E( I ) R = P + BB E( I+1 ) = S*R OLDC = C C = P / R S = BB / R OLDGAM = GAMMA ALPHA = D( I ) GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM D( I+1 ) = OLDGAM + ( ALPHA-GAMMA ) IF( C.NE.ZERO ) THEN P = ( GAMMA*GAMMA ) / C ELSE P = OLDC*BB END IF 80 CONTINUE C E( L ) = S*P D( L ) = SIGMA + GAMMA E( M ) = ZERO GO TO 50 C C Eigenvalue found. C 90 CONTINUE D( L ) = P NCONV = NCONV + 1 C L = L + 1 IF( L.LE.LEND ) $ GO TO 50 GO TO 20 C ELSE C C QR Iteration C C Look for small superdiagonal element. C 100 CONTINUE IF( L.NE.LEND ) THEN LENDP1 = LEND + 1 DO 110 M = L, LENDP1, -1 TST = SQRT( ABS( E( M-1 ) ) ) IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M-1 ) ) ) ) $ GO TO 120 110 CONTINUE END IF C M = LEND C 120 CONTINUE P = D( L ) IF( M.EQ.L ) $ GO TO 140 C C If remaining matrix is 2 by 2, use DLAE2 to compute its C eigenvalues. C IF( M.EQ.L-1 ) THEN RTE = SQRT( E( L-1 ) ) CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 ) D( L ) = RT1 D( L-1 ) = RT2 NCONV = NCONV + 2 L = L - 2 IF( L.GE.LEND ) $ GO TO 100 GO TO 20 END IF C IF( JTOT.EQ.NMAXIT ) $ GO TO 150 JTOT = JTOT + 1 C C Form shift. C RTE = SQRT( E( L-1 ) ) SIGMA = ( D( L-1 )-P ) / ( TWO*RTE ) R = DLAPY2( SIGMA, ONE ) SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) C C = ONE S = ZERO GAMMA = D( M ) - SIGMA P = GAMMA*GAMMA C C Inner loop C LM1 = L - 1 DO 130 I = M, LM1 BB = E( I ) R = P + BB IF( I.NE.1 ) $ E( I-1 ) = S*R OLDC = C C = P / R S = BB / R OLDGAM = GAMMA ALPHA = D( I+1 ) GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM D( I ) = OLDGAM + ( ALPHA-GAMMA ) IF( C.NE.ZERO ) THEN P = ( GAMMA*GAMMA ) / C ELSE P = OLDC*BB END IF 130 CONTINUE C E( LM1 ) = S*P D( L ) = SIGMA + GAMMA IF( M.NE.1 ) $ E( M-1 ) = ZERO GO TO 100 C C Eigenvalue found. C 140 CONTINUE D( L ) = P NCONV = NCONV + 1 C L = L - 1 IF( L.GE.LEND ) $ GO TO 100 GO TO 20 C END IF C C Set error -- no convergence to an eigenvalue after a total C of N*MAXIT iterations. C 150 CONTINUE INFO = NCONV RETURN C C Sort eigenvalues in increasing order. C 160 CONTINUE DO 180 II = 2, N I = II - 1 K = I P = D( I ) DO 170 J = II, N IF( D( J ).LT.P ) THEN K = J P = D( J ) END IF 170 CONTINUE IF( K.NE.I ) THEN D( K ) = D( I ) D( I ) = P END IF 180 CONTINUE C RETURN C C End of DSTERF C END SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) C C -- LAPACK routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C March 18, 1992 C C .. Scalar Arguments .. INTEGER INFO, LDA, M, N C .. C .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ) C .. C C Purpose C ======= C C DGETF2 computes an LU factorization of a general m-by-n matrix A C using partial pivoting with row interchanges. C C The factorization has the form C A = P * L * U C where P is a permutation matrix, L is lower triangular with unit C diagonal elements (lower trapezoidal if m > n), and U is upper C triangular (upper trapezoidal if m < n). C C This is the right-looking Level 2 BLAS version of the algorithm. C C Arguments C ========= C C M (input) INTEGER C The number of rows of the matrix A. M >= 0. C C N (input) INTEGER C The number of columns of the matrix A. N >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the m by n matrix to be factored. C On exit, the factors L and U from the factorization C A = P*L*U; the unit diagonal elements of L are not stored. C C LDA (input) INTEGER C The leading dimension of the array A. LDA >= max(1,M). C C IPIV (output) INTEGER array, dimension (min(M,N)) C The pivot indices; for 1 <= i <= min(M,N), row i of the C matrix was interchanged with row IPIV(i). C C INFO (output) INTEGER C = 0: successful exit C < 0: if INFO = -k, the k-th argument had an illegal value C > 0: if INFO = k, U(k,k) is exactly zero. The factorization C has been completed, but the factor U is exactly C singular, and division by zero will occur if it is used C to solve a system of equations. C C ===================================================================== C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. C .. Local Scalars .. INTEGER J, JP C .. C .. External Functions .. INTEGER IDAMAX EXTERNAL IDAMAX C .. C .. External Subroutines .. EXTERNAL DGER, DSCAL, DSWAP, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGETF2', -INFO ) RETURN END IF C C Quick return if possible C IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN C DO 10 J = 1, MIN( M, N ) C C Find pivot and test for singularity. C JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) IPIV( J ) = JP IF( A( JP, J ).NE.ZERO ) THEN C C Apply the interchange to columns 1:N. C IF( JP.NE.J ) $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) C C Compute elements J+1:M of J-th column. C IF( J.LT.M ) $ CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) C ELSE IF( INFO.EQ.0 ) THEN C INFO = J END IF C IF( J.LT.MIN( M, N ) ) THEN C C Update trailing submatrix. C CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, $ A( J+1, J+1 ), LDA ) END IF 10 CONTINUE RETURN C C End of DGETF2 C END C SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) C C -- LAPACK routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. INTEGER INFO, LDA, M, N C .. C .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ) C .. C C Purpose C ======= C C DGETRF computes an LU factorization of a general m-by-n matrix A C using partial pivoting with row interchanges. C C The factorization has the form C A = P * L * U C where P is a permutation matrix, L is lower triangular with unit C diagonal elements (lower trapezoidal if m > n), and U is upper C triangular (upper trapezoidal if m < n). C C This is the right-looking Level 3 BLAS version of the algorithm. C C Arguments C ========= C C M (input) INTEGER C The number of rows of the matrix A. M >= 0. C C N (input) INTEGER C The number of columns of the matrix A. N >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the m by n matrix to be factored. C On exit, the factors L and U from the factorization C A = P*L*U; the unit diagonal elements of L are not stored. C C LDA (input) INTEGER C The leading dimension of the array A. LDA >= max(1,M). C C IPIV (output) INTEGER array, dimension (min(M,N)) C The pivot indices; for 1 <= i <= min(M,N), row i of the C matrix was interchanged with row IPIV(i). C C INFO (output) INTEGER C = 0: successful exit C < 0: if INFO = -k, the k-th argument had an illegal value C > 0: if INFO = k, U(k,k) is exactly zero. The factorization C has been completed, but the factor U is exactly C singular, and division by zero will occur if it is used C to solve a system of equations. C C ===================================================================== C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) C .. C .. Local Scalars .. INTEGER I, IINFO, J, JB, NB C .. C .. External Subroutines .. EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA C .. C .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV C .. C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGETRF', -INFO ) RETURN END IF C C Quick return if possible C IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN C C Determine the block size for this environment. C NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN C C Use unblocked code. C CALL DGETF2( M, N, A, LDA, IPIV, INFO ) ELSE C C Use blocked code. C DO 20 J = 1, MIN( M, N ), NB JB = MIN( MIN( M, N )-J+1, NB ) C C Factor diagonal and subdiagonal blocks and test for exact C singularity. C CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) C C Adjust INFO and the pivot indices. C IF( INFO.EQ.0 .AND. IINFO.GT.0 ) $ INFO = IINFO + J - 1 DO 10 I = J, MIN( M, J+JB-1 ) IPIV( I ) = J - 1 + IPIV( I ) 10 CONTINUE C C Apply interchanges to columns 1:J-1. C CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) C IF( J+JB.LE.N ) THEN C C Apply interchanges to columns J+JB:N. C CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, $ IPIV, 1 ) C C Compute block row of U. C CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), $ LDA ) IF( J+JB.LE.M ) THEN C C Update trailing submatrix. C CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), $ LDA ) END IF END IF 20 CONTINUE END IF RETURN C C End of DGETRF C END C SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) C C -- LAPACK routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. INTEGER INFO, LDA, LWORK, N C .. C .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), WORK( LWORK ) C .. C C Purpose C ======= C C DGETRI computes the inverse of a matrix using the LU factorization C computed by DGETRF. C C This method inverts U and then computes inv(A) by solving the system C inv(A)*L = inv(U) for inv(A). C C Arguments C ========= C C N (input) INTEGER C The order of the matrix A. N >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the factors L and U from the factorization C A = P*L*U as computed by DGETRF. C On exit, if INFO = 0, the inverse of the original matrix A. C C LDA (input) INTEGER C The leading dimension of the array A. LDA >= max(1,N). C C IPIV (input) INTEGER array, dimension (N) C The pivot indices from DGETRF; for 1<=i<=N, row i of the C matrix was interchanged with row IPIV(i). C C WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) C If INFO returns 0, then WORK(1) returns N*NB, the minimum C value of LWORK required to use the optimal blocksize. C C LWORK (input) INTEGER C The dimension of the array WORK. LWORK >= max(1,N). C For optimal performance LWORK should be at least N*NB, C where NB is the optimal blocksize returned by ILAENV. C C INFO (output) INTEGER C = 0: successful exit C < 0: if INFO = -k, the k-th argument had an illegal value C > 0: if INFO = k, U(k,k) is exactly zero; the matrix is C singular and its inverse could not be computed. C C ===================================================================== C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) C .. C .. Local Scalars .. INTEGER I, IWS, J, JB, JJ, JP, LDWORK, NB, NBMIN, NN C .. C .. External Functions .. INTEGER ILAENV EXTERNAL ILAENV C .. C .. External Subroutines .. EXTERNAL DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 WORK( 1 ) = MAX( N, 1 ) IF( N.LT.0 ) THEN INFO = -1 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -3 ELSE IF( LWORK.LT.N ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGETRI', -INFO ) RETURN END IF C C Quick return if possible C IF( N.EQ.0 ) $ RETURN C C Form inv(U). If INFO > 0 from DTRTRI, then U is singular, C and the inverse is not computed. C CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO ) IF( INFO.GT.0 ) $ RETURN C C Determine the block size for this environment. C NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 ) NBMIN = 2 LDWORK = N IF( NB.GT.1 .AND. NB.LT.N ) THEN IWS = MAX( LDWORK*NB, 1 ) IF( LWORK.LT.IWS ) THEN NB = LWORK / LDWORK NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) ) END IF ELSE IWS = N END IF C C Solve the equation inv(A)*L = inv(U) for inv(A). C IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN C C Use unblocked code. C DO 20 J = N, 1, -1 C C Copy current column of L to WORK and replace with zeros. C DO 10 I = J + 1, N WORK( I ) = A( I, J ) A( I, J ) = ZERO 10 CONTINUE C C Compute current column of inv(A). C IF( J.LT.N ) $ CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ), $ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 ) 20 CONTINUE ELSE C C Use blocked code. C NN = ( ( N-1 ) / NB )*NB + 1 DO 50 J = NN, 1, -NB JB = MIN( NB, N-J+1 ) C C Copy current block column of L to WORK and replace with C zeros. C DO 40 JJ = J, J + JB - 1 DO 30 I = JJ + 1, N WORK( I+( JJ-J )*LDWORK ) = A( I, JJ ) A( I, JJ ) = ZERO 30 CONTINUE 40 CONTINUE C C Compute current block column of inv(A). C IF( J+JB.LE.N ) $ CALL DGEMM( 'No transpose', 'No transpose', N, JB, $ N-J-JB+1, -ONE, A( 1, J+JB ), LDA, $ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA ) CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB, $ ONE, WORK( J ), LDWORK, A( 1, J ), LDA ) 50 CONTINUE END IF C C Apply column interchanges. C DO 60 J = N - 1, 1, -1 JP = IPIV( J ) IF( JP.NE.J ) $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) 60 CONTINUE C WORK( 1 ) = IWS RETURN C C End of DGETRI C END C SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) C C -- LAPACK routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. CHARACTER TRANS INTEGER INFO, LDA, LDB, N, NRHS C .. C .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ), B( LDB, * ) C .. C C Purpose C ======= C C DGETRS solves a system of linear equations C A * X = B or A' * X = B C with a general n by n matrix A using the LU factorization computed C by DGETRF. C C Arguments C ========= C C TRANS (input) CHARACTER*1 C Specifies the form of the system of equations. C = 'N': A * X = B (No transpose) C = 'T': A'* X = B (Transpose) C = 'C': A'* X = B (Conjugate transpose = Transpose) C C N (input) INTEGER C The order of the matrix A. N >= 0. C C NRHS (input) INTEGER C The number of right hand sides, i.e., the number of columns C of the matrix B. NRHS >= 0. C C A (input) DOUBLE PRECISION array, dimension (LDA,N) C The factors L and U from the factorization A = P*L*U C as computed by DGETRF. C C LDA (input) INTEGER C The leading dimension of the array A. LDA >= max(1,N). C C IPIV (input) INTEGER array, dimension (N) C The pivot indices from DGETRF; for 1<=i<=N, row i of the C matrix was interchanged with row IPIV(i). C C B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) C On entry, the right hand side vectors B for the system of C linear equations. C On exit, the solution vectors, X. C C LDB (input) INTEGER C The leading dimension of the array B. LDB >= max(1,N). C C INFO (output) INTEGER C = 0: successful exit C < 0: if INFO = -k, the k-th argument had an illegal value C C ===================================================================== C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) C .. C .. Local Scalars .. LOGICAL NOTRAN C .. C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. C .. External Subroutines .. EXTERNAL DLASWP, DTRSM, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 NOTRAN = LSAME( TRANS, 'N' ) IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGETRS', -INFO ) RETURN END IF C C Quick return if possible C IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN C IF( NOTRAN ) THEN C C Solve A * X = B. C C Apply row interchanges to the right hand sides. C CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) C C Solve L*X = B, overwriting B with X. C CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, $ ONE, A, LDA, B, LDB ) C C Solve U*X = B, overwriting B with X. C CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, $ NRHS, ONE, A, LDA, B, LDB ) ELSE C C Solve A' * X = B. C C Solve U'*X = B, overwriting B with X. C CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, $ ONE, A, LDA, B, LDB ) C C Solve L'*X = B, overwriting B with X. C CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, $ A, LDA, B, LDB ) C C Apply row interchanges to the solution vectors. C CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) END IF C RETURN C C End of DGETRS C END C SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) C C -- LAPACK auxiliary routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N C .. C .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION A( LDA, * ) C .. C C Purpose C ======= C C DLASWP performs a series of row interchanges on the matrix A. C One row interchange is initiated for each of rows K1 through K2 of A. C C Arguments C ========= C C N (input) INTEGER C The number of columns of the matrix A. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the matrix of column dimension N to which the row C interchanges will be applied. C On exit, the permuted matrix. C C LDA (input) INTEGER C The leading dimension of the array A. C C K1 (input) INTEGER C The first element of IPIV for which a row interchange will C be done. C C K2 (input) INTEGER C The last element of IPIV for which a row interchange will C be done. C C IPIV (input) INTEGER array, dimension (M*abs(INCX)) C The vector of pivot indices. Only the elements in positions C K1 through K2 of IPIV are accessed. C IPIV(K) = L implies rows K and L are to be interchanged. C C INCX (input) INTEGER C The increment between successive values of IPIV. If IPIV C is negative, the pivots are applied in reverse order. C C C .. Local Scalars .. INTEGER I, IP, IX C .. C .. External Subroutines .. EXTERNAL DSWAP C .. C .. Executable Statements .. C C Interchange row I with row IPIV(I) for each of rows K1 through K2. C IF( INCX.EQ.0 ) $ RETURN IF( INCX.GT.0 ) THEN IX = K1 ELSE IX = 1 + ( 1-K2 )*INCX END IF IF( INCX.EQ.1 ) THEN DO 10 I = K1, K2 IP = IPIV( I ) IF( IP.NE.I ) $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) 10 CONTINUE ELSE IF( INCX.GT.1 ) THEN DO 20 I = K1, K2 IP = IPIV( IX ) IF( IP.NE.I ) $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) IX = IX + INCX 20 CONTINUE ELSE IF( INCX.LT.0 ) THEN DO 30 I = K2, K1, -1 IP = IPIV( IX ) IF( IP.NE.I ) $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) IX = IX + INCX 30 CONTINUE END IF C RETURN C C End of DLASWP C END C SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) C C -- LAPACK routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. CHARACTER DIAG, UPLO INTEGER INFO, LDA, N C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) C .. C C Purpose C ======= C C DTRTI2 computes the inverse of a real upper or lower triangular C matrix. C C This is the Level 2 BLAS version of the algorithm. C C Arguments C ========= C C UPLO (input) CHARACTER*1 C Specifies whether the matrix A is upper or lower triangular. C = 'U': Upper triangular C = 'L': Lower triangular C C DIAG (input) CHARACTER*1 C Specifies whether or not the matrix A is unit triangular. C = 'N': Non-unit triangular C = 'U': Unit triangular C C N (input) INTEGER C The order of the matrix A. N >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the triangular matrix A. If UPLO = 'U', the C leading n by n upper triangular part of the array A contains C the upper triangular matrix, and the strictly lower C triangular part of A is not referenced. If UPLO = 'L', the C leading n by n lower triangular part of the array A contains C the lower triangular matrix, and the strictly upper C triangular part of A is not referenced. If DIAG = 'U', the C diagonal elements of A are also not referenced and are C assumed to be 1. C C On exit, the (triangular) inverse of the original matrix, in C the same storage format. C C LDA (input) INTEGER C The leading dimension of the array A. LDA >= max(1,N). C C INFO (output) INTEGER C = 0: successful exit C < 0: if INFO = -k, the k-th argument had an illegal value C C ===================================================================== C C .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) C .. C .. Local Scalars .. LOGICAL NOUNIT, UPPER INTEGER J DOUBLE PRECISION AJJ C .. C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. C .. External Subroutines .. EXTERNAL DSCAL, DTRMV, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOUNIT = LSAME( DIAG, 'N' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRTI2', -INFO ) RETURN END IF C IF( UPPER ) THEN C C Compute inverse of upper triangular matrix. C DO 10 J = 1, N IF( NOUNIT ) THEN A( J, J ) = ONE / A( J, J ) AJJ = -A( J, J ) ELSE AJJ = -ONE END IF C C Compute elements 1:j-1 of j-th column. C CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, $ A( 1, J ), 1 ) CALL DSCAL( J-1, AJJ, A( 1, J ), 1 ) 10 CONTINUE ELSE C C Compute inverse of lower triangular matrix. C DO 20 J = N, 1, -1 IF( NOUNIT ) THEN A( J, J ) = ONE / A( J, J ) AJJ = -A( J, J ) ELSE AJJ = -ONE END IF IF( J.LT.N ) THEN C C Compute elements j+1:n of j-th column. C CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J, $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 ) END IF 20 CONTINUE END IF C RETURN C C End of DTRTI2 C END C SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) C C -- LAPACK routine (version 1.0) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 29, 1992 C C .. Scalar Arguments .. CHARACTER DIAG, UPLO INTEGER INFO, LDA, N C .. C .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) C .. C C Purpose C ======= C C DTRTRI computes the inverse of a real upper or lower triangular C matrix A. C C This is the Level 3 BLAS version of the algorithm. C C Arguments C ========= C C UPLO (input) CHARACTER*1 C Specifies whether the matrix A is upper or lower triangular. C = 'U': Upper triangular C = 'L': Lower triangular C C DIAG (input) CHARACTER*1 C Specifies whether or not the matrix A is unit triangular. C = 'N': Non-unit triangular C = 'U': Unit triangular C C N (input) INTEGER C The order of the matrix A. N >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C C On entry, the triangular matrix A. If UPLO = 'U', the C leading n by n upper triangular part of the array A contains C the upper triangular matrix, and the strictly lower C triangular part of A is not referenced. If UPLO = 'L', the C leading n by n lower triangular part of the array A contains C the lower triangular matrix, and the strictly upper C triangular part of A is not referenced. If DIAG = 'U', the C diagonal elements of A are also not referenced and are C assumed to be 1. C C On exit, the (triangular) inverse of the original matrix, in C the same storage format. C C LDA (input) INTEGER C The leading dimension of the array A. LDA >= max(1,N). C C INFO (output) INTEGER C = 0: successful exit C > 0: if INFO = k, A(k,k) is exactly zero. The triangular C matrix is singular and its inverse can not be computed. C < 0: if INFO = -k, the k-th argument had an illegal value C C ===================================================================== C C .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) C .. C .. Local Scalars .. LOGICAL NOUNIT, UPPER INTEGER J, JB, NB, NN C .. C .. External Functions .. LOGICAL LSAME INTEGER ILAENV EXTERNAL LSAME, ILAENV C .. C .. External Subroutines .. EXTERNAL DTRMM, DTRSM, DTRTI2, XERBLA C .. C .. Intrinsic Functions .. INTRINSIC MAX, MIN C .. C .. Executable Statements .. C C Test the input parameters. C INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOUNIT = LSAME( DIAG, 'N' ) IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -5 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRTRI', -INFO ) RETURN END IF C C Quick return if possible C IF( N.EQ.0 ) $ RETURN C C Check for singularity if non-unit. C IF( NOUNIT ) THEN DO 10 INFO = 1, N IF( A( INFO, INFO ).EQ.ZERO ) $ RETURN 10 CONTINUE INFO = 0 END IF C C Determine the block size for this environment. C NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 ) IF( NB.LE.1 .OR. NB.GE.N ) THEN C C Use unblocked code C CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) ELSE C C Use blocked code C IF( UPPER ) THEN C C Compute inverse of upper triangular matrix C DO 20 J = 1, N, NB JB = MIN( NB, N-J+1 ) C C Compute rows 1:j-1 of current block column C CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1, $ JB, ONE, A, LDA, A( 1, J ), LDA ) CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1, $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA ) C C Compute inverse of current diagonal block C CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO ) 20 CONTINUE ELSE C C Compute inverse of lower triangular matrix C NN = ( ( N-1 ) / NB )*NB + 1 DO 30 J = NN, 1, -NB JB = MIN( NB, N-J+1 ) IF( J+JB.LE.N ) THEN C C Compute rows j+jb:n of current block column C CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG, $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA, $ A( J+JB, J ), LDA ) CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG, $ N-J-JB+1, JB, -ONE, A( J, J ), LDA, $ A( J+JB, J ), LDA ) END IF C C Compute inverse of current diagonal block C CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO ) 30 CONTINUE END IF END IF C RETURN C C End of DTRTRI C END C INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, $ N4 ) C C -- LAPACK auxiliary routine (preliminary version) -- C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., C Courant Institute, Argonne National Lab, and Rice University C February 20, 1992 C C .. Scalar Arguments .. CHARACTER*( * ) NAME, OPTS INTEGER ISPEC, N1, N2, N3, N4 C .. C C Purpose C ======= C C ILAENV is called from the LAPACK routines to choose problem-dependent C parameters for the local environment. See ISPEC for a description of C the parameters. C C This version provides a set of parameters which should give good, C but not optimal, performance on many of the currently available C computers. Users are encouraged to modify this subroutine to set C the tuning parameters for their particular machine using the option C and problem size information in the arguments. C C This routine will not function correctly if it is converted to all C lower case. Converting it to all upper case is allowed. C C Arguments C ========= C C ISPEC (input) INTEGER C Specifies the parameter to be returned as the value of C ILAENV. C = 1: the optimal blocksize; if this value is 1, an unblocked C algorithm will give the best performance. C = 2: the minimum block size for which the block routine C should be used; if the usable block size is less than C this value, an unblocked routine should be used. C = 3: the crossover point (in a block routine, for N less C than this value, an unblocked routine should be used) C = 4: the number of shifts, used in the nonsymmetric C eigenvalue routines C = 5: the minimum column dimension for blocking to be used; C rectangular blocks must have dimension at least k by m, C where k is given by ILAENV(2,...) and m by ILAENV(5,...) C = 6: the crossover point for the SVD (when reducing an m by n C matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds C this value, a QR factorization is used first to reduce C the matrix to a triangular form.) C = 7: the number of processors C = 8: the crossover point for the multishift QR and QZ methods C for nonsymmetric eigenvalue problems. C C NAME (input) CHARACTER*(*) C The name of the calling subroutine, in either upper case or C lower case. C C OPTS (input) CHARACTER*(*) C The character options to the subroutine NAME, concatenated C into a single character string. For example, UPLO = 'U', C TRANS = 'T', and DIAG = 'N' for a triangular routine would C be specified as OPTS = 'UTN'. C C N1 (input) INTEGER C N2 (input) INTEGER C N3 (input) INTEGER C N4 (input) INTEGER C Problem dimensions for the subroutine NAME; these may not all C be required. C C (ILAENV) (output) INTEGER C >= 0: the value of the parameter specified by ISPEC C < 0: if ILAENV = -k, the k-th argument had an illegal value. C C Further Details C =============== C C The following conventions have been used when calling ILAENV from the C LAPACK routines: C 1) OPTS is a concatenation of all of the character options to C subroutine NAME, in the same order that they appear in the C argument list for NAME, even if they are not used in determining C the value of the parameter specified by ISPEC. C 2) The problem dimensions N1, N2, N3, N4 are specified in the order C that they appear in the argument list for NAME. N1 is used C first, N2 second, and so on, and unused problem dimensions are C passed a value of -1. C 3) The parameter value returned by ILAENV is checked for validity in C the calling subroutine. For example, ILAENV is used to retrieve C the optimal blocksize for STRTRI as follows: C C NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) C IF( NB.LE.1 ) NB = MAX( 1, N ) C C ===================================================================== C C .. Local Scalars .. LOGICAL CNAME, SNAME CHARACTER*1 C1 C C Added by Bob Fay C CHARACTER*1 CZ C CHARACTER*2 C2, C4 CHARACTER*3 C3 CHARACTER*6 SUBNAM INTEGER I, IC, IZ, NB, NBMIN, NX C .. C .. Intrinsic Functions .. INTRINSIC CHAR, ICHAR, INT, MIN, REAL C C Added by Bob Fay C DATA CZ/'Z'/ C .. C .. Executable Statements .. C GO TO ( 100, 100, 100, 400, 500, 600, 700, 800 ) ISPEC C C Invalid value for ISPEC C ILAENV = -1 RETURN C 100 CONTINUE C C Convert NAME to upper case if the first character is lower case. C ILAENV = 1 SUBNAM = NAME IC = ICHAR( SUBNAM( 1:1 ) ) C C Change by Bob Fay C C IZ = ICHAR( 'Z' ) C IZ = ICHAR ( CZ ) IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN C C ASCII character set C IF( IC.GE.97 .AND. IC.LE.122 ) THEN SUBNAM( 1:1 ) = CHAR( IC-32 ) DO 10 I = 2, 6 IC = ICHAR( SUBNAM( I:I ) ) IF( IC.GE.97 .AND. IC.LE.122 ) $ SUBNAM( I:I ) = CHAR( IC-32 ) 10 CONTINUE END IF C ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN C C EBCDIC character set C IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN SUBNAM( 1:1 ) = CHAR( IC+64 ) DO 20 I = 2, 6 IC = ICHAR( SUBNAM( I:I ) ) IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) ) $ SUBNAM( I:I ) = CHAR( IC+64 ) 20 CONTINUE END IF C ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN C C Prime machines: ASCII+128 C IF( IC.GE.225 .AND. IC.LE.250 ) THEN SUBNAM( 1:1 ) = CHAR( IC-32 ) DO 30 I = 2, 6 IC = ICHAR( SUBNAM( I:I ) ) IF( IC.GE.225 .AND. IC.LE.250 ) $ SUBNAM( I:I ) = CHAR( IC-32 ) 30 CONTINUE END IF END IF C C1 = SUBNAM( 1:1 ) SNAME = C1.EQ.'S' .OR. C1.EQ.'D' CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' IF( .NOT.( CNAME .OR. SNAME ) ) $ RETURN C2 = SUBNAM( 2:3 ) C3 = SUBNAM( 4:6 ) C4 = C3( 2:3 ) C GO TO ( 110, 200, 300 ) ISPEC C 110 CONTINUE C C ISPEC = 1: block size C C In these examples, separate code is provided for setting NB for C real and complex. We assume that NB will take the same value in C single or double precision. C NB = 1 C IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'PO' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN NB = 1 ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN NB = 64 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRF' ) THEN NB = 64 ELSE IF( C3.EQ.'TRD' ) THEN NB = 1 ELSE IF( C3.EQ.'GST' ) THEN NB = 64 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF END IF ELSE IF( C2.EQ.'GB' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN IF( N4.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF ELSE IF( N4.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF END IF END IF ELSE IF( C2.EQ.'PB' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN IF( N2.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF ELSE IF( N2.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF END IF END IF ELSE IF( C2.EQ.'TR' ) THEN IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'LA' ) THEN IF( C3.EQ.'UUM' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN IF( C3.EQ.'EBZ' ) THEN NB = 1 END IF END IF ILAENV = NB RETURN C 200 CONTINUE C C ISPEC = 2: minimum block size C NBMIN = 2 IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN NBMIN = 2 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRD' ) THEN NBMIN = 2 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF END IF END IF ILAENV = NBMIN RETURN C 300 CONTINUE C C ISPEC = 3: crossover point C NX = 0 IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( SNAME .AND. C3.EQ.'TRD' ) THEN NX = 1 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRD' ) THEN NX = 1 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NX = 128 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NX = 128 END IF END IF END IF ILAENV = NX RETURN C 400 CONTINUE C C ISPEC = 4: number of shifts (used by xHSEQR) C ILAENV = 6 RETURN C 500 CONTINUE C C ISPEC = 5: minimum column dimension (not used) C ILAENV = 2 RETURN C 600 CONTINUE C C ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) C ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) RETURN C 700 CONTINUE C C ISPEC = 7: number of processors (not used) C ILAENV = 1 RETURN C 800 CONTINUE C C ISPEC = 8: crossover point for multishift (used by xHSEQR) C ILAENV = 50 RETURN C C End of ILAENV C END C C Start of M.FOR - MERGE step C SUBROUTINE VMERGE C C Note: Usage of storage and common blocks has been largely patterned C after the TRANSFORM step. C C Several checks, e.g., matching number of variance IDs etc., are C built into the new syntax but not the old. 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) PARAMETER (MTRANS=1500,MRANGS=20) PARAMETER (MTRSZI=MSIZEI+6*MRANGE-6*MRANGS+2*MRNSET+MRECOD+MVAR) PARAMETER (IXFLLD=49+3*MAXIDS) PARAMETER (NOPTNT=2,NOPTNV=9) PARAMETER (MAXSUB=500,MAXSBL=2000) 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 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 Usage in this subroutine: C V1 - Variable number (or block no. if V2=9) C V2 - Transformation code (used to indicate n(block) only) C V3 - Pointer to 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,ICHECK EXTERNAL REFRSH,ALPCHK,ICHECK INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID, . SDWRK,VKEEPF,ISTEPC,ISELEC,IOUTPT,IAS,IASLST,NCRVLB,NASVL, . IFLLVL,IXFILL(IXFLLD) COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT, . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF, . IFLLVL,ISTEPC,ISELEC,IOUTPT,IAS,IASLST,NCRVLB,NASVL,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 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: C C BLVSTR - (Values from primary input saved to include in output C file.) Beginning variable of block. C BLVSIZ - read from incoming file, used to compute block numbers C in MXSIZE. C BLNCLS - number of classes in block C BLCPNT - pointer for classes to CLPNT and CLTYPE C CLPNT - used as pointers to class variables C INTEGER ITYPEF(3),IFILEF(3) LOGICAL LTEMP,ENDMRG DOUBLE PRECISION MISSNG C CHARACTER*12 OPTNT(NOPTNT),OPTNV(NOPTNV) INTEGER INDXT(NOPTNT),INDXV(NOPTNV) INTEGER IVALT(NOPTNT),IVALV(NOPTNV) DATA OPTNT / 'ZEROFILL ','MISSINGFILL '/ DATA OPTNV / 'BYGROUP ','CONSTANTS ','REPLICATE ', . 'CONSTANT ','FULL ','BYREPEAT ', . 'REPEAT ','IDCHECK ','NOIDCHECK '/ DATA INDXV/3,3,3,3,3,3,3,4,4/ DATA INDXT/1,1/ DATA IVALT/0,1/ DATA IVALV/1,2,3,2,1,4,4,1,0/ DATA MISSNG/-98765.432109D0/ C 200 FORMAT(/,5X,'WARNING: The SELECT variable is not associated with', . ' one or more blocks') C C Initializations. C RCEIL(1) - maximum size of integer array, set to parameter value C NPASS - index to variable arguments to copy C Each variable to be copied requires 2 levels of NPASS: C One for INCORPORATEd file and one for merged file. C NTRANS - number of input VPLX files, including primary file C ENDMRG set to true on end of file or when encountering C a command from another step. C ISOPTN = 1 step options have been set C RCEIL(1)=MTRSZI NPASS=0 NTRANS=1 ENDMRG=.FALSE. ISOPTN=0 IFLLVL=0 C C C IX(NTRANS*12-11) = Starting location in IX for options C IX(NTRANS*12-10) = Starting location in IX for values copied from C block information arrays C IX(NTRANS*12-9) = Number of blocks (from ANCLBL) C IX(NTRANS*12-8) = Number of elements in class specifications for C block (from ANCLBR) C IX(NTRANS*12-7) = Number of variables (from ANVTOT) C IX(NTRANS*12-6) = 2*Number of variables to move (counting block N) C IX(NTRANS*12-5) = Starting value of NPASS C IX(NTRANS*12-4) = Starting location for ID C IX(NTRANS*12-3) = Starting location for DX C C SICMUL - starting position in IX for multipliers showing for each C block the multiplying effect of the class variables. C TMOVE1 and TMOVE2 use SICMUL, in COMMON, under some C conditions. Set the array up to full MCLBLK size here. C C Error call if parameter MTRSZI is too small. C SICMUL=1+12*MTRANS NXPTI=SICMUL+MCLBLK IF(NXPTI+12.GT.MTRSZI) THEN CALL FESTOP(130001) END IF 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) IF(IKEY.EQ.197) THEN C ! Set ISTEPC to identify step ISTEPC=1 C ! MERGE ELSE ISTEPC=2 C ! EXTRACT END IF CALL FNREAD(IPT,ITYPEF,IFILEF,1,IPOSSC) 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(130002) END IF C C Call PREAMB to read the metadata on the primary input file, C CALL PREAMB 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 C NVIN=NVTOT IV=0 C C Store the number of the block for each variable in MXSIZE C DO 8 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 8 CONTINUE C C Allocate and initialize room for options (including FORTRAN file C number.) C IX(NTRANS*12-11)=NXPTI I=NXPTI CALL ROOMI(10) IX(I)=12 IX(I+1)=0 IX(I+2)=0 IX(I+3)=0 C C C ** Copy values into upper end of arrays in the same manner as C PREAMD. C ANVTOT=NVTOT ANVREG=NVREG ANCLSS=NCLASS ATSIZE=TSIZE ANCLBL=NCLBLK ANCLBR=NCLBAR ANCRVL=NCRVL ANVRID=NVARID ANBY=NBY CALL RCHECK(2,NVTOT,ANVTOT) ICLBLK=RCEIL(8)-ANCLBL+1 ANID=NID ANIDTT=NIDTOT CALL RCHECK(8,NCLBLK,ANCLBL) CALL RCHECK(9,NCLBAR,ANCLBR) I=RCEIL(8)-ANCLBL+1 C C Copying of block arrays. C DO 10 J=1,ANCLBL BLTYPE(I)=BLTYPE(J) BLXSTR(I)=BLXSTR(J) BLXINC(I)=BLXINC(J) BLXSIZ(I)=BLXSIZ(J) BLVSTR(I)=BLVSTR(J) BLVSIZ(I)=BLVSIZ(J) BLNCLS(I)=BLNCLS(J) BLCPNT(I)=BLCPNT(J) IX(SICMUL+I-1)=BLXSIZ(J)/BLXINC(J) C C Adjust BLCPNT to point to actual entries in CLPNT, CLTYPE. C Note: BLXSTR, BLVSTR are not adjusted for high-end positioning C and thus give relative, not actual, positions C IF(BLCPNT(I).GT.0) THEN BLCPNT(I)=BLCPNT(I)+RCEIL(9)-ANCLBR END IF I=I+1 10 CONTINUE C IF(ANCLBR.GT.0) THEN C C Adjust CLPNT to point to actual positions of class variables. C I=RCEIL(9)-ANCLBR+1 DO 12 J=1,ANCLBR CLTYPE(I)=CLTYPE(J) CLPNT(I)=CLPNT(J)+RCEIL(2)-ANVTOT I=I+1 12 CONTINUE C END IF IF(ANVTOT.GT.0) THEN I=RCEIL(2)-ANVTOT+1 DO 14 J=1,ANVTOT MTYPE(I)=MTYPE(J) MSIZE(I)=MSIZE(J) VNAME(I)=VNAME(J) IF(LPOINT(J).GT.0)LPOINT(I)=LPOINT(J)+RCEIL(7)-ANCRVL C C Note: MXSIZE is adjusted to give actual block numbers. C MXSIZE(I)=MXSIZE(J)+RCEIL(8)-ANCLBL I=I+1 14 CONTINUE END IF C C VMAPL contains pointers to the first ANVREG variables C These are relative positions; actual positions not determined C here. C IF(ANVREG.GT.0) THEN I=RCEIL(2)-ANVTOT+1 DO 16 J=1,ANVREG VMAPL(I)=VMAPL(J) I=I+1 16 CONTINUE END IF IF(ANCRVL.GT.0) THEN I=RCEIL(7)-ANCRVL+1 DO 17 J=1,ANCRVL LEVEL(I)=LEVEL(J) I=I+1 17 CONTINUE END IF C C ISELEC - class variable identified by SELECT C IOUTPT - class variable identified by OUTPUT class C IAS - class variable identified by AS C IASLST - pointer in IX to list from AS C NASLST - number of elements in ASTLST list C NCRVLB - if labels are read with an AS statement, they will be C read after this point C NASVL - number of labels read after as AS statement. C ISELEC=0 IOUTPT=0 IAS=0 IASLST=0 NCRVLB=NCRVL NASVL=0 C C If new syntax C IF(IPOSSC.GT.0) THEN TSWTCH=3 CALL STBLNK(CARD,1,IPOSSC) IPOSSC=IPOSSC+1 U5LCSW=1 C ! Reset U5LCSW used by REFRSH NXPTIM=NXPTI CALL CMPAR1(IX,IPOSSC) CALL NMERGE(IX(NLINE+NLINE2+NXPTIM),IX(NXPTIM),IX(NLINE+NXPTIM)) GO TO 64 END IF C C AS 195 C SELECT 9 C STEPOPTION 198-200 C OPTION 36 C INCORPORATE 196 C OUTPUT CLASS 111 C 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)GO TO 62 C CALL KYFIND(IKEY,IPT) IF(IKEY.NE.9.AND.IKEY.NE.36.AND.IKEY.NE.111.AND.IKEY.NE.196.AND. . IKEY.NE.195.AND.(IKEY.LT.198.OR.IKEY.GT.200)) GO TO 62 C IF(IKEY.EQ.196) THEN GO TO 27 END IF CALL CRDPRN(1) C C If encounter INCORPORATE, branch to complete processing of previous C input file. C C C If continuation line without keyword, read next record C IF(IKEY.EQ.-1) THEN GO TO 1 END IF IF(IKEY.EQ.9.OR.IKEY.EQ.111) THEN C C SELECT (9) OUTPUT (111) C C C Determine class variable to use C C C Find level to select and edit for completeness C C IBEYND = 1 if have read beyond 1st record C IBEYND=0 C C Error messages if both SELECT and OUTPUT appear. C IF(IKEY.EQ.9) THEN IF(ISELEC.GT.0) THEN CALL FESTOP(130003) ELSE IF(IOUTPT.GT.0) THEN CALL FESTOP(130004) END IF ELSE IF(IOUTPT.GT.0) THEN CALL FESTOP(130005) ELSE IF(ISELEC.GT.0) THEN CALL FESTOP(130019) END IF END IF C IF(IPT.LE.0) THEN CALL NBFND2(IPT,IPOS) IF(IPT.EQ.1)IBEYND=1 IF(IPOS.GT.0) THEN IPT=IPOS ELSE CALL FESTOP(130006) END IF END IF CALL CMATCH(CARD(IPT:256),IPT,256,'CLASS',5,IPOS,1) IF(IPOS.GT.0) THEN IPT=IPOS END IF MAXVN=RCEIL(2)-NVTOT-ANVTOT-2 C C Error message if not enough room for variable names. C IF(MAXVN.LE.0) THEN K=ANVTOT+2 CALL RCHECK(2,NVIN,K) END IF CALL VNFIND(IPT,VNAME(NVIN+1),MAXVN,N,IPOS,2,VNAME,NVIN) IF(IPT.EQ.1)IBEYND=1 IF(N.EQ.0) THEN CALL FESTOP(130006) ELSE IF(N.GT.1) THEN CALL FESTOP(130007) ELSE IF(IPOS.EQ.0) THEN CALL FESTOP(130010) ELSE IPT=IPOS END IF CALL VNMTCH(VNAME(NVIN+1),VNAME,NVIN,K) C C If the provided variable name does not match, accept only if C OUTPUT, if output class has not been previously identified by AS. C IF(K.EQ.0) THEN IF(IKEY.EQ.9) THEN CALL FESTOP(130008) ELSE IF(IAS.GT.0) THEN CALL FESTOP(130020) ELSE CALL RINCR(2,NVIN,1) K=NVIN MTYPE(NVIN)=4 IOUTPT=NVIN LABEL(NVIN)(1:12)=VNAME(NVIN) LABEL(NVIN)(13:24)=' ' END IF C C If variable has appeared, make sure it is a class variable, etc. C ELSE IF(MTYPE(K).NE.4) THEN CALL FESTOP(130009) ELSE IF(IKEY.EQ.9) THEN ISELEC=K ELSE IF(IAS.GT.0) THEN IF(IAS.NE.K) THEN CALL FESTOP(130020) END IF END IF IOUTPT=K END IF END IF END IF END IF C C Search for "(ISVAL)" C CALL NBFND2(IPT,IPOS) IF(IPT.EQ.1)IBEYND=1 IF(IPOS.GT.0) THEN IPT=IPOS ELSE CALL FESTOP(130010) END IF IF(CARD(IPT:IPT).NE.'(') THEN CALL FESTOP(130010) ELSE IPOS=IPT+1 CALL NBFND2(IPOS,IPT) IF(IPOS.EQ.1)IBEYND=1 IF(IPT.LE.0) THEN CALL FESTOP(130011) END IF END IF CALL IFIND(CARD(IPT:256),IPT,256,IPOS,ISVAL) IF(IPOS.EQ.0) THEN CALL FPSTOP(130011,IPT) END IF C C For SELECT, edit ISVAL. C IF(IKEY.EQ.9) THEN IF(ISVAL.LT.0.OR.ISVAL.GT.MSIZE(ISELEC)) THEN CALL FPSTOP(130012,IPT) END IF NOUTPT=1 ELSE IF(ISVAL.LE.0) THEN CALL FPSTOP(130011,IPT) END IF NOUTPT=ISVAL IF(IAS.GT.NVTOT)MSIZE(IAS)=NOUTPT END IF CALL NBFND2(IPOS,IPT) IF(IPOS.EQ.1)IBEYND=1 IF(IPT.LE.0) THEN CALL FESTOP(130013) END IF IF(CARD(IPT:IPT).NE.')') THEN CALL FPSTOP(130013,IPT) END IF IPT=IPT+1 C C Store labels and other information for the new class in the C slot NVTOT+1 above the number of variables in the incoming file. C This positioning anticipates the later moving around of labels. C IF(IKEY.EQ.111) THEN K=NVTOT+1 MSIZE(K)=NOUTPT C C Deliberately leave space of NOUTPT in LEVEL array. Values of C LEVEL stored here will have to be moved later. C LPOINT(K)=NCRVL+NOUTPT+1 NCRVLB=NCRVL+2*NOUTPT C C If levels have been read with a previous AS statement, move them. C IF(NASVL.GT.0) THEN DO 19 I=1,NASVL LEVEL(NCRVLB+I)=LEVEL(NCRVL+I) 19 CONTINUE END IF C CALL NBFND2(IPT,IPOS) IF(IPT.EQ.1)IBEYND=1 IPT=IPOS NCRVLS=NCRVL CALL RINCR(7,NCRVL,NOUTPT) DO 20 I=1,NOUTPT CALL RINCR(7,NCRVL,1) LEVEL(NCRVL)(1:12)=' ' LEVEL(NCRVL)(13:24)=LEVEL(NCRVL)(1:12) 20 CONTINUE IF(IPT.GT.1) THEN CALL LEVELR(IPT,IPOS,NL,LEVEL(NCRVLS+NOUTPT+1),NOUTPT) END IF IF(IPT.EQ.1)IBEYND=1 END IF IF(U5END.EQ.1.OR.(ALPCHK(CARD(1:1)).AND.IBEYND.EQ.1))GO TO 2 GO TO 1 C ELSE IF(IKEY.EQ.195) THEN C C AS C C C IBEYND = 1 if have read beyond 1st record C IBEYND=0 C C Determine if class name has been given C C Read list of variables. C IF(ISELEC.GT.0) THEN CALL FESTOP(130014) ELSE IF(IAS.GT.0) THEN CALL FESTOP(130021) END IF IF(IPT.LE.0) THEN CALL NBFND2(IPT,IPOS) IF(IPT.EQ.1)IBEYND=1 IF(IPOS.GT.0) THEN IPT=IPOS ELSE CALL FESTOP(130015) END IF END IF MAXVN=RCEIL(2)-ANVTOT-NVTOT+2 IF(MAXVN.LE.0) THEN K=ANVTOT+2 CALL RCHECK(2,NVIN,ANVTOT) END IF CALL VNFIND(IPT,VNAME(NVIN+1),MAXVN,N,IPOS,2,VNAME,NVIN) IF(IPT.EQ.1)IBEYND=1 C IF(N.GT.1) THEN CALL FESTOP(130016) ELSE IF(N.EQ.1) THEN IPT=IPOS CALL VNMTCH(VNAME(NVIN+1),VNAME,NVIN,K) C C Accept unmatching name only if OUTPUT has not already appeared. C IF(K.EQ.0) THEN IF(IOUTPT.GT.0) THEN CALL FESTOP(130018) ELSE CALL RINCR(2,NVIN,1) MTYPE(NVIN)=4 MSIZE(NVIN)=0 IAS=NVIN LABEL(NVIN)(1:12)=VNAME(NVIN) LABEL(NVIN)(13:24)=' ' END IF ELSE IF(MTYPE(K).NE.4) THEN CALL FESTOP(130009) ELSE IAS=K IF(IOUTPT.GT.0) THEN IF(K.NE.IOUTPT) THEN CALL FESTOP(130017) END IF END IF END IF END IF END IF CALL NBFND2(IPT,IPOS) IF(IPT.EQ.1)IBEYND=1 IF(IPOS.GT.0) THEN IPT=IPOS ELSE CALL FESTOP(130010) END IF C C Read the disposition list. C IF(CARD(IPT:IPT).NE.'(') THEN CALL FESTOP(130010) ELSE IPOS=IPT+1 CALL NBFND2(IPOS,IPT) IF(IPOS.EQ.1)IBEYND=1 IF(IPT.LE.0) THEN CALL FESTOP(130018) END IF END IF CALL RNSCAN(IPT,IPOS,RANGE,MRANGS,RTYPE,RGROUP, . NR,3,LEVEL,1) IF(IPT.EQ.1) THEN IF(IPOS.EQ.0) THEN CALL FESTOP(130015) END IF ELSE IF(IPOS.EQ.0.OR.NR.LE.0) THEN CALL FESTOP(130022) END IF IPT=IPOS IASLST=NXPTI IASNOW=IASLST-1 DO 24 I=1,NR IF(RTYPE(I).EQ.5) THEN CALL FESTOP(130023) ELSE IF(RTYPE(I).EQ.1.OR.RTYPE(I).EQ.3.OR.RTYPE(I).EQ.6) THEN ILOW=RANGE(1,I)+.1D-7 ELSE ILOW=1 END IF IF(RTYPE(I).EQ.1.OR.RTYPE(I).EQ.2) THEN IHIGH=RANGE(2,I) ELSE IF(ILOW.EQ.1) THEN IF(IAS.EQ.0) THEN CALL FESTOP(130024) ELSE IF(MSIZE(IAS).EQ.0) THEN CALL FESTOP(130024) ELSE IHIGH=MSIZE(IAS) END IF END IF ELSE IF(IOUTPT.GT.0) THEN IHIGH=NOUTPT ELSE CALL FESTOP(130024) END IF END IF END IF DO 22 J=ILOW,IHIGH CALL ROOMI(1) IASNOW=IASNOW+1 IX(IASNOW)=J 22 CONTINUE END IF 24 CONTINUE C C Note: NASLST is the length of the specification. C This will be checked for consistency later. C NASLST=IASNOW-IASLST+1 C C Check for the presence of labels. C CALL NBFND2(IPT,IPOS) IF(IPT.EQ.1)IBEYND=1 IF(IPOS.GT.0) THEN IPT=IPOS CALL LEVELR(IPT,IPOS,NASVL,LEVEL(NCRVLB+1),NASLST) IF(IPT.EQ.1)IBEYND=1 END IF IF(U5END.EQ.1.OR.(ALPCHK(CARD(1:1)).AND.IBEYND.EQ.1))GO TO 2 GO TO 1 C ELSE IF(IKEY.GE.198.AND.IKEY.LE.200) THEN C C STEPOPTION, STEP_OPTION C 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.1) THEN CALL FESTOP(200069) END IF NXPTIS=NXPTI CALL ROOMI(1) IX(NXPTIS)=0 ISOPTN=1 CALL OPTNTR(NOPTNT,INDXT,IVALT,OPTNT,IPT,IPOS,IX(NXPTIS)) IF(IX(NXPTIS).EQ.1) THEN IFLLVL=1 END IF NXPTI=NXPTIS ELSE IF(IKEY.EQ.36) THEN C C OPTION C I=IX(NTRANS*12-11) CALL OPTNTR(NOPTNV,INDXV,IVALV,OPTNV,IPT,IPOS,IX(I)) END IF IF(IPT.EQ.1) THEN GO TO 2 ELSE GO TO 1 END IF C C The first section of code is executed at the beginning of a C new subroutine or at the end of the TRANSFORM specification. C 27 CONTINUE I=IX(NTRANS*12-11) IX(I+4)=ANIDTT IX(I+5)=ATSIZE IX(I+6)=ANRPTT IX(I+7)=ANVREG IX(I+8)=ANVRID IX(I+9)=ANBY IX(NTRANS*12-9)=ANCLBL IX(NTRANS*12-8)=ANCLBR IX(NTRANS*12-7)=ANVTOT IX(NTRANS*12-5)=NPASS+1 C IX(NTRANS*12-10)=NXPTI K=NXPTI IF(ISELEC.EQ.0) THEN C C First, copy critical stored arrays into IX, unless ISELEC>0 C I=5*ANCLBL CALL ROOMI(I) I=RCEIL(8)-ANCLBL+1 DO 28 J=1,ANCLBL IX(K)=BLXINC(I) IX(K+1)=BLNCLS(I) IX(K+2)=BLCPNT(I) IX(K+3)=IX(SICMUL+I-1) IX(K+4)=BLXSTR(I) I=I+1 K=K+5 28 CONTINUE C IF(ANCLBR.GT.0) THEN I=2*ANCLBR CALL ROOMI(I) I=RCEIL(9)-ANCLBR+1 DO 30 J=1,ANCLBR IX(K)=CLTYPE(I) IX(K+1)=CLPNT(I) I=I+1 K=K+2 30 CONTINUE END IF C IF(ANVTOT.GT.0) THEN CALL ROOMI(ANVTOT) I=RCEIL(2)-ANVTOT+1 DO 31 J=1,ANVTOT IX(K)=MSIZE(I) I=I+1 K=K+1 31 CONTINUE END IF IF(ANVREG.GT.0) THEN I=2*ANVREG CALL ROOMI(I) I=RCEIL(2)-ANVTOT+1 DO 32 J=1,ANVREG IX(K)=VMAPL(I) IX(K+1)=MXSIZE(I) I=I+1 K=K+2 32 CONTINUE END IF END IF C IF(NTRANS.EQ.1) THEN IF(ISELEC.GT.0) THEN C C Adjust meta-data for SELECT C ISIZE=MSIZE(ISELEC) IF(ISELEC.LT.NVTOT) THEN C C First, adjust level, moving any labels above the selected variable C down by ISIZE C IF(NCRVL.GT.ISIZE) THEN DO 33 LL=LPOINT(ISELEC),NCRVL-ISIZE LEVEL(LL)=LEVEL(LL+ISIZE) 33 CONTINUE END IF C C Reduce variable list for any variables above ISELEC C DO 34 I=ISELEC+1,NVTOT MTYPE(I-1)=MTYPE(I) MSIZE(I-1)=MSIZE(I) VNAME(I-1)=VNAME(I) LABEL(I-1)=LABEL(I) IF(LPOINT(I).GT.0) THEN LPOINT(I-1)=LPOINT(I)-ISIZE ELSE LPOINT(I-1)=0 END IF 34 CONTINUE END IF C C Adjust contents of CLPNT, etc. C IWARN=0 I=RCEIL(8)-ANCLBL+1 C C ISEL2 is variable number of selected class in upper copy C ISEL2=ISELEC+RCEIL(2)-ANVTOT KK=0 IST=1 DO 38 J=1,ANCLBL BLXSTR(J)=IST BLCPNT(J)=KK+1 IWARNB=1 IF(BLNCLS(I).GT.0) THEN II=BLCPNT(I) DO 35 JJ=1,BLNCLS(I) IF(CLPNT(II).EQ.ISEL2) THEN IWARNB=0 ELSE KK=KK+1 IF(CLPNT(II).GT.ISEL2) THEN CLPNT(KK)=CLPNT(II)-RCEIL(2)+ANVTOT-1 ELSE CLPNT(KK)=CLPNT(II)-RCEIL(2)+ANVTOT END IF CLTYPE(KK)=CLTYPE(II) END IF II=II+1 35 CONTINUE END IF IF(IWARNB.EQ.1) THEN IWARN=1 ELSE BLXSIZ(J)=BLXSIZ(J)/ISIZE BLNCLS(J)=BLNCLS(J)-1 IF(BLNCLS(J).EQ.0) THEN BLCPNT(J)=0 END IF END IF IX(SICMUL+J-1)=BLXSIZ(J)/BLXINC(J) IF(BLVSIZ(J).GT.0) THEN IST1=IST IF(BLTYPE(J).EQ.1) THEN IST1=IST1+1 END IF LL=BLVSTR(J) C C Recreate VMAPL C DO 36 L=1,BLVSIZ(J) VMAPL(LL)=IST1 IST1=IST1+MSIZE(LL) LL=LL+1 36 CONTINUE END IF IST=IST+BLXSIZ(J) I=I+1 38 CONTINUE IF(IWARN.EQ.1) THEN WRITE(U6,200) END IF NVTOT=NVTOT-1 NCLASS=NCLASS-1 TSIZE=IST-1 NCLBAR=KK NCRVL=NCRVL-ISIZE ISELEC=ISEL2 ELSE IF (IOUTPT.GT.0) THEN C C Establish space to keep track of which output levels have been C assigned. C ISOUTF=NXPTI CALL ROOMI(NOUTPT) DO 39 I=1,NOUTPT IX(ISOUTF+I-1)=0 39 CONTINUE C C Adjust meta-data for OUTPUT CLASS C IF(IOUTPT.GT.NVTOT) THEN C C If OUTPUT class is not in incoming file C C IOUT2 will be the new position of the output class C IOUT2=NVREG+NCLASS+1 C C First, adjust variable list. Move up any labels associated with C BY variables, etc. NCLABV will be the start of these labels, if C any. C NCLABV=0 IF(IOUT2.LE.NVTOT) THEN DO 40 I=IOUT2,NVTOT IF(NCLABV.EQ.0) THEN IF(LPOINT(I).GT.0) THEN NCLABV=LPOINT(I) END IF END IF 40 CONTINUE IF(NCLABV.GT.0) THEN DO 41 I=NCRVLS,NCLABV,-1 LEVEL(I+NOUTPT)=LEVEL(I) 41 CONTINUE END IF MTYPE(NVTOT+2)=MTYPE(NVTOT+1) MSIZE(NVTOT+2)=MSIZE(NVTOT+1) VNAME(NVTOT+2)=VNAME(NVTOT+1) LABEL(NVTOT+2)=LABEL(NVTOT+1) DO 42 I=NVTOT,IOUT2,-1 MTYPE(I+1)=MTYPE(I) MSIZE(I+1)=MSIZE(I) VNAME(I+1)=VNAME(I) LABEL(I+1)=LABEL(I) IF(LPOINT(I).GT.0) THEN LPOINT(I+1)=LPOINT(I)+NOUTPT ELSE LPOINT(I+1)=0 END IF 42 CONTINUE MTYPE(IOUT2)=MTYPE(NVTOT+2) MSIZE(IOUT2)=MSIZE(NVTOT+2) VNAME(IOUT2)=VNAME(NVTOT+2) LABEL(IOUT2)=LABEL(NVTOT+2) END IF IF(NCLABV.EQ.0)NCLABV=NCRVLS+1 LPOINT(IOUT2)=NCLABV DO 43 I=1,NOUTPT LEVEL(NCLABV)=LEVEL(NCRVLS+NOUTPT+I) NCLABV=NCLABV+1 43 CONTINUE C C Adjust contents of CLPNT, etc. C I=RCEIL(8)-ANCLBL+1 ISIZE=MSIZE(IOUT2) KK=0 IST=1 DO 46 J=1,ANCLBL BLXSTR(J)=IST BLCPNT(J)=KK+1 IF(BLNCLS(I).GT.0) THEN II=BLCPNT(I) DO 44 JJ=1,BLNCLS(I) KK=KK+1 CLPNT(KK)=CLPNT(II)-RCEIL(2)+ANVTOT CLTYPE(KK)=CLTYPE(II) II=II+1 44 CONTINUE END IF KK=KK+1 CLPNT(KK)=IOUT2 CLTYPE(KK)=1 BLXSIZ(J)=BLXSIZ(J)*ISIZE IX(SICMUL+J-1)=BLXSIZ(J)/BLXINC(J) BLNCLS(J)=BLNCLS(J)+1 IF(BLVSIZ(J).GT.0) THEN IST1=IST IF(BLTYPE(J).EQ.1) THEN IST1=IST1+1 END IF LL=BLVSTR(J) C C Recreate VMAPL C DO 45 L=1,BLVSIZ(J) VMAPL(LL)=IST1 IST1=IST1+MSIZE(LL) LL=LL+1 45 CONTINUE END IF IST=IST+BLXSIZ(J) I=I+1 46 CONTINUE NVTOT=NVTOT+1 NCLASS=NCLASS+1 TSIZE=IST-1 NCLBAR=KK NCRVL=NCRVLS+NOUTPT ELSE C ! OUTPUT class is already present in incoming file C C IOUT2 will be the new position of the output class. C In this case (OUTPUT class present in file) IOUT2 is pointing C to a class variable. C ISIZE=MSIZE(IOUTPT) IOUT2=NVREG+NCLASS NCLABV=LPOINT(IOUT2)+MSIZE(IOUT2) LL=LPOINT(IOUTPT)+ISIZE C C Move any labels for classes above IOUTPT down by ISIZE C IF(LL.LT.NCLABV) THEN DO 47 I=LL,NCLABV-1 LEVEL(I-ISIZE)=LEVEL(I) 47 CONTINUE END IF IF(IOUT2.LT.NVTOT) THEN C C Adjust any labels above the class labels. C IF(NCLABV.LE.NCRVLS) THEN C C If NOUTPT > ISIZE, must move remaining labels up C IF(NOUTPT.GT.ISIZE) THEN DO 461 I=NCRVLS,NCLABV,-1 LEVEL(I+NOUTPT-ISIZE)=LEVEL(I) 461 CONTINUE C C If NOUTPT < ISIZE, must move remaining labels down C ELSE IF(NOUTPT.LT.ISIZE) THEN DO 462 I=NCLABV,NCRVLS LEVEL(I+NOUTPT-ISIZE)=LEVEL(I) 462 CONTINUE END IF END IF END IF LL=NCLABV-ISIZE C C Copy output labels for IOUTPT into place, which begins aT C NCLABV-ISIZE C DO 48 I=1,NOUTPT LEVEL(LL)=LEVEL(NCRVLS+NOUTPT+I) LL=LL+1 48 CONTINUE LPOINT(IOUTPT)=NCLABV-ISIZE IF(IOUTPT.LT.IOUT2) THEN C C First, reduce variable list C MTYPE(NVTOT+2)=MTYPE(IOUTPT) MSIZE(NVTOT+2)=NOUTPT VNAME(NVTOT+2)=VNAME(IOUTPT) LABEL(NVTOT+2)=LABEL(IOUTPT) LPOINT(NVTOT+2)=LPOINT(IOUTPT) DO 50 I=IOUTPT,IOUT2-1 MTYPE(I)=MTYPE(I+1) MSIZE(I)=MSIZE(I+1) VNAME(I)=VNAME(I+1) LABEL(I)=LABEL(I+1) C C Since the range of IOUTPT to IOUT2 should only contain class C variables, adjust LPOINT without checking if it is 0. C LPOINT(I)=LPOINT(I+1)-ISIZE 50 CONTINUE MTYPE(IOUT2)=MTYPE(NVTOT+2) MSIZE(IOUT2)=MSIZE(NVTOT+2) VNAME(IOUT2)=VNAME(NVTOT+2) LABEL(IOUT2)=LABEL(NVTOT+2) LPOINT(IOUT2)=LPOINT(NVTOT+2) ELSE MSIZE(IOUT2)=NOUTPT END IF IF(IOUT2.LT.NVTOT) THEN DO 505 I=IOUT2+1,NVTOT IF(LPOINT(I).GT.0) THEN LPOINT(I)=LPOINT(I)+NOUTPT-ISIZE END IF 505 CONTINUE END IF C C Adjust contents of CLPNT, etc. C I=RCEIL(8)-ANCLBL+1 C C IOUTUP is variable number of selected class in upper copy C IOUTUP=IOUTPT+RCEIL(2)-ANVTOT KK=0 IST=1 DO 54 J=1,ANCLBL BLXSTR(J)=IST BLCPNT(J)=KK+1 IWARNB=1 IF(BLNCLS(I).GT.0) THEN II=BLCPNT(I) DO 51 JJ=1,BLNCLS(I) IF(CLPNT(II).EQ.IOUTUP) THEN IF(CLTYPE(II).EQ.1) THEN BLXSIZ(J)=(BLXSIZ(J)/MSIZE(IOUTUP))*MSIZE(IOUT2) ELSE BLXSIZ(J)=(BLXSIZ(J)/(MSIZE(IOUTUP)+1))*MSIZE(IOUT2) END IF IWARNB=0 ELSE KK=KK+1 IF(CLPNT(II).GT.IOUTUP) THEN CLPNT(KK)=CLPNT(II)-RCEIL(2)+ANVTOT-1 ELSE CLPNT(KK)=CLPNT(II)-RCEIL(2)+ANVTOT END IF CLTYPE(KK)=CLTYPE(II) END IF II=II+1 51 CONTINUE KK=KK+1 CLPNT(KK)=IOUT2 CLTYPE(KK)=1 END IF IF(IWARNB.EQ.1) THEN CALL FESTOP(130026) END IF IX(SICMUL+J-1)=BLXSIZ(J)/BLXINC(J) IF(BLVSIZ(J).GT.0) THEN IST1=IST IF(BLTYPE(J).EQ.1) THEN IST1=IST1+1 END IF LL=BLVSTR(J) C C Recreate VMAPL C DO 52 L=1,BLVSIZ(J) VMAPL(LL)=IST1 IST1=IST1+MSIZE(LL) LL=LL+1 52 CONTINUE END IF IST=IST+BLXSIZ(J) I=I+1 54 CONTINUE TSIZE=IST-1 NCLBAR=KK NCRVL=NCRVLS+NOUTPT-ISIZE END IF C C Update IOUTPT to be new position of output class C IOUTPT=IOUT2 ELSE CALL FESTOP(130027) END IF C C Begin to plan out space for incoming and outgoing double data. C NEXTD=NIDTOT+TSIZE+1 IX(NTRANS*12-4)=NEXTD IX(NTRANS*12-3)=NEXTD+NIDTOT NEXTD=NEXTD+ANIDTT+ATSIZE ELSE C C Plan space for NTRANS > 1 C IX(NTRANS*12-4)=NEXTD IX(NTRANS*12-3)=NEXTD+ANIDTT NEXTD=NEXTD+ANIDTT+ATSIZE END IF C IF(IOUTPT.GT.0) THEN C C If OUTPUT CLASS, then determine position in output class. C K=RCEIL(2)-ANVTOT+1 CALL VNMTCH(VNAME(IOUTPT),VNAME(K),ANVTOT,IOUTUP) IF(IOUTUP.GT.0) THEN IOUTUP=IOUTUP+K-1 END IF IOUTCL=NXPTI NOUTCL=0 IF(IASLST.GT.0) THEN IF(IOUTUP.GT.0) THEN IF(NASLST.NE.MSIZE(IOUTUP)) THEN CALL FESTOP(130028) END IF DO 55 I=1,NASLST IF(IX(I+IASLST-1).GT.0)NOUTCL=NOUTCL+1 55 CONTINUE I=2*NOUTCL CALL ROOMI(I) L=IOUTCL DO 56 I=1,NASLST K=IX(IASLST+I-1) IF(K.GT.0) THEN IX(L)=I IX(L+NOUTCL)=K L=L+1 C C If a label was provided as part of an AS statement, copy it. C IF(L-IOUTCL.LE.NASVL) THEN IL=LPOINT(IOUTPT) LEVEL(LPOINT(IOUTPT)+K-1)=LEVEL(NCRVLB+L-IOUTCL) END IF IF(K.GT.NOUTPT) THEN CALL FESTOP(130031) ELSE IF(IX(ISOUTF+K-1).GT.0) THEN CALL FESTOP(130032) ELSE IX(ISOUTF+K-1)=NTRANS END IF END IF 56 CONTINUE ELSE IF(NASLST.NE.1) THEN CALL FESTOP(130029) END IF NOUTCL=1 CALL ROOMI(2) K=IX(IASLST) IF(K.EQ.0) THEN CALL FESTOP(130033) ELSE IF(K.GT.NOUTPT) THEN CALL FESTOP(130031) ELSE IF(IX(ISOUTF+K-1).GT.0) THEN CALL FESTOP(130032) END IF IX(IOUTCL)=0 IX(IOUTCL+1)=K IX(ISOUTF+K-1)=NTRANS C C If label was provided as part of the AS list, then copy it. C IF(NASVL.GT.0) THEN IL=LPOINT(IOUTPT) LEVEL(LPOINT(IOUTPT)+K-1)=LEVEL(NCRVLB+1) END IF END IF ELSE C C An AS statement has not provided a list of outgoing class(es) C IF(IOUTUP.GT.0) THEN NOUTCL=MSIZE(IOUTUP) I=2*NOUTCL CALL ROOMI(I) L=0 DO 57 I=1,NOUTPT IF(IX(ISOUTF+I-1).EQ.0) THEN L=L+1 IX(IOUTCL+L-1)=L IX(IOUTCL+NOUTCL+L-1)=I IX(ISOUTF+I-1)=NTRANS IF(L.EQ.NOUTCL)GO TO 58 END IF 57 CONTINUE CALL FESTOP(130034) 58 CONTINUE ELSE NOUTCL=1 CALL ROOMI(2) DO 59 I=1,NOUTPT IF(IX(ISOUTF+I-1).EQ.0) THEN IX(IOUTCL)=0 IX(IOUTCL+1)=I IX(ISOUTF+I-1)=NTRANS GO TO 60 END IF 59 CONTINUE CALL FESTOP(130035) 60 CONTINUE END IF END IF C C If output class is on incoming file, update level labels, if C appropriate. C IF(IOUTUP.GT.0) THEN JJ=LPOINT(IOUTUP)-1 KK=LPOINT(IOUTPT)-1 DO 61 I=1,NOUTCL J=IX(IOUTCL+I-1) K=IX(IOUTCL+NOUTCL+I-1) IF(LEVEL(KK+K)(1:12).EQ.' '.AND. . LEVEL(KK+K)(13:24).EQ.LEVEL(KK+K)(1:12)) THEN LEVEL(KK+K)=LEVEL(JJ+J) END IF 61 CONTINUE END IF ELSE IOUTCL=NXPTI NOUTCL=1 CALL ROOMI(2) IX(IOUTCL)=ISVAL IX(IOUTCL+1)=0 END IF NPASSV=NPASS CALL MRGSET(IOUTUP,NPASS,IX(IOUTCL),NOUTCL) C C If ENDMRG, begin to output. C IF(ENDMRG) THEN GO TO 64 END IF C C INCORPORATE C C CALL CRDPRN(1) IF(IPT.LE.0) THEN IPT=20 CALL NBFND2(IPT,IPOS) IF(IPOS.LE.0) THEN CALL FESTOP(130025) END IF IPT=IPOS END IF NLIST=0 ILISTX=0 CALL RINCR(12,NTRANS,1) IX(NTRANS*12-11)=NXPTI I=NXPTI CALL ROOMI(10) IX(I+1)=0 IX(I+2)=0 C ! Default is NOIDCHECK with old syntax IX(I+3)=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(130030) END IF CALL PREAMD(K) IF(AVERSN.EQ.9004) THEN ANID=ANVRID+ANBY ELSE ANID=ANIDTT END IF ICLBLK=RCEIL(8)-ANCLBL+1 IV=RCEIL(2)-ANVTOT DO 632 J=1,ANCLBL IF(BLVSIZ(ICLBLK).GT.0) THEN DO 631 I=1,BLVSIZ(ICLBLK) IV=IV+1 MXSIZE(IV)=ICLBLK 631 CONTINUE END IF IX(SICMUL+ICLBLK-1)=BLXSIZ(ICLBLK)/BLXINC(ICLBLK) ICLBLK=ICLBLK+1 632 CONTINUE IAS=0 IASLST=0 NASVL=0 NCRVLB=NCRVL C IF(IPT.EQ.1) THEN C GO TO 2 C ELSE GO TO 1 C END IF 62 CONTINUE ENDMRG=.TRUE. GO TO 27 64 CONTINUE C C C IX(NTRANS*12-11) = Starting location in IX for options C IX(NTRANS*12-10) = Starting location in IX for values copied from C block information arrays C IX(NTRANS*12-9) = Number of blocks (from ANCLBL) C IX(NTRANS*12-8) = Number of elements in class specifications for C block (from ANCLBR) C IX(NTRANS*12-7) = Number of variables (from ANVTOT) C IX(NTRANS*12-6) = 2*Number of variables to move (counting block N's) C IX(NTRANS*12-5) = Starting value of NPASS C IX(NTRANS*12-4) = Starting location for ID C IX(NTRANS*12-3) = Starting location for DX C C SICMUL - starting position in IX for multipliers showing for C each block the multiplying effect of class variables. C TMOVE1 and TMOVE2 use SICMUL, in COMMON, to locate the C array. Set the array up to full MCLBLK size here. C C First, provide default labels for unspecified levels. C IF(IOUTPT.GT.0) THEN I=LPOINT(IOUTPT) CALL LEVELD(LEVEL(I),NOUTPT) END IF CALL PREAMO NXPTD=1 I=IX(NTRANS*12-3)+ATSIZE CALL ROOMD(I) IF(NBY.EQ.0)NBYGRP=1 IF(IFLLVL.EQ.0) THEN FILLVL=0. ELSE FILLVL=MISSNG END IF DO 75 I=1,TSIZE DX(I+NIDTOT)=FILLVL 75 CONTINUE DO 90 IBYGRP=1,NBYGRP DO 89 IREP=0,NRPTOT DO 88 ITRANS=1,NTRANS CALL VMREAD(IX(IX(ITRANS*12-11)),ITRANS,IREP,IBYGRP) IF(ITRANS.EQ.1) THEN J=IX(8) DO 65 I=1,NIDTOT DX(I)=DX(J) J=J+1 65 CONTINUE END IF ANCLBL=IX(ITRANS*12-9) ANCLBR=IX(ITRANS*12-8) ANVTOT=IX(ITRANS*12-7) ANVREG=IX(IX(ITRANS*12-11)+7) IF(ISELEC.EQ.0) THEN C C First, copy critical stored arrays into IX, unless ISELEC>0 C K=IX(ITRANS*12-10) I=RCEIL(8)-ANCLBL+1 DO 66 J=1,ANCLBL BLXINC(I)=IX(K) BLNCLS(I)=IX(K+1) BLCPNT(I)=IX(K+2) IX(SICMUL+I-1)=IX(K+3) BLXSTR(I)=IX(K+4) I=I+1 K=K+5 66 CONTINUE C IF(ANCLBR.GT.0) THEN I=RCEIL(9)-ANCLBR+1 DO 68 J=1,ANCLBR CLTYPE(I)=IX(K) CLPNT(I)=IX(K+1) I=I+1 K=K+2 68 CONTINUE END IF C IF(ANVTOT.GT.0) THEN I=RCEIL(2)-ANVTOT+1 DO 70 J=1,ANVTOT MSIZE(I)=IX(K) I=I+1 K=K+1 70 CONTINUE END IF IF(ANVREG.GT.0) THEN I=RCEIL(2)-ANVTOT+1 DO 71 J=1,ANVREG VMAPL(I)=IX(K) MXSIZE(I)=IX(K+1) I=I+1 K=K+2 71 CONTINUE END IF END IF DO 86 IPASS=IX(ITRANS*12-5),IX(ITRANS*12-5)+IX(ITRANS*12-6)-1,2 ICLSS=V3(IPASS) IF(V2(IPASS).EQ.9) THEN ICLBLK=V1(IPASS) ELSE ICLBLK=MXSIZE(V1(IPASS)) END IF ISN=BLXSTR(ICLBLK) INCN=BLXINC(ICLBLK) INC=INCN C C For N of block, location has already been determined. C Otherwise, find location and increment of variable. C IF(V2(IPASS).EQ.9) THEN IS=ISN+IX(ITRANS*12-3)-1 ELSE IS=VMAPL(V1(IPASS))+IX(ITRANS*12-3)-1 END IF IF(ICLSS.GT.0) THEN CALL TMOVE1(IS,INC,ISN,INCN,NXPTD,1, . IX(ICLSS+2),IX(ICLSS),ICLBLK,V1(IPASS),V2(IPASS)) ELSE CALL TMOVE1(IS,INC,ISN,INCN,NXPTD,1,IX,0,ICLBLK,V1(IPASS), . V2(IPASS)) END IF ICLSS=V3(IPASS+1) IF(V2(IPASS+1).EQ.9) THEN ICLBLK=V1(IPASS+1) ELSE ICLBLK=MXSIZE(V1(IPASS+1)) END IF ISN=BLXSTR(ICLBLK) INCN=BLXINC(ICLBLK) INC=INCN 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+1).EQ.9) THEN IS=ISN+NIDTOT ELSE IS=VMAPL(V1(IPASS+1))+NIDTOT END IF IPASS1=IPASS+1 CALL TMOVE2(IPASS1,IS,INC,NXPTD,1,ICLBLK) 86 CONTINUE 88 CONTINUE WRITE(11)(DX(I),I=1,NIDTOT) CALL UNFOUT(11,DX(NIDTOT+1),TSIZE) 89 CONTINUE 90 CONTINUE CLOSE(11) DO 92 ITRANS=1,NTRANS CLOSE(UNIT=IX(IX(ITRANS*12-11))) 92 CONTINUE RETURN C C Return to 27 to complete the processing of the last subroutine, C if any, before exiting the routine C END C C SUBROUTINE MRGSET(IOUTUP,NPASS,IMCLSS,NOUTCL) C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C INTEGER IOUTUP,NOUTCL INTEGER IMCLSS(NOUTCL,2) 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) C PARAMETER (MTRANS=1500,MRANGS=20) PARAMETER (MTRSZI=MSIZEI+6*MRANGE-6*MRANGS+2*MRNSET+MRECOD+MVAR) PARAMETER (IXFLLD=49+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,ISTEPC,ISELEC,IOUTPT,IAS,IASLST,NCRVLB,NASVL, . IFLLVL,IXFILL(IXFLLD) COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT, . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF, . IFLLVL,ISTEPC,ISELEC,IOUTPT,IAS,IASLST,NCRVLB,NASVL,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 200 FORMAT(/,' Mismatch on block:',8X,I6,/, . ' Associated classes output:',I6,/, . ' Associated classes input: ',I6) 201 FORMAT(/,' Block:',I6,' in output file includes class:',A12,',', . /,' which is expected but not found on the input file') 202 FORMAT(/,' Block:',I6,' class:',A12,', size mismatch') 203 FORMAT(/,' Mismatch for ',A12) 204 FORMAT(/,' Classes for output block:') 205 FORMAT(3X,A12) 206 FORMAT(/,' No classes for output block') 207 FORMAT(/,' Classes for input block:') 208 FORMAT(/,' No classes for input block') 101 FORMAT(1X,I7,8X,I7) 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 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 JCLBLK=RCEIL(8)-ANCLBL+1 ISTART=RCEIL(2)-ANVTOT+1+ANVREG C ! Start of incoming class DO 50 ICLBLK=1,NCLBLK C C First, check if block has matching class specifications. C IF(IOUTPT.GT.0) THEN C ! OUTPUT CLASS IF(IOUTUP.GT.0) THEN C ! OUTPUT CLASS present in incoming MCHTYP=1 C ! OUTPUT CLASS in both IF(BLNCLS(ICLBLK).NE.BLNCLS(JCLBLK)) THEN K=JCLBLK-RCEIL(8)+ANCLBL IMERR1=130101 C C Transfer to 55 to write out class variables in block C GO TO 55 END IF ILIM1=BLNCLS(ICLBLK) ELSE C ! OUTPUT CLASS not present MCHTYP=2 C ! OUTPUT CLASS output only IF(BLNCLS(ICLBLK).NE.BLNCLS(JCLBLK)+1) THEN K=JCLBLK-RCEIL(8)+ANCLBL IMERR1=130102 GO TO 55 END IF ILIM1=BLNCLS(ICLBLK)-1 END IF ELSE C ! SELECT C IF(BLNCLS(ICLBLK).NE.BLNCLS(JCLBLK)-1.AND. . BLNCLS(ICLBLK).NE.BLNCLS(JCLBLK)) THEN K=JCLBLK-RCEIL(8)+ANCLBL IMERR1=130103 GO TO 55 END IF IF(BLNCLS(ICLBLK).EQ.BLNCLS(JCLBLK)-1) THEN MCHTYP=3 C ! SELECT CLASS in block ELSE MCHTYP=4 C ! SELECT CLASS not in block END IF ILIM1=BLNCLS(ICLBLK) END IF C IF(ILIM1.EQ.0.AND.MCHTYP.NE.3) THEN C ! No classes output, and ICLSS1=0 C ! class not selected ELSE C ! Set up CLSCAN equivalent array ICLSS1=NXPTI ISIZE=1 K=ICLSS1+5 CALL ROOMI(5) ICLBAR=BLCPNT(ICLBLK) IF(ILIM1.GT.0) THEN DO 10 I=1,ILIM1 C ! loop over outgoing classes LL=CLPNT(ICLBAR) JL=BLCPNT(JCLBLK) CALL VNMTCH(VNAME(LL),VNAME(ISTART),ANCLSS,L) L=L+ISTART-1 C ! matching class in upper array IF(L.EQ.0) THEN WRITE(U6,201)ICLBLK,VNAME(LL) IMERR1=130104 GO TO 55 END IF DO 2 JCLBAR=BLCPNT(JCLBLK),BLCPNT(JCLBLK)+BLNCLS(JCLBLK)-1 IF(L.EQ.CLPNT(JCLBAR)) GO TO 4 2 CONTINUE WRITE(U6,201)ICLBLK,VNAME(LL) C ! Class not found in incoming IMERR1=130104 GO TO 55 4 CONTINUE IF(I.LT.ILIM1.OR.MCHTYP.NE.1) THEN C ! Except for IF(CLTYPE(ICLBAR).NE.CLTYPE(JCLBAR)) THEN C ! OUTPUT CLASS WRITE(U6,202)ICLBLK,VNAME(LL) C ! CLTYPE, MSIZE, IMERR1=130105 C ! etc. must match GO TO 55 END IF IF(MSIZE(LL).NE.MSIZE(L)) THEN WRITE(U6,202)ICLBLK,VNAME(LL) IMERR1=130106 GO TO 55 END IF IF(CLTYPE(JCLBAR).EQ.0) THEN C ! Set up arrays ISIZE=ISIZE*(MSIZE(L)+1) C ! as CLSCAN DO 6 J=0,MSIZE(L) C ! equivalents CALL ROOMI(3) IX(K)=L IX(K+1)=J IX(K+2)=J+1 K=K+3 6 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 ELSE C ! OUTPUT CLASS DO 8 J=1,NOUTCL C ! in both CALL ROOMI(3) IX(K)=L IX(K+1)=IMCLSS(J,1) IX(K+2)=J K=K+3 8 CONTINUE ISIZE=ISIZE*NOUTCL END IF ICLBAR=ICLBAR+1 10 CONTINUE END IF IF(MCHTYP.EQ.3) THEN C ! For SELECTED CALL ROOMI(3) C ! CLASS IX(K)=ISELEC IX(K+1)=IMCLSS(1,1) IX(K+2)=1 K=K+3 END IF IX(ICLSS1)=(K-ICLSS1)/3-1 IX(ICLSS1+1)=ISIZE IX(ICLSS1+2)=IX(ICLSS1) IX(ICLSS1+3)=0 IX(ICLSS1+4)=0 END IF C IF(BLNCLS(ICLBLK).EQ.0) THEN C ! For output ICLSS2=0 ELSE C ! Set up CLSCAN ICLSS2=NXPTI C ! equivalent ISIZE=1 C ! array K=ICLSS2+5 CALL ROOMI(5) ICLBAR=BLCPNT(ICLBLK) DO 20 I=1,BLNCLS(ICLBLK) LL=CLPNT(ICLBAR) IF(I.LT.BLNCLS(ICLBLK).OR.MCHTYP.GT.2) THEN IF(CLTYPE(ICLBAR).EQ.0) THEN ISIZE=ISIZE*(MSIZE(LL)+1) DO 16 J=0,MSIZE(LL) CALL ROOMI(3) IX(K)=LL IX(K+1)=J IX(K+2)=J+1 K=K+3 16 CONTINUE ELSE ISIZE=ISIZE*MSIZE(LL) CALL ROOMI(3) IX(K)=LL IX(K+1)=0 IX(K+2)=0 K=K+3 END IF ELSE C ! Array entries for matching OUTPUT CLASS DO 18 J=1,NOUTCL CALL ROOMI(3) IX(K)=LL IX(K+1)=IMCLSS(J,2) IX(K+2)=J K=K+3 18 CONTINUE ISIZE=ISIZE*NOUTCL END IF ICLBAR=ICLBAR+1 20 CONTINUE IX(ICLSS2)=(K-ICLSS2)/3-1 IX(ICLSS2+1)=ISIZE IX(ICLSS2+2)=IX(ICLSS2) IX(ICLSS2+3)=0 IX(ICLSS2+4)=0 END IF IF(BLTYPE(ICLBLK).EQ.1.AND.BLTYPE(JCLBLK).EQ.1) THEN C ! Copy N CALL RINCR(4,NPASS,2) C ! of block V1(NPASS-1)=JCLBLK V2(NPASS-1)=9 V3(NPASS-1)=ICLSS1 V1(NPASS)=ICLBLK V2(NPASS)=9 V3(NPASS)=ICLSS2 END IF IF(BLVSIZ(ICLBLK).GT.0.AND.BLVSIZ(JCLBLK).GT.0) THEN DO 40 IVIN=BLVSTR(ICLBLK),BLVSTR(ICLBLK)+BLVSIZ(ICLBLK)-1 K=RCEIL(2)-ANVTOT+BLVSTR(JCLBLK) CALL VNMTCH(VNAME(IVIN),VNAME(K),BLVSIZ(JCLBLK),L) IF(L.NE.0) THEN C ! Matching var L=K+L-1 IF(NTRANS.GT.1) THEN C ! For INCORPORATEd files IF(MTYPE(IVIN).NE.MTYPE(L)) THEN WRITE(U6,203)VNAME(IVIN) IMERR1=130107 GO TO 62 ELSE IF(MSIZE(IVIN).NE.MSIZE(L)) THEN WRITE(U6,203)VNAME(IVIN) IMERR1=130108 GO TO 62 ELSE IF(MTYPE(IVIN).EQ.8.OR.MTYPE(IVIN).EQ.9.OR. . MTYPE(IVIN).EQ.19) THEN I=CDMPNT(IVIN) IJ=CDMPNT(L) DO 24 II=I,I+CROSSD(I) IF(CROSSD(II).NE.CROSSD(IJ)) THEN WRITE(U6,203)VNAME(IVIN) IMERR1=130109 GO TO 62 END IF IJ=IJ+1 24 CONTINUE END IF ELSE IF(MCHTYP.EQ.3.AND.IMCLSS(1,1).EQ.0) THEN IF(MTYPE(IVIN).GT.10.AND.MTYPE(IVIN).LE.20) THEN WRITE(U6,203)MTYPE(IVIN) IMERR1=130110 GO TO 62 END IF END IF CALL RINCR(4,NPASS,2) V1(NPASS-1)=L V2(NPASS-1)=0 V3(NPASS-1)=ICLSS1 V1(NPASS)=IVIN V2(NPASS)=0 V3(NPASS)=ICLSS2 END IF 40 CONTINUE END IF JCLBLK=JCLBLK+1 50 CONTINUE IX(NTRANS*12-6)=NPASS-NPASSV RETURN C C For mismatching classes, write information C 55 CONTINUE WRITE(U6,200)ICLBLK,BLNCLS(ICLBLK),BLNCLS(JCLBLK) IF(BLNCLS(ICLBLK).EQ.0) THEN WRITE(U6,206) ELSE WRITE(U6,204) DO 57 ICLBAR=BLCPNT(ICLBLK),BLCPNT(ICLBLK)+BLNCLS(ICLBLK)-1 WRITE(U6,205)VNAME(CLPNT(ICLBAR)) 57 CONTINUE END IF IF(BLNCLS(JCLBLK).EQ.0) THEN WRITE(U6,208) ELSE WRITE(U6,207) DO 60 ICLBAR=BLCPNT(JCLBLK),BLCPNT(JCLBLK)+BLNCLS(JCLBLK)-1 WRITE(U6,205)VNAME(CLPNT(ICLBAR)) 60 CONTINUE END IF 62 CONTINUE IF(U5.GE.13.AND.U5.LE.17) THEN RETURN ELSE CALL FSTOP END IF END C SUBROUTINE VMREAD(IXM,ITRANS,IREP,IBYGRP) C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C INTEGER IXM(10),ITRANS 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) C PARAMETER (MTRANS=1500,MRANGS=20) PARAMETER (MTRSZI=MSIZEI+6*MRANGE-6*MRANGS+2*MRNSET+MRECOD+MVAR) PARAMETER (IXFLLD=49+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,ISTEPC,ISELEC,IOUTPT,IAS,IASLST,NCRVLB,NASVL, . IFLLVL,IXFILL(IXFLLD) COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT, . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF, . ISTEPC,ISELEC,IOUTPT,IAS,IASLST,NCRVLB,NASVL,IFLLVL,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 LOGICAL ENDFLE C 201 FORMAT(' MISMATCH OF VARIANCE IDS - PRIMARY FILE:',3(/,5X,3F22.3)) 202 FORMAT(' VPLX FILE ASSIGNED TO UNIT',I3,' IDS:',3(/,5X,3F22.3)) 203 FORMAT(' MISMATCH OF BY IDS - PRIMARY FILE:',3(/,5X,3F22.3)) C C IXM(1) - FORTRAN unit C IXM(2) - 1 unit on end of file (not used) C IXM(3) - read option C 0 = not given (i.e., default option) C 1 = FULL C 2 = CONSTANTS C 3 = REPLICATE C 4 = BYREPEAT C IXM(4) - ID checking option C 0 = no checking C 1 = check C IXM(5) - ANIDTT - length of ID on file C IXM(6) - ATSIZE - total size of matrix C IXM(7) - ANRPTT - number of replicates C IXM(8) - ANVREG - number of regular variables C IXM(9) - ANVRID - number of variance IDs C IXM(10)- ANBY - number of BY variables C IDSTRT=IX(12*ITRANS-4) IDXSTR=IX(12*ITRANS-3) 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(IREP.EQ.0.AND.IBYGRP.EQ.1.AND.IXM(3).EQ.2) THEN C C If OPTION CONSTANT, read only if IFIRST C IREAD=1 ELSE IF(IXM(3).EQ.1) THEN C C Under FULL, read only for full samples. C IF(IREP.EQ.0) THEN IREAD=1 IF(IBYGRP.GT.1.AND.IXM(7).GT.0) THEN C C SPACE VPLX FILE TO NEXT BY GROUP HERE C DO 2 I=1,IXM(7) READ(IXM(1),END=94)(DX(IDSTRT+J-1),J=1,IXM(5)) CALL UNFIN(IXM(1),DX(IDXSTR),IXM(6),ENDFLE) IF(ENDFLE)GO TO 94 2 CONTINUE END IF END IF ELSE IF(IXM(3).EQ.0.OR.IXM(3).EQ.3.OR.IXM(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(IXM(3).EQ.4) THEN IF(IREP.EQ.0.AND.IBYGRP.GT.0) THEN REWIND(UNIT=IXM(1)) NXPTD2=NXPTD CALL PREAMD(IXM(1)) NXPTD=NXPTD2 END IF END IF END IF C C IF(IREAD.EQ.1) THEN C C READ VPLX FILE C READ(IXM(1),END=94)(DX(IDSTRT+J-1),J=1,IXM(5)) IF(IXM(4).EQ.1) THEN C ! IDCHECK IF(IREP.GT.0.AND.(IXM(3).EQ.3.OR.IXM(3).EQ.4)) THEN DO 10 J=1,NVARID IF(DABS(DX(IDSTRT+J-1)-DX(IX(8)+J-1)).GT..1D-03) GO TO 11 10 CONTINUE GO TO 12 11 CONTINUE WRITE(U6,201)(DX(IX(8)+J-1),J=1,NVARID) WRITE(U6,202)IXM(1),(DX(IDSTRT+J-1),J=1,NVARID) CALL FESTOP(130201) 12 CONTINUE END IF END IF IF(IXM(3).EQ.1.OR.IXM(3).EQ.3) THEN DO 15 J=1,NBY IF(DABS(DX(IDSTRT+IXM(9)+J-1)-DX(IX(8)+NVARID+J-1)).GT. . .1D-03) GO TO 16 15 CONTINUE GO TO 17 16 CONTINUE WRITE(U6,203)(DX(IX(8)+NVARID+J-1),J=1,NBY) WRITE(U6,202)IXM(1),(DX(IDSTRT+IXM(9)+J-1),J=1,NBY) CALL FESTOP(130202) 17 CONTINUE END IF CALL UNFIN(IXM(1),DX(IDXSTR),IXM(6),ENDFLE) IF(ENDFLE)GO TO 94 END IF RETURN 94 CONTINUE CALL FESTOP(130200) END C SUBROUTINE NMERGE(IXM,LNMAP,LNECHO) C C Note: Usage of storage and common blocks has been largely patterned C after the TRANSFORM step. C C IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER (IXDIM=13) INTEGER IXM(IXDIM,*),LNMAP(*),LNECHO(*) 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 (MTRANS=1500,MRANGS=20) PARAMETER (MTRSZI=MSIZEI+6*MRANGE-6*MRANGS+2*MRNSET+MRECOD+MVAR) PARAMETER (IXFLLD=49+3*MAXIDS) PARAMETER (NOPTNT=4,NOPTNV=10) PARAMETER (MAXFMT=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 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 Usage in this subroutine: C V1 - Variable number (or block no. if V2=9) C V2 - Transformation code (used to indicate n(block) only) C V3 - Pointer to 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 CHARACTER*256 CARDWK,CARDSV,CARDIM COMMON /CMBLK2/CARDWK,CARDSV,CARDIM C LOGICAL REFRSH,ALPCHK,ICHECK EXTERNAL REFRSH,ALPCHK,ICHECK C INTEGER SICMUL,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT,SDCONS,SDID, . SDWRK,VKEEPF,ISTEPC,ISELEC,IOUTPT,IAS,IASLST,NCRVLB,NASVL, . IFLLVL,IXFILL(IXFLLD) COMMON /STPBLK/SICMUL,NVIN,SICLBK,SIVMAP,SIXINC,SIXSTR,SDTOUT, . IOUTSZ,NCLBLS,NTRANS,SDCONS,SDID,SDWRK,IXBASE,NKEEP,VKEEPF, . IFLLVL,ISTEPC,ISELEC,IOUTPT,IAS,IASLST,NCRVLB,NASVL,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 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 INTEGER ITYPEF(3),IFILEF(3) C CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT C C Usage in this subroutine: C C BLVSTR - (Values from primary input saved to include in output C file.) Beginning variable of block. C BLVSIZ - read from incoming file, used to compute block numbers C in MXSIZE. C BLNCLS - number of classes in block C BLCPNT - pointer for classes to CLPNT and CLTYPE C CLPNT - used as pointers to class variables C C LOGICAL ENDMRG CHARACTER*12 OPTNT(NOPTNT),OPTNV(NOPTNV) INTEGER INDXT(NOPTNT),INDXV(NOPTNV) INTEGER IVALT(NOPTNT),IVALV(NOPTNV) DATA OPTNT / 'ZEROFILL ','MISSINGFILL ','ZERO ', . 'MISSING '/ DATA OPTNV / 'BYGROUP ','CONSTANTS ','REPLICATE ', . 'CONSTANT ','FULL ','BYREPEAT ', . 'REPEAT ','IDCHECK ','NOIDCHECK ', . 'FULLSAMPLE '/ DATA INDXV/3,3,3,3,3,3,3,4,4,3/ DATA INDXT/1,1,1,1/ DATA IVALT/0,1,0,1/ DATA IVALV/1,2,3,2,1,4,4,1,0,1/ C 100 FORMAT(/,' Note: Fortran unit',I3,' assigned to ',A40) 101 FORMAT(/,' Note: Fortran unit',I3,' assigned to ',/,1X,A80) 200 FORMAT(/,5X,'WARNING: The SELECT variable is not associated with', . ' one or more blocks') 201 FORMAT(5X,'WARNING: Because this file lacks BY variables, BYREPE', .'AT is default') 202 FORMAT(5X,'WARNING: Because this file lacks BY variables, CONSTA', .'NTS is default') 203 FORMAT(' REPLICATES ON INCORPORATED FILE',I8,' VS. PRIMARY',I8) 204 FORMAT(5X,'WARNING: Coefficients for variance calculation differ', . ' from primary.',/,14X,'Largest difference is',D14.6) 205 FORMAT(/,' ERROR ON FILE ASSIGNED TO FORTRAN UNIT',I3,/) C C Initializations. C NPASS - index to variable arguments to copy C Each variable to be copied requires 2 levels of NPASS: C One for INCORPORATEd file and one for merged file. C NPASS=0 C C VMERGE has already reserved space in IX C IX(1) - IX(12*MTRANS) Space to indicate transformations (merge C information) C IX(12*MTRANS+1) - IX(12*MTRANS+MCLBLK) - SICMUL=12*NTRANS+1 - C start of IX array with multipliers for blocks used by C TMOVE2 C C IX(NTRANS*12-11) = Starting location in IX for options C IX(NTRANS*12-10) = Starting location in IX for values copied from C block information arrays C IX(NTRANS*12-9) = Number of blocks (from ANCLBL) C IX(NTRANS*12-8) = Number of elements in class specifications for C block (from ANCLBR) C IX(NTRANS*12-7) = Number of variables (from ANVTOT) C IX(NTRANS*12-6) = 2*Number of variables to move (counting block N) C IX(NTRANS*12-5) = Starting value of NPASS C IX(NTRANS*12-4) = Starting location for ID C IX(NTRANS*12-3) = Starting location for DX C C VTMPSZ=MVAR-SVTEMP+1 C ! Note: not used C C ISELEC - class variable identified by SELECT C IOUTPT - class variable identified by OUTPUT class C IAS - class variable identified by AS C IASLST - pointer in IX to list from AS C NASLST - number of elements in ASTLST list C NCRVLB - if labels are read with an AS statement, they will be C read after this point C NASVL - number of labels read after as AS statement. C C ISELEC=0 C IOUTPT=0 C IAS=0 C IASLST=0 C NCRVLB=NCRVL C NASVL=0 C 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) IF(IGROUP.EQ.7.AND.(IKEY.EQ.1.OR.IKEY.EQ.25)) THEN C C SELECT (7,1) OUTPUT (7,25) C C Determine class variable to use C Find level to select and edit for completeness C C Error messages if both SELECT and OUTPUT appear. C IF(IKEY.EQ.1) THEN C ! SELECT IF(ISELEC.GT.0) THEN C ! previous SELECT IF(ISTEPC.EQ.1) THEN IMERR1=130003 ELSE IMERR1=130038 END IF ELSE IF(IOUTPT.GT.0) THEN IMERR1=130004 END IF ELSE C ! OUTPUT IF(IOUTPT.GT.0) THEN IMERR1=130005 ELSE IF(ISELEC.GT.0) THEN IMERR1=130019 END IF END IF IF(IMERR1.GT.0) THEN ILINE=IXM(1,ISTATE) IMERR2=IXM(2,ISTATE) CALL CMPRNT(IXM,LNMAP) END IF C CALL CMATCH(CARD(IPT:256),IPT,256,'CLASS',5,IPOS,1) IF(IPOS.GT.0) THEN CALL NBFND2(IPOS,IPT) C ! CLASS is optional END IF C ! (undocumented) MAXVN=RCEIL(2)-NVTOT-ANVTOT-2 IF(MAXVN.LE.0) THEN C ! Error if not enough room K=ANVTOT+2 C ! for variable names. CALL RCHECK(2,NVIN,K) END IF CALL VNFIND(IPT,VNAME(NVIN+1),MAXVN,N,IPOS,2,VNAME,NVIN) IF(N.EQ.0) THEN IMERR1=130006 IMERR2=IPT ELSE IF(N.GT.1) THEN C ! Accept only one variable name IMERR1=130007 IMERR2=IPOS END IF IF(IMERR1.GT.0) THEN ILINE=LNCNTR CALL CMPRNT(IXM,LNMAP) END IF CALL VNMTCH(VNAME(NVIN+1),VNAME,NVIN,K) C C If the provided variable name does not match, accept only if C OUTPUT, if output class has not been previously identified by AS. C IF(K.EQ.0) THEN IF(IKEY.EQ.1) THEN C ! SELECT IMERR1=130008 ELSE IF(IAS.GT.0) THEN C ! If class variable already named IMERR1=130020 C ! in AS statement, must agree ELSE CALL RINCR(2,NVIN,1) C ! Add new OUTPUT CLASS to end of K=NVIN C ! variable list MTYPE(NVIN)=4 IOUTPT=NVIN LABEL(NVIN)(1:12)=VNAME(NVIN) LABEL(NVIN)(13:24)=' ' END IF C C If variable has appeared, make sure it is a class variable, etc. C ELSE IF(MTYPE(K).NE.4) THEN IMERR1=130009 ELSE IF(IKEY.EQ.1) THEN C ! SELECT ISELEC=K ELSE IF(IAS.GT.0.AND.IAS.NE.K) THEN IMERR1=130020 END IF IOUTPT=K END IF END IF END IF IF(IMERR1.GT.0) THEN ILINE=LNCNTR IMERR2=IPT CALL CMPRNT(IXM,LNMAP) END IF C C Search for "(ISVAL)" C CALL NBFND2(IPOS,IPT) IF(CARD(IPT:IPT).NE.'(') THEN IMERR1=130010 ELSE IPOS=IPT+1 CALL NBFND2(IPOS,IPT) CALL IFIND(CARD(IPT:256),IPT,256,IPOS,ISVAL) IF(IPOS.EQ.0) THEN IMERR1=130011 ELSE C C For SELECT, edit ISVAL. C IF(IKEY.EQ.1) THEN C ! SELECT IF(ISVAL.LT.0.OR.ISVAL.GT.MSIZE(ISELEC)) THEN IMERR1=130012 END IF NOUTPT=1 ELSE C ! OUTPUT CLASS IF(ISVAL.LE.0) THEN IMERR1=130011 END IF NOUTPT=ISVAL IF(IAS.GT.NVTOT) THEN C ! If previous AS statement has MSIZE(IAS)=NOUTPT C ! named a new class variable END IF C ! store size here END IF END IF END IF IF(IMERR1.GT.0) THEN ILINE=LNCNTR IMERR2=IPT CALL CMPRNT(IXM,LNMAP) END IF CALL NBFND2(IPOS,IPT) IF(CARD(IPT:IPT).NE.')') THEN IMERR1=130013 IMERR2=IPT ILINE=LNCNTR CALL CMPRNT(IXM,LNMAP) END IF IPOS=IPT+1 C C Store labels and other information for the new class in the C slot NVTOT+1 above the number of variables in the incoming file. C This positioning anticipates the later moving around of labels. C IF(IKEY.EQ.25) THEN C ! OUTPUT K=NVTOT+1 MSIZE(K)=NOUTPT C C Deliberately leave space of NOUTPT in LEVEL array. Values of C LEVEL stored here will have to be moved later. C LPOINT(K)=NCRVL+NOUTPT+1 NCRVLB=NCRVL+2*NOUTPT I=2*NOUTPT+NASVL CALL RCHECK(7,NCRVL,I) C ! Check for enough room for labels C C If levels have been read with a previous AS statement, move them. C IF(NASVL.GT.0) THEN DO 19 I=1,NASVL LEVEL(NCRVLB+I)=LEVEL(NCRVL+I) 19 CONTINUE END IF C CALL NBFND2(IPOS,IPT) NCRVLS=NCRVL CALL RINCR(7,NCRVL,NOUTPT) DO 20 I=1,NOUTPT CALL RINCR(7,NCRVL,1) C ! LEVELD called LEVEL(NCRVL)(1:12)=' ' C ! from VMERGE LEVEL(NCRVL)(13:24)=LEVEL(NCRVL)(1:12) C ! later for 20 CONTINUE C ! defaults IF(IPT.GT.1) THEN CALL LEVELR(IPT,IPOS,NL, C ! For now, store . LEVEL(NCRVLS+NOUTPT+1), C ! labels at . NOUTPT) C ! NCRVLS+NOUTPT+1 END IF END IF CALL NBFND2(IPOS,IPT) IF(CARD(IPT:IPT).NE.';') THEN IMERR1=130040 IMERR2=IPT ILINE=LNCNTR CALL CMPRNT(IXM,LNMAP) END IF C ELSE IF(IGROUP.EQ.8.AND.IKEY.EQ.6) THEN C ! AS (8,6) C C C Determine if class name has been given C C Read list of variables. C IF(ISELEC.GT.0) THEN IMERR1=130014 ELSE IF(IAS.GT.0) THEN IMERR1=130021 END IF IF(IMERR1.GT.0) THEN ILINE=LNCNTR IMERR2=IPT CALL CMPRNT(IXM,LNMAP) END IF MAXVN=RCEIL(2)-ANVTOT-NVTOT-2 IF(MAXVN.LE.0) THEN K=ANVTOT+2 CALL RCHECK(2,NVIN,ANVTOT) END IF CALL VNFIND(IPT,VNAME(NVIN+1),MAXVN,N,IPOS,2,VNAME,NVIN) C IF(N.GT.1) THEN IMERR1=130016 ELSE IF(N.EQ.1) THEN IPT=IPOS CALL VNMTCH(VNAME(NVIN+1),VNAME,NVIN,K) C C Accept unmatching name only if OUTPUT has not already appeared. C IF(K.EQ.0) THEN IF(IOUTPT.GT.0) THEN IMERR1=130018 ELSE CALL RINCR(2,NVIN,1) MTYPE(NVIN)=4 MSIZE(NVIN)=0 C ! Size to be determined later IAS=NVIN LABEL(NVIN)(1:12)=VNAME(NVIN) LABEL(NVIN)(13:24)=' ' END IF ELSE IF(MTYPE(K).NE.4) THEN IMERR1=130009 ELSE IAS=K IF(IOUTPT.GT.0) THEN IF(K.NE.IOUTPT) THEN IMERR1=130017 END IF END IF END IF END IF END IF IF(IMERR1.GT.0) THEN ILINE=LNCNTR CALL CMPRNT(IXM,LNMAP) END IF CALL NBFND2(IPT,IPOS) C C Read the disposition list. C IF(CARD(IPT:IPT).NE.'(') THEN IMERR1=130010 ILINE=LNCNTR IMERR2=IPT CALL CMPRNT(IXM,LNMAP) ELSE IPOS=IPT+1 CALL NBFND2(IPOS,IPT) END IF CALL RNSCAN(IPT,IPOS,RANGE,MRANGS,RTYPE,RGROUP, . NR,3,LEVEL,1) IF(IPOS.EQ.0.OR.NR.LE.0) THEN IMERR1=130022 ILINE=LNCNTR CALL CMPRNT(IXM,LNMAP) END IF IPT=IPOS C ! IPOS set to 1 beyond ')' by RNSCAN IASLST=NXPTI IASNOW=IASLST-1 DO 24 I=1,NR IF(RTYPE(I).EQ.5) THEN C ! 5 MISSING IMERR1=130023 ELSE IF(RTYPE(I).EQ.1.OR. C ! 1 value1 - value2 . RTYPE(I).EQ.3.OR. C ! 3 value - HIGH . RTYPE(I).EQ.6) THEN C ! 6 value - n ILOW=RANGE(1,I)+.1D-7 ELSE C ! 2 LOW - value ILOW=1 C ! 4 LOW - HIGH END IF IF(RTYPE(I).EQ.1.OR.RTYPE(I).EQ.2) THEN IHIGH=RANGE(2,I) ELSE IF(ILOW.EQ.1) THEN IF(MSIZE(IAS).EQ.0) THEN C ! When 1-HIGH, interpret as IMERR1=130024 C ! determined by MSIZE(IAS) ELSE IHIGH=MSIZE(IAS) END IF ELSE IF(IOUTPT.GT.0) THEN C ! For other n-HIGH, interpret IHIGH=NOUTPT C ! HIGH as governed by size ELSE C ! of output class IMERR1=130024 END IF END IF END IF IF(IMERR1.EQ.0) THEN DO 22 J=ILOW,IHIGH C ! Identify elements of range CALL ROOMI(1) IASNOW=IASNOW+1 IX(IASNOW)=J 22 CONTINUE END IF END IF IF(IMERR1.GT.0) THEN ILINE=LNCNTR CALL CMPRNT(IXM,LNMAP) END IF 24 CONTINUE C C Note: NASLST is the length of the specification. C This will be checked for consistency later. C NASLST=IASNOW-IASLST+1 C C Check for the presence of labels. C CALL NBFND2(IPT,IPOS) IF(CARD(IPOS:IPOS).NE.';') THEN IPT=IPOS CALL LEVELR(IPT,IPOS,NASVL,LEVEL(NCRVLB+1),NASLST) IF(IPOS.NE.0) THEN CALL NBFND2(IPOS,IPT) IF(CARD(IPT:IPT).NE.';') THEN IMERR1=130040 IMERR2=IPT END IF ELSE IMERR1=130040 END IF IF(IMERR1.GT.0) THEN ILINE=LNCNTR CALL CMPRNT(IXM,LNMAP) END IF END IF C ELSE IF(IGROUP.EQ.2.AND.(IKEY.EQ.14.OR.IKEY.EQ.15)) THEN C C STEP OPTION, STEPOPTION, STEP_OPTION C IF(IKEY.EQ.14) THEN C ! STEP CALL NBFND2(IPT,IPOS) IPT=IPOS 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 IMERR1=200070 IMERR2=IPT ILINE=LNCNTR CALL CMPRNT(IXM,LNMAP) END IF END IF END IF IF(ISOPTN.EQ.1.OR.NTRANS.GT.1) THEN C ! STEP OPTION must be set IMERR1=130041 C ! at beginning ILINE=LNCNTR CALL CMPRNT(IXM,LNMAP) END IF NXPTIS=NXPTI CALL ROOMI(1) IX(NXPTIS)=0 ISOPTN=1 C ! Flag that step options set CALL OPTNTR(NOPTNT,INDXT,IVALT,OPTNT,IPT,IPOS,IX(NXPTIS)) IF(IX(NXPTIS).EQ.1) THEN IFLLVL=1 C ! MISSINGFILL END IF NXPTI=NXPTIS CALL NBFND2(IPOS,IPT) IF(CARD(IPT:IPT).NE.';') THEN IMERR1=130040 IMERR2=IPT ILINE=LNCNTR CALL CMPRNT(IXM,LNMAP) END IF ELSE IF(IGROUP.EQ.2.AND.IKEY.EQ.11) THEN C ! OPTION IF(NTRANS.EQ.1) THEN IMERR1=130042 ILINE=IXM(1,ISTATE) IMERR2=IXM(2,ISTATE) CALL CMPRNT(IXM,LNMAP) END IF I=IX(NTRANS*12-11) CALL OPTNTR(NOPTNV,INDXV,IVALV,OPTNV,IPT,IPOS,IX(I)) CALL NBFND2(IPOS,IPT) IF(CARD(IPT:IPT).NE.';') THEN IMERR1=130040 IMERR2=IPT ILINE=LNCNTR CALL CMPRNT(IXM,LNMAP) END IF ELSE IF(IGROUP.NE.8.OR.IKEY.NE.7) THEN C ! If not INCORPORATE, IF(ISTEPC.EQ.1) THEN C ! error IMERR1=130036 C ! FUTURE: add DROP, KEEP ELSE IMERR1=130037 END IF ILINE=IXM(1,ISTATE) IMERR2=IXM(2,ISTATE) CALL CMPRNT(IXM,LNMAP) END IF C IF(ISTATE.LT.NSTATE.AND. C ! End of loop unless at . (IGROUP.NE.8.OR.IKEY.NE.7)) GO TO 1 C ! last statement or 64 CONTINUE C ! INCORPORATE I=IX(NTRANS*12-11) C ! This section completes processing IX(I+4)=ANIDTT C ! for a file (either IN= or IX(I+5)=ATSIZE C ! INCORPORATE) IX(I+6)=ANRPTT IX(I+7)=ANVREG IX(I+8)=ANVRID IX(I+9)=ANBY IX(NTRANS*12-9)=ANCLBL IX(NTRANS*12-8)=ANCLBR IX(NTRANS*12-7)=ANVTOT IX(NTRANS*12-5)=NPASS+1 C IX(NTRANS*12-10)=NXPTI K=NXPTI IF(ISELEC.EQ.0) THEN C C First, copy critical stored arrays into IX, unless ISELEC>0 C I=5*ANCLBL CALL ROOMI(I) I=RCEIL(8)-ANCLBL+1 C ! Information stored at upper DO 28 J=1,ANCLBL C ! end of arrays by PREAMD are IX(K)=BLXINC(I) C ! saved in IX IX(K+1)=BLNCLS(I) IX(K+2)=BLCPNT(I) IX(K+3)=IX(SICMUL+I-1) IX(K+4)=BLXSTR(I) I=I+1 K=K+5 28 CONTINUE C IF(ANCLBR.GT.0) THEN I=2*ANCLBR CALL ROOMI(I) I=RCEIL(9)-ANCLBR+1 DO 30 J=1,ANCLBR IX(K)=CLTYPE(I) IX(K+1)=CLPNT(I) I=I+1 K=K+2 30 CONTINUE END IF C IF(ANVTOT.GT.0) THEN CALL ROOMI(ANVTOT) I=RCEIL(2)-ANVTOT+1 DO 31 J=1,ANVTOT IX(K)=MSIZE(I) I=I+1 K=K+1 31 CONTINUE END IF IF(ANVREG.GT.0) THEN I=2*ANVREG CALL ROOMI(I) I=RCEIL(2)-ANVTOT+1 DO 32 J=1,ANVREG IX(K)=VMAPL(I) IX(K+1)=MXSIZE(I) I=I+1 K=K+2 32 CONTINUE END IF END IF C IF(NTRANS.EQ.1) THEN C ! For primary file (IN =) IF(ISELEC.GT.0) THEN C C Adjust meta-data for SELECT C ISIZE=MSIZE(ISELEC) IF(ISELEC.LT.NVTOT) THEN C C First, adjust level, moving any labels above the selected variable C down by ISIZE C C IF(NCRVL.GT.ISIZE) THEN ! changed 7/1/98 C IF(NCRVL.GE.ISIZE+LPOINT(ISELEC)) THEN DO 33 LL=LPOINT(ISELEC),NCRVL-ISIZE LEVEL(LL)=LEVEL(LL+ISIZE) 33 CONTINUE END IF C C Reduce variable list for any variables above ISELEC C DO 34 I=ISELEC+1,NVTOT MTYPE(I-1)=MTYPE(I) MSIZE(I-1)=MSIZE(I) VNAME(I-1)=VNAME(I) LABEL(I-1)=LABEL(I) IF(LPOINT(I).GT.0) THEN LPOINT(I-1)=LPOINT(I)-ISIZE ELSE LPOINT(I-1)=0 END IF 34 CONTINUE END IF C C Adjust contents of CLPNT, etc. C IWARN=0 I=RCEIL(8)-ANCLBL+1 C ! location of block information in C ! copy at upper end C C ISEL2 is variable number of selected class in upper copy C ISEL2=ISELEC+RCEIL(2)-ANVTOT KK=0 IST=1 DO 38 J=1,ANCLBL BLXSTR(J)=IST BLCPNT(J)=KK+1 IWARNB=1 C ! selected class not yet found IF(BLNCLS(I).GT.0) THEN II=BLCPNT(I) DO 35 JJ=1,BLNCLS(I) IF(CLPNT(II).EQ.ISEL2) THEN IWARNB=0 C ! selected class found in block ELSE KK=KK+1 IF(CLPNT(II).GT.ISEL2) THEN CLPNT(KK)=CLPNT(II)-RCEIL(2)+ANVTOT-1 ELSE CLPNT(KK)=CLPNT(II)-RCEIL(2)+ANVTOT END IF CLTYPE(KK)=CLTYPE(II) END IF II=II+1 35 CONTINUE END IF IF(IWARNB.EQ.1) THEN IWARN=1 C ! class variable not found ELSE BLXSIZ(J)=BLXSIZ(J)/ISIZE BLNCLS(J)=BLNCLS(J)-1 IF(BLNCLS(J).EQ.0) THEN C ! change BLPCNT if no remaining BLCPNT(J)=0 C ! class variables END IF END IF IX(SICMUL+J-1)=BLXSIZ(J)/BLXINC(J) IF(BLVSIZ(J).GT.0) THEN IST1=IST IF(BLTYPE(J).EQ.1) THEN IST1=IST1+1 END IF LL=BLVSTR(J) C C Recreate VMAPL C DO 36 L=1,BLVSIZ(J) VMAPL(LL)=IST1 IST1=IST1+MSIZE(LL) LL=LL+1 36 CONTINUE END IF IST=IST+BLXSIZ(J) I=I+1 38 CONTINUE IF(IWARN.EQ.1) THEN WRITE(U6,200) END IF NVTOT=NVTOT-1 NCLASS=NCLASS-1 TSIZE=IST-1 NCLBAR=KK NCRVL=NCRVL-ISIZE ISELEC=ISEL2 C ! Change ISELEC to point to C ! upper value ELSE IF (IOUTPT.GT.0) THEN C ! OUTPUT CLASS C C Establish space to keep track of which output levels have been C assigned. C ISOUTF=NXPTI C ! IX(ISOUTF) - array of flags CALL ROOMI(NOUTPT) C ! for assigned levels DO 39 I=1,NOUTPT IX(ISOUTF+I-1)=0 39 CONTINUE C C Adjust meta-data for OUTPUT CLASS C IF(IOUTPT.GT.NVTOT) THEN C ! OUTPUT CLASS is a new var C C IOUT2 will be the new position of the output class C IOUT2=NVREG+NCLASS+1 C C First, adjust variable list. Move up any labels associated with C BY variables, etc. NCLABV will be the start of these labels, if C any. C NCLABV=0 IF(IOUT2.LE.NVTOT) THEN DO 40 I=IOUT2,NVTOT IF(NCLABV.EQ.0) THEN IF(LPOINT(I).GT.0) THEN NCLABV=LPOINT(I) END IF END IF 40 CONTINUE IF(NCLABV.GT.0) THEN DO 41 I=NCRVLS,NCLABV,-1 LEVEL(I+NOUTPT)=LEVEL(I) 41 CONTINUE END IF MTYPE(NVTOT+2)=MTYPE(NVTOT+1) C ! Move MTYPE, etc. for MSIZE(NVTOT+2)=MSIZE(NVTOT+1) C ! new output var up by VNAME(NVTOT+2)=VNAME(NVTOT+1) C ! 1 LABEL(NVTOT+2)=LABEL(NVTOT+1) DO 42 I=NVTOT,IOUT2,-1 C ! Move existing var. up MTYPE(I+1)=MTYPE(I) C ! by 1 MSIZE(I+1)=MSIZE(I) VNAME(I+1)=VNAME(I) LABEL(I+1)=LABEL(I) IF(LPOINT(I).GT.0) THEN LPOINT(I+1)=LPOINT(I)+NOUTPT ELSE LPOINT(I+1)=0 END IF 42 CONTINUE MTYPE(IOUT2)=MTYPE(NVTOT+2) C ! Insert for new var MSIZE(IOUT2)=MSIZE(NVTOT+2) VNAME(IOUT2)=VNAME(NVTOT+2) LABEL(IOUT2)=LABEL(NVTOT+2) END IF IF(NCLABV.EQ.0)NCLABV=NCRVLS+1 C ! Adjust LPOINT LPOINT(IOUT2)=NCLABV DO 43 I=1,NOUTPT LEVEL(NCLABV)=LEVEL(NCRVLS+NOUTPT+I) NCLABV=NCLABV+1 43 CONTINUE C C Adjust contents of CLPNT, etc. C I=RCEIL(8)-ANCLBL+1 ISIZE=MSIZE(IOUT2) KK=0 IST=1 DO 46 J=1,ANCLBL BLXSTR(J)=IST BLCPNT(J)=KK+1 IF(BLNCLS(I).GT.0) THEN II=BLCPNT(I) DO 44 JJ=1,BLNCLS(I) KK=KK+1 CLPNT(KK)=CLPNT(II)-RCEIL(2)+ANVTOT CLTYPE(KK)=CLTYPE(II) II=II+1 44 CONTINUE END IF KK=KK+1 CLPNT(KK)=IOUT2 C ! Add new class to end of list CLTYPE(KK)=1 C ! for block BLXSIZ(J)=BLXSIZ(J)*ISIZE IX(SICMUL+J-1)=BLXSIZ(J)/BLXINC(J) BLNCLS(J)=BLNCLS(J)+1 IF(BLVSIZ(J).GT.0) THEN C ! If reg. vars in block IST1=IST IF(BLTYPE(J).EQ.1) THEN IST1=IST1+1 END IF LL=BLVSTR(J) C C Recreate VMAPL C DO 45 L=1,BLVSIZ(J) VMAPL(LL)=IST1 IST1=IST1+MSIZE(LL) LL=LL+1 45 CONTINUE END IF IST=IST+BLXSIZ(J) I=I+1 46 CONTINUE NVTOT=NVTOT+1 NCLASS=NCLASS+1 TSIZE=IST-1 NCLBAR=KK NCRVL=NCRVLS+NOUTPT ELSE C C OUTPUT class is already present in incoming file C C C IOUT2 will be the new position of the output class. C In this case (OUTPUT class present in file) IOUT2 is pointing C to a class variable. Put IOUT2 at the end of the class list. C ISIZE=MSIZE(IOUTPT) IOUT2=NVREG+NCLASS NCLABV=LPOINT(IOUT2)+MSIZE(IOUT2) LL=LPOINT(IOUTPT)+ISIZE C C Move any labels for classes above IOUTPT down by ISIZE C IF(LL.LT.NCLABV) THEN DO 47 I=LL,NCLABV-1 LEVEL(I-ISIZE)=LEVEL(I) 47 CONTINUE END IF IF(IOUT2.LT.NVTOT.AND.NCLABV.LE.NCRVLS) THEN C C Adjust any labels above the class labels. C C C If NOUTPT > ISIZE, must move remaining labels up C IF(NOUTPT.GT.ISIZE) THEN DO 461 I=NCRVLS,NCLABV,-1 LEVEL(I+NOUTPT-ISIZE)=LEVEL(I) 461 CONTINUE C C If NOUTPT < ISIZE, must move remaining labels down C ELSE IF(NOUTPT.LT.ISIZE) THEN DO 462 I=NCLABV,NCRVLS LEVEL(I+NOUTPT-ISIZE)=LEVEL(I) 462 CONTINUE END IF END IF LL=NCLABV-ISIZE LPOINT(IOUTPT)=LL C C Copy output labels for IOUTPT into place, which begins at C NCLABV-ISIZE C DO 48 I=1,NOUTPT LEVEL(LL)=LEVEL(NCRVLS+NOUTPT+I) LL=LL+1 48 CONTINUE IF(IOUTPT.LT.IOUT2) THEN C C First, reduce variable list C MTYPE(NVTOT+2)=MTYPE(IOUTPT) MSIZE(NVTOT+2)=NOUTPT VNAME(NVTOT+2)=VNAME(IOUTPT) LABEL(NVTOT+2)=LABEL(IOUTPT) LPOINT(NVTOT+2)=LPOINT(IOUTPT) DO 50 I=IOUTPT,IOUT2-1 MTYPE(I)=MTYPE(I+1) MSIZE(I)=MSIZE(I+1) VNAME(I)=VNAME(I+1) LABEL(I)=LABEL(I+1) C C Since the range of IOUTPT to IOUT2 should only contain class C variables, adjust LPOINT without checking if it is 0. C LPOINT(I)=LPOINT(I+1)-ISIZE 50 CONTINUE MTYPE(IOUT2)=MTYPE(NVTOT+2) MSIZE(IOUT2)=MSIZE(NVTOT+2) VNAME(IOUT2)=VNAME(NVTOT+2) LABEL(IOUT2)=LABEL(NVTOT+2) LPOINT(IOUT2)=LPOINT(NVTOT+2) ELSE C ! If output class in place MSIZE(IOUT2)=NOUTPT END IF IF(IOUT2.LT.NVTOT) THEN C ! Adjust LPOINT for DO 505 I=IOUT2+1,NVTOT C ! other vars IF(LPOINT(I).GT.0) THEN LPOINT(I)=LPOINT(I)+NOUTPT-ISIZE END IF 505 CONTINUE END IF C C Adjust contents of CLPNT, etc. C I=RCEIL(8)-ANCLBL+1 C C IOUTUP is variable number of selected class in upper copy C IOUTUP=IOUTPT+RCEIL(2)-ANVTOT KK=0 IST=1 DO 54 J=1,ANCLBL BLXSTR(J)=IST BLCPNT(J)=KK+1 IWARNB=1 IF(BLNCLS(I).GT.0) THEN II=BLCPNT(I) DO 51 JJ=1,BLNCLS(I) IF(CLPNT(II).EQ.IOUTUP) THEN IF(CLTYPE(II).EQ.1) THEN BLXSIZ(J)=(BLXSIZ(J)/MSIZE(IOUTUP))*MSIZE(IOUT2) ELSE BLXSIZ(J)=(BLXSIZ(J)/(MSIZE(IOUTUP)+1))*MSIZE(IOUT2) END IF IWARNB=0 ELSE KK=KK+1 IF(CLPNT(II).GT.IOUTUP) THEN CLPNT(KK)=CLPNT(II)-RCEIL(2)+ANVTOT-1 ELSE CLPNT(KK)=CLPNT(II)-RCEIL(2)+ANVTOT END IF CLTYPE(KK)=CLTYPE(II) END IF II=II+1 51 CONTINUE KK=KK+1 CLPNT(KK)=IOUT2 CLTYPE(KK)=1 END IF IF(IWARNB.EQ.1) THEN C ! Require presence of IOUT in IMERR1=130026 C ! each block ILINE=LNCNTR CALL CMPRNT(IXM,LNMAP) END IF IX(SICMUL+J-1)=BLXSIZ(J)/BLXINC(J) IF(BLVSIZ(J).GT.0) THEN IST1=IST IF(BLTYPE(J).EQ.1) THEN IST1=IST1+1 END IF LL=BLVSTR(J) C C Recreate VMAPL C DO 52 L=1,BLVSIZ(J) VMAPL(LL)=IST1 IST1=IST1+MSIZE(LL) LL=LL+1 52 CONTINUE END IF IST=IST+BLXSIZ(J) I=I+1 54 CONTINUE TSIZE=IST-1 NCLBAR=KK NCRVL=NCRVLS+NOUTPT-ISIZE END IF C C Update IOUTPT to be new position of output class C IOUTPT=IOUT2 ELSE IMERR1=130027 ILINE=LNCNTR CALL CMPRNT(IXM,LNMAP) END IF C C Begin to plan out space for incoming and outgoing double data. C NEXTD=NIDTOT+TSIZE+1 IX(NTRANS*12-4)=NEXTD IX(NTRANS*12-3)=NEXTD+NIDTOT NEXTD=NEXTD+ANIDTT+ATSIZE ELSE C ! NTRANS > 1 C C Plan space for NTRANS > 1 C IX(NTRANS*12-4)=NEXTD IX(NTRANS*12-3)=NEXTD+ANIDTT NEXTD=NEXTD+ANIDTT+ATSIZE C C IX(3) - read option C 0 = not given (i.e., default option) C 1 = FULL, FULLSAMPLE C 2 = CONSTANTS C 3 = REPLICATE C 4 = BYREPEAT C IX(4) - ID checking option C 0 = no checking C 1 = check C I=IX(NTRANS*12-11) IF(IX(I+2).EQ.0) THEN IF(ANRPTT.GT.0) THEN IF(NBY.GT.0.AND.ANBY.EQ.0) THEN IX(I+2)=4 WRITE(U6,201) ELSE IX(I+2)=3 END IF ELSE C ! ANRPTT = 0 IF(NBY.GT.0.AND.ANBY.EQ.0) THEN IX(I+2)=2 WRITE(U6,202) ELSE IX(I+2)=1 END IF END IF END IF IF(IX(I+2).EQ.3.OR. C ! 3 - replicate . IX(I+2).EQ.4) THEN C ! 4 - byrepeat IF(NRPTOT.NE.ANRPTT) THEN C ! Check # replicates WRITE(U6,205)IX(I) WRITE(U6,203)ANRPTT,NRPTOT IMERR1=130043 ELSE IF(NRPTOT.GT.0) THEN C ! Check coefficients DTEMP1=0. DTEMP2=0. DO 72 IREP=1,NRPTOT IF(DABS(DX(SDCOEF+IREP-1)-DX(ASDCOF+IREP-1)).GT.DTEMP1) THEN DTEMP1=DABS(DX(SDCOEF+IREP-1)-DX(ASDCOF+IREP-1)) END IF IF(DABS(DX(SDCOEF+IREP-1)).GT.DTEMP2) THEN DTEMP2=DABS(DX(SDCOEF+IREP-1)) END IF 72 CONTINUE IF(DTEMP2.LE.0) THEN IF(DTEMP1.GT..1D-05) THEN WRITE(U6,204)DTEMP1 END IF ELSE IF(DTEMP1/DTEMP2.GT..1D-06) THEN WRITE(U6,204)DTEMP1 END IF END IF END IF IF(IMERR1.EQ.0) THEN IF(ANVRID.NE.NVARID.AND.IX(I+3).EQ.1) THEN IMERR1=130046 END IF END IF END IF IF(IMERR1.EQ.0.AND. C ! Check BY under . (IX(I+2).EQ.1.OR.IX(I+2).EQ.3)) THEN C ! FULL or REPLICATE IF(NBY.NE.ANBY.AND.IX(I+3).EQ.1) THEN C ! Check same # BY IMERR1=130045 C ! for IDCHECK ELSE IF(NBYGRP.GT.1.AND.NBYGRP.NE.ANBYGR) THEN IMERR1=130044 END IF END IF IF(IMERR1.GT.0) THEN IF(IMERR1.NE.130043) THEN WRITE(U6,205)IX(I) END IF ILINE=IXM(1,ISTATE) CALL CMPRNT(IXM,LNMAP) END IF END IF C IF(IOUTPT.GT.0) THEN C C If OUTPUT CLASS, then determine position in output class. C K=RCEIL(2)-ANVTOT+1 CALL VNMTCH(VNAME(IOUTPT),VNAME(K),ANVTOT,IOUTUP) IF(IOUTUP.GT.0) THEN IOUTUP=IOUTUP+K-1 END IF IOUTCL=NXPTI NOUTCL=0 IF(IASLST.GT.0) THEN IF(IOUTUP.GT.0) THEN IF(NASLST.NE.MSIZE(IOUTUP)) THEN IMERR1=130028 ILINE=LNCNTR CALL CMPRNT(IXM,LNMAP) END IF DO 55 I=1,NASLST IF(IX(I+IASLST-1).GT.0)NOUTCL=NOUTCL+1 55 CONTINUE I=2*NOUTCL CALL ROOMI(I) L=IOUTCL DO 56 I=1,NASLST K=IX(IASLST+I-1) IF(K.GT.0) THEN IX(L)=I IX(L+NOUTCL)=K L=L+1 C C If a label was provided as part of an AS statement, copy it. C IF(L-IOUTCL.LE.NASVL) THEN IL=LPOINT(IOUTPT) LEVEL(LPOINT(IOUTPT)+K-1)=LEVEL(NCRVLB+L-IOUTCL) END IF IF(K.GT.NOUTPT) THEN IMERR1=130031 ELSE IF(IX(ISOUTF+K-1).GT.0) THEN IMERR1=130032 ELSE IX(ISOUTF+K-1)=NTRANS END IF IF(IMERR1.GT.0) THEN ILINE=LNCNTR CALL CMPRNT(IXM,LNMAP) END IF END IF 56 CONTINUE ELSE IF(NASLST.NE.1) THEN IMERR1=130029 END IF NOUTCL=1 CALL ROOMI(2) K=IX(IASLST) IF(K.EQ.0) THEN IMERR1=130033 ELSE IF(K.GT.NOUTPT) THEN IMERR1=130031 ELSE IF(IX(ISOUTF+K-1).GT.0) THEN IMERR1=130032 END IF IF(IMERR1.GT.0) THEN ILINE=LNCNTR CALL CMPRNT(IXM,LNMAP) END IF IX(IOUTCL)=0 IX(IOUTCL+1)=K IX(ISOUTF+K-1)=NTRANS C C If label was provided as part of the AS list, then copy it. C IF(NASVL.GT.0) THEN IL=LPOINT(IOUTPT) LEVEL(LPOINT(IOUTPT)+K-1)=LEVEL(NCRVLB+1) END IF END IF ELSE C C An AS statement has not provided a list of outgoing class(es) C IF(IOUTUP.GT.0) THEN NOUTCL=MSIZE(IOUTUP) I=2*NOUTCL CALL ROOMI(I) L=0 DO 57 I=1,NOUTPT IF(IX(ISOUTF+I-1).EQ.0) THEN L=L+1 IX(IOUTCL+L-1)=L IX(IOUTCL+NOUTCL+L-1)=I IX(ISOUTF+I-1)=NTRANS IF(L.EQ.NOUTCL)GO TO 58 END IF 57 CONTINUE IMERR1=130034 58 CONTINUE ELSE NOUTCL=1 CALL ROOMI(2) DO 59 I=1,NOUTPT IF(IX(ISOUTF+I-1).EQ.0) THEN IX(IOUTCL)=0 IX(IOUTCL+1)=I IX(ISOUTF+I-1)=NTRANS GO TO 60 END IF 59 CONTINUE IMERR1=130035 60 CONTINUE END IF IF(IMERR1.GT.0) THEN ILINE=LNCNTR CALL CMPRNT(IXM,LNMAP) END IF END IF C C If output class is on incoming file, update level labels, if C appropriate. C IF(IOUTUP.GT.0) THEN JJ=LPOINT(IOUTUP)-1 KK=LPOINT(IOUTPT)-1 DO 61 I=1,NOUTCL J=IX(IOUTCL+I-1) K=IX(IOUTCL+NOUTCL+I-1) IF(LEVEL(KK+K)(1:12).EQ.' '.AND. . LEVEL(KK+K)(13:24).EQ.LEVEL(KK+K)(1:12)) THEN LEVEL(KK+K)=LEVEL(JJ+J) END IF 61 CONTINUE END IF ELSE IOUTCL=NXPTI NOUTCL=1 CALL ROOMI(2) IX(IOUTCL)=ISVAL IX(IOUTCL+1)=0 END IF NPASSV=NPASS CALL MRGSET(IOUTUP,NPASS,IX(IOUTCL),NOUTCL) C C INCORPORATE C IF(IGROUP.NE.8.OR.IKEY.NE.7.OR.ENDMRG) GO TO 1 C ! Skip to end of loop C ! unless incorporate IF(ISTEPC.EQ.2) THEN C ! Error if EXTRACT IMERR1=130039 IMERR2=IPT ILINE=LNCNTR CALL CMPRNT(IXM,LNMAP) END IF NLIST=0 ILISTX=0 CALL RINCR(12,NTRANS,1) IX(NTRANS*12-11)=NXPTI I=NXPTI CALL ROOMI(10) IX(I+1)=0 IX(I+2)=0 C ! No default on FULL etc. IX(I+3)=1 C ! Default is IDCHECK (new syntax) ITYPEF(1)=2 ITYPEF(2)=0 CALL FNREAD(IPT,ITYPEF,IFILEF,2,IPOSSC) IF(IMERR1.GT.0) THEN ILINE=LNCNTR CALL CMPRNT(IXM,LNMAP) END IF K=IFILEF(1) IX(IX(NTRANS*12-11))=K IF(K.EQ.0) THEN IMERR1=130030 ILINE=LNCNTR CALL CMPRNT(IXM,LNMAP) END IF IF(U5ECSV.EQ.1) THEN CALL FNLGTH(J) IF(J.LE.40) THEN WRITE(U6,100)K,FNWRK(1:40) ELSE WRITE(U6,101)K,FNWRK END IF END IF CALL PREAMD(K) IF(AVERSN.EQ.9004) THEN ANID=ANVRID+ANBY ELSE ANID=ANIDTT END IF ICLBLK=RCEIL(8)-ANCLBL+1 IV=RCEIL(2)-ANVTOT DO 632 J=1,ANCLBL IF(BLVSIZ(ICLBLK).GT.0) THEN DO 631 I=1,BLVSIZ(ICLBLK) IV=IV+1 MXSIZE(IV)=ICLBLK 631 CONTINUE END IF IX(SICMUL+ICLBLK-1)=BLXSIZ(ICLBLK)/BLXINC(ICLBLK) ICLBLK=ICLBLK+1 632 CONTINUE IAS=0 IASLST=0 NASVL=0 NCRVLB=NCRVL IF(ISTATE.EQ.NSTATE) THEN C ! If last statement ENDMRG=.TRUE. C ! is INCORPORATE, loop GO TO 64 C ! back to 64 to process END IF C ! this last file. 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) RETURN END C C C End of M.FOR CC C CM.FOR - routines for new syntax. These routines are generally C shared by several steps, including CREATE, REWEIGHT, and C TRANSFORM C SUBROUTINE CMPAR1(IX,IPT) C INTEGER IX(*),IPT C C IX - IX array passed to CMPAR1. IX is not referenced through C a COMMON statement because of differences between CREATE C and TRANSFORM in the COMMON block definitions of IX. C IPT - provided by KEYFND, next nonblank position in CARD, if any. C C CMPAR1 performs the initial processing in interpreting the C statements in the new syntax. It: C a) writes the initial input to unit 13, including metacommands C and other statements usually created by REFRSH, C b) writes the statements to 14 that will be parsed, C c) classifies the statements by type, and C d) performs an analysis of the nesting of IF, WHILE, and DO. C PARAMETER (MAXFMT=20) PARAMETER (MAXALT=5) PARAMETER (MAXSUB=500,MAXSBL=2000,MAXSNL=24) PARAMETER (MAXSBC=6000) PARAMETER (MSIZED=1000000) C PARAMETER (IXDIM=13) C DOUBLE PRECISION DX(MSIZED) COMMON /DBLOCK/DX 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 C INTEGER SIZED,RCEIL(13) COMMON /PBLOCK/NXPTD,LASTPD,SIZED,NXPTI,RCEIL 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 CMPFLG - set to 1 during initial reading of statements. C It is set to 1 in this routine and returned to 0 at the C end of the sequence of statements. It signals REFRSH to C consider commands COMMENT, SCRATCH#, MACROWRITE, C ERRORFILE, MACROIMPLEMENT, MACROIMPLEMENTEND, C to end the specification for the step. C IGNORE, IGNORE OFF, LONGCOMMENT, LONGCOMMENT OFF, SET, C and ECHO may be interspersed in the commands. C U5ESAV - end-of-file status for active input unit at end of C statements for the step. C 1 - active input unit was at end of file. C 0 - not at end of file. C IALTSV - to save the depth of alternative input files used for C scratch file, first by unit 14, and then by others. C TSWTCH - 1 if TRANSFORM step C 2 if CREATE step (or REWEIGHT, etc.) C NLINE - number of lines written to unit 14 C ILINE - the current line C NSTATE - number of statements C ISTATE - the current statement C U5ECSV - the status of echo when new syntax encountered. C CHARACTER*256 CARDWK,CARDSV,CARDIM COMMON /CMBLK2/CARDWK,CARDSV,CARDIM LOGICAL ALPCHK,DGTCHK,REFRSH EXTERNAL ALPCHK,DGTCHK,REFRSH CHARACTER*160 FNWRK,LSTVPL CHARACTER*128 INFRMT(MAXFMT) COMMON /IOBLK2/FNWRK,LSTVPL,INFRMT CHARACTER*80 CARDIN CHARACTER*(MAXSNL) SUBNAM(MAXSUB) CHARACTER*12 SUBCSV(MAXSBC) COMMON /CINBLK/CARDIN,SUBNAM,SUBCSV C C 202 FORMAT(' TOO MANY LEVELS, MAXIMUM=',I2) C C Use of IX array: C IX(1,*) - Beginning line of statement C IX(2,*) - Beginning character C IX(3,*) - Ending line C IX(4,*) - Ending character C IX(5,*) - Statement type: C 1 - Simple eq., single = C 2 - Parallel eq. { } = C 3 - Comment * ; C 4 - CALL subroutine C 5 - IF C 6 - ELSE IF, ELSEIF C 7 - ELSE C 8 - END IF, ENDIF C 9 - DO C 10 - END DO C 11 - DECLARE C 12 - WHILE C 13 - END WHILE C 14 - Compound equation with multiple = Note: removed C 15 - Compound set equation with multiple = Note: removed C 16 - key word statement C C IX(6,*) - IF level C = 0 if not within IF block. C C IX(7,*) - total nesting depth, considering IF, WHILE, DO C C IX(8,*) - line of beginning character following initial C keyword. C C IX(9,*) - beginning character following initial keyword. C C The beginning character following the initial keyword is C defined according to the statement type. C Beginning character after keyword C 1 - Simple eq. Initial character C 2 - Parallel eq. " C 3 - Comment * ; " C 4 - CALL Subroutine name C 5 - IF Next nonblank character C 6 - ELSE IF, ELSEIF " C 7 - ELSE " C 8 - END IF, ENDIF " C 9 - DO " C 10 - END DO " C 11 - DECLARE " C 12 - WHILE " C 13 - END WHILE " C 14 - Compound eq. Initial character C 15 - Compound set eq. " C 16 - Key word Next nonblank character after C key word C C IX(10,*)- IGROUP, grouping of key words C Note: also temporarily used for IF, ELSE IF, to location C pointers C C IX(11,*)- IKEY, key word index C Note: also temporarily used for IF, ELSE IF, to location C pointers C C IX(12,*)- Code for any associated NOTE: with statement C C IX(13,*)- Additional information associated with NOTE: e.g., number C of variables C C C Use of units: C 13 - copy of input, with indicated substitutions, INCLUDE, IGNORE, C etc., statements if any, etc. C 14 - copy of input, saved in original form to match with C diagnostics, if any. Parsing is of this file without the C additional statements included on unit 13. C C Note: 13 and 14 are used by CMPAR1, but 15 - 17 are opened here C as well. C C 15 - used by NSETP1 etc. to store the lines of a single command C 16 - used by RPOLSH as input C 17 - used by NSETP1 etc. for set equations and other tasks C CALL SCOPEN(13) CALL SCOPEN(14) CALL SCOPEN(15) CALL SCOPEN(16) CALL SCOPEN(17) C C Both 13 and 14 mirror the input. Unit 13 echoes the complete input, C including metacommands and indications of substitutions handled by C REFRSH. The only records written to 14 are commands to be parsed. C An array is set up for each step pointing from each line of 14 back C to the corresponding line in 13. The array begins at NXPTIB=NXPTI. C This space is not freed up by this routine but instead used by C subsequent routines. C C Write commands to 13 and 14. C CMPFLG=1 NLINE=0 NLINE2=1 LNCNTR=0 NXPTDS=NXPTD C ! Save NXPTD, DX used to store U5ENOW C C Note: write the last line of the primary step statement to 14 but C not to 13 C WRITE(14)CARD U5ECSV=U5ECHO U5ENOW=U5ECHO U5ECHO=0 NXPTIB=NXPTI K=0 CALL ROOMI(1) IX(NXPTIB)=1 C 2 CONTINUE IF(REFRSH(IBASE)) THEN C C Note: NLINE is updated by REFRSH for metacommands, etc. C In this loop, NLINE tracks records written to unit 13 and NLINE2 C tracks records written to 14. Later, however, NLINE tracks C records on 14. C WRITE(13)CARDIM NLINE=NLINE+1 CALL ROOMD(1) DX(NXPTD-1)=U5ENOW K=NLINE IAPOST=0 DO 1 I=1,256 IF(IAPOST.EQ.1) THEN IF(CARD(I:I).EQ.'''')IAPOST=0 ELSE IF(IAPOST.EQ.2) THEN IF(CARD(I:I).EQ.'"')IAPOST=0 ELSE IF(CARD(I:I).EQ.'''') THEN IAPOST=1 ELSE IF(CARD(I:I).EQ.'"') THEN IAPOST=2 ELSE IF(CARD(I:I).EQ.'!') THEN CALL STBLNK(CARD,I,256) END IF 1 CONTINUE CALL NBFIND(CARD,1,256,IPOS) WRITE(14)CARD NLINE2=NLINE2+1 CALL ROOMI(1) IX(NXPTI-1)=NLINE GO TO 2 ELSE C C Note: may arrive here if error in input according to REFRSH C IF(IMERR1.GT.0) THEN U5=13 CMPFLG=0 C C If IMERR2 has been set, save the value and reset IMERR2 to 0 to C use CRDPRN(0) to print the cards C J=IMERR2 IMERR2=0 WRITE(13)CARDIM NLINE=NLINE+1 REWIND(13) U5ECHO=1 DO 3 I=1,NLINE READ(13)CARDIM CALL CRDPRN(0) 3 CONTINUE IMERR2=J CALL FSTOP END IF C C Arrive here if at end of step (with no input error). C C Save end of file status on input (in block CMBLK1) C U5ESAV=U5END C C If not at end of file in input stream, save status C IF(U5END.EQ.0) THEN IF(U5ALT(MAXALT).NE.0) THEN IF(U5ALT(MAXALT).NE.U5) THEN WRITE(U6,202)MAXALT CALL FESTOP(161040) END IF END IF DO 4 I=MAXALT,1,-1 IF(U5ALT(I).NE.0) THEN U5ASTT(I)=1 U5LINE(I)=CARDIN IF(I.LT.MAXALT) THEN U5ALT(I+1)=14 END IF IALTSV=I+1 GO TO 5 END IF 4 CONTINUE 5 CONTINUE ELSE U5ASTT(1)=0 U5END=0 END IF C REWIND(UNIT=13) REWIND(UNIT=14) U5=14 C C At this point, reset CMPFLG back to 0, for normal REFRSH C processing C CMPFLG=0 END IF IF(K.LT.NLINE) THEN DO 8 I=K+1,NLINE CALL ROOMD(1) DX(NXPTD-1)=U5ENOW 8 CONTINUE END IF NXPTIE=NXPTI CALL ROOMI(NLINE) J=NXPTIE K=NXPTDS DO 7 I=1,NLINE IX(J)=DX(K)+.01 J=J+1 K=K+1 7 CONTINUE NXPTD=NXPTDS C C NLINE is now set = # lines on 14 C K=NLINE NLINE=NLINE2 NLINE2=K C C At this point, all the statements associated with step have been C written to unit 14. Identify boundaries between statements and C ensure statements can clearly delineated. NXPTIS will save C the beginning of the matrix. C NXPTIS=NXPTI NSTATE=0 ISTATE=0 READ(14)CARD C C If command(s) have been included on the same line with step C IF(IPT.GT.0) THEN CALL NBFIND(CARD(IPT:256),IPT,256,IPOS) ELSE IPOS=0 END IF IF(IPOS.GT.0) THEN ILINE=1 C C If commands begin after the primary step line. C ELSE IF(NLINE.EQ.1) THEN RETURN ELSE READ(14)CARD END IF ILINE=2 IBASE=1 C C Use NBFNDL to find next blank position. NBFNDL will keep track of C ILINE. C CALL NBFNDL(IBASE,IPOS) IF(IPOS.LE.0) THEN C C RETURN here because no characters follow the statement initiating the C step. C RETURN END IF END IF C C An initial character of a statement has been identified at IPOS. C 10 CONTINUE CALL RCHECK(1,NXPTI,IXDIM) NSTATE=NSTATE+1 C C Flags/variables for initial check of statement syntax C C IPAREN - depth of parentheses ( [ C IAPOST - 0 not inside parentheses (normal status) C 1 inside character string bound by ' ' C IEQ - number of = encountered. C ISET - nesting of set notation { } C IVEC - 0 not part of constant vector < > (normal status) C 1 inside vector - nesting is not allowed C IPAREN=0 IAPOST=0 IEQ=0 ISET=0 IVECT=0 C IX(NXPTI)=ILINE IX(NXPTI+1)=IPOS IX(NXPTI+2)=0 IX(NXPTI+3)=0 IX(NXPTI+11)=0 IX(NXPTI+12)=0 C C Immediate recognition of COMMENT in form "* ;" C Immediate recognition of "{ }=" C IF(CARD(IPOS:IPOS).EQ.'*') THEN ISTYPE=3 IPOS=IPOS+1 ELSE IF(CARD(IPOS:IPOS).EQ.'{') THEN ISTYPE=2 IPOS=IPOS+1 ISET=1 C C Otherwise, check for key words. Encode ISTYLE as negative C initially to indicate potential keyword form, prior to C confirmation. Exceptions are 6 for ELSEIF and 8 for ENDIF C ELSE IF(ALPCHK(CARD(IPOS:IPOS))) THEN CALL KYCHK2(IPOS,IGROUP,IKEY,IPOS2) ISTYPE=0 IF(IKEY.GT.0) THEN IF(IGROUP.EQ.1) THEN IF(IKEY.EQ.18) THEN C C END C ISTYPE=-8 ELSE IF(IKEY.EQ.15) THEN C C IF C ISTYPE=-5 ELSE IF(IKEY.EQ.16) THEN C C ELSE C ISTYPE=-6 ELSE IF(IKEY.EQ.17) THEN C C ELSEIF C ISTYPE=6 ELSE IF(IKEY.EQ.19) THEN C C END IF C ISTYPE=8 ELSE C C Other key words C ISTYPE=-16 END IF C ELSE IF(IGROUP.EQ.2.OR.IGROUP.EQ.7.OR. . (TSWTCH.EQ.3.AND.IGROUP.EQ.8))THEN C ! Recognize MERGE ISTYPE=-16 END IF IF(ISTYPE.EQ.-16) THEN IX(NXPTI+9)=IGROUP IX(NXPTI+10)=IKEY END IF C ELSE CALL CMATCH(CARD(IPOS:256),IPOS,256,'CALL',4,IPOS2,1) IF(IPOS2.GT.0) THEN ISTYPE=-4 ELSE CALL CMATCH(CARD(IPOS:256),IPOS,256,'DO',2,IPOS2,1) IF(IPOS2.GT.0) THEN ISTYPE=-9 ELSE CALL CMATCH(CARD(IPOS:256),IPOS,256,'DECLARE',7,IPOS2,1) IF(IPOS2.GT.0) THEN ISTYPE=-11 ELSE CALL CMATCH(CARD(IPOS:256),IPOS,256,'WHILE',5,IPOS2,1) IF(IPOS2.GT.0) THEN ISTYPE=-12 END IF END IF END IF END IF IX(NXPTI+9)=0 IX(NXPTI+10)=0 END IF C C If initial key word, check consistency C IF(ISTYPE.NE.0) THEN IPOS=IPOS2 K=ILINE CALL NBFNDL(IPOS,IPOS2) IF(IPOS.EQ.1.AND.IAPOST.EQ.1) THEN ILINE=K IMERR1=161020 CALL CMPRNT(IX(NXPTIS),IX(NXPTIB)) END IF IF(IPOS2.EQ.0) THEN IMERR1=161001