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
