C   *******************************************************************
C   * C.I.P.W.-Norm, FORTRAN 77, (05/02/1992)			      *
C   * This Program, calculates the C.I.P.W-norm of a sample from its  *
C   * chemical composition.   It incorporates modifications proposed  *
C   * by JOHANNSEN (1931); KELSEY (1965); HUTCHISON (1985); and own.  *
C   *******************************************************************
c$DEBUG
      INTEGER IN, OUT, REF, RESULT, OXOUT(35), NOXOUT, NMIN
      PARAMETER (IN=5, OUT=6, REF=9, RESULT=10)
      REAL MWV, MT, KS, NS, IL, LC, KL, NE, MON, MINOUT(40)
      CHARACTER*1 ANSWER
      CHARACTER*3 MINNAM(40)
      CHARACTER*5 OXIDE(35), TITLEX
      CHARACTER*30 NAME
      DIMENSION WTP(35), V(21), MWV(35), PROP(35)
C   OXIDE - ANALYSED OXIDE, MWV - MOLECULAR WEIGHTS
C   ***********************************************
      DATA OXIDE(1),MWV(1)/'SiO2 ',60.0843  /
      DATA OXIDE(2),MWV(2)/'TiO2 ',79.8788  /
      DATA OXIDE(3),MWV(3)/'Al2O3',101.96128/
      DATA OXIDE(4),MWV(4)/'Fe2O3',159.6922 /
      DATA OXIDE(5),MWV(5)/'FeO  ',71.8464  /
      DATA OXIDE(6),MWV(6)/'MnO  ',70.93745 /
      DATA OXIDE(7),MWV(7)/'NiO  ',74.6894  /
      DATA OXIDE(8),MWV(8)/'MgO  ',40.3044  /
      DATA OXIDE(9),MWV(9)/'CaO  ',56.0774  /
      DATA OXIDE(10),MWV(10)/'BaO  ',153.3264 /
      DATA OXIDE(11),MWV(11)/'SrO  ',103.6194 /
      DATA OXIDE(12),MWV(12)/'Na2O ',61.978936/
      DATA OXIDE(13),MWV(13)/'K2O  ',94.196   /
      DATA OXIDE(14),MWV(14)/'P2O5 ',141.94452/
      DATA OXIDE(15),MWV(15)/'F-   ',18.998403/
      DATA OXIDE(16),MWV(16)/'Cl-  ',35.4527  /
      DATA OXIDE(17),MWV(17)/'S    ',32.066   /
      DATA OXIDE(18),MWV(18)/'CO2  ',44.0098  /
      DATA OXIDE(19),MWV(19)/'ZrO2 ',123.2228 /
      DATA OXIDE(20),MWV(20)/'SnO2 ',150.7088 /
      DATA OXIDE(21),MWV(21)/'Cr2O3',151.9904 /
      DATA OXIDE(22),MWV(22)/'CuO  ',79.5454  /
      DATA OXIDE(23),MWV(23)/'ZnO  ',81.3894  /
      DATA OXIDE(24),MWV(24)/'Li2O ',29.8814  /
      DATA OXIDE(25),MWV(25)/'SO3  ',80.0642  /
      DATA OXIDE(26),MWV(26)/'H2O+ ',18.01528 /
      DATA OXIDE(27),MWV(27)/'H2O- ',18.01528 /
      DATA OXIDE(28),MWV(28)/'V2O3 ',149.8812 /
      DATA OXIDE(29),MWV(29)/'CoO  ',74.9326  /
      DATA OXIDE(30),MWV(30)/'Rb2O ',186.935  /
      DATA OXIDE(31),MWV(31)/'Cs2O ',281.81026/
      DATA OXIDE(32),MWV(32)/'HfO2 ',210.4888 /
      DATA OXIDE(33),MWV(33)/'Y2O3 ',225.8099 /
      DATA OXIDE(34),MWV(34)/'Ce2O3',328.2982 /
      DATA OXIDE(35),MWV(35)/'La2O3',325.8092 /
      DO 1 K=1,35
1     CONTINUE
      SUM=0.0
      SUM1=0.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.4)')
      DO 5 IJ=1,NUM
2     READ(IN,60)TITLEX,WTPER
60    FORMAT(A,F8.4)
      DO 3 I=1,35
      NUMCOM=I
      IF (TITLEX.EQ.OXIDE(I)) GOTO 4
3     CONTINUE
      WRITE(OUT,70)TITLEX
70    FORMAT(10X,' NO compound called',A,' in the 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
      OPEN(UNIT=RESULT, FILE='CIPW.OUT')
      WRITE(RESULT,100)NAME
100   FORMAT(/,2X,' S A M P L E: ',A)
      WRITE(RESULT,1000)
1000  FORMAT(1X,73('*'))
      WRITE(RESULT,110)
110   FORMAT(3X,'OXIDES',4X,'wt-%',4X,'OXIDES',4X,'wt-%',4X,'OXIDES',
     1 4X,'wt-%',4X,'OXIDES',4X,'wt-%',/)
      NOXOUT=0
      DO 6 IJ=1,35
      IF (WTP(IJ).NE.0.0) THEN
      NOXOUT=NOXOUT+1
      OXOUT(NOXOUT)=IJ
      ENDIF
6     CONTINUE
      WRITE(RESULT,120) (OXIDE(OXOUT(I)),WTP(OXOUT(I)), I=1,NOXOUT)
120   FORMAT(3X,A,F9.3,4X,A,F9.3,4X,A,F9.3,4X,A,F9.3)
      WRITE(RESULT,130)SUM1
130   FORMAT(/,2X,6H TOTAL,F9.3)
      WRITE(RESULT,140)
140   FORMAT (/,3X,'C I P W  -  N O R M        C O M P L E T E   D A T A
     1	  O U T P U T')
      WRITE(RESULT,1000)
      DO 7 IJ=1,35
7     CONTINUE
      DO 8 I=1,35
      PROP(I)=WTP(I)/MWV(I)
8     CONTINUE
      IF (PROP(25).GT.0.0) THEN
      PROP(17)=PROP(25)*0.4005035959
      END IF
C   ********************************
C   V - Values
C   **********
      V(1)=PROP(1)
C   V(1)=SiO2
      V(2)=PROP(2)
C   V(2)=TiO2
      V(3)=PROP(3)
C   V(3)=Al2O3
      V(4)=PROP(4)+PROP(28)
C   V(4)=Fe2O3 + V2O3
      V(5)=PROP(5)+PROP(7)+PROP(29)
C   V(5)=FeO + NiO + CoO
      V(6)=PROP(8)+PROP(24)
C   V(6)=MgO + Li2O
      V(7)=PROP(9)
C   V(7)=CaO
      V(8)=PROP(12)
C   V(8)=Na2O
      V(9)=PROP(13)+PROP(30)+PROP(31)
C   V(9)=K2O + Rb2O + Cs2O
      V(10)=PROP(14)
C   V(10)=P2O5
      V(11)=PROP(15)+PROP(16)
C   V(11)=F- + Cl-
      V(12)=PROP(17)
C   V(12)=S
      V(13)=PROP(18)
C   V(13)=CO2
      V(14)=PROP(19)+PROP(32)
C   V(14)=ZrO2 + HfO2
      V(15)=PROP(20)
C   V(15)=SnO2
      V(16)=PROP(21)
C   V(16)=Cr2O3
      V(17)=PROP(26)
C   V(17)=H2O+
      V(18)=PROP(27)
C   V(18)=H2O-
      V(19)=PROP(33)+PROP(34)+PROP(35)
C   V(19)=Y2O3 + Ce2O3 + La2O3
      V(20)=PROP(10)+PROP(11)
C   V(20)=BaO+SrO
C   *************************************
C   *	  CIPW NORM CALCULATIONS	*
C   *************************************
C   Normative Cassiterite (Ct)
C   **************************
      Ct=V(15)
C   Normative Zircon (Z)
C   ********************
      Z= V(14)
      Y=Z
C   Normative Monacite (Mon)
C   ************************
      IF (V(19).GT.V(10)) GOTO 200
      Mon=V(19)
      V(10)=V(10)-Mon
      V(19)=0
      GOTO 210
200   Mon=V(10)
      V(19)=V(19)-Mon
      V(10)=0
C   Normative Apatite (Ap).  V(7) = CaO only
C   ****************************************
210   IF (V(7).GE.((10./3.)*V(10))) GOTO 230
      Ap=0.3*V(7)
      V(10)=V(10)-Ap
      V(7)=0
      EXCESS1 = V(10)*141.944524
      WRITE(RESULT,220)EXCESS1
220   FORMAT(/'Insufficient Ca for Apatite, Excess P2O5 = ',F6.3)
      GOTO 240
230   Ap=V(10)
      V(7)=V(7)-((10./3.)*Ap)
240   IF (V(11).GE.((2./3.)*Ap)) GOTO 250
      V(11)=0
      GOTO 260
250   V(11)=V(11)-((2./3.)*Ap)
C   Normative Fluorite (Fr).  V(7) = CaO only
C   *****************************************
260   IF (V(11).GT.(2*V(7))) GOTO 270
      Fr=0.5*V(11)
      V(7)=V(7)-Fr
      GOTO 290
270   Fr=V(7)
      V(11)=V(11)-(2*Fr)
      V(7)=0
      EXCESS2=V(11)*18.9984032
      WRITE(RESULT,280)EXCESS2
280   FORMAT(/'Insufficient Ca for Fluorine, Excess F- = ',F6.3)
C   Normative Pyrite (Pr)
C   ********************************************************
C   V(5)=FeO+NiO+CoO only.  MnO is added later, after the  *
C   calculation of Pyrite as Pyrite does not contain any MnO
C   ********************************************************
290   IF (V(12).GT.(2*V(5))) GOTO 300
      Pr=0.5*V(12)
      V(5)=V(5)-Pr
      GOTO 320
300   Pr=V(5)
      V(12)=V(12)-(2*Pr)
      V(5)=0
      EXCESS5=V(12)*32.066
      WRITE(RESULT,310)EXCESS5
310   FORMAT(/'Insufficient FeO for Pyrite, Excess S = ',F6.3)
C   Normative Calcite (Cc).  CaO*CO2
C   ********************************
320   V(7)=V(7)+V(20)
      IF (V(13).GT.V(7)) GOTO 330
      Cc=V(13)
      V(7)=V(7)-Cc
      V(13)=0
      GOTO 340
330   Do=V(13)
      V(7)=V(7)-(0.5*Do)
      V(6)=V(6)-(0.5*Do)
C   Normative Chromite (Cm)
C   ***********************
340   V(5)=V(5)+PROP(6)
      IF (V(16).GT.V(5)) GOTO 350
      Cm=V(16)
      V(5)=V(5)-Cm
      GOTO 360
350   Cm=V(5)
      V(16)=V(16)-Cm
      V(5)=0
C   Normative Ilmenite (Il)
C   ***********************
360   IF (V(5).GT.V(2)) GOTO 370
      Il=V(5)
      V(2)=V(2)-Il
      V(5)=0
      GOTO 380
370   Il=V(2)
      V(5)=V(5)-Il
      V(2)=0
C   Normative Orthoclase (Or)
C   *************************
380   IF (V(3).GE.V(9)) GOTO 390
      Or=V(3)
      V(9)=V(9)-Or
      V(3)=0
C   Normative K-Metasilicate (Ks)
C   *****************************
      Ks=V(9)
      Y=Y+(6*Or)+Ks
      GOTO 400
390   Or=V(9)
      V(3)=V(3)-Or
      Y=Y+6*Or
C   Normative Albite (Ab)
C   *********************
400   IF (V(3).GE.V(8)) GOTO 410
      Ab=V(3)
      V(8)=V(8)-Ab
      V(3)=0
      Y=Y+(6*Ab)
      GOTO 420
410   Ab=V(8)
      V(3)=V(3)-Ab
      V(8)=0
      Y=Y+(6*Ab)
C   Normative Acmite (Ac)
C   *********************
420   IF (V(8).GT.V(4)) GOTO 430
      Ac=V(8)
      V(4)=V(4)-Ac
      Y=Y+(4*Ac)
      GOTO 440
430   Ac=V(4)
      V(8)=V(8)-Ac
      V(4)=0
C   Normative Na-Metasilicate (Ns)
C   ******************************
      Ns=V(8)
      Y=Y+((4*Ac)+Ns)
C   Normative Anorthite (An)
C   ************************
440   IF (V(3).GT.V(7)) GOTO 450
      An=V(3)
      V(7)=V(7)-An
      Y=Y+(2*An)
      GOTO 460
450   An=V(7)
      V(3)=V(3)-An
      V(7)=0
      Y=Y+(2*An)
C   Normative Corundum (C)
C   **********************
      C=V(3)
C   Normative Sphene (Tn) and Rutile (Ru)
C   *************************************
460   IF(V(7).GT.V(2)) GOTO 470
      Tn=V(7)
      V(2)=V(2)-Tn
      V(7)=0
      Ru=V(2)
      Y=Y+Tn
      GOTO 480
470   Tn=V(2)
      V(7)=V(7)-Tn
      Y=Y+Tn
C   Normative Magnetite (Mt)
C   ************************
      V(4)=V(4)+V(16)
480   IF (V(4).GT.V(5)) GOTO 490
      Mt=V(4)
      V(5)=V(5)-Mt
      GOTO 500
490   Mt=V(5)
      V(4)=V(4)-Mt
      V(5)=0
C   Normative Hematite (Hm)
C   ***********************
      Hm=V(4)
C   Normative Spinel (Sp) and Herzynite (Her)
C   *****************************************
500   SUM=V(6)+V(5)
      RMg=V(6)/(SUM+0.0000000001)
      RFe=V(5)/(SUM+0.0000000001)
      IF (WTP(1).GE.45) GOTO 520
      IF (SUM.GE.C) GOTO 510
      Sp=RMg*SUM
      Her=RFe*SUM
      C=C-(Sp+Her)
      SUM=0
      GOTO 520
510   Sp=RMg*C
      Her=RFe*C
      SUM=SUM-(Sp+Her)
      C=0
C   Normative Diopside (Dio, Hed), Hypersthene (En, Fs) and
C   ******************************************************
C   Wollastonite (Wo)
C   *****************
520   IF (V(7).GT.SUM) GOTO 530
      Dio=RMg*V(7)
      Hed=RFe*V(7)
      SUM=SUM-(Dio+Hed)
      En=RMg*SUM
      Fs=RFe*SUM
      Y=Y+(2*(Dio+Hed))+En+Fs
      GOTO 540
530   Dio=RMg*SUM
      Hed=RFe*SUM
      V(7)=V(7)-(Dio+Hed)
      Wo=V(7)
      Y=Y+((2*(Dio+Hed))+Wo)
C   Checking Normative Silica (Q)
C   *****************************
540   IF (Y.GT.V(1)) GOTO 550
      Q=V(1)-Y
      GOTO 650
550   Q=0
      D=Y-V(1)
C   Recalculating Normative Olivine (Fo,Fa) and Hypersthene (En,Fs)
C   ***************************************************************
      IF (D.GT.(0.5*(En+Fs))) GOTO 560
      Fo=RMg*D
      Fa=RFe*D
      En=En-(2*Fo)
      Fs=Fs-(2*Fa)
      GOTO 650
560   Fo=0.5*En
      Fa=0.5*Fs
      D=D-(0.5*(En+Fs))
      En=0
      Fs=0
C   Recalculating Normative Sphene (Tn) and Perovskite (Pf).
C   ********************************************************
      IF (D.GT.Tn) GOTO 570
      Tn=Tn-D
      Pf=D
      GOTO 650
570   Pf=Tn
      D=D-Tn
      Tn=0
C   Recalculating Normative Nepheline (Ne) and Albite (Ab).
C   *******************************************************
      IF (D.GT.4*Ab) GOTO 590
      Ne=0.25*D
      Ab=Ab-(0.25*D)
      GOTO 650
590   Ne=Ab
      D=D-(4*Ab)
      Ab=0
C   Recalculating Normative Leucite (Lc) and Orthoclase (Or).
C   *********************************************************
      IF (D.GT.(2*Or)) GOTO 600
      Lc=0.5*D
      Or=Or-(0.5*D)
      GOTO 650
600   Lc=Or
      D=D-(2*Or)
      Or=0
C   Recalculating Normative Di-Calcium Silicate (Cs), Olivine (Fo, Fa)
C   and Diopside (Dio, Hed).
C   *****************************************************************
      IF (D.GT.(0.5*Wo)) GOTO 610
      Cs=D
      Wo=Wo-(2*D)
      GOTO 650
610   Cs=0.5*Wo
      D=D-(0.5*Wo)
      Wo=0
      IF(D.GT.(Dio+Hed)) GOTO 620
      Cs=Cs+0.5*D
      Fo=Fo+((0.5*D)*RMg)
      Fa=Fa+((0.5*D)*RFe)
      Dio=Dio-(D*RMg)
      Hed=Hed-(D*RFe)
      GOTO 650
620   Cs=Cs+(0.5*(Dio+Hed))
      Fo=Fo+(0.5*Dio)
      Fa=Fa+(0.5*Hed)
      D=D-(Dio+Hed)
      Dio=0
      Hed=0
      IF(D.GT.(2*Lc)) GOTO 630
C   Normative Kaliophyllite (Kl)
C   ****************************
      Kl=0.5*D
      Lc=Lc-(0.5*D)
      GOTO 650
630   Kl=Lc
      D=D-(2*Lc)
      Lc=0
      EXCESS7=D*60.0843
      WRITE(RESULT,640)EXCESS7
640   FORMAT(/2X,'Desilification incomplete, SiO2 Deff. = ',F6.3)
650   CONTINUE
      NMIN=0
      Q=Q*60.0843
      IF (Q.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Q
       MINNAM(NMIN)='Q'
      ENDIF
      C=C*101.961278
      IF (C.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=C
       MINNAM(NMIN)='C'
      END IF
      Or=Or*556.66307
      IF (Or.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Or
       MINNAM(NMIN)='Or'
      END IF
      Ab=Ab*524.446
      IF (Ab.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Ab
       MINNAM(NMIN)='Ab'
      END IF
      An=An*278.20727
      IF (An.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=An
       MINNAM(NMIN)='An'
      END IF
      Ne=Ne*284.1088
      IF (Ne.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Ne
       MINNAM(NMIN)='Ne'
      END IF
      Lc=Lc*436.49447
      IF (Lc.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Lc
       MINNAM(NMIN)='Lc'
      END IF
      Kl=Kl*316.32587
      IF (Kl.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Kl
       MINNAM(NMIN)='Kl'
      END IF
      Ac=Ac*462.00833
      IF (Ac.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Ac
       MINNAM(NMIN)='Ac'
      END IF
      Wo=Wo*116.1617
      IF (Wo.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Wo
       MINNAM(NMIN)='Wo'
      END IF
      Dio=Dio*216.5504
      Hed=Hed*248.0924
      Di=Dio+Hed
      IF (Di.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Di
       MINNAM(NMIN)='Di'
      END IF
      En=En*100.3887
      Fs=Fs*131.9307
      Hyp=En+Fs
      IF (Hyp.GT.0) THEN
      NMIN=NMIN+1
      MINOUT(NMIN)=Hyp
      MINNAM(NMIN)='Hyp'
      END IF
      Fo=Fo*140.6931
      Fa=Fa*203.7771
      Ol=Fo+Fa
      IF (Ol.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Ol
       MINNAM(NMIN)='Ol'
      END IF
      Ap=Ap*341.53478
      IF (Ap.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Ap
       MINNAM(NMIN)='Ap'
      END IF
      Z=Z*183.3071
      IF (Z.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Z
       MINNAM(NMIN)='Z'
      END IF
      Mt=Mt*231.5386
      IF (Mt.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Mt
       MINNAM(NMIN)='Mt'
      END IF
      Hm=Hm*159.6922
      IF (Hm.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Hm
       MINNAM(NMIN)='Hm'
      END IF
      Il=Il*151.7252
      IF (Il.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Il
       MINNAM(NMIN)='Il'
      END IF
      Tn=Tn*196.0405
      IF (Tn.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Tn
       MINNAM(NMIN)='Tn'
      END IF
      Cm=Cm*223.8368
      IF (Cm.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Cm
       MINNAM(NMIN)='Cm'
      END IF
      Sp=Sp*142.26567
      IF (Sp.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Sp
       MINNAM(NMIN)='Sp'
      END IF
      Her=Her*173.80767
      IF (Her.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Her
       MINNAM(NMIN)='Her'
      END IF
      Ru=Ru*79.8788
      IF (Ru.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Ru
       MINNAM(NMIN)='Ru'
      END IF
      Pf=Pf*135.9562
      IF (Pf.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Pf
       MINNAM(NMIN)='Pf'
      END IF
      Ct=Ct*150.7088
      IF (Ct.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Ct
       MINNAM(NMIN)='Ct'
      END IF
      Mon=Mon*235.12136
      IF (Mon.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Mon
       MINNAM(NMIN)='Mon'
      END IF
      Fr=Fr*94.074206
      IF (Fr.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Fr
       MINNAM(NMIN)='Fr'
      END IF
      Pr=Pr*119.979
      IF (Pr.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Pr
       MINNAM(NMIN)='Pr'
      END IF
      Cc=Cc*100.0872
      IF (Cc.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Cc
       MINNAM(NMIN)='Cc'
      END IF
      Do=Do*92.2007
      IF (Do.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Do
       MINNAM(NMIN)='Do'
      END IF
      Ks=Ks*154.2803
      IF (Ks.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Ks
       MINNAM(NMIN)='Ks'
      END IF
      Ns=Ns*122.06323
      IF (Ns.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Ns
       MINNAM(NMIN)='Ns'
      END IF
      Cs=Cs*172.2391
      IF (Cs.GT.0) THEN
       NMIN=NMIN+1
       MINOUT(NMIN)=Cs
       MINNAM(NMIN)='Cs'
      END IF
      W1=WTP(26)
      W2=WTP(27)
      W3=W1+W2
      WRITE(RESULT,660)
660   FORMAT(/2X,' Q	   C       Or      Ab      An      Ne      Lc'
     1,6X,'Kl')
      WRITE(RESULT,670)Q,C,Or,Ab,An,Ne,Lc,Kl
670   FORMAT(8F8.3)
      WRITE(RESULT,680)
680   FORMAT (//2X,' Ac      Wo')
      WRITE(RESULT,690)Ac,Wo
690   FORMAT(2F8.3)
      WRITE(RESULT,700)
700   FORMAT(/2X,' Dio	   Hed	    (Di) DIOPSIDE ')
      WRITE(RESULT,720)Dio,Hed,Di
      WRITE(RESULT,710)
710   FORMAT(/2X,' En      Fs       (Hy) HYPERSTHENE')
      WRITE(RESULT,720)En,Fs,Hyp
720   FORMAT(2F8.3,F11.3)
      WRITE(RESULT,730)
730   FORMAT(/2X,' Fo	   Fa	    (Ol) OLIVINE')
      WRITE(RESULT,720)Fo,Fa,Ol
      WRITE(RESULT,740)
740   FORMAT(//2X,' Ap      Z       Mt	    Hm      Il	    Tn      Cm
     1 ')
      WRITE(RESULT,750)Ap,Z,Mt,Hm,Il,Tn,Cm
750   FORMAT(7F8.3)
      WRITE(RESULT,760)
760   FORMAT(/2X,' Sp      Her     Ru      Pf      Ct      Mon     Fr'
     1)
      WRITE(RESULT,770)Sp,Her,Ru,Pf,Ct,Mon,Fr
770   FORMAT(7F8.3)
      WRITE(RESULT,790)
790   FORMAT(/2X,' Pr      Cc      Do      Ks      Ns 	   Cs')
      WRITE(RESULT,800)Pr,Cc,Do,Ks,Ns,Cs
800   FORMAT(6F8.3)
      WRITE(RESULT,810)
810   FORMAT(/'  WATER',4X,' H2O+    H2O-     TOTAL')
      WRITE(RESULT,820)W1,W2,W3
820   FORMAT(7X,2F8.2,F10.2)
C   FINAL SUMMARY
C   *************
      WRITE(RESULT,830)
830   FORMAT(//,27X,'     S U M M A R Y    ')
      WRITE(RESULT,840)
840   FORMAT(24X,'*****************************')
      WRITE(RESULT,1000)
      TOTAL=0
      TOTAL=Q+C+Or+Ab+An+Ne+Lc+Kl+Ac+Wo+Di+Hyp+Ol+Ap+Z+Mt+Hm+Il+Tn+Cm+
     1 Sp+Her+Ru+Pf+Ct+Mon+Fr+Pr+Cc+Do+Ks+Ns+Cs
      WRITE(RESULT,850) (MINNAM(I),MINOUT(I), I=1,NMIN),'SUM:',TOTAL
850   FORMAT((' *',5(3X,A3,F7.3),5X,' *'))
C      WRITE(RESULT,845)TOTAL
C  845	FORMAT (' *',2X,' Total   = ',F7.3,53X,' *')
      WRITE(RESULT,860)
860   FORMAT(' *',70X,' *')
      WRITE(RESULT,860)
C   DIFFERENTIATION INDEX (DI)
C   **************************
      DIF=Q+Or+Ab+Ne+Lc+Ks
      WRITE(RESULT,870)DIF
870   FORMAT (' *',1X,(' Differentiation Index (DI) =',F6.3),34X,' *')
C   CRYSTALLIZATION INDEX (CI)
C   **************************
      CI=An+Di+Fo+(0.700837*En)+Sp
      WRITE(RESULT,880)CI
880   FORMAT (' *',1X,(' Crystallization Index (CI) =',F6.3),34X,' *')
C   SOLIDIFICATION INDEX (SI)
C   *************************
      SI=100*WTP(8)/(WTP(4)+WTP(5)+WTP(8)+WTP(12)+WTP(13))
      WRITE(RESULT,890)SI
890   FORMAT (' *',1X,(' Solidification Index  (SI) =',F6.3),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 900
      A=WTP(3)+WTP(9)
      B=WTP(12)+WTP(13)+WTP(24)+WTP(30)+WTP(31)
      AR=(A+B)/(A-B)
900   B=2*WTP(12)
      AR=(A+B)/(A-B)
      WRITE(RESULT,910)AR
910   FORMAT (' *',1X,' Alkalinity Ratio      (AR) =',F6.3,34X,' *')
      END IF
      WRITE(RESULT,860)
      WRITE(RESULT,1000)
      END
