C C *********************************************************************** C C DW-NOMINATE.FOR—-DYNAMIC-WEIGHTED NOMINATE – THIS PROGRAM IMPLEMENTS C THE ROLL CALL AND LEGISLATOR PHASES FOR THE SENATE C C 1 OCTOBER 2004
C
C *********************************************************************** C
dimension ISTATE(54001),IDIST(54001),IPARTY(54001), C ID1(54001),LVOTE(3600),YY(150000), C CUMNML(150000),ZDF(150000,4),WDERV(99), C XBETA(5,5),OUTX0(99,99),DERVISH(99,99), C OUTX1(99,99),OUTX2(99,99),OUTX3(99,99), C OLDZ(99),OLDD(99),DDERVX(99),ZDERVX(99), C XMAT(1001,25),ZVEC(2901,25),WS(5802), C MCUTS(2901,2),LERROR(1001,2901), C LDATA(1001,2901),LL(2901),YSS(2901), C KA(2901),KPTY1(200),KPTY2(200), C XVAR(99999,10) LOGICAL*1 RCVOTE1,RCVOTE9,RCVOTET1,RCVOTET9,RCBAD,LWHERE COMMON /XXCOM/ ZMID(99001,2),XDATA(54001,9),DYN(99001,2), C RCVOTE1(54001,2901),RCVOTE9(54001,2901), C RCVOTET1(99001,660),RCVOTET9(99001,660), C RCBAD(99001),LWHERE(99999,111), C NUMCONG(200),MCONG(200,3),ICONG(99001), C INUM(99001),WEIGHT(99),NUMCONGT(200), C NCONG(54001),KWHERE(99999,111), C XBIGLOG(54001,2),KBIGLOG(54001,4) COMMON /MINE/ NS,NQTOT,NPTOT,KLASS, C KLASSYY,KLASSNY,KLASSYN,KLASSNN character*1 LNAME(54001,11),KSTA(54001,7), C MNAME(54001,20),LSTA(20) CHARACTER*64 FNAME1,FNAME2,FNAME3,FNAME4,FNAME5,FNAME6,FNAME7, C FTITLE INTEGER*2 ITIM1,ITIM2,ITIM3,ITIM4,JTIM1,JTIM2,JTIM3,JTIM4
C C
OPEN(4,FILE='DW-NOMSTART.DAT',STATUS='OLD') OPEN(21,FILE='DWNOM21.DAT') OPEN(26,FILE='DWNOM26.DAT') OPEN(28,FILE='DWNOM28.DAT') OPEN(29,FILE='DWNOM29.DAT') OPEN(40,FILE='DWNOM40.DAT')
C C READ ROLL CALL COORDINATE FILE – INPUT C
READ(4,102)FNAME1 WRITE(21,102)FNAME1 WRITE(*,102)FNAME1 OPEN(1,FILE=FNAME1,STATUS='OLD')
C C READ ROLL CALL COORDINATE FILE – OUTPUT C
READ(4,102)FNAME2 WRITE(21,102)FNAME2 WRITE(*,102)FNAME2 OPEN(30,FILE=FNAME2)
C C READ LEGISLATOR COORDINATE FILE – INPUT C
READ(4,102)FNAME3 WRITE(21,102)FNAME3 WRITE(*,102)FNAME3 OPEN(20,FILE=FNAME3,STATUS='OLD')
C C READ LEGISLATOR COORDINATE FILE – OUTPUT C
READ(4,102)FNAME4 WRITE(21,102)FNAME4 WRITE(*,102)FNAME4 OPEN(24,FILE=FNAME4)
C C READ ROLL CALL NUMBERS FILE – *.NUM C
READ(4,102)FNAME5 WRITE(21,102)FNAME5 WRITE(*,102)FNAME5 OPEN(22,FILE=FNAME5,STATUS='OLD')
C C READ ROLL CALL VOTE FILE C
READ(4,102)FNAME6 WRITE(21,102)FNAME6 WRITE(*,102)FNAME6 OPEN(23,FILE=FNAME6,STATUS='OLD')
C C READ TRANSPOSED ROLL CALL VOTE FILE C
READ(4,102)FNAME7 WRITE(21,102)FNAME7 WRITE(*,102)FNAME7 OPEN(25,FILE=FNAME7,STATUS='OLD')
C
100 FORMAT(2X,I3,2I2,I4,I5,2I1,11A1,3600I1)
C
101 format(I3,1x,i5,1x,i5,1x,i2,1x,i2,1x,7a1,1x,i4,1x,i1,1x,i1,1x, c 11a1,4f7.3) 102 FORMAT(A64) 103 FORMAT(10I5) 104 FORMAT(15F8.4) 150 FORMAT(6X,I5,41X,2F7.3) 175 FORMAT(I3,I5,4F7.3) 180 FORMAT(I3,1X,2I4) 190 FORMAT(I4,I6,I3,I4,1X,11A1,2F7.3) 200 FORMAT(I4,I6,I3,I2,1X,7A1,1X,I4,1X,11A1,3600I1) 201 FORMAT(I4,I6,I3,I2,1X,7A1,1X,I4,1X,11A1,2F7.3,I5) 202 FORMAT(I9,4F15.3) 203 FORMAT(I4,I5,4I4,2I2,30F7.3) 210 FORMAT(I3,I8,I6,I3,I2,1X,7A1,1X,I4,1X,11A1,40F7.3) 211 FORMAT(I4,I6,I3,I2,1X,7A1,1X,I4,1X,11A1,6F7.3,2F12.5,4I5,2F7.3) 212 FORMAT(I4,I6,I3,I2,1X,7A1,1X,I4,1X,11A1,F7.3,2F12.5,4I5,2F7.3) 213 FORMAT(54X,40F7.3) 214 FORMAT(10X,10F10.6) 240 FORMAT(I4,I5,1X,600I1) 250 FORMAT(I4,I5,15I4) 251 FORMAT(I4,I5,3I4,5F7.3/17X,I4,5F7.3) 252 FORMAT(17X,5I4,5F7.3) 253 FORMAT(I4,I5,7I4,5F7.3) 300 FORMAT(' TOTAL ROLL CALLS 01-108 ',3I7) 301 FORMAT(' TOTAL LEGISLATORS 01-108',3I7) 302 FORMAT(' NUMBER OF CONGRESSES',I6) 303 FORMAT(4I4,6F7.3) 304 FORMAT(' FATAL MISMATCH',I4,4I6) 305 FORMAT(' MISMATCH ON ROLL CALL NUMBERS',3I5) 306 FORMAT(' MISMATCH ON MISSING DATA',3I5) 307 FORMAT(' MISMATCH ON NON-MISSING DATA',3I5) 308 FORMAT(' UNIQUE LEGISLATORS',4I6,I9/19X,4F15.3) 312 FORMAT(I4,I5,5I4,4F7.3) 313 FORMAT(' NUMBER RCs & CLASSIFICATION',6I9/ C 30X,2F8.4) 314 FORMAT(' NUMBER READ ROLL CALL FILE',3I6) 315 FORMAT(' NUMBER RECORDS WRITTEN',4I8) 316 FORMAT(' FATAL MISMATCH ON LEGISLATORS',3I7) 317 FORMAT(' MISMATCH ON STATE CODES',3I7) 318 FORMAT(' MISMATCH ON CONGRESSIONAL DISTRICT CODES',3I7) 319 FORMAT(' MISMATCH ON PARTY CODES',3I7) 1000 format(22x,4(i2.2,'.')) 1001 format(' ELAPSED TIME OF JOB ',4(i2.2,'.'))
C C C READ TITLE OF RUN C
READ(4,102)FTITLE WRITE(21,102)FTITLE WRITE(*,102)FTITLE READ(4,103)NS,NMODEL,NFIRST,NLAST,IHAPPY1,IHAPPY2 WRITE(21,103)NS,NMODEL,NFIRST,NLAST,IHAPPY1,IHAPPY2 WRITE(*,103)NS,NMODEL,NFIRST,NLAST,IHAPPY1,IHAPPY2 READ(4,104)WEIGHT(NS+1),(WEIGHT(K),K=2,NS) WRITE(21,104)WEIGHT(NS+1),(WEIGHT(K),K=2,NS) WRITE(*,104)WEIGHT(NS+1),(WEIGHT(K),K=2,NS)
C C NS=2 C NMODEL=0 C NFIRST=1 C NLAST=57 C C DIMENSION WEIGHTS C
WEIGHT(1)=1.000
C WEIGHT(2)=1.000 C WEIGHT(2)=.50 C C SIGMA-SQUARED (BETA) C
C WEIGHT(NS+1)=4.925 C
DO 46 J=1,111 DO 47 I=1,99999 LWHERE(I,J)=.FALSE. 47 CONTINUE 46 CONTINUE
C C DEFINE TWO-PARTY SYSTEM C
DO 8810 I=1,200 KPTY1(I)=0 KPTY2(I)=0 8810 CONTINUE
C C FEDERALIST-JEFFERSONIAN REPUBLICAN 1789-1812 C C (13 - 17 ADDED FOR NICOLE MELLOW) C C 4000 = ANTI-ADMINISTRATION (LATER JEFFERSONIAN REPUBLICAN) C 5000 = PRO-ADMINISTRATION (LATER FEDERALIST) C
DO 8811 I=1,3 KPTY1(I)=4000 KPTY2(I)=5000 8811 CONTINUE
C
C 200 = JEFFERSONIAN REPUBLICAN C 1 = FEDERALIST C
DO 8812 I=4,17 KPTY1(I)=200 KPTY2(I)=1 8812 CONTINUE
C C WHIG-DEMOCRAT PARTY SYSTEM 1827-1848 C C (19 ADDED FOR NICOLE MELLOW) C C 555 = JACKSON C 22 = ADAMS C
KPTY1(19)=555 KPTY2(19)=22 KPTY1(20)=555 KPTY2(20)=22
C C 555 = JACKSON C 1275 = ANTI-JACKSON C
DO 13 I=21,24 KPTY1(I)=555 KPTY2(I)=1275 13 CONTINUE
C C 100 = DEMOCRAT C 29 = WHIG
C
DO 14 I=25,30 KPTY1(I)=100 KPTY2(I)=29 14 CONTINUE
C C REPUBLICAN-DEMOCRAT PARTY SYSTEM 1857-1998 C C 100 = DEMOCRAT C 200 = REPUBLICAN
C
DO 15 I=35,NLAST KPTY1(I)=100 KPTY2(I)=200 15 CONTINUE
C C C READ IN CUMULATIVE NORMAL DISTRIBUTION FUNCTION C C
ndevit=50001 XDEVIT=10000.0
C
DO 501 I=1,NDEVIT YY(I)=FLOAT(I-1)/XDEVIT X=(FLOAT(I-1)/XDEVIT)/SQRT(2.0) XX=ERF(X) XX=XX/2.0 +.5 CUMNML(I)=XX 501 CONTINUE
C
TWOPI=1.0/SQRT(2.0*3.1415926536) DO 901 I=1,NDEVIT ZDF(I,1)=YY(NDEVIT+1-I)*(-1.0) ZDF(I,2)=1.0-CUMNML(NDEVIT+1-I) ZDF(I,3)=ALOG(ZDF(I,2)) 901 CONTINUE DO 902 I=2,NDEVIT ZDF(I-1+NDEVIT,1)=YY(I) ZDF(I-1+NDEVIT,2)=CUMNML(I) ZDF(I-1+NDEVIT,3)=ALOG(ZDF(I-1+NDEVIT,2)) 902 CONTINUE DO 903 I=1,2*NDEVIT-1 ZDF(I,4)=(TWOPI*EXP((-ZDF(I,1)**2)/2.0))/ZDF(I,2)
C WRITE(33,202)I,(ZDF(I,J),J=1,4)
903 CONTINUE
C
DO 10 I=1,200 NUMCONG(I)=0 NUMCONGT(I)=0 10 CONTINUE
C C READ NHOUSE.NUM – GIVES NUMBER OF ROLL CALLS AND LEGISLATORS FOR C EACH CONGRESS
I=0 525 READ(22,180,END=425)(MCONG(I+1,J),J=1,3) I=I+1 GO TO 525 425 WRITE(*,302)I WRITE(21,302)I
C C READ ROLL CALL STARTS – HC01108.DAT C
I=0 575 READ(1,175,END=475)ICONG(I+1),INUM(I+1),DYN(I+1,1), C ZMID(I+1,1),DYN(I+1,2),ZMID(I+1,2) NP=MCONG(ICONG(I+1),3) READ(25,240,END=475)JJJJ,J,(LVOTE(JJ),JJ=1,NP) I=I+1 KYES=0 KNO=0 DO 11 JJ=1,NP RCVOTET1(I,JJ)=.FALSE. RCVOTET9(I,JJ)=.FALSE. IF(LVOTE(JJ).GE.1.AND.LVOTE(JJ).LE.3)THEN RCVOTET1(I,JJ)=.TRUE. KYES=KYES+1 ENDIF IF(LVOTE(JJ).EQ.0.OR.LVOTE(JJ).GT.6)THEN RCVOTET9(I,JJ)=.TRUE. ENDIF IF(LVOTE(JJ).GE.4.AND.LVOTE(JJ).LE.6)THEN KNO=KNO+1 ENDIF 11 CONTINUE RCBAD(I)=.FALSE. KRCTOT=KYES+KNO KRCMIN=MIN0(KYES,KNO) XMARG=0.0 IF(KRCTOT.GT.0)THEN XMARG=FLOAT(KRCMIN)/FLOAT(KRCTOT) IF(XMARG.GE..025)THEN RCBAD(I)=.TRUE. ENDIF ENDIF NUMCONGT(ICONG(I))=NUMCONGT(ICONG(I))+1 GO TO 575 475 WRITE(*,300)I WRITE(21,300)I NQTOT=I
C C READ PSEUDO-DYNAMIC STARTS FROM BLACK BOX – HL01108.SRT C
I=0 550 READ(20,201,END=450)NCONG(I+1),ID1(I+1),ISTATE(I+1),IDIST(I+1), C (KSTA(I+1,JJ),JJ=1,7),IPARTY(I+1), C (LNAME(I+1,JJ),JJ=1,11),(XDATA(I+1,JJ),JJ=1,2)
C C (LNAME(I+1,JJ),JJ=1,11),(XDATA(I+1,JJ),JJ=1,2),KHIT C C USE KHIT SWITCH ONLY ON VERY FIRST RUN WITH BRAND-NEW STARTING C COORDINATES C C IF(KHIT.LT.25)GO TO 550
NQ=MCONG(NCONG(I+1),2) READ(23,200,END=450)JJJJ,JD1,JSTATE,JDIST, C (LSTA(JJ),JJ=1,7),JPARTY, C (MNAME(I+1,JJ),JJ=1,11),(LVOTE(JJ),JJ=1,NQ) I=I+1
C C ERROR CHECKS C C – ID NUMBER C
IF(ID1(I).NE.JD1)THEN WRITE(*,316)I,ID1(I),JD1 STOP ENDIF
C C – STATE CODE C
IF(ISTATE(I).NE.JSTATE)THEN WRITE(*,317)I,ID1(I),JD1 STOP ENDIF
C C – CONGRESSIONAL DISTRICT C
IF(IDIST(I).NE.JDIST)THEN WRITE(*,318)I,ID1(I),JD1 STOP ENDIF
C C – PARTY CODE C
IF(IPARTY(I).NE.JPARTY)THEN WRITE(*,319)I,ID1(I),JD1 STOP ENDIF
C
LWHERE(ID1(I),NCONG(I))=.TRUE. KWHERE(ID1(I),NCONG(I))=I DO 1 JJ=1,NQ RCVOTE1(I,JJ)=.FALSE. RCVOTE9(I,JJ)=.FALSE. IF(LVOTE(JJ).GE.1.AND.LVOTE(JJ).LE.3)THEN RCVOTE1(I,JJ)=.TRUE. ENDIF IF(LVOTE(JJ).EQ.0.OR.LVOTE(JJ).GT.6)THEN RCVOTE9(I,JJ)=.TRUE. ENDIF 1 CONTINUE NUMCONG(NCONG(I))=NUMCONG(NCONG(I))+1 GO TO 550 450 WRITE(*,301)I WRITE(21,301)I NPTOT=I
C
DO 9999 IHAPPY=IHAPPY1,IHAPPY2
C C ************************************ C DIMENSION WEIGHT PHASE C ************************************
IF(NS.GE.2)THEN CALL WINT(XPLOG,WDERV,NFIRST,NLAST,ZDF,NDEVIT,XDEVIT) WRITE(21,214)(WEIGHT(K),K=1,NS+1) ENDIF
C C ************************************ C BETA (1/SIGMA) PHASE C ************************************
CALL SIGMAS(XPLOG,WDERV,NFIRST,NLAST,ZDF,NDEVIT,XDEVIT) WRITE(21,214)(WEIGHT(K),K=1,NS+1)
C C ************************************ C ROLL CALL PHASE C ************************************ C
C
KTOTP=0 KTOTQ=0 KK=0 LASSB4=0 LASSAF=0 LATOT=0 LPRE=0 LSCALE=0 IF(NFIRST.GT.1)THEN DO 1111 II=1,NFIRST-1 NPC=NUMCONG(II) NQC=NUMCONGT(II) KTOTP=KTOTP+NPC KTOTQ=KTOTQ+NQC 1111 CONTINUE ENDIF DO 2 II=NFIRST,NLAST IICONG=II NPC=NUMCONG(II) NQC=NUMCONGT(II) NQ=MCONG(II,2) IF(NQ.NE.NQC)THEN WRITE(*,305)II,NQ,NQC STOP ENDIF DO 3 J=1,NQ NEQ=J KYES=0 KYESD=0 KYESND=0 KYESSD=0 KYESR=0 KYESNR=0 KYESSR=0 KNO=0 KNOD=0 KNOSD=0 KNOND=0 KNOR=0 KNOSR=0 KNONR=0 KMISS=0 DO 4 I=1,NPC LL(I)=I LDATA(I,1)=0 YSS(I)=XMAT(I,1) DO 4444 K=1,NS XMAT(I,K)=XDATA(I+KTOTP,K) 4444 CONTINUE ISOUTH=0 IF(ISTATE(I+KTOTP).GE.40.AND.ISTATE(I+KTOTP).LE.49)ISOUTH=1 IF(ISTATE(I+KTOTP).EQ.51.OR.ISTATE(I+KTOTP).EQ.53.OR. C ISTATE(I+KTOTP).EQ.54)ISOUTH=1 IF(RCVOTE9(I+KTOTP,J).NEQV.RCVOTET9(J+KTOTQ,I))THEN WRITE(*,306)II,J,I STOP ENDIF IF(RCVOTE1(I+KTOTP,J).NEQV.RCVOTET1(J+KTOTQ,I))THEN WRITE(*,307)II,J,I STOP ENDIF IF(RCVOTE9(I+KTOTP,J).EQV..TRUE.)KMISS=KMISS+1
C C IF NOT MISSING DATA C
IF(RCVOTE9(I+KTOTP,J).EQV..FALSE.)THEN
C C IF YES C
IF(RCVOTE1(I+KTOTP,J).EQV..TRUE.)THEN KYES=KYES+1 LDATA(I,1)=1 IF(IPARTY(I+KTOTP).EQ.KPTY1(II))THEN KYESD=KYESD+1 IF(ISOUTH.EQ.0)THEN KYESND=KYESND+1 ENDIF IF(ISOUTH.EQ.1)THEN KYESSD=KYESSD+1 ENDIF ENDIF IF(IPARTY(I+KTOTP).EQ.KPTY2(II))THEN KYESR=KYESR+1 IF(ISOUTH.EQ.0)THEN KYESNR=KYESNR+1 ENDIF IF(ISOUTH.EQ.1)THEN KYESSR=KYESSR+1 ENDIF ENDIF ENDIF
C C IF NO C
IF(RCVOTE1(I+KTOTP,J).EQV..FALSE.)THEN KNO=KNO+1 LDATA(I,1)=6 IF(IPARTY(I+KTOTP).EQ.KPTY1(II))THEN KNOD=KNOD+1 IF(ISOUTH.EQ.0)THEN KNOND=KNOND+1 ENDIF IF(ISOUTH.EQ.1)THEN KNOSD=KNOSD+1 ENDIF ENDIF IF(IPARTY(I+KTOTP).EQ.KPTY2(II))THEN KNOR=KNOR+1 IF(ISOUTH.EQ.0)THEN KNONR=KNONR+1 ENDIF IF(ISOUTH.EQ.1)THEN KNOSR=KNOSR+1 ENDIF ENDIF ENDIF ENDIF 4 CONTINUE CALL RSORT(YSS,NPC,LL) DO 44 I=1,NPC KA(I)=LDATA(LL(I),1) 44 CONTINUE KK=KK+1
C RCBAD(KK)=.FALSE.
KRCTOT=KYES+KNO KRCMIN=MIN0(KYES,KNO) IF(KRCTOT.GT.0)THEN XMARG=FLOAT(KRCMIN)/FLOAT(KRCTOT) IF(XMARG.LT..025)THEN DO 625 K=1,NS ZMID(NEQ+KTOTQ,K)=0.0 DYN(NEQ+KTOTQ,K)=0.0 625 CONTINUE ENDIF IF(XMARG.GE..025)THEN
C RCBAD(KK)=.TRUE.
LPRE=LPRE+KRCMIN LSCALE=LSCALE+1
C C DO CHECK ON MIDPOINT TO MAKE SURE ITS WITHIN THE UNIT HYPERSPHERE C
SUM=0.0 DO 23 K=1,NS SUM=SUM+ZMID(NEQ+KTOTQ,K)**2 23 CONTINUE IF(SUM.GT.1.0)THEN DO 24 K=1,NS ZMID(NEQ+KTOTQ,K)=ZMID(NEQ+KTOTQ,K)/SQRT(SUM) 24 CONTINUE ENDIF DO 21 K=1,NS IF(ABS(OLDD(K)).GT.2.0)THEN OLDD(K)=(OLDD(K))/ABS(OLDD(K)) ENDIF OLDZ(K+NS)=ZMID(NEQ+KTOTQ,K) OLDD(K+NS)=DYN(NEQ+KTOTQ,K) OLDZ(K)=ZMID(NEQ+KTOTQ,K) OLDD(K)=DYN(NEQ+KTOTQ,K) 21 CONTINUE
C C GET INITIAL CLASSIFICATION AND LOG-LIKELIHOOD C C
IF(NS.EQ.1)THEN IVOT=1 KCCUT=1 LCCUT=6 CALL JAN11PT(NPC,IVOT,YSS,KA,WS,JCH,JEH,JCL,JEL,KCCUT, C LCCUT)
C
XPCT1=(FLOAT(JCH+JCL)/FLOAT(JCH+JEH+JCL+JEL))*100.0
C WRITE(*,312)IICONG,NEQ,NPC,JCH,JEH,JEL,JCL,WS(1),XPCT1
WRITE(40,312)IICONG,NEQ,NPC,JCH,JEH,JEL,JCL,WS(1),XPCT1
C
IVOT=2 KCCUT=6 LCCUT=1 CALL JAN11PT(NPC,IVOT,YSS,KA,WS,JCH,JEH,JCL,JEL,KCCUT, C LCCUT)
C
XPCT2=(FLOAT(JCH+JCL)/FLOAT(JCH+JEH+JCL+JEL))*100.0
C WRITE(*,312)IICONG,NEQ,NPC,JCH,JEH,JEL,JCL,WS(2),XPCT2
WRITE(40,312)IICONG,NEQ,NPC,JCH,JEH,JEL,JCL,WS(2),XPCT2 IF(XPCT1.GE.XPCT2)THEN MCUTS(1,1)=1 MCUTS(1,2)=6 IF(IHAPPY.EQ.1)THEN OLDD(1)=.5 IF(ABS(WS(1)).GT.1.0)THEN AA=ABS(WS(1)) WS(1)=WS(1)/AA ENDIF OLDZ(1)=WS(1) ENDIF ENDIF IF(XPCT1.LT.XPCT2)THEN MCUTS(1,1)=6 MCUTS(1,2)=1 IF(IHAPPY.EQ.1)THEN OLDD(1)=-.5 IF(ABS(WS(2)).GT.1.0)THEN AA=ABS(WS(2)) WS(2)=WS(2)/AA ENDIF OLDZ(1)=WS(2) ENDIF ENDIF ENDIF
C C CALL CUTTING PLANE ROUTINE TO GET PROPER POLARITIES FOR C STARTS IN TWO OR MORE DIMENSIONS C
IF(NS.GT.1)THEN IFIXX=1 NRCALL=1 ZVEC(1,1)=1.0 DO 4445 K=2,NS ZVEC(1,K)=0.0 4445 CONTINUE CALL CUTPLANE(NEQ,NPC,NRCALL,NS,XMAT,ZVEC,WS, C MCUTS,LERROR,IFIXX,KTT,KT,LDATA) WRITE(40,203)IICONG,NEQ,KYES,KNO,KTT,KT, C MCUTS(1,1),MCUTS(1,2), C (ZVEC(1,J2001),J2001=1,NS),WS(1), C WS(2),WS(3)
C C GET MIDPOINT AND SPREADS FROM CUTPLANE IF FIRST GLOBAL ITERATION C
IF(IHAPPY.EQ.1)THEN IF(ZVEC(1,1).LT.0.0)THEN DO 4447 K=1,NS ZVEC(1,K)=-ZVEC(1,K) 4447 CONTINUE WS(1)=-WS(1) KCUTTT=MCUTS(1,1) MCUTS(1,1)=MCUTS(1,2) MCUTS(1,2)=KCUTTT ENDIF SUM=0.0 DO 4446 K=1,NS OLDZ(K)=WS(1)*ZVEC(1,K) SUM=SUM+OLDZ(K)**2 IF(MCUTS(1,1).EQ.1)THEN OLDD(K)= .5*ZVEC(1,K) ENDIF IF(MCUTS(1,2).EQ.1)THEN OLDD(K)=-.5*ZVEC(1,K) ENDIF 4446 CONTINUE IF(SUM.GT.1.0)THEN DO 4448 K=1,NS OLDZ(K)=OLDZ(K)/SQRT(SUM) 4448 CONTINUE ENDIF ENDIF
C WRITE(40,203)IICONG,NEQ,KYES,KNO,KTT,KT, C C MCUTS(1,1),MCUTS(1,2), C C (ZVEC(1,J2001),J2001=1,NS),WS(1), C C (OLDD(K),K=1,NS),(OLDZ(K),K=1,NS)
ENDIF
C C GET INITIAL LOG-LIKELIHOOD C
CALL PROLLC2(IICONG,NEQ,NPC,KRC,KTOTP,KTOTQ, C XPLOG,OLDZ,OLDD,DDERVX,ZDERVX, C ZDF,NDEVIT,XDEVIT) GMPB4=EXP(XPLOG/FLOAT(KRC))
C
KLASSOLD=KLASS KLASSOYY=KLASSYY KLASSONY=KLASSNY KLASSOYN=KLASSYN KLASSONN=KLASSNN WRITE(28,253)II,J,KYES,KNO,KLASSOLD, C KLASSOYY,KLASSOYN,KLASSONY,KLASSONN, C GMPB4,(OLDD(K),OLDZ(K),K=1,NS) CALL RCINT2(IICONG,NEQ,NPC,NQC,KRC,KTOTP,KTOTQ, C XPLOG,OLDZ,OLDD, C ZDF,NDEVIT,XDEVIT) GMPAF=EXP(XPLOG/FLOAT(KRC)) DO 22 K=1,NS ZMID(NEQ+KTOTQ,K)=OLDZ(K) DYN(NEQ+KTOTQ,K)=OLDD(K) 22 CONTINUE
C
WRITE(28,252)KLASS,KLASSYY,KLASSYN,KLASSNY,KLASSNN, C GMPAF, C (DYN(NEQ+KTOTQ,K),ZMID(NEQ+KTOTQ,K),K=1,NS) LASSB4=LASSB4+KLASSOLD LASSAF=LASSAF+KLASS LATOT=LATOT+KYES+KNO ENDIF ENDIF WRITE(29,250)II,J,KMISS,KYES,KNO,KYESR,KNOR, C KYESD,KNOD, C KYESNR,KNONR,KYESSR,KNOSR, C KYESND,KNOND,KYESSD,KNOSD 3 CONTINUE KTOTP=KTOTP+NPC KTOTQ=KTOTQ+NQC 2 CONTINUE YCLASS=FLOAT(LASSAF)/FLOAT(LATOT) YPRE=FLOAT(LPRE-LATOT+LASSAF)/FLOAT(LPRE) WRITE(*,313)KK,LSCALE,LATOT,LASSB4,LASSAF,LPRE,YCLASS,YPRE WRITE(21,313)KK,LSCALE,LATOT,LASSB4,LASSAF,LPRE,YCLASS,YPRE DO 41 I=1,NQTOT WRITE(30,175)ICONG(I),INUM(I), C (DYN(I,K),ZMID(I,K),K=1,NS) 41 CONTINUE
C C
CALL PLOG(XPLOG,WDERV,NFIRST,NLAST, C ZDF,NDEVIT,XDEVIT)
C C C ****************************************** C LEGISLATOR PHASE C ******************************************
NPUNIQUE=0 NPUNIQUF=0 NPUNIQUG=0 NPUNIQUH=0 NXTOT=0 XTOTLOG0=0.0 XTOTLOG1=0.0 XTOTLOG2=0.0 XTOTLOG3=0.0 DO 48 I=1,99999 NEP=I KK=0 KLOCATE=0 DO 49 J=NFIRST,NLAST IF(LWHERE(I,J).EQV..TRUE.)THEN KK=KK+1 KLOCATE=KWHERE(I,J) ENDIF 49 CONTINUE IF(KK.EQ.0)GO TO 48 NPUNIQUE=NPUNIQUE+1 IF(KK.GE.5)NPUNIQUF=NPUNIQUF+1 IF(KK.GE.6)NPUNIQUG=NPUNIQUG+1 IF(KK.GE.7)NPUNIQUH=NPUNIQUH+1 CALL XINT(NEP,ID1,LNAME,XPLOG0,XPLOG1,XPLOG2,XPLOG3, C NFIRST,NLAST,NMODEL, C ZDF,NDEVIT,XDEVIT,KXTOT,XBETA, C OUTX0,OUTX1,OUTX2,OUTX3,DERVISH) NXTOT=NXTOT+KXTOT XTOTLOG0=XTOTLOG0+XPLOG0 XTOTLOG1=XTOTLOG1+XPLOG1 XTOTLOG2=XTOTLOG2+XPLOG2 XTOTLOG3=XTOTLOG3+XPLOG3
C C WRITE(26,210)KK,KXTOT,I,ISTATE(KLOCATE),NMODEL, C C (KSTA(KLOCATE,JJ),JJ=1,7),IPARTY(KLOCATE), C C (MNAME(KLOCATE,JJ),JJ=1,11),(XBETA(1,JJ),JJ=1,NS), C C (XBETA(2,JJ),JJ=1,NS),(XBETA(3,JJ),JJ=1,NS), C C (XBETA(4,JJ),JJ=1,NS), C C EXP(XPLOG0/FLOAT(KXTOT)),EXP(XPLOG1/FLOAT(KXTOT)), C C EXP(XPLOG2/FLOAT(KXTOT)),EXP(XPLOG3/FLOAT(KXTOT))
IF(NMODEL.EQ.0)THEN WRITE(26,210)KK,KXTOT,I,ISTATE(KLOCATE),NMODEL, C (KSTA(KLOCATE,JJ),JJ=1,7),IPARTY(KLOCATE), C (MNAME(KLOCATE,JJ),JJ=1,11), C EXP(XPLOG0/FLOAT(KXTOT)), C (XBETA(1,JJ),JJ=1,NS) WRITE(26,213)(SQRT(OUTX0(JJ,JJ)),JJ=1,NS)
C C OUTPUT ENTIRE MATRIX C
WRITE(26,213)((OUTX0(JJ,JIJ),JIJ=1,NS),JJ=1,NS)
C C STORE NEEDED VARIANCES AND COVARIANCES C
XVAR(I,1)=OUTX0(1,1) XVAR(I,2)=0.0 XVAR(I,3)=0.0 XVAR(I,4)=OUTX0(2,2) XVAR(I,5)=0.0 XVAR(I,6)=0.0 ENDIF IF(NMODEL.EQ.1)THEN IF(KK.LT.5)THEN WRITE(26,210)KK,KXTOT,I,ISTATE(KLOCATE),NMODEL, C (KSTA(KLOCATE,JJ),JJ=1,7),IPARTY(KLOCATE), C (MNAME(KLOCATE,JJ),JJ=1,11), C EXP(XPLOG0/FLOAT(KXTOT)), C (XBETA(1,JJ),JJ=1,NS) WRITE(26,213)(SQRT(OUTX0(JJ,JJ)),JJ=1,NS)
C C STORE NEEDED VARIANCES AND COVARIANCES C
XVAR(I,1)=OUTX0(1,1) XVAR(I,2)=0.0 XVAR(I,3)=0.0 XVAR(I,4)=OUTX0(2,2) XVAR(I,5)=0.0 XVAR(I,6)=0.0
C C OUTPUT ENTIRE MATRIX C
WRITE(26,213)((OUTX0(JJ,JIJ),JIJ=1,NS),JJ=1,NS) ENDIF IF(KK.GE.5)THEN WRITE(26,210)KK,KXTOT,I,ISTATE(KLOCATE),NMODEL, C (KSTA(KLOCATE,JJ),JJ=1,7),IPARTY(KLOCATE), C (MNAME(KLOCATE,JJ),JJ=1,11), C EXP(XPLOG1/FLOAT(KXTOT)), C (XBETA(1,JJ),JJ=1,NS),(XBETA(2,JJ),JJ=1,NS) WRITE(26,213)(SQRT(OUTX1(JJ,JJ)),JJ=1,2*NS)
C C OUTPUT ENTIRE MATRIX C
WRITE(26,213)((OUTX1(JJ,JIJ),JIJ=1,2*NS),JJ=1,2*NS)
C C STORE NEEDED VARIANCES AND COVARIANCES C
XVAR(I,1)=OUTX1(1,1) XVAR(I,2)=OUTX1(3,3) XVAR(I,3)=OUTX1(1,3) XVAR(I,4)=OUTX1(2,2) XVAR(I,5)=OUTX1(4,4) XVAR(I,6)=OUTX1(2,4) ENDIF ENDIF IF(NMODEL.EQ.2)THEN IF(KK.LT.5)THEN WRITE(26,210)KK,KXTOT,I,ISTATE(KLOCATE),NMODEL, C (KSTA(KLOCATE,JJ),JJ=1,7),IPARTY(KLOCATE), C (MNAME(KLOCATE,JJ),JJ=1,11), C EXP(XPLOG0/FLOAT(KXTOT)), C (XBETA(1,JJ),JJ=1,NS) WRITE(26,213)(SQRT(OUTX0(JJ,JJ)),JJ=1,NS) ENDIF IF(KK.EQ.5)THEN WRITE(26,210)KK,KXTOT,I,ISTATE(KLOCATE),NMODEL, C (KSTA(KLOCATE,JJ),JJ=1,7),IPARTY(KLOCATE), C (MNAME(KLOCATE,JJ),JJ=1,11), C EXP(XPLOG1/FLOAT(KXTOT)), C (XBETA(1,JJ),JJ=1,NS),(XBETA(2,JJ),JJ=1,NS) WRITE(26,213)(SQRT(OUTX1(JJ,JJ)),JJ=1,2*NS) ENDIF IF(KK.GE.6)THEN WRITE(26,210)KK,KXTOT,I,ISTATE(KLOCATE),NMODEL, C (KSTA(KLOCATE,JJ),JJ=1,7),IPARTY(KLOCATE), C (MNAME(KLOCATE,JJ),JJ=1,11), C EXP(XPLOG2/FLOAT(KXTOT)), C (XBETA(1,JJ),JJ=1,NS),(XBETA(2,JJ),JJ=1,NS), C (XBETA(3,JJ),JJ=1,NS) WRITE(26,213)(SQRT(OUTX2(JJ,JJ)),JJ=1,3*NS) ENDIF ENDIF IF(NMODEL.EQ.3)THEN IF(KK.LT.5)THEN WRITE(26,210)KK,KXTOT,I,ISTATE(KLOCATE),NMODEL, C (KSTA(KLOCATE,JJ),JJ=1,7),IPARTY(KLOCATE), C (MNAME(KLOCATE,JJ),JJ=1,11), C EXP(XPLOG0/FLOAT(KXTOT)), C (XBETA(1,JJ),JJ=1,NS) WRITE(26,213)(SQRT(OUTX0(JJ,JJ)),JJ=1,NS) ENDIF IF(KK.EQ.5)THEN WRITE(26,210)KK,KXTOT,I,ISTATE(KLOCATE),NMODEL, C (KSTA(KLOCATE,JJ),JJ=1,7),IPARTY(KLOCATE), C (MNAME(KLOCATE,JJ),JJ=1,11), C EXP(XPLOG1/FLOAT(KXTOT)), C (XBETA(1,JJ),JJ=1,NS),(XBETA(2,JJ),JJ=1,NS) WRITE(26,213)(SQRT(OUTX1(JJ,JJ)),JJ=1,2*NS) ENDIF IF(KK.EQ.6)THEN WRITE(26,210)KK,KXTOT,I,ISTATE(KLOCATE),NMODEL, C (KSTA(KLOCATE,JJ),JJ=1,7),IPARTY(KLOCATE), C (MNAME(KLOCATE,JJ),JJ=1,11), C EXP(XPLOG2/FLOAT(KXTOT)), C (XBETA(1,JJ),JJ=1,NS),(XBETA(2,JJ),JJ=1,NS), C (XBETA(3,JJ),JJ=1,NS) WRITE(26,213)(SQRT(OUTX2(JJ,JJ)),JJ=1,3*NS) ENDIF IF(KK.GE.7)THEN WRITE(26,210)KK,KXTOT,I,ISTATE(KLOCATE),NMODEL, C (KSTA(KLOCATE,JJ),JJ=1,7),IPARTY(KLOCATE), C (MNAME(KLOCATE,JJ),JJ=1,11), C EXP(XPLOG3/FLOAT(KXTOT)), C (XBETA(1,JJ),JJ=1,NS),(XBETA(2,JJ),JJ=1,NS), C (XBETA(3,JJ),JJ=1,NS),(XBETA(4,JJ),JJ=1,NS) WRITE(26,213)(SQRT(OUTX3(JJ,JJ)),JJ=1,4*NS) ENDIF ENDIF 48 CONTINUE WRITE(21,308)NPUNIQUE,NPUNIQUF,NPUNIQUG,NPUNIQUH,NXTOT, C XTOTLOG0,XTOTLOG1,XTOTLOG2,XTOTLOG3 WRITE( *,308)NPUNIQUE,NPUNIQUF,NPUNIQUG,NPUNIQUH,NXTOT, C XTOTLOG0,XTOTLOG1,XTOTLOG2,XTOTLOG3
C
CALL PLOG(XPLOG,WDERV,NFIRST,NLAST, C ZDF,NDEVIT,XDEVIT)
C
SUMLOG1=0.0 SUMLOG2=0.0 DO 61 I=1,NPTOT GMPA=EXP(XBIGLOG(I,1)/FLOAT(KBIGLOG(I,1))) GMPB=EXP(XBIGLOG(I,2)/FLOAT(KBIGLOG(I,2))) SUMLOG1=SUMLOG1+XBIGLOG(I,1) SUMLOG2=SUMLOG2+XBIGLOG(I,2) IF(NS.EQ.1)THEN WRITE(24,212)NCONG(I),ID1(I),ISTATE(I),IDIST(I), C (KSTA(I,JJ),JJ=1,7),IPARTY(I), C (MNAME(I,JJ),JJ=1,11),(XDATA(I,JJ),JJ=1,1), C (XBIGLOG(I,JJ),JJ=1,2), C (KBIGLOG(I,JJ),JJ=1,4), C GMPA,GMPB ENDIF IF(NS.EQ.2)THEN TT=XDATA(I,NS+1) VARX1=XVAR(ID1(I),1)+TT*TT*XVAR(ID1(I),2)+ C 2.0*TT*XVAR(ID1(I),3) VARX2=XVAR(ID1(I),4)+TT*TT*XVAR(ID1(I),5)+ C 2.0*TT*XVAR(ID1(I),6) SDX1=SQRT(ABS(VARX1)) SDX2=SQRT(ABS(VARX2)) WRITE(24,211)NCONG(I),ID1(I),ISTATE(I),IDIST(I), C (KSTA(I,JJ),JJ=1,7),IPARTY(I), C (MNAME(I,JJ),JJ=1,11),(XDATA(I,JJ),JJ=1,2), C SDX1,SDX2,VARX1,VARX2, C (XBIGLOG(I,JJ),JJ=1,2), C (KBIGLOG(I,JJ),JJ=1,4), C GMPA,GMPB ENDIF 61 CONTINUE WRITE(21,202)NXTOT,SUMLOG1,SUMLOG2 WRITE(*,202)NXTOT,SUMLOG1,SUMLOG2
C
9999 CONTINUE
C
write(*,1000)itim1,itim2,itim3,itim4 write(*,1001)jtim1,jtim2,jtim3,jtim4 write(21,1000)itim1,itim2,itim3,itim4 write(21,1001)jtim1,jtim2,jtim3,jtim4 stop end
C C *************************************************************************** C SUBROUTINE SIGMAS–FINDS BEST STARTING ESTIMATE OF SIGMA-SQUARED VIA C GRID SEARCH C *************************************************************************** C
SUBROUTINE SIGMAS(XPLOG,WDERV,NFIRST,NLAST,ZDF,NDEVIT,XDEVIT) DIMENSION WDERV(99),ZDF(150000,4) LOGICAL*1 RCVOTE1,RCVOTE9,RCVOTET1,RCVOTET9,RCBAD,LWHERE COMMON /XXCOM/ ZMID(99001,2),XDATA(54001,9),DYN(99001,2), C RCVOTE1(54001,2901),RCVOTE9(54001,2901), C RCVOTET1(99001,660),RCVOTET9(99001,660), C RCBAD(99001),LWHERE(99999,111), C NUMCONG(200),MCONG(200,3),ICONG(99001), C INUM(99001),WEIGHT(99),NUMCONGT(200), C NCONG(54001),KWHERE(99999,111), C XBIGLOG(54001,2),KBIGLOG(54001,4) COMMON /MINE/ NS,NQTOT,NPTOT,KLASS, C KLASSYY,KLASSNY,KLASSYN,KLASSNN
C
NINC=15 XINC=.1
C C DETERMINE DIRECTION TO START SEARCH FOR BETA C C CURRENT VALUE C
CALL PLOG(XPLOG,WDERV,NFIRST,NLAST,ZDF,NDEVIT,XDEVIT) SAVECURR=XPLOG
C C CURRENT UP XINC C
WEIGHT(NS+1)=WEIGHT(NS+1)+XINC
C
CALL PLOG(XPLOG,WDERV,NFIRST,NLAST,ZDF,NDEVIT,XDEVIT) SAVEUP=XPLOG WEIGHT(NS+1)=WEIGHT(NS+1)-XINC
C C CURRENT DOWN XINC C
WEIGHT(NS+1)=WEIGHT(NS+1)-XINC
C
CALL PLOG(XPLOG,WDERV,NFIRST,NLAST,ZDF,NDEVIT,XDEVIT) SAVEDWN=XPLOG WEIGHT(NS+1)=WEIGHT(NS+1)+XINC
C C DETERMINE DIRECTION TO MOVE C
IF(SAVEUP.GT.SAVECURR)THEN WEIGHT(NS+1)=WEIGHT(NS+1)+XINC CALL PLOG(XPLOG,WDERV,NFIRST,NLAST,ZDF,NDEVIT,XDEVIT) SAVECURR=XPLOG DO 1 I=1,NINC WEIGHT(NS+1)=WEIGHT(NS+1)+XINC CALL PLOG(XPLOG,WDERV,NFIRST,NLAST,ZDF,NDEVIT,XDEVIT) SAVEUP=XPLOG
C C STEP FORWARD UNTIL LOG-LIKELIHOOD GOES UP – IF IT GOES UP C RESTORE PREVIOUS VALUE AND HALVE THE STEP C
IF(SAVEUP.LT.SAVECURR)THEN WEIGHT(NS+1)=WEIGHT(NS+1)-XINC XINC=XINC/2.0 ENDIF IF(SAVEUP.GT.SAVECURR)THEN SAVECURR=SAVEUP ENDIF WRITE(*,1111)SAVECURR,SAVEUP 1111 FORMAT(2F15.3) 1 CONTINUE ENDIF IF(SAVEDWN.GT.SAVECURR)THEN WEIGHT(NS+1)=WEIGHT(NS+1)-XINC CALL PLOG(XPLOG,WDERV,NFIRST,NLAST,ZDF,NDEVIT,XDEVIT) SAVECURR=XPLOG DO 2 I=1,NINC WEIGHT(NS+1)=WEIGHT(NS+1)-XINC CALL PLOG(XPLOG,WDERV,NFIRST,NLAST,ZDF,NDEVIT,XDEVIT) SAVEDWN=XPLOG
C C STEP BACKWARD UNTIL LOG-LIKELIHOOD GOES UP – IF IT GOES UP C RESTORE PREVIOUS VALUE AND HALVE THE STEP C
IF(SAVEDWN.LT.SAVECURR)THEN WEIGHT(NS+1)=WEIGHT(NS+1)+XINC XINC=XINC/2.0 ENDIF IF(SAVEDWN.GT.SAVECURR)THEN SAVECURR=SAVEDWN ENDIF
C WRITE(*,1111)SAVECURR,SAVEDWN
2 CONTINUE ENDIF
C
RETURN END
C C *************************************************************************** C SUBROUTINE WINT—FINDS BEST STARTING ESTIMATE OF DIMENSION WEIGHT VIA C GRID SEARCH C *************************************************************************** C
SUBROUTINE WINT(XPLOG,WDERV,NFIRST,NLAST,ZDF,NDEVIT,XDEVIT) DIMENSION WDERV(99),ZDF(150000,4) LOGICAL*1 RCVOTE1,RCVOTE9,RCVOTET1,RCVOTET9,RCBAD,LWHERE COMMON /XXCOM/ ZMID(99001,2),XDATA(54001,9),DYN(99001,2), C RCVOTE1(54001,2901),RCVOTE9(54001,2901), C RCVOTET1(99001,660),RCVOTET9(99001,660), C RCBAD(99001),LWHERE(99999,111), C NUMCONG(200),MCONG(200,3),ICONG(99001), C INUM(99001),WEIGHT(99),NUMCONGT(200), C NCONG(54001),KWHERE(99999,111), C XBIGLOG(54001,2),KBIGLOG(54001,4) COMMON /MINE/ NS,NQTOT,NPTOT,KLASS, C KLASSYY,KLASSNY,KLASSYN,KLASSNN
C
NINC=15 XINC=.01
C C DETERMINE DIRECTION TO START SEARCH FOR W C C CURRENT VALUE C
CALL PLOG(XPLOG,WDERV,NFIRST,NLAST,ZDF,NDEVIT,XDEVIT) SAVECURR=XPLOG
C C CURRENT UP XINC C
WEIGHT(2)=WEIGHT(2)+XINC
C
CALL PLOG(XPLOG,WDERV,NFIRST,NLAST,ZDF,NDEVIT,XDEVIT) SAVEUP=XPLOG WEIGHT(2)=WEIGHT(2)-XINC
C C CURRENT DOWN XINC C
WEIGHT(2)=WEIGHT(2)-XINC
C
CALL PLOG(XPLOG,WDERV,NFIRST,NLAST,ZDF,NDEVIT,XDEVIT) SAVEDWN=XPLOG WEIGHT(2)=WEIGHT(2)+XINC
C C DETERMINE DIRECTION TO MOVE C
IF(SAVEUP.GT.SAVECURR)THEN WEIGHT(2)=WEIGHT(2)+XINC CALL PLOG(XPLOG,WDERV,NFIRST,NLAST,ZDF,NDEVIT,XDEVIT) SAVECURR=XPLOG DO 1 I=1,NINC WEIGHT(2)=WEIGHT(2)+XINC CALL PLOG(XPLOG,WDERV,NFIRST,NLAST,ZDF,NDEVIT,XDEVIT) SAVEUP=XPLOG
C C STEP FORWARD UNTIL LOG-LIKELIHOOD GOES UP – IF IT GOES UP C RESTORE PREVIOUS VALUE AND HALVE THE STEP C
IF(SAVEUP.LT.SAVECURR)THEN WEIGHT(2)=WEIGHT(2)-XINC XINC=XINC/2.0 ENDIF IF(SAVEUP.GT.SAVECURR)THEN SAVECURR=SAVEUP ENDIF WRITE(*,1111)SAVECURR,SAVEUP 1111 FORMAT(2F15.3) 1 CONTINUE ENDIF IF(SAVEDWN.GT.SAVECURR)THEN WEIGHT(2)=WEIGHT(2)-XINC CALL PLOG(XPLOG,WDERV,NFIRST,NLAST,ZDF,NDEVIT,XDEVIT) SAVECURR=XPLOG DO 2 I=1,NINC WEIGHT(2)=WEIGHT(2)-XINC CALL PLOG(XPLOG,WDERV,NFIRST,NLAST,ZDF,NDEVIT,XDEVIT) SAVEDWN=XPLOG
C C STEP BACKWARD UNTIL LOG-LIKELIHOOD GOES UP – IF IT GOES UP C RESTORE PREVIOUS VALUE AND HALVE THE STEP C
IF(SAVEDWN.LT.SAVECURR)THEN WEIGHT(2)=WEIGHT(2)+XINC XINC=XINC/2.0 ENDIF IF(SAVEDWN.GT.SAVECURR)THEN SAVECURR=SAVEDWN ENDIF
C WRITE(*,1111)SAVECURR,SAVEDWN
2 CONTINUE ENDIF
C
RETURN END
C C ************************************************************************** C SUBROUTINE JAN11PT – FINDS OPTIMAL CUTTING POINT FOR ONE DIMENSION C ************************************************************************** C
SUBROUTINE JAN11PT(NP,IVOT,YSS,KA,WS,JCH,JEH,JCL,JEL,KCCUT, C LCCUT) DIMENSION YSS(2901),KA(2901),WS(5802),LV(2901),LVB(2901), C LEB(2901),Z(2901),Y(2901), C LE(2901),LJEP(2901),RICE(2901), C AAJEP(101), C ABJEP(101),LAJEP(101),LBJEP(101),LCJEP(101), C LDJEP(101),ABABJEP(101),MJEP(101)
C
NPN=NP+1 NPP=NP-1 KCUT=KCCUT LCUT=LCCUT NOTE=1 AA1=0.0 AB1=0.0 LA1=0 LB1=0 LC1=0 LD1=0 DO 999 III=1,NOTE
C C CHECK ALL POSSIBLE INTERIOR CUT POINTS – THE NP INPUT POINTS C ARE HELD FIXED. THERE ARE NP POSSIBLE CUT-POINTS BEGINNING C WITH CUT-POINT 1 WHICH IS .001 UNITS TO THE LEFT OF POINT 1. C CUT-POINT 2 IS BETWEEN POINTS 1 AND 2, ETC. C C 1 2 3 4 5 6 7 8 9 10 11 .….. NP-1 NP C * * * * * * * * * * * * C 1 2 3 4 5 6 7 8 9 10 11 .….…… NP C C IF KCUT=1 AND LCUT=6, THE FOLLOWING NP PATTERNS ARE TESTED C C PATTERN C 1 6666666666666666666666 C 2 1666666666666666666666 C 3 1166666666666666666666 C 4 1116666666666666666666 C 5 1111666666666666666666 C 6 1111166666666666666666 C 7 1111116666666666666666 C . .…. C . .…. C . .…. C NP-1 1111111111111111111166 C NP 1111111111111111111116 C C BECAUSE THE PROGRAM TRIES BOTH KCUT=1/LCUT=6 AND KCUT=6/LCUT=1, THIS C WILL ALSO TEST THE ONE MISSING PATTERN ABOVE, VIZ., ALL “1”s. C C
KSE=0 KSV=0 LSV=0 LSE=0 KMARK=1 I=0 10 I=I+1 IF(I-NP-1)61,12,12 61 Z(I)=999.0 IF(I.EQ.1)THEN Y(I)=YSS(1)-.001 ENDIF IF(I.GT.1)THEN Y(I)=(YSS(I)+YSS(I-1))/2.0 ENDIF
C IF(KA(I).EQ.9)GO TO 10
IF(KMARK.EQ.1)THEN DO 3 J=I,NP IF(KA(J).EQ.9)GO TO 3 IF(LCUT-KA(J))33,5,33 33 IF(KCUT-KA(J))3,6,3 5 LSV=LSV+1 GO TO 3 6 LSE=LSE+1 3 CONTINUE KMARK=0 GO TO 31 ENDIF IF(KA(I-1).EQ.KCUT)THEN KSV=KSV+1 LSE=LSE-1 ENDIF IF(KA(I-1).EQ.LCUT)THEN KSE=KSE+1 LSV=LSV-1 ENDIF
C
31 CONTINUE LJEP(I)=I LV(I)=KSV LVB(I)=LSV LE(I)=KSE LEB(I)=LSE KT=LV(I)+LE(I)+LVB(I)+LEB(I) Z(I)=FLOAT(LE(I)+LEB(I))/FLOAT(KT) COX1=0.0 COX2=0.0 IF(LV(I)+LEB(I).GT.0)COX1=FLOAT(LV(I))/FLOAT(LV(I)+LEB(I)) IF(LVB(I)+LE(I).GT.0)COX2=FLOAT(LE(I))/FLOAT(LVB(I)+LE(I)) RICE(I)=COX1-COX2
C WRITE(21,1001)I,Y(I),KA(I),LVB(I),LEB(I),LV(I),LE(I),RICE(I)
1001 FORMAT(I4,F7.3,I2,4I4,F7.3)
C
GO TO 10 12 CONTINUE
C C FIND BEST CUT POINT C
CALL RSORT(Z,NP,LJEP) KIN=1 MJEP(1)=1 AAJEP(KIN)=Z(1) ABJEP(KIN)=Y(LJEP(1)) ABABJEP(KIN)=ABS(ABJEP(KIN)) LAJEP(KIN)=LV(LJEP(1)) LBJEP(KIN)=LE(LJEP(1)) LCJEP(KIN)=LVB(LJEP(1)) LDJEP(KIN)=LEB(LJEP(1))
C C CHECK IF THERE ARE MULTIPLE CUT-POINTS WITH SAME CLASSIFICATION AND C SELECT THAT CUT-POINT CLOSEST TO THE INTERIOR OF THE SPACE C
DO 63 I=2,NP IF(ABS(Z(1)-Z(I)).LE..00001)THEN KIN=KIN+1 MJEP(KIN)=KIN AAJEP(KIN)=Z(I) ABJEP(KIN)=Y(LJEP(I)) ABABJEP(KIN)=ABS(ABJEP(KIN)) LAJEP(KIN)=LV(LJEP(I)) LBJEP(KIN)=LE(LJEP(I)) LCJEP(KIN)=LVB(LJEP(I)) LDJEP(KIN)=LEB(LJEP(I)) IF(KIN.GT.100)GO TO 633 GO TO 63 ENDIF IF(Z(1).LT.Z(I))GO TO 633 63 CONTINUE 633 CONTINUE IF(KIN.EQ.1)THEN AA=AAJEP(1) AB=ABJEP(1) LA=LAJEP(1) LB=LBJEP(1) LC=LCJEP(1) LD=LDJEP(1) ENDIF IF(KIN.GT.1)THEN CALL RSORT(ABABJEP,KIN,MJEP) AA=AAJEP(MJEP(1)) AB=ABJEP(MJEP(1)) LA=LAJEP(MJEP(1)) LB=LBJEP(MJEP(1)) LC=LCJEP(MJEP(1)) LD=LDJEP(MJEP(1)) ENDIF
C
AA1=AA AB1=AB LA1=LA LB1=LB LC1=LC LD1=LD
C
999 CONTINUE AA=AA1 AB=AB1 LA=LA1 LB=LB1 LC=LC1 LD=LD1 WS(IVOT)=AB JCL=LA JEL=LB JCH=LC JEH=LD
C
RETURN END
C C *************************************************************************** C SUBROUTINE PLOG—CALCULATES LOG-LIKELIHOOD FOR THE NOMINATE PROBIT
C MODEL
C *************************************************************************** C
SUBROUTINE PLOG(XPLOG,WDERV,NFIRST,NLAST, C ZDF,NDEVIT,XDEVIT) DIMENSION DYES(99),DNO(99),DCC(99),DBB(99), C WDERV(99),ZDF(150000,4),WDERV2(99) LOGICAL*1 RCVOTE1,RCVOTE9,RCVOTET1,RCVOTET9,RCBAD,LWHERE COMMON /XXCOM/ ZMID(99001,2),XDATA(54001,9),DYN(99001,2), C RCVOTE1(54001,2901),RCVOTE9(54001,2901), C RCVOTET1(99001,660),RCVOTET9(99001,660), C RCBAD(99001),LWHERE(99999,111), C NUMCONG(200),MCONG(200,3),ICONG(99001), C INUM(99001),WEIGHT(99),NUMCONGT(200), C NCONG(54001),KWHERE(99999,111), C XBIGLOG(54001,2),KBIGLOG(54001,4) COMMON /MINE/ NS,NQTOT,NPTOT,KLASS, C KLASSYY,KLASSNY,KLASSYN,KLASSNN 1001 FORMAT(I4,F5.2,F10.7) 1002 FORMAT(' LOG-L',2I10,10F8.5) 1003 FORMAT(4I4,3F15.3) 1004 FORMAT(5I8,6F15.3) 1005 FORMAT(I4,2I5,I8,3F15.3) 1006 FORMAT(I10,11F20.3) 1007 FORMAT(' LNL',2I10,F15.3,10F8.4)
C C
XPLOG=0.0 XXPLOG=0.0
C
DO 7 K=1,2*NS+2 WDERV(K)=0.0 WDERV2(K)=0.0 7 CONTINUE KTOT=0 KTOTP=0 KTOTQ=0 KLASS=0 KLASSYY=0 KLASSNY=0 KLASSYN=0 KLASSNN=0 KLASS2=0 IF(NFIRST.GT.1)THEN DO 11 II=1,NFIRST-1 NPC=NUMCONG(II) NQC=NUMCONGT(II) KTOTP=KTOTP+NPC KTOTQ=KTOTQ+NQC 11 CONTINUE ENDIF DO 1 II=NFIRST,NLAST NPC=NUMCONG(II) NQC=NUMCONGT(II) DO 2 I=1,NPC YPLOG=0.0 KPLOG=0 KPWRONG=0 DO 8 K=1,2*(NS+1) WDERV(K)=0.0 8 CONTINUE DO 33 J=1,NQC IF(RCBAD(J+KTOTQ).EQV..TRUE.)THEN DO 3 K=1,NS DYES(K)=0.0 DNO(K)=0.0 DYES(K)=(XDATA(I+KTOTP,K)-ZMID(J+KTOTQ,K)+DYN(J+KTOTQ,K))**2 DNO(K) =(XDATA(I+KTOTP,K)-ZMID(J+KTOTQ,K)-DYN(J+KTOTQ,K))**2 3 CONTINUE
C C IF NOT MISSING DATA C
IF(RCVOTE9(I+KTOTP,J).EQV..FALSE.)THEN KTOT=KTOT+1
C C IF YES C
IF(RCVOTE1(I+KTOTP,J).EQV..TRUE.)THEN DC=0.0 DB=0.0 DO 4 K=1,NS DC=DC+(-WEIGHT(K)*WEIGHT(K)*DYES(K)) DB=DB+(-WEIGHT(K)*WEIGHT(K)*DNO(K)) DCC(K)=DYES(K) DBB(K)=DNO(K) 4 CONTINUE XCC=+1.0 ENDIF
C C IF NO C
IF(RCVOTE1(I+KTOTP,J).EQV..FALSE.)THEN DC=0.0 DB=0.0 DO 5 K=1,NS DC=DC+(-WEIGHT(K)*WEIGHT(K)*DNO(K)) DB=DB+(-WEIGHT(K)*WEIGHT(K)*DYES(K)) DCC(K)=DNO(K) DBB(K)=DYES(K) 5 CONTINUE XCC=-1.0 ENDIF
C
ZS=WEIGHT(NS+1)*(EXP(DC)-EXP(DB))
C C CROSS CLASSIFICATIONS C
IF(ABS(DC).LE.ABS(DB))KLASS=KLASS+1 IF(ABS(DC).LE.ABS(DB).AND.XCC.EQ.+1.0)THEN KLASSYY=KLASSYY+1 ENDIF IF(ABS(DC).GT.ABS(DB).AND.XCC.EQ.+1.0)THEN KLASSNY=KLASSNY+1 ENDIF IF(ABS(DC).GT.ABS(DB).AND.XCC.EQ.-1.0)THEN KLASSYN=KLASSYN+1 ENDIF IF(ABS(DC).LE.ABS(DB).AND.XCC.EQ.-1.0)THEN KLASSNN=KLASSNN+1 ENDIF IF(ZS.GT.0.0)KLASS2=KLASS2+1
C
WWIMJ=ZS*XDEVIT KWIMJ=IFIX(ABS(WWIMJ)+.5) IF(KWIMJ.GT.NDEVIT-2)KWIMJ=NDEVIT-2 IF(ZS.GE.0.0)THEN ZDISTF=ZDF(NDEVIT-1+KWIMJ+1,2) CDFLOG=ZDF(NDEVIT-1+KWIMJ+1,3) ENDIF IF(ZS.LT.0.0)THEN ZDISTF=ZDF(NDEVIT-KWIMJ,2) CDFLOG=ZDF(NDEVIT-KWIMJ,3) KPWRONG=KPWRONG+1 ENDIF XPLOG=XPLOG+CDFLOG YPLOG=YPLOG+CDFLOG KPLOG=KPLOG+1 ZGAUSS=EXP(-(ZS*ZS)/2.0) DO 6 K=1,NS AZULU=-2.0*WEIGHT(K)*WEIGHT(NS+1)* C (((1.0/SQRT(2.0*3.1415926536))*EXP(-(ZS*ZS)/2.0))/ZDISTF)* C (DCC(K)*EXP(DC)-DBB(K)*EXP(DB)) WDERV(K)=WDERV(K)+AZULU WDERV(NS+1+K)=WDERV(NS+1+K)+AZULU**2 6 CONTINUE AZULU= C (((1.0/SQRT(2.0*3.1415926536))*EXP(-(ZS*ZS)/2.0))/ZDISTF)* C (EXP(DC) - EXP(DB)) WDERV(NS+1)=WDERV(NS+1)+AZULU WDERV(NS+1+NS+1)=WDERV(NS+1+NS+1)+AZULU**2 ENDIF ENDIF 33 CONTINUE XBIGLOG(I+KTOTP,2)=YPLOG KBIGLOG(I+KTOTP,2)=KPLOG KBIGLOG(I+KTOTP,4)=KPWRONG XXPLOG=XXPLOG+YPLOG DO 9 K=1,NS+1+NS+1 WDERV2(K)=WDERV2(K)+WDERV(K) 9 CONTINUE 2 CONTINUE KTOTP=KTOTP+NPC KTOTQ=KTOTQ+NQC 1 CONTINUE
C
WRITE(21,1006)KTOT,XPLOG,XXPLOG
C WRITE(* ,1006)KTOT,XPLOG,XXPLOG
GMP=EXP(XXPLOG/FLOAT(KTOT)) XCLASS=FLOAT(KLASS)/FLOAT(KTOT) WRITE(21,1002)KTOT,KLASS,XCLASS,GMP,(WEIGHT(JJ),JJ=1,NS+1) WRITE(27,1006)KTOT,XXPLOG,(WDERV2(JJ),JJ=1,NS+1) WRITE(27,1006)KTOT,XXPLOG,(WDERV2(JJ),JJ=NS+2,2*(NS+1)) WRITE(*,1007)KTOT,KLASS,XXPLOG,XCLASS,GMP,(WEIGHT(JJ),JJ=1,NS+1)
C WRITE(*,1006)KTOT,XXPLOG,(WDERV2(JJ),JJ=1,NS+1) C WRITE(*,1006)KTOT,XXPLOG,(WDERV2(JJ),JJ=NS+2,2*(NS+1))
XPLOG=XXPLOG RETURN END
C C *************************************************************************** C SUBROUTINE PROX–CALCULATES DERIVATIVES AND LOG-LIKELIHOODS FOR THE C LEGISLATOR PARAMETERS FOR THE NOMINATE PROBIT
C MODEL
C *************************************************************************** C
SUBROUTINE PROX(NEP,KRC,ATIME,XMARK,XPLOG, C XDERV,XDERV1,XDERV2,XDERV3, C XBETA,OUTX0,OUTX1,OUTX2,OUTX3, C NFIRST,NLAST, C ZDF,NDEVIT,XDEVIT,NMODEL) DIMENSION DYES(99),DNO(99),DYES1(99),DNO1(99), C DCC(99),DBB(99),DCC1(99),DBB1(99),XDERV(99), C XDERV1(99),XDERV2(99),XDERV3(99), C ATIME(152,127),MARK(99,3),XMARK(99,3), C XBETA(5,5),ZDF(150000,4),OUTX0(99,99),AADERV(99), C OUTX1(99,99),OUTX2(99,99),OUTX3(99,99) LOGICAL*1 RCVOTE1,RCVOTE9,RCVOTET1,RCVOTET9,RCBAD,LWHERE COMMON /XXCOM/ ZMID(99001,2),XDATA(54001,9),DYN(99001,2), C RCVOTE1(54001,2901),RCVOTE9(54001,2901), C RCVOTET1(99001,660),RCVOTET9(99001,660), C RCBAD(99001),LWHERE(99999,111), C NUMCONG(200),MCONG(200,3),ICONG(99001), C INUM(99001),WEIGHT(99),NUMCONGT(200), C NCONG(54001),KWHERE(99999,111), C XBIGLOG(54001,2),KBIGLOG(54001,4) COMMON /MINE/ NS,NQTOT,NPTOT,KLASS, C KLASSYY,KLASSNY,KLASSYN,KLASSNN 100 FORMAT(8F7.3) 200 FORMAT(I6,2I5,2F13.5) 1001 FORMAT(I4,F5.2,F10.7) 1002 FORMAT(' LEG ',I6,2I6,5F7.3,2F13.5)
C
XPLOG=0.0 DO 40 K=1,4*NS DO 40 J=1,4*NS OUTX0(J,K)=0.0 OUTX1(J,K)=0.0 OUTX2(J,K)=0.0 OUTX3(J,K)=0.0 40 CONTINUE KK=0 KTOTQ=0 IF(NFIRST.GT.1)THEN DO 11 J=1,NFIRST-1 NQ=MCONG(J,2) KTOTQ=KTOTQ+NQ 11 CONTINUE ENDIF DO 51 J=NFIRST,NLAST NQ=MCONG(J,2) IF(LWHERE(NEP,J).EQV..TRUE.)THEN KK=KK+1 MWHERE=KWHERE(NEP,J) MARK(KK,1)=MWHERE MARK(KK,2)=NQ MARK(KK,3)=KTOTQ
C C STORE TIME TREND TERMS TO CALCULATE STANDARD ERRORS IN MAIN C PROGRAM C
XDATA(MWHERE,NS+1)=0.0 XDATA(MWHERE,NS+2)=0.0 XDATA(MWHERE,NS+3)=0.0
C
DO 52 K=1,NS
C C CONSTANT MODEL C
IF(NMODEL.EQ.0)THEN XDATA(MWHERE,K)=ATIME(KK,1)*XBETA(1,K) ENDIF
C C LINEAR MODEL C
IF(NMODEL.EQ.1)THEN XDATA(MWHERE,K)=ATIME(KK,1)*XBETA(1,K)+ C ATIME(KK,2)*XBETA(2,K) XDATA(MWHERE,NS+1)=ATIME(KK,2) ENDIF
C C QUADRATIC MODEL C
IF(NMODEL.EQ.2)THEN XDATA(MWHERE,K)=ATIME(KK,1)*XBETA(1,K)+ C ATIME(KK,2)*XBETA(2,K)+ C ATIME(KK,3)*XBETA(3,K) XDATA(MWHERE,NS+1)=ATIME(KK,2) XDATA(MWHERE,NS+2)=ATIME(KK,3) ENDIF
C C CUBIC MODEL C
IF(NMODEL.EQ.3)THEN XDATA(MWHERE,K)=ATIME(KK,1)*XBETA(1,K)+ C ATIME(KK,2)*XBETA(2,K)+ C ATIME(KK,3)*XBETA(3,K)+ C ATIME(KK,4)*XBETA(4,K) XDATA(MWHERE,NS+1)=ATIME(KK,2) XDATA(MWHERE,NS+2)=ATIME(KK,3) XDATA(MWHERE,NS+3)=ATIME(KK,4) ENDIF
C
XMARK(KK,K)=XDATA(MWHERE,K) 52 CONTINUE ENDIF KTOTQ=KTOTQ+NQ 51 CONTINUE KLASS=0 KLASS2=0 DO 8 K=1,NS XDERV(K)=0.0 XDERV1(K)=0.0 XDERV2(K)=0.0 XDERV3(K)=0.0 8 CONTINUE
C C ************** C C LOOP OVER NUMBER OF CONGRESSES MEMBER SERVED IN C C
KTOT=0 DO 22 JJ=1,KK YPLOG=0.0 KPLOG=0 KPWRONG=0 MWHERE=MARK(JJ,1) NQ=MARK(JJ,2) KTOTQ=MARK(JJ,3)
C C LOOP OVER NUMBER OF ROLL CALLS WITHIN THE CURRENT CONGRESS C
DO 2 J=1,NQ
C C IF AT LEAST 2.5% IN MINORITY C
IF(RCBAD(J+KTOTQ).EQV..TRUE.)THEN
C
DO 3 K=1,NS DYES(K)=0.0 DNO(K)=0.0 DYES1(K)=0.0 DNO1(K)=0.0 DYES(K)=(XDATA(MWHERE,K)-ZMID(J+KTOTQ,K)+DYN(J+KTOTQ,K))**2 DNO(K) =(XDATA(MWHERE,K)-ZMID(J+KTOTQ,K)-DYN(J+KTOTQ,K))**2 DYES1(K)=(XDATA(MWHERE,K)-ZMID(J+KTOTQ,K)+DYN(J+KTOTQ,K)) DNO1(K) =(XDATA(MWHERE,K)-ZMID(J+KTOTQ,K)-DYN(J+KTOTQ,K)) 3 CONTINUE
C C IF NOT MISSING DATA C
IF(RCVOTE9(MWHERE,J).EQV..FALSE.)THEN KTOT=KTOT+1
C C IF YES C
IF(RCVOTE1(MWHERE,J).EQV..TRUE.)THEN DC=0.0 DB=0.0 DO 4 K=1,NS DC=DC+(-WEIGHT(K)*WEIGHT(K)*DYES(K)) DB=DB+(-WEIGHT(K)*WEIGHT(K)*DNO(K)) DCC(K)=DYES(K) DBB(K)=DNO(K) DCC1(K)=DYES1(K)*WEIGHT(K)*WEIGHT(K) DBB1(K)=DNO1(K)*WEIGHT(K)*WEIGHT(K) 4 CONTINUE ENDIF
C C IF NO C
IF(RCVOTE1(MWHERE,J).EQV..FALSE.)THEN DC=0.0 DB=0.0 DO 5 K=1,NS DC=DC+(-WEIGHT(K)*WEIGHT(K)*DNO(K)) DB=DB+(-WEIGHT(K)*WEIGHT(K)*DYES(K)) DCC(K)=DNO(K) DBB(K)=DYES(K) DCC1(K)=DNO1(K)*WEIGHT(K)*WEIGHT(K) DBB1(K)=DYES1(K)*WEIGHT(K)*WEIGHT(K) 5 CONTINUE ENDIF
C
ZS=WEIGHT(NS+1)*(EXP(DC)-EXP(DB))
C
IF(ABS(DC).LE.ABS(DB))KLASS=KLASS+1 IF(ZS.GT.0.0)KLASS2=KLASS2+1
C
WWIMJ=ZS*XDEVIT KWIMJ=IFIX(ABS(WWIMJ)+.5) IF(KWIMJ.GT.NDEVIT-2)KWIMJ=NDEVIT-2 IF(ZS.GE.0.0)THEN ZDISTF=ZDF(NDEVIT-1+KWIMJ+1,2) CDFLOG=ZDF(NDEVIT-1+KWIMJ+1,3) ENDIF IF(ZS.LT.0.0)THEN ZDISTF=ZDF(NDEVIT-KWIMJ,2) CDFLOG=ZDF(NDEVIT-KWIMJ,3) KPWRONG=KPWRONG+1 ENDIF XPLOG=XPLOG+CDFLOG YPLOG=YPLOG+CDFLOG KPLOG=KPLOG+1 ZGAUSS=EXP(-(ZS*ZS)/2.0)
C C OUTER PRODUCT MATRIX C
DO 31 K=1,NS AADERV(K)=(ZGAUSS/ZDISTF)* C (DCC1(K)*EXP(DC)-DBB1(K)*EXP(DB)) IF(NMODEL.EQ.1)THEN AADERV(K+NS)=ATIME(JJ,2)*(ZGAUSS/ZDISTF)* C (DCC1(K)*EXP(DC)-DBB1(K)*EXP(DB)) ENDIF IF(NMODEL.EQ.2)THEN AADERV(K+NS)=ATIME(JJ,2)*(ZGAUSS/ZDISTF)* C (DCC1(K)*EXP(DC)-DBB1(K)*EXP(DB)) AADERV(K+2*NS)=ATIME(JJ,3)*(ZGAUSS/ZDISTF)* C (DCC1(K)*EXP(DC)-DBB1(K)*EXP(DB)) ENDIF IF(NMODEL.EQ.3)THEN AADERV(K+NS)=ATIME(JJ,2)*(ZGAUSS/ZDISTF)* C (DCC1(K)*EXP(DC)-DBB1(K)*EXP(DB)) AADERV(K+2*NS)=ATIME(JJ,3)*(ZGAUSS/ZDISTF)* C (DCC1(K)*EXP(DC)-DBB1(K)*EXP(DB)) AADERV(K+3*NS)=ATIME(JJ,4)*(ZGAUSS/ZDISTF)* C (DCC1(K)*EXP(DC)-DBB1(K)*EXP(DB)) ENDIF 31 CONTINUE DO 32 JJK=1,NS DO 32 JJJ=1,NS OUTX0(JJJ,JJK)=OUTX0(JJJ,JJK)+AADERV(JJK)*AADERV(JJJ) 32 CONTINUE IF(NMODEL.EQ.1)THEN DO 33 JJK=1,2*NS DO 33 JJJ=1,2*NS OUTX1(JJJ,JJK)=OUTX1(JJJ,JJK)+AADERV(JJK)*AADERV(JJJ) 33 CONTINUE ENDIF IF(NMODEL.EQ.2)THEN DO 34 JJK=1,3*NS DO 34 JJJ=1,3*NS OUTX2(JJJ,JJK)=OUTX2(JJJ,JJK)+AADERV(JJK)*AADERV(JJJ) 34 CONTINUE ENDIF IF(NMODEL.EQ.3)THEN DO 35 JJK=1,4*NS DO 35 JJJ=1,4*NS OUTX3(JJJ,JJK)=OUTX3(JJJ,JJK)+AADERV(JJK)*AADERV(JJJ) 35 CONTINUE ENDIF
C C WRITE(41,200)NEP,JJ,J,(AADERV(JJI),JJI=1,NS) C
DO 6 K=1,NS XDERV(K)=XDERV(K)+(ZGAUSS/ZDISTF)* C (DCC1(K)*EXP(DC)-DBB1(K)*EXP(DB)) XDERV1(K)=XDERV1(K)+ATIME(JJ,2)*(ZGAUSS/ZDISTF)* C (DCC1(K)*EXP(DC)-DBB1(K)*EXP(DB)) XDERV2(K)=XDERV2(K)+ATIME(JJ,3)*(ZGAUSS/ZDISTF)* C (DCC1(K)*EXP(DC)-DBB1(K)*EXP(DB)) XDERV3(K)=XDERV3(K)+ATIME(JJ,4)*(ZGAUSS/ZDISTF)* C (DCC1(K)*EXP(DC)-DBB1(K)*EXP(DB)) 6 CONTINUE ENDIF ENDIF 2 CONTINUE XBIGLOG(MWHERE,1)=YPLOG KBIGLOG(MWHERE,1)=KPLOG KBIGLOG(MWHERE,3)=KPWRONG 22 CONTINUE GMP=EXP(XPLOG/FLOAT(KTOT))
C WRITE(21,1002)NEP,KTOT,KLASS,XBETA(1,1),XBETA(2,1), C C XBETA(1,2),XBETA(2,2),GMP,XPLOG,XDERV(1)
KRC=KTOT RETURN END
C C *************************************************************************** C SUBROUTINE XINT—FINDS LEGISLATOR PARAMETERS C *************************************************************************** C
SUBROUTINE XINT(NEP,ID1,LNAME,XPLOG0,XPLOG1,XPLOG2,XPLOG3, C NFIRST,NLAST,NNMODEL, C ZDF,NDEVIT,XDEVIT,KXTOT,XBETA,OUTX0, C OUTX1,OUTX2,OUTX3,DERVISH) DIMENSION ATIME(152,127),ZDF(150000,4), C YYY(152),VVV(152),ID1(54001),XMARK(99,3), C XDERV(99),XDERV1(99),XDERV2(99),XDERV3(99), C XXX(152),ZMAT(99,99),FV1(199), C FV2(199),WVEC(199),DERVISH(99,99), C LLL(152),YLOG(152),YGAMMA(152,99), C XXXSAVE(152,99),XBETA(5,5),XBETASV(5,5), C YGMP(152),YYGMP(152),OUTX0(99,99), C OUTX1(99,99),OUTX2(99,99),OUTX3(99,99) LOGICAL*1 RCVOTE1,RCVOTE9,RCVOTET1,RCVOTET9,RCBAD,LWHERE COMMON /XXCOM/ ZMID(99001,2),XDATA(54001,9),DYN(99001,2), C RCVOTE1(54001,2901),RCVOTE9(54001,2901), C RCVOTET1(99001,660),RCVOTET9(99001,660), C RCBAD(99001),LWHERE(99999,111), C NUMCONG(200),MCONG(200,3),ICONG(99001), C INUM(99001),WEIGHT(99),NUMCONGT(200), C NCONG(54001),KWHERE(99999,111), C XBIGLOG(54001,2),KBIGLOG(54001,4) COMMON /MINE/ NS,NQTOT,NPTOT,KLASS, C KLASSYY,KLASSNY,KLASSYN,KLASSNN character*1 LNAME(54001,11) 101 FORMAT(' PERFORMANCE INDEX EIGENVALUE/VECTOR ROUTINE=',3I6) 102 FORMAT(2I6,30F10.4) 103 FORMAT(12X,30F10.4) 201 FORMAT(I6,2I4,150F10.4) 203 FORMAT(I6,I5,F12.5,20F10.4) 205 FORMAT(I6,I3,I5,I4,I3,F12.5,30F10.4) 206 FORMAT(I6,I5,4F8.4,4F12.5) 307 FORMAT(' NEGATIVE SQUARE ROOT FARTKNOCKER!!') 1000 FORMAT(3I6,I3,1X,11A1,155F7.3) 1001 FORMAT(' LEG',I6,2I4,2F7.3,2F13.5) 1002 FORMAT(10X,2F10.5,55F7.3) 1003 FORMAT(' MAJOR ERROR',I6)
C
KK=0 DO 50 J=NFIRST,NLAST IF(LWHERE(NEP,J).EQV..TRUE.)KK=KK+1 50 CONTINUE
C C ********** C GET STARTING ESTIMATES OF THE BETAS FOR THE LEGISLATOR TIME POLYNOMIAL C ONE DIMENSION AT A TIME USING SIMPLE OLS ON THE LEGRENDRE POLYNOMIALS C C Xikt = Xik0 + Xik1*T + Xik2T**2 WHERE T IS THE LEGRENDRE POLYNOMIAL C C XBETA(1,K) CONTAINS Xik0 C XBETA(2,K) CONTAINS Xik1 C XBETA(3,K) CONTAINS Xik2 C XBETA(4,K) CONTAINS Xik3 C ********* C
XINC=0.0 IF(KK.GT.1)XINC=2.0/(FLOAT(KK)-1.0) SUM=0.0 DO 52 K=1,NS XBETA(1,K)=0.0 XBETA(2,K)=0.0 XBETA(3,K)=0.0 XBETA(4,K)=0.0 KK=0 DO 51 J=NFIRST,NLAST IF(LWHERE(NEP,J).EQV..TRUE.)THEN KK=KK+1 MWHERE=KWHERE(NEP,J) ATIME(KK,1)=1.0 XTIME=-1.0+(FLOAT(KK)-1.0)*XINC ATIME(KK,2)=XTIME ATIME(KK,3)=(3.0*XTIME*XTIME - 1.0)/2.0 ATIME(KK,4)=(5.0*XTIME*XTIME*XTIME - 3.0*XTIME)/2.0 YYY(KK)=XDATA(MWHERE,K) ENDIF 51 CONTINUE
C C LINEAR MODEL C
IF(KK.EQ.5)THEN CALL REGA(KK,2,ATIME,YYY,VVV)
C WRITE(33,201)NEP,KK,K,(VVV(JFX),JFX=1,4) C WRITE(33,201)NEP,KK,K,(YYY(JFX),JFX=1,KK)
ENDIF
C C QUADRATIC MODEL C
IF(KK.EQ.6)THEN CALL REGA(KK,3,ATIME,YYY,VVV)
C WRITE(33,201)NEP,KK,K,(VVV(JFX),JFX=1,4) C WRITE(33,201)NEP,KK,K,(YYY(JFX),JFX=1,KK)
ENDIF
C C CUBIC MODEL C
IF(KK.GE.7)THEN CALL REGA(KK,4,ATIME,YYY,VVV)
C WRITE(33,201)NEP,KK,K,(VVV(JFX),JFX=1,4) C WRITE(33,201)NEP,KK,K,(YYY(JFX),JFX=1,KK)
ENDIF
C
IF(KK.LT.5)THEN VVV(1)=YYY(1) VVV(2)=0.0 VVV(3)=0.0 VVV(4)=0.0 ENDIF XBETA(1,K)=VVV(1) XBETA(2,K)=VVV(2) XBETA(3,K)=VVV(3) XBETA(4,K)=VVV(4) XBETASV(1,K)=XBETA(1,K) XBETASV(2,K)=XBETA(2,K) XBETASV(3,K)=XBETA(3,K) XBETASV(4,K)=XBETA(4,K)
C C CONSTRAIN TO CONSTANT MODEL HERE C **** C XBETA(2,K)=0.0 C XBETA(3,K)=0.0 C XBETA(4,K)=0.0 C **** C C WRITE(44,1000)NEP,ID1(MWHERE),MWHERE,KK, C C (LNAME(MWHERE,JJ),JJ=1,11), C C (VVV(JJ),JJ=1,4),(YYY(JJ),JJ=1,KK) C WRITE(44,1002)(ATIME(JJ,2),JJ=1,KK)
SUM=SUM+XBETA(1,K)**2 52 CONTINUE
C C DO CHECK ON STARTING VALUE OF LEGISLATOR COORDINATE – IF OUTSIDE C HYPERSPHERE PULL IT BACK INSIDE C
IF(SUM.GT.1.0)THEN DO 55 K=1,NS XBETA(1,K)=.75*(XBETA(1,K)/SQRT(SUM)) 55 CONTINUE ENDIF
C C SAVE NUMBER OF CONGRESSES HERE C
NEPCONG=KK
C C CALCULATE NEW PROJECTED LEGISLATOR COORDINATE WITH A C SIMPLE GRID SEARCH C
NINC=25
C C *********** C CONSTANT TERM FIRST C *********** C
DO 99 IIII=1,10
C
DO 2 K=1,NS XBETASV(1,K)=XBETA(1,K) XXX(K)=0.0 2 CONTINUE
C
DO 40 K=1,NS XDERV(K)=0.0 XDERV1(K)=0.0 XDERV2(K)=0.0 XDERV3(K)=0.0 40 CONTINUE
C C GET DERIVATIVES C
NMODEL=0 CALL PROX(NEP,KRC,ATIME,XMARK,XPLOG, C XDERV,XDERV1,XDERV2,XDERV3, C XBETASV,OUTX0,OUTX1,OUTX2,OUTX3, C NFIRST,NLAST, C ZDF,NDEVIT,XDEVIT,NMODEL)
C C SAVE INITIAL LOG-LIKELIHOOD C
IF(IIII.EQ.1)THEN SAVEGMP=EXP(XPLOG/FLOAT(KRC)) ENDIF
C
GMP=EXP(XPLOG/FLOAT(KRC)) SUMA=0.0 DO 61 K=1,NS XXX(K)=XDERV(K)/FLOAT(KRC) SUMA=SUMA+XXX(K)**2 61 CONTINUE
C C C CALCULATE STEPSIZE IN .01 UNITS C
STEP=.01/SQRT(SUMA)
C
C C WRITE(28,203)NEP,IIII,XPLOG,GMP, C C (XBETA(1,K),K=1,NS),(XXX(K),K=1,NS),STEP C C C SEARCH ALONG VECTOR IN BEST DIRECTION C C
XINC=0.0
C
DO 212 KK=1,NINC SUM=0.0 DO 24 K=1,NS
C C ***** C CHECK FOR SIGN OF DERIVATIVE FOR GRADIENT!!!!!!!! C ***** C
XBETA(1,K)=XBETASV(1,K)-XINC*XXX(K)
C
SUM=SUM+XBETA(1,K)**2 24 CONTINUE
C C CHECK TO SEE IF LEGISLATOR POINT OUTSIDE UNIT HYPERSPHERE C
IF(SUM.GT.1.0)THEN
C C RESET LEGISLATOR POINT TO SURFACE OF UNIT HYPERSPHERE AND C CALCULATE DERIVATIVES AND LOG-LIKELIHOODS. THEN EXIT C SEARCH LOOP C
DO 241 K=1,NS XBETA(1,K)=XBETA(1,K)/SQRT(SUM) 241 CONTINUE DO 243 K=1,NS XDERV(K)=0.0 XDERV1(K)=0.0 XDERV2(K)=0.0 XDERV3(K)=0.0 243 CONTINUE NMODEL=0 CALL PROX(NEP,KRC,ATIME,XMARK,XPLOG, C XDERV,XDERV1,XDERV2,XDERV3, C XBETA,OUTX0,OUTX1,OUTX2,OUTX3, C NFIRST,NLAST, C ZDF,NDEVIT,XDEVIT,NMODEL)
C
GMP=EXP(XPLOG/FLOAT(KRC))
C
YGMP(KK)=GMP LLL(KK)=KK DO 242 K=1,NS YGAMMA(KK,K)=XBETA(1,K) XXXSAVE(KK,K)=XXX(K) 242 CONTINUE YLOG(KK)=XPLOG GO TO 2112 ENDIF DO 240 K=1,NS XDERV(K)=0.0 XDERV1(K)=0.0 XDERV2(K)=0.0 XDERV3(K)=0.0 240 CONTINUE
C C GET DERIVATIVES C
NMODEL=0 CALL PROX(NEP,KRC,ATIME,XMARK,XPLOG, C XDERV,XDERV1,XDERV2,XDERV3, C XBETA,OUTX0,OUTX1,OUTX2,OUTX3, C NFIRST,NLAST, C ZDF,NDEVIT,XDEVIT,NMODEL)
C
GMP=EXP(XPLOG/FLOAT(KRC))
C
YGMP(KK)=GMP LLL(KK)=KK DO 222 K=1,NS YGAMMA(KK,K)=XBETA(1,K) XXXSAVE(KK,K)=XXX(K) 222 CONTINUE YLOG(KK)=XPLOG
C C WRITE(28,205)NEP,NEPCONG,IIII,KK,NMODEL,YLOG(KK),YGMP(KK), C C (YGAMMA(KK,K),K=1,NS),(XBETASV(1,K),K=1,NS), C C (XXX(K),K=1,NS),XINC C
XINC=XINC+STEP 212 CONTINUE
C
NNINC=NINC GO TO 2113 2112 NNINC=KK 2113 CONTINUE
C C FIND MAXIMUM ON BEST DIRECTION THROUGH THE SPACE C
CALL RSORT(YGMP,NNINC,LLL)
C WRITE(28,205)NEP,NEPCONG,IIII,LLL(NNINC),NMODEL,YLOG(LLL(NNINC)), C C YGMP(NNINC),(YGAMMA(LLL(NNINC),K),K=1,NS), C C (XBETA(1,K),K=1,NS),(XXXSAVE(LLL(NNINC),K),K=1,NS)
DO 224 K=1,NS XBETA(1,K)=YGAMMA(LLL(NNINC),K) XBETASV(1,K)=XBETA(1,K) 224 CONTINUE
C C STORE GMP C
YYGMP(IIII)=YGMP(NNINC)
C C EXIT THE SEARCH IF NO IMPROVEMENT AFTER 3rd ITERATION C
IF(IIII.GE.3)THEN STOPPER=YYGMP(IIII)-YYGMP(IIII-1) IF(STOPPER.LE..0001)GO TO 919 ENDIF 99 CONTINUE 919 CONTINUE
C C
NMODEL=0 CALL PROX(NEP,KRC,ATIME,XMARK,XPLOG, C XDERV,XDERV1,XDERV2,XDERV3, C XBETA,OUTX0,OUTX1,OUTX2,OUTX3, C NFIRST,NLAST, C ZDF,NDEVIT,XDEVIT,NMODEL)
C
GMPNOW=EXP(XPLOG/FLOAT(KRC)) DO 666 K=1,NS SUM=0.0 DO 665 JJJ=1,NEPCONG SUM=SUM+XMARK(JJJ,K) 665 CONTINUE SUM=SUM/FLOAT(NEPCONG)
C WRITE(21,1002)SAVEGMP,GMPNOW,(XBETA(JJ,K),JJ=1,4), C C SUM,(XMARK(JJ,K),JJ=1,NEPCONG)
IF((SAVEGMP-GMPNOW).GT..00001)THEN WRITE(*,1003)NEP WRITE(21,1003)NEP
C STOP
ENDIF 666 CONTINUE
C C LOG-LIKELIHOOD OF CONSTANT MODEL C
XPLOG0=XPLOG XPLOG1=XPLOG XPLOG2=XPLOG XPLOG3=XPLOG
C
NINC=10
C
C C *********** C LINEAR TERM C *********** C
IF(NNMODEL.GE.1.AND.NEPCONG.GE.5)THEN NMODEL=1
C C INITIALIZE LINEAR BETAS TO ZERO SO STARTING LOG-LIKELIHOOD C IS EQUAL TO THE THE ENDING LOG-LIKELIHOOD OF CONSTANT C MODEL C
DO 41 K=1,NS XBETA(2,K)=0.0 41 CONTINUE
C
DO 999 IIII=1,10
C
DO 30 K=1,NS XBETASV(2,K)=XBETA(2,K) XXX(K)=0.0 30 CONTINUE
C
DO 31 K=1,NS XDERV(K)=0.0 XDERV1(K)=0.0 XDERV2(K)=0.0 XDERV3(K)=0.0 31 CONTINUE
C C GET DERIVATIVES C
CALL PROX(NEP,KRC,ATIME,XMARK,XPLOG, C XDERV,XDERV1,XDERV2,XDERV3, C XBETASV,OUTX0,OUTX1,OUTX2,OUTX3, C NFIRST,NLAST, C ZDF,NDEVIT,XDEVIT,NMODEL)
C C SAVE INITIAL LOG-LIKELIHOOD C
IF(IIII.EQ.1)THEN SAVEGMP=EXP(XPLOG/FLOAT(KRC)) ENDIF
C
GMP=EXP(XPLOG/FLOAT(KRC)) ASUMA=0.0 DO 32 K=1,NS XXX(K)=XDERV1(K)/FLOAT(KRC) ASUMA=ASUMA+XXX(K)**2 32 CONTINUE
C C CALCULATE STEPSIZE IN .01 UNITS C
STEP=.01/SQRT(ASUMA)
C
C C SEARCH ALONG VECTOR IN BEST DIRECTION C C
XINC=0.0
C
DO 312 KK=1,NINC SUM=0.0 DO 34 K=1,NS
C C ***** C CHECK FOR SIGN OF DERIVATIVE FOR GRADIENT!!!!!!!! C ***** C
XBETA(2,K)=XBETASV(2,K)-XINC*XXX(K)
C
34 CONTINUE
C
DO 35 K=1,NS XDERV(K)=0.0 XDERV1(K)=0.0 XDERV2(K)=0.0 XDERV3(K)=0.0 35 CONTINUE
C C GET DERIVATIVES C
CALL PROX(NEP,KRC,ATIME,XMARK,XPLOG, C XDERV,XDERV1,XDERV2,XDERV3, C XBETA,OUTX0,OUTX1,OUTX2,OUTX3, C NFIRST,NLAST, C ZDF,NDEVIT,XDEVIT,NMODEL)
C
GMP=EXP(XPLOG/FLOAT(KRC))
C
YGMP(KK)=GMP LLL(KK)=KK DO 36 K=1,NS YGAMMA(KK,K)=XBETA(2,K) XXXSAVE(KK,K)=XXX(K) 36 CONTINUE YLOG(KK)=XPLOG
C C WRITE(27,205)NEP,NEPCONG,IIII,KK,NMODEL,YLOG(KK),YGMP(KK), C C (YGAMMA(KK,K),K=1,NS),(XBETASV(2,K),K=1,NS), C C (XXX(K),K=1,NS),XINC C
XINC=XINC+STEP 312 CONTINUE
C
NNINC=NINC
C C FIND MAXIMUM ON BEST DIRECTION THROUGH THE SPACE C
CALL RSORT(YGMP,NNINC,LLL)
C WRITE(27,205)NEP,NEPCONG,IIII,LLL(NNINC),NMODEL, C C YLOG(LLL(NNINC)), C C YGMP(NNINC),(YGAMMA(LLL(NNINC),K),K=1,NS), C C (XBETA(2,K),K=1,NS),(XXXSAVE(LLL(NNINC),K),K=1,NS)
DO 37 K=1,NS XBETA(2,K)=YGAMMA(LLL(NNINC),K) XBETASV(2,K)=XBETA(2,K) 37 CONTINUE
C C STORE GMP C
YYGMP(IIII)=YGMP(NNINC)
C C EXIT THE SEARCH IF NO IMPROVEMENT AFTER 3rd ITERATION C
IF(IIII.GE.3)THEN STOPPER=YYGMP(IIII)-YYGMP(IIII-1) IF(STOPPER.LE..0001)GO TO 929 ENDIF 999 CONTINUE 929 CONTINUE
C C
CALL PROX(NEP,KRC,ATIME,XMARK,XPLOG, C XDERV,XDERV1,XDERV2,XDERV3, C XBETA,OUTX0,OUTX1,OUTX2,OUTX3, C NFIRST,NLAST, C ZDF,NDEVIT,XDEVIT,NMODEL)
C
GMPNOW=EXP(XPLOG/FLOAT(KRC)) DO 766 K=1,NS SUM=0.0 DO 664 JJJ=1,NEPCONG SUM=SUM+XMARK(JJJ,K) 664 CONTINUE SUM=SUM/FLOAT(NEPCONG)
C WRITE(21,1002)SAVEGMP,GMPNOW,(XBETA(JJ,K),JJ=1,4), C C SUM,(XMARK(JJ,K),JJ=1,NEPCONG)
IF((SAVEGMP-GMPNOW).GT..00001)THEN WRITE(*,1003)NEP STOP ENDIF 766 CONTINUE
C C LOG-LIKELIHOOD OF LINEAR MODEL C
XPLOG1=XPLOG XPLOG2=XPLOG XPLOG3=XPLOG
C
ENDIF
C
C
C C *********** C QUADRATIC TERM C *********** C
IF(NNMODEL.GE.2.AND.NEPCONG.GE.6)THEN NMODEL=2
C C INITIALIZE QUADRATIC BETAS TO ZERO SO STARTING LOG-LIKELIHOOD C IS EQUAL TO THE THE ENDING LOG-LIKELIHOOD OF LINEAR C MODEL C
DO 71 K=1,NS XBETA(3,K)=0.0 71 CONTINUE
C
DO 998 IIII=1,10
C
DO 72 K=1,NS XBETASV(3,K)=XBETA(3,K) XXX(K)=0.0 72 CONTINUE
C
DO 73 K=1,NS XDERV(K)=0.0 XDERV1(K)=0.0 XDERV2(K)=0.0 XDERV3(K)=0.0 73 CONTINUE
C C GET DERIVATIVES C
CALL PROX(NEP,KRC,ATIME,XMARK,XPLOG, C XDERV,XDERV1,XDERV2,XDERV3, C XBETASV,OUTX0,OUTX1,OUTX2,OUTX3, C NFIRST,NLAST, C ZDF,NDEVIT,XDEVIT,NMODEL)
C C SAVE INITIAL LOG-LIKELIHOOD C
IF(IIII.EQ.1)THEN SAVEGMP=EXP(XPLOG/FLOAT(KRC)) ENDIF
C
GMP=EXP(XPLOG/FLOAT(KRC)) ASUMA=0.0 DO 74 K=1,NS XXX(K)=XDERV2(K)/FLOAT(KRC) ASUMA=ASUMA+XXX(K)**2 74 CONTINUE
C C CALCULATE STEPSIZE IN .01 UNITS C
STEP=.01/SQRT(ASUMA)
C
C C SEARCH ALONG VECTOR IN BEST DIRECTION C C
XINC=0.0
C
DO 712 KK=1,NINC SUM=0.0 DO 75 K=1,NS
C C ***** C CHECK FOR SIGN OF DERIVATIVE FOR GRADIENT!!!!!!!! C ***** C
XBETA(3,K)=XBETASV(3,K)-XINC*XXX(K)
C
75 CONTINUE
C
DO 76 K=1,NS XDERV(K)=0.0 XDERV1(K)=0.0 XDERV2(K)=0.0 XDERV3(K)=0.0 76 CONTINUE
C C GET DERIVATIVES C
CALL PROX(NEP,KRC,ATIME,XMARK,XPLOG, C XDERV,XDERV1,XDERV2,XDERV3, C XBETA,OUTX0,OUTX1,OUTX2,OUTX3, C NFIRST,NLAST, C ZDF,NDEVIT,XDEVIT,NMODEL)
C
GMP=EXP(XPLOG/FLOAT(KRC))
C
YGMP(KK)=GMP LLL(KK)=KK DO 77 K=1,NS YGAMMA(KK,K)=XBETA(3,K) XXXSAVE(KK,K)=XXX(K) 77 CONTINUE YLOG(KK)=XPLOG
C C WRITE(27,205)NEP,NEPCONG,IIII,KK,NMODEL,YLOG(KK),YGMP(KK), C C (YGAMMA(KK,K),K=1,NS),(XBETASV(3,K),K=1,NS), C C (XXX(K),K=1,NS),XINC C
XINC=XINC+STEP 712 CONTINUE
C
NNINC=NINC
C C FIND MAXIMUM ON BEST DIRECTION THROUGH THE SPACE C
CALL RSORT(YGMP,NNINC,LLL)
C WRITE(27,205)NEP,NEPCONG,IIII,LLL(NNINC),NMODEL, C C YLOG(LLL(NNINC)), C C YGMP(NNINC),(YGAMMA(LLL(NNINC),K),K=1,NS), C C (XBETA(3,K),K=1,NS),(XXXSAVE(LLL(NNINC),K),K=1,NS)
DO 78 K=1,NS XBETA(3,K)=YGAMMA(LLL(NNINC),K) XBETASV(3,K)=XBETA(3,K) 78 CONTINUE
C C STORE GMP C
YYGMP(IIII)=YGMP(NNINC)
C C EXIT THE SEARCH IF NO IMPROVEMENT AFTER 3rd ITERATION C
IF(IIII.GE.3)THEN STOPPER=YYGMP(IIII)-YYGMP(IIII-1) IF(STOPPER.LE..0001)GO TO 979 ENDIF 998 CONTINUE 979 CONTINUE
C C
CALL PROX(NEP,KRC,ATIME,XMARK,XPLOG, C XDERV,XDERV1,XDERV2,XDERV3, C XBETA,OUTX0,OUTX1,OUTX2,OUTX3, C NFIRST,NLAST, C ZDF,NDEVIT,XDEVIT,NMODEL)
C
GMPNOW=EXP(XPLOG/FLOAT(KRC)) DO 79 K=1,NS SUM=0.0 DO 764 JJJ=1,NEPCONG SUM=SUM+XMARK(JJJ,K) 764 CONTINUE SUM=SUM/FLOAT(NEPCONG)
C WRITE(21,1002)SAVEGMP,GMPNOW,(XBETA(JJ,K),JJ=1,4), C C SUM,(XMARK(JJ,K),JJ=1,NEPCONG)
IF((SAVEGMP-GMPNOW).GT..00001)THEN WRITE(*,1003)NEP STOP ENDIF 79 CONTINUE
C C LOG-LIKELIHOOD OF QUADRATIC MODEL C
XPLOG2=XPLOG XPLOG3=XPLOG
C
ENDIF
C
C
C C *********** C CUBIC TERM C *********** C
IF(NNMODEL.GE.3.AND.NEPCONG.GE.7)THEN NMODEL=3
C C INITIALIZE CUBIC BETAS TO ZERO SO STARTING LOG-LIKELIHOOD C IS EQUAL TO THE THE ENDING LOG-LIKELIHOOD OF QUADRATIC C MODEL C
DO 81 K=1,NS XBETA(4,K)=0.0 81 CONTINUE
C
DO 997 IIII=1,10
C
DO 82 K=1,NS XBETASV(4,K)=XBETA(4,K) XXX(K)=0.0 82 CONTINUE
C
DO 83 K=1,NS XDERV(K)=0.0 XDERV1(K)=0.0 XDERV2(K)=0.0 XDERV3(K)=0.0 83 CONTINUE
C C GET DERIVATIVES C
CALL PROX(NEP,KRC,ATIME,XMARK,XPLOG, C XDERV,XDERV1,XDERV2,XDERV3, C XBETASV,OUTX0,OUTX1,OUTX2,OUTX3, C NFIRST,NLAST, C ZDF,NDEVIT,XDEVIT,NMODEL)
C C SAVE INITIAL LOG-LIKELIHOOD C
IF(IIII.EQ.1)THEN SAVEGMP=EXP(XPLOG/FLOAT(KRC)) ENDIF
C
GMP=EXP(XPLOG/FLOAT(KRC)) ASUMA=0.0 DO 84 K=1,NS XXX(K)=XDERV3(K)/FLOAT(KRC) ASUMA=ASUMA+XXX(K)**2 84 CONTINUE
C C CALCULATE STEPSIZE IN .01 UNITS C
STEP=.01/SQRT(ASUMA)
C
C C SEARCH ALONG VECTOR IN BEST DIRECTION C C
XINC=0.0
C
DO 812 KK=1,NINC SUM=0.0 DO 85 K=1,NS
C C ***** C CHECK FOR SIGN OF DERIVATIVE FOR GRADIENT!!!!!!!! C ***** C
XBETA(4,K)=XBETASV(4,K)-XINC*XXX(K)
C
85 CONTINUE
C
DO 86 K=1,NS XDERV(K)=0.0 XDERV1(K)=0.0 XDERV2(K)=0.0 XDERV3(K)=0.0 86 CONTINUE
C C GET DERIVATIVES C
CALL PROX(NEP,KRC,ATIME,XMARK,XPLOG, C XDERV,XDERV1,XDERV2,XDERV3, C XBETA,OUTX0,OUTX1,OUTX2,OUTX3, C NFIRST,NLAST, C ZDF,NDEVIT,XDEVIT,NMODEL)
C
GMP=EXP(XPLOG/FLOAT(KRC))
C
YGMP(KK)=GMP LLL(KK)=KK DO 87 K=1,NS YGAMMA(KK,K)=XBETA(4,K) XXXSAVE(KK,K)=XXX(K) 87 CONTINUE YLOG(KK)=XPLOG
C C WRITE(27,205)NEP,NEPCONG,IIII,KK,NMODEL,YLOG(KK),YGMP(KK), C C (YGAMMA(KK,K),K=1,NS),(XBETASV(4,K),K=1,NS), C C (XXX(K),K=1,NS),XINC C
XINC=XINC+STEP 812 CONTINUE
C
NNINC=NINC
C C FIND MAXIMUM ON BEST DIRECTION THROUGH THE SPACE C
CALL RSORT(YGMP,NNINC,LLL)
C WRITE(27,205)NEP,NEPCONG,IIII,LLL(NNINC),NMODEL, C C YLOG(LLL(NNINC)), C C YGMP(NNINC),(YGAMMA(LLL(NNINC),K),K=1,NS), C C (XBETA(4,K),K=1,NS),(XXXSAVE(LLL(NNINC),K),K=1,NS)
DO 88 K=1,NS XBETA(4,K)=YGAMMA(LLL(NNINC),K) XBETASV(4,K)=XBETA(4,K) 88 CONTINUE
C C STORE GMP C
YYGMP(IIII)=YGMP(NNINC)
C C EXIT THE SEARCH IF NO IMPROVEMENT AFTER 3rd ITERATION C
IF(IIII.GE.3)THEN STOPPER=YYGMP(IIII)-YYGMP(IIII-1) IF(STOPPER.LE..0001)GO TO 989 ENDIF 997 CONTINUE 989 CONTINUE
C C
CALL PROX(NEP,KRC,ATIME,XMARK,XPLOG, C XDERV,XDERV1,XDERV2,XDERV3, C XBETA,OUTX0,OUTX1,OUTX2,OUTX3, C NFIRST,NLAST, C ZDF,NDEVIT,XDEVIT,NMODEL)
C
GMPNOW=EXP(XPLOG/FLOAT(KRC)) DO 89 K=1,NS SUM=0.0 DO 864 JJJ=1,NEPCONG SUM=SUM+XMARK(JJJ,K) 864 CONTINUE SUM=SUM/FLOAT(NEPCONG)
C WRITE(21,1002)SAVEGMP,GMPNOW,(XBETA(JJ,K),JJ=1,4), C C SUM,(XMARK(JJ,K),JJ=1,NEPCONG)
IF((SAVEGMP-GMPNOW).GT..00001)THEN WRITE(*,1003)NEP STOP ENDIF 89 CONTINUE
C C LOG-LIKELIHOOD OF CUBIC MODEL C
XPLOG3=XPLOG
C
ENDIF
C
C
KXTOT=KRC
C C INVERT OUTER PRODUCT MATRIX TO GET STANDARD ERRORS C C ***CONSTANT MODEL*** C C WRITE(33,102)NEP,NS,(OUTX0(1,J),J=1,NS) C WRITE(33,102)NEP,NS,(OUTX0(2,J),J=1,NS)
call rs(99,NS,OUTX0,wvec,1,ZMAT,fv1,fv2,ier)
C WRITE(33,101)NEP,NS,IER C WRITE(33,102)NEP,NS,(WVEC(J),J=1,NS) C WRITE(33,102)KRC,NEPCONG,(XDERV(J),J=1,NS) C WRITE(33,103)(XDERV1(J),J=1,NS) C C (X’X)-1 C
DO 60 I=1,NS DERVISH(1,I)=XDERV(I)/FLOAT(KRC) DERVISH(2,I)=XDERV1(I)/FLOAT(KRC) DERVISH(3,I)=XDERV2(I)/FLOAT(KRC) DERVISH(4,I)=XDERV3(I)/FLOAT(KRC) DO 60 K=1,NS SUM=0.0 DO 62 J=1,NS IF(ABS(WVEC(NS+1-J)).GT..0001)THEN SUM=SUM+ZMAT(K,NS+1-J)*(1.0/WVEC(NS+1-J))*ZMAT(I,NS+1-J) ENDIF 62 CONTINUE 60 OUTX0(I,K)=SUM
C C ***LINEAR MODEL C
IF(NEPCONG.GE.5)THEN call rs(99,2*NS,OUTX1,wvec,1,ZMAT,fv1,fv2,ier)
C WRITE(33,101)NEP,NS,IER C WRITE(33,102)NEP,NS,(WVEC(J),J=1,2*NS) C C (X’X)-1 C
DO 63 I=1,2*NS DO 63 K=1,2*NS SUM=0.0 DO 64 J=1,2*NS IF(ABS(WVEC(2*NS+1-J)).GT..0001)THEN SUM=SUM+ZMAT(K,2*NS+1-J)* C (1.0/WVEC(2*NS+1-J))*ZMAT(I,2*NS+1-J) ENDIF 64 CONTINUE 63 OUTX1(I,K)=SUM ENDIF
C C ***QUADRATIC MODEL C
IF(NEPCONG.GE.6)THEN call rs(99,3*NS,OUTX2,wvec,1,ZMAT,fv1,fv2,ier)
C WRITE(33,101)NEP,NS,IER C WRITE(33,102)NEP,NS,(WVEC(J),J=1,NS) C C (X’X)-1 C
DO 65 I=1,3*NS DO 65 K=1,3*NS SUM=0.0 DO 66 J=1,3*NS IF(ABS(WVEC(3*NS+1-J)).GT..0001)THEN SUM=SUM+ZMAT(K,3*NS+1-J)* C (1.0/WVEC(3*NS+1-J))*ZMAT(I,3*NS+1-J) ENDIF 66 CONTINUE 65 OUTX2(I,K)=SUM ENDIF
C C ***CUBIC MODEL C
IF(NEPCONG.GE.7)THEN call rs(99,4*NS,OUTX3,wvec,1,ZMAT,fv1,fv2,ier)
C WRITE(33,101)NEP,NS,IER C WRITE(33,102)NEP,NS,(WVEC(J),J=1,NS) C C (X’X)-1 C
DO 67 I=1,4*NS DO 67 K=1,4*NS SUM=0.0 DO 68 J=1,4*NS IF(ABS(WVEC(4*NS+1-J)).GT..0001)THEN SUM=SUM+ZMAT(K,4*NS+1-J)* C (1.0/WVEC(4*NS+1-J))*ZMAT(I,4*NS+1-J) ENDIF 68 CONTINUE 67 OUTX3(I,K)=SUM ENDIF
C
RETURN END
C C ************************************************************************** C SUBROUTINE REGA—CALLED BY REG2. PERFORMS THE REGRESSION: C C [W’W]-1*W’[X(I,NY) - c’] C C TO GET THE ROW ENTRIES OF P. C ************************************************************************** C
SUBROUTINE REGA(NS,NF,A,Y,V) DIMENSION A(152,127),Y(152),B(127,127),C(127,127),V(152), CBB(127,152),ZMAT(127,127),FV1(127),FV2(127),WVEC(127) COMMON /AREA1/ JR,LR 101 FORMAT(' PERFORMANCE INDEX EIGENVALUE/VECTOR ROUTINE=',3I5) 102 FORMAT(2I5,30F10.4)
C C X’X C
DO 7 J=1,152 V(J)=0.0 7 CONTINUE DO 1 J=1,NF DO 1 JJ=1,NF SUM=0.0 DO 2 I=1,NS 2 SUM=SUM+A(I,J)*A(I,JJ) 1 B(J,JJ)=SUM call rs(127,nf,B,wvec,1,ZMAT,fv1,fv2,ier)
C WRITE(33,101)NS,NF,IER C WRITE(33,102)NS,NF,(WVEC(J),J=1,NF) C WRITE(33,102)NS,NF,(B(1,J),J=1,NF) C WRITE(33,102)NS,NF,(B(2,J),J=1,NF) C WRITE(33,102)NS,NF,(B(3,J),J=1,NF) C WRITE(33,102)NS,NF,(B(4,J),J=1,NF) C C (X’X)-1 C
DO 60 I=1,NF DO 60 K=1,NF SUM=0.0 DO 61 J=1,NF IF(ABS(WVEC(J)).GT..01)THEN SUM=SUM+ZMAT(K,J)*(1.0/WVEC(J))*ZMAT(I,J) ENDIF 61 CONTINUE 60 C(I,K)=SUM
C C (X’X)-1X’ C
DO 3 I=1,NS DO 3 J=1,NF SUM=0.0 DO 4 JJ=1,NF 4 SUM=SUM+C(J,JJ)*A(I,JJ) 3 BB(J,I)=SUM
C C BETA = (X’X)-1X’Y C
DO 5 JJ=1,NF SUM=0.0 DO 6 J=1,NS 6 SUM=SUM+BB(JJ,J)*Y(J) 5 V(JJ)=SUM RETURN END
C C *************************************************************************** C SUBROUTINE PROLLC2–CALCULATES DERIVATIVES AND LOG-LIKELIHOODS FOR THE C ROLL CALL PARAMETERS FOR THE NOMINATE PROBIT
C MODEL
C *************************************************************************** C
SUBROUTINE PROLLC2(IICONG,NEQ,NPC,KTOT,KTOTP,KTOTQ, C XPLOG,OLDZ,OLDD,DDERV,ZDERV, C ZDF,NDEVIT,XDEVIT) DIMENSION ZDF(150000,4),DYES(99),DNO(99),DYES1(99),DNO1(99), C DCC(99),DBB(99),DCC1(99),DBB1(99),ZDERV(99), C DDERV(99),OLDZ(99),OLDD(99) LOGICAL*1 RCVOTE1,RCVOTE9,RCVOTET1,RCVOTET9,RCBAD,LWHERE COMMON /XXCOM/ ZMID(99001,2),XDATA(54001,9),DYN(99001,2), C RCVOTE1(54001,2901),RCVOTE9(54001,2901), C RCVOTET1(99001,660),RCVOTET9(99001,660), C RCBAD(99001),LWHERE(99999,111), C NUMCONG(200),MCONG(200,3),ICONG(99001), C INUM(99001),WEIGHT(99),NUMCONGT(200), C NCONG(54001),KWHERE(99999,111), C XBIGLOG(54001,2),KBIGLOG(54001,4) COMMON /MINE/ NS,NQTOT,NPTOT,KLASS, C KLASSYY,KLASSNY,KLASSYN,KLASSNN 100 FORMAT(8F7.3) 1001 FORMAT(I4,F5.2,F10.7) 1002 FORMAT(' R-C ',I3,3I5,F7.3,F13.5,2F10.4,2F7.3)
C
XPLOG=0.0 KLASS=0 KLASSYY=0 KLASSNY=0 KLASSYN=0 KLASSNN=0 KLASS2=0 DO 8 K=1,NS ZDERV(K)=0.0 DDERV(K)=0.0 8 CONTINUE
C
KTOT=0 DO 2 I=1,NPC DO 3 K=1,NS DYES(K)=0.0 DNO(K)=0.0 DYES1(K)=0.0 DNO1(K)=0.0 DYES(K)=(XDATA(I+KTOTP,K)-OLDZ(K)+OLDD(K))**2 DNO(K) =(XDATA(I+KTOTP,K)-OLDZ(K)-OLDD(K))**2 DYES1(K)=(XDATA(I+KTOTP,K)-OLDZ(K)+OLDD(K)) DNO1(K) =(XDATA(I+KTOTP,K)-OLDZ(K)-OLDD(K)) 3 CONTINUE
C C IF NOT MISSING DATA C
IF(RCVOTE9(I+KTOTP,NEQ).EQV..FALSE.)THEN KTOT=KTOT+1
C C IF YES C
IF(RCVOTE1(I+KTOTP,NEQ).EQV..TRUE.)THEN DC=0.0 DB=0.0 DO 4 K=1,NS DC=DC+(-WEIGHT(K)*WEIGHT(K)*DYES(K)) DB=DB+(-WEIGHT(K)*WEIGHT(K)*DNO(K)) DCC(K)=DYES(K) DBB(K)=DNO(K) DCC1(K)=DYES1(K)*WEIGHT(K)*WEIGHT(K) DBB1(K)=DNO1(K)*WEIGHT(K)*WEIGHT(K) 4 CONTINUE XCC=+1.0 ENDIF
C C IF NO C
IF(RCVOTE1(I+KTOTP,NEQ).EQV..FALSE.)THEN DC=0.0 DB=0.0 DO 5 K=1,NS DC=DC+(-WEIGHT(K)*WEIGHT(K)*DNO(K)) DB=DB+(-WEIGHT(K)*WEIGHT(K)*DYES(K)) DCC(K)=DNO(K) DBB(K)=DYES(K) DCC1(K)=DNO1(K)*WEIGHT(K)*WEIGHT(K) DBB1(K)=DYES1(K)*WEIGHT(K)*WEIGHT(K) 5 CONTINUE XCC=-1.0 ENDIF
C
ZS=WEIGHT(NS+1)*(EXP(DC)-EXP(DB))
C
IF(ABS(DC).LE.ABS(DB))KLASS=KLASS+1 IF(ABS(DC).LE.ABS(DB).AND.XCC.EQ.+1.0)THEN KLASSYY=KLASSYY+1 ENDIF IF(ABS(DC).GT.ABS(DB).AND.XCC.EQ.+1.0)THEN KLASSNY=KLASSNY+1 ENDIF IF(ABS(DC).GT.ABS(DB).AND.XCC.EQ.-1.0)THEN KLASSYN=KLASSYN+1 ENDIF IF(ABS(DC).LE.ABS(DB).AND.XCC.EQ.-1.0)THEN KLASSNN=KLASSNN+1 ENDIF IF(ZS.GT.0.0)KLASS2=KLASS2+1
C
WWIMJ=ZS*XDEVIT KWIMJ=IFIX(ABS(WWIMJ)+.5) IF(KWIMJ.GT.NDEVIT-2)KWIMJ=NDEVIT-2 IF(ZS.GE.0.0)THEN ZDISTF=ZDF(NDEVIT-1+KWIMJ+1,2) CDFLOG=ZDF(NDEVIT-1+KWIMJ+1,3) ENDIF IF(ZS.LT.0.0)THEN ZDISTF=ZDF(NDEVIT-KWIMJ,2) CDFLOG=ZDF(NDEVIT-KWIMJ,3) ENDIF XPLOG=XPLOG+CDFLOG ZGAUSS=EXP(-(ZS*ZS)/2.0) DO 6 K=1,NS ZDERV(K)=ZDERV(K)+(ZGAUSS/ZDISTF)* C (-DCC1(K)*EXP(DC)+DBB1(K)*EXP(DB)) DDERV(K)=DDERV(K)+XCC*(ZGAUSS/ZDISTF)* C ( DCC1(K)*EXP(DC)+DBB1(K)*EXP(DB)) 6 CONTINUE ENDIF 2 CONTINUE GMP=EXP(XPLOG/FLOAT(KTOT)) RETURN END
C C *************************************************************************** C SUBROUTINE RCINT2—FINDS ROLL CALL PARAMETERS C *************************************************************************** C
SUBROUTINE RCINT2(IICONG,NEQ,NPC,NQC,KRC,KTOTP,KTOTQ, C XPLOG,OLDZ,OLDD, C ZDF,NDEVIT,XDEVIT) DIMENSION ZDF(150000,4),DDERVX(99),ZDERVX(99),OLDZ(99), C OLDD(99),DZSAVE(66),XXX(66),YGAMMA(50,66), C XXXSAVE(50,66),YLOG(50),LLL(50),YGMP(50), C YYGMP(50) LOGICAL*1 RCVOTE1,RCVOTE9,RCVOTET1,RCVOTET9,RCBAD,LWHERE COMMON /XXCOM/ ZMID(99001,2),XDATA(54001,9),DYN(99001,2), C RCVOTE1(54001,2901),RCVOTE9(54001,2901), C RCVOTET1(99001,660),RCVOTET9(99001,660), C RCBAD(99001),LWHERE(99999,111), C NUMCONG(200),MCONG(200,3),ICONG(99001), C INUM(99001),WEIGHT(99),NUMCONGT(200), C NCONG(54001),KWHERE(99999,111), C XBIGLOG(54001,2),KBIGLOG(54001,4) COMMON /MINE/ NS,NQTOT,NPTOT,KLASS, C KLASSYY,KLASSNY,KLASSYN,KLASSNN 203 FORMAT(I5,2I4,8X,I2,F12.5,20F10.4) 205 FORMAT(I6,2I5,5X,F12.5,20F10.4) 206 FORMAT(I5,4I4,I2,F12.5,20F10.4) 1001 FORMAT(' RCS',4I5,F7.3,5I4,20F7.3) 1002 FORMAT(I4,I5,2F12.5,20F7.3) 1003 FORMAT(' FATAL ERROR ROLL CALL PHASE',2I5) 1004 FORMAT(I4,I5,F12.5,12X,20F7.3)
C C INITIALIZE LOG-LIKELIHOOD C
CALL PROLLC2(IICONG,NEQ,NPC,KRC,KTOTP,KTOTQ, C XPLOG,OLDZ,OLDD,DDERVX,ZDERVX, C ZDF,NDEVIT,XDEVIT)
C WRITE(21,1004)IICONG,NEQ,EXP(XPLOG/FLOAT(KRC)), C C (OLDD(K),K=1,NS),(OLDZ(K),K=1,NS) C C CALCULATE NEW ROLL CALL COORDINATES WITH A C SIMPLE GRID SEARCH C
NINC=25 DO 9999 JJJJ=1,5
C C *********** C SPREAD TERM FIRST C *********** C
DO 99 IIII=1,10
C C ERROR CATCH C
DO 2 K=1,NS DZSAVE(K)=OLDZ(K) IF(ABS(OLDD(K)).LE..001)OLDD(K)=.03 DZSAVE(K+NS)=OLDD(K) XXX(K)=0.0 2 CONTINUE
C
DO 40 K=1,NS DDERVX(K)=0.0 ZDERVX(K)=0.0 40 CONTINUE
C C GET DERIVATIVES C
CALL PROLLC2(IICONG,NEQ,NPC,KRC,KTOTP,KTOTQ, C XPLOG,OLDZ,OLDD,DDERVX,ZDERVX, C ZDF,NDEVIT,XDEVIT)
C C SAVE INITIAL LOG-LIKELIHOOD C
IF(IIII.EQ.1)THEN SAVEGMP=EXP(XPLOG/FLOAT(KRC)) ENDIF
C
GMP=EXP(XPLOG/FLOAT(KRC)) SUMA=0.0 SUMB=0.0 KCATCH=0 DO 61 K=1,NS XXX(K)=ZDERVX(K)/FLOAT(KRC) XXX(K+NS)=DDERVX(K)/FLOAT(KRC) SUMA=SUMA+XXX(K)**2 SUMB=SUMB+XXX(K+NS)**2 IF(ABS(XXX(K+NS)).LE..0001)KCATCH=KCATCH+1 61 CONTINUE
C C ERROR CATCH IF ZERO DERIVATIVE C
KEXIT=0 IF(KCATCH.EQ.NS)THEN DO 661 K=1,NS DZSAVE(K+NS)=OLDD(K) KEXIT=1 661 CONTINUE ENDIF IF(KEXIT.EQ.1)GO TO 919
C C CALCULATE STEPSIZE IN .01 UNITS C
STEPZ=.01/SQRT(SUMA) STEPD=.01/SQRT(SUMB)
C
C C C SEARCH ALONG VECTOR IN BEST DIRECTION C C
XINCZ=0.0 XINCD=0.0
C
DO 212 KK=1,NINC SUM=0.0 DO 24 K=1,NS
C C ***** C CHECK FOR SIGN OF DERIVATIVE FOR GRADIENT!!!!!!!! C ***** C
OLDD(K)=DZSAVE(K+NS)-XINCD*XXX(K+NS)
C
24 CONTINUE DO 240 K=1,NS DDERVX(K)=0.0 ZDERVX(K)=0.0 240 CONTINUE
C C GET DERIVATIVES C
CALL PROLLC2(IICONG,NEQ,NPC,KRC,KTOTP,KTOTQ, C XPLOG,OLDZ,OLDD,DDERVX,ZDERVX, C ZDF,NDEVIT,XDEVIT)
C
GMP=EXP(XPLOG/FLOAT(KRC))
C
YGMP(KK)=GMP LLL(KK)=KK DO 222 K=1,NS YGAMMA(KK,K)=OLDZ(K) YGAMMA(KK,K+NS)=OLDD(K) XXXSAVE(KK,K)=XXX(K) XXXSAVE(KK,K+NS)=XXX(K+NS) 222 CONTINUE YLOG(KK)=XPLOG
C
XINCD=XINCD+STEPD 212 CONTINUE
C
NNINC=NINC
C C FIND MAXIMUM ON BEST DIRECTION THROUGH THE SPACE C
CALL RSORT(YGMP,NNINC,LLL) KEXIT=0 DO 224 K=1,NS OLDZ(K)=YGAMMA(LLL(NNINC),K) OLDD(K)=YGAMMA(LLL(NNINC),K+NS) DZSAVE(K)=OLDZ(K) DZSAVE(K+NS)=OLDD(K) IF(ABS(OLDD(K)).LE..001)THEN OLDD(K)=.03 DZSAVE(K+NS)=OLDD(K) KEXIT=1 ENDIF 224 CONTINUE
C C ERROR CATCH FOR ZERO DISTANCE C
IF(KEXIT.EQ.1)GO TO 919
C C STORE GMP C
YYGMP(IIII)=YGMP(NNINC)
C C EXIT THE SEARCH IF NO IMPROVEMENT AFTER 3rd ITERATION C
IF(IIII.GE.3)THEN STOPPER=YYGMP(IIII)-YYGMP(IIII-1) IF(STOPPER.LE..0001)GO TO 919 ENDIF 99 CONTINUE 919 CONTINUE
C C
CALL PROLLC2(IICONG,NEQ,NPC,KRC,KTOTP,KTOTQ, C XPLOG,OLDZ,OLDD,DDERVX,ZDERVX, C ZDF,NDEVIT,XDEVIT)
C
GMPNOW=EXP(XPLOG/FLOAT(KRC))
C WRITE(21,1002)IICONG,NEQ,SAVEGMP,GMPNOW, C C (OLDD(K),K=1,NS),(OLDZ(K),K=1,NS)
IF((SAVEGMP-GMPNOW).GT..00001)THEN
C WRITE(*,1003)IICONG,NEQ C WRITE(21,1003)IICONG,NEQ C STOP
ENDIF
C C C *********** C MIDPOINT SECOND C *********** C
DO 98 IIII=1,10
C
DO 32 K=1,NS DZSAVE(K)=OLDZ(K) DZSAVE(K+NS)=OLDD(K) XXX(K)=0.0 32 CONTINUE
C
DO 33 K=1,NS DDERVX(K)=0.0 ZDERVX(K)=0.0 33 CONTINUE
C C GET DERIVATIVES C
CALL PROLLC2(IICONG,NEQ,NPC,KRC,KTOTP,KTOTQ, C XPLOG,OLDZ,OLDD,DDERVX,ZDERVX, C ZDF,NDEVIT,XDEVIT)
C C SAVE INITIAL LOG-LIKELIHOOD C
IF(IIII.EQ.1)THEN SAVEGMP=EXP(XPLOG/FLOAT(KRC)) ENDIF
C
GMP=EXP(XPLOG/FLOAT(KRC)) SUMA=0.0 SUMB=0.0 DO 34 K=1,NS XXX(K)=ZDERVX(K)/FLOAT(KRC) XXX(K+NS)=DDERVX(K)/FLOAT(KRC) SUMA=SUMA+XXX(K)**2 SUMB=SUMB+XXX(K+NS)**2 34 CONTINUE
C C C CALCULATE STEPSIZE IN .01 UNITS C
STEPZ=.01/SQRT(SUMA) STEPD=.01/SQRT(SUMB)
C
C C IF(IICONG.EQ.45.AND.NEQ.EQ.20)THEN C IPHASE=1 C WRITE(27,203)NEQ,JJJJ,IIII,IPHASE,XPLOG,GMP, C C (DZSAVE(K),K=1,2*NS),(XXX(K),K=1,2*NS),STEPZ,STEPD C ENDIF C C C SEARCH ALONG VECTOR IN BEST DIRECTION C C
XINCZ=0.0 XINCD=0.0
C
DO 213 KK=1,NINC SUM=0.0 DO 35 K=1,NS
C C ***** C CHECK FOR SIGN OF DERIVATIVE FOR GRADIENT!!!!!!!! C ***** C
OLDZ(K)=DZSAVE(K)-XINCZ*XXX(K)
C
SUM=SUM+OLDZ(K)**2 35 CONTINUE
C C CHECK TO SEE IF ROLL CALL MIDPOINT OUTSIDE UNIT HYPERSPHERE C
IF(SUM.GT.1.0)THEN
C C RESET LEGISLATOR POINT TO SURFACE OF UNIT HYPERSPHERE AND C CALCULATE DERIVATIVES AND LOG-LIKELIHOODS. THEN EXIT C SEARCH LOOP C
DO 36 K=1,NS OLDZ(K)=OLDZ(K)/SQRT(SUM) 36 CONTINUE DO 37 K=1,NS DDERVX(K)=0.0 ZDERVX(K)=0.0 37 CONTINUE CALL PROLLC2(IICONG,NEQ,NPC,KRC,KTOTP,KTOTQ, C XPLOG,OLDZ,OLDD,DDERVX,ZDERVX, C ZDF,NDEVIT,XDEVIT)
C
GMP=EXP(XPLOG/FLOAT(KRC))
C
YGMP(KK)=GMP LLL(KK)=KK DO 38 K=1,NS YGAMMA(KK,K)=OLDZ(K) YGAMMA(KK,K+NS)=OLDD(K) XXXSAVE(KK,K)=XXX(K) XXXSAVE(KK,K+NS)=XXX(K+NS) 38 CONTINUE YLOG(KK)=XPLOG GO TO 2113 ENDIF DO 39 K=1,NS DDERVX(K)=0.0 ZDERVX(K)=0.0 39 CONTINUE
C C GET DERIVATIVES C
CALL PROLLC2(IICONG,NEQ,NPC,KRC,KTOTP,KTOTQ, C XPLOG,OLDZ,OLDD,DDERVX,ZDERVX, C ZDF,NDEVIT,XDEVIT)
C
GMP=EXP(XPLOG/FLOAT(KRC))
C
YGMP(KK)=GMP LLL(KK)=KK DO 41 K=1,NS YGAMMA(KK,K)=OLDZ(K) YGAMMA(KK,K+NS)=OLDD(K) XXXSAVE(KK,K)=XXX(K) XXXSAVE(KK,K+NS)=XXX(K+NS) 41 CONTINUE YLOG(KK)=XPLOG
C C IF(IICONG.EQ.45.AND.NEQ.EQ.20)THEN C IPHASE=1 C WRITE(27,206)NEQ,JJJJ,IIII,KRC,KK,IPHASE,YLOG(KK),YGMP(KK), C C (YGAMMA(KK,K),K=1,NS),(DZSAVE(K),K=1,NS), C C (XXX(K),K=1,NS),XINCZ C ENDIF C
XINCZ=XINCZ+STEPZ 213 CONTINUE
C
NNINC=NINC GO TO 2115 2113 NNINC=KK 2115 CONTINUE
C C FIND MAXIMUM ON BEST DIRECTION THROUGH THE SPACE C
CALL RSORT(YGMP,NNINC,LLL)
C IF(IICONG.EQ.45.AND.NEQ.EQ.20)THEN C IPHASE=1 C WRITE(27,206)NEQ,JJJJ,IIII,KRC,LLL(NNINC),IPHASE,YLOG(LLL(NNINC)), C C YGMP(NNINC),(YGAMMA(LLL(NNINC),K),K=1,NS), C C (DZSAVE(K),K=1,NS), C C (XXXSAVE(LLL(NNINC),K),K=1,NS) C ENDIF
DO 42 K=1,NS OLDZ(K)=YGAMMA(LLL(NNINC),K) OLDD(K)=YGAMMA(LLL(NNINC),K+NS) DZSAVE(K)=OLDZ(K) DZSAVE(K+NS)=OLDD(K) 42 CONTINUE
C C STORE GMP C
YYGMP(IIII)=YGMP(NNINC)
C C EXIT THE SEARCH IF NO IMPROVEMENT AFTER 3rd ITERATION C
IF(IIII.GE.3)THEN STOPPER=YYGMP(IIII)-YYGMP(IIII-1) IF(STOPPER.LE..0001)GO TO 909 ENDIF 98 CONTINUE 909 CONTINUE
C C
CALL PROLLC2(IICONG,NEQ,NPC,KRC,KTOTP,KTOTQ, C XPLOG,OLDZ,OLDD,DDERVX,ZDERVX, C ZDF,NDEVIT,XDEVIT)
C
GMPNOW=EXP(XPLOG/FLOAT(KRC))
C WRITE(21,1002)IICONG,NEQ,SAVEGMP,GMPNOW, C C (OLDD(K),K=1,NS),(OLDZ(K),K=1,NS)
IF((SAVEGMP-GMPNOW).GT..00001)THEN
C WRITE(*,1003)IICONG,NEQ C WRITE(21,1003)IICONG,NEQ C STOP
ENDIF
C
9999 CONTINUE RETURN END
C C C ************************************************************************ C SORT SUBROUTINE–SORTS A VECTOR ‘A’ OF REAL ELEMENTS INTO ASCENDING C ORDER. ‘LA’ IS THE NUMBER OF ELEMENTS TO BE SORTED AND ‘IR’ IS A C VECTOR OF INTEGERS THAT RECORDS THE PERMUTATIONS–USUALLY SET TO C 1,2,3,4,… C ************************************************************************ C C
SUBROUTINE RSORT(A,LA,IR) DIMENSION A(LA),IU(21),IL(21),IR(LA) IF (LA.LE.0) RETURN M = 1 I = 1 J = LA R = .375 5 IF (I.EQ.J) GO TO 45 IF (R.GT..5898437) GO TO 10 R = R+3.90625E-2 GO TO 15 10 R = R-.21875 15 K = I
C C SELECT A CENTRAL ELEMENT OF THE
C ARRAY AND SAVE IT IN LOCATION T
C
IJ = I+(J-I)*R T = A(IJ) IT = IR(IJ)
C C FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T
C
IF (A(I).LE.T) GO TO 20 A(IJ) = A(I) A(I) = T T = A(IJ) IR(IJ) = IR(I) IR(I) = IT IT = IR(IJ) 20 L = J
C C IF LAST ELEMENT OF ARRAY IS LESS THAN C T, INTERCHANGE WITH T C
IF (A(J).GE.T) GO TO 30 A(IJ) = A(J) A(J) = T T = A(IJ) IR(IJ) = IR(J) IR(J) = IT IT = IR(IJ)
C C IF FIRST ELEMENT OF ARRAY IS GREATER C THAN T, INTERCHANGE WITH T C
IF (A(I).LE.T) GO TO 30 A(IJ) = A(I) A(I) = T T = A(IJ) IR(IJ) = IR(I) IR(I) = IT IT = IR(IJ) GO TO 30 25 IF (A(L).EQ.A(K)) GO TO 30 TT = A(L) A(L) = A(K) A(K) = TT ITT = IR(L) IR(L) = IR(K) IR(K) = ITT
C C FIND AN ELEMENT IN THE SECOND HALF OF C THE ARRAY WHICH IS SMALLER THAN T C
30 L = L-1 IF (A(L).GT.T) GO TO 30
C C FIND AN ELEMENT IN THE FIRST HALF OF C THE ARRAY WHICH IS GREATER THAN T C
35 K = K+1 IF (A(K).LT.T) GO TO 35
C C INTERCHANGE THESE ELEMENTS C
IF (K.LE.L) GO TO 25
C C SAVE UPPER AND LOWER SUBSCRIPTS OF C THE ARRAY YET TO BE SORTED C
IF (L-I.LE.J-K) GO TO 40 IL(M) = I IU(M) = L I = K M = M+1 GO TO 50 40 IL(M) = K IU(M) = J J = L M = M+1 GO TO 50
C C BEGIN AGAIN ON ANOTHER PORTION OF C THE UNSORTED ARRAY C
45 M = M-1 IF (M.EQ.0) RETURN I = IL(M) J = IU(M) 50 IF (J-I.GE.11) GO TO 15 IF (I.EQ.1) GO TO 5 I = I-1 55 I = I+1 IF (I.EQ.J) GO TO 45 T = A(I+1) IT = IR(I+1) IF (A(I).LE.T) GO TO 55 K = I 60 A(K+1) = A(K) IR(K+1) = IR(K) K = K-1 IF (T.LT.A(K)) GO TO 60 A(K+1) = T IR(K+1) = IT GO TO 55 END
C C C ************************************************************************** C EIGENVECTOR/EIGENVALUE DECOMPOSITION SUBROUTINES FOR A SYMMETRIC MATRIX C SUBROUTINES ARE FROM EISPACK C ************************************************************************** C
SUBROUTINE RS(NM,N,A,W,MATZ,Z,FV1,FV2,IERR)
C
INTEGER N,NM,IERR,MATZ REAL A(NM,N),W(N),Z(NM,N),FV1(N),FV2(N)
C C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) C OF A REAL SYMMETRIC MATRIX. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX A. C C A CONTAINS THE REAL SYMMETRIC MATRIX. C C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. C C ON OUTPUT C C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. C C Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. C C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT C AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. C C FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C —————————————————————— C
IF (N .LE. NM) GO TO 10 IERR = 10 * N GO TO 50
C
10 IF (MATZ .NE. 0) GO TO 20
C .….….. FIND EIGENVALUES ONLY .….…..
CALL TRED1(NM,N,A,W,FV1,FV2) CALL TQLRAT(N,W,FV2,IERR) GO TO 50
C .….….. FIND BOTH EIGENVALUES AND EIGENVECTORS .….…..
20 CALL TRED2(NM,N,A,W,FV1,Z) CALL TQL2(NM,N,W,FV1,Z,IERR) 50 RETURN END SUBROUTINE TRED1(NM,N,A,D,E,E2)
C
INTEGER I,J,K,L,N,II,NM,JP1 REAL A(NM,N),D(N),E(N),E2(N) REAL F,G,H,SCALE
C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1, C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). C C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX C TO A SYMMETRIC TRIDIAGONAL MATRIX USING C ORTHOGONAL SIMILARITY TRANSFORMATIONS. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE C LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. C C ON OUTPUT C C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- C FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER C TRIANGLE. THE FULL UPPER TRIANGLE OF A IS UNALTERED. C C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. C C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C —————————————————————— C
DO 100 I = 1, N D(I) = A(N,I) A(N,I) = A(I,I) 100 CONTINUE
C .….….. FOR I=N STEP -1 UNTIL 1 DO – .….…..
DO 300 II = 1, N I = N + 1 - II L = I - 1 H = 0.0E0 SCALE = 0.0E0 IF (L .LT. 1) GO TO 130
C .….….. SCALE ROW (ALGOL TOL THEN NOT NEEDED) .….…..
DO 120 K = 1, L 120 SCALE = SCALE + ABS(D(K))
C
IF (SCALE .NE. 0.0E0) GO TO 140
C
DO 125 J = 1, L D(J) = A(L,J) A(L,J) = A(I,J) A(I,J) = 0.0E0 125 CONTINUE
C
130 E(I) = 0.0E0 E2(I) = 0.0E0 GO TO 300
C
140 DO 150 K = 1, L D(K) = D(K) / SCALE H = H + D(K) * D(K) 150 CONTINUE
C
E2(I) = SCALE * SCALE * H F = D(L) G = -SIGN(SQRT(H),F) E(I) = SCALE * G H = H - F * G D(L) = F - G IF (L .EQ. 1) GO TO 285
C .….….. FORM A*U .….…..
DO 170 J = 1, L 170 E(J) = 0.0E0
C
DO 240 J = 1, L F = D(J) G = E(J) + A(J,J) * F JP1 = J + 1 IF (L .LT. JP1) GO TO 220
C
DO 200 K = JP1, L G = G + A(K,J) * D(K) E(K) = E(K) + A(K,J) * F 200 CONTINUE
C
220 E(J) = G 240 CONTINUE
C .….….. FORM P .….…..
F = 0.0E0
C
DO 245 J = 1, L E(J) = E(J) / H F = F + E(J) * D(J) 245 CONTINUE
C
H = F / (H + H)
C .….….. FORM Q .….…..
DO 250 J = 1, L 250 E(J) = E(J) - H * D(J)
C .….….. FORM REDUCED A .….…..
DO 280 J = 1, L F = D(J) G = E(J)
C
DO 260 K = J, L 260 A(K,J) = A(K,J) - F * E(K) - G * D(K)
C
280 CONTINUE
C
285 DO 290 J = 1, L F = D(J) D(J) = A(L,J) A(L,J) = A(I,J) A(I,J) = F * SCALE 290 CONTINUE
C
300 CONTINUE
C
RETURN END SUBROUTINE TRED2(NM,N,A,D,E,Z)
C
INTEGER I,J,K,L,N,II,NM,JP1 REAL A(NM,N),D(N),E(N),Z(NM,N) REAL F,G,H,HH,SCALE
C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED2, C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). C C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX TO A C SYMMETRIC TRIDIAGONAL MATRIX USING AND ACCUMULATING C ORTHOGONAL SIMILARITY TRANSFORMATIONS. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE C LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. C C ON OUTPUT C C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. C C Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX C PRODUCED IN THE REDUCTION. C C A AND Z MAY COINCIDE. IF DISTINCT, A IS UNALTERED. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C —————————————————————— C
DO 100 I = 1, N
C
DO 80 J = I, N 80 Z(J,I) = A(J,I)
C
D(I) = A(N,I) 100 CONTINUE
C
IF (N .EQ. 1) GO TO 510
C .….….. FOR I=N STEP -1 UNTIL 2 DO – .….…..
DO 300 II = 2, N I = N + 2 - II L = I - 1 H = 0.0E0 SCALE = 0.0E0 IF (L .LT. 2) GO TO 130
C .….….. SCALE ROW (ALGOL TOL THEN NOT NEEDED) .….…..
DO 120 K = 1, L 120 SCALE = SCALE + ABS(D(K))
C
IF (SCALE .NE. 0.0E0) GO TO 140 130 E(I) = D(L)
C
DO 135 J = 1, L D(J) = Z(L,J) Z(I,J) = 0.0E0 Z(J,I) = 0.0E0 135 CONTINUE
C
GO TO 290
C
140 DO 150 K = 1, L D(K) = D(K) / SCALE H = H + D(K) * D(K) 150 CONTINUE
C
F = D(L) G = -SIGN(SQRT(H),F) E(I) = SCALE * G H = H - F * G D(L) = F - G
C .….….. FORM A*U .….…..
DO 170 J = 1, L 170 E(J) = 0.0E0
C
DO 240 J = 1, L F = D(J) Z(J,I) = F G = E(J) + Z(J,J) * F JP1 = J + 1 IF (L .LT. JP1) GO TO 220
C
DO 200 K = JP1, L G = G + Z(K,J) * D(K) E(K) = E(K) + Z(K,J) * F 200 CONTINUE
C
220 E(J) = G 240 CONTINUE
C .….….. FORM P .….…..
F = 0.0E0
C
DO 245 J = 1, L E(J) = E(J) / H F = F + E(J) * D(J) 245 CONTINUE
C
HH = F / (H + H)
C .….….. FORM Q .….…..
DO 250 J = 1, L 250 E(J) = E(J) - HH * D(J)
C .….….. FORM REDUCED A .….…..
DO 280 J = 1, L F = D(J) G = E(J)
C
DO 260 K = J, L 260 Z(K,J) = Z(K,J) - F * E(K) - G * D(K)
C
D(J) = Z(L,J) Z(I,J) = 0.0E0 280 CONTINUE
C
290 D(I) = H 300 CONTINUE
C .….….. ACCUMULATION OF TRANSFORMATION MATRICES .….…..
DO 500 I = 2, N L = I - 1 Z(N,L) = Z(L,L) Z(L,L) = 1.0E0 H = D(I) IF (H .EQ. 0.0E0) GO TO 380
C
DO 330 K = 1, L 330 D(K) = Z(K,I) / H
C
DO 360 J = 1, L G = 0.0E0
C
DO 340 K = 1, L 340 G = G + Z(K,I) * Z(K,J)
C
DO 360 K = 1, L Z(K,J) = Z(K,J) - G * D(K) 360 CONTINUE
C
380 DO 400 K = 1, L 400 Z(K,I) = 0.0E0
C
500 CONTINUE
C
510 DO 520 I = 1, N D(I) = Z(N,I) Z(N,I) = 0.0E0 520 CONTINUE
C
Z(N,N) = 1.0E0 E(1) = 0.0E0 RETURN END SUBROUTINE TQL2(NM,N,D,E,Z,IERR)
C
INTEGER I,J,K,L,M,N,II,L1,L2,NM,MML,IERR REAL D(N),E(N),Z(NM,N) REAL C,C2,C3,DL1,EL1,F,G,H,P,R,S,S2,TST1,TST2,PYTHAG
C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2, C NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND C WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). C C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD. C THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO C BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS C FULL MATRIX TO TRIDIAGONAL FORM. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN C THE IDENTITY MATRIX. C C ON OUTPUT C C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT C UNORDERED FOR INDICES 1,2,…,IERR-1. C C E HAS BEEN DESTROYED. C C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED C EIGENVALUES. C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 30 ITERATIONS. C C CALLS PYTHAG FOR SQRT(A*A + B*B) . C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C —————————————————————— C
IERR = 0 IF (N .EQ. 1) GO TO 1001
C
DO 100 I = 2, N 100 E(I-1) = E(I)
C
F = 0.0E0 TST1 = 0.0E0 E(N) = 0.0E0
C
DO 240 L = 1, N J = 0 H = ABS(D(L)) + ABS(E(L)) IF (TST1 .LT. H) TST1 = H
C .….….. LOOK FOR SMALL SUB-DIAGONAL ELEMENT .….…..
DO 110 M = L, N TST2 = TST1 + ABS(E(M)) IF (TST2 .EQ. TST1) GO TO 120
C .….….. E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT C THROUGH THE BOTTOM OF THE LOOP .….…..
110 CONTINUE
C
120 IF (M .EQ. L) GO TO 220 130 IF (J .EQ. 30) GO TO 1000 J = J + 1
C .….….. FORM SHIFT .….…..
L1 = L + 1 L2 = L1 + 1 G = D(L) P = (D(L1) - G) / (2.0E0 * E(L)) R = PYTHAG(P,1.0E0) D(L) = E(L) / (P + SIGN(R,P)) D(L1) = E(L) * (P + SIGN(R,P)) DL1 = D(L1) H = G - D(L) IF (L2 .GT. N) GO TO 145
C
DO 140 I = L2, N 140 D(I) = D(I) - H
C
145 F = F + H
C .….….. QL TRANSFORMATION .….…..
P = D(M) C = 1.0E0 C2 = C EL1 = E(L1) S = 0.0E0 MML = M - L
C .….….. FOR I=M-1 STEP -1 UNTIL L DO – .….…..
DO 200 II = 1, MML C3 = C2 C2 = C S2 = S I = M - II G = C * E(I) H = C * P R = PYTHAG(P,E(I)) E(I+1) = S * R S = E(I) / R C = P / R P = C * D(I) - S * G D(I+1) = H + S * (C * G + S * D(I))
C .….….. FORM VECTOR .….…..
DO 180 K = 1, N H = Z(K,I+1) Z(K,I+1) = S * Z(K,I) + C * H Z(K,I) = C * Z(K,I) - S * H 180 CONTINUE
C
200 CONTINUE
C
P = -S * S2 * C3 * EL1 * E(L) / DL1 E(L) = S * P D(L) = C * P TST2 = TST1 + ABS(E(L)) IF (TST2 .GT. TST1) GO TO 130 220 D(L) = D(L) + F 240 CONTINUE
C .….….. ORDER EIGENVALUES AND EIGENVECTORS .….…..
DO 300 II = 2, N I = II - 1 K = I P = D(I)
C
DO 260 J = II, N IF (D(J) .GE. P) GO TO 260 K = J P = D(J) 260 CONTINUE
C
IF (K .EQ. I) GO TO 300 D(K) = D(I) D(I) = P
C
DO 280 J = 1, N P = Z(J,I) Z(J,I) = Z(J,K) Z(J,K) = P 280 CONTINUE
C
300 CONTINUE
C
GO TO 1001
C .….….. SET ERROR – NO CONVERGENCE TO AN C EIGENVALUE AFTER 30 ITERATIONS .….…..
1000 IERR = L 1001 RETURN END SUBROUTINE TQLRAT(N,D,E2,IERR)
C
INTEGER I,J,L,M,N,II,L1,MML,IERR REAL D(N),E2(N) REAL B,C,F,G,H,P,R,S,T,EPSLON,PYTHAG
C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT, C ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH. C C THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC C TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD. C C ON INPUT C C N IS THE ORDER OF THE MATRIX. C C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. C C E2 CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF THE C INPUT MATRIX IN ITS LAST N-1 POSITIONS. E2(1) IS ARBITRARY. C C ON OUTPUT C C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND C ORDERED FOR INDICES 1,2,…IERR-1, BUT MAY NOT BE C THE SMALLEST EIGENVALUES. C C E2 HAS BEEN DESTROYED. C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 30 ITERATIONS. C C CALLS PYTHAG FOR SQRT(A*A + B*B) . C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C C —————————————————————— C
IERR = 0 IF (N .EQ. 1) GO TO 1001
C
DO 100 I = 2, N 100 E2(I-1) = E2(I)
C
F = 0.0E0 T = 0.0E0 E2(N) = 0.0E0
C
DO 290 L = 1, N J = 0 H = ABS(D(L)) + SQRT(E2(L)) IF (T .GT. H) GO TO 105 T = H B = EPSLON(T) C = B * B
C .….….. LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT .….…..
105 DO 110 M = L, N IF (E2(M) .LE. C) GO TO 120
C .….….. E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT C THROUGH THE BOTTOM OF THE LOOP .….…..
110 CONTINUE
C
120 IF (M .EQ. L) GO TO 210 130 IF (J .EQ. 30) GO TO 1000 J = J + 1
C .….….. FORM SHIFT .….…..
L1 = L + 1 S = SQRT(E2(L)) G = D(L) P = (D(L1) - G) / (2.0E0 * S) R = PYTHAG(P,1.0E0) D(L) = S / (P + SIGN(R,P)) H = G - D(L)
C
DO 140 I = L1, N 140 D(I) = D(I) - H
C
F = F + H
C .….….. RATIONAL QL TRANSFORMATION .….…..
G = D(M) IF (G .EQ. 0.0E0) G = B H = G S = 0.0E0 MML = M - L
C .….….. FOR I=M-1 STEP -1 UNTIL L DO – .….…..
DO 200 II = 1, MML I = M - II P = G * H R = P + E2(I) E2(I+1) = S * R S = E2(I) / R D(I+1) = H + S * (H + D(I)) G = D(I) - E2(I) / G IF (G .EQ. 0.0E0) G = B H = G * P / R 200 CONTINUE
C
E2(L) = S * G D(L) = H
C .….….. GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST .….…..
IF (H .EQ. 0.0E0) GO TO 210 IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 210 E2(L) = H * E2(L) IF (E2(L) .NE. 0.0E0) GO TO 130 210 P = D(L) + F
C .….….. ORDER EIGENVALUES .….…..
IF (L .EQ. 1) GO TO 250
C .….….. FOR I=L STEP -1 UNTIL 2 DO – .….…..
DO 230 II = 2, L I = L + 2 - II IF (P .GE. D(I-1)) GO TO 270 D(I) = D(I-1) 230 CONTINUE
C
250 I = 1 270 D(I) = P 290 CONTINUE
C
GO TO 1001
C .….….. SET ERROR – NO CONVERGENCE TO AN C EIGENVALUE AFTER 30 ITERATIONS .….…..
1000 IERR = L 1001 RETURN END REAL FUNCTION PYTHAG(A,B) REAL A,B
C C FINDS SQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW C
REAL P,R,S,T,U P = AMAX1(ABS(A),ABS(B)) IF (P .EQ. 0.0E0) GO TO 20 R = (AMIN1(ABS(A),ABS(B))/P)**2 10 CONTINUE T = 4.0E0 + R IF (T .EQ. 4.0E0) GO TO 20 S = R/T U = 1.0E0 + 2.0E0*S P = U*P R = (S/U)**2 * R GO TO 10 20 PYTHAG = P RETURN END
c
REAL FUNCTION EPSLON (X) REAL X REAL A,B,C,EPS A = 4.0E0/3.0E0 10 B = A - 1.0E0 C = B + B + B EPS = ABS(C-1.0E0) IF(EPS .EQ. 0.0E0)GO TO 10 EPSLON = EPS*ABS(X) RETURN END
C C ********************************************************************* C SUBROUTINE CUTPLANE – FINDS CUTTING LINE USING THE CUTTING C PLANE PROCEDURE C ********************************************************************* C C
SUBROUTINE CUTPLANE(JJJ,NP,NRCALL,NS,XMAT,ZVEC,WS, C MCUTS,LERROR,IFIXX,KTT,KT,LDATA) DIMENSION XMAT(1001,25),ZVEC(2901,25),XPROJ(1001,2901),XXY(2901), C LLL(2901),XXX(1001),MM(2901),MVOTE(2901),WS(5802), C LLV(2901),LLVB(2901),LLE(2901),LLEB(2901), C LERROR(1001,2901),ZS(2901),MCUTS(2901,2), C XJCH(25),XJEH(25),XJCL(25),XJEL(25), C LDATA(1001,2901) 100 FORMAT(5I5) 1093 FORMAT(' CLASSIFICATION CHECK ',I3,I8) 1094 FORMAT(' RC CLASSIFICATION ERROR ',2I3,2I8,2F10.5)
C C ESTIMATE PROJECTION VECTORS C
KT=0 KTT=0 KTTSAVE=0 KTSAVE=0 KCHECK=0 DO 93 JX=1,NRCALL
C C GET YES AND NO COUNTS C
KYES=0 KNO=0 DO 92 I=1,NP IF(LDATA(I,JX).EQ.1)KYES=KYES+1 IF(LDATA(I,JX).EQ.6)KNO=KNO+1 92 CONTINUE
C C
DO 89 I=1,NP SUM=0.0 DO 90 K=1,NS SUM=SUM+XMAT(I,K)*ZVEC(JX,K) 90 CONTINUE
C C SAVE PROJECTION VECTORS – LEGISLATOR BY ROLL CALL MATRIX C
XPROJ(I,JX)=SUM XXY(I)=SUM LLL(I)=I XXX(I)=SUM MM(I)=LDATA(I,JX) IF(LDATA(I,JX).EQ.0)MM(I)=9 89 CONTINUE
C C SORT PROJECTION VECTOR (Y-HAT) C
CALL RSORT(XXX,NP,LLL) DO 114 I=1,NP MVOTE(I)=MM(LLL(I)) 114 CONTINUE
C C
C CALCULATE CLASSIFICATION ERRORS OF PROJECTION ONTO NORMAL VECTOR C
C
JCH=0 JEH=0 JCL=0 JEL=0 IROTC=0 CALL JAN1PT(NP,NRCALL,NS,JX,XMAT,XXX,MVOTE,WS, C LLV,LLVB,LLE,LLEB,LERROR, C ZS,JCH,JEH,JCL,JEL,IROTC,KCUT,LCUT,LLL, C XJCH,XJEH,XJCL,XJEL)
C
IF(JEH+JEL.EQ.0)THEN KT=KT+JCH+JEH+JCL+JEL KTSAVE=KTSAVE+JCH+JEH+JCL+JEL IJUST=0 GO TO 9377 ENDIF IF(IFIXX.EQ.0)THEN KT=KT+JCH+JEH+JCL+JEL KTSAVE=KTSAVE+JCH+JEH+JCL+JEL KTTSAVE=KTTSAVE+JEH+JEL GO TO 9377 ENDIF
C C SET-UP FOR GRID SEARCH FOR BEST CUTTING LINE C
NCUT=25 CALL SEARCH(IIII,JX,NCUT,NS,NP,NRCALL,KCUT,LCUT,KTT,KT, C XMAT,ZVEC,XPROJ,WS,XXY, C KITTY1,KITTY2,KYES,KNO,LDATA)
C C
KTTSAVE=KTTSAVE+KITTY1 KTSAVE=KTSAVE+KITTY2
C
9377 CONTINUE
C C STORE DIRECTIONALITY OF ROLL CALL C
MCUTS(JX,1)=KCUT MCUTS(JX,2)=LCUT
C C C LOCATE ERRORS – WS(.) CONTAINS THE OPTIMAL CUTTING POINT ON THE C PROJECTION VECTOR – IT CAN BE USED TO CALCULATE THE C CLASSIFICATION ERRORS C
KSUM=0 KSUMYES=0 KSUMNO=0 SUMYES=0.0 SUMNO=0.0 DO 108 I=1,NP LERROR(I,JX)=0 XXX(I)=XXY(I) LLL(I)=I IF(LDATA(I,JX).EQ.0)GO TO 108 IF(LDATA(I,JX).EQ.1)THEN SUMYES=SUMYES+XXY(I) KSUMYES=KSUMYES+1 ENDIF IF(LDATA(I,JX).EQ.6)THEN SUMNO=SUMNO+XXY(I) KSUMNO=KSUMNO+1 ENDIF IF(XXY(I).LT.WS(JX))THEN IF(LDATA(I,JX).NE.KCUT)THEN LERROR(I,JX)=1 KCHECK=KCHECK+1 KSUM=KSUM+1 ENDIF ENDIF IF(XXY(I).GT.WS(JX))THEN IF(LDATA(I,JX).NE.LCUT)THEN LERROR(I,JX)=1 KCHECK=KCHECK+1 KSUM=KSUM+1 ENDIF ENDIF 108 CONTINUE SUMYES=SUMYES/FLOAT(KSUMYES) SUMNO=SUMNO/FLOAT(KSUMNO) WS(2)=SUMYES WS(3)=SUMNO
C
93 CONTINUE
C
KT=KTSAVE KTT=KTTSAVE KCHECK2=0 DO 281 JX=1,NRCALL DO 282 I=1,NP KCHECK2=KCHECK2+LERROR(I,JX) 282 CONTINUE 281 CONTINUE IF(KT.GT.0)THEN XERROR=FLOAT(KTT)/FLOAT(KT) YERROR=1.0-XERROR ENDIF
C WRITE(21,1094)JJJ,NS,KTT,KT,XERROR,YERROR C WRITE(* ,1094)JJJ,NS,KTT,KT,XERROR,YERROR
RETURN END
C C ************************************************************************ C SUBROUTINE SEARCH C ************************************************************************ C
SUBROUTINE SEARCH(IIII,JX,NCUT,NS,NP,NRCALL,KCUT,LCUT,KTT,KT, C XMAT,ZVEC,XPROJ,WS,XXY, C KITTY1,KITTY2,KYES,KNO,LDATA) DIMENSION XMAT(1001,25),ZVEC(2901,25), C XPROJ(1001,2901),WS(5802),XXY(1001),XXX(1001),MM(1001), C LLL(1001),MVOTE(1001),LLM(1001),LLN(1001), C KKKCUT(1001),LLLCUT(1001),LLV(2901), C LLVB(2901),LLE(2901),LLEB(2901),LERROR(1001,2901), C XJCH(25),XJEH(25),XJCL(25),XJEL(25), C ZS(2901),UUU(1001,25),Y16MIDP(1001,25), C FV1(1001),FV2(1001),SUMX(1001),X16MIDP(1001,25), C YHAT(61913),LWRONG(1001), C VVV(25,25),LDATA(1001,2901) 210 FORMAT(I5,10F12.3) 1091 FORMAT(' INVERSE MATRIX ERROR',I4,I5,I8,2F10.4) 1099 FORMAT(I3,I5,I3,2I4) 1103 FORMAT(' MIDPOINT DECOMPOSITION',5I6) 1212 FORMAT(I3,I5,7I4) 3909 FORMAT(I5,I3,6I4,2I8,5I5)
C
DO 1 I=1,50 SUMX(I)=0.0 1 CONTINUE
C C PHASE 2 C C NCUT2=20 C
DO 999 IJL=1,NCUT
C C SET-UP FOR PHASE 2 C C
DO 388 K=1,NS UUU(IJL,K)=ZVEC(JX,K) 388 CONTINUE DO 389 I=1,NP SUM=0.0 DO 390 K=1,NS SUM=SUM+XMAT(I,K)*ZVEC(JX,K) 390 CONTINUE
C C SAVE PROJECTION VECTORS – LEGISLATOR BY ROLL CALL MATRIX C
XPROJ(I,JX)=SUM XXY(I)=SUM LLL(I)=I XXX(I)=SUM MM(I)=LDATA(I,JX) IF(LDATA(I,JX).EQ.0)MM(I)=9 389 CONTINUE
C C SORT PROJECTION VECTOR (Y-HAT) C C
CALL RSORT(XXX,NP,LLL) DO 314 I=1,NP MVOTE(I)=MM(LLL(I)) 314 CONTINUE
C C
C CALCULATE CLASSIFICATION ERRORS FOR BEST SOLUTION FROM PHASE 1 C
C
JCH=0 JEH=0 JCL=0 JEL=0 IROTC=0 CALL JAN1PT(NP,NRCALL,NS,JX,XMAT,XXX,MVOTE,WS, C LLV,LLVB,LLE,LLEB,LERROR, C ZS,JCH,JEH,JCL,JEL,IROTC,KCUT,LCUT,LLL, C XJCH,XJEH,XJCL,XJEL)
C C WRITE(21,3909)JX,IJL,KYES,KNO,JCH,JCL,JEH,JEL C
LLM(IJL)=IJL LLN(IJL)=JEH+JEL FV1(IJL)=FLOAT(JEH+JEL) FV2(IJL)=WS(JX) KKKCUT(IJL)=KCUT LLLCUT(IJL)=LCUT
C
IF(JEH+JEL.EQ.0)THEN KT=KT+JCH+JCL+JEH+JEL KITTY1=0 KITTY2=JCH+JCL+JEH+JEL IJUST=2 RETURN ENDIF
C C
KASTRO=4*(JEH+JEL) IF(KASTRO.GT.NP)KASTRO=NP IF(KASTRO.LT.4*NS)KASTRO=4*NS
C
DO 108 I=1,NP LWRONG(I)=0 DB2B1=WS(JX)-XXY(I) IF(XXY(I).LT.WS(JX))THEN
C C IF CORRECT PLACE LEGISLATOR POINT ON THE CURRENT CUTTING PLANE C
IF(LDATA(I,JX).EQ.KCUT)THEN DO 109 K=1,NS Y16MIDP(I,K)=XMAT(I,K)+DB2B1*ZVEC(JX,K) 109 CONTINUE ENDIF
C C IF INCORRECT PUT ACTUAL POINT INTO THE CUTTING CLOUD C
IF(LDATA(I,JX).EQ.LCUT)THEN LWRONG(I)=1 DO 110 K=1,NS Y16MIDP(I,K)=XMAT(I,K) 110 CONTINUE ENDIF
C C IF NOT-VOTING PUT LEGISLATOR POINT ON THE CURRRENT CUTTING PLANE C
IF(LDATA(I,JX).EQ.0)THEN DO 111 K=1,NS Y16MIDP(I,K)=XMAT(I,K)+DB2B1*ZVEC(JX,K) 111 CONTINUE ENDIF ENDIF IF(XXY(I).GT.WS(JX))THEN
C C IF CORRECT PLACE LEGISLATOR POINT ON THE CURRENT CUTTING PLANE C
IF(LDATA(I,JX).EQ.LCUT)THEN DO 112 K=1,NS Y16MIDP(I,K)=XMAT(I,K)+DB2B1*ZVEC(JX,K) 112 CONTINUE ENDIF
C C IF INCORRECT PUT ACTUAL POINT INTO THE CUTTING CLOUD C
IF(LDATA(I,JX).EQ.KCUT)THEN LWRONG(I)=1 DO 113 K=1,NS Y16MIDP(I,K)=XMAT(I,K) 113 CONTINUE ENDIF
C C IF NOT-VOTING PUT LEGISLATOR POINT ON THE CURRRENT CUTTING PLANE C
IF(LDATA(I,JX).EQ.0)THEN DO 214 K=1,NS Y16MIDP(I,K)=XMAT(I,K)+DB2B1*ZVEC(JX,K) 214 CONTINUE ENDIF ENDIF
C
108 CONTINUE
C C MASS CENTER THE CUTTING PLANE MATRIX (Y16MIDP(,) HAS ALL POINTS) C
DO 215 K=1,NS SUM=0.0 DO 216 I=1,NP SUM=SUM+Y16MIDP(I,K) 216 CONTINUE DO 217 I=1,NP Y16MIDP(I,K)=Y16MIDP(I,K)-SUM/FLOAT(NP) SUMX(K)=SUMX(K)+Y16MIDP(I,K)**2 217 CONTINUE SUMX(K)=SUMX(K)/FLOAT(NP) 215 CONTINUE
C C CONSTRUCT PARTIAL CUTTING PLANE MATRIX (X16MIDP(,)) C
KK=0 KHIT=0
C
DO 316 I=1,NP IF(LWRONG(I).EQ.1)THEN KK=KK+1 DO 317 K=1,NS X16MIDP(KK,K)=Y16MIDP(I,K) 317 CONTINUE ENDIF 316 CONTINUE DO 201 I=1,NP IF(LWRONG(I).EQ.0)THEN KK=KK+1 DO 219 K=1,NS X16MIDP(KK,K)=Y16MIDP(I,K) 219 CONTINUE IF(KK.EQ.KASTRO)GO TO 203 ENDIF 201 CONTINUE 203 CONTINUE
C C MASS CENTER THE PARTIAL CUTTING PLANE MATRIX C
DO 815 K=1,NS SUM=0.0 DO 816 I=1,KASTRO SUM=SUM+X16MIDP(I,K) 816 CONTINUE DO 817 I=1,KASTRO X16MIDP(I,K)=X16MIDP(I,K)-SUM/FLOAT(KASTRO) SUMX(K+NS)=SUMX(K+NS)+X16MIDP(I,K)**2 817 CONTINUE SUMX(K+NS)=SUMX(K+NS)/FLOAT(KASTRO) 815 CONTINUE
C C RUN REGRESSION TO ELIMINATE DIMENSION WITH LEAST VARIANCE C C C CALL SINGULAR VALUE DECOMPOSITION ROUTINE C
XTOL=.001 CALL LSVRR(NP,NS,Y16MIDP,1001,21,XTOL,IRANK,YHAT,Y16MIDP, C 1001,VVV,25)
C
DO 115 K=1,NS SUMX(K)=SUMX(K+NS) ZVEC(JX,K)=VVV(K,NS) 115 CONTINUE
C C IF(IIII.EQ.1)THEN C WRITE(21,3908)JX,IJL,(YHAT(K),K=1,NS),(VVV(K,NS),K=1,NS)
3908 FORMAT(I5,I3,10F7.3)
C ENDIF C C C RUN REGRESSION TO ELIMINATE DIMENSION WITH LEAST VARIANCE C
CALL LSVRR(KASTRO,NS,X16MIDP,1001,21,XTOL,IRANK,YHAT,X16MIDP, C 1001,VVV,25)
C
IF(IJL.GT.25)THEN DO 114 K=1,NS ZVEC(JX,K)=VVV(K,NS) 114 CONTINUE ENDIF
C C
999 CONTINUE
C
CALL RSORT(FV1,NCUT,LLM)
C
DO 281 JJ=1,NCUT IF(FV1(1).LT.FV1(JJ))GO TO 282 281 CONTINUE 282 KIN=JJ-1 LLM(1)=LLM(KIN)
C
DO 387 K=1,NS ZVEC(JX,K)=UUU(LLM(1),K) 387 CONTINUE WS(JX)=FV2(LLM(1)) KCUT=KKKCUT(LLM(1)) LCUT=LLLCUT(LLM(1)) DO 137 I=1,NP SUM=0.0 DO 138 K=1,NS SUM=SUM+XMAT(I,K)*ZVEC(JX,K) 138 CONTINUE XPROJ(I,JX)=SUM XXY(I)=SUM 137 CONTINUE KTT=KTT+LLN(LLM(1)) KITTY1=LLN(LLM(1)) IJUST=3 KT=KT+JCH+JCL+JEH+JEL KITTY2=JCH+JCL+JEH+JEL RETURN END
C C ************************************************************************** C SUBROUTINE JAN1PT – FINDS OPTIMAL CUTTING POINT FOR ONE DIMENSION C ************************************************************************** C
SUBROUTINE JAN1PT(NP,NRCALL,NS,IVOT,XMAT,YSS,KA,WS,LLV,LLVB, C LLE,LLEB, C LERROR,ZS,JCH,JEH,JCL,JEL,IROTC,KCCUT,LCCUT, C LLL,XJCH,XJEH,XJCL,XJEL) DIMENSION YSS(2901),KA(2901),WS(5802),LV(2901),LVB(2901), C LEB(2901),Z(2901),Y(2901),LLV(2901),LLE(2901), C LLVB(2901),LE(2901),LERROR(1001,2901),LJEP(2901), C LLEB(2901),ZS(2901),LLL(2901),XMAT(1001,25), C XJCH(25),XJEH(25),XJCL(25),XJEL(25),AAJEP(101), C ABJEP(101),LAJEP(101),LBJEP(101),LCJEP(101), C LDJEP(101),ABABJEP(101),MJEP(101)
C
JROTC=1 IF(IROTC.EQ.2)THEN JROTC=0 IROTC=1 ENDIF NPN=NP+1 NPP=NP-1 KCUT=1 LCUT=6 NOTE=2 IF(IROTC.EQ.1)THEN NOTE=1 ENDIF AA1=0.0 AB1=0.0 LA1=0 LB1=0 LC1=0 LD1=0 AA2=999.0 AB2=0.0 LA2=0 LB2=0 LC2=0 LD2=0 DO 999 III=1,NOTE IF(III.EQ.2)THEN KCUT=6 LCUT=1 ENDIF
C C CHECK ALL POSSIBLE INTERIOR CUT POINTS – THE NP INPUT POINTS C ARE HELD FIXED. THERE ARE NP POSSIBLE CUT-POINTS BEGINNING C WITH CUT-POINT 1 WHICH IS .001 UNITS TO THE LEFT OF POINT 1. C CUT-POINT 2 IS BETWEEN POINTS 1 AND 2, ETC. C C 1 2 3 4 5 6 7 8 9 10 11 .….. NP-1 NP C * * * * * * * * * * * * C 1 2 3 4 5 6 7 8 9 10 11 .….…… NP C C IF KCUT=1 AND LCUT=6, THE FOLLOWING NP PATTERNS ARE TESTED C C PATTERN C 1 6666666666666666666666 C 2 1666666666666666666666 C 3 1166666666666666666666 C 4 1116666666666666666666 C 5 1111666666666666666666 C 6 1111166666666666666666 C 7 1111116666666666666666 C . .…. C . .…. C . .…. C NP-1 1111111111111111111166 C NP 1111111111111111111116 C C BECAUSE THE PROGRAM TRIES BOTH KCUT=1/LCUT=6 AND KCUT=6/LCUT=1, THIS C WILL ALSO TEST THE ONE MISSING PATTERN ABOVE, VIZ., ALL “1”s. C C
KSE=0 KSV=0 LSV=0 LSE=0 KMARK=1 I=0 10 I=I+1 IF(I-NP-1)61,12,12 61 Z(I)=999.0 IF(I.EQ.1)THEN Y(I)=YSS(1)-.001 ENDIF IF(I.GT.1)THEN Y(I)=(YSS(I)+YSS(I-1))/2.0 ENDIF
C IF(KA(I).EQ.9)GO TO 10
IF(KMARK.EQ.1)THEN DO 3 J=I,NP IF(KA(J).EQ.9)GO TO 3 IF(LCUT-KA(J))33,5,33 33 IF(KCUT-KA(J))3,6,3 5 LSV=LSV+1 GO TO 3 6 LSE=LSE+1 3 CONTINUE KMARK=0 GO TO 31 ENDIF IF(KA(I-1).EQ.KCUT)THEN KSV=KSV+1 LSE=LSE-1 ENDIF IF(KA(I-1).EQ.LCUT)THEN KSE=KSE+1 LSV=LSV-1 ENDIF
C
31 CONTINUE LJEP(I)=I LV(I)=KSV LVB(I)=LSV LE(I)=KSE LEB(I)=LSE KT=LV(I)+LE(I)+LVB(I)+LEB(I) Z(I)=FLOAT(LE(I)+LEB(I))/FLOAT(KT)
C
IF(JROTC.EQ.0)THEN ZS(I)=Y(I) LLV(I)=LV(I) LLE(I)=LE(I) LLVB(I)=LVB(I) LLEB(I)=LEB(I) ENDIF GO TO 10 12 CONTINUE
C C FIND BEST CUT POINT C
CALL RSORT(Z,NP,LJEP) KIN=1 MJEP(1)=1 AAJEP(KIN)=Z(1) ABJEP(KIN)=Y(LJEP(1)) ABABJEP(KIN)=ABS(ABJEP(KIN)) LAJEP(KIN)=LV(LJEP(1)) LBJEP(KIN)=LE(LJEP(1)) LCJEP(KIN)=LVB(LJEP(1)) LDJEP(KIN)=LEB(LJEP(1))
C C CHECK IF THERE ARE MULTIPLE CUT-POINTS WITH SAME CLASSIFICATION AND C SELECT THAT CUT-POINT CLOSEST TO THE INTERIOR OF THE SPACE C
DO 63 I=2,NP IF(ABS(Z(1)-Z(I)).LE..00001)THEN KIN=KIN+1 MJEP(KIN)=KIN AAJEP(KIN)=Z(I) ABJEP(KIN)=Y(LJEP(I)) ABABJEP(KIN)=ABS(ABJEP(KIN)) LAJEP(KIN)=LV(LJEP(I)) LBJEP(KIN)=LE(LJEP(I)) LCJEP(KIN)=LVB(LJEP(I)) LDJEP(KIN)=LEB(LJEP(I)) IF(KIN.GT.100)GO TO 633 GO TO 63 ENDIF IF(Z(1).LT.Z(I))GO TO 633 63 CONTINUE 633 CONTINUE IF(KIN.EQ.1)THEN AA=AAJEP(1) AB=ABJEP(1) LA=LAJEP(1) LB=LBJEP(1) LC=LCJEP(1) LD=LDJEP(1) ENDIF IF(KIN.GT.1)THEN CALL RSORT(ABABJEP,KIN,MJEP) AA=AAJEP(MJEP(1)) AB=ABJEP(MJEP(1)) LA=LAJEP(MJEP(1)) LB=LBJEP(MJEP(1)) LC=LCJEP(MJEP(1)) LD=LDJEP(MJEP(1)) ENDIF
C
IF(III.EQ.1)THEN AA1=AA AB1=AB LA1=LA LB1=LB LC1=LC LD1=LD ENDIF IF(III.EQ.2)THEN AA2=AA AB2=AB LA2=LA LB2=LB LC2=LC LD2=LD ENDIF
C
999 CONTINUE
C
IF(AA1.LE.AA2)THEN KCCUT=1 LCCUT=6 AA=AA1 AB=AB1 LA=LA1 LB=LB1 LC=LC1 LD=LD1 ENDIF IF(AA1.GT.AA2)THEN KCCUT=6 LCCUT=1 AA=AA2 AB=AB2 LA=LA2 LB=LB2 LC=LC2 LD=LD2 ENDIF IF(IROTC.EQ.1)THEN KCCUT=1 LCCUT=6 AA=AA1 AB=AB1 LA=LA1 LB=LB1 LC=LC1 LD=LD1 ENDIF WS(IVOT)=AB IF(IROTC.EQ.1)WS(IVOT+NRCALL)=AB IF(JROTC.EQ.1)THEN ZS(IVOT)=AA LLV(IVOT)=LA LLE(IVOT)=LB LLVB(IVOT)=LC LLEB(IVOT)=LD ENDIF JCL=LA JEL=LB JCH=LC JEH=LD
C
IF(IROTC.EQ.0)THEN DO 71 K=1,NS XJCH(K)=0.0 XJEH(K)=0.0 XJCL(K)=0.0 XJEL(K)=0.0 71 CONTINUE DO 64 I=1,NP IF(KA(I).EQ.9)GO TO 64 IF(YSS(I).LT.AB)THEN IF(KA(I).EQ.KCCUT)THEN LERROR(LLL(I),IVOT)=0 DO 70 K=1,NS XJCL(K)=XJCL(K)+XMAT(LLL(I),K) 70 CONTINUE ENDIF IF(KA(I).EQ.LCCUT)THEN LERROR(LLL(I),IVOT)=1 DO 72 K=1,NS XJEL(K)=XJEL(K)+XMAT(LLL(I),K) 72 CONTINUE ENDIF ENDIF IF(YSS(I).GT.AB)THEN IF(KA(I).EQ.LCCUT)THEN LERROR(LLL(I),IVOT)=0 DO 73 K=1,NS XJCH(K)=XJCH(K)+XMAT(LLL(I),K) 73 CONTINUE ENDIF IF(KA(I).EQ.KCCUT)THEN LERROR(LLL(I),IVOT)=1 DO 74 K=1,NS XJEH(K)=XJEH(K)+XMAT(LLL(I),K) 74 CONTINUE ENDIF ENDIF 64 CONTINUE DO 75 K=1,NS IF(JCL.GT.0)XJCL(K)=XJCL(K)/FLOAT(JCL) IF(JEL.GT.0)XJEL(K)=XJEL(K)/FLOAT(JEL) IF(JCH.GT.0)XJCH(K)=XJCH(K)/FLOAT(JCH) IF(JEH.GT.0)XJEH(K)=XJEH(K)/FLOAT(JEH) 75 CONTINUE ENDIF IF(IROTC.EQ.1)THEN DO 65 I=1,NP IF(KA(I).EQ.9)GO TO 65 IF(YSS(I).LT.AB)THEN IF(KA(I).EQ.KCCUT)LERROR(IVOT,LLL(I))=0 IF(KA(I).EQ.LCCUT)LERROR(IVOT,LLL(I))=1 ENDIF IF(YSS(I).GT.AB)THEN IF(KA(I).EQ.LCCUT)LERROR(IVOT,LLL(I))=0 IF(KA(I).EQ.KCCUT)LERROR(IVOT,LLL(I))=1 ENDIF 65 CONTINUE ENDIF RETURN END
C———————————————————————– C IMSL Name: LSVRR/DLSVRR (Single/Double precision version) C C Computer: PCDSMS/SINGLE C C Revised: January 1, 1985 C C Purpose: Compute the singular value decomposition of a real C matrix. C C Usage: CALL LSVRR (NRA, NCA, A, LDA, IPATH, TOL, IRANK, C S, U, LDU, V, LDV) C C Arguments: C NRA - Number of rows of A. (Input) C NCA - Number of columns of A. (Input) C A - NRA by NCA matrix whose singular value decomposition C is to be computed. (Input) C LDA - Leading dimension of A exactly as specified in the C dimension statement of the calling program. (Input) C IPATH - Flag used to control the computation of the singular C vectors. (Input) C IPATH has the decimal expansion IJ such that: C I = 0 means do not compute the left singular vectors, C I = 1 means return the NCA left singular vectors in U, C I = 2 means return only the MIN(NRA,NCA) left singular C vectors in U, C J = 0 means do not compute the right singular vectors, C J = 1 means return the right singular vectors in V. C For example, IPATH = 20 means I = 2 and J = 0. C TOL - Scalar containing the tolerance used to determine when a C singular value is negligible. (Input) C If TOL is positive then a singular value SI is considered C negligible if SI .LE. TOL. C If TOL is negative then a singular value SI is considered C negligible if SI .LE. ABS(TOL)*(Infinity norm of A). C In this case ABS(TOL) should generally contain an C estimate of the level of relative error in the data. C IRANK - Scalar containing an estimate of the rank of A. (Output) C S - Vector of length MIN(NRA+1,NCA) containing the singular C values of A in descending order of magnitude in the first C MIN(NRA,NCA) positions. (Output) C U - NRA by NCU matrix containing the left singular vectors of C A. (Output) C NCU must be equal to NRA if I is equal to 1. C NCU must be equal to MIN(NRA,NCA) if I is equal to 2. C U will not be referenced if I is equal to zero. If NRA C is less than or equal to NCU, then U can share the same C storage locations as A. See Remarks. C LDU - Leading dimension of U exactly as specified in the C dimension statement of the calling program. (Input) C V - NCA by NCA matrix containing the right singular vectors C of A. (Output) C V will not be referenced if J is equal to zero. V can C share the same storage location as A; however U and V C cannot both coincide with A simultaneously. C LDV - Leading dimension of V exactly as specified in the C dimension statement of the calling program. (Input) C C Remarks: C 1. Automatic workspace usage is C LSVRR NRA*NCA + NRA + NCA + MAX(NRA,NCA) - 1 units, or C DLSVRR 2*(NRA*NCA + NRA + NCA + MAX(NRA,NCA) - 1) C units. C Workspace may be explicitly provided, if desired, by use of C L2VRR/DL2VRR. The reference is C CALL L2VRR (NRA, NCA, A, LDA, IPATH, TOL, IRANK, C S, U, LDU, V, LDV, ACOPY, WK) C The additional arguments are as follows: C ACOPY - Work vector of length NRA*NCA for the matrix A. If C A is not needed then A and ACOPY may share the same C storage locations. C WK - Work vector of length NRA + NCA + MAX(NRA,NCA) - 1. C C 2. Informational error C Type Code C 4 1 Convergence cannot be achieved for all the singular C values and their corresponding singular vectors. C C 3. When NRA is much greater than NCA, it might not be reasonable to C store the whole matrix U. In this case IPATH with I = 2 allows C a singular value factorization of A to be computed in which only C the first NCA columns of U are computed, and in many applications C those are all that are needed. C C Keywords: Least squares; Complete orthogonal decomposition; C Rank estimation C C GAMS: D6 C C Chapters: MATH/LIBRARY Linear Systems C STAT/LIBRARY Mathematical Support C C Copyright: 1985 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE LSVRR (NRA, NCA, A, LDA, IPATH, TOL, IRANK, S, U, & LDU, V, LDV)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER NRA, NCA, LDA, IPATH, IRANK, LDU, LDV REAL TOL, A(LDA,*), S(*), U(LDU,*), V(LDV,*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER INDA, INDW
C SPECIFICATIONS FOR SPECIAL CASES C SPECIFICATIONS FOR COMMON /WORKSP/
REAL RWKSP(61913) REAL RDWKSP(5000) DOUBLE PRECISION DWKSP(2500) COMPLEX CWKSP(2500) COMPLEX CZWKSP(2500) COMPLEX *16 ZWKSP(1250) INTEGER IWKSP(5000) LOGICAL LWKSP(5000) EQUIVALENCE (DWKSP(1), RWKSP(1)) EQUIVALENCE (CWKSP(1), RWKSP(1)), (ZWKSP(1), RWKSP(1)) EQUIVALENCE (IWKSP(1), RWKSP(1)), (LWKSP(1), RWKSP(1)) EQUIVALENCE (RDWKSP(1), RWKSP(1)), (CZWKSP(1), RWKSP(1)) COMMON /WORKSP/ RWKSP
C SPECIFICATIONS FOR INTRINSICS C INTRINSIC MAX0
INTRINSIC MAX0 INTEGER MAX0
C SPECIFICATIONS FOR SUBROUTINES
EXTERNAL E1MES, E1POP, E1PSH, E1STI, L2VRR
C SPECIFICATIONS FOR FUNCTIONS
EXTERNAL I1KGT, N1RCD INTEGER I1KGT, N1RCD
C
CALL E1PSH ('LSVRR ')
C
IF (NRA.LE.0 .OR. NCA.LE.0) THEN CALL E1STI (1, NRA) CALL E1STI (2, NCA) CALL E1MES (5, 1, 'Both the number of rows and the '// & 'number of columns of the input matrix have to '// & 'be positive while NRA = %(I1) and NCA = %(I2) '// & 'are given.') ELSE INDA = I1KGT(NRA*NCA,3) INDW = I1KGT(NRA+NCA+MAX0(NCA,NRA)-1,3) IF (N1RCD(0) .NE. 0) THEN CALL E1MES (5, 2, ' ') CALL E1STI (1, NRA) CALL E1STI (2, NCA) CALL E1MES (5, 2, 'The workspace is based on NRA and NCA '// & 'where NRA = %(I1) and NCA = %(I2) are '// & 'given.') ELSE CALL L2VRR (NRA, NCA, A, LDA, IPATH, TOL, IRANK, S, U, & LDU, V, LDV, RDWKSP(INDA), RDWKSP(INDW)) END IF END IF
C
CALL E1POP ('LSVRR ') RETURN END
C———————————————————————– C IMSL Name: L2VRR/DL2VRR (Single/Double precision version) C C Computer: DGC/SINGLE C C Revised: January 1, 1985 C C Purpose: Compute the singular value decomposition of a real C matrix. C C Usage: CALL L2VRR (NRA, NCA, A, LDA, IPATH, TOL, IRANK, C S, U, LDU, V, LDV, WKA, WK) C C Arguments: See LSVRR/DLSVRR. C C Remarks: See LSVRR/DLSVRR. C C Chapter: MATH/LIBRARY Linear Systems C C Copyright: 1985 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE L2VRR (NRA, NCA, A, LDA, IPATH, TOL, IRANK, S, U, & LDU, V, LDV, WKA, WK)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER NRA, NCA, LDA, IPATH, IRANK, LDU, LDV REAL TOL, A(LDA,*), S(*), U(*), V(*), WKA(*), WK(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, INDE, INDW, JOBU, JOBV
C SPECIFICATIONS FOR INTRINSICS C INTRINSIC MOD
INTRINSIC MOD INTEGER MOD
C SPECIFICATIONS FOR SUBROUTINES
EXTERNAL E1MES, E1POP, E1PSH, E1STI, SCOPY, L3VRR
C SPECIFICATIONS FOR FUNCTIONS
EXTERNAL N1RCD INTEGER N1RCD
C
CALL E1PSH ('L2VRR ')
C
IF (NRA.LE.0 .OR. NCA.LE.0) THEN CALL E1STI (1, NRA) CALL E1STI (2, NCA) CALL E1MES (5, 1, 'Both the number of rows and the '// & 'number of columns of the input matrix have to '// & 'be positive while NRA = %(I1) and NCA = %(I2) '// & 'are given.') ELSE IF (NRA .GT. LDA) THEN CALL E1STI (1, NRA) CALL E1STI (2, LDA) CALL E1MES (5, 2, 'The number of rows of A must be '// & 'less than or equal to its leading dimension '// & 'while NRA = %(I1) and LDA = %(I2) are '// & 'given.') END IF
C
IF (LDU .LE. 0) THEN CALL E1STI (1, LDU) CALL E1MES (5, 3, 'The leading dimension of U must '// & 'be greater than zero. LDU = %(I1) is '// & 'given.') END IF
C
IF (LDV .LE. 0) THEN CALL E1STI (1, LDV) CALL E1MES (5, 4, 'The leading dimension of V must '// & 'be greater than zero. LDV = %(I1) is '// & 'given.') END IF
C
IF (N1RCD(0) .EQ. 0) THEN JOBU = MOD(IPATH,100)/10 JOBV = MOD(IPATH,10) IF ((JOBU.NE.0.AND.JOBU.NE.1.AND.JOBU.NE.2) .OR. & (JOBV.NE.0.AND.JOBV.NE.1)) THEN CALL E1STI (1, JOBU) CALL E1STI (2, JOBV) CALL E1MES (5, 7, 'Error in computation control flag. '// & 'The IJ decimal expansion of IPATH is I = '// & '%(I1) and J = %(I2). I must be either '// & '0, 1 or 2 and J must be either 0 or 1.') ELSE
C MAKE A COPY OF A IN WKA AND WORK C WITH WKA ONLY.
DO 10 I=1, NCA CALL SCOPY (NRA, A(1,I), 1, WKA((I-1)*NRA+1), 1) 10 CONTINUE
C
INDE = 1 INDW = NCA + 1 CALL L3VRR (NRA, NCA, WKA, NRA, IPATH, TOL, IRANK, S, & U, LDU, V, LDV, WK(INDE), WK(INDW)) END IF END IF END IF
C
CALL E1POP ('L2VRR ') RETURN END
C———————————————————————– C IMSL Name: L3VRR/DL3VRR (Single/Double precision version) C C Computer: DGC/SINGLE C C Revised: January 1, 1985 C C Purpose: Compute the singular value decomposition of a real C matrix. C C Usage: CALL L3VRR (NRA, NCA, A, LDA, IPATH, TOL, IRANK, C S, U, LDU, V, LDV, E, WORK) C C Arguments: See LSVRR/DLSVRR C C Remarks: See LSVRR/DLSVRR. C C Chapter: MATH/LIBRARY Linear Systems C C Copyright: 1985 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE L3VRR (NRA, NCA, A, LDA, IPATH, TOL, IRANK, S, U, & LDU, V, LDV, E, WORK)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER NRA, NCA, LDA, IPATH, IRANK, LDU, LDV REAL TOL, A(LDA,*), S(*), U(LDU,*), V(LDV,*), E(*), WORK(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, IEND, INFO, ISTART, ITER, J, JOBU, K, KASE, KK, L, & LL, LLS, LM1, LP1, LS, LU, M, MAXIT, MINMN, MM, MM1, & MP1, NCT, NCTP1, NCU, NRT, NRTP1 REAL ANORM, B, C, CS, EL, EMM1, F, G, SCALE, SHIFT, SL, & SM, SMM1, SN, STOL, T, T1, TEST, ZTEST LOGICAL WANTU, WANTV
C SPECIFICATIONS FOR INTRINSICS C INTRINSIC ABS,AMAX1,MAX0,MIN0,MOD,SIGN,SQRT
INTRINSIC ABS, AMAX1, MAX0, MIN0, MOD, SIGN, SQRT INTEGER MAX0, MIN0, MOD REAL ABS, AMAX1, SIGN, SQRT
C SPECIFICATIONS FOR SUBROUTINES
EXTERNAL E1MES, E1POP, E1PSH, E1STI, SCOPY, SGEMV, SGER, SROT, & SROTG, SSCAL, SSET, SSWAP
C SPECIFICATIONS FOR FUNCTIONS
EXTERNAL SASUM, SNRM2 REAL SASUM, SNRM2
C
CALL E1PSH ('L3VRR ')
C IF TOL.LT.0, COMPUTE THE INFINITY C NORM OF A AND SINGULAR VALUE C TOLERANCE FOR RANK ESTIMATION
IF (TOL .LT. 0.0E0) THEN ANORM = 0.0E0 DO 10 I=1, NRA ANORM = AMAX1(ANORM,SASUM(NCA,A(I,1),LDA)) 10 CONTINUE STOL = ABS(TOL)*ANORM ELSE STOL = TOL END IF
C SET THE MAXIMUM NUMBER OF C ITERATIONS.
MAXIT = 30
C DETERMINE WHAT IS TO BE COMPUTED.
WANTU = .FALSE. WANTV = .FALSE. JOBU = MOD(IPATH,100)/10 NCU = NRA IF (JOBU .EQ. 2) NCU = MIN0(NRA,NCA) IF (JOBU .NE. 0) WANTU = .TRUE. IF (MOD(IPATH,10) .NE. 0) WANTV = .TRUE.
C REDUCE A TO BIDIAGONAL FORM, STORING C THE DIAGONAL ELEMENTS IN S AND THE C SUPER-DIAGONAL ELEMENTS IN E.
INFO = 0 NCT = MIN0(NRA-1,NCA) NRT = MAX0(0,MIN0(NCA-2,NRA)) LU = MAX0(NCT,NRT) IF (LU .GE. 1) THEN DO 20 L=1, LU LP1 = L + 1 IF (L .LE. NCT) THEN
C COMPUTE THE TRANSFORMATION FOR THE C L-TH NCA AND PLACE THE L-TH C DIAGONAL IN S(L).
S(L) = SNRM2(NRA-L+1,A(L,L),1) IF (S(L) .NE. 0.0E0) THEN IF (A(L,L) .NE. 0.0E0) S(L) = SIGN(S(L),A(L,L)) CALL SSCAL (NRA-L+1, 1.0E0/S(L), A(L,L), 1) A(L,L) = 1.0E0 + A(L,L) END IF S(L) = -S(L) END IF
C
IF (NCA .GE. LP1) THEN IF (L.LE.NCT .AND. S(L).NE.0.0E0) THEN
C APPLY THE TRANSFORMATION.
CALL SGEMV ('T', NRA-L+1, NCA-LP1+1, -1.0E0/A(L,L), & A(L,LP1), LDA, A(L,L), 1, 0.0E0, & WORK(NRA+1), 1) CALL SGER (NRA-L+1, NCA-LP1+1, 1.0E0, A(L,L), 1, & WORK(NRA+1), 1, A(L,LP1), LDA) END IF
C PLACE THE L-TH ROW OF A INTO E FOR C THE SUBSEQUENT CALCULATION OF THE C ROW TRANSFORMATION.
CALL SCOPY (NCA-LP1+1, A(L,LP1), LDA, E(LP1), 1) END IF
C PLACE THE TRANSFORMATION IN U FOR C SUBSEQUENT BACK MULTIPLICATION.
IF (WANTU .AND. L.LE.NCT) CALL SCOPY (NRA-L+1, A(L,L), 1, & U(L,L), 1) IF (L .LE. NRT) THEN
C COMPUTE THE L-TH ROW TRANSFORMATION C AND PLACE THE L-TH SUPER-DIAGONAL C IN E(L).
E(L) = SNRM2(NCA-L,E(LP1),1) IF (E(L) .NE. 0.0E0) THEN IF (E(LP1) .NE. 0.0E0) E(L) = SIGN(E(L),E(LP1)) CALL SSCAL (NCA-L, 1.0E0/E(L), E(LP1), 1) E(LP1) = 1.0E0 + E(LP1) END IF E(L) = -E(L) IF (LP1.LE.NRA .AND. E(L).NE.0.0E0) THEN
C APPLY THE TRANSFORMATION.
CALL SGEMV ('N', NRA-L, NCA-LP1+1, 1.0E0, & A(LP1,LP1), LDA, E(LP1), 1, 0.0E0, & WORK(LP1), 1) CALL SGER (NRA-L, NCA-LP1+1, -1.0E0/E(LP1), & WORK(LP1), 1, E(LP1), 1, A(LP1,LP1), LDA) END IF
C PLACE THE TRANSFORMATION IN V FOR C SUBSEQUENT BACK MULTIPLICATION.
IF (WANTV) CALL SCOPY (NCA-LP1+1, E(LP1), 1, V(LP1,L), & 1) END IF 20 CONTINUE END IF
C SET UP THE FINAL BIDIAGONAL MATRIX C OR ORDER M.
M = MIN0(NCA,NRA+1) NCTP1 = NCT + 1 NRTP1 = NRT + 1 IF (NCT .LT. NCA) S(NCTP1) = A(NCTP1,NCTP1) IF (NRA .LT. M) S(M) = 0.0E0 IF (NRTP1 .LT. M) E(NRTP1) = A(NRTP1,M) E(M) = 0.0E0
C IF REQUIRED, GENERATE U.
IF (WANTU) THEN IF (NCU .GE. NCTP1) THEN DO 30 J=NCTP1, NCU CALL SSET (NRA, 0.0E0, U(1,J), 1) U(J,J) = 1.0E0 30 CONTINUE END IF IF (NCT .GE. 1) THEN DO 40 LL=1, NCT L = NCT - LL + 1 IF (S(L) .NE. 0.0E0) THEN LP1 = L + 1 IF (NCU .GE. LP1) THEN CALL SGEMV ('T', NRA-L+1, NCU-LP1+1, & -1.0E0/U(L,L), U(L,LP1), LDU, U(L,L), & 1, 0.0E0, WORK(NRA+1), 1) CALL SGER (NRA-L+1, NCU-LP1+1, 1.0E0, U(L,L), 1, & WORK(NRA+1), 1, U(L,LP1), LDU) END IF CALL SSCAL (NRA-L+1, -1.0E0, U(L,L), 1) U(L,L) = 1.0E0 + U(L,L) LM1 = L - 1 IF (LM1 .GE. 1) CALL SSET (LM1, 0.0E0, U(1,L), 1) ELSE CALL SSET (NRA, 0.0E0, U(1,L), 1) U(L,L) = 1.0E0 END IF 40 CONTINUE END IF END IF
C IF IT IS REQUIRED, GENERATE V.
IF (WANTV) THEN DO 50 LL=1, NCA L = NCA - LL + 1 LP1 = L + 1 IF (L.LE.NRT .AND. E(L).NE.0.0E0) THEN CALL SGEMV ('T', NCA-L, NCA-LP1+1, -1.0E0/V(LP1,L), & V(LP1,LP1), LDV, V(LP1,L), 1, 0.0E0, & WORK(NRA+1), 1) CALL SGER (NCA-L, NCA-LP1+1, 1.0E0, V(LP1,L), 1, & WORK(NRA+1), 1, V(LP1,LP1), LDV) END IF CALL SSET (NCA, 0.0E0, V(1,L), 1) V(L,L) = 1.0E0 50 CONTINUE END IF
C MAIN ITERATION LOOP FOR THE SINGULAR C VALUES.
MM = M ITER = 0 60 CONTINUE
C QUIT IF ALL THE SINGULAR VALUES HAVE C BEEN FOUND.
IF (M.NE.0 .AND. ITER.LE.MAXIT) THEN
C THIS SECTION OF THE PROGRAM INSPECTS C FOR NEGLIGIBLE ELEMENTS IN THE S AND C E ARRAYS. ON COMPLETION THE VARIABLES C KASE AND L ARE SET AS FOLLOWS. C C KASE = 1 IF S(M) AND E(L-1) ARE C NEGLIGIBLE AND L.LT.M C C KASE = 2 IF S(L) IS NEGLIGIBLE C AND L.LT.M C C KASE = 3 IF E(L-1) IS NEGLIGIBLE, C L.LT.M, AND S(L), …, S(M) ARE NOT C NEGLIGIBLE (QR STEP). C C KASE = 4 IF E(M-1) IS NEGLIGIBLE C (CONVERGENCE).
DO 70 LL=1, M L = M - LL IF (L .EQ. 0) GO TO 80 TEST = ABS(S(L)) + ABS(S(L+1)) ZTEST = TEST + ABS(E(L)) IF (ZTEST .EQ. TEST) THEN E(L) = 0.0E0 GO TO 80 END IF 70 CONTINUE 80 CONTINUE IF (L .EQ. M-1) THEN KASE = 4 ELSE LP1 = L + 1 MP1 = M + 1 DO 90 LLS=LP1, MP1 LS = M - LLS + LP1 IF (LS .EQ. L) GO TO 100 TEST = 0.0E0 IF (LS .NE. M) TEST = TEST + ABS(E(LS)) IF (LS .NE. L+1) TEST = TEST + ABS(E(LS-1)) ZTEST = TEST + ABS(S(LS)) IF (ZTEST .EQ. TEST) THEN S(LS) = 0.0E0 GO TO 100 END IF 90 CONTINUE 100 CONTINUE IF (LS .EQ. L) THEN KASE = 3 ELSE IF (LS .EQ. M) THEN KASE = 1 ELSE KASE = 2 L = LS END IF END IF L = L + 1
C PERFORM THE TASK INDICATED BY KASE.
IF (KASE .EQ. 1) THEN
C DEFLATE NEGLIGIBLE S(M).
MM1 = M - 1 F = E(M-1) E(M-1) = 0.0E0 DO 110 KK=L, MM1 K = MM1 - KK + L T1 = S(K) CALL SROTG (T1, F, CS, SN) S(K) = T1 IF (K .NE. L) THEN F = -SN*E(K-1) E(K-1) = CS*E(K-1) END IF IF (WANTV) CALL SROT (NCA, V(1,K), 1, V(1,M), 1, CS, SN) 110 CONTINUE
C SPLIT AT NEGLIGIBLE S(L).
ELSE IF (KASE .EQ. 2) THEN F = E(L-1) E(L-1) = 0.0E0 DO 120 K=L, M T1 = S(K) CALL SROTG (T1, F, CS, SN) S(K) = T1 F = -SN*E(K) E(K) = CS*E(K) IF (WANTU) CALL SROT (NRA, U(1,K), 1, U(1,L-1), 1, CS, & SN) 120 CONTINUE
C PERFORM ONE QR STEP.
ELSE IF (KASE .EQ. 3) THEN
C CALCULATE THE SHIFT.
SCALE = AMAX1(ABS(S(M)),ABS(S(M-1)),ABS(E(M-1)),ABS(S(L)), & ABS(E(L))) SM = S(M)/SCALE SMM1 = S(M-1)/SCALE EMM1 = E(M-1)/SCALE SL = S(L)/SCALE EL = E(L)/SCALE B = ((SMM1+SM)*(SMM1-SM)+EMM1**2)/2.0E0 C = (SM*EMM1)**2 SHIFT = 0.0E0 IF (B.NE.0.0E0 .OR. C.NE.0.0E0) THEN SHIFT = SQRT(B**2+C) IF (B .LT. 0.0E0) SHIFT = -SHIFT SHIFT = C/(B+SHIFT) END IF F = (SL+SM)*(SL-SM) - SHIFT G = SL*EL
C CHASE ZEROS.
MM1 = M - 1 DO 130 K=L, MM1 CALL SROTG (F, G, CS, SN) IF (K .NE. L) E(K-1) = F F = CS*S(K) + SN*E(K) E(K) = CS*E(K) - SN*S(K) G = SN*S(K+1) S(K+1) = CS*S(K+1) IF (WANTV) CALL SROT (NCA, V(1,K), 1, V(1,K+1), 1, CS, & SN) CALL SROTG (F, G, CS, SN) S(K) = F F = CS*E(K) + SN*S(K+1) S(K+1) = -SN*E(K) + CS*S(K+1) G = SN*E(K+1) E(K+1) = CS*E(K+1) IF (WANTU .AND. K.LT.NRA) CALL SROT (NRA, U(1,K), 1, & U(1,K+1), 1, CS, SN) 130 CONTINUE E(M-1) = F ITER = ITER + 1
C CONVERGENCE.
ELSE IF (KASE .EQ. 4) THEN
C MAKE THE SINGULAR VALUE POSITIVE.
IF (S(L) .LT. 0.0E0) THEN S(L) = -S(L) IF (WANTV) CALL SSCAL (NCA, -1.0E0, V(1,L), 1) END IF
C ORDER THE SINGULAR VALUE.
140 IF (L .EQ. MM) GO TO 150 IF (S(L) .GE. S(L+1)) GO TO 150 T = S(L) S(L) = S(L+1) S(L+1) = T IF (WANTV .AND. L.LT.NCA) CALL SSWAP (NCA, V(1,L), 1, V(1, & L+1), 1) IF (WANTU .AND. L.LT.NRA) CALL SSWAP (NRA, U(1,L), 1, U(1, & L+1), 1) L = L + 1 GO TO 140 150 CONTINUE ITER = 0 M = M - 1 END IF GO TO 60 END IF IF (ITER .GT. MAXIT) INFO = M IF (INFO .EQ. 0) THEN
C ESTIMATE THE RANK OF A
LS = MIN0(NCA+1,NRA) MINMN = MIN0(NCA,NRA) IRANK = MINMN DO 160 I=1, MINMN IF (ABS(S(I)) .LE. STOL) THEN IRANK = I - 1 GO TO 170 END IF 160 CONTINUE 170 CONTINUE ELSE ISTART = INFO + 1 IEND = MIN0(NRA,NCA) CALL E1STI (1, ISTART) CALL E1STI (2, IEND)
C CALL E1MES (4, 1, ‘Convergence can only be obtained ’// C & ‘for the %(I1), … , %(I2) singular values ’// C & ‘and their corresponding singular vectors.’)
END IF CALL E1POP ('L3VRR ')
C
RETURN END
C———————————————————————– C IMSL Name: E1MES C C Computer: DGC/SINGLE C C Revised: March 2, 1984 C C Purpose: Set an error state for the current level in the stack. C The message is printed immediately if the error type is C 5, 6, or 7 and the print attribute for that type is YES. C C Usage: CALL E1MES(IERTYP,IERCOD,MSGPKD) C C Arguments: C IERTYP - Integer specifying the error type. (Input) C IERTYP=1, informational/note C IERTYP=2, informational/alert C IERTYP=3, informational/warning C IERTYP=4, informational/fatal C IERTYP=5, terminal C IERTYP=6, PROTRAN/warning C IERTYP=7, PROTRAN/fatal C IERCOD - Integer specifying the error code. (Input) C MSGPKD - A character string containing the message. C (Input) Within the message, any of following may appear C %(A1),%(A2),…,%(A9) for character arrays C %(C1),%(C2),…,%(C9) for complex numbers C %(D1),%(D2),…,%(D9) for double precision numbers C %(I1),%(I2),…,%(I9) for integer numbers C %(K1),%(K2),…,%(K9) for keywords C %(L1),%(L2),…,%(L9) for literals (strings) C %(R1),%(R2),…,%(R9) for real numbers C %(Z1),%(Z2),…,%(Z9) for double complex numbers C This provides a way to insert character arrays, strings, C numbers, and keywords into the message. See remarks C below. C C Remarks: C The number of characters in the message after the insertion of C the corresponding strings, etc. should not exceed 255. If the C limit is exceeded, only the first 255 characters will be used. C The appropriate strings, etc. need to have been previously stored C in common via calls to E1STA, E1STD, etc. Line breaks may be C specified by inserting the two characters ‘%/’ into the message C at the desired locations. C C Copyright: 1984 by IMSL, Inc. All rights reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE E1MES (IERTYP, IERCOD, MSGPKD)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER IERTYP, IERCOD CHARACTER MSGPKD*(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER ERTYP2, I, IER, IPLEN, ISUB, LAST, LEN2, LOC, M, MS, & NLOC, NUM, PBEG CHARACTER MSGTMP(255)
C SPECIFICATIONS FOR SAVE VARIABLES
INTEGER IFINIT, NFORMS CHARACTER BLNK, DBB(3), FIND(4), FORMS(9), INREF(25), LPAR, & NCHECK(3), PERCNT, RPAR SAVE BLNK, DBB, FIND, FORMS, IFINIT, INREF, LPAR, NCHECK, & NFORMS, PERCNT, RPAR
C SPECIFICATIONS FOR SPECIAL CASES C SPECIFICATIONS FOR COMMON /ERCOM1/
INTEGER CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51), & PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7, & IALLOC(51), HDRFMT(7), TRACON(7) COMMON /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE, & PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT, & TRACON SAVE /ERCOM1/
C SPECIFICATIONS FOR COMMON /ERCOM2/
CHARACTER MSGSAV(255), PLIST(300), RNAME(51)*6 COMMON /ERCOM2/ MSGSAV, PLIST, RNAME SAVE /ERCOM2/
C SPECIFICATIONS FOR COMMON /ERCOM3/
DOUBLE PRECISION ERCKSM COMMON /ERCOM3/ ERCKSM SAVE /ERCOM3/
C SPECIFICATIONS FOR COMMON /ERCOM4/
LOGICAL ISUSER(51) COMMON /ERCOM4/ ISUSER SAVE /ERCOM4/
C SPECIFICATIONS FOR INTRINSICS C INTRINSIC LEN,MIN0
INTRINSIC LEN, MIN0 INTEGER LEN, MIN0
C SPECIFICATIONS FOR SUBROUTINES
EXTERNAL C1TCI, E1INIT, E1PRT, E1UCS, M1VE, M1VECH
C SPECIFICATIONS FOR FUNCTIONS
EXTERNAL I1DX INTEGER I1DX
C
DATA FORMS/'A', 'C', 'D', 'I', 'K', 'L', 'R', 'S', 'Z'/, & NFORMS/9/ DATA PERCNT/'%'/, LPAR/'('/, RPAR/')'/, BLNK/' '/ DATA INREF/' ', 'i', 'n', ' ', 'r', 'e', 'f', 'e', 'r', & 'e', 'n', 'c', 'e', ' ', 't', 'o', ' ', 'k', 'e', & 'y', 'w', 'o', 'r', 'd', ' '/ DATA NCHECK/'N', '1', '*'/, DBB/'.', ' ', ' '/ DATA FIND/'*', ' ', ' ', '*'/ DATA IFINIT/0/
C INITIALIZE ERROR TABLE IF NECESSARY
IF (IFINIT .EQ. 0) THEN CALL E1INIT IFINIT = 1 END IF
C CHECK AND SET ERROR TYPE IF NECESSARY
IF (IERTYP .NE. -1) THEN ERTYPE(CALLVL) = IERTYP ELSE IF (IERTYP.LT.-1 .OR. IERTYP.GT.7) THEN MSGLEN = 51 CALL M1VECH ('. Error from E1MES. Illegal error type'// & ' specified. ', MSGLEN, MSGSAV, MSGLEN) CALL E1PRT STOP END IF
C
ERTYP2 = ERTYPE(CALLVL)
C SET ERROR CODE IF NECESSARY
IF (IERCOD .GT. -1) ERCODE(CALLVL) = IERCOD LEN2 = LEN(MSGPKD)
C
IF (IERTYP.EQ.0 .OR. IERCOD.EQ.0) THEN
C REMOVE THE ERROR STATE
MSGLEN = 0 ELSE IF (LEN2.EQ.0 .OR. (LEN2.EQ.1.AND.MSGPKD(1:1).EQ.BLNK)) THEN IF (ERTYP2 .EQ. 6) IFERR6 = 1 IF (ERTYP2 .EQ. 7) IFERR7 = 1
C UPDATE CHECKSUM PARAMETER ERCKSM
CALL E1UCS
C PRINT MESSAGE IF NECESSARY
IF (ERTYP2.GE.5 .AND. PRINTB(ERTYP2).EQ.1) CALL E1PRT ELSE
C FILL UP MSGSAV WITH EXPANDED MESSAGE
LEN2 = MIN0(LEN2,255) DO 10 I=1, LEN2 MSGTMP(I) = MSGPKD(I:I) 10 CONTINUE MS = 0 M = 0
C CHECK PLIST FOR KEYWORD NAME
NLOC = I1DX(PLIST,PLEN,NCHECK,3) IF (NLOC.GT.0 .AND. HDRFMT(ERTYP2).EQ.3) THEN
C M1VE INREF INTO MSGSAV
CALL M1VE (INREF, 1, 25, 25, MSGSAV, 1, 25, 25, IER)
C GET LENGTH OF KEYWORD NAME
CALL C1TCI (PLIST(NLOC+3), 3, IPLEN, IER) PBEG = NLOC + 3 + IER
C M1VE KEYWORD NAME INTO MSGSAV
CALL M1VE (PLIST, PBEG, PBEG+IPLEN-1, PLEN, MSGSAV, 26, & IPLEN+25, 255, IER)
C UPDATE POINTER
MS = IPLEN + 25 END IF
C INSERT DOT, BLANK, BLANK
CALL M1VE (DBB, 1, 3, 3, MSGSAV, MS+1, MS+3, 255, IER) MS = MS + 3
C LOOK AT NEXT CHARACTER
20 M = M + 1 ISUB = 0 IF (M .GT. LEN2-4) THEN LAST = LEN2 - M + 1 DO 30 I=1, LAST 30 MSGSAV(MS+I) = MSGTMP(M+I-1) MSGLEN = MS + LAST GO TO 40 ELSE IF (MSGTMP(M).EQ.PERCNT .AND. MSGTMP(M+1).EQ.LPAR .AND. & MSGTMP(M+4).EQ.RPAR) THEN CALL C1TCI (MSGTMP(M+3), 1, NUM, IER) IF (IER.EQ.0 .AND. NUM.NE.0 .AND. I1DX(FORMS,NFORMS, & MSGTMP(M+2),1).NE.0) THEN
C LOCATE THE ITEM IN THE PARAMETER LIST
CALL M1VE (MSGTMP(M+2), 1, 2, 2, FIND, 2, 3, 4, IER) LOC = I1DX(PLIST,PLEN,FIND,4) IF (LOC .GT. 0) THEN
C SET IPLEN = LENGTH OF STRING
CALL C1TCI (PLIST(LOC+4), 4, IPLEN, IER) PBEG = LOC + 4 + IER
C ADJUST IPLEN IF IT IS TOO BIG
IPLEN = MIN0(IPLEN,255-MS)
C M1VE STRING FROM PLIST INTO MSGSAV
CALL M1VE (PLIST, PBEG, PBEG+IPLEN-1, PLEN, MSGSAV, & MS+1, MS+IPLEN, 255, IER) IF (IER.GE.0 .AND. IER.LT.IPLEN) THEN
C UPDATE POINTERS
M = M + 4 MS = MS + IPLEN - IER
C BAIL OUT IF NO MORE ROOM
IF (MS .GE. 255) THEN MSGLEN = 255 GO TO 40 END IF
C SET FLAG TO SHOW SUBSTITION WAS MADE
ISUB = 1 END IF END IF END IF END IF IF (ISUB .EQ. 0) THEN MS = MS + 1 MSGSAV(MS) = MSGTMP(M) END IF GO TO 20 40 ERTYP2 = ERTYPE(CALLVL) IF (ERTYP2 .EQ. 6) IFERR6 = 1 IF (ERTYP2 .EQ. 7) IFERR7 = 1
C UPDATE CHECKSUM PARAMETER ERCKSM
CALL E1UCS
C PRINT MESSAGE IF NECESSARY
IF (ERTYP2.GE.5 .AND. PRINTB(ERTYP2).EQ.1) CALL E1PRT END IF
C CLEAR PARAMETER LIST
PLEN = 1
C
RETURN END
C———————————————————————– C IMSL Name: E1POP C C Computer: DGC/SINGLE C C Revised: March 13, 1984 C C Purpose: To pop a subroutine name from the error control stack. C C Usage: CALL E1POP(NAME) C C Arguments: C NAME - A character string of length six specifying the name C of the subroutine. (Input) C C Copyright: 1984 by IMSL, Inc. All rights reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE E1POP (NAME)
C SPECIFICATIONS FOR ARGUMENTS
CHARACTER NAME*(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER IERTYP, IR
C SPECIFICATIONS FOR SPECIAL CASES C SPECIFICATIONS FOR COMMON /ERCOM1/
INTEGER CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51), & PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7, & IALLOC(51), HDRFMT(7), TRACON(7) COMMON /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE, & PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT, & TRACON SAVE /ERCOM1/
C SPECIFICATIONS FOR COMMON /ERCOM2/
CHARACTER MSGSAV(255), PLIST(300), RNAME(51)*6 COMMON /ERCOM2/ MSGSAV, PLIST, RNAME SAVE /ERCOM2/
C SPECIFICATIONS FOR COMMON /ERCOM3/
DOUBLE PRECISION ERCKSM COMMON /ERCOM3/ ERCKSM SAVE /ERCOM3/
C SPECIFICATIONS FOR COMMON /ERCOM4/
LOGICAL ISUSER(51) COMMON /ERCOM4/ ISUSER SAVE /ERCOM4/
C SPECIFICATIONS FOR SUBROUTINES
EXTERNAL E1MES, E1PRT, E1PSH, E1STI, E1STL, I1KRL
C SPECIFICATIONS FOR FUNCTIONS
EXTERNAL I1KST INTEGER I1KST
C
IF (CALLVL .LE. 1) THEN CALL E1PSH ('E1POP ') CALL E1STL (1, NAME) CALL E1MES (5, 1, 'Error condition in E1POP. Cannot pop '// & 'from %(L1) because stack is empty.') STOP ELSE IF (NAME .NE. RNAME(CALLVL)) THEN CALL E1STL (1, NAME) CALL E1STL (2, RNAME(CALLVL)) CALL E1MES (5, 2, 'Error condition in E1POP. %(L1) does '// & 'not match the name %(L2) in the stack.') STOP ELSE IERTYP = ERTYPE(CALLVL) IF (IERTYP .NE. 0) THEN
C M1VE ERROR TYPE AND ERROR CODE TO C PREVIOUS LEVEL FOR ERROR TYPES 2-7
IF (IERTYP.GE.2 .AND. IERTYP.LE.7) THEN ERTYPE(CALLVL-1) = ERTYPE(CALLVL) ERCODE(CALLVL-1) = ERCODE(CALLVL) END IF
C CHECK PRINT TABLE TO DETERMINE C WHETHER TO PRINT STORED MESSAGE
IF (IERTYP .LE. 4) THEN IF (ISUSER(CALLVL-1) .AND. PRINTB(IERTYP).EQ.1) & CALL E1PRT ELSE IF (PRINTB(IERTYP) .EQ. 1) CALL E1PRT END IF
C CHECK STOP TABLE AND ERROR TYPE TO C DETERMINE WHETHER TO STOP
IF (IERTYP .LE. 4) THEN IF (ISUSER(CALLVL-1) .AND. STOPTB(IERTYP).EQ.1) THEN STOP END IF ELSE IF (IERTYP .EQ. 5) THEN IF (STOPTB(IERTYP) .EQ. 1) THEN STOP END IF ELSE IF (HDRFMT(IERTYP) .EQ. 1) THEN IF (ISUSER(CALLVL-1)) THEN IF (N1RGB(0) .NE. 0) THEN STOP END IF END IF END IF END IF
C SET ERROR TYPE AND CODE
IF (CALLVL .LT. MAXLEV) THEN ERTYPE(CALLVL+1) = -1 ERCODE(CALLVL+1) = -1 END IF
C SET IR = AMOUNT OF WORKSPACE C ALLOCATED AT THIS LEVEL
IR = I1KST(1) - IALLOC(CALLVL-1) IF (IR .GT. 0) THEN
C RELEASE WORKSPACE
CALL I1KRL (IR) IALLOC(CALLVL) = 0 ELSE IF (IR .LT. 0) THEN CALL E1STI (1, CALLVL) CALL E1STI (2, IALLOC(CALLVL-1)) CALL E1STI (3, I1KST(1)) CALL E1MES (5, 3, 'Error condition in E1POP. '// & ' The number of workspace allocations at '// & 'level %(I1) is %(I2). However, the total '// & 'number of workspace allocations is %(I3).') STOP END IF
C DECREASE THE STACK POINTER BY ONE
CALLVL = CALLVL - 1 END IF
C
RETURN END
C———————————————————————– C IMSL Name: E1PSH C C Computer: DGC/SINGLE C C Revised: March 2, 1984 C C Purpose: To push a subroutine name onto the error control stack. C C Usage: CALL E1PSH(NAME) C C Arguments: C NAME - A character string of length six specifing the name of C the subroutine. (Input) C C Copyright: 1984 by IMSL, Inc. All rights reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE E1PSH (NAME)
C SPECIFICATIONS FOR ARGUMENTS
CHARACTER NAME*(*)
C SPECIFICATIONS FOR SAVE VARIABLES
INTEGER IFINIT SAVE IFINIT
C SPECIFICATIONS FOR SPECIAL CASES C SPECIFICATIONS FOR COMMON /ERCOM1/
INTEGER CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51), & PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7, & IALLOC(51), HDRFMT(7), TRACON(7) COMMON /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE, & PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT, & TRACON SAVE /ERCOM1/
C SPECIFICATIONS FOR COMMON /ERCOM2/
CHARACTER MSGSAV(255), PLIST(300), RNAME(51)*6 COMMON /ERCOM2/ MSGSAV, PLIST, RNAME SAVE /ERCOM2/
C SPECIFICATIONS FOR COMMON /ERCOM3/
DOUBLE PRECISION ERCKSM COMMON /ERCOM3/ ERCKSM SAVE /ERCOM3/
C SPECIFICATIONS FOR COMMON /ERCOM4/
LOGICAL ISUSER(51) COMMON /ERCOM4/ ISUSER SAVE /ERCOM4/
C SPECIFICATIONS FOR SUBROUTINES
EXTERNAL E1INIT, E1MES, E1STI
C SPECIFICATIONS FOR FUNCTIONS
EXTERNAL I1KST INTEGER I1KST
C
DATA IFINIT/0/
C INITIALIZE ERROR TABLE IF NECESSARY
IF (IFINIT .EQ. 0) THEN CALL E1INIT IFINIT = 1 END IF IF (CALLVL .GE. MAXLEV) THEN CALL E1STI (1, MAXLEV) CALL E1MES (5, 1, 'Error condition in E1PSH. Push would '// & 'cause stack level to exceed %(I1). ') STOP ELSE
C STORE ALLOCATION LEVEL
IALLOC(CALLVL) = I1KST(1)
C INCREMENT THE STACK POINTER BY ONE
CALLVL = CALLVL + 1
C PUT SUBROUTINE NAME INTO STACK
RNAME(CALLVL) = NAME
C SET ERROR TYPE AND ERROR CODE
ERTYPE(CALLVL) = 0 ERCODE(CALLVL) = 0 END IF
C
RETURN END
C———————————————————————– C IMSL Name: E1STI C C Computer: PCDSMS/SINGLE C C Revised: March 6, 1984 C C Purpose: To store an integer for subsequent use within an error C message. C C Usage: CALL E1STI(II, IVALUE) C C Arguments: C II - Integer specifying the substitution index. II must be C between 1 and 9. (Input) C IVALUE - The integer to be stored. (Input) C C Copyright: 1984 by IMSL, Inc. All rights reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE E1STI (II, IVALUE)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER II, IVALUE
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER IBEG, IER, ILEN CHARACTER ARRAY(14)
C SPECIFICATIONS FOR SAVE VARIABLES
INTEGER IFINIT CHARACTER BLANK(1) SAVE BLANK, IFINIT
C SPECIFICATIONS FOR SPECIAL CASES C SPECIFICATIONS FOR COMMON /ERCOM1/
INTEGER CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51), & PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7, & IALLOC(51), HDRFMT(7), TRACON(7) COMMON /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE, & PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT, & TRACON SAVE /ERCOM1/
C SPECIFICATIONS FOR COMMON /ERCOM2/
CHARACTER MSGSAV(255), PLIST(300), RNAME(51)*6 COMMON /ERCOM2/ MSGSAV, PLIST, RNAME SAVE /ERCOM2/
C SPECIFICATIONS FOR COMMON /ERCOM3/
DOUBLE PRECISION ERCKSM COMMON /ERCOM3/ ERCKSM SAVE /ERCOM3/
C SPECIFICATIONS FOR COMMON /ERCOM4/
LOGICAL ISUSER(51) COMMON /ERCOM4/ ISUSER SAVE /ERCOM4/
C SPECIFICATIONS FOR SUBROUTINES
EXTERNAL C1TIC, E1INIT, E1INPL
C SPECIFICATIONS FOR FUNCTIONS
EXTERNAL I1ERIF INTEGER I1ERIF
C
DATA BLANK/' '/, IFINIT/0/
C INITIALIZE IF NECESSARY
IF (IFINIT .EQ. 0) THEN CALL E1INIT IFINIT = 1 END IF CALL C1TIC (IVALUE, ARRAY, 14, IER) IBEG = I1ERIF(ARRAY,14,BLANK,1) IF (II.GE.1 .AND. II.LE.9 .AND. IER.EQ.0) THEN ILEN = 15 - IBEG CALL E1INPL ('I', II, ILEN, ARRAY(IBEG)) END IF
C
RETURN END
C———————————————————————– C IMSL Name: I1KGT C C Computer: PCDSMS/SINGLE C C Revised: January 17, 1984 C C Purpose: Allocate numerical workspace. C C Usage: I1KGT(NELMTS,ITYPE) C C Arguments: C NELMTS - Number of elements of data type ITYPE to be C allocated. (Input) C ITYPE - Data type of array to be allocated. (Input) C 1 - logical C 2 - integer C 3 - real C 4 - double precision C 5 - complex C 6 - double complex C I1KGT - Integer function. (Output) Returns the index of the C first element in the current allocation. C C Remarks: C 1. On return, the array will occupy C WKSP(I1KGT), WKSP(I1KGT+1), …, WKSP(I1KGT+NELMTS-1) where C WKSP is an array of data type ITYPE equivalenced to RWKSP. C C 2. If I1KGT is negative, the absolute value of I1KGT is the C additional workspace needed for the current allocation. C C 3. The allocator reserves the first sixteen integer locations of C the stack for its own internal bookkeeping. These are initialized C by the function IWKIN upon the first call to the allocation C package. C C 4. The use of the first ten integer locations is as follows: C WKSP( 1) - LOUT The number of current allocations C WKSP( 2) - LNOW The current active length of the stack C WKSP( 3) - LUSED The maximum value of WKSP(2) achieved C thus far C WKSP( 4) - LBND The lower bound of permanent storage which C is one numeric storage unit more than the C maximum allowed length of the stack. C WKSP( 5) - LMAX The maximum length of the storage array C WKSP( 6) - LALC The total number of allocations handled by C I1KGT C WKSP( 7) - LNEED The number of numeric storage units by which C the array size must be increased for all past C allocations to succeed C WKSP( 8) - LBOOK The number of numeric storage units used for C bookkeeping C WKSP( 9) - LCHAR The pointer to the portion of the permanent C stack which contains the bookkeeping and C pointers for the character workspace C allocation. C WKSP(10) - LLCHAR The length of the array beginning at LCHAR C set aside for character workspace bookkeeping C and pointers. C NOTE - If character workspace is not being used, C LCHAR and LLCHAR can be ignored. C 5. The next six integer locations contain values describing the C amount of storage allocated by the allocation system to the C various data types. C WKSP(11) - Numeric storage units allocated to LOGICAL C WKSP(12) - Numeric storage units allocated to INTEGER C WKSP(13) - Numeric storage units allocated to REAL C WKSP(14) - Numeric storage units allocated to DOUBLE PRECISION C WKSP(15) - Numeric storage units allocated to COMPLEX C WKSP(16) - Numeric storage units allocated to DOUBLE COMPLEX C C Copyright: 1984 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
INTEGER FUNCTION I1KGT (NELMTS, ITYPE)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER NELMTS, ITYPE
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, IDUMAL, IGAP, ILEFT, IPA, IPA7, ISA, ISA7, & ISIZE(6), JTYPE, LALC, LBND, LBOOK, LMAX, LNEED, & LNEED1, LNOW, LOUT, LUSED
C SPECIFICATIONS FOR SAVE VARIABLES
LOGICAL FIRST SAVE FIRST
C SPECIFICATIONS FOR SPECIAL CASES C SPECIFICATIONS FOR COMMON /ERCOM8/
INTEGER PROLVL, XXLINE(10), XXPLEN(10), ICALOC(10), INALOC(10) COMMON /ERCOM8/ PROLVL, XXLINE, XXPLEN, ICALOC, INALOC SAVE /ERCOM8/
C SPECIFICATIONS FOR COMMON /ERCOM9/
CHARACTER XXPROC(10)*31 COMMON /ERCOM9/ XXPROC SAVE /ERCOM9/
C SPECIFICATIONS FOR COMMON /WORKSP/
REAL RWKSP(61913) REAL RDWKSP(5000) DOUBLE PRECISION DWKSP(2500) COMPLEX CWKSP(2500) COMPLEX CZWKSP(2500) COMPLEX *16 ZWKSP(1250) INTEGER IWKSP(5000) LOGICAL LWKSP(5000) EQUIVALENCE (DWKSP(1), RWKSP(1)) EQUIVALENCE (CWKSP(1), RWKSP(1)), (ZWKSP(1), RWKSP(1)) EQUIVALENCE (IWKSP(1), RWKSP(1)), (LWKSP(1), RWKSP(1)) EQUIVALENCE (RDWKSP(1), RWKSP(1)), (CZWKSP(1), RWKSP(1)) COMMON /WORKSP/ RWKSP
C SPECIFICATIONS FOR EQUIVALENCE
EQUIVALENCE (LOUT, IWKSP(1)) EQUIVALENCE (LNOW, IWKSP(2)) EQUIVALENCE (LUSED, IWKSP(3)) EQUIVALENCE (LBND, IWKSP(4)) EQUIVALENCE (LMAX, IWKSP(5)) EQUIVALENCE (LALC, IWKSP(6)) EQUIVALENCE (LNEED, IWKSP(7)) EQUIVALENCE (LBOOK, IWKSP(8)) EQUIVALENCE (ISIZE(1), IWKSP(11))
C SPECIFICATIONS FOR INTRINSICS C INTRINSIC IABS,MAX0,MOD
INTRINSIC IABS, MAX0, MOD INTEGER IABS, MAX0, MOD
C SPECIFICATIONS FOR SUBROUTINES
EXTERNAL E1MES, E1POP, E1POS, E1PSH, E1STI, IWKIN
C SPECIFICATIONS FOR FUNCTIONS
EXTERNAL I1KQU INTEGER I1KQU
C
DATA FIRST/.TRUE./
C
CALL E1PSH ('I1KGT ')
C
IF (FIRST) THEN
C INITIALIZE WORKSPACE IF NEEDED
FIRST = .FALSE. CALL IWKIN (0) END IF
C NUMBER OF ELEMENTS LESS THAN 0
IF (NELMTS .LT. 0) THEN CALL E1STI (1, NELMTS) CALL E1MES (5, 2, 'Number of elements is not positive.%/'// & 'NELMTS = %(I1).') CALL E1POP ('I1KGT ') GO TO 9000 END IF
C ILLEGAL DATA TYPE REQUESTED
IF (ITYPE.EQ.0 .OR. IABS(ITYPE).GE.7) THEN CALL E1MES (5, 3, 'Illegal data type requested.') CALL E1POP ('I1KGT ') GO TO 9000 END IF
C BOOKKEEPING OVERWRITTEN
IF (LNOW.LT.LBOOK .OR. LNOW.GT.LUSED .OR. LUSED.GT.LMAX .OR. & LNOW.GE.LBND .OR. LOUT.GT.LALC) THEN CALL E1MES (5, 4, 'One or more of the first eight '// & 'bookkeeping locations in IWKSP have been '// & 'overwritten.') CALL E1POP ('I1KGT ') GO TO 9000 END IF
C
CALL E1POP ('I1KGT ')
C DETERMINE NUMBER OF LOCATIONS STILL C AVAILABLE FOR DATA TYPE ITYPE C NOTE: I1KQU ALLOWS FOR 2 INTEGER C POINTERS WHICH MUST BE HANDLED C ARTIFICIALLY IF ILEFT = 0.
ILEFT = I1KQU(IABS(ITYPE))
C
IF (ITYPE .GT. 0) THEN
C RELEASABLE STORAGE
IF (ILEFT .GE. NELMTS) THEN I1KGT = (LNOW*ISIZE(2)-1)/ISIZE(ITYPE) + 2 I = ((I1KGT-1+NELMTS)*ISIZE(ITYPE)-1)/ISIZE(2) + 3
C IWKSP(I-1) CONTAINS THE DATA TYPE FOR C THIS ALLOCATION. IWKSP(I) CONTAINS C LNOW FOR THE PREVIOUS ALLOCATION.
IWKSP(I-1) = ITYPE IWKSP(I) = LNOW LOUT = LOUT + 1 LALC = LALC + 1 LNOW = I LUSED = MAX0(LUSED,LNOW) LNEED = 0 ELSE
C RELEASABLE STORAGE WAS REQUESTED C BUT THE STACK WOULD OVERFLOW. C THEREFORE, ALLOCATE RELEASABLE C SPACE THROUGH THE END OF THE STACK
IF (LNEED .EQ. 0) THEN IDUMAL = (LNOW*ISIZE(2)-1)/ISIZE(ITYPE) + 2 I = ((IDUMAL-1+ILEFT)*ISIZE(ITYPE)-1)/ISIZE(2) + 3
C ADVANCE COUNTERS AND STORE POINTERS C IF THERE IS ROOM TO DO SO
IF (I .LT. LBND) THEN
C IWKSP(I-1) CONTAINS THE DATA TYPE FOR C THIS ALLOCATION. IWKSP(I) CONTAINS C LNOW FOR THE PREVIOUS ALLOCATION.
IWKSP(I-1) = ITYPE IWKSP(I) = LNOW LOUT = LOUT + 1 LALC = LALC + 1 LNOW = I LUSED = MAX0(LUSED,LNOW) END IF END IF
C CALCULATE AMOUNT NEEDED TO ACCOMODATE C THIS ALLOCATION REQUEST
LNEED1 = (NELMTS-ILEFT)*ISIZE(ITYPE) IF (ILEFT .EQ. 0) THEN IGAP = ISIZE(ITYPE) - MOD(LNOW+LNEED,ISIZE(ITYPE)) IF (IGAP .EQ. ISIZE(ITYPE)) IGAP = 0 LNEED1 = LNEED1 + 2*ISIZE(2) + IGAP END IF
C MODIFY LNEED ACCORDING TO THE SIZE C OF THE BASE BEING USED (D.P. HERE)
LNEED = LNEED + ((LNEED1+ISIZE(3)-1)/ISIZE(3))
C SINCE CURRENT ALLOCATION IS ILLEGAL, C RETURN THE NEGATIVE OF THE ADDITIONAL C AMOUNT NEEDED TO MAKE IT LEGAL
I1KGT = -LNEED END IF ELSE
C PERMANENT STORAGE
IF (ILEFT .GE. NELMTS) THEN JTYPE = -ITYPE I1KGT = (LBND*ISIZE(2)-1)/ISIZE(JTYPE) + 1 - NELMTS I = ((I1KGT-1)*ISIZE(JTYPE))/ISIZE(2) - 1
C IWKSP(I) CONTAINS LBND FOR PREVIOUS C PERMANENT STORAGE ALLOCATION. C IWKSP(I+1) CONTAINS THE DATA TYPE FOR C THIS ALLOCATION.
IWKSP(I) = LBND IWKSP(I+1) = JTYPE LALC = LALC + 1 LBND = I LNEED = 0 ELSE
C PERMANENT STORAGE WAS REQUESTED C BUT THE STACK WOULD OVERFLOW, C THEREFORE, ALLOCATE RELEASABLE C SPACE THROUGH THE END OF THE STACK
IF (LNEED .EQ. 0) THEN JTYPE = -ITYPE IDUMAL = (LNOW*ISIZE(2)-1)/ISIZE(JTYPE) + 2 I = ((IDUMAL-1+ILEFT)*ISIZE(JTYPE)-1)/ISIZE(2) + 3
C ADVANCE COUNTERS AND STORE POINTERS C IF THERE IS ROOM TO DO SO
IF (I .LT. LBND) THEN
C IWKSP(I-1) CONTAINS THE DATA TYPE FOR C THIS ALLOCATION. IWKSP(I) CONTAINS C LNOW FOR THE PREVIOUS ALLOCATION.
IWKSP(I-1) = JTYPE IWKSP(I) = LNOW LOUT = LOUT + 1 LALC = LALC + 1 LNOW = I LUSED = MAX0(LUSED,LNOW) END IF END IF
C CALCULATE AMOUNT NEEDED TO ACCOMODATE C THIS ALLOCATION REQUEST
LNEED1 = (NELMTS-ILEFT)*ISIZE(-ITYPE) IF (ILEFT .EQ. 0) THEN IGAP = ISIZE(-ITYPE) - MOD(LNOW+LNEED,ISIZE(-ITYPE)) IF (IGAP .EQ. ISIZE(-ITYPE)) IGAP = 0 LNEED1 = LNEED1 + 2*ISIZE(2) + IGAP END IF
C MODIFY LNEED ACCORDING TO THE SIZE C OF THE BASE BEING USED (D.P. HERE)
LNEED = LNEED + ((LNEED1+ISIZE(3)-1)/ISIZE(3))
C SINCE CURRENT ALLOCATION IS ILLEGAL, C RETURN THE NEGATIVE OF THE ADDITIONAL C AMOUNT NEEDED TO MAKE IT LEGAL
I1KGT = -LNEED END IF END IF
C STACK OVERFLOW - UNRECOVERABLE ERROR
9000 IF (LNEED .GT. 0) THEN CALL E1POS (-5, IPA, ISA) CALL E1POS (5, 0, 0) CALL E1POS (-7, IPA7, ISA7) CALL E1POS (7, 0, 0) CALL E1PSH ('I1KGT ') CALL E1STI (1, LNEED+(LMAX/ISIZE(3))) IF (XXLINE(PROLVL).GE.1 .AND. XXLINE(PROLVL).LE.999) THEN CALL E1MES (7, 1, 'Insufficient workspace for current '// & 'allocation(s). Correct by inserting the '// & 'following PROTRAN line: $OPTIONS;WORKSPACE=%'// & '(I1)') ELSE CALL E1MES (5, 5, 'Insufficient workspace for current '// & 'allocation(s). Correct by calling IWKIN '// & 'from main program with the three following '// & 'statements: (REGARDLESS OF PRECISION)%/'// & ' COMMON /WORKSP/ RWKSP%/ REAL '// & 'RWKSP(%(I1))%/ CALL IWKIN(%(I1))') END IF CALL E1POP ('I1KGT ') CALL E1POS (5, IPA, ISA) CALL E1POS (7, IPA7, ISA7) END IF
C
RETURN END
C———————————————————————– C IMSL Name: N1RCD C C Computer: DGC/SINGLE C C Revised: March 6, 1984 C C Purpose: Retrieve an error code. C C Usage: N1RCD(IOPT) C C Arguments: C IOPT - Integer specifying the level. (Input) C If IOPT=0 the error code for the current level is C returned. If IOPT=1 the error code for the most C recently called routine (last pop) is returned. C C Copyright: 1984 by IMSL, Inc. All rights reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
INTEGER FUNCTION N1RCD (IOPT)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER IOPT
C SPECIFICATIONS FOR SPECIAL CASES C SPECIFICATIONS FOR COMMON /ERCOM1/
INTEGER CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51), & PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7, & IALLOC(51), HDRFMT(7), TRACON(7) COMMON /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE, & PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT, & TRACON SAVE /ERCOM1/
C SPECIFICATIONS FOR COMMON /ERCOM2/
CHARACTER MSGSAV(255), PLIST(300), RNAME(51)*6 COMMON /ERCOM2/ MSGSAV, PLIST, RNAME SAVE /ERCOM2/
C SPECIFICATIONS FOR COMMON /ERCOM3/
DOUBLE PRECISION ERCKSM COMMON /ERCOM3/ ERCKSM SAVE /ERCOM3/
C SPECIFICATIONS FOR COMMON /ERCOM4/
LOGICAL ISUSER(51) COMMON /ERCOM4/ ISUSER SAVE /ERCOM4/
C SPECIFICATIONS FOR SUBROUTINES
EXTERNAL E1PRT, M1VECH
C
IF (IOPT.NE.0 .AND. IOPT.NE.1) THEN ERTYPE(CALLVL) = 5 ERCODE(CALLVL) = 1 MSGLEN = 47 CALL M1VECH ('. The argument passed to N1RCD must be 0 or '// & '1. ', MSGLEN, MSGSAV, MSGLEN) CALL E1PRT STOP ELSE N1RCD = ERCODE(CALLVL+IOPT) END IF
C
RETURN END
C———————————————————————– C IMSL Name: SASUM (Single precision version) C C Computer: PCDSMS/SINGLE C C Revised: August 9, 1986 C C Purpose: Sum the absolute values of the components of a C single precision vector. C C Usage: SASUM(N, SX, INCX) C C Arguments: C N - Length of vectors X. (Input) C SX - Real vector of length N*INCX. (Input) C INCX - Displacement between elements of SX. (Input) C X(I) is defined to be SX(1+(I-1)*INCX). INCX must be C greater than 0. C SASUM - Single precision sum from I=1 to N of ABS(X(I)). C (Output) C X(I) refers to a specific element of SX. C C GAMS: D1a C C Chapters: MATH/LIBRARY Basic Matrix/Vector Operations C STAT/LIBRARY Mathematical Support C C Copyright: 1986 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
REAL FUNCTION SASUM (N, SX, INCX)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER N, INCX REAL SX(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, M, MP1, NINCX
C SPECIFICATIONS FOR SPECIAL CASES C INTRINSIC MOD
INTRINSIC MOD INTEGER MOD
C SPECIFICATIONS FOR INTRINSICS C INTRINSIC ABS
INTRINSIC ABS REAL ABS
C
SASUM = 0.0E0 IF (N .GT. 0) THEN IF (INCX .NE. 1) THEN
C CODE FOR INCREMENT NOT EQUAL TO 1
NINCX = N*INCX DO 10 I=1, NINCX, INCX SASUM = SASUM + ABS(SX(I)) 10 CONTINUE ELSE
C CODE FOR INCREMENT EQUAL TO 1
M = MOD(N,6)
C CLEAN-UP LOOP
DO 30 I=1, M SASUM = SASUM + ABS(SX(I)) 30 CONTINUE MP1 = M + 1 DO 40 I=MP1, N, 6 SASUM = SASUM + ABS(SX(I)) + ABS(SX(I+1)) + & ABS(SX(I+2)) + ABS(SX(I+3)) + ABS(SX(I+4)) + & ABS(SX(I+5)) 40 CONTINUE END IF END IF RETURN END
C———————————————————————– C IMSL Name: SCOPY (Single precision version) C C Computer: PCDSMS/SINGLE C C Revised: August 9, 1986 C C Purpose: Copy a vector X to a vector Y, both single precision. C C Usage: CALL SCOPY (N, SX, INCX, SY, INCY) C C Arguments: C N - Length of vectors X and Y. (Input) C SX - Real vector of length MAX(N*IABS(INCX),1). (Input) C INCX - Displacement between elements of SX. (Input) C X(I) is defined to be.. SX(1+(I-1)*INCX) if INCX .GE. 0 C or SX(1+(I-N)*INCX) if INCX .LT. 0. C SY - Real vector of length MAX(N*IABS(INCY),1). (Output) C SCOPY copies X(I) to Y(I) for I=1,…,N. X(I) and Y(I) C refer to specific elements of SX and SY, respectively. C See INCX and INCY argument descriptions. C INCY - Displacement between elements of SY. (Input) C Y(I) is defined to be.. SY(1+(I-1)*INCY) if INCY .GE. 0 C or SY(1+(I-N)*INCY) if INCY .LT. 0. C C GAMS: D1a C C Chapters: MATH/LIBRARY Basic Matrix/Vector Operations C STAT/LIBRARY Mathematical Support C C Copyright: 1986 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE SCOPY (N, SX, INCX, SY, INCY)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER N, INCX, INCY REAL SX(*), SY(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, IX, IY, M, MP1
C SPECIFICATIONS FOR SPECIAL CASES C INTRINSIC MOD
INTRINSIC MOD INTEGER MOD
C
IF (N .GT. 0) THEN IF (INCX.NE.1 .OR. INCY.NE.1) THEN
C CODE FOR UNEQUAL INCREMENTS
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 SY(IY) = SX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE ELSE
C CODE FOR BOTH INCREMENTS EQUAL TO 1
M = MOD(N,7)
C CLEAN-UP LOOP
DO 30 I=1, M SY(I) = SX(I) 30 CONTINUE MP1 = M + 1 DO 40 I=MP1, N, 7 SY(I) = SX(I) SY(I+1) = SX(I+1) SY(I+2) = SX(I+2) SY(I+3) = SX(I+3) SY(I+4) = SX(I+4) SY(I+5) = SX(I+5) SY(I+6) = SX(I+6) 40 CONTINUE END IF END IF RETURN END
C———————————————————————– C IMSL Name: SGEMV (Single precision version) C C Computer: PCDSMS/SINGLE C C Revised: July 15, 1986 C C Purpose: Perform the matrix-vector multiplication C y = alpha*A*x + beta*y or y = alpha*A’*x + beta*y, C all single precision. C C Usage: CALL SGEMV (TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, C INCY) C C Arguments: C TRANS - Character specifing the operation to be performed. C (Input) C TRANS Operation C ‘N’ or ‘n’ y = alpha*A*x + beta*y C ‘T’ or ‘t’ y = alpha*A’*x + beta*y C ‘C’ or ‘c’ y = alpha*A’*x + beta*y C M - Number of rows in A. (Input) C N - Number of columns in A. (Input) C ALPHA - Scalar. (Input) C A - Array of size M by N. (Input) C LDA - Leading dimension of A exactly as specified in the C calling routine. (Input) C X - Vector of length (N-1)*IABS(INCX)+1 when TRANS is C ‘N’ or ‘n’ and of length (M-1)*IABS(INCX)+1 otherwise. C (Input) C INCX - Displacement between elements of X. (Input) C BETA - Scalar. (Input) C When BETA is zero, Y is not referenced. C Y - Vector of length (N-1)*IABS(INCY)+1 when TRANS is C ‘M’ or ‘m’ and of length (M-1)*IABS(INCY)+1 otherwise. C (Input/Output) C INCY - Displacement between elements of Y. (Input) C C GAMS: D1b C C Chapter: MATH/LIBRARY Basic Matrix/Vector Operations C C Copyright: 1986 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE SGEMV (TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, & INCY)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER M, N, LDA, INCX, INCY REAL ALPHA, BETA, X(*), Y(*) CHARACTER TRANS*1
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, IX, IY, KY, LENX, LENY
C SPECIFICATIONS FOR SPECIAL CASES
REAL A(*) EXTERNAL SAXPY, SDOT INTEGER KX REAL SDOT
C SPECIFICATIONS FOR INTRINSICS C INTRINSIC IABS
INTRINSIC IABS INTEGER IABS
C SPECIFICATIONS FOR SUBROUTINES
EXTERNAL SSCAL, SSET
C Quick return if possible
IF (M.EQ.0 .OR. N.EQ.0 .OR. (ALPHA.EQ.0.0) .AND. (BETA.EQ.1.0)) & GO TO 9000
C
IF (TRANS.EQ.'N' .OR. TRANS.EQ.'n') THEN LENX = N LENY = M ELSE LENX = M LENY = N END IF
C
IX = 1 IY = 1 IF (INCX .LT. 0) IX = (-LENX+1)*INCX + 1 IF (INCY .LT. 0) IY = (-LENY+1)*INCY + 1
C
IF (BETA .EQ. 1) THEN ELSE IF (INCY .EQ. 0) THEN IF (BETA .EQ. 0.0) THEN Y(1) = 0.0 ELSE Y(1) = BETA**LENY*Y(1) END IF ELSE IF (BETA .EQ. 0.0) THEN CALL SSET (LENY, 0.0, Y, IABS(INCY)) ELSE CALL SSCAL (LENY, BETA, Y, IABS(INCY)) END IF
C
IF (ALPHA .EQ. 0.0) GO TO 9000
C Not transpose
IF (TRANS.EQ.'N' .OR. TRANS.EQ.'n') THEN KX = IX DO 10 I=1, N CALL SAXPY (M, ALPHA*X(KX), A(LDA*(I-1)+1), 1, Y, INCY) KX = KX + INCX 10 CONTINUE ELSE
C Transpose
KY = IY DO 20 I=1, N Y(KY) = Y(KY) + ALPHA*SDOT(M,A(LDA*(I-1)+1),1,X,INCX) KY = KY + INCY 20 CONTINUE END IF
C
9000 RETURN END
C———————————————————————– C IMSL Name: SGER (Single precision version) C C Computer: PCDSMS/SINGLE C C Revised: July 15, 1986 C C Purpose: Perform the rank-one matrix update A = alpha*x*y’ + A, C all single precision. C C Usage: CALL SGER (M, N, ALPHA, X, INCX, Y, INCY, A, LDA) C C Arguments: C M - Number of rows in A. (Input) C N - Number of columns in A. (Input) C ALPHA - Real scalar. (Input) C X - Real vector of length (M-1)*IABS(INCX)+1. (Input) C INCX - Displacement between elements of X. (Input) C Y - Real vector of length (N-1)*IABS(INCY)+1. (Input) C INCY - Displacement between elements of Y. (Input) C A - Array of size M by N. (Input/Output) C On input, A contains the matrix to be updated. C On output, A contains the updated matrix. C LDA - Leading dimension of A exactly as specified in the C calling routine. (Input) C C GAMS: D1b C C Chapter: MATH/LIBRARY Basic Matrix/Vector Operations C C Copyright: 1986 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE SGER (M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER M, N, INCX, INCY, LDA REAL ALPHA, X(*), Y(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER IY, J
C SPECIFICATIONS FOR SPECIAL CASES
REAL A(*) INTEGER I1X EXTERNAL SAXPY
C Quick return if possible
IF (M.EQ.0 .OR. N.EQ.0 .OR. ALPHA.EQ.0.0) GO TO 9000
C
IY = 1 IF (INCY .LT. 0) IY = (-N+1)*INCY + 1
C
I1X = 1 DO 10 J=1, N CALL SAXPY (M, ALPHA*Y(IY), X, INCX, A(I1X), 1) IY = IY + INCY I1X = I1X + LDA 10 CONTINUE
C
9000 RETURN END
C———————————————————————– C IMSL Name: SNRM2 (Single precision version) C C Computer: DGC/SINGLE C C Revised: August 9, 1986 C C Purpose: Compute the Euclidean length or L2 norm of a C single-precision vector. C C Usage: SNRM2(N, SX, INCX) C C Arguments: C N - Length of vector X. (Input) C SX - Real vector of length N*INCX. (Input) C INCX - Displacement between elements of SX. (Input) C X(I) is defined to be SX(1+(I-1)*INCX). INCX must be C greater than zero. C SNRM2 - Square root of the sum from I=1 to N of X(I)**2. C (Output) C X(I) refers to a specific element of SX. See INCX C argument description. C C GAMS: D1a3b C C Chapters: MATH/LIBRARY Basic Matrix/Vector Operations C STAT/LIBRARY Mathematical Support C C Copyright: 1986 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
REAL FUNCTION SNRM2 (N, SX, INCX)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER N, INCX REAL SX(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, J, NEXT, NN REAL HITEST, SUM, XMAX
C SPECIFICATIONS FOR SAVE VARIABLES
REAL CUTHI, CUTLO, ONE, ZERO SAVE CUTHI, CUTLO, ONE, ZERO
C SPECIFICATIONS FOR INTRINSICS C INTRINSIC ABS,SQRT
INTRINSIC ABS, SQRT REAL ABS, SQRT
C
DATA ZERO/0.0E0/, ONE/1.0E0/ DATA CUTLO/4.441E-16/, CUTHI/1.304E19/
C
IF (N .GT. 0) GO TO 10 SNRM2 = ZERO GO TO 140
C
10 ASSIGN 30 TO NEXT SUM = ZERO NN = N*INCX
C BEGIN MAIN LOOP
I = 1 20 GO TO NEXT, (30, 40, 70, 80) 30 IF (ABS(SX(I)) .GT. CUTLO) GO TO 110 ASSIGN 40 TO NEXT XMAX = ZERO
C PHASE 1. SUM IS ZERO
40 IF (SX(I) .EQ. ZERO) GO TO 130 IF (ABS(SX(I)) .GT. CUTLO) GO TO 110
C PREPARE FOR PHASE 2.
ASSIGN 70 TO NEXT GO TO 60
C PREPARE FOR PHASE 4.
50 I = J ASSIGN 80 TO NEXT SUM = (SUM/SX(I))/SX(I) 60 XMAX = ABS(SX(I)) GO TO 90
C PHASE 2. SUM IS SMALL. SCALE TO C AVOID DESTRUCTIVE UNDERFLOW.
70 IF (ABS(SX(I)) .GT. CUTLO) GO TO 100
C COMMON CODE FOR PHASES 2 AND 4. IN C PHASE 4 SUM IS LARGE. SCALE TO C AVOID OVERFLOW.
80 IF (ABS(SX(I)) .LE. XMAX) GO TO 90 SUM = ONE + SUM*(XMAX/SX(I))**2 XMAX = ABS(SX(I)) GO TO 130
C
90 SUM = SUM + (SX(I)/XMAX)**2 GO TO 130
C PREPARE FOR PHASE 3.
100 SUM = (SUM*XMAX)*XMAX
C FOR REAL OR D.P. SET HITEST = C CUTHI/N FOR COMPLEX SET HITEST = C CUTHI/(2*N)
110 HITEST = CUTHI/N
C PHASE 3. SUM IS MID-RANGE. NO C SCALING.
DO 120 J=I, NN, INCX IF (ABS(SX(J)) .GE. HITEST) GO TO 50 120 SUM = SUM + SX(J)*SX(J) SNRM2 = SQRT(SUM) GO TO 140
C
130 CONTINUE I = I + INCX IF (I .LE. NN) GO TO 20
C END OF MAIN LOOP. COMPUTE SQUARE C ROOT AND ADJUST FOR SCALING.
SNRM2 = XMAX*SQRT(SUM) 140 CONTINUE RETURN END
C———————————————————————– C IMSL Name: SROT (Single precision version) C C Computer: DGC/SINGLE C C Revised: August 9, 1986 C C Purpose: Apply a Givens plane rotation in single precision. C C Usage: CALL SROT (N, SX, INCX, SY, INCY, C, S) C C Arguments: C N - Length of vectors X and Y. (Input) C SX - Real vector of length MAX(N*IABS(INCX),1). C (Input/Output) C SROT replaces X(I) with SC*X(I) + SS*Y(I) for I=1,…,N. C X(I) and Y(I) refer to specific elements of SX and SY. C INCX - Displacement between elements of SX. (Input) C X(I) is defined to be C SX(1+(I-1)*INCX) if INCX.GE.0 or C SX(1+(I-N)*INCX) if INCX.LT.0. C SY - Real vector of length MAX(N*IABS(INCY),1). C (Input/Output) C SROT replaces Y(I) with -SS*X(I) + SC*Y(I) for I=1,…,N. C X(I) and Y(I) refer to specific elements of SX and SY. C INCY - Displacement between elements of SY. (Input) C Y(I) is defined to be C SY(1+(I-1)*INCY) if INCY.GE.0 or C SY(1+(I-N)*INCY) if INCY.LT.0. C C - Real scalar containing elements of the rotation matrix. C (Input) C S - Real scalar containing elements of the rotation matrix. C (Input) C C Remark: C ( SC SS ) (X(1) … X(N)) C SROT applies ( ) to ( ) C (-SS SC ) (Y(1) … Y(N)) C C GAMS: D1a8 C C Chapters: MATH/LIBRARY Basic Matrix/Vector Operations C STAT/LIBRARY Mathematical Support C C Copyright: 1986 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE SROT (N, SX, INCX, SY, INCY, C, S)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER N, INCX, INCY REAL C, S, SX(*), SY(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, IX, IY REAL STEMP
C
IF (N .GT. 0) THEN IF (INCX.NE.1 .OR. INCY.NE.1) THEN
C CODE FOR UNEQUAL INCREMENTS OR EQUAL C INCREMENTS NOT EQUAL TO 1
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 STEMP = C*SX(IX) + S*SY(IY) SY(IY) = C*SY(IY) - S*SX(IX) SX(IX) = STEMP IX = IX + INCX IY = IY + INCY 10 CONTINUE ELSE
C CODE FOR BOTH INCREMENTS EQUAL TO 1
DO 20 I=1, N STEMP = C*SX(I) + S*SY(I) SY(I) = C*SY(I) - S*SX(I) SX(I) = STEMP 20 CONTINUE END IF END IF RETURN END
C———————————————————————– C IMSL Name: SROTG (Single precision version) C C Computer: DGC/SINGLE C C Revised: August 9, 1986 C C Purpose: Construct a Givens plane rotation in single precision. C C Usage: CALL SROTG (SA, SB, SC, SS) C C Arguments: C SA - First element of vector. (Input/Output) C On output, R = (+/-)SQRT(SA**2 + SB**2) overwrites SA. C SB - Second element of vector. (Input/Output) C On output, Z overwrites SB where Z is defined to be C SS if ABS(SA) .GT. ABS(SB) C 1.0/SC if ABS(SB) .GE. ABS(SA) and SC .NE. 0.0 C 1.0 if SC .EQ. 0.0. C SC - Real scalar containing elements of the rotation matrix. C (Output) C SS - Real scalar containing elements of the rotation matrix. C (Output) C C Remark: C SROTG constructs the Givens rotation C ( SC SS ) C G = ( ) , SC**2 + SS**2 = 1 C (-SS SC ) C which zeros the second element of (SA SB)(transpose). C C GAMS: D1a8 C C Chapters: MATH/LIBRARY Basic Matrix/Vector Operations C STAT/LIBRARY Mathematical Support C C Copyright: 1986 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE SROTG (SA, SB, SC, SS)
C SPECIFICATIONS FOR ARGUMENTS
REAL SA, SB, SC, SS
C SPECIFICATIONS FOR LOCAL VARIABLES
REAL R, U, V
C SPECIFICATIONS FOR INTRINSICS C INTRINSIC ABS,SQRT
INTRINSIC ABS, SQRT REAL ABS, SQRT
C
IF (ABS(SA) .GT. ABS(SB)) THEN
C HERE ABS(SA) .GT. ABS(SB)
U = SA + SA V = SB/U
C NOTE THAT U AND R HAVE THE SIGN OF C SA
R = SQRT(.25+V**2)*U
C NOTE THAT SC IS POSITIVE
SC = SA/R SS = V*(SC+SC) SB = SS SA = R ELSE
C HERE ABS(SA) .LE. ABS(SB)
IF (SB .NE. 0.0) THEN U = SB + SB V = SA/U
C NOTE THAT U AND R HAVE THE SIGN OF C SB (R IS IMMEDIATELY STORED IN SA)
SA = SQRT(.25+V**2)*U
C NOTE THAT SS IS POSITIVE
SS = SB/SA SC = V*(SS+SS) IF (SC .NE. 0.0) THEN SB = 1.0/SC ELSE SB = 1.0 END IF
C HERE SA = SB = 0.
ELSE SC = 1.0 SS = 0.0 SA = 0.0 SB = 0.0 END IF END IF
C
RETURN END
C———————————————————————– C IMSL Name: SSCAL (Single precision version) C C Computer: PCDSMS/SINGLE C C Revised: August 9, 1986 C C Purpose: Multiply a vector by a scalar, y = ay, both single C precision. C C Usage: CALL SSCAL (N, SA, SX, INCX) C C Arguments: C N - Length of vector X. (Input) C SA - Real scalar. (Input) C SX - Real vector of length N*INCX. (Input/Output) C SSCAL replaces X(I) with SA*X(I) for I=1,…,N. X(I) C refers to a specific element of SX. See INCX argument C description. C INCX - Displacement between elements of SX. (Input) C X(I) is defined to be SX(1+(I-1)*INCX). INCX must be C greater than zero. C C GAMS: D1a6 C C Chapters: MATH/LIBRARY Basic Matrix/Vector Operations C STAT/LIBRARY Mathematical Support C C Copyright: 1986 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE SSCAL (N, SA, SX, INCX)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER N, INCX REAL SA, SX(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, M, MP1, NS
C
IF (N .GT. 0) THEN IF (INCX .NE. 1) THEN
C CODE FOR INCREMENTS NOT EQUAL TO 1.
NS = N*INCX DO 10 I=1, NS, INCX SX(I) = SA*SX(I) 10 CONTINUE ELSE
C CODE FOR INCREMENTS EQUAL TO 1. C CLEAN-UP LOOP SO REMAINING VECTOR C LENGTH IS A MULTIPLE OF 5.
M = N - (N/5)*5 DO 30 I=1, M SX(I) = SA*SX(I) 30 CONTINUE MP1 = M + 1 DO 40 I=MP1, N, 5 SX(I) = SA*SX(I) SX(I+1) = SA*SX(I+1) SX(I+2) = SA*SX(I+2) SX(I+3) = SA*SX(I+3) SX(I+4) = SA*SX(I+4) 40 CONTINUE END IF END IF RETURN END
C———————————————————————– C IMSL Name: SSET (Single precision version) C C Computer: PCDSMS/SINGLE C C Revised: August 9, 1986 C C Purpose: Set the components of a vector to a scalar, all C single precision. C C Usage: CALL SSET (N, SA, SX, INCX) C C Arguments: C N - Length of vector X. (Input) C SA - Real scalar. (Input) C SX - Real vector of length N*INCX. (Input/Output) C SSET replaces X(I) with SA for I=1,…,N. X(I) refers to C a specific element of SX. See INCX argument description. C INCX - Displacement between elements of SX. (Input) C X(I) is defined to be SX(1+(I-1)*INCX). INCX must be C greater than zero. C C GAMS: D1a1 C C Chapters: MATH/LIBRARY Basic Matrix/Vector Operations C STAT/LIBRARY Mathematical Support C C Copyright: 1986 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE SSET (N, SA, SX, INCX)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER N, INCX REAL SA, SX(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, M, MP1, NINCX
C SPECIFICATIONS FOR SPECIAL CASES C INTRINSIC MOD
INTRINSIC MOD INTEGER MOD
C
IF (N .GT. 0) THEN IF (INCX .NE. 1) THEN
C CODE FOR INCREMENT NOT EQUAL TO 1
NINCX = N*INCX DO 10 I=1, NINCX, INCX SX(I) = SA 10 CONTINUE ELSE
C CODE FOR INCREMENT EQUAL TO 1
M = MOD(N,8)
C CLEAN-UP LOOP
DO 30 I=1, M SX(I) = SA 30 CONTINUE MP1 = M + 1 DO 40 I=MP1, N, 8 SX(I) = SA SX(I+1) = SA SX(I+2) = SA SX(I+3) = SA SX(I+4) = SA SX(I+5) = SA SX(I+6) = SA SX(I+7) = SA 40 CONTINUE END IF END IF RETURN END
C———————————————————————– C IMSL Name: SSWAP (Single precision version) C C Computer: PCDSMS/SINGLE C C Revised: August 9, 1986 C C Purpose: Interchange vectors X and Y, both single precision. C C Usage: CALL SSWAP (N, SX, INCX, SY, INCY) C C Arguments: C N - Length of vectors X and Y. (Input) C SX - Real vector of length MAX(N*IABS(INCX),1). C (Input/Output) C INCX - Displacement between elements of SX. (Input) C X(I) is defined to be C SX(1+(I-1)*INCX) if INCX.GE.0 or C SX(1+(I-N)*INCX) if INCX.LT.0. C SY - Real vector of length MAX(N*IABS(INCY),1). C (Input/Output) C INCY - Displacement between elements of SY. (Input) C Y(I) is defined to be C SY(1+(I-1)*INCY) if INCY.GE.0 or C SY(1+(I-N)*INCY) if INCY.LT.0. C C GAMS: D1a5 C C Chapters: MATH/LIBRARY Basic Matrix/Vector Operations C STAT/LIBRARY Mathematical Support C C Copyright: 1986 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE SSWAP (N, SX, INCX, SY, INCY)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER N, INCX, INCY REAL SX(*), SY(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, IX, IY, M, MP1 REAL STEMP
C SPECIFICATIONS FOR SPECIAL CASES C INTRINSIC MOD
INTRINSIC MOD INTEGER MOD
C
IF (N .GT. 0) THEN IF (INCX.NE.1 .OR. INCY.NE.1) THEN
C CODE FOR UNEQUAL INCREMENTS OR EQUAL C INCREMENTS NOT EQUAL TO 1
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 STEMP = SX(IX) SX(IX) = SY(IY) SY(IY) = STEMP IX = IX + INCX IY = IY + INCY 10 CONTINUE ELSE
C CODE FOR BOTH INCREMENTS EQUAL TO 1
M = MOD(N,3)
C CLEAN-UP LOOP
DO 30 I=1, M STEMP = SX(I) SX(I) = SY(I) SY(I) = STEMP 30 CONTINUE MP1 = M + 1 DO 40 I=MP1, N, 3 STEMP = SX(I) SX(I) = SY(I) SY(I) = STEMP STEMP = SX(I+1) SX(I+1) = SY(I+1) SY(I+1) = STEMP STEMP = SX(I+2) SX(I+2) = SY(I+2) SY(I+2) = STEMP 40 CONTINUE END IF END IF RETURN END
C———————————————————————– C IMSL Name: C1TCI C C Computer: PCDSMS/SINGLE C C Revised: August 13, 1984 C C Purpose: Convert character string into corresponding integer C form. C C Usage: CALL C1TCI (CHRSTR, SLEN, NUM, IER) C C Arguments: C CHRSTR - Character array that contains the number description. C (Input) C SLEN - Length of the character array. (Input) C NUM - The answer. (Output) C IER - Completion code. (Output) Where C IER =-2 indicates that the number is too large to C be converted; C IER =-1 indicates that SLEN <= 0; C IER = 0 indicates normal completion; C IER > 0 indicates that the input string contains a C nonnumeric character. IER is the index of C the first nonnumeric character in CHRSTR. C C Copyright: 1984 by IMSL, Inc. All rights reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE C1TCI (CHRSTR, SLEN, NUM, IER)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER SLEN, NUM, IER CHARACTER CHRSTR(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER COUNT, I, IMACH5, J, N, S, SIGN CHARACTER ZERO
C SPECIFICATIONS FOR SAVE VARIABLES
CHARACTER BLANK, DIGIT*10, MINUS, PLUS SAVE BLANK, DIGIT, MINUS, PLUS
C SPECIFICATIONS FOR EQUIVALENCE
EQUIVALENCE (DIGIT, ZERO)
C SPECIFICATIONS FOR INTRINSICS C INTRINSIC INDEX
INTRINSIC INDEX INTEGER INDEX
C SPECIFICATIONS FOR FUNCTIONS
EXTERNAL IMACH INTEGER IMACH
C
DATA DIGIT/'0123456789'/ DATA BLANK/' '/, MINUS/'-'/, PLUS/'+'/
C C CHECK SLEN
NUM = 0 IF (SLEN .LE. 0) THEN IER = -1 GO TO 50 END IF
C HANDLE LEADING BLANKS
SIGN = 1 I = 1 10 IF (I .LE. SLEN) THEN IF (CHRSTR(I) .EQ. BLANK) THEN I = I + 1 GO TO 10 END IF ELSE IER = 1 GO TO 50 END IF
C CHECK FOR SIGN, IF ANY
S = I IF (CHRSTR(I) .EQ. MINUS) THEN SIGN = -1 I = I + 1 ELSE IF (CHRSTR(I) .EQ. PLUS) THEN I = I + 1 END IF 20 IF (I .LE. SLEN) THEN IF (CHRSTR(I) .EQ. BLANK) THEN I = I + 1 GO TO 20 END IF ELSE IER = S GO TO 50 END IF
C SKIP LEADING ZERO
J = I 30 IF (I .LE. SLEN) THEN IF (CHRSTR(I) .EQ. ZERO) THEN I = I + 1 GO TO 30 END IF ELSE IER = 0 GO TO 50 END IF
C CHECK FIRST NONBLANK CHARACTER
COUNT = 0
C CHECK NUMERIC CHARACTERS
IMACH5 = IMACH(5) 40 N = INDEX(DIGIT,CHRSTR(I)) IF (N .NE. 0) THEN COUNT = COUNT + 1 IF (NUM .GT. ((IMACH5-N)+1)/10) THEN IER = -2 GO TO 50 ELSE NUM = NUM*10 - 1 + N I = I + 1 IF (I .LE. SLEN) GO TO 40 END IF END IF
C
IF (COUNT .EQ. 0) THEN IF (I .GT. J) THEN IER = I ELSE IER = S END IF ELSE IF (I .GT. SLEN) THEN NUM = SIGN*NUM IER = 0 ELSE NUM = SIGN*NUM IER = I END IF
C
50 CONTINUE RETURN END
C———————————————————————– C IMSL Name: E1INIT C C Computer: DGC/SINGLE C C Revised: March 13, 1984 C C Purpose: Initialization. C C Usage: CALL E1INIT C C Arguments: None C C Copyright: 1984 by IMSL, Inc. All rights reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE E1INIT
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER L
C SPECIFICATIONS FOR SAVE VARIABLES
INTEGER ISINIT SAVE ISINIT
C SPECIFICATIONS FOR SPECIAL CASES C SPECIFICATIONS FOR COMMON /ERCOM1/
INTEGER CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51), & PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7, & IALLOC(51), HDRFMT(7), TRACON(7) COMMON /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE, & PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT, & TRACON SAVE /ERCOM1/
C SPECIFICATIONS FOR COMMON /ERCOM2/
CHARACTER MSGSAV(255), PLIST(300), RNAME(51)*6 COMMON /ERCOM2/ MSGSAV, PLIST, RNAME SAVE /ERCOM2/
C SPECIFICATIONS FOR COMMON /ERCOM3/
DOUBLE PRECISION ERCKSM COMMON /ERCOM3/ ERCKSM SAVE /ERCOM3/
C SPECIFICATIONS FOR COMMON /ERCOM4/
LOGICAL ISUSER(51) COMMON /ERCOM4/ ISUSER SAVE /ERCOM4/
C SPECIFICATIONS FOR COMMON /ERCOM8/
INTEGER PROLVL, XXLINE(10), XXPLEN(10), ICALOC(10), INALOC(10) COMMON /ERCOM8/ PROLVL, XXLINE, XXPLEN, ICALOC, INALOC SAVE /ERCOM8/
C SPECIFICATIONS FOR COMMON /ERCOM9/
CHARACTER XXPROC(10)*31 COMMON /ERCOM9/ XXPROC SAVE /ERCOM9/
C
DATA ISINIT/0/
C
IF (ISINIT .EQ. 0) THEN
C INITIALIZE
CALLVL = 1 ERCODE(1) = 0 ERTYPE(1) = 0 IALLOC(1) = 0 ISUSER(1) = .TRUE. IFERR6 = 0 IFERR7 = 0 PLEN = 1 MAXLEV = 50 DO 10 L=2, 51 ERTYPE(L) = -1 ERCODE(L) = -1 IALLOC(L) = 0 ISUSER(L) = .FALSE. 10 CONTINUE DO 20 L=1, 7 HDRFMT(L) = 1 TRACON(L) = 1 20 CONTINUE PROLVL = 1 DO 30 L=1, 10 30 ICALOC(L) = 0 XXLINE(1) = 0 XXPLEN(1) = 1 XXPROC(1) = '?' RNAME(1) = 'USER' PRINTB(1) = 0 PRINTB(2) = 0 DO 40 L=3, 7 40 PRINTB(L) = 1 STOPTB(1) = 0 STOPTB(2) = 0 STOPTB(3) = 0 STOPTB(4) = 1 STOPTB(5) = 1 STOPTB(6) = 0 STOPTB(7) = 1 ERCKSM = 0.0D0
C SET FLAG TO INDICATE THAT C INITIALIZATION HAS OCCURRED
ISINIT = 1 END IF
C
RETURN END
C———————————————————————– C IMSL Name: E1PRT C C Computer: PCDSMS/SINGLE C C Revised: March 14, 1984 C C Purpose: To print an error message. C C Usage: CALL E1PRT C C Arguments: None C C Copyright: 1984 by IMSL, Inc. All rights reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE E1PRT
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER ALL, I, IBEG, IBLOC, IBLOC2, IEND, IER, IHDR, J, & LERTYP, LOC, LOCM1, LOCX, MAXLOC, MAXTMP, MLOC, MOD, & NCBEG, NLOC, NOUT CHARACTER MSGTMP(70), STRING(10)
C SPECIFICATIONS FOR SAVE VARIABLES
CHARACTER ATLINE(9), BLANK(1), DBB(3), FROM(6), MSGTYP(8,7), & PERSLA(2), QMARK, UNKNOW(8)
C SPECIFICATIONS FOR SPECIAL CASES C SPECIFICATIONS FOR COMMON /ERCOM1/
INTEGER CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51), & PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7, & IALLOC(51), HDRFMT(7), TRACON(7) COMMON /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE, & PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT, & TRACON SAVE /ERCOM1/
C SPECIFICATIONS FOR COMMON /ERCOM2/
CHARACTER MSGSAV(255), PLIST(300), RNAME(51)*6 COMMON /ERCOM2/ MSGSAV, PLIST, RNAME SAVE /ERCOM2/
C SPECIFICATIONS FOR COMMON /ERCOM3/
DOUBLE PRECISION ERCKSM COMMON /ERCOM3/ ERCKSM SAVE /ERCOM3/
C SPECIFICATIONS FOR COMMON /ERCOM4/
LOGICAL ISUSER(51) COMMON /ERCOM4/ ISUSER SAVE /ERCOM4/
C SPECIFICATIONS FOR COMMON /ERCOM8/
INTEGER PROLVL, XXLINE(10), XXPLEN(10), ICALOC(10), INALOC(10) COMMON /ERCOM8/ PROLVL, XXLINE, XXPLEN, ICALOC, INALOC SAVE /ERCOM8/
C SPECIFICATIONS FOR COMMON /ERCOM9/
CHARACTER XXPROC(10)*31 COMMON /ERCOM9/ XXPROC SAVE /ERCOM9/ SAVE ATLINE, BLANK, DBB, FROM, MSGTYP, PERSLA, QMARK, & UNKNOW
C SPECIFICATIONS FOR INTRINSICS C INTRINSIC MIN0
INTRINSIC MIN0 INTEGER MIN0
C SPECIFICATIONS FOR SUBROUTINES
EXTERNAL C1TIC, M1VE, UMACH
C SPECIFICATIONS FOR FUNCTIONS
EXTERNAL I1DX, I1ERIF INTEGER I1DX, I1ERIF
C
DATA MSGTYP/'N', 'O', 'T', 'E', ' ', ' ', ' ', ' ', 'A', & 'L', 'E', 'R', 'T', ' ', ' ', ' ', 'W', 'A', 'R', & 'N', 'I', 'N', 'G', ' ', 'F', 'A', 'T', 'A', 'L', & ' ', ' ', ' ', 'T', 'E', 'R', 'M', 'I', 'N', 'A', & 'L', 'W', 'A', 'R', 'N', 'I', 'N', 'G', ' ', 'F', & 'A', 'T', 'A', 'L', ' ', ' ', ' '/ DATA UNKNOW/'U', 'N', 'K', 'N', 'O', 'W', 'N', ' '/ DATA ATLINE/' ', 'a', 't', ' ', 'l', 'i', 'n', 'e', ' '/ DATA BLANK/' '/, FROM/' ', 'f', 'r', 'o', 'm', ' '/ DATA DBB/'.', ' ', ' '/, PERSLA/'%', '/'/ DATA QMARK/'?'/
C
IF (MSGLEN .LE. 0) RETURN CALL UMACH (2, NOUT) MAXTMP = 70 MOD = 0 LERTYP = ERTYPE(CALLVL) IHDR = HDRFMT(LERTYP) IF (IHDR .EQ. 3) THEN IF (XXPROC(PROLVL)(1:1).EQ.QMARK .AND. XXLINE(PROLVL).EQ.0) & THEN IHDR = 1 END IF END IF IEND = 0 IF (IHDR.EQ.1 .AND. ERTYPE(CALLVL).LE.4) THEN MSGTMP(1) = BLANK(1) IEND = 1
C CONVERT ERROR CODE INTO CHAR STRING
CALL C1TIC (ERCODE(CALLVL), STRING, 10, IER)
C LOCATE START OF NON-BLANK CHARACTERS
IBEG = I1ERIF(STRING,10,BLANK,1)
C M1VE IT TO MSGTMP
CALL M1VE (STRING, IBEG, 10, 10, MSGTMP, IEND+1, & IEND+11-IBEG, MAXTMP, IER) IEND = IEND + 11 - IBEG END IF IF (IHDR .NE. 2) THEN CALL M1VE (FROM, 1, 6, 6, MSGTMP, IEND+1, IEND+6, MAXTMP, IER) IEND = IEND + 6 END IF IF (IHDR .EQ. 3) THEN
C THIS IS A PROTRAN RUN TIME ERROR MSG. C RETRIEVE THE PROCEDURE NAME
CALL M1VE (XXPROC(PROLVL), 1, XXPLEN(PROLVL), 31, MSGTMP, & IEND+1, IEND+XXPLEN(PROLVL), MAXTMP, IER) MLOC = IEND + XXPLEN(PROLVL) + 1 MSGTMP(MLOC) = BLANK(1) IEND = IEND + I1DX(MSGTMP(IEND+1),XXPLEN(PROLVL)+1,BLANK,1) - & 1 IF (XXLINE(PROLVL) .GT. 0) THEN
C INSERT ATLINE
CALL M1VE (ATLINE, 1, 9, 9, MSGTMP, IEND+1, IEND+9, & MAXTMP, IER) IEND = IEND + 9
C CONVERT PROTRAN GLOBAL LINE NUMBER
CALL C1TIC (XXLINE(PROLVL), STRING, 10, IER)
C LOCATE START OF NON-BLANK CHARACTERS
IBEG = I1ERIF(STRING,10,BLANK,1)
C M1VE GLOBAL LINE NUMBER TO MSGTMP
CALL M1VE (STRING, IBEG, 10, 10, MSGTMP, IEND+1, & IEND+11-IBEG, MAXTMP, IER) IEND = IEND + 11 - IBEG END IF ELSE
C THIS IS EITHER A LIBRARY ERROR MSG C OR A PROTRAN PREPROCESSOR ERROR MSG
IF (IHDR .EQ. 1) THEN
C THIS IS A LIBRARY ERROR MESSAGE. C RETRIEVE ROUTINE NAME
CALL M1VE (RNAME(CALLVL), 1, 6, 6, MSGTMP, IEND+1, IEND+6, & MAXTMP, IER) MSGTMP(IEND+7) = BLANK(1) IEND = IEND + I1DX(MSGTMP(IEND+1),7,BLANK,1) - 1 END IF
C ADD DOT, BLANK, BLANK IF NEEDED
IF (I1DX(MSGSAV,3,DBB,3) .NE. 1) THEN CALL M1VE (DBB, 1, 3, 3, MSGTMP, IEND+1, IEND+3, MAXTMP, & IER) IEND = IEND + 3 MOD = 3 END IF END IF
C MSGTMP AND MSGSAV NOW CONTAIN THE C ERROR MESSAGE IN FINAL FORM.
NCBEG = 59 - IEND - MOD ALL = 0 IBLOC = I1DX(MSGSAV,MSGLEN,PERSLA,2) IF (IBLOC.NE.0 .AND. IBLOC.LT.NCBEG) THEN LOCM1 = IBLOC - 1 LOC = IBLOC + 1 ELSE IF (MSGLEN .LE. NCBEG) THEN LOCM1 = MSGLEN ALL = 1 ELSE LOC = NCBEG
C CHECK FOR APPROPRIATE PLACE TO SPLIT
10 CONTINUE IF (MSGSAV(LOC) .NE. BLANK(1)) THEN LOC = LOC - 1 IF (LOC .GT. 1) GO TO 10 LOC = NCBEG + 1 END IF LOCM1 = LOC - 1 END IF
C NO BLANKS FOUND IN FIRST NCBEG CHARS
IF (LERTYP.GE.1 .AND. LERTYP.LE.7) THEN WRITE (NOUT,99995) (MSGTYP(I,LERTYP),I=1,8), & (MSGTMP(I),I=1,IEND), (MSGSAV(I),I=1,LOCM1) ELSE WRITE (NOUT,99995) (UNKNOW(I),I=1,8), (MSGTMP(I),I=1,IEND), & (MSGSAV(I),I=1,LOCM1) END IF IF (ALL .EQ. 0) THEN
C PREPARE TO WRITE CONTINUATION OF C MESSAGE C C FIND WHERE TO BREAK MESSAGE C LOC = NUMBER OF CHARACTERS OF C MESSAGE WRITTEN SO FAR
20 LOCX = LOC + 64 NLOC = LOC + 1 IBLOC2 = IBLOC MAXLOC = MIN0(MSGLEN-LOC,64) IBLOC = I1DX(MSGSAV(NLOC),MAXLOC,PERSLA,2) IF (MSGSAV(NLOC).EQ.BLANK(1) .AND. IBLOC2.EQ.0) NLOC = NLOC + & 1 IF (IBLOC .GT. 0) THEN
C PAGE BREAK FOUND AT IBLOC
LOCX = NLOC + IBLOC - 2 WRITE (NOUT,99996) (MSGSAV(I),I=NLOC,LOCX) LOC = NLOC + IBLOC GO TO 20
C DON’T BOTHER LOOKING FOR BLANK TO C BREAK AT IF LOCX .GE. MSGLEN
ELSE IF (LOCX .LT. MSGLEN) THEN
C CHECK FOR BLANK TO BREAK THE LINE
30 CONTINUE IF (MSGSAV(LOCX) .EQ. BLANK(1)) THEN
C BLANK FOUND AT LOCX
WRITE (NOUT,99996) (MSGSAV(I),I=NLOC,LOCX) LOC = LOCX GO TO 20 END IF LOCX = LOCX - 1 IF (LOCX .GT. NLOC) GO TO 30 LOCX = LOC + 64
C NO BLANKS FOUND IN NEXT 64 CHARS
WRITE (NOUT,99996) (MSGSAV(I),I=NLOC,LOCX) LOC = LOCX GO TO 20 ELSE
C ALL THE REST WILL FIT ON 1 LINE
LOCX = MSGLEN WRITE (NOUT,99996) (MSGSAV(I),I=NLOC,LOCX) END IF END IF
C SET LENGTH OF MSGSAV AND PLEN C TO SHOW THAT MESSAGE HAS C ALREADY BEEN PRINTED
9000 MSGLEN = 0 PLEN = 1 IF (TRACON(LERTYP).EQ.1 .AND. CALLVL.GT.2) THEN
C INITIATE TRACEBACK
WRITE (NOUT,99997) DO 9005 J=CALLVL, 1, -1 IF (J .GT. 1) THEN IF (ISUSER(J-1)) THEN WRITE (NOUT,99998) RNAME(J), ERTYPE(J), ERCODE(J) ELSE WRITE (NOUT,99999) RNAME(J), ERTYPE(J), ERCODE(J) END IF ELSE WRITE (NOUT,99998) RNAME(J), ERTYPE(J), ERCODE(J) END IF 9005 CONTINUE END IF
C
RETURN
99995 FORMAT (/, ‘ *** ’, 8A1, ‘ ERROR’, 59A1) 99996 FORMAT (‘ *** ’, 9X, 64A1) 99997 FORMAT (14X, ‘Here is a traceback of subprogram calls’,
& ' in reverse order:', /, 14X, ' Routine Error ', & 'type Error code', /, 14X, ' ------- ', & '---------- ----------')
99998 FORMAT (20X, A6, 5X, I6, 8X, I6) 99999 FORMAT (20X, A6, 5X, I6, 8X, I6, 4X, ‘(Called internally)’)
END
C———————————————————————– C IMSL Name: E1UCS C C Computer: PCDSMS/SINGLE C C Revised: March 8, 1984 C C Purpose: To update the checksum number for error messages. C C Usage: CALL E1UCS C C Arguments: None C C Copyright: 1984 by IMSL, Inc. All rights reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE E1UCS
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, IBEG, IBEG2, IEND, ILOC, IPOS, JLOC, NCODE, NLEN DOUBLE PRECISION DNUM
C SPECIFICATIONS FOR SAVE VARIABLES
DOUBLE PRECISION DMAX CHARACTER BLANK(1), COMMA(1), EQUAL(1), LPAR(1) SAVE BLANK, COMMA, DMAX, EQUAL, LPAR
C SPECIFICATIONS FOR SPECIAL CASES C SPECIFICATIONS FOR COMMON /ERCOM1/
INTEGER CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51), & PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7, & IALLOC(51), HDRFMT(7), TRACON(7) COMMON /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE, & PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT, & TRACON SAVE /ERCOM1/
C SPECIFICATIONS FOR COMMON /ERCOM2/
CHARACTER MSGSAV(255), PLIST(300), RNAME(51)*6 COMMON /ERCOM2/ MSGSAV, PLIST, RNAME SAVE /ERCOM2/
C SPECIFICATIONS FOR COMMON /ERCOM3/
DOUBLE PRECISION ERCKSM COMMON /ERCOM3/ ERCKSM SAVE /ERCOM3/
C SPECIFICATIONS FOR COMMON /ERCOM4/
LOGICAL ISUSER(51) COMMON /ERCOM4/ ISUSER SAVE /ERCOM4/
C SPECIFICATIONS FOR INTRINSICS C INTRINSIC DMOD
INTRINSIC DMOD DOUBLE PRECISION DMOD
C SPECIFICATIONS FOR SUBROUTINES
EXTERNAL S1ANUM
C SPECIFICATIONS FOR FUNCTIONS
EXTERNAL ICASE, I1X INTEGER ICASE, I1X
C
DATA BLANK(1)/' '/, COMMA(1)/','/, LPAR(1)/'('/ DATA EQUAL(1)/'='/, DMAX/1.0D+9/
C
IF (MSGLEN .GT. 1) THEN IPOS = 0 IBEG2 = 1 10 IBEG = IBEG2 IEND = MSGLEN
C LOOK FOR BLANK, COMMA, LEFT PAREN., C OR EQUAL SIGN
ILOC = I1X(MSGSAV(IBEG),IEND-IBEG+1,BLANK,1) JLOC = I1X(MSGSAV(IBEG),IEND-IBEG+1,COMMA,1) IF (ILOC.EQ.0 .OR. (JLOC.GT.0.AND.JLOC.LT.ILOC)) ILOC = JLOC JLOC = I1X(MSGSAV(IBEG),IEND-IBEG+1,LPAR,1) IF (ILOC.EQ.0 .OR. (JLOC.GT.0.AND.JLOC.LT.ILOC)) ILOC = JLOC JLOC = I1X(MSGSAV(IBEG),IEND-IBEG+1,EQUAL,1) IF (ILOC.EQ.0 .OR. (JLOC.GT.0.AND.JLOC.LT.ILOC)) ILOC = JLOC IF (ILOC .GE. 1) THEN CALL S1ANUM (MSGSAV(IBEG+ILOC), IEND-IBEG-ILOC+1, NCODE, & NLEN) IF (NCODE.EQ.2 .OR. NCODE.EQ.3) THEN
C FLOATING POINT NUMBER FOUND. C SET POINTERS TO SKIP OVER IT
IBEG2 = IBEG + ILOC + NLEN IF (IBEG2 .LE. MSGLEN) THEN CALL S1ANUM (MSGSAV(IBEG2), IEND-IBEG2+1, NCODE, & NLEN) IF ((MSGSAV(IBEG2).EQ.'+'.OR.MSGSAV(IBEG2).EQ. & '-') .AND. NCODE.EQ.1) THEN
C INTEGER IMMEDIATELY FOLLOWS A REAL AS C WITH SOME CDC NOS. LIKE 1.2345678+123 C SET POINTERS TO SKIP OVER IT
IBEG2 = IBEG2 + NLEN END IF END IF ELSE IBEG2 = IBEG + ILOC END IF IEND = IBEG + ILOC - 1 END IF
C UPDATE CKSUM USING PART OF MESSAGE
DO 20 I=IBEG, IEND IPOS = IPOS + 1 DNUM = ICASE(MSGSAV(I)) ERCKSM = DMOD(ERCKSM+DNUM*IPOS,DMAX) 20 CONTINUE
C GO BACK FOR MORE IF NEEDED
IF (IEND.LT.MSGLEN .AND. IBEG2.LT.MSGLEN) GO TO 10
C UPDATE CKSUM USING ERROR TYPE
DNUM = ERTYPE(CALLVL) ERCKSM = DMOD(ERCKSM+DNUM*(IPOS+1),DMAX)
C UPDATE CKSUM USING ERROR CODE
DNUM = ERCODE(CALLVL) ERCKSM = DMOD(ERCKSM+DNUM*(IPOS+2),DMAX) END IF
C
RETURN END
C———————————————————————– C IMSL Name: M1VE C C Computer: DGC/SINGLE C C Revised: March 5, 1984 C C Purpose: Move a subset of one character array to another. C C Usage: CALL M1VE(INSTR, INBEG, INEND, INLEN, OUTSTR, OUTBEG, C OUTEND, OUTLEN, IER) C C Arguments: C INSTR - Source character array. (Input) C INBEG - First element of INSTR to be moved. (Input) C INEND - Last element of INSTR to be moved. (Input) C The source subset is INSTR(INBEG),…,INSTR(INEND). C INLEN - Length of INSTR. (Input) C OUTSTR - Destination character array. (Output) C IUTBEG - First element of OUTSTR destination. (Input) C IUTEND - Last element of OUTSTR destination. (Input) C The destination subset is OUTSRT(IUTBEG),…, C OUTSTR(IUTEND). C IUTLEN - Length of OUTSTR. (Input) C IER - Completion code. (Output) C IER = -2 indicates that the input parameters, INBEG, C INEND, INLEN, IUTBEG, IUTEND are not C consistent. One of the conditions C INBEG.GT.0, INEND.GE.INBEG, INLEN.GE.INEND, C IUTBEG.GT.0, or IUTEND.GE.IUTBEG is not C satisfied. C IER = -1 indicates that the length of OUTSTR is C insufficient to hold the subset of INSTR. C That is, IUTLEN is less than IUTEND. C IER = 0 indicates normal completion C IER > 0 indicates that the specified subset of OUTSTR, C OUTSTR(IUTBEG),…,OUTSTR(IUTEND) is not long C enough to hold the subset INSTR(INBEG),…, C INSTR(INEND) of INSTR. IER is set to the C number of characters that were not moved. C C Remarks: C 1. If the subset of OUTSTR is longer than the subset of INSTR, C trailing blanks are moved to OUTSTR. C 2. If the subset of INSTR is longer than the subset of OUTSTR, C the shorter subset is moved to OUTSTR and IER is set to the number C of characters that were not moved to OUTSTR. C 3. If the length of OUTSTR is insufficient to hold the subset, C IER is set to -2 and nothing is moved. C C Copyright: 1984 by IMSL, Inc. All rights reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE M1VE (INSTR, INBEG, INEND, INLEN, OUTSTR, IUTBEG, & IUTEND, IUTLEN, IER)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER INBEG, INEND, INLEN, IUTBEG, IUTEND, IUTLEN, IER CHARACTER INSTR(*), OUTSTR(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER IUTLAS, KI, KO
C SPECIFICATIONS FOR SAVE VARIABLES
CHARACTER BLANK SAVE BLANK
C SPECIFICATIONS FOR INTRINSICS C INTRINSIC MIN0
INTRINSIC MIN0 INTEGER MIN0
C
DATA BLANK/' '/
C CHECK INBEG, INEND, INLEN, IUTBEG, C AND IUTEND C
IF (INBEG.LE.0 .OR. INEND.LT.INBEG .OR. INLEN.LT.INEND .OR. & IUTBEG.LE.0 .OR. IUTEND.LT.IUTBEG) THEN IER = -2 RETURN ELSE IF (IUTLEN .LT. IUTEND) THEN IER = -1 RETURN END IF
C DETERMINE LAST CHARACTER TO M1VE
IUTLAS = IUTBEG + MIN0(INEND-INBEG,IUTEND-IUTBEG)
C M1VE CHARACTERS
KI = INBEG DO 10 KO=IUTBEG, IUTLAS OUTSTR(KO) = INSTR(KI) KI = KI + 1 10 CONTINUE
C SET IER TO NUMBER OF CHARACTERS THAT C WHERE NOT MOVED
IER = KI - INEND - 1
C APPEND BLANKS IF NECESSARY
DO 20 KO=IUTLAS + 1, IUTEND OUTSTR(KO) = BLANK 20 CONTINUE
C
RETURN END
C———————————————————————– C IMSL Name: M1VECH C C Computer: DGC/SINGLE C C Revised: December 31, 1984 C C Purpose: Character substring assignment. C C Usage: CALL M1VECH (STR1, LEN1, STR2, LEN2) C C Arguments: C STR1 - Source substring. (Input) C The source substring is STR1(1:LEN1). C LEN1 - Length of STR1. (Input) C STR2 - Destination substring. (Output) C The destination substring is STR2(1:LEN2). C LEN2 - Length of STR2. (Input) C C Copyright: 1984 by IMSL, Inc. All rights reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE M1VECH (STR1, LEN1, STR2, LEN2)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER LEN1, LEN2 CHARACTER STR1*(*), STR2*(*)
C
STR2(1:LEN2) = STR1(1:LEN1)
C
RETURN END
C———————————————————————– C IMSL Name: I1DX (Single precision version) C C Computer: DGC/SINGLE C C Revised: September 9, 1985 C C Purpose: Determine the array subscript indicating the starting C element at which a key character sequence begins. C (Case-insensitive version) C C Usage: I1DX(CHRSTR, I1LEN, KEY, KLEN) C C Arguments: C CHRSTR - Character array to be searched. (Input) C I1LEN - Length of CHRSTR. (Input) C KEY - Character array that contains the key sequence. (Input) C KLEN - Length of KEY. (Input) C I1DX - Integer function. (Output) C C Remarks: C 1. Returns zero when there is no match. C C 2. Returns zero if KLEN is longer than ISLEN. C C 3. Returns zero when any of the character arrays has a negative or C zero length. C C GAMS: N5c C C Chapter: MATH/LIBRARY Utilities C C Copyright: 1985 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
INTEGER FUNCTION I1DX (CHRSTR, I1LEN, KEY, KLEN)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER I1LEN, KLEN CHARACTER CHRSTR(*), KEY(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, II, J
C SPECIFICATIONS FOR FUNCTIONS
EXTERNAL ICASE, I1CSTR INTEGER ICASE, I1CSTR
C
I1DX = 0 IF (KLEN.LE.0 .OR. I1LEN.LE.0) GO TO 9000 IF (KLEN .GT. I1LEN) GO TO 9000
C
I = 1 II = I1LEN - KLEN + 1 10 IF (I .LE. II) THEN IF (ICASE(CHRSTR(I)) .EQ. ICASE(KEY(1))) THEN IF (KLEN .NE. 1) THEN J = KLEN - 1 IF (I1CSTR(CHRSTR(I+1),J,KEY(2),J) .EQ. 0) THEN I1DX = I GO TO 9000 END IF ELSE I1DX = I GO TO 9000 END IF END IF I = I + 1 GO TO 10 END IF
C
9000 RETURN END
C———————————————————————– C IMSL Name: I1KRL C C Computer: PCDSMS/SINGLE C C Revised: August 9, 1983 C C Purpose: Deallocate the last N allocations made in the workspace. C stack by I1KGT C C Usage: CALL I1KRL(N) C C Arguments: C N - Number of allocations to be released top down (Input) C C Copyright: 1983 by IMSL, Inc. All Rights Reserved C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE I1KRL (N)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER N
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, IN, LALC, LBND, LBOOK, LMAX, LNEED, LNOW, LOUT, & LUSED, NDX, NEXT
C SPECIFICATIONS FOR SAVE VARIABLES
LOGICAL FIRST SAVE FIRST
C SPECIFICATIONS FOR SPECIAL CASES C SPECIFICATIONS FOR COMMON /WORKSP/
REAL RWKSP(61913) REAL RDWKSP(5000) DOUBLE PRECISION DWKSP(2500) COMPLEX CWKSP(2500) COMPLEX CZWKSP(2500) COMPLEX *16 ZWKSP(1250) INTEGER IWKSP(5000) LOGICAL LWKSP(5000) EQUIVALENCE (DWKSP(1), RWKSP(1)) EQUIVALENCE (CWKSP(1), RWKSP(1)), (ZWKSP(1), RWKSP(1)) EQUIVALENCE (IWKSP(1), RWKSP(1)), (LWKSP(1), RWKSP(1)) EQUIVALENCE (RDWKSP(1), RWKSP(1)), (CZWKSP(1), RWKSP(1)) COMMON /WORKSP/ RWKSP
C SPECIFICATIONS FOR EQUIVALENCE
EQUIVALENCE (LOUT, IWKSP(1)) EQUIVALENCE (LNOW, IWKSP(2)) EQUIVALENCE (LUSED, IWKSP(3)) EQUIVALENCE (LBND, IWKSP(4)) EQUIVALENCE (LMAX, IWKSP(5)) EQUIVALENCE (LALC, IWKSP(6)) EQUIVALENCE (LNEED, IWKSP(7)) EQUIVALENCE (LBOOK, IWKSP(8))
C SPECIFICATIONS FOR SUBROUTINES
EXTERNAL E1MES, E1STI, IWKIN
C
DATA FIRST/.TRUE./
C
IF (FIRST) THEN
C INITIALIZE WORKSPACE IF NEEDED
FIRST = .FALSE. CALL IWKIN (0) END IF
C CALLING I1KRL(0) WILL CONFIRM C INTEGRITY OF SYSTEM AND RETURN
IF (N .LT. 0) THEN CALL E1MES (5, 10, 'Error from subroutine I1KRL: Attempt'// & ' to release a negative number of workspace'// & ' allocations. ') GO TO 9000 END IF
C BOOKKEEPING OVERWRITTEN
IF (LNOW.LT.LBOOK .OR. LNOW.GT.LUSED .OR. LUSED.GT.LMAX .OR. & LNOW.GE.LBND .OR. LOUT.GT.LALC) THEN CALL E1MES (5, 11, 'Error from subroutine I1KRL: One or '// & 'more of the first eight bookkeeping locations '// & 'in IWKSP have been overwritten. ') GO TO 9000 END IF
C CHECK ALL THE POINTERS IN THE C PERMANENT STORAGE AREA. THEY MUST C BE MONOTONE INCREASING AND LESS THAN C OR EQUAL TO LMAX, AND THE INDEX OF C THE LAST POINTER MUST BE LMAX+1.
NDX = LBND IF (NDX .NE. LMAX+1) THEN DO 10 I=1, LALC NEXT = IWKSP(NDX) IF (NEXT .EQ. LMAX+1) GO TO 20
C
IF (NEXT.LE.NDX .OR. NEXT.GT.LMAX) THEN CALL E1MES (5, 12, 'Error from subroutine I1KRL: '// & 'A pointer in permanent storage has been '// & ' overwritten. ') GO TO 9000 END IF NDX = NEXT 10 CONTINUE CALL E1MES (5, 13, 'Error from subroutine I1KRL: A '// & 'pointer in permanent storage has been '// & 'overwritten. ') GO TO 9000 END IF 20 IF (N .GT. 0) THEN DO 30 IN=1, N IF (LNOW .LE. LBOOK) THEN CALL E1MES (5, 14, 'Error from subroutine I1KRL: '// & 'Attempt to release a nonexistant '// & 'workspace allocation. ') GO TO 9000 ELSE IF (IWKSP(LNOW).LT.LBOOK .OR. IWKSP(LNOW).GE.LNOW-1) & THEN
C CHECK TO MAKE SURE THE BACK POINTERS C ARE MONOTONE.
CALL E1STI (1, LNOW) CALL E1MES (5, 15, 'Error from subroutine I1KRL: '// & 'The pointer at IWKSP(%(I1)) has been '// & 'overwritten. ') GO TO 9000 ELSE LOUT = LOUT - 1 LNOW = IWKSP(LNOW) END IF 30 CONTINUE END IF
C
9000 RETURN END
C———————————————————————– C IMSL Name: I1KST C C Computer: PCDSMS/SINGLE C C Revised: August 9, 1983 C C Purpose: Return control information about the workspace stack. C C Usage: I1KST(NFACT) C C Arguments: C NFACT - Integer value between 1 and 6 inclusive returns the C following information: (Input) C NFACT = 1 - LOUT: number of current allocations C excluding permanent storage. At the C end of a run, there should be no C active allocations. C NFACT = 2 - LNOW: current active length C NFACT = 3 - LTOTAL: total storage used thus far C NFACT = 4 - LMAX: maximum storage allowed C NFACT = 5 - LALC: total number of allocations made C by I1KGT thus far C NFACT = 6 - LNEED: number of numeric storage units C by which the stack size must be C increased for all past allocations C to succeed C I1KST - Integer function. (Output) Returns a workspace stack C statistic according to value of NFACT. C C Copyright: 1983 by IMSL, Inc. All Rights Reserved C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
INTEGER FUNCTION I1KST (NFACT)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER NFACT
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER ISTATS(7)
C SPECIFICATIONS FOR SAVE VARIABLES
LOGICAL FIRST SAVE FIRST
C SPECIFICATIONS FOR SPECIAL CASES C SPECIFICATIONS FOR COMMON /WORKSP/
REAL RWKSP(61913) REAL RDWKSP(5000) DOUBLE PRECISION DWKSP(2500) COMPLEX CWKSP(2500) COMPLEX CZWKSP(2500) COMPLEX *16 ZWKSP(1250) INTEGER IWKSP(5000) LOGICAL LWKSP(5000) EQUIVALENCE (DWKSP(1), RWKSP(1)) EQUIVALENCE (CWKSP(1), RWKSP(1)), (ZWKSP(1), RWKSP(1)) EQUIVALENCE (IWKSP(1), RWKSP(1)), (LWKSP(1), RWKSP(1)) EQUIVALENCE (RDWKSP(1), RWKSP(1)), (CZWKSP(1), RWKSP(1)) COMMON /WORKSP/ RWKSP
C SPECIFICATIONS FOR EQUIVALENCE
EQUIVALENCE (ISTATS(1), IWKSP(1))
C SPECIFICATIONS FOR SUBROUTINES
EXTERNAL E1MES, IWKIN
C
DATA FIRST/.TRUE./
C
IF (FIRST) THEN
C INITIALIZE WORKSPACE IF NEEDED
FIRST = .FALSE. CALL IWKIN (0) END IF
C
IF (NFACT.LE.0 .OR. NFACT.GE.7) THEN CALL E1MES (5, 9, 'Error from subroutine I1KST: Argument'// & ' for I1KST must be between 1 and 6 inclusive.') ELSE IF (NFACT .EQ. 1) THEN
C LOUT
I1KST = ISTATS(1) ELSE IF (NFACT .EQ. 2) THEN
C LNOW + PERMANENT
I1KST = ISTATS(2) + (ISTATS(5)-ISTATS(4)+1) ELSE IF (NFACT .EQ. 3) THEN
C LUSED + PERMANENT
I1KST = ISTATS(3) + (ISTATS(5)-ISTATS(4)+1) ELSE IF (NFACT .EQ. 4) THEN
C LMAX
I1KST = ISTATS(5) ELSE IF (NFACT .EQ. 5) THEN
C LALC
I1KST = ISTATS(6) ELSE IF (NFACT .EQ. 6) THEN
C LNEED
I1KST = ISTATS(7) END IF
C
RETURN END
C———————————————————————– C IMSL Name: I1KQU C C Computer: PCDSMS/SINGLE C C Revised: January 17, 1984 C C Purpose: Return number of elements of data type ITYPE that C remain to be allocated in one request. C C Usage: I1KQU(ITYPE) C C Arguments: C ITYPE - Type of storage to be checked (Input) C 1 - logical C 2 - integer C 3 - real C 4 - double precision C 5 - complex C 6 - double complex C I1KQU - Integer function. (Output) Returns number of elements C of data type ITYPE remaining in the stack. C C Copyright: 1983 by IMSL, Inc. All Rights Reserved C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
INTEGER FUNCTION I1KQU (ITYPE)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER ITYPE
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER ISIZE(6), LALC, LBND, LBOOK, LMAX, LNEED, LNOW, LOUT, & LUSED
C SPECIFICATIONS FOR SAVE VARIABLES
LOGICAL FIRST SAVE FIRST
C SPECIFICATIONS FOR SPECIAL CASES C SPECIFICATIONS FOR COMMON /WORKSP/
REAL RWKSP(61913) REAL RDWKSP(5000) DOUBLE PRECISION DWKSP(2500) COMPLEX CWKSP(2500) COMPLEX CZWKSP(2500) COMPLEX *16 ZWKSP(1250) INTEGER IWKSP(5000) LOGICAL LWKSP(5000) EQUIVALENCE (DWKSP(1), RWKSP(1)) EQUIVALENCE (CWKSP(1), RWKSP(1)), (ZWKSP(1), RWKSP(1)) EQUIVALENCE (IWKSP(1), RWKSP(1)), (LWKSP(1), RWKSP(1)) EQUIVALENCE (RDWKSP(1), RWKSP(1)), (CZWKSP(1), RWKSP(1)) COMMON /WORKSP/ RWKSP
C SPECIFICATIONS FOR EQUIVALENCE
EQUIVALENCE (LOUT, IWKSP(1)) EQUIVALENCE (LNOW, IWKSP(2)) EQUIVALENCE (LUSED, IWKSP(3)) EQUIVALENCE (LBND, IWKSP(4)) EQUIVALENCE (LMAX, IWKSP(5)) EQUIVALENCE (LALC, IWKSP(6)) EQUIVALENCE (LNEED, IWKSP(7)) EQUIVALENCE (LBOOK, IWKSP(8)) EQUIVALENCE (ISIZE(1), IWKSP(11))
C SPECIFICATIONS FOR INTRINSICS C INTRINSIC MAX0
INTRINSIC MAX0 INTEGER MAX0
C SPECIFICATIONS FOR SUBROUTINES
EXTERNAL E1MES, E1POP, E1PSH, IWKIN
C
DATA FIRST/.TRUE./
C
CALL E1PSH ('I1KQU ')
C
IF (FIRST) THEN
C INITIALIZE WORKSPACE IF NEEDED
FIRST = .FALSE. CALL IWKIN (0) END IF
C BOOKKEEPING OVERWRITTEN
IF (LNOW.LT.LBOOK .OR. LNOW.GT.LUSED .OR. LUSED.GT.LMAX .OR. & LNOW.GE.LBND .OR. LOUT.GT.LALC) THEN CALL E1MES (5, 7, 'One or more of the first eight '// & 'bookkeeping locations in IWKSP have been '// & 'overwritten.') ELSE IF (ITYPE.LE.0 .OR. ITYPE.GE.7) THEN
C ILLEGAL DATA TYPE REQUESTED
CALL E1MES (5, 8, 'Illegal data type requested.') ELSE
C THIS CALCULATION ALLOWS FOR THE C TWO POINTER LOCATIONS IN THE STACK C WHICH ARE ASSIGNED TO EACH ALLOCATION
I1KQU = MAX0(((LBND-3)*ISIZE(2))/ISIZE(ITYPE)-(LNOW*ISIZE(2)- & 1)/ISIZE(ITYPE)-1,0) END IF
C
CALL E1POP ('I1KQU ') RETURN END
C———————————————————————– C IMSL Name: IWKIN (Single precision version) C C Computer: PCDSMS/SINGLE C C Revised: January 17, 1984 C C Purpose: Initialize bookkeeping locations describing the C workspace stack. C C Usage: CALL IWKIN (NSU) C C Argument: C NSU - Number of numeric storage units to which the workspace C stack is to be initialized C C GAMS: N4 C C Chapters: MATH/LIBRARY Reference Material C STAT/LIBRARY Reference Material C C Copyright: 1984 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE IWKIN (NSU)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER NSU
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER ISIZE(6), LALC, LBND, LBOOK, LMAX, LNEED, LNOW, LOUT, & LUSED, MELMTS, MTYPE
C SPECIFICATIONS FOR SAVE VARIABLES
LOGICAL FIRST SAVE FIRST
C SPECIFICATIONS FOR SPECIAL CASES C SPECIFICATIONS FOR COMMON /WORKSP/
REAL RWKSP(61913) REAL RDWKSP(5000) DOUBLE PRECISION DWKSP(2500) COMPLEX CWKSP(2500) COMPLEX CZWKSP(2500) COMPLEX *16 ZWKSP(1250) INTEGER IWKSP(5000) LOGICAL LWKSP(5000) EQUIVALENCE (DWKSP(1), RWKSP(1)) EQUIVALENCE (CWKSP(1), RWKSP(1)), (ZWKSP(1), RWKSP(1)) EQUIVALENCE (IWKSP(1), RWKSP(1)), (LWKSP(1), RWKSP(1)) EQUIVALENCE (RDWKSP(1), RWKSP(1)), (CZWKSP(1), RWKSP(1)) COMMON /WORKSP/ RWKSP
C SPECIFICATIONS FOR EQUIVALENCE
EQUIVALENCE (LOUT, IWKSP(1)) EQUIVALENCE (LNOW, IWKSP(2)) EQUIVALENCE (LUSED, IWKSP(3)) EQUIVALENCE (LBND, IWKSP(4)) EQUIVALENCE (LMAX, IWKSP(5)) EQUIVALENCE (LALC, IWKSP(6)) EQUIVALENCE (LNEED, IWKSP(7)) EQUIVALENCE (LBOOK, IWKSP(8)) EQUIVALENCE (ISIZE(1), IWKSP(11))
C SPECIFICATIONS FOR INTRINSICS C INTRINSIC MAX0
INTRINSIC MAX0 INTEGER MAX0
C SPECIFICATIONS FOR SUBROUTINES
EXTERNAL E1MES, E1STI
C
DATA FIRST/.TRUE./
C
IF (.NOT.FIRST) THEN IF (NSU .NE. 0) THEN CALL E1STI (1, LMAX) CALL E1MES (5, 100, 'Error from subroutine IWKIN: '// & 'Workspace stack has previously been '// & 'initialized to %(I1). Correct by making the '// & 'call to IWKIN the first executable '// & 'statement in the main program. ')
C
STOP
C
ELSE RETURN END IF END IF
C
IF (NSU .EQ. 0) THEN
C IF NSU=0 USE DEFAULT SIZE 5000
MELMTS = 5000 ELSE MELMTS = NSU END IF
C NUMBER OF ITEMS .LT. 0
IF (MELMTS .LE. 0) THEN CALL E1STI (1, MELMTS) CALL E1MES (5, 1, 'Error from subroutine IWKIN: Number '// & 'of numeric storage units is not positive. NSU '// & '= %(I1) ') ELSE
C
FIRST = .FALSE.
C HERE TO INITIALIZE C C SET DATA SIZES APPROPRIATE FOR A C STANDARD CONFORMING FORTRAN SYSTEM C USING THE FORTRAN C *NUMERIC STORAGE UNIT* AS THE C MEASURE OF SIZE. C C TYPE IS REAL
MTYPE = 3
C LOGICAL
ISIZE(1) = 1
C INTEGER
ISIZE(2) = 1
C REAL
ISIZE(3) = 1
C DOUBLE PRECISION
ISIZE(4) = 2
C COMPLEX
ISIZE(5) = 2
C DOUBLE COMPLEX
ISIZE(6) = 4
C NUMBER OF WORDS USED FOR BOOKKEEPING
LBOOK = 16
C CURRENT ACTIVE LENGTH OF THE STACK
LNOW = LBOOK
C MAXIMUM VALUE OF LNOW ACHIEVED THUS C FAR
LUSED = LBOOK
C MAXIMUM LENGTH OF THE STORAGE ARRAY
LMAX = MAX0(MELMTS,((LBOOK+2)*ISIZE(2)+ISIZE(3)-1)/ISIZE(3))
C LOWER BOUND OF THE PERMANENT STORAGE C WHICH IS ONE WORD MORE THAN THE C MAXIMUM ALLOWED LENGTH OF THE STACK
LBND = LMAX + 1
C NUMBER OF CURRENT ALLOCATIONS
LOUT = 0
C TOTAL NUMBER OF ALLOCATIONS MADE
LALC = 0
C NUMBER OF WORDS BY WHICH THE ARRAY C SIZE MUST BE INCREASED FOR ALL PAST C ALLOCATIONS TO SUCCEED
LNEED = 0 END IF
C
RETURN END
C———————————————————————– C IMSL Name: I1X (Single precision version) C C Computer: DGC/SINGLE C C Revised: August 30, 1985 C C Purpose: Determine the array subscript indicating the starting C element at which a key character sequence begins. C (Case-sensitive version) C C Usage: I1X(CHRSTR, I1LEN, KEY, KLEN) C C Arguments: C CHRSTR - Character array to be searched. (Input) C I1LEN - Length of CHRSTR. (Input) C KEY - Character array that contains the key sequence. (Input) C KLEN - Length of KEY. (Input) C I1X - Integer function. (Output) C C Remarks: C 1. Returns zero when there is no match. C C 2. Returns zero if KLEN is longer than ISLEN. C C 3. Returns zero when any of the character arrays has a negative or C zero length. C C GAMS: N5c C C Chapter: MATH/LIBRARY Utilities C C Copyright: 1985 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
INTEGER FUNCTION I1X (CHRSTR, I1LEN, KEY, KLEN)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER I1LEN, KLEN CHARACTER CHRSTR(*), KEY(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, II, J
C
I1X = 0 IF (KLEN.LE.0 .OR. I1LEN.LE.0) GO TO 9000 IF (KLEN .GT. I1LEN) GO TO 9000
C
I = 1 II = I1LEN - KLEN + 1 10 IF (I .LE. II) THEN IF (CHRSTR(I) .EQ. KEY(1)) THEN DO 20 J=2, KLEN IF (CHRSTR(I+J-1) .NE. KEY(J)) GO TO 30 20 CONTINUE I1X = I GO TO 9000 30 CONTINUE END IF I = I + 1 GO TO 10 END IF
C
9000 RETURN END
C———————————————————————– C IMSL Name: C1TIC C C Computer: PCDSMS/SINGLE C C Revised: March 9, 1984 C C Purpose: Convert an integer to its corresponding character form. C (Right justified) C C Usage: CALL C1TIC(NUM, CHRSTR, SLEN, IER) C C Arguments: C NUM - Integer number. (Input) C CHRSTR - Character array that receives the result. (Output) C SLEN - Length of the character array. (Input) C IER - Completion code. (Output) Where C IER < 0 indicates that SLEN <= 0, C IER = 0 indicates normal completion, C IER > 0 indicates that the character array is too C small to hold the complete number. IER C indicates how many significant digits are C being truncated. C C Remarks: C 1. The character array is filled in a right justified manner. C 2. Leading zeros are replaced by blanks. C 3. Sign is inserted only for negative number. C C Copyright: 1984 by IMSL, Inc. All rights reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE C1TIC (NUM, CHRSTR, SLEN, IER)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER NUM, SLEN, IER CHARACTER CHRSTR(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, J, K, L
C SPECIFICATIONS FOR SAVE VARIABLES
CHARACTER BLANK(1), DIGIT(10), MINUS(1) SAVE BLANK, DIGIT, MINUS
C SPECIFICATIONS FOR INTRINSICS C INTRINSIC IABS
INTRINSIC IABS INTEGER IABS
C SPECIFICATIONS FOR SUBROUTINES
EXTERNAL M1VE
C
DATA DIGIT/'0', '1', '2', '3', '4', '5', '6', '7', '8', & '9'/ DATA BLANK/' '/, MINUS/'-'/
C CHECK SLEN
IF (SLEN .LE. 0) THEN IER = -1 RETURN END IF
C THE NUMBER IS ZERO
IF (NUM .EQ. 0) THEN CALL M1VE (BLANK, 1, 1, 1, CHRSTR, 1, SLEN-1, SLEN, I) CHRSTR(SLEN) = DIGIT(1) IER = 0 RETURN END IF
C CONVERT NUMBER DIGIT BY DIGIT TO C CHARACTER FORM
J = SLEN K = IABS(NUM) 10 IF (K.GT.0 .AND. J.GE.1) THEN L = K K = K/10 L = L - K*10 CHRSTR(J) = DIGIT(L+1) J = J - 1 GO TO 10 END IF
C
20 IF (K .EQ. 0) THEN IF (NUM .LT. 0) THEN CALL M1VE (MINUS, 1, 1, 1, CHRSTR, J, J, SLEN, I) IF (I .NE. 0) THEN IER = 1 RETURN END IF J = J - 1 END IF IER = 0 CALL M1VE (BLANK, 1, 1, 1, CHRSTR, 1, J, SLEN, I) RETURN END IF
C DETERMINE THE NUMBER OF SIGNIFICANT C DIGITS BEING TRUNCATED
I = 0 30 IF (K .GT. 0) THEN K = K/10 I = I + 1 GO TO 30 END IF
C
IF (NUM .LT. 0) I = I + 1 IER = I
C
RETURN END
C———————————————————————– C IMSL Name: N1RGB C C Computer: DGC/SINGLE C C Revised: March 2, 1984 C C Purpose: Return a positive number as a flag to indicated that a C stop should occur due to one or more global errors. C C Usage: N1RGB(IDUMMY) C C Arguments: C IDUMMY - Integer scalar dummy argument. C C Copyright: 1984 by IMSL, Inc. All rights reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
INTEGER FUNCTION N1RGB (IDUMMY)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER IDUMMY
C SPECIFICATIONS FOR SPECIAL CASES C SPECIFICATIONS FOR COMMON /ERCOM1/
INTEGER CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51), & PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7, & IALLOC(51), HDRFMT(7), TRACON(7) COMMON /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE, & PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT, & TRACON SAVE /ERCOM1/
C SPECIFICATIONS FOR COMMON /ERCOM2/
CHARACTER MSGSAV(255), PLIST(300), RNAME(51)*6 COMMON /ERCOM2/ MSGSAV, PLIST, RNAME SAVE /ERCOM2/
C SPECIFICATIONS FOR COMMON /ERCOM3/
DOUBLE PRECISION ERCKSM COMMON /ERCOM3/ ERCKSM SAVE /ERCOM3/
C SPECIFICATIONS FOR COMMON /ERCOM4/
LOGICAL ISUSER(51) COMMON /ERCOM4/ ISUSER SAVE /ERCOM4/
C INITIALIZE FUNCTION
N1RGB = 0
C CHECK FOR GLOBAL ERROR TYPE 6
IF (IFERR6 .GT. 0) THEN N1RGB = STOPTB(6) IFERR6 = 0 END IF
C CHECK FOR GLOBAL ERROR TYPE 7
IF (IFERR7 .GT. 0) THEN N1RGB = STOPTB(7) IFERR7 = 0 END IF
C
RETURN END
C———————————————————————– C IMSL Name: SDOT (Single precision version) C C Computer: PCDSMS/SINGLE C C Revised: August 9, 1986 C C Purpose: Compute the single-precision dot product x*y. C C Usage: SDOT(N, SX, INCX, SY, INCY) C C Arguments: C N - Length of vectors X and Y. (Input) C SX - Real vector of length MAX(N*IABS(INCX),1). (Input) C INCX - Displacement between elements of SX. (Input) C X(I) is defined to be.. SX(1+(I-1)*INCX) if INCX .GE. 0 C or SX(1+(I-N)*INCX) if INCX .LT. 0. C SY - Real vector of length MAX(N*IABS(INCY),1). (Input) C INCY - Displacement between elements of SY. (Input) C Y(I) is defined to be.. SY(1+(I-1)*INCY) if INCY .GE. 0 C or SY(1+(I-N)*INCY) if INCY .LT. 0. C SDOT - Sum from I=1 to N of X(I)*Y(I). (Output) C X(I) and Y(I) refer to specific elements of SX and SY, C respectively. See INCX and INCY argument descriptions. C C GAMS: D1a4 C C Chapters: MATH/LIBRARY Basic Matrix/Vector Operations C STAT/LIBRARY Mathematical Support C C Copyright: 1986 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
REAL FUNCTION SDOT (N, SX, INCX, SY, INCY)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER N, INCX, INCY REAL SX(*), SY(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, IX, IY, M, MP1
C SPECIFICATIONS FOR SPECIAL CASES C INTRINSIC MOD
INTRINSIC MOD INTEGER MOD
C
SDOT = 0.0E0 IF (N .GT. 0) THEN IF (INCX.NE.1 .OR. INCY.NE.1) THEN
C CODE FOR UNEQUAL INCREMENTS
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 SDOT = SDOT + SX(IX)*SY(IY) IX = IX + INCX IY = IY + INCY 10 CONTINUE ELSE
C CODE FOR BOTH INCREMENTS EQUAL TO 1
M = MOD(N,5)
C CLEAN-UP LOOP SO REMAINING VECTOR
DO 30 I=1, M SDOT = SDOT + SX(I)*SY(I) 30 CONTINUE MP1 = M + 1 DO 40 I=MP1, N, 5 SDOT = SDOT + SX(I)*SY(I) + SX(I+1)*SY(I+1) + & SX(I+2)*SY(I+2) + SX(I+3)*SY(I+3) + & SX(I+4)*SY(I+4) 40 CONTINUE END IF END IF RETURN END
C———————————————————————– C IMSL Name: E1POS C C Computer: DGC/SINGLE C C Revised: March 2, 1984 C C Purpose: Set or retrieve print and stop attributes. C C Usage: CALL E1POS(IERTYP,IPATT,ISATT) C C Arguments: C IERTYP - Integer specifying the error type for which print and C stop attributes are to be set or retrieved. (Input) If C IERTYP is 0 then the settings apply to all error types. C If IERTYP is between 1 and 7, then the settings only C apply to that specified error type. If IERTYP is C negative then the current print and stop attributes will C be returned in IPATT and ISATT. C IPATT - If IERTYP is positive, IPATT is an integer specifying the C desired print attribute as follows: -1 means no change, C 0 means NO, 1 means YES, and 2 means assign the default C setting. (Input) If IERTYP is negative, IPATT is C returned as 1 if print is YES or 0 if print is NO for C error type IABS(IERTYP). (Output) C ISATT - If IERTYP is positive, ISATT is an integer specifying the C desired stop attribute as follows: -1 means no change, C 0 means NO, 1 means YES, and 2 means assign the default C setting. (Input) If IERTYP is negative, ISATT is C returned as 1 if print is YES or 0 if print is NO for C error type IABS(IERTYP). (Output) C C Copyright: 1984 by IMSL, Inc. All rights reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE E1POS (IERTYP, IPATT, ISATT)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER IERTYP, IPATT, ISATT
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, IER
C SPECIFICATIONS FOR SAVE VARIABLES
INTEGER DEFLTP(7), DEFLTS(7), IFINIT SAVE DEFLTP, DEFLTS, IFINIT
C SPECIFICATIONS FOR SPECIAL CASES C SPECIFICATIONS FOR COMMON /ERCOM1/
INTEGER CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51), & PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7, & IALLOC(51), HDRFMT(7), TRACON(7) COMMON /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE, & PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT, & TRACON SAVE /ERCOM1/
C SPECIFICATIONS FOR COMMON /ERCOM2/
CHARACTER MSGSAV(255), PLIST(300), RNAME(51)*6 COMMON /ERCOM2/ MSGSAV, PLIST, RNAME SAVE /ERCOM2/
C SPECIFICATIONS FOR COMMON /ERCOM3/
DOUBLE PRECISION ERCKSM COMMON /ERCOM3/ ERCKSM SAVE /ERCOM3/
C SPECIFICATIONS FOR COMMON /ERCOM4/
LOGICAL ISUSER(51) COMMON /ERCOM4/ ISUSER SAVE /ERCOM4/
C SPECIFICATIONS FOR INTRINSICS C INTRINSIC IABS
INTRINSIC IABS INTEGER IABS
C SPECIFICATIONS FOR SUBROUTINES
EXTERNAL E1INIT, E1MES, E1STI
C
DATA IFINIT/0/ DATA DEFLTP/0, 0, 1, 1, 1, 1, 1/, DEFLTS/0, 0, 0, 1, 1, 0, 1/
C INITIALIZE ERROR TABLE IF NECESSARY
IF (IFINIT .EQ. 0) THEN CALL E1INIT IFINIT = 1 END IF IER = 0 IF (IERTYP .GE. 0) THEN IF (IPATT.LT.-1 .OR. IPATT.GT.2) THEN CALL E1STI (1, IPATT) CALL E1MES (5, 1, 'Invalid value specified for print '// & 'table attribute. IPATT must be -1, 0, 1, '// & 'or 2. IPATT = %(I1)') IER = 1 END IF IF (ISATT.LT.-1 .OR. ISATT.GT.2) THEN CALL E1STI (1, ISATT) CALL E1MES (5, 1, 'Invalid value specified for stop '// & 'table attribute. ISATT must be -1, 0, 1, '// & 'or 2. ISATT = %(I1)') IER = 1 END IF END IF IF (IER .EQ. 0) THEN IF (IERTYP .EQ. 0) THEN IF (IPATT.EQ.0 .OR. IPATT.EQ.1) THEN DO 10 I=1, 7 10 PRINTB(I) = IPATT ELSE IF (IPATT .EQ. 2) THEN
C ASSIGN DEFAULT SETTINGS
DO 20 I=1, 7 20 PRINTB(I) = DEFLTP(I) END IF IF (ISATT.EQ.0 .OR. ISATT.EQ.1) THEN DO 30 I=1, 7 30 STOPTB(I) = ISATT ELSE IF (ISATT .EQ. 2) THEN
C ASSIGN DEFAULT SETTINGS
DO 40 I=1, 7 40 STOPTB(I) = DEFLTS(I) END IF ELSE IF (IERTYP.GE.1 .AND. IERTYP.LE.7) THEN IF (IPATT.EQ.0 .OR. IPATT.EQ.1) THEN PRINTB(IERTYP) = IPATT ELSE IF (IPATT .EQ. 2) THEN
C ASSIGN DEFAULT SETTING
PRINTB(IERTYP) = DEFLTP(IERTYP) END IF IF (ISATT.EQ.0 .OR. ISATT.EQ.1) THEN STOPTB(IERTYP) = ISATT ELSE IF (ISATT .EQ. 2) THEN
C ASSIGN DEFAULT SETTING
STOPTB(IERTYP) = DEFLTS(IERTYP) END IF ELSE IF (IERTYP.LE.-1 .AND. IERTYP.GE.-7) THEN I = IABS(IERTYP) IPATT = PRINTB(I) ISATT = STOPTB(I) END IF END IF
C
RETURN END
C———————————————————————– C IMSL Name: E1STL C C Computer: DGC/SINGLE C C Revised: November 8, 1985 C C Purpose: To store a string for subsequent use within an error C message. C C Usage: CALL E1STL(IL,STRING) C C Arguments: C IL - Integer specifying the substitution index. IL must be C between 1 and 9. (Input) C STRING - A character string. (Input) C C Copyright: 1985 by IMSL, Inc. All rights reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE E1STL (IL, STRING)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER IL CHARACTER STRING*(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, LEN2 CHARACTER STRGUP(255)
C SPECIFICATIONS FOR SAVE VARIABLES
INTEGER IFINIT SAVE IFINIT
C SPECIFICATIONS FOR SPECIAL CASES C SPECIFICATIONS FOR COMMON /ERCOM1/
INTEGER CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51), & PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7, & IALLOC(51), HDRFMT(7), TRACON(7) COMMON /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE, & PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT, & TRACON SAVE /ERCOM1/
C SPECIFICATIONS FOR COMMON /ERCOM2/
CHARACTER MSGSAV(255), PLIST(300), RNAME(51)*6 COMMON /ERCOM2/ MSGSAV, PLIST, RNAME SAVE /ERCOM2/
C SPECIFICATIONS FOR COMMON /ERCOM3/
DOUBLE PRECISION ERCKSM COMMON /ERCOM3/ ERCKSM SAVE /ERCOM3/
C SPECIFICATIONS FOR COMMON /ERCOM4/
LOGICAL ISUSER(51) COMMON /ERCOM4/ ISUSER SAVE /ERCOM4/
C SPECIFICATIONS FOR INTRINSICS C INTRINSIC IABS,LEN,MIN0
INTRINSIC IABS, LEN, MIN0 INTEGER IABS, LEN, MIN0
C SPECIFICATIONS FOR SUBROUTINES
EXTERNAL E1INIT, E1INPL
C
DATA IFINIT/0/
C INITIALIZE IF NECESSARY
IF (IFINIT .EQ. 0) THEN CALL E1INIT IFINIT = 1 END IF LEN2 = LEN(STRING) LEN2 = MIN0(LEN2,255) DO 10 I=1, LEN2 STRGUP(I) = STRING(I:I) 10 CONTINUE IF (IABS(IL).GE.1 .AND. IABS(IL).LE.9) THEN CALL E1INPL ('L', IL, LEN2, STRGUP) END IF
C
RETURN END
C———————————————————————– C IMSL Name: SAXPY (Single precision version) C C Computer: PCDSMS/SINGLE C C Revised: August 9, 1986 C C Purpose: Compute the scalar times a vector plus a vector, C y = ax + y, all single precision. C C Usage: CALL SAXPY (N, SA, SX, INCX, SY, INCY) C C Arguments: C N - Length of vectors X and Y. (Input) C SA - Real scalar. (Input) C SX - Real vector of length MAX(N*IABS(INCX),1). (Input) C INCX - Displacement between elements of SX. (Input) C X(I) is defined to be C SX(1+(I-1)*INCX) if INCX.GE.0 or C SX(1+(I-N)*INCX) if INCX.LT.0. C SY - Real vector of length MAX(N*IABS(INCY),1). C (Input/Output) C SAXPY replaces Y(I) with SA*X(I) + Y(I) for I=1,…,N. C X(I) and Y(I) refer to specific elements of SX and SY. C INCY - Displacement between elements of SY. (Input) C Y(I) is defined to be C SY(1+(I-1)*INCY) if INCY.GE.0 or C SY(1+(I-N)*INCY) if INCY.LT.0. C C GAMS: D1a7 C C Chapters: MATH/LIBRARY Basic Matrix/Vector Operations C STAT/LIBRARY Mathematical Support C C Copyright: 1986 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE SAXPY (N, SA, SX, INCX, SY, INCY)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER N, INCX, INCY REAL SA, SX(*), SY(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, IX, IY, M, MP1
C SPECIFICATIONS FOR SPECIAL CASES C INTRINSIC MOD
INTRINSIC MOD INTEGER MOD
C
IF (N .GT. 0) THEN IF (SA .NE. 0.0) THEN IF (INCX.NE.1 .OR. INCY.NE.1) THEN
C CODE FOR UNEQUAL INCREMENTS OR EQUAL C INCREMENTS NOT EQUAL TO 1
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 SY(IY) = SY(IY) + SA*SX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE ELSE
C CODE FOR BOTH INCREMENTS EQUAL TO 1
M = MOD(N,4)
C CLEAN-UP LOOP
DO 30 I=1, M SY(I) = SY(I) + SA*SX(I) 30 CONTINUE MP1 = M + 1 DO 40 I=MP1, N, 4 SY(I) = SY(I) + SA*SX(I) SY(I+1) = SY(I+1) + SA*SX(I+1) SY(I+2) = SY(I+2) + SA*SX(I+2) SY(I+3) = SY(I+3) + SA*SX(I+3) 40 CONTINUE END IF END IF END IF RETURN END
C———————————————————————– C IMSL Name: I1ERIF C C Computer: PCDSMS/SINGLE C C Revised: March 13, 1984 C C Purpose: Return the position of the first element of a given C character array which is not an element of another C character array. C C Usage: I1ERIF(STR1, LEN1, STR2, LEN2) C C Arguments: C STR1 - Character array to be searched. (Input) C LEN1 - Length of STR1. (Input) C STR2 - Character array to be searched for. (Input) C LEN2 - Length of STR2. (Input) C I1ERIF - Integer function. (Output) C C Copyright: 1984 by IMSL, Inc. All rights reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
INTEGER FUNCTION I1ERIF (STR1, LEN1, STR2, LEN2)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER LEN1, LEN2 CHARACTER STR1(*), STR2(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I
C SPECIFICATIONS FOR FUNCTIONS
EXTERNAL I1X INTEGER I1X
C FIRST EXECUTABLE STATEMENT
IF (LEN1.LE.0 .OR. LEN2.LE.0) THEN I1ERIF = 1 ELSE DO 10 I=1, LEN1 IF (I1X(STR2,LEN2,STR1(I),1) .EQ. 0) THEN I1ERIF = I RETURN END IF 10 CONTINUE I1ERIF = 0 END IF
C
RETURN END
C———————————————————————– C IMSL Name: ICASE (Single precision version) C C Computer: DGC/SINGLE C C Revised: September 9, 1985 C C Purpose: Convert from character to the integer ASCII value without C regard to case. C C Usage: ICASE(CH) C C Arguments: C CH - Character to be converted. (Input) C ICASE - Integer ASCII value for CH without regard to the case C of CH. (Output) C ICASE returns the same value as IMSL routine IACHAR for C all but lowercase letters. For these, it returns the C IACHAR value for the corresponding uppercase letter. C C GAMS: N3 C C Chapter: MATH/LIBRARY Utilities C STAT/LIBRARY Utilities C C Copyright: 1986 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
INTEGER FUNCTION ICASE (CH)
C SPECIFICATIONS FOR ARGUMENTS
CHARACTER CH
C SPECIFICATIONS FOR FUNCTIONS
EXTERNAL IACHAR INTEGER IACHAR
C
ICASE = IACHAR(CH) IF (ICASE.GE.97 .AND. ICASE.LE.122) ICASE = ICASE - 32
C
RETURN END
C———————————————————————– C IMSL Name: S1ANUM C C Computer: PCDSMS/SINGLE C C Revised: March 28, 1984 C C Purpose: Scan a token and identify it as follows: integer, real C number (single/double), FORTRAN relational operator, C FORTRAN logical operator, or FORTRAN logical constant. C C Usage: CALL S1ANUM(INSTR, SLEN, CODE, OLEN) C C Arguments: C INSTR - Character string to be scanned. (Input) C SLEN - Length of INSTR. (Input) C CODE - Token code. (Output) Where C CODE = 0 indicates an unknown token, C CODE = 1 indicates an integer number, C CODE = 2 indicates a (single precision) real number, C CODE = 3 indicates a (double precision) real number, C CODE = 4 indicates a logical constant (.TRUE. or C .FALSE.), C CODE = 5 indicates the relational operator .EQ., C CODE = 6 indicates the relational operator .NE., C CODE = 7 indicates the relational operator .LT., C CODE = 8 indicates the relational operator .LE., C CODE = 9 indicates the relational operator .GT., C CODE = 10 indicates the relational operator .GE., C CODE = 11 indicates the logical operator .AND., C CODE = 12 indicates the logical operator .OR., C CODE = 13 indicates the logical operator .EQV., C CODE = 14 indicates the logical operator .NEQV., C CODE = 15 indicates the logical operator .NOT.. C OLEN - Length of the token as counted from the first character C in INSTR. (Output) OLEN returns a zero for an unknown C token (CODE = 0). C C Remarks: C 1. Blanks are considered significant. C 2. Lower and upper case letters are not significant. C C Copyright: 1984 by IMSL, Inc. All rights reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE S1ANUM (INSTR, SLEN, CODE, OLEN)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER SLEN, CODE, OLEN CHARACTER INSTR(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER I, IBEG, IIBEG, J LOGICAL FLAG CHARACTER CHRSTR(6)
C SPECIFICATIONS FOR SAVE VARIABLES
INTEGER TABPTR(16), TDCNST, TICNST, TOKEN(13), TRCNST, TZERR CHARACTER DIGIT(10), LETTER(52), MINUS, PERIOD, PLUS, TABLE(38) SAVE DIGIT, LETTER, MINUS, PERIOD, PLUS, TABLE, TABPTR, & TDCNST, TICNST, TOKEN, TRCNST, TZERR
C SPECIFICATIONS FOR FUNCTIONS
EXTERNAL I1X, I1CSTR INTEGER I1X, I1CSTR
C
DATA TOKEN/5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 4, 4/ DATA TABLE/'D', 'E', 'E', 'Q', 'N', 'E', 'L', 'T', 'L', & 'E', 'G', 'T', 'G', 'E', 'A', 'N', 'D', 'O', 'R', & 'E', 'Q', 'V', 'N', 'E', 'Q', 'V', 'N', 'O', 'T', & 'T', 'R', 'U', 'E', 'F', 'A', 'L', 'S', 'E'/ DATA TABPTR/1, 2, 3, 5, 7, 9, 11, 13, 15, 18, 20, 23, 27, 30, & 34, 39/ DATA DIGIT/'0', '1', '2', '3', '4', '5', '6', '7', '8', & '9'/ DATA LETTER/'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', '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 PERIOD/'.'/, PLUS/'+'/, MINUS/'-'/ DATA TZERR/0/, TICNST/1/ DATA TRCNST/2/, TDCNST/3/
C
IF (SLEN .LE. 0) THEN CODE = 0 OLEN = 0 RETURN END IF
C STATE 0 - ASSUME ERROR TOKEN
IBEG = 1 CODE = TZERR
C CHECK SIGN
IF (INSTR(IBEG).EQ.MINUS .OR. INSTR(IBEG).EQ.PLUS) THEN FLAG = .TRUE. IIBEG = IBEG IBEG = IBEG + 1 ELSE FLAG = .FALSE. END IF
C STATE 1 - ASSUME INTEGER CONSTANT
IF (I1X(DIGIT,10,INSTR(IBEG),1) .NE. 0) THEN CODE = TICNST IIBEG = IBEG IBEG = IBEG + 1
C
10 IF (IBEG .LE. SLEN) THEN
C
IF (I1X(DIGIT,10,INSTR(IBEG),1) .NE. 0) THEN IIBEG = IBEG IBEG = IBEG + 1 GO TO 10
C
END IF
C
ELSE GO TO 80
C
END IF
C
IF (INSTR(IBEG) .NE. PERIOD) GO TO 80 END IF
C STATE 2 - ASSUME REAL CONSTANT
IF (CODE .EQ. TICNST) THEN CODE = TRCNST IIBEG = IBEG IBEG = IBEG + 1 IF (IBEG .GT. SLEN) GO TO 80 ELSE IF (INSTR(IBEG).EQ.PERIOD .AND. SLEN.GE.2) THEN IF (I1X(DIGIT,10,INSTR(IBEG+1),1) .NE. 0) THEN CODE = TRCNST IIBEG = IBEG + 1 IBEG = IBEG + 2 IF (IBEG .GT. SLEN) GO TO 80 END IF END IF
C
IF (I1X(DIGIT,10,INSTR(IBEG),1) .NE. 0) THEN CODE = TRCNST IIBEG = IBEG IBEG = IBEG + 1
C
20 IF (IBEG .LE. SLEN) THEN
C
IF (I1X(DIGIT,10,INSTR(IBEG),1) .NE. 0) THEN IIBEG = IBEG IBEG = IBEG + 1 GO TO 20
C
END IF
C
ELSE GO TO 80
C
END IF
C
END IF
C
IF (CODE .EQ. TZERR) THEN IF (INSTR(IBEG) .NE. PERIOD) GO TO 80 IBEG = IBEG + 1 IF (IBEG .GT. SLEN) GO TO 80 END IF
C
IF (I1X(LETTER,52,INSTR(IBEG),1) .EQ. 0) GO TO 80 CHRSTR(1) = INSTR(IBEG)
C
DO 30 I=2, 6 IBEG = IBEG + 1 IF (IBEG .GT. SLEN) GO TO 80 IF (I1X(LETTER,52,INSTR(IBEG),1) .EQ. 0) GO TO 40 CHRSTR(I) = INSTR(IBEG) 30 CONTINUE
C
GO TO 80
C
40 CONTINUE
C
DO 50 J=1, 15 IF (I1CSTR(CHRSTR,I-1,TABLE(TABPTR(J)),TABPTR(J+1)-TABPTR(J)) & .EQ. 0) GO TO 60 50 CONTINUE
C
GO TO 80
C STATE 4 - LOGICAL OPERATOR
60 IF (J .GT. 2) THEN
C
IF (CODE .EQ. TRCNST) THEN
C
IF (INSTR(IBEG) .EQ. PERIOD) THEN CODE = TICNST IIBEG = IIBEG - 1 END IF
C
GO TO 80
C
ELSE IF (INSTR(IBEG) .NE. PERIOD) THEN GO TO 80
C
ELSE IF (FLAG) THEN GO TO 80
C
ELSE CODE = TOKEN(J-2) IIBEG = IBEG GO TO 80
C
END IF
C
END IF
C STATE 5 - DOUBLE PRECISION CONSTANT
IF (CODE .NE. TRCNST) GO TO 80 IF (INSTR(IBEG).EQ.MINUS .OR. INSTR(IBEG).EQ.PLUS) IBEG = IBEG + & 1 IF (IBEG .GT. SLEN) GO TO 80
C
IF (I1X(DIGIT,10,INSTR(IBEG),1) .EQ. 0) THEN GO TO 80
C
ELSE IIBEG = IBEG IBEG = IBEG + 1
C
70 IF (IBEG .LE. SLEN) THEN
C
IF (I1X(DIGIT,10,INSTR(IBEG),1) .NE. 0) THEN IIBEG = IBEG IBEG = IBEG + 1 GO TO 70
C
END IF
C
END IF
C
END IF
C
IF (J .EQ. 1) CODE = TDCNST
C
80 CONTINUE
C
IF (CODE .EQ. TZERR) THEN OLEN = 0
C
ELSE OLEN = IIBEG END IF
C
RETURN END
C———————————————————————– C IMSL Name: IMACH (Single precision version) C C Computer: PCDSMS/SINGLE C C Revised: March 26, 1984 C C Purpose: Retrieve integer machine constants. C C Usage: IMACH(N) C C Arguments: C N - Index of desired constant. (Input) C IMACH - Machine constant. (Output) C C Remark: C Following is a description of the assorted integer machine C constants. C C Words C C IMACH( 1) = Number of bits per integer storage unit. C IMACH( 2) = Number of characters per integer storage unit. C C Integers C C Assume integers are represented in the S-DIGIT, BASE-A form C SIGN ( X(S-1)A*(S-1) + … + X(1)*A + X(0) ) C where 0 .LE. X(I) .LT. A for I=0,…,S-1. Then C C IMACH( 3) = A, the base. C IMACH( 4) = S, number of BASE-A digits. C IMACH( 5) = A**S - 1, largest magnitude. C C Floating-point numbers C C Assume floating-point numbers are represented in the T-DIGIT, C BASE-B form SIGN (B*E)( (X(1)/B) + … + (X(T)/B**T) ) C where 0 .LE. X(I) .LT. B for I=1,…,T, C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. Then C C IMACH( 6) = B, the base. C C Single precision C C IMACH( 7) = T, number of BASE-B digits. C IMACH( 8) = EMIN, smallest exponent E. C IMACH( 9) = EMAX, largest exponent E. C C Double precision C C IMACH(10) = T, number of BASE-B digits. C IMACH(11) = EMIN, smallest exponent E. C IMACH(12) = EMAX, largest exponent E. C C GAMS: R1 C C Chapters: MATH/LIBRARY Reference Material C STAT/LIBRARY Reference Material C SFUN/LIBRARY Reference Material C C Copyright: 1984 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
INTEGER FUNCTION IMACH (N)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER N
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER NOUT
C SPECIFICATIONS FOR SAVE VARIABLES
INTEGER IMACHV(12) SAVE IMACHV
C SPECIFICATIONS FOR SUBROUTINES
EXTERNAL UMACH
C DEFINE CONSTANTS
DATA IMACHV(1)/32/ DATA IMACHV(2)/4/ DATA IMACHV(3)/2/ DATA IMACHV(4)/31/ DATA IMACHV(5)/2147483647/ DATA IMACHV(6)/2/ DATA IMACHV(7)/24/ DATA IMACHV(8)/-125/ DATA IMACHV(9)/128/ DATA IMACHV(10)/53/ DATA IMACHV(11)/-1021/ DATA IMACHV(12)/1024/
C
IF (N.LT.1 .OR. N.GT.12) THEN
C ERROR. INVALID RANGE FOR N.
CALL UMACH (2, NOUT) WRITE (NOUT,99999) N
99999 FORMAT (/, ‘ *** TERMINAL ERROR 5 from IMACH. The argument’,
& /, ' *** must be between 1 and 12 inclusive.' & , /, ' *** N = ', I6, '.', /) IMACH = 0 STOP
C
ELSE IMACH = IMACHV(N) END IF
C
RETURN END
C———————————————————————– C IMSL Name: E1INPL C C Computer: PCDSMS/SINGLE C C Revised: March 2, 1984 C C Purpose: To store a character string in the parameter list PLIST C for use by the error message handler. C C Usage: CALL E1INPL(FORM,NUM,SLEN,STRUP) C C Arguments: C FORM - A character string of length one to be inserted into C PLIST which specifies the form of the string. (Input) C For example, ‘L’ for string, ‘A’ for character array, C ‘I’ for integer, ‘K’ for keyword (PROTRAN only). An C asterisk is inserted into PLIST preceding FORM. C NUM - Integer to be inserted as a character into PLIST C immediately following FORM. (Input) NUM must be between C 1 and 9. C SLEN - The number of characters in STRUP. (Input) LEN must be C less than or equal to 255. The character representation C of SLEN is inserted into PLIST after NUM and an asterisk. C STRUP - A character string of length LEN which is to be inserted C into PLIST. (Input) Trailing blanks are ignored. C C Copyright: 1984 by IMSL, Inc. All rights reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE E1INPL (FORM, NUM, SLEN, STRUP)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER NUM, SLEN CHARACTER FORM, STRUP(*)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER IER, L, LEN2, LENCK, LOC, NLEN, NNUM CHARACTER STRNCH(3)
C SPECIFICATIONS FOR SAVE VARIABLES
CHARACTER BLANK, PRCNT(1), TEMP(4) SAVE BLANK, PRCNT, TEMP
C SPECIFICATIONS FOR SPECIAL CASES C SPECIFICATIONS FOR COMMON /ERCOM1/
INTEGER CALLVL, MAXLEV, MSGLEN, ERTYPE(51), ERCODE(51), & PRINTB(7), STOPTB(7), PLEN, IFERR6, IFERR7, & IALLOC(51), HDRFMT(7), TRACON(7) COMMON /ERCOM1/ CALLVL, MAXLEV, MSGLEN, ERTYPE, ERCODE, & PRINTB, STOPTB, PLEN, IFERR6, IFERR7, IALLOC, HDRFMT, & TRACON SAVE /ERCOM1/
C SPECIFICATIONS FOR COMMON /ERCOM2/
CHARACTER MSGSAV(255), PLIST(300), RNAME(51)*6 COMMON /ERCOM2/ MSGSAV, PLIST, RNAME SAVE /ERCOM2/
C SPECIFICATIONS FOR COMMON /ERCOM3/
DOUBLE PRECISION ERCKSM COMMON /ERCOM3/ ERCKSM SAVE /ERCOM3/
C SPECIFICATIONS FOR COMMON /ERCOM4/
LOGICAL ISUSER(51) COMMON /ERCOM4/ ISUSER SAVE /ERCOM4/
C SPECIFICATIONS FOR INTRINSICS C INTRINSIC IABS
INTRINSIC IABS INTEGER IABS
C SPECIFICATIONS FOR SUBROUTINES
EXTERNAL C1TIC, M1VE
C
DATA TEMP/'*', ' ', ' ', '*'/, PRCNT/'%'/, BLANK/' '/
C
NNUM = IABS(NUM) LENCK = PLEN + SLEN + 8 IF (NNUM.GE.1 .AND. NNUM.LE.9 .AND. LENCK.LE.300) THEN TEMP(2) = FORM CALL C1TIC (NNUM, TEMP(3), 1, IER) LOC = PLEN + 1 IF (LOC .EQ. 2) LOC = 1 CALL M1VE (TEMP, 1, 4, 4, PLIST(LOC), 1, 4, 262, IER) LOC = LOC + 4 IF (NUM .LT. 0) THEN LEN2 = SLEN ELSE DO 10 L=1, SLEN LEN2 = SLEN - L + 1 IF (STRUP(LEN2) .NE. BLANK) GO TO 20 10 CONTINUE LEN2 = 1 20 CONTINUE END IF NLEN = 1 IF (LEN2 .GE. 10) NLEN = 2 IF (LEN2 .GE. 100) NLEN = 3 CALL C1TIC (LEN2, STRNCH, NLEN, IER) CALL M1VE (STRNCH, 1, NLEN, 3, PLIST(LOC), 1, NLEN, 262, IER) LOC = LOC + NLEN CALL M1VE (PRCNT, 1, 1, 1, PLIST(LOC), 1, 1, 262, IER) LOC = LOC + 1 CALL M1VE (STRUP, 1, LEN2, LEN2, PLIST(LOC), 1, LEN2, 262, & IER) PLEN = LOC + LEN2 - 1 END IF
C
RETURN END
C———————————————————————– C IMSL Name: UMACH (Single precision version) C C Computer: PCDSMS/SINGLE C C Revised: March 21, 1984 C C Purpose: Set or retrieve input or output device unit numbers. C C Usage: CALL UMACH (N, NUNIT) C C Arguments: C N - Index of desired unit. (Input) C The values of N are defined as follows: C N = 1, corresponds to the standard input unit. C N = 2, corresponds to the standard output unit. C NUNIT - I/O unit. (Input or Output) C If the value of N is negative, the unit corresponding C to the index is reset to the value given in NUNIT. C Otherwise, the value corresponding to the index is C returned in NUNIT. C C GAMS: R1 C C Chapters: MATH/LIBRARY Reference Material C STAT/LIBRARY Reference Material C SFUN/LIBRARY Reference Material C C Copyright: 1984 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
SUBROUTINE UMACH (N, NUNIT)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER N, NUNIT
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER NN, NOUT
C SPECIFICATIONS FOR SAVE VARIABLES
INTEGER UNIT(2) SAVE UNIT
C SPECIFICATIONS FOR INTRINSICS C INTRINSIC IABS
INTRINSIC IABS INTEGER IABS
C
DATA UNIT(1)/5/ DATA UNIT(2)/6/
C
NN = IABS(N) IF (NN.NE.1 .AND. NN.NE.2) THEN
C ERROR. INVALID RANGE FOR N.
NOUT = UNIT(2) WRITE (NOUT,99999) NN
99999 FORMAT (/, ‘ *** TERMINAL ERROR 5 from UMACH. The absolute’,
& /, ' *** value of the index variable must be' & , /, ' *** 1 or 2. IABS(N) = ', I6, & '.', /) STOP
C CHECK FOR RESET OR RETRIEVAL
ELSE IF (N .LT. 0) THEN
C RESET
UNIT(NN) = NUNIT ELSE
C RETRIEVE
NUNIT = UNIT(N) END IF
C
RETURN END
C———————————————————————– C IMSL Name: IACHAR (Single precision version) C C Computer: PCDSMS/SINGLE C C Revised: September 9, 1985 C C Purpose: Return the integer ASCII value of a character argument. C C Usage: IACHAR(CH) C C Arguments: C CH - Character argument for which the integer ASCII value C is desired. (Input) C IACHAR - Integer ASCII value for CH. (Output) C The character CH is in the IACHAR-th position of the C ASCII collating sequence. C C GAMS: N3 C C Chapter: MATH/LIBRARY Utilities C STAT/LIBRARY Utilities C C Copyright: 1986 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
INTEGER FUNCTION IACHAR (CH)
C SPECIFICATIONS FOR ARGUMENTS
CHARACTER CH
C SPECIFICATIONS FOR SAVE VARIABLES
IACHAR = ICHAR(CH) RETURN END
C———————————————————————– C IMSL Name: I1CSTR (Single precision version) C C Computer: DGC/SINGLE C C Revised: September 10, 1985 C C Purpose: Case insensitive comparison of two character arrays. C C Usage: I1CSTR(STR1, LEN1, STR2, LEN2) C C Arguments: C STR1 - First character array. (Input) C LEN1 - Length of STR1. (Input) C STR2 - Second character array. (Input) C LEN2 - Length of STR2. (Input) C I1CSTR - Integer function. (Output) Where C I1CSTR = -1 if STR1 .LT. STR2, C I1CSTR = 0 if STR1 .EQ. STR2, C I1CSTR = 1 if STR1 .GT. STR2. C C Remarks: C 1. If the two arrays, STR1 and STR2, are of unequal length, the C shorter array is considered as if it were extended with blanks C to the length of the longer array. C C 2. If one or both lengths are zero or negative the I1CSTR output is C based on comparison of the lengths. C C GAMS: N5c C C Chapter: MATH/LIBRARY Utilities C C Copyright: 1985 by IMSL, Inc. All Rights Reserved. C C Warranty: IMSL warrants only that IMSL testing has been applied C to this code. No other warranty, expressed or implied, C is applicable. C C———————————————————————– C
INTEGER FUNCTION I1CSTR (STR1, LEN1, STR2, LEN2)
C SPECIFICATIONS FOR ARGUMENTS
INTEGER LEN1, LEN2 CHARACTER STR1(LEN1), STR2(LEN2)
C SPECIFICATIONS FOR LOCAL VARIABLES
INTEGER IC1, IC2, ICB, IS, L, LENM
C SPECIFICATIONS FOR INTRINSICS C INTRINSIC ISIGN,MIN0
INTRINSIC ISIGN, MIN0 INTEGER ISIGN, MIN0
C SPECIFICATIONS FOR FUNCTIONS
EXTERNAL ICASE INTEGER ICASE
C
IF (LEN1.GT.0 .AND. LEN2.GT.0) THEN
C COMPARE FIRST LENM CHARACTERS
LENM = MIN0(LEN1,LEN2) DO 10 L=1, LENM IC1 = ICASE(STR1(L)) IC2 = ICASE(STR2(L)) IF (IC1 .NE. IC2) THEN I1CSTR = ISIGN(1,IC1-IC2) RETURN END IF 10 CONTINUE END IF
C COMPARISON BASED ON LENGTH OR C TRAILING BLANKS
IS = LEN1 - LEN2 IF (IS .EQ. 0) THEN I1CSTR = 0 ELSE IF (LEN1.LE.0 .OR. LEN2.LE.0) THEN
C COMPARISON BASED ON LENGTH
I1CSTR = ISIGN(1,IS) ELSE
C COMPARISON BASED ON TRAILING BLANKS C TO EXTEND SHORTER ARRAY
LENM = LENM + 1 ICB = ICASE(' ') IF (IS .GT. 0) THEN
C EXTEND STR2 WITH BLANKS
DO 20 L=LENM, LEN1 IC1 = ICASE(STR1(L)) IF (IC1 .NE. ICB) THEN I1CSTR = ISIGN(1,IC1-ICB) RETURN END IF 20 CONTINUE ELSE
C EXTEND STR1 WITH BLANKS
DO 30 L=LENM, LEN2 IC2 = ICASE(STR2(L)) IF (ICB .NE. IC2) THEN I1CSTR = ISIGN(1,ICB-IC2) RETURN END IF 30 CONTINUE END IF
C
I1CSTR = 0 END IF END IF
C
RETURN END