C   FORTRAN 77 PROGRAM, VERSION 15/02/1992
C   NIGGLI MOLECULAR NORM (CATANORM)
C   After Barth 1962a; modified by Hutchison & Jeacoke 1971.
c$DEBUG
      INTEGER IN, OUT, REF, RESULT, OXOUT(36), NOXOUT
      PARAMETER (IN=5, OUT=6, REF=9, RESULT=10)
      REAL MT,KS,NS,IL,LC,KL,NE,MON,MU,MUSCO,MINOUT(40)
      CHARACTER*1 ANSWER,BIOT
      CHARACTER*3 MINNAM(40)
      CHARACTER*5 OXIDE(36),TITLEX
      CHARACTER*30 NAME
      DIMENSION WTP(36),V(22),EQMOL(36),CATPC(36)
C   *******************************************
C   WTP   - WeighT Percent.
C   OXIDE - OXIDE analysed.
C   EQMOL - EQuivalent MOLecular weight values.
C   CATPC - CATion PerCent
C   *******************************************
      DATA OXIDE(1),EQMOL(1)/'SiO2 ',60.0843	/
      DATA OXIDE(2),EQMOL(2)/'TiO2 ',79.8988	/
      DATA OXIDE(3),EQMOL(3)/'Al2O3',50.98064	/
      DATA OXIDE(4),EQMOL(4)/'Fe2O3',79.8461	/
      DATA OXIDE(5),EQMOL(5)/'FeO  ',71.8464	/
      DATA OXIDE(6),EQMOL(6)/'MnO  ',70.93745	/
      DATA OXIDE(7),EQMOL(7)/'NiO  ',74.6894	/
      DATA OXIDE(8),EQMOL(8)/'MgO  ',40.3044	/
      DATA OXIDE(9),EQMOL(9)/'CaO  ',56.0774	/
      DATA OXIDE(10),EQMOL(10)/'BaO  ',153.3294 /
      DATA OXIDE(11),EQMOL(11)/'SrO  ',103.6194 /
      DATA OXIDE(12),EQMOL(12)/'Na2O ',30.989468/
      DATA OXIDE(13),EQMOL(13)/'K2O  ',47.098	/
      DATA OXIDE(14),EQMOL(14)/'P2O5 ',70.97226 /
      DATA OXIDE(15),EQMOL(15)/'F-   ',18.998403/
      DATA OXIDE(16),EQMOL(16)/'Cl-  ',35.4527	/
      DATA OXIDE(17),EQMOL(17)/'S    ',32.066	/
      DATA OXIDE(18),EQMOL(18)/'CO2  ',44.0098	/
      DATA OXIDE(19),EQMOL(19)/'ZrO2 ',123.2228 /
      DATA OXIDE(20),EQMOL(20)/'SnO2 ',150.7088 /
      DATA OXIDE(21),EQMOL(21)/'Cr2O3',75.9952	/
      DATA OXIDE(22),EQMOL(22)/'CuO  ',79.5454	/
      DATA OXIDE(23),EQMOL(23)/'ZnO  ',81.3894	/
      DATA OXIDE(24),EQMOL(24)/'Li2O ',14.9407	/
      DATA OXIDE(25),EQMOL(25)/'SO3  ',80.0642	/
      DATA OXIDE(26),EQMOL(26)/'H2O+ ',9.00764	/
      DATA OXIDE(27),EQMOL(27)/'H2O- ',9.00764	/
      DATA OXIDE(28),EQMOL(28)/'V2O3 ',74.9406	/
      DATA OXIDE(29),EQMOL(29)/'CoO  ',74.9326	/
      DATA OXIDE(30),EQMOL(30)/'Rb2O ',93.4675	/
      DATA OXIDE(31),EQMOL(31)/'Cs2O ',140.90513/
      DATA OXIDE(32),EQMOL(32)/'HfO2 ',210.4888 /
      DATA OXIDE(33),EQMOL(33)/'Y2O3 ',112.90495/
      DATA OXIDE(34),EQMOL(34)/'Ce2O3',164.1191 /
      DATA OXIDE(35),EQMOL(35)/'La2O3',162.9046 /
      DATA OXIDE(36),EQMOL(36)/'H2O  ',9.00764	/
      DO 1 K=1,36
1     CONTINUE
      SUM=0
      SUM1=0
      WRITE(OUT,10)
10    FORMAT(/' Sample Name or No: ? ')
      READ(IN,20)NAME
20    FORMAT(A)
      WRITE(OUT,30)
30    FORMAT(/' How many elements have been analyzed: ?')
      READ(IN,40)NUM
40    FORMAT(I2)
      WRITE(OUT,50)
50    FORMAT(/' Oxides and Wt-%(A6,F8,3)'/)
      DO 5 IJ=1,NUM
2     READ(IN,60)TITLEX,WTPER
60    FORMAT(A,F8.4)
      DO 3 I=1,36
      NUMCOM=I
      IF(TITLEX.EQ.OXIDE(I)) GOTO 4
3     CONTINUE
      WRITE(OUT,70)TITLEX
70    FORMAT(10X,20H No compound called  ,A,8H in data)
      WRITE(OUT,80)
80    FORMAT(/' Do you want to try again (Y/y))?')
      READ(IN,90) ANSWER
90    FORMAT(A)
      IF(ANSWER.EQ.'Y'.OR.ANSWER.EQ.'y') GOTO 2
      STOP
4     CONTINUE
      SUM1=SUM1+WTPER
      WTP(NUMCOM)=WTPER
5     CONTINUE
      WRITE(OUT,100)
100   FORMAT(/' Do you want to calculate Biotite (Y/y))?')
      READ(IN,105) BIOT
105   FORMAT(A)
      WRITE(OUT,110)
110   FORMAT(/' Do you want to calculate Muscovite (Y/y))?')
      READ(IN,105) MUSCO
      OPEN (UNIT=RESULT, FILE='CNORM.OUT')
      WRITE(RESULT,120)NAME
120   FORMAT(/,2X,' S A M P L E: ',A)
      WRITE(RESULT,1000)
1000  FORMAT(1X,73('*'))
      WRITE(RESULT,130)
130   FORMAT(3X,'OXIDES',4X,'wt-%',4X,'OXIDES',4X,'wT-%',4X,'OXIDES',
     14X,'wt-%',4X,'OXIDES',4X,'wt-%')
      NOXOUT=0
      DO 6 I=1,36
      CATPC(I) =1000*WTP(I)/EQMOL(I)
      CATPC(26)=0
      CATPC(27)=0
      CATPC(36)=0
      SUM=SUM+CATPC(I)
6     CONTINUE
      DO 7 IJ=1,36
      CATPC(IJ)=(100*CATPC(IJ))/SUM
      IF (WTP(IJ).NE.0.0) THEN
      NOXOUT=NOXOUT+1
      OXOUT(NOXOUT)=IJ
      ENDIF
7     CONTINUE
      WRITE(RESULT,140)(OXIDE(OXOUT(I)),WTP(OXOUT(I)), I=1,NOXOUT)
140   FORMAT(3X,A,F9.3,4X,A,F9.3,4X,A,F9.3,4X,A,F9.3)
      WRITE(RESULT,150)SUM1
150   FORMAT(/,2X,6H TOTAL,F9.3)
      WRITE(RESULT,160)
160   FORMAT (/,4X,'C A T A N O R M   -   C O M P L E T E   D A T A   O
     1U T P U T')
      WRITE(RESULT,1000)
      IF (CATPC(25).GT.0) THEN
      CATPC(17)=CATPC(25)*0.4004586663
      END IF
C   ***************
      V(1)=CATPC(1)
      V(2)=CATPC(2)
      V(3)=CATPC(3)
      V(4)=CATPC(4)+CATPC(28)
      V(5)=CATPC(5)+CATPC(7)+CATPC(29)
      V(6)=CATPC(8)+CATPC(24)
      V(7)=CATPC(9)
      V(8)=CATPC(12)
      V(9)=CATPC(13)+CATPC(30)+CATPC(31)
      V(10)=CATPC(14)
      V(11)=CATPC(15) + CATPC(16)
      V(12)=CATPC(17)
      V(13)=CATPC(18)
      V(14)=CATPC(19)+CATPC(32)
C   V(1) = SiO2
C   V(2) = TiO2
C   V(3) = Al2O3
C   V(4) = Fe2O3+V2O3
C   V(5) = FeO+NiO+CoO
C   V(6) = MgO+Li2O
C   V(7) = CaO
C   V(8) = Na2O
C   V(9) = K2O+Rb2O+Cs2O
C   V(10) = P2O5
C   V(11) = F-+Cl-
C   V(12) = S
C   V(13) = CO2
C   V(14) = ZrO2+HfO2
      V(15)=CATPC(20)
C   V(15) = SnO2
      V(16)=CATPC(21)
C   V(16) = Cr2O3
      V(17)=CATPC(26)
C   V(17) = H2O+
      V(18)=CATPC(33)+CATPC(34)+CATPC(35)
C   V(18) = Y2O3+Ce2O3+La2O3
      V(19)=CATPC(10)+CATPC(11)
C   V(19) = BaO+SrO
C   ****************************************************************
C   NIGGLI CATANORM CALCULATION: BIOTITE AND/OR MUSCOVITE AS OPTIONS
C   ****************************************************************
C
C   Normative Cassiterite (Ct)
C   **************************
      Ct=V(15)
C   Normative Zircon (Zr)
C   *********************
      Z=2*V(14)
      V(1)=V(1)-V(14)
C   Normative Monacite (Mon)
C   ************************
      IF (V(18).LE.0) GOTO 205
      IF (V(18).GT.V(10)) GOTO 200
      Mon=2*V(18)
      V(10)=V(10)-V(18)
      V(18)=0
      GOTO 205
200   Mon=2*V(10)
      V(18)=V(18)-V(10)
      V(10)=0
      GOTO 250
C   Normative Apatite (Ap)
C   **********************
205   IF (V(10).GT.(0.6*V(7))) GOTO 220
      IF (V(10).LT.(3*V(11))) GOTO 210
      Ap=((8./3.)*V(10))+V(11)
      V(7)=V(7)-((5./3.)*V(10))
      V(10)=0
      V(11)=0
      GOTO 250
210   Ap=3*V(10)
      V(7)=V(7)-((5./3.)*V(10))
      V(11)=V(11)-((1./3.)*V(10))
      V(10)=0
      GOTO 250
220   IF (V(10).LT.(3*V(11))) GOTO 230
      Ap=((5./3.)*V(7))+V(11)
      V(10)=V(10)-((3./5.)*V(7))
      V(11)=0
      V(7)=0
      GOTO 250
230   Ap=1.8*V(7)
      V(11)=V(11)-(0.2*V(7))
      V(10)=V(10)-(0.6*V(7))
      V(7)=0
      WRITE(RESULT,240)V(10)
240   FORMAT(' Insufficient Ca for Apatite, Excess P2O5 = ',F6.2)
      GOTO 340
C   Normative Fluorite (Fr)
C   ***********************
250   IF (V(7).GE.(0.5*V(11))) GOTO 270
      Fr=3*V(7)
      V(11)=V(11)-(2*V(7))
      V(7)=0
      WRITE(RESULT,260)V(11)
260   FORMAT(' Insuficient Ca for Fluorite, Excess F- =',F6.2)
      GOTO 340
270   Fr=1.5*V(11)
      V(7)=V(7)-(0.5*V(11))
      V(11)=0
C   Normative Calcite (Cc)
C   **********************
310   V(7)=V(7)+V(19)
      IF (V(13).GT.V(7)) GOTO 320
      Cc=2*V(13)
      V(7)=V(7)-V(13)
      V(13)=0
      GOTO 340
320   Cc=2*V(7)
      V(13)=V(13)-V(7)
      V(7)=0
      WRITE(RESULT,330)V(13)
330   FORMAT(' Insufficient Ca for Calcite, Excess CO2 =',F6.2)
C   Normative Pyrite (Pr)
C   *********************
340   IF (V(5).GE.(0.5*V(12))) GOTO 360
      Pr=3*V(5)
      V(12)=V(12)-(2*V(5))
      V(5)=0
      WRITE(RESULT,350)V(12)
350   FORMAT(' Insufficient FeO for Pyrite, Excess S =',F6.2)
      GOTO 370
360   Pr=1.5*V(12)
      V(5)=V(5)-(0.5*V(12))
      V(12)=0
C   Normative Chromite (Cm).
C   FeO = FeO + MnO + NiO + CoO
C   ***************************
370   V(5)=V(5)+CATPC(6)
      IF (V(5).GE.(0.5*V(16))) GOTO 390
      Cm=3*V(5)
      V(16)=V(16)-(2*V(5))
      V(5)=0
      WRITE(RESULT,380)V(16)
380   FORMAT(' Insufficient FeO for Chromite, Excess Cr =',F6.2)
      WRITE(3,380)V(16)
      GOTO 400
390   Cm=1.5*V(16)
      V(5)=V(5)-(0.5*V(16))
      V(16)=0
C   Normative Orthoclase (Or)
C   *************************
400   VY=0.04*V(9)
      VX=V(9)+VY
      IF (VX.GT.V(3)) GOTO 410
      Or=5*VX
      V(3)=V(3)-VX
      V(1)=V(1)-3*VX
      VX=0
      GOTO 420
410   Or=5*V(3)
      VX=VX-V(3)
      V(1)=V(1)-(3*V(3))
      V(3)=0
C   Normative K-Metasilicate (Ks)
C   *****************************
      Ks=1.5*VX
      V(1)=V(1)-(0.5*VX)
      VX=0
C   Normative Albite (Ab)
C   *********************
420   V(8)=V(8)-VY
      IF (V(8).GT.V(3)) GOTO 430
      Ab=5*V(8)
      V(3)=V(3)-V(8)
      V(1)=V(1)-(3*V(8))
      V(8)=0
      GOTO 450
430   Ab=5*V(3)
      V(8)=V(8)-V(3)
      V(1)=V(1)-(3*V(3))
      V(3)=0
C   Normative (Aegirine or Acmite) (Ac): Na Fe [Si2O6]
C   0.5*Na2O, Fe2O3, 2SiO2
C   **************************************************
      IF (V(8).GT.V(4)) GOTO 440
      Ac=4*V(8)
      V(4)=V(4)-V(8)
      V(1)=V(1)-(2*V(8))
      V(8)=0
      GOTO 450
440   Ac=4*V(4)
      V(8)=V(8)-V(4)
      V(1)=V(1)-(2*V(4))
      V(4)=0
C   Normative Na-Metasilicate (Ns)
C   ******************************
      Ns=1.5*V(8)
      V(1)=V(1)-(0.5*V(8))
      V(8)=0
C   Normative Anorthite (An)
C   ************************
450   IF (V(7).GT.(0.5*V(3))) GOTO 460
      An=5*V(7)
      V(3)=V(3)-(2*V(7))
      V(1)=V(1)-(2*V(7))
      V(7)=0
      GOTO 480
460   An=2.5*V(3)
      V(7)=V(7)-(0.5*V(3))
      V(1)=V(1)-V(3)
      V(3)=0
C   Normative Corundum (C)
C   **********************
480   C=V(3)
C   Normative Magnetite (Mt)
C   ************************
      IF (V(4).GT.(2*V(5))) GOTO 490
      Mt=1.5*V(4)
      V(5)=V(5)-(0.5*V(4))
      V(4)=0
      GOTO 500
490   Mt=3*V(5)
      V(4)=V(4)-(2*V(5))
      V(5)=0
C   Normative Hematite (Hm)
C   ***********************
      Hm=V(4)
      V(4)=0
C   Normative Ilmenite (Il)
C   ***********************
500   IF (V(2).GT.V(5)) GOTO 505
      Il=2*V(2)
      V(5)=V(5)-V(2)
      V(2)=0
      GOTO 510
505   Il=2*V(5)
      V(2)=V(2)-V(5)
      V(5)=0
C   *********************************
510   RATIO=V(6)/(V(5)+0.00000000001)
      V(22)=V(6)+V(5)
C   ************************************************
C   Normative Biotite (Bi)
C   0.5*K2O MgO FeO MnO 0.5*Al2O3 3*SiO2
C   1/8[KAlMg3[Si3 O10](OH)2]  3MgO+5Or=8Bi    Barth
C			       6Hy +5Or=8Bi+3Q Barth
C   ************************************************
      IF (BIOT.NE.'Y'.AND.BIOT.NE.'y') GOTO 522
      IF (V(22).GT.(0.6*Or)) GOTO 515
      Bi=V(2)+((8./3.)*V(22))
      Or=Or-(V(2)+(5./3.)*V(22))
      V(22)=0
      GOTO 517
515   Bi=1.6*Or
      V(22)=V(22)-((0.6*Or)-V(2))
      Or=0
C   Normative Muscovite (Mu).
C   *************************
517   IF (MUSCO.NE.'Y'.AND.MUSCO.NE.'y') GOTO 522
      IF (C.GT.(0.4*Or)) GOTO 520
      Mu=3.5*C
      Or=Or-(Mu/1.4)
      C=0
      GOTO 522
520   Mu=1.4*Or
      C=C-(Mu/3.5)
      Or=0
C   Normative Titanite (Sphene) (Tn)
C   ********************************
522   IF (V(2).GT.V(7)) GOTO 525
      Tn=3*V(2)
      V(7)=V(7)-V(2)
      V(1)=V(1)-V(2)
      V(2)=0
      GOTO 528
525   Tn=3*V(7)
      V(2)=V(2)-V(7)
      V(1)=V(1)-V(7)
      V(7)=0
C   Normative Rutile (Ru)
C   *********************
      Ru=V(2)
C   Normative Wollastonite (Wo) Ca[SiO3] (3*CaO 3*SiO2)
C   ***************************************************
528   Wo=2*V(7)
      V(1)=V(1)-V(7)
      V(7)=0
C   Normative Spinel (Sp)
C   *********************
      IF (WTP(1).GE.45) GOTO 540
      IF (V(22).GE.(2*C)) GOTO 530
      Sp=3*V(22)
      C=C-(2*V(22))
      V(22)=0
      GOTO 540
530   Sp=1.5*C
      V(22)=V(22)-(0.5*C)
      C=0
C   Normative Hypersthene (Hy) MgFe[Si2O6]  FeO MgO 2*SiO2
C   ******************************************************
540   Hy=2*V(22)
      V(1)=V(1)-V(22)
      V(22)=0
C   Normative Diopside (Di)  CaMg[Si2O6]   CaO MgO 2*SiO2
C   *****************************************************
      IF (Hy.LT.Wo) GOTO 550
      Di=2*Wo
      Hy=Hy-Wo
      Wo=0
      GOTO 560
550   Di=2*Hy
      Wo=Wo-Hy
      Hy=0
C   Normative Quartz (Q)
C   ********************
560   IF (V(1).LT.0) GOTO 570
      Q=V(1)
      GOTO 660
570   Q=-V(1)
C   Normative Perofskite (Pf)
C   *************************
      IF (Tn.LT.(3*Q)) GOTO 580
      Pf=2*Q
      Tn=Tn-(3*Q)
      Q=0
      GOTO 660
580   Pf=(2./3.)*Tn
      Q=Q-((1./3.)*Tn)
      Tn=0
C   Normative Olivine (Ol)
C   **********************
      IF (Hy.LT.(4*Q)) GOTO 590
      Ol=3*Q
      Hy=Hy-(4*Q)
      Q=0
      GOTO 660
590   Ol=0.75*Hy
      Q=Q-(0.25*Hy)
      Hy=0
C   Normative Nepheline (Ne)
C   ************************
      IF (Ab.LT.(2.5*Q)) GOTO 600
      Ne=1.5*Q
      Ab=Ab-(2.5*Q)
      Q=0
      GOTO 660
600   Ne=0.6*Ab
      Q=Q-(0.4*Ab)
      Ab=0
C   Normative Leucite (Lc)
C   **********************
      IF (Or.LT.(5*Q)) GOTO 610
      Lc=4*Q
      Or=Or-(5*Q)
      Q=0
      GOTO 660
610   Lc=0.8*Or
      Q=Q-(0.2*Or)
      Or=0
C   Normative Kalsilite (Kl)
C   ************************
      IF (Lc.LT.(4*Q)) GOTO 620
      Kl=3*Q
      Lc=Lc-(4*Q)
      Q=0
      GOTO 660
620   Kl=0.75*Lc
      Q=Q-(0.25*Lc)
      Lc=0
C   Normative Ca-metasilicate (Cs)
C   ******************************
      IF (Wo.LT.(4*Q)) GOTO 630
      Cs=3*Q
      Wo=Wo-(4*Q)
      Q=0
      GOTO 660
630   Cs=0.75*Wo
      Q=Q-(0.25*Wo)
      Wo=0
      IF (Di.LT.(4*Q)) GOTO 640
      Cs=Cs+(1.5*Q)
      Ol=Ol+(1.5*Q)
      Di=Di-(4*Q)
      Q=0
      GOTO 660
640   Cs=Cs+(0.375*Di)
      Ol=Ol+(0.375*Di)
      Q=Q-(0.25*Di)
      Di=0
      WRITE(RESULT,650)Q
650   FORMAT(' Desilification incomplete, SiO2 Deff. =',F6.2)
660   IF (Q.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Q
      MINNAM(NMIN)='Q'
      END IF
      IF (C.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=C
      MINNAM(NMIN)='C'
      END IF
      IF (Or.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Or
      MINNAM(NMIN)='Or'
      END IF
      IF (Ab.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Ab
      MINNAM(NMIN)='Ab'
      END IF
      IF (An.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=An
      MINNAM(NMIN)='An'
      END IF
      IF (Ne.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Ne
      MINNAM(NMIN)='Ne'
      END IF
      IF (Lc.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Lc
      MINNAM(NMIN)='Lc'
      END IF
      IF (Bi.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Bi
      MINNAM(NMIN)='Bi'
      END IF
      IF (Mu.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Mu
      MINNAM(NMIN)='Mu'
      END IF
      IF (Wo.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Wo
      MINNAM(NMIN)='Wo'
      END IF
      IF (Ac.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Ac
      MINNAM(NMIN)='Ac'
      END IF
      IF (Di.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Di
      MINNAM(NMIN)='Di'
      END IF
      IF (Hy.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Hy
      MINNAM(NMIN)='Hy'
      END IF
      IF (Ol.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Ol
      MINNAM(NMIN)='Ol'
      END IF
      IF (Mt.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Mt
      MINNAM(NMIN)='Mt'
      END IF
      IF (Hm.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Hm
      MINNAM(NMIN)='Hm'
      END IF
      IF (Il.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Il
      MINNAM(NMIN)='Il'
      END IF
      IF (Tn.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Tn
      MINNAM(NMIN)='Tn'
      END IF
      IF (Ru.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Ru
      MINNAM(NMIN)='Ru'
      END IF
      IF (Pf.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Pf
      MINNAM(NMIN)='Pf'
      END IF
      IF (Z.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Z
      MINNAM(NMIN)='Z'
      END IF
      IF (Ap.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Ap
      MINNAM(NMIN)='Ap'
      END IF
      IF (Sp.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Sp
      MINNAM(NMIN)='Sp'
      END IF
      IF (Ct.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Ct
      MINNAM(NMIN)='Ct'
      END IF
      IF (Pr.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Pr
      MINNAM(NMIN)='Pr'
      END IF
      IF (Fr.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Fr
      MINNAM(NMIN)='Fr'
      END IF
      IF (Cc.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Cc
      MINNAM(NMIN)='Cc'
      END IF
      IF (Mon.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Mon
      MINNAM(NMIN)='Mon'
      END IF
      IF (Cm.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Cm
      MINNAM(NMIN)='Cm'
      END IF
      IF (Kl.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Kl
      MINNAM(NMIN)='Kl'
      END IF
      IF (Ks.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Ks
      MINNAM(NMIN)='Ks'
      END IF
      IF (Ns.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Ns
      MINNAM(NMIN)='Ns'
      END IF
      IF (Cs.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Cs
      MINNAM(NMIN)='Cs'
      END IF
      WRITE(RESULT,670)
670   FORMAT(/2X,' Q	   C	   Or      Ab	   An      Ne      Lc')
      WRITE(RESULT,680)Q,C,Or,Ab,An,Ne,Lc
680   FORMAT(7F8.3/)
      WRITE(RESULT,690)
690   FORMAT(//,2X,' Bi      Mu      Wo      Ac      Di      Hy')
      WRITE(RESULT,700)Bi,Mu,Wo,Ac,Di,Hy
700   FORMAT(6F8.3/)
      WRITE(RESULT,710)
710   FORMAT(//,2X,' Ol	   Mt      Hm      Il	   Tn	   Ru      Pf')
      WRITE(RESULT,720)Mt,Hm,Il,Tn,Ru,Pf
720   FORMAT(7F8.3/)
      WRITE(RESULT,730)
730   FORMAT(2X,' Sp      Ct      Pr      Fr      Cc      Ap      Z ')
      WRITE(RESULT,740)Sp,Ct,Pr,Fr,Cc,Ap,Z
740   FORMAT(7F8.3/)
      WRITE(RESULT,750)
750   FORMAT(2X,' Mon     Cm      Kl      Ks      Ns      Cs ')
      WRITE(RESULT,760)Mon,Cm,Kl,Ks,Ns,Cs
760   FORMAT(6F8.3)
C   FINAL SUMMARY
C   *****************************
      WRITE(RESULT,911)
911   FORMAT(//,27X,'     S U M M A R Y')
      WRITE(RESULT,912)
912   FORMAT(24X,'*****************************')
      WRITE(RESULT,1000)
      TOTAL=0
      TOTAL=Q+C+Or+Ab+An+Ne+Lc+Bi+Mu+Wo+Ac+Di+Hy+Ol+Mt+Hm+Il+Tn+Ru+Pf+Z+
     1 Sp+Ct+Pr+Fr+Cc+Ap+Mon+Cm+Kl+Ks+Ns+Cs
      WRITE(RESULT,914) (MINNAM(I),MINOUT(I), I=1,NMIN),'SUM:',TOTAL
914   FORMAT((' *',5(3X,A4,F7.3),' *'))
      WRITE(RESULT,1001)
1001  FORMAT(' *',70X,' *')
      IF (Di.GT.0) GOTO 780
      WRITE(RESULT,770)
770   FORMAT (' *',1X,' Diopside    =   0.0',49X,' *')
      GOTO 800
780   IX=0.5+(50*RATIO)/(RATIO+1)
      IY=50-IX
      WRITE(RESULT,790)Di,IX,IY
790   FORMAT (' *',1X,' Diopside    = ',F6.2,'   Wo( 50) En(',I3,') Fs(
     1',I3,')',21X,' *')
800   IF (Hy.GT.0) GOTO 820
      WRITE(RESULT,810)
810   FORMAT (' *',1X,' Hypersthene =   0.0',49X,' *')
      GOTO 840
820   IX=0.5+(100*RATIO)/(RATIO+1)
      IY=100-IX
      WRITE(RESULT,830)Hy,IX,IY
830   FORMAT (' *',1X,' Hypersthene = ',F6.2,'   En(',I3,') Fs(',I3,')
     1',28X,' *')
840   IF (Ol.GT.0) GOTO 860
      WRITE(RESULT,850)
850   FORMAT (' *',1X,' Olivine     =   0.0',49X,' *')
      GOTO 880
860   IX=0.5+(100*RATIO)/(RATIO+1)
      IY=100-IX
      WRITE(RESULT,870)Ol,IX,IY
870   FORMAT (' *',1X,' Olivine     = ',F6.2,'   Fo(',I3,') Fa(',I3,')
     1',28X,' *')
880   Plag=Ab+An
      IF (Plag.GT.0) GOTO 900
      WRITE(RESULT,890)
890   FORMAT (' *',1X,' Plagioclase =   0.0',49X,' *')
      GOTO 920
900   IX=(100*Ab)/(Plag+0.5)
      IY=100-IX
      WRITE(RESULT,910)Plag,IX,IY
910   FORMAT (' *',1X,' Plagioclase = ',F6.2,'   Ab(',I3,') An(',I3,
     1')',30X,' *')
      WRITE(RESULT,1001)
920   TOTAL=Q+Or+Plag
      IX=(100*Q)/(TOTAL+0.5)
      IY=(100*Or)/(TOTAL+0.5)
      IZ=100-(IX+IY)
      WRITE(RESULT,930)TOTAL,IX,IY,IZ
930   FORMAT (' *',1X,' Q  + Or + Plag =',F6.2,'  Q  (',I3,') Or (',I3,')
     1) Plag(',I3,')',17X,' *')
      TOTAL=0
      TOTAL=An+Ab+Or
      IX=(100*Ab)/(TOTAL+0.5)
      IY=(100*An)/(TOTAL+0.5)
      IZ=100-IX-IY
      WRITE(RESULT,940)TOTAL,IX,IY,IZ
940   FORMAT (' *',1X,' Ab + An + Or   =',F6.2,'  Ab (',I3,') An (',I3,')
     1) Or  (',I3,')',17X,' *')
      TOTAL=0
      TOTAL=Q+Ab+Or
      IX=(100*Q)/(TOTAL+0.5)
      IY=(100*Ab)/(TOTAL+0.5)
      IZ=100-(IX+IY)
      WRITE(RESULT,950)TOTAL,IX,IY,IZ
950   FORMAT (' *',1X,' Q  + Ab + Or   =',F6.2,'  Q  (',I3,') Ab (',I3,')
     1) Or  (',I3,')',17X,' *')
      WRITE(RESULT,1001)
C   DIFFERENTIATION INDEX (DI)
C   **************************
      DIF=(Q+Or+Ab+Ne+Lc+Ks)
      WRITE(RESULT,960)DIF
960   FORMAT (' *',1X,' Differentiation Index (DI) =',F6.2,34X,' *')
C   CRYSTALLIZATION INDEX (CI)
C   **************************
      CI=An+RATIO/(RATIO+1)*(Di+Ol+(0.75*Hy)+Sp)
      WRITE(RESULT,970)CI
970   FORMAT (' *',1X,' Crystallization Index (CI) =',F6.2,34X,' *')
C   SOLIDIFICATION INDEX (SI)
C   *************************
      SI=100*WTP(8)/(WTP(4)+WTP(5)+WTP(6)+WTP(7)+WTP(8)+WTP(12)+WTP(13))
      WRITE(RESULT,980)SI
980   FORMAT (' *',1X,' Solidification Index  (SI) =',F6.2,34X,' *')
C   ALKALINITY RATIO (AR)
C   *********************
      IF (WTP(1).GT.50) THEN
      IF (WTP(13)/WTP(12).GT.1.AND.WTP(13)/WTP(12).LT.2.5) GOTO 990
      A=WTP(3)+WTP(9)
      B=WTP(12)+WTP(13)+WTP(24)+WTP(30)+WTP(31)
      AR=(A+B)/(A-B)
990   B=2*WTP(12)
      AR=(A+B)/(A-B)
      WRITE(RESULT,999)AR
999   FORMAT (' *',1X,' Alkalinity Ratio      (AR) =',F6.2,34X,' *')
      END IF
      WRITE(RESULT,1001)
      WRITE(RESULT,1000)
      END
