C The following three statements are MS-FORTRAN Meta Commands and should C be removed, when using another compiler: C 'NOFLOATCALLS' should also be removed when using the (ALT)MATH.LIB C ********************************************************** C * B E G I N P R O G R A M E X E C U T I O N * C ********************************************************** C C Set the following parameters in the second line C RO, CO, G is maximum number of Rows, Columns and Groups C INTEGER RO,CO,G character*80 in1,in2,out PARAMETER (RO=12,CO=12,G=10) REAL F(RO,CO,G),FF(RO,CO,G),FI(RO,CO,G),TIK(RO,G), 1 TJK(CO,G),TJKCON(G),FS(RO,CO,G),DIK(RO,CO,G),DIK1(RO,CO,G), 2 RLM(RO,G),CLM(CO,G),RLMI(RO,G),MU(RO,G), 3 NU(CO,G),RHO(RO),SIG(CO),DLM1(RO,G),DLMI1(RO,G), 4 P(G),A(RO,G),B(CO,G),X,XX,CLMI(CO,G),DLM(RO,G),DLMI(RO,G) CHARACTER DATFID*20,TITLE*60,FMT*20 LOGICAL PC DIMENSION MODEL(40),MOD(40) call getarg(1,in1) call getarg(2,in2) call getarg(3,out) open(9,file=in1) open(10,file=in2) open(12,file=out) C C PC=.TRUE. PC-version with specific I/O handling C PC=.FALSE. Mainframe version C PC=.FALSE. IF(PC) Call PCInit 10 FORMAT(A) 20 FORMAT(2I2,I3,F8.7,I4,F4.3) 30 FORMAT(40I2) C Read Input file READ(9,10)TITLE READ(9,30)J1,J2,J3,J4,J5,J6,INC,J7,J8,J9 READ(9,20)NR,NC,NL,TOL,IT,CONST C C Default Values C IF(TOL.eq.0.0) TOL=.01 IF(IT.eq.0) IT=100 C C Intro C WRITE(12,21)TITLE,NL,NR,NC,TOL,IT 21 FORMAT( *' ',55('*'),/, *' A s s o c (PC) - Version 1.10b - 10 December 1988', //, *' Based on ANOASC by Clifford Clogg and James Shockey.',/, *' Several enhancements added by Ruud Luijkx',/, *' ',55('*'),//, *' Run: ', A60,/, *' A s s o c (PC) analyzes the Conditional Association in ',/, *' ',I3,' Groups with ',I3,' Rows and ',I3,' Columns',/, *' Tolerance to end Iteration=',F8.7,' Maximum Iterations=',I4,/) READ(9,10) FMT READ(9,10) DATFID open(10,FILE=DATFID,status='OLD') If(fmt.eq.'FREE'.or.fmt.eq.'free'.or.fmt.eq.'Free') Then READ(10,*)(((F(I,J,K),J=1,NC),I=1,NR),K=1,NL) Else READ(10,FMT)(((F(I,J,K),J=1,NC),I=1,NR),K=1,NL) EndIf DO 860 I=1,NR DO 860 J=1,NC DO 860 K=1,NL FS(I,J,K)=1.0 If(CONST.NE.0.0) F(I,J,K)=F(I,J,K)+CONST 860 CONTINUE IF(INC.EQ.0) GO TO 802 If(fmt.eq.'FREE'.or.fmt.eq.'free'.or.fmt.eq.'Free') Then READ(9,*) (((FS(I,J,K),J=1,NC),I=1,NR),K=1,NL) Else READ(9,FMT) (((FS(I,J,K),J=1,NC),I=1,NR),K=1,NL) Endif 802 CONTINUE C READ(9,30) MODEL C C Diagnosis C WRITE(12,1) DATFID 1 FORMAT(' ',67('!'),/,' Diagnosis: ',/, *' - Data were read from file ', A20) IF(CONST.NE.0.0) Write(12,2) CONST 2 FORMAT( *' - A Constant of ',F4.3,' was added to all frequencies') IF(INC.eq.1) Write(12,3) 3 FORMAT( *' - Structural zeroes: be careful with degrees of freedom') IF(NR.LE.3.AND.NC.LE.3) Write(12,4) 4 FORMAT( *' - #Rows and #Columns less than 3: be careful with',/ *' degrees of freedom') IF(NR.LE.4.AND.NC.LE.4.AND.J7.NE.0) Write(12,5) 5 FORMAT( *' - #Rows and #Columns less than 4 and diagonalparameters',/, *' are specified: be careful with degrees of freedom') IF(NR.NE.NC.AND.J7.EQ.0)THEN WRITE(12,4990) 4990 FORMAT( *' - Table is not square - equal row and column models',/, 1' will not be calculated') ELSEIF(NR.NE.NC.AND.J7.NE.0) THEN WRITE(12,4991) 4991 FORMAT( *' - quasi-models cannot be calculated for not square table') Write(12,7) STOP ENDIF Write(12,7) 7 FORMAT(' ',67('!'),//) C C Main Loop C DO 499 IN=1,15 DO 410 LL=1,15 MOD(LL)=0 410 CONTINUE IH1=0 IH2=0 IE=0 IF (MODEL(IN).EQ.0) GOTO 499 IF (MODEL(IN).NE.0) MOD(IN)=1 WRITE(12,561) 561 FORMAT(' ',47('*')) IF(MOD( 4).EQ.1) IH1=1 IF(MOD( 5).EQ.1) IH2=1 IF(MOD( 6).EQ.1) IH1=1 IF(MOD( 7).EQ.1) IH2=1 IF(MOD(10).EQ.1) IH1=1 IF(MOD(10).EQ.1) IH2=1 IF(MOD(11).EQ.1) IH2=1 IF(MOD(12).EQ.1) IH1=1 IF(MOD(14).EQ.1) IH1=1 IF(MOD(14).EQ.1) IH2=1 IF(MOD(14).EQ.1) IE=1 IF(MOD(15).EQ.1) IE=1 IF(MOD( 1).EQ.1) WRITE(12,9000) IF(MOD( 2).EQ.1) WRITE(12,9001) IF(MOD( 3).EQ.1) WRITE(12,9002) IF(MOD( 4).EQ.1) WRITE(12,9003) IF(MOD( 5).EQ.1) WRITE(12,9004) IF(MOD( 6).EQ.1) WRITE(12,9005) IF(MOD( 7).EQ.1) WRITE(12,9006) IF(MOD( 8).EQ.1) WRITE(12,9007) IF(MOD( 9).EQ.1) WRITE(12,9008) IF(MOD(10).EQ.1) WRITE(12,9009) IF(MOD(11).EQ.1) WRITE(12,9010) IF(MOD(12).EQ.1) WRITE(12,9011) IF(MOD(13).EQ.1) WRITE(12,9012) IF(MOD(14).EQ.1) WRITE(12,9013) IF(MOD(15).EQ.1) WRITE(12,9014) 9000 FORMAT(' Null Conditional Association ',/, * ' (Conditional Independence)') 9001 FORMAT(' Homogeneous Conditional Uniform Association') 9002 FORMAT(' Heterogeneous Conditional Uniform Association') 9003 FORMAT(' Homogeneous Conditional Row-Effects') 9004 FORMAT(' Homogeneous Conditional Column Effects') 9005 FORMAT(' Simple Heterogeneous Row Effects') 9006 FORMAT(' Simple Heterogeneous Column Effects') 9007 FORMAT(' Heterogeneous Row Effects') 9008 FORMAT(' Heterogeneous Column Effects') 9009 FORMAT(' Homogeneous Row-Column Effects') 9010 FORMAT(' Heterogeneous Row, Homogeneous Column Effects') 9011 FORMAT(' Heterogeneous Column, Homogeneous Row Effects') 9012 FORMAT(' Heterogeneous Row and Column Effects') 9013 FORMAT(' Homogeneous Equal Row and Column Effects') 9014 FORMAT(' Heterogeneous Equal Row and Column Effects') IF((MOD(10).EQ.1.OR.MOD(11).EQ.1.OR.MOD(12).EQ.1.OR.MOD(13).EQ.1. *OR.MOD(14).EQ.1.OR.MOD(15).EQ.1).AND.(J5.EQ.1))WRITE(12,9015) 9015 FORMAT(' Log-Multiplicative Model (II)') IF((MOD(10).EQ.1.OR.MOD(11).EQ.1.OR.MOD(12).EQ.1.OR.MOD(13).EQ.1. *OR.MOD(14).EQ.1.OR.MOD(15).EQ.1).AND.(J5.NE.1))WRITE(12,9016) 9016 FORMAT(' Log-Linear Model (I)') IF(J7.EQ.1) WRITE(12,9021) IF(J7.EQ.2) WRITE(12,9022) IF(J7.EQ.3) WRITE(12,9023) IF(J7.EQ.4) WRITE(12,9024) IF(J7.EQ.5) WRITE(12,9025) 9021 FORMAT(' Free Diagonal') 9022 FORMAT(' Groups Specific Diagonal') 9023 FORMAT(' Category Specific Diagonal ') 9024 FORMAT(' Group and Category Specific Diagonal') 9025 FORMAT(' One Diagonal Parameter') WRITE(12,561) DO 31 I=1,NR RHO(I)=REAL(I) - REAL(NR+1)/2. 31 CONTINUE DO 32 J=1,NC SIG(J)=REAL(J) - REAL(NC+1)/2. 32 CONTINUE DO 40 I=1,NR DO 40 K=1,NL TIK(I,K)=1.0 A(I,K)=1.0 MU(I,K)=REAL(I) 40 CONTINUE DO 39 J=1,NC DO 39 K=1,NL TJK(J,K)=1.0 B(J,K)=1.0 NU(J,K)=REAL(J) DO 39 I=1,NR FF(I,J,K)=1.0 FI(I,J,K)=1.0 DIK(I,J,K)=1.0 DIK1(I,J,K)=1.0 P(K)=0.0 39 CONTINUE CALL DLMARG(RO,CO,G,F,DLM,DLM1,NR,NC,NL,FS,J7) CALL RLMARG(RO,CO,G,F,RLM,NR,NC,NL,FS) CALL CLMARG(RO,CO,G,F,CLM,NR,NC,NL,FS) T=1.0 R=REAL(NR) C=REAL(NC) L=REAL(NL) C C BEGIN MAIN LOOP C DO 500 M=1,IT C C Null Conditional Association (Conditional Independence C IF(IN.GE.10)GO TO 120 IF((IN.GE.3).AND.(IN.LE.9))GO TO 50 IF(J7.GE.1.AND.J7.LE.5)THEN CALL DLMARG(RO,CO,G,FI,DLMI,DLMI1,NR,NC,NL,FS,J7) CALL XDIK(RO,CO,G,DIK,DIK1,DLM,DLM1,DLMI,DLMI1,NR,NC,NL,J7) CALL FCIND(RO,CO,G,FI,TIK,TJK,DIK,DIK1,T,NR,NC,NL,FS) ENDIF CALL RLMARG(RO,CO,G,FI,RLMI,NR,NC,NL,FS) CALL XTIK(RO,CO,G,TIK,RLM,RLMI,NR,NC,NL) CALL FCIND(RO,CO,G,FI,TIK,TJK,DIK,DIK1,T,NR,NC,NL,FS) CALL CLMARG(RO,CO,G,FI,CLMI,NR,NC,NL,FS) CALL XTJK(RO,CO,G,TJK,CLM,CLMI,NR,NC,NL,TJKCON) CALL FCIND(RO,CO,G,FI,TIK,TJK,DIK,DIK1,T,NR,NC,NL,FS) IF(MOD(1).NE.1)GO TO 45 GOTO 400 C C Statement 400 BEGINS CHECK FOR CONVERGENCE C 45 CONTINUE IF(MOD(2).NE.1)GO TO 50 C C Homogeneous Conditional Uniform Association IF MOD(2)=1 C !! Still zero-divide problems!! C X=0.0 XX=0.0 DO 48 K=1,NL DO 48 I=1,NR DO 48 J=1,NC IF(FS(I,J,K).EQ.0.0)GO TO 48 Y=RHO(I)*SIG(J) YY=Y*Y X=X+(F(I,J,K) - FI(I,J,K))*Y XX=XX + YY*FI(I,J,K) 48 CONTINUE T=T*(1.+X/XX) IF(J7.GE.1.AND.J7.LE.5)THEN CALL DLMARG(RO,CO,G,FI,DLMI,DLMI1,NR,NC,NL,FS,J7) CALL XDIK(RO,CO,G,DIK,DIK1,DLM,DLM1,DLMI,DLMI1,NR,NC,NL,J7) CALL FCIND(RO,CO,G,FI,TIK,TJK,DIK,DIK1,T,NR,NC,NL,FS) ENDIF CALL RLMARG(RO,CO,G,FI,RLMI,NR,NC,NL,FS) CALL XTIK(RO,CO,G,TIK,RLM,RLMI,NR,NC,NL) CALL FCIND(RO,CO,G,FI,TIK,TJK,DIK,DIK1,T,NR,NC,NL,FS) CALL CLMARG(RO,CO,G,FI,CLMI,NR,NC,NL,FS) CALL XTJK(RO,CO,G,TJK,CLM,CLMI,NR,NC,NL,TJKCON) CALL FCIND(RO,CO,G,FI,TIK,TJK,DIK,DIK1,T,NR,NC,NL,FS) GOTO 400 50 CONTINUE C C Heterogeneous Conditional Uniform Association IF MOD(3)=1 C IF(MOD(3).NE.1)GO TO 60 CALL RLMARG(RO,CO,G,FI,RLMI,NR,NC,NL,FS) CALL XTIK(RO,CO,G,TIK,RLM,RLMI,NR,NC,NL) CALL FHECU(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,NR,NC,NL,FS) CALL CLMARG(RO,CO,G,FI,CLMI,NR,NC,NL,FS) CALL XTJK(RO,CO,G,TJK,CLM,CLMI,NR,NC,NL,TJKCON) CALL FHECU(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,NR,NC,NL,FS) IF(J7.GE.1.AND.J7.LE.5)THEN CALL DLMARG(RO,CO,G,FI,DLMI,DLMI1,NR,NC,NL,FS,J7) CALL XDIK(RO,CO,G,DIK,DIK1,DLM,DLM1,DLMI,DLMI1,NR,NC,NL,J7) CALL FHECU(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,NR,NC,NL,FS) ENDIF DO 53 K=1,NL A(2,K)=0.0 A(3,K)=0.0 53 CONTINUE DO 55 K=1,NL DO 54 J=1,NC DO 54 I=1,NR IF(FS(I,J,K).EQ.0.0)GO TO 54 Y=RHO(I)*SIG(J) YY=Y*Y A(2,K)=A(2,K) + (F(I,J,K)-FI(I,J,K))*Y A(3,K)=A(3,K) + YY*FI(I,J,K) 54 CONTINUE A(1,K)=A(1,K)*(1. + A(2,K)/A(3,K)) 55 CONTINUE CALL FHECU(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,NR,NC,NL,FS) GOTO 400 60 CONTINUE C C Homogeneous Conditional Row Effects MOD(4)=1 C CALL RLMARG(RO,CO,G,FI,RLMI,NR,NC,NL,FS) CALL XTIK(RO,CO,G,TIK,RLM,RLMI,NR,NC,NL) CALL FROCOL(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS) CALL CLMARG(RO,CO,G,FI,CLMI,NR,NC,NL,FS) CALL XTJK(RO,CO,G,TJK,CLM,CLMI,NR,NC,NL,TJKCON) CALL FROCOL(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS) IF(J7.GE.1.AND.J7.LE.5)THEN CALL DLMARG(RO,CO,G,FI,DLMI,DLMI1,NR,NC,NL,FS,J7) CALL XDIK(RO,CO,G,DIK,DIK1,DLM,DLM1,DLMI,DLMI1,NR,NC,NL,J7) CALL FROCOL(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS) ENDIF IF(MOD(4).NE.1)GO TO 70 DO 63 I=1,NR A(I,2)=0.0 A(I,3)=0.0 63 CONTINUE DO 64 I=1,NR DO 65 J=1,NC Y=SIG(J) YY=Y*Y DO 65 K=1,NL IF(FS(I,J,K).EQ.0.0)GO TO 65 A(I,2)=A(I,2) + (F(I,J,K) - FI(I,J,K))*Y A(I,3)=A(I,3) + YY*FI(I,J,K) 65 CONTINUE A(I,1)=A(I,1)*(1. + A(I,2)/A(I,3)) DO 64 K=2,NL A(I,K)=A(I,1) 64 CONTINUE CALL FROCOL(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS) IF(J7.GE.1.AND.J7.LE.5)THEN CALL DLMARG(RO,CO,G,FI,DLMI,DLMI1,NR,NC,NL,FS,J7) CALL XDIK(RO,CO,G,DIK,DIK1,DLM,DLM1,DLMI,DLMI1,NR,NC,NL,J7) CALL FROCOL(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS) ENDIF GOTO 400 70 CONTINUE C C Homogeneous Conditional Column Effects if MOD(5)=1 C IF(MOD(5).NE.1)GO TO 80 DO 71 J=1,NC B(J,2)=0.0 B(J,3)=0.0 71 CONTINUE DO 72 J=1,NC DO 73 I=1,NR Y=RHO(I) YY=Y*Y DO 73 K=1,NL IF(FS(I,J,K).EQ.0.0)GO TO 73 B(J,2)=B(J,2)+(F(I,J,K)-FI(I,J,K))*Y B(J,3)=B(J,3)+ YY*FI(I,J,K) 73 CONTINUE B(J,1)=B(J,1)*(1. + B(J,2)/B(J,3)) DO 72 K=2,NL B(J,K)=B(J,1) 72 CONTINUE CALL FROCOL(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS) GOTO 400 80 CONTINUE C C Simple Heterogenous Row Effects IF MOD(6)=1 C IF(MOD(6).NE.1) GOTO 90 DO 81 I=1,NR A(I,2)=0.0 A(I,3)=0.0 81 CONTINUE DO 83 I=1,NR DO 82 J=1,NC Y=SIG(J) YY=Y*Y DO 82 K=1,NL IF(FS(I,J,K).EQ.0.0)GO TO 82 A(I,2)=A(I,2) + (F(I,J,K)-FI(I,J,K))*Y A(I,3)=A(I,3) + YY*FI(I,J,K) 82 CONTINUE A(I,1)=A(I,1)*(1. + A(I,2)/A(I,3)) DO 83 K=2,NL A(I,K)=A(I,1) 83 CONTINUE CALL FROCOL(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS) DO 84 K=1,NL NU(2,K)=0.0 NU(3,K)=0.0 84 CONTINUE DO 85 K=1,NL DO 86 J=1,NC DO 86 I=1,NR IF(FS(I,J,K).EQ.0.0)GO TO 86 Y=RHO(I)*SIG(J) YY=Y*Y NU(2,K)=NU(2,K) + (F(I,J,K)-FI(I,J,K))*Y NU(3,K)=NU(3,K) + YY*FI(I,J,K) 86 CONTINUE NU(1,K)=NU(1,K)*(1. + NU(2,K)/NU(3,K)) DO 85 J=1,NC B(J,K)=NU(1,K)**SIG(J) 85 CONTINUE CALL FROCOL(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS) GOTO 400 90 CONTINUE C C Simple Heterogeneous Column Effects IF MOD(7)=1 C IF(MOD(7).NE.1) GOTO 100 DO 91 J=1,NC B(J,2)=0.0 B(J,3)=0.0 91 CONTINUE DO 92 J=1,NC DO 93 I=1,NR Y=RHO(I) YY=Y*Y DO 93 K=1,NL IF(FS(I,J,K).EQ.0.0) GOTO 93 B(J,2)=B(J,2) + (F(I,J,K)-FI(I,J,K))*Y B(J,3)=B(J,3) + YY*FI(I,J,K) 93 CONTINUE B(J,1)=B(J,1)*(1. + B(J,2)/B(J,3)) DO 92 K=2,NL B(J,K)=B(J,1) 92 CONTINUE CALL FROCOL(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS) DO 94 K=1,NL NU(2,K)=0.0 NU(3,K)=0.0 94 CONTINUE DO 95 K=1,NL DO 96 J=1,NC DO 96 I=1,NR IF(FS(I,J,K).EQ.0.0)GO TO 96 Y=RHO(I)*SIG(J) YY=Y*Y NU(2,K)=NU(2,K) + (F(I,J,K) - FI(I,J,K))*Y NU(3,K)=NU(3,K) + YY*FI(I,J,K) 96 CONTINUE NU(1,K)=NU(1,K)*(1. + NU(2,K)/NU(3,K)) DO 95 I=1,NR A(I,K)=NU(1,K)**RHO(I) 95 CONTINUE CALL FROCOL(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS) GOTO 400 100 CONTINUE C C Heterogeneous Row Effects IF MOD(8)=1 C IF(MOD(8).NE.1)GO TO 110 DO 101 I=1,NR DO 101 K=1,NL MU(I,K)=0.0 NU(I,K)=0.0 101 CONTINUE DO 102 I=1,NR DO 102 K=1,NL DO 103 J=1,NC IF(FS(I,J,K).EQ.0.0) GOTO 103 Y=SIG(J) YY=Y*Y MU(I,K)=MU(I,K) + (F(I,J,K)-FI(I,J,K))*Y NU(I,K)=NU(I,K) + YY*FI(I,J,K) 103 CONTINUE A(I,K)=A(I,K)*(1. + MU(I,K)/NU(I,K)) 102 CONTINUE CALL FROCOL(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS) GOTO 400 110 CONTINUE IF(MOD(9).NE.1) GOTO 120 C C Heterogeneous Column Effects MOD(9)=1 C DO 111 J=1,NC DO 111 K=1,NL MU(J,K)=0.0 NU(J,K)=0.0 111 CONTINUE DO 112 J=1,NC DO 112 K=1,NL DO 113 I=1,NR IF(FS(I,J,K).EQ.0.0)GO TO 113 Y=RHO(I) YY=Y*Y MU(J,K)=MU(J,K) + (F(I,J,K)-FI(I,J,K))*Y NU(J,K)=NU(J,K) + YY*FI(I,J,K) 113 CONTINUE B(J,K)=B(J,K)*(1. + MU(J,K)/NU(J,K)) 112 CONTINUE CALL FROCOL(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS) GOTO 400 C C----------MODEL I CALCULATIONS (MODEL.II GO TO 140)----------- C 120 CONTINUE IF(J5.EQ.1)GO TO 140 CALL RLMARG(RO,CO,G,FI,RLMI,NR,NC,NL,FS) CALL XTIK(RO,CO,G,TIK,RLM,RLMI,NR,NC,NL) CALL FROCOL(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS) IF(MOD(14).EQ.1.OR.MOD(15).EQ.1) GOTO 1200 DO 121 J=1,NC DO 121 K=1,NL MU(J,K)=0.0 NU(J,K)=0.0 121 CONTINUE DO 122 J=1,NC X=0.0 XX=0.0 DO 123 K=1,NL DO 123 I=1,NR IF(FS(I,J,K).EQ.0.0)GO TO 123 Y=RHO(I) YY=Y*Y MU(J,K)=MU(J,K) + (F(I,J,K) - FI(I,J,K))*Y NU(J,K)=NU(J,K) + YY*FI(I,J,K) 123 CONTINUE IF(MOD(10).NE.1.AND.MOD(11).NE.1)GO TO 126 DO 127 K=1,NL X=X + MU(J,K) XX=XX + NU(J,K) 127 CONTINUE DO 128 K=1,NL IF((X/XX).LE.-1.0) GO TO 128 B(J,K)=B(J,K)*(1. + X/XX) 128 CONTINUE GOTO 122 126 CONTINUE DO 129 K=1,NL IF((MU(J,K)/NU(J,K)).LE.-1.0) GO TO 129 B(J,K)=B(J,K)*(1. + MU(J,K)/NU(J,K)) 129 CONTINUE 122 CONTINUE CALL FROCOL(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS) 1200 CONTINUE CALL CLMARG(RO,CO,G,FI,CLMI,NR,NC,NL,FS) CALL XTJK(RO,CO,G,TJK,CLM,CLMI,NR,NC,NL,TJKCON) CALL FROCOL(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS) DO 131 I=1,NR DO 131 K=1,NL MU(I,K)=0.0 NU(I,K)=0.0 131 CONTINUE DO 132 I=1,NR X=0.0 XX=0.0 DO 133 K=1,NL DO 133 J=1,NC IF(FS(I,J,K).EQ.0.0) GOTO 133 Y=SIG(J) YY=Y*Y IF(MOD(14).EQ.1.OR.MOD(15).EQ.1) THEN MU(I,K)=MU(I,K) + (F(I,J,K)+F(J,I,K) - FI(J,I,K) 1 - FI(I,J,K))*Y NU(I,K)=NU(I,K) + YY*(FI(I,J,K)+FI(J,I,K)) ELSE MU(I,K)=MU(I,K) + (F(I,J,K) - FI(I,J,K))*Y NU(I,K)=NU(I,K) + YY*(FI(I,J,K)) ENDIF 133 CONTINUE IF(MOD(14).NE.1.AND.MOD(10).NE.1.AND.MOD(12).NE.1)GO TO 136 DO 137 K=1,NL X=X+MU(I,K) XX=XX + NU(I,K) 137 CONTINUE DO 138 K=1,NL IF((X/XX).LE.-1.0) THEN IF(MOD(14).EQ.1.OR.MOD(15).EQ.1)B(I,K)=A(I,K) GOTO 138 ELSE A(I,K)=A(I,K)*(1. + X/XX) IF(MOD(14).EQ.1.OR.MOD(15).EQ.1)B(I,K)=A(I,K) ENDIF 138 CONTINUE GOTO 132 136 CONTINUE DO 139 K=1,NL IF((MU(I,K)/NU(I,K)).LE.-1.0) THEN IF(MOD(14).EQ.1.OR.MOD(15).EQ.1)B(I,K)=A(I,K) GOTO 139 ELSE A(I,K)=A(I,K)*(1. + MU(I,K)/NU(I,K)) IF(MOD(14).EQ.1.OR.MOD(15).EQ.1)B(I,K)=A(I,K) ENDIF 139 CONTINUE 132 CONTINUE CALL FROCOL(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS) IF(J7.GE.1.AND.J7.LE.5)THEN CALL DLMARG(RO,CO,G,FI,DLMI,DLMI1,NR,NC,NL,FS,J7) CALL XDIK(RO,CO,G,DIK,DIK1,DLM,DLM1,DLMI,DLMI1,NR,NC,NL,J7) CALL FROCOL(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS) ENDIF GOTO 400 140 CONTINUE C C ------ MODEL II CALCULATIONS BEGIN HERE --------- C IF(M.GT.1)GO TO 2997 DO 2995 K=1,NL DO 2998 I=1,NR A(I,K)=RHO(I) 2998 CONTINUE DO 2995 J=1,NC B(J,K)=SIG(J) 2995 CONTINUE 2997 CONTINUE C C ------ THE ABOVE SETS THE A AND B VECTORS FOR THE FIRST LOOP C ------ NOW THE A AND B SCORES ARE RESCALED C ------ RESCALE B C DO 5559 K=1,NL CLMI(1,K)=0.0 CLMI(2,K)=0.0 DO 5558 J=1,NC CLMI(2,K)=CLMI(2,K) + B(J,K)**2 CLMI(1,K)=CLMI(1,K) + B(J,K) 5558 CONTINUE CLMI(1,K)=CLMI(1,K)/C CLMI(2,K)=SQRT(CLMI(2,K) - C * (CLMI(1,K) * CLMI(1,K))) DO 5559 J=1,NC B(J,K)=(B(J,K) - CLMI(1,K))/CLMI(2,K) IF(ABS(B(J,K)).LE..0001)B(J,K)=0.0 5559 CONTINUE C C ----- RESCALE THE A C DO 5556 K=1,NL CLMI(1,K)=0.0 CLMI(2,K)=0.0 DO 5557 I=1,NR CLMI(2,K)=CLMI(2,K) + A(I,K)**2 CLMI(1,K)=CLMI(1,K) + A(I,K) 5557 CONTINUE CLMI(1,K)=CLMI(1,K)/R CLMI(2,K)=SQRT(CLMI(2,K) - R * (CLMI(1,K) * CLMI(1,K))) DO 5556 I=1,NR A(I,K)=(A(I,K) - CLMI(1,K))/CLMI(2,K) IF(ABS(A(I,K)).LE..0001)A(I,K)=0.0 5556 CONTINUE 1401 CONTINUE CALL RLMARG(RO,CO,G,FI,RLMI,NR,NC,NL,FS) CALL XTIK(RO,CO,G,TIK,RLM,RLMI,NR,NC,NL) CALL FROCO2 (RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS,P) C C ----- USE ITER MARGINALS FOR DUMMY STORAGE C ----- COMPUTE THE SCALING PARAMETER P(K)--PHI C DO 8222 J=1,NC DO 8222 K=1,NL CLMI(J,K)=0.0 8222 CONTINUE DO 8224 K=1,NL DO 8223 I=1,NR DO 8223 J=1,NC IF(FS(I,J,K).EQ.0.0) GOTO 8223 CLMI(1,K)=CLMI(1,K) + A(I,K)*B(J,K)*(F(I,J,K)-FI(I,J,K)) CLMI(2,K)=CLMI(2,K) + ((A(I,K)*B(J,K))**2)*FI(I,J,K) 8223 CONTINUE P(K)=P(K) + CLMI(1,K)/CLMI(2,K) 8224 CONTINUE CALL FROCO2(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS,P) IF(MOD(14).EQ.1.OR.MOD(15).EQ.1) GOTO 8225 DO 141 J=1,NC DO 141 K=1,NL CLMI(J,K)=0.0 RLMI(J,K)=0.0 141 CONTINUE DO 142 J=1,NC X=0.0 XX=0.0 DO 143 K=1,NL DO 143 I=1,NR IF(FS(I,J,K).EQ.0.0)GO TO 143 Y=A(I,K) YY=Y*Y CLMI(J,K)=CLMI(J,K) + (F(I,J,K) - FI(I,J,K))*Y RLMI(J,K)=RLMI(J,K) + YY*FI(I,J,K) 143 CONTINUE IF(MOD(10).NE.1.AND.MOD(11).NE.1) GOTO 146 DO 147 K=1,NL X=X + CLMI(J,K) XX=XX + RLMI(J,K) 147 CONTINUE DO 148 K=1,NL NU(J,K)=NU(J,K) + X/XX 148 CONTINUE GOTO 142 146 CONTINUE DO 149 K=1,NL NU(J,K)=NU(J,K) + CLMI(J,K)/RLMI(J,K) 149 CONTINUE 142 CONTINUE C C ----- RESCALE NU AND PUT IN B C DO 1491 K=1,NL CLMI(1,K)=0.0 CLMI(2,K)=0.0 DO 1490 J=1,NC CLMI(2,K)=CLMI(2,K) + NU(J,K)**2 CLMI(1,K)=CLMI(1,K) + NU(J,K) 1490 CONTINUE CLMI(1,K)=CLMI(1,K)/C CLMI(2,K)=SQRT(CLMI(2,K) - C*(CLMI(1,K)*CLMI(1,K))) DO 1491 J=1,NC B(J,K)=(NU(J,K) - CLMI(1,K))/CLMI(2,K) IF(ABS(B(J,K)).LE..0001) B(J,K)=0.0 1491 CONTINUE CALL FROCO2(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS,P) 8225 CONTINUE CALL CLMARG(RO,CO,G,FI,CLMI,NR,NC,NL,FS) CALL XTJK(RO,CO,G,TJK,CLM,CLMI,NR,NC,NL,TJKCON) CALL FROCO2 (RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS,P) DO 151 I=1,NR DO 151 K=1,NL CLMI(I,K)=0.0 RLMI(I,K)=0.0 151 CONTINUE DO 152 I=1,NR X=0.0 XX=0.0 DO 153 K=1,NL DO 153 J=1,NC IF(FS(I,J,K).EQ.0.0) GOTO 153 Y=B(J,K) YY=Y*Y IF(MOD(14).EQ.1.OR.MOD(15).EQ.1) THEN CLMI(I,K)=CLMI(I,K)+(F(I,J,K)+F(J,I,K)-FI(J,I,K) 1 - FI(I,J,K))*Y RLMI(I,K)=RLMI(I,K) + YY*(FI(I,J,K)+FI(J,I,K)) ELSE CLMI(I,K)=CLMI(I,K) + (F(I,J,K) - FI(I,J,K))*Y RLMI(I,K)=RLMI(I,K) + YY*(FI(I,J,K)) ENDIF 153 CONTINUE IF(MOD(14).NE.1.AND.MOD(10).NE.1.AND.MOD(12).NE.1) GOTO 156 DO 157 K=1,NL X=X + CLMI(I,K) XX=XX + RLMI(I,K) 157 CONTINUE DO 158 K=1,NL MU(I,K)=MU(I,K) + X/XX IF(MOD(14).EQ.1.OR.MOD(15).EQ.1) NU(I,K)=MU(I,K) 158 CONTINUE GOTO 152 156 CONTINUE DO 159 K=1,NL MU(I,K)=MU(I,K) + CLMI(I,K)/RLMI(I,K) IF(MOD(14).EQ.1.OR.MOD(15).EQ.1) NU(I,K)=MU(I,K) 159 CONTINUE 152 CONTINUE C C ----- RESCALE THE MU AND PLACE IN A C DO 1591 K=1,NL CLMI(1,K)=0.0 CLMI(2,K)=0.0 DO 1590 I=1,NR CLMI(2,K)=CLMI(2,K) + MU(I,K)**2 CLMI(1,K)=CLMI(1,K) + MU(I,K) 1590 CONTINUE CLMI(1,K)=CLMI(1,K)/R CLMI(2,K)=SQRT(CLMI(2,K) - R*(CLMI(1,K)*CLMI(1,K))) DO 1591 I=1,NR A(I,K)=(MU(I,K) - CLMI(1,K))/CLMI(2,K) IF(ABS(A(I,K)).LE..0001) A(I,K)=0.0 IF(MOD(14).EQ.1.OR.MOD(15).EQ.1) B(I,K)=A(I,K) 1591 CONTINUE CALL FROCO2(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS,P) IF(J7.GE.1.AND.J7.LE.5)THEN CALL DLMARG(RO,CO,G,FI,DLMI,DLMI1,NR,NC,NL,FS,J7) CALL XDIK(RO,CO,G,DIK,DIK1,DLM,DLM1,DLMI,DLMI1,NR,NC,NL,J7) CALL FROCO2(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS,P) ENDIF GOTO 400 400 CONTINUE C C TEST FOR CONVERGENCE C XDEV=0.0 DO 401 I=1,NR DO 401 J=1,NC DO 401 K=1,NL X=ABS(FF(I,J,K)-FI(I,J,K)) IF(X.GE.XDEV)XDEV=X 401 CONTINUE If(PC) Call PCtr(M,IN) IF(J6.EQ.0.and.((M/25)*25.eq.M)) WRITE(12,402) M,XDEV 402 FORMAT(/,' ITERATION =',I5,' DEVIATION =',F12.7) 2888 CONTINUE DO 403 I=1,NR DO 403 J=1,NC DO 403 K=1,NL FF(I,J,K)=FI(I,J,K) 403 CONTINUE IF(XDEV.LE.TOL)GO TO 510 500 CONTINUE 510 XSQ=0.0 C C ----- CALCULATE CHI-SQUARE, WRITE RESULTS C NDIAG=0 NZERO=0 XLSQ=0.0 XN=0.0 DELTA=0.0 IF(J7.EQ.1) NDIAG=NR*NL IF(J7.EQ.2) NDIAG=NL IF(J7.EQ.3) NDIAG=NR IF(J7.EQ.4) NDIAG=NR+NL-1 IF(J7.EQ.5) NDIAG=1 DO 520 I=1,NR DO 520 J=1,NC DO 520 K=1,NL IF(FS(I,J,K).EQ.0.0)NZERO=NZERO+1 XN=XN+F(I,J,K) IF(FS(I,J,K).EQ.0.0)GOTO 520 DELTA=DELTA + ABS(F(I,J,K)-FF(I,J,K)) IF(FF(I,J,K).LE..00001)GOTO 520 XSQ=XSQ + ((F(I,J,K)-FF(I,J,K))**2)/FF(I,J,K) FI(I,J,K)=(F(I,J,K)-FF(I,J,K))/(FF(I,J,K)**.5) IF(F(I,J,K).GT.0.0)XLSQ=XLSQ + F(I,J,K)*ALOG(F(I,J,K) 1 /FF(I,J,K)) 520 CONTINUE DELTA=DELTA/(2.*XN) XLSQ=2.*XLSQ IDF=(NR-1)*(NC-1)*NL If(Mod( 1).EQ.1) Idf=Idf If(Mod( 2).EQ.1) Idf=Idf - 1 If(Mod( 3).EQ.1) Idf=Idf - NL If(Mod( 4).EQ.1) Idf=Idf - (NR-1) If(Mod( 5).EQ.1) Idf=Idf - (NC-1) If(Mod( 6).EQ.1) Idf=Idf - (NR-2) - NL If(Mod( 7).EQ.1) Idf=Idf - (NC-2) - NL If(Mod( 8).EQ.1) Idf=Idf - NL*(NR-1) If(Mod( 9).EQ.1) Idf=Idf - NL*(NC-1) If(Mod(10).EQ.1) Idf=Idf - (NR-2) - (NC-2) - NL If(Mod(11).EQ.1) Idf=Idf - NL*(NR-2) - (NC-2) - NL If(Mod(12).EQ.1) Idf=Idf - (NR-2) - NL*(NC-2) - NL If(Mod(13).EQ.1) Idf=Idf - NL*(NR-2) - NL*(NC-2) - NL If(Mod(14).EQ.1) Idf=Idf - (NR-2) - NL If(Mod(15).EQ.1) Idf=Idf - NL*(NR-2) - NL IDF=IDF-NDIAG-NZERO SUM=0.0 SUM1=0.0 DO 2001 I=1,NR DO 2001 J=1,NC DO 2001 K=1,NL SUM=SUM+F(I,J,K) SUM1=SUM1+FF(I,J,K) 2001 CONTINUE BIC=XLSQ - IDF * LOG(SUM) WRITE(12,530)M,XDEV,XSQ,XLSQ,IDF,BIC,DELTA,XSQ/IDF,XLSQ/IDF, 1SUM,XSQ/SUM,XLSQ/SUM,SUM1 530 FORMAT(//,' Iteration = ',I4,' Deviation = ',F10.7,/, 1 ' Pearson Chi-Square = ',F12.4,/, 2 ' Likelihood-Ratio Chi-Square= ',F12.4,/, 3 ' Degrees of Freedom = ',I6,/ 4 ' BIC = ',F12.4,/, 5 ' Index of Dissimilarity = ',F12.4,/, 6 ' Chi/Df = ',F12.4,/, 7 ' L/Df = ',F12.4,/, 5 ' Sample Size = ',F12.4,/, 8 ' Effect Size (Chi) = ',F12.4,/, 9 ' Effect Size (L) = ',F12.4,/, 5 ' Expected Sample Size = ',F12.4,/) NX=NR-1 NY=NC-1 IF(J1.EQ.1) GO TO 600 WRITE(12,531) 531 FORMAT(//,' Observed, Expected, and Stdized Residuals') WRITE(12,559) 559 FORMAT(' ',41('-')) DO 532 K=1,NL WRITE(12,533)K 533 FORMAT(/,' -----Group #',I4) 535 FORMAT(/,' --All Groups--') DO 532 I=1,NR WRITE(12,534)(F(I,J,K),J=1,NC) WRITE(12,534)(FF(I,J,K),J=1,NC) WRITE(12,534)(FI(I,J,K),J=1,NC) WRITE(12,558) 558 FORMAT(/) 534 FORMAT(10F8.2) 532 CONTINUE C C CALCULATE CROSS-RATIOS OF OBSERVED AND EXPECTED, TO VERIFY MODEL C 600 IF(J2.EQ.1)GO TO 601 DO 540 K=1,NL DO 540 I=1,NX DO 540 J=1,NY C C ----- REPLACE ZEROES WITH 0.5 IN DENOMINATOR OF OBS ODDS----- C IF(F(I,J+1,K).LE..01) VV=0.5 IF(F(I,J+1,K).GT..01) VV=F(I,J+1,K) IF(F(I+1,J,K).LE..01) WW=0.5 IF(F(I+1,J,K).GT..01) WW=F(I+1,J,K) FI(I,J,K)=F(I,J,K)*F(I+1,J+1,K)/(VV*WW) 540 CONTINUE WRITE(12,545) 545 FORMAT(//,' Observed Cross-Ratios') WRITE(12,560) 560 FORMAT(' ',21('-')) DO 546 K=1,NL WRITE(12,533) K DO 546 I=1,NX WRITE(12,547) (FI(I,J,K),J=1,NY) 546 CONTINUE 547 FORMAT(/,10(1X,F10.5)) 601 IF(J3.EQ.1) GOTO 6000 DO 550 K=1,NL DO 550 I=1,NX DO 550 J=1,NY PP=FS(I,J,K)*FS(I+1,J+1,K)*FS(I+1,J,K)*FS(I,J+1,K) IF(PP.EQ.0) GOTO 800 C C ----- REPLACE ZEROES WITH 0.5 IN DENOMINATOR ----- C IF(FF(I,J+1,K).LE..01) TT=0.5 IF(FF(I,J+1,K).GT..01) TT=FF(I,J+1,K) IF(FF(I+1,J,K).LE..01) QQ=0.5 IF(FF(I+1,J,K).GT..01) QQ=FF(I+1,J,K) FI(I,J,K)=FF(I,J,K)*FF(I+1,J+1,K)/(TT*QQ) GOTO 550 800 CONTINUE FI(I,J,K)=-1.0 550 CONTINUE WRITE(12,551) 551 FORMAT(//,1H ,'Expected Cross-Ratios') WRITE(12,560) DO 552 K=1,NL WRITE(12,533) K DO 552 I=1,NX WRITE(12,547) (FI(I,J,K),J=1,NY) 552 CONTINUE 6000 Continue C C Printing of Model Parameters C IF(J4.EQ.1) GOTO 499 WRITE(12,6001) 6001 FORMAT(/,' Model Parameters',/,' ',16('-')) 6002 Format(2X,I3,5X,7F10.3) 6003 Format(10X,7F10.3) 6004 FORMAT(' All Groups ',/,' ',10('-'),/,9(10X,7F10.3/),/) 6005 Format(' Group # ',/,' ',7('-')) 6006 Format(2X,I3,':',I3,1X,7F10.3) IF(J8.EQ.1) GOTO 6020 C Rows WRITE(12,6010) 6010 FORMAT(/,' *** Rows',/,' ',8('-'),/) Write(12,6005) DO 6011 K=1,NL KK=1 6012 LL=KK+6 If(LL.GT.NR) LL=NR If(KK.EQ.1) Then Write(12,6002) K,(TIK(I,K), I=KK,LL) Else Write(12,6003) (TIK(I,K), I=KK,LL) EndIf KK=KK+7 IF(LL.LT.NR) Goto 6012 6011 CONTINUE C Columns WRITE(12,6015) 6015 FORMAT(/,' *** Columns',/,' ',11('-'),/) Write(12,6005) DO 6016 K=1,NL KK=1 6017 LL=KK+6 If(LL.GT.NC) LL=NC If(KK.EQ.1) Then Write(12,6002) K,(TJK(J,K), J=KK,LL) Else Write(12,6003) (TJK(J,K), J=KK,LL) EndIf KK=KK+7 IF(LL.LT.NC) Goto 6017 6016 CONTINUE 6020 CONTINUE IF(J5.EQ.1.AND.IN.GE.10) GOTO 6059 C Uniform Association If(In.eq.2) Write(12,6030) T 6030 Format(/,' *** Uniform Association: ', F7.3,/,' ',25('-'),/) If(In.eq.3.or.In.eq.6.or.In.eq.7) Then Write(12,6031) 6031 Format(/,' *** Uniform Association',/,' ',25('-'),/) If(In.eq.6.or.In.eq.7) Then Do 6033 K=1,NL If(In.eq.6) A(1,K)=B(2,K)/B(1,K) If(In.eq.7) A(1,K)=A(2,K)/A(1,K) 6033 Continue EndIf Write(12,6005) KK=1 6032 LL=KK+6 If(LL.GT.NL) LL=NL Write(12,6006) KK,LL,(A(1,K), K=KK,LL) KK=KK+7 IF(LL.LT.NL) Goto 6032 EndIf C If(In.ge.1.and.In.le.3) Goto 6090 IF(In.eq.5.or.In.eq.7.or.In.eq.9) Goto 6049 C Row effects WRITE(12,6040) 6040 FORMAT(/,' *** Alpha-s',/,' ',11('-'),/) IF(IH1.EQ.1) THEN WRITE(12,6004) (A(I,1),I=1,NR) ELSE Write(12,6005) DO 6041 K=1,NL KK=1 6042 LL=KK+6 If(LL.GT.NR) LL=NR If(KK.EQ.1) Then Write(12,6002) K,(A(I,K), I=KK,LL) Else Write(12,6003) (A(I,K), I=KK,LL) EndIf KK=KK+7 IF(LL.LT.NR) Goto 6042 6041 CONTINUE ENDIF IF(J9.eq.1) goto 6049 C Alpha Ratios WRITE(12,6043) 6043 FORMAT(/,' *** Alpha Ratios',/,' ',16('-'),/) DO 6044 K=1,NL DO 6044 I=1,NX A(I,K)=A(I+1,K)/A(I,K) 6044 CONTINUE IF(IH1.EQ.1) Then WRITE(12,6004) (A(I,1),I=1,NX) Else Write(12,6005) Do 6045 K=1,NL KK=1 6046 LL=KK+6 If(LL.GT.NX) LL=NX If(KK.EQ.1) Then Write(12,6002) K,(A(I,K), I=KK,LL) Else Write(12,6003) (A(I,K), I=KK,LL) EndIf KK=KK+7 IF(LL.LT.NX) Goto 6046 6045 CONTINUE EndIf 6049 CONTINUE IF(In.eq.4.or.In.eq.6.or.In.eq.8) Goto 6090 C Betas WRITE(12,6050) 6050 FORMAT(/,' *** Beta-s',/,' ',10('-'),/) IF(IH2.EQ.1) THEN WRITE(12,6004) (B(J,1),J=1,NC) ELSE Write(12,6005) DO 6051 K=1,NL KK=1 6052 LL=KK+6 If(LL.GT.NC) LL=NC If(KK.EQ.1) Then Write(12,6002) K,(B(J,K), J=KK,LL) Else Write(12,6003) (B(J,K), J=KK,LL) EndIf KK=KK+7 IF(LL.LT.NC) Goto 6052 6051 CONTINUE END IF If(J9.EQ.1) GOTO 6090 C Beta Ratios WRITE(12,6053) 6053 FORMAT(/,' *** Beta Ratios',/,' ',15('-'),/) DO 6054 K=1,NL DO 6054 J=1,NY B(J,K)=B(J+1,K)/B(J,K) 6054 CONTINUE IF(IH2.EQ.1) Then WRITE(12,6004) (B(J,1),J=1,NY) Else Write(12,6005) Do 6055 K=1,NL KK=1 6056 LL=KK+6 If(LL.GT.NY) LL=NY If(KK.EQ.1) Then Write(12,6002) K,(B(J,K), J=KK,LL) Else Write(12,6003) (B(J,K), J=KK,LL) EndIf KK=KK+7 IF(LL.LT.NY) Goto 6056 6055 CONTINUE EndIf GOTO 6090 6059 Continue C Model II C Phis WRITE(12,6060) 6060 FORMAT(/,' *** Phi-s',/,' ',9('-'),/) Write(12,6005) KK=1 6061 LL=KK+6 If(LL.GT.NL) LL=NL Write(12,6006) KK,LL,(P(K), K=KK,LL) KK=KK+7 IF(LL.LT.NL) Goto 6061 C Rhos IF(IE.NE.1) WRITE(12,6062) IF(IE.EQ.1) WRITE(12,6063) 6062 FORMAT(/,' *** Rho-s',/,' ',9('-'),/) 6063 FORMAT(/,' *** Equal Rho-s and Sigma-s',/,' ',27('-'),/) IF(IH1.EQ.1) THEN WRITE(12,6004) (A(I,1),I=1,NR) ELSE Write(12,6005) DO 6064 K=1,NL KK=1 6065 LL=KK+6 If(LL.GT.NR) LL=NR If(KK.EQ.1) Then Write(12,6002) K,(A(I,K), I=KK,LL) Else Write(12,6003) (A(I,K), I=KK,LL) EndIf KK=KK+7 IF(LL.LT.NR) Goto 6065 6064 CONTINUE ENDIF IF(J9.EQ.1) GOTO 6075 C Mus IF(IE.NE.1) WRITE(12,6066) IF(IE.EQ.1) WRITE(12,6067) 6066 FORMAT(/,' *** Mu-s',/,' ',8('-'),/) 6067 FORMAT(/,' *** Equal Mu-s and Nu-s',/,' ',23('-'),/) IF(IH1.EQ.1) THEN WRITE(12,6004) (MU(I,1),I=1,NR) ELSE Write(12,6005) DO 6068 K=1,NL KK=1 6069 LL=KK+6 If(LL.GT.NR) LL=NR If(KK.EQ.1) Then Write(12,6002) K,(MU(I,K), I=KK,LL) Else Write(12,6003) (MU(I,K), I=KK,LL) EndIf KK=KK+7 IF(LL.LT.NR) Goto 6069 6068 CONTINUE ENDIF C Mu differences IF(IE.NE.1) WRITE(12,6070) IF(IE.EQ.1) WRITE(12,6071) 6070 FORMAT(/,' *** Mu Differences',/,' ',18('-'),/) 6071 FORMAT(/,' *** Equal Mu and Nu Differences',/,' ',31('-'),/) DO 6072 K=1,NL DO 6072 I=1,NX MU(I,K)=MU(I+1,K) - MU(I,K) 6072 CONTINUE IF(IH1.EQ.1) THEN WRITE(12,6004) (MU(I,1),I=1,NX) ELSE Write(12,6005) DO 6073 K=1,NL KK=1 6074 LL=KK+6 If(LL.GT.NX) LL=NX If(KK.EQ.1) Then Write(12,6002) K,(MU(I,K), I=KK,LL) Else Write(12,6003) (MU(I,K), I=KK,LL) EndIf KK=KK+7 IF(LL.LT.NX) Goto 6074 6073 CONTINUE ENDIF 6075 Continue IF(IE.EQ.1) GOTO 6090 C Sigmas WRITE(12,6076) 6076 FORMAT(/,' *** Sigma-s',/,' ',11('-'),/) IF(IH2.EQ.1) THEN WRITE(12,6004) (B(J,1),J=1,NC) ELSE Write(12,6005) DO 6077 K=1,NL KK=1 6078 LL=KK+6 If(LL.GT.NC) LL=NC If(KK.EQ.1) Then Write(12,6002) K,(B(J,K), J=KK,LL) Else Write(12,6003) (B(J,K), J=KK,LL) EndIf KK=KK+7 IF(LL.LT.NC) Goto 6078 6077 CONTINUE ENDIF IF(J9.eq.1) goto 6090 C Nus WRITE(12,6080) 6080 FORMAT(/,' *** Nu-s',/,' ',8('-'),/) IF(IH2.EQ.1) THEN WRITE(12,6004) (NU(J,1),J=1,NC) ELSE Write(12,6005) DO 6081 K=1,NL KK=1 6082 LL=KK+6 If(LL.GT.NC) LL=NC If(KK.EQ.1) Then Write(12,6002) K,(NU(J,K), J=KK,LL) Else Write(12,6003) (NU(J,K), J=KK,LL) EndIf KK=KK+7 IF(LL.LT.NC) Goto 6082 6081 CONTINUE ENDIF C Nu differences WRITE(12,6085) 6085 FORMAT(/,' *** Nu Differences',/,' ',18('-'),/) DO 6086 K=1,NL DO 6086 J=1,NY NU(J,K)=NU(J+1,K) - NU(J,K) 6086 CONTINUE IF(IH2.EQ.1) THEN WRITE(12,6004) (NU(J,1),J=1,NY) ELSE Write(12,6005) DO 6087 K=1,NL KK=1 6088 LL=KK+6 If(LL.GT.NY) LL=NY If(KK.EQ.1) Then Write(12,6002) K,(NU(J,K), J=KK,LL) Else Write(12,6003) (NU(J,K), J=KK,LL) EndIf KK=KK+7 IF(LL.LT.NY) Goto 6088 6087 CONTINUE ENDIF 6090 CONTINUE C Diagonal C Free Diagonals IF(J7.EQ.1) THEN WRITE(12,6091) 6091 FORMAT(/,' *** Free Diagonals',/,' ',18('-'),/) Write(12,6005) DO 6092 K=1,NL KK=1 6093 LL=KK+6 If(LL.GT.NR) LL=NR If(KK.EQ.1) Then Write(12,6002) K,(DIK(I,I,K), I=KK,LL) Else Write(12,6003) (DIK(I,I,K), I=KK,LL) EndIf KK=KK+7 IF(LL.LT.NR) Goto 6093 6092 CONTINUE ENDIF C Group Specific Diagonal Parameters IF(J7.EQ.2.OR.J7.EQ.4) THEN WRITE(12,6094) 6094 FORMAT(/,' *** Group Specific Diagonals',/,' ',28('-'),/) Write(12,6005) KK=1 6095 LL=KK+6 If(LL.GT.NL) LL=NL Write(12,6006) KK,LL,(DIK1(1,1,K), K=KK,LL) KK=KK+7 IF(LL.LT.NL) Goto 6095 ENDIF C Category Specific Diagonal Parameters IF(J7.GE.3.AND.J7.LE.4) THEN WRITE(12,6096) 6096 FORMAT(/,' *** Category Specific Diagonals',/,' ',31('-'),/) WRITE(12,6004) (DIK(I,I,1),I=1,NR) ENDIF IF(J7.EQ.5) Write(12,6097) DIK(1,1,1) 6097 Format(/,' *** Diagonal Effect: ', F7.3,/,' ',20('-'),/) 499 CONTINUE 9020 FORMAT(//,' ',56('*'),/,' No More Model Information Requested--- * Job Completed ',/,' ',56('*'),//) WRITE(12,9020) 1010 STOP END C C C SUBROUTINE RLMARG(RO,CO,G,F,RLM,NR,NC,NL,FS) C TAKES ARRAYF AND RETURNS ROW-LAYER MARGINALS IN RLM INTEGER RO,CO,G DIMENSION F(RO,CO,G),RLM(RO,G),FS(RO,CO,G) DO 10 I=1,NR DO 10 K=1,NL RLM(I,K)=0.0 10 CONTINUE DO 20 I=1,NR DO 20 J=1,NC DO 20 K=1,NL RLM(I,K)=RLM(I,K)+F(I,J,K)*FS(I,J,K) 20 CONTINUE RETURN END C C C SUBROUTINE CLMARG(RO,CO,G,F,CLM,NR,NC,NL,FS) C TAKES ARRAY F AND RETURNS COL-LAYER MARGINALS IN CLM INTEGER RO,CO,G DIMENSION F(RO,CO,G),CLM(CO,G),FS(RO,CO,G) DO 10 J=1,NC DO 10 K=1,NL CLM(J,K)=0.0 10 CONTINUE DO 20 I=1,NR DO 20 J=1,NC DO 20 K=1,NL CLM(J,K)=CLM(J,K)+F(I,J,K)*FS(I,J,K) 20 CONTINUE RETURN END C C C SUBROUTINE FCIND(RO,CO,G,FI,TIK,TJK,DIK,DIK1,T,NR,NC,NL,FS) C CALCULATES EXPECTED UNDER C-IND AND HOMOGENEOUS UNIFORM MODEL INTEGER RO,CO,G DIMENSION FI(RO,CO,G),TIK(RO,G),TJK(CO,G), 1FS(RO,CO,G),DIK(RO,CO,G),DIK1(RO,CO,G) DO 10 K=1,NL DO 10 I=1,NR DO 10 J=1,NC X=REAL(I*J) FI(I,J,K)=TIK(I,K)*TJK(J,K)*DIK(I,J,K)*DIK1(I,J,K) * *(T**X)*FS(I,J,K) 10 CONTINUE RETURN END C C C SUBROUTINE FHECU(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,NR,NC,NL,FS) C CALCULATES EXPECTED UNDER HETEROGENEOUS UNIFORM MODEL INTEGER RO,CO,G DIMENSION FI(RO,CO,G),TIK(RO,G),TJK(CO,G),DIK(RO,CO,G), 1 DIK1(RO,CO,G),FS(RO,CO,G) REAL A(RO,G) DO 10 K=1,NL DO 10 J=1,NC DO 10 I=1,NR X=(REAL(I)-REAL(NR+1)/2.)*(REAL(J)-REAL(NC+1)/2.) FI(I,J,K)=TIK(I,K)*TJK(J,K)*DIK(I,J,K)*DIK1(I,J,K) * *(A(1,K)**X)*FS(I,J,K) 10 CONTINUE RETURN END C C C SUBROUTINE FROCOL(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS) C CALCULATES F'S UNDER SOME ROW=COLUMN EFFECT MODELS INTEGER RO,CO,G DIMENSION FI(RO,CO,G),TIK(RO,G),TJK(CO,G),DIK(RO,CO,G), 1 DIK1(RO,CO,G),FS(RO,CO,G) REAL A(RO,G),B(CO,G) DO 10 J=1,NC X=REAL(J)-REAL(NC+1)/2. DO 10 I=1,NR Y=REAL(I)-REAL(NR+1)/2. DO 10 K=1,NL FI(I,J,K)=TIK(I,K)*TJK(J,K)*DIK(I,J,K)*DIK1(I,J,K) * *(A(I,K)**X)*(B(J,K)**Y)*FS(I,J,K) 10 CONTINUE RETURN END C C C SUBROUTINE XTIK(RO,CO,G,TIK,RLM,RLMI,NR,NC,NL) C CALCULATES THE TIK INTEGER RO,CO,G DIMENSION TIK(RO,G),RLM(RO,G),RLMI(RO,G) DO 10 I=1,NR DO 10 K=1,NL TIK(I,K)=TIK(I,K)*RLM(I,K)/RLMI(I,K) 10 CONTINUE RETURN END C C C SUBROUTINE XTJK(RO,CO,G,TJK,CLM,CLMI,NR,NC,NL,TJKCON) C CALCULATES THE TJK INTEGER RO,CO,G DIMENSION TJK(CO,G),CLM(CO,G),CLMI(CO,G),TJKCON(G) DO 10 K=1,NL TJKCON(K)=1 DO 10 J=1,NC TJKCON(K)=TJKCON(K)*TJK(J,K) 10 CONTINUE DO 20 J=1,NC DO 20 K=1,NL TJK(J,K)=TJK(J,K)*CLM(J,K)/CLMI(J,K)/TJKCON(k)**(1/real(nc)) 20 CONTINUE RETURN END C C SUBROUTINE FROCO2(RO,CO,G,FI,TIK,TJK,DIK,DIK1,A,B,NR,NC,NL,FS,P) C CALCULATES F'S UNDER SOME MODEL II ROW-COLUMN EFFECTS MODELS INTEGER RO,CO,G REAL FI(RO,CO,G),TIK(RO,G),TJK(CO,G),DIK(RO,CO,G),DIK1(RO,CO,G), * FS(RO,CO,G) REAL P(G),A(RO,G),B(CO,G) DO 10 I=1,NR DO 10 J=1,NC DO 10 K=1,NL FI(I,J,K)=TIK(I,K)*TJK(J,K)*DIK(I,J,K)*DIK1(I,J,K) * *EXP(P(K)*A(I,K)*B(J,K))*FS(I,J,K) 10 CONTINUE RETURN END C C C SUBROUTINE XDIK(RO,CO,G,DIK,DIK1,DLM,DLM1,DLMI,DLMI1,NR,NC,NL,J7) C CALCULATES THE DIK,DIK1 INTEGER RO,CO,G DIMENSION DIK(RO,CO,G),DIK1(RO,CO,G),DLM(RO,G),DLMI(RO,G), 1 DLM1(RO,G),DLMI1(RO,G) DO 10 I=1,NR DO 10 K=1,NL IF(J7.EQ.1) THEN IF(DLMI(I,K).EQ.0.0)THEN DIK(I,I,K)=0.0 ELSE DIK(I,I,K)=DIK(I,I,K)*DLM(I,K)/DLMI(I,K) ENDIF ELSEIF(J7.EQ.4.OR.J7.EQ.3)THEN IF(DLMI(I,1).EQ.0.0)THEN DIK(I,I,K)=0.0 ELSE DIK(I,I,K)=DIK(I,I,K)*DLM(I,1)/DLMI(I,1) ENDIF ELSEIF(J7.EQ.5) THEN IF(DLMI(1,1).EQ.0.0)THEN DIK(I,I,K)=0.0 ELSE DIK(I,I,K)=DIK(I,I,K)*DLM(1,1)/DLMI(1,1) ENDIF ENDIF IF(J7.EQ.2.OR.J7.EQ.4) THEN IF(DLMI1(1,K).EQ.0.0)THEN DIK1(I,I,K)=0.0 ELSE DIK1(I,I,K)=DIK1(I,I,K)*DLM1(1,K)/DLMI1(1,K) ENDIF ENDIF 10 CONTINUE RETURN END C SUBROUTINE DLMARG(RO,CO,G,F,DLM,DLM1,NR,NC,NL,FS,J7) C TAKES ARRAY F AND RETURNS DIAGONAL-LAYER MARGINALS IN DLM INTEGER RO,CO,G DIMENSION F(RO,CO,G),DLM(RO,G),FS(RO,CO,G),DLM1(RO,G) DO 10 I=1,NR DO 10 K=1,NL DLM(I,K)=0.0 DLM1(I,K)=0.0 10 CONTINUE IF(J7.EQ.1)THEN DO 20 I=1,NR DO 20 K=1,NL DLM(I,K)=DLM(I,K)+F(I,I,K)*FS(I,I,K) 20 CONTINUE ENDIF IF(J7.EQ.2.OR.J7.EQ.4)THEN DO 21 I=1,NR DO 21 K=1,NL DLM1(1,K)=DLM1(1,K)+F(I,I,K)*FS(I,I,K) 21 CONTINUE ENDIF IF(J7.EQ.3.OR.J7.EQ.4)THEN DO 22 I=1,NR DO 22 K=1,NL DLM(I,1)=DLM(I,1)+F(I,I,K)*FS(I,I,K) 22 CONTINUE ENDIF IF(J7.EQ.5)THEN DO 23 I=1,NR DO 23 K=1,NL DLM(1,1)=DLM(1,1)+F(I,I,K)*FS(I,I,K) 23 CONTINUE ENDIF RETURN END C C C SUBROUTINE PCInit Character INFID*50,OUTFID*50 5005 WRITE(*,*) ' ' WRITE(*,*) 'What is the name of the Input Commandfile?' WRITE(*,*) '(be sure to include the associated path.)' 5010 FORMAT (A) READ (*, 5010) INFID OPEN (9,FILE=INFID,IOSTAT=IOS) IF (IOS .NE. 0) THEN WRITE(*,*) ' ' WRITE(*,*) 'Unable to open the file named', INFID WRITE(*,*) 'Please try again.' GOTO 5005 ENDIF WRITE (*,*) ' ' WRITE (*,*) ' ' WRITE (*,*) 'Where would you like your output to go?' WRITE (*,*) 'Enter "PRN" for a printer or "CON" for the screen' WRITE (*,*) 'or a file name including the associated path.' READ (*, 5010) OUTFID OPEN (12,FILE=OUTFID,STATUS='NEW') End C Subroutine PCtr(M,IN) If(M.eq.1) Write(*,1) IN 1 Format(/' Model ',I2,' is estimated '/) IF((M/10)*10.EQ.M) Then Write(*,'(A\)') 'Û' If((M/500)*500.EQ.M) Write(*,'(T25\)') EndIf End