Journal Name: Mathematical Geosciences

Article Title: CIPWFULL: A Software Program for Calculation of Comprehensive CIPW Norms of Igneous Rocks

Journal Name: Mathematical Geosciences

Author Name: ALI T. AL-MISHWAT

Affiliation: DEPARTMENT OF EARTH AND ENVIRONMENTAL SCIENCES, KUWAIT UNIVERSITY,

P.O.BOX 5969 – SAFAT, 13060- KUWAIT

E-mail:

!======

PROGRAM CIPWFULL

!

! ALI THEYAB AL-MISHWAT

! DEPARTMENT OF EARTH AND ENVIRONMENTAL SCIENCES

! KUWAIT UNIVERSITY

! P. O. BOX 5969 -SAFAT

! KUWAIT - 13060

!

! E-MAIL: OR

!

! CREATED JUNE 22, 1977 - LAST REVISION OCTOBER 31,2013

!======

! THIS IS A STANDALONE PROGRAM. INPUT OF ELEMEENTS AND OXIDES IS USER-DEFINED.

! PROGRAM WILL CAST INTO CIPW SEQUENCE.

!======

! WHICH SAMPLE HAS OXIDATION CORRECTION

! NEED TO OVERRIDE SPSH FILE????p

! rock suites NOW 20 CHARACTER LONG, ADD TO 40 LATER-IGBA

! calculate and SHOW oxidation ratio ONLY for 1-IRON rocks

! spsh: show NOR.FAC AND NOR.TOTAL ONLY WHEN NORMALIZATION IS REQUIRED

! F IS ASSUMED TO GO ONLY IN FLUORIDE FORMATION; NONE IN APATITE.

! THENARDITE (NA2O.SO3))IS NOT CREATED IN CIPWFULL, BUT KEPT FOR COMPLETION PURPOSES.

! (HUAYNE MINERALS ARE EXTREMLY RARE!). IT MAY BE INCLUDED IN PROGRAM IF FUTURE NEEDS

! WARRANT IT!).

! DECEMBER 2012-WITH SPSH OPTION ONLY

! FIX TOTAL/NORMALIZATION (?) AFTER CONVERTING TRACE TO % AND ADDITION TO MAJORS. !!!!!

! WHAT IF CO2>CAO?-RARE, BUT STILL DEAL WITH IT

! STILL VERIFY APATITE CALCULATIONS !!!!!!!!!!!

!======

! PLOTTING (TRNGL & CARTEX) FROZEN NOW. A FUTURE PROJECT.

! ALLOW FOR OXIDATION AND NORMALIZATION OPTIONS

!======

! NOV 3,2005

! REMAIN CHECKING: ALKALINE,PERALKALINE ??SHOULD BE BEFORE NORMALIZATION

! CHECK NORM.FACT. & OXID. RAT. NUMBERS

!======

! MAJOR-MINOR-TOTAL-NORALIZATION-OXIDATION (NO DIFFERENCE IF OXIDATION BEFORE)!

!======55===

! OUTPUT 2 FILES: 1) RESULT FLAT TEXT FILE AND , 3)ERROR AND INCONSISTANCY FILE

! 2)SPREADSHEET FILE

!======

! PERALKALINE: AL2O3<NA2O+K2O)-MOLAR

! PERALUMINOUS: AL2O3>(CAO+NA2O+K2O)-MOLAR

! METALUMINOUS: AL2O3<(CAO+NA2O+K2O) & AL2O3>NA2O+K2O)-MOLAR

!======

! THE SPECIES F,CL AND S ARE FED AS FP, CP AND SP IF THEY ARE FED AS PPM.

!======

! INPUT SEQUENCE OF ELEMENTS:

! F AS F IF IN WT% OR FP IF IN PPM

! CL AS CL IF WT% OR AS CP IF IN PPM

! THESE TWO ELEMENTS AR SPECIAL CASES

!======

C PARSLOW'S SCHEME(MIN. MAG.,VOL. 37,P.262-269) IS NO LONGER AN OPTION FOR GRANITIC ROCKS.

C BIOTITE IS CALCULATED IN THE NORM ASSUMING THE AVERAGE FORMULA

C K2O-1/2TIO2-1/2MGO-5FEO-6SIO2-AL2O3 - REMOVED FROM CALCULATION

C WHICH GIVES A MOLECULAR WEIGHT OF 652.74 FOR NORMATIVE BIOTITE.

! BIOTITE HAS BEEN DISABLED IN CIPWFULL.FOR.

!======

IMPLICIT NONE

!======

INTERFACE

SUBROUTINE TRNGL(X,LABEL,THR,NOSMPL,IFULL,MARK,LABL,NUM)

END SUBROUTINE TRNGL

SUBROUTINE CARTES(SUMY1,SUMY2,NOSMPL,MARK,IFULL,LABL,NUM)

END SUBROUTINE CARTES

END INTERFACE

!======

! IEL = NUMBER OF ELMENTS PERMITTED INTO CIPW CALCULATIONS (33)

! ICL = NUMBER OF COMPONENTS ACTUALLY INVOLVED IN CIPW SEQUENCE (22)

! MARK = PLOTTING SYMBOLS

INTEGER,

1PARAMETER :: KYN=50000,LMT=80,IEL=33 !IEL=NUMBER OF ELEMENTS IN CIPW SEQUENCE

INTEGER :: I,J,K,L,N,NOELEM,MARK(KYN),IRANK,LRG, !FOXC(KYN)

1 ISTR,ERLM,ERLM1,NGNR,ANM,

1 KO,JO,ME,NOSMPL,ICRM,NUM,NPOT,MPTOX(KYN),ICAN,JM,ER,

2 NOOX(KYN),NOSP,CS,NRML !IFULL,JKLNM, 0/1 FOR NORMALIZATION

INTEGER :: NSOD,NMAG,NFRC,NCAL,NSIL,NFRS,KDBG,ICN(KYN),OUTPUT,

1FK,FKK,KKK,KEEPR(1000),MNKL,KF !,OXD - IBAN=0(cipw),=1(igba)

REAL,

1PARAMETER :: PPMTOPER=10000.0 ! PPM TO % (10000 PPM=1 %)

REAL :: SUMY1(KYN),DFI(KYN),SUMY2(KYN),X11,X22,X33,APS(KYN)

REAL :: SMRY,TOT,SI,TEMPASS,ABABAN(KYN),EMGNUM(KYN),

1 SOLAF,AGPC(KYN),SAKN(KYN,3),RHT(KYN,3),

2 RG(KYN,3),GR(KYN,3),CI(KYN,IEL),TTL(KYN),

3 S1,S2,S3,SUMY,SS1,SS2,SS3,NRMFAC(KYN),

4 ANATTL(KYN) !ANATTL=ELEMENT TOTAL-'MINORS' IN

REAL :: WT(KYN,IEL),WTWT(KYN,IEL),WMT(IEL),TIR,TOR,

1 C(KYN,32),A(KYN,IEL),RATIO(KYN),AA(KYN,32),

2 ATFM(32),X(KYN,3),Y(KYN,3),OXRAT(KYN),

3 O5O5,ASPS(KYN,32),AAA(KYN,32),SURP1(1000),AP(KYN)

CHARACTER :: SPL(KYN)*8,NM(KYN)*4,SMP0(KYN)*8

CHARACTER :: OXIDE(IEL)*5,NAME(32)*4,

1 TITLE(IEL)*5,ALALK(KYN)*12,ALUMIN(4)*12,

2 NAM(32)*4,THR(3)*4,SAMPLE(KYN)*8,

3 YN*1,ELMIDE(22)*5,ELMIDY(22)*5,

4 CARDY*120,NAMEY(32)*4,VP(KYN)*1,T*1,

5 JOBTITL*120 !TITLE OF JOB

! ELMIDY RETAINED FOR OUTPUT LISTING OF ELEMENTS

! VP: V OR P FOR EACH ROCK-FOR OXIDATION CORRECTION, WHEN NEEDED.

!======

! CHARACTER LABL(KYN,2)*3,LABEL(20)*4

!======

CHARACTER

1(LEN=LMT) :: CARD,DRAC,DRAC3,DATAFILE

CHARACTER :: SAM1(1000)*8,ELM1(1000)*5,MIN1(1000)*10

CHARACTER :: RGP(1000)*20,SUITE(KYN)*20 ! MAKE 40 LATER - IGBA

COMMON/RG/RGP !RGP- ROCK SUITES (BY NUMBER-1000)

COMMON/INCONS/SAM1,ELM1,MIN1,SURP1

COMMON/ANOM/ANM

COMMON/MONA/SMP0,APS

COMMON/ISTR/ISTR

COMMON/NEGN/SPL,NM,AP

COMMON/KNG/NGNR

COMMON/SNT/DRAC,DATAFILE

COMMON/KDBG1/KDBG

COMMON/FEFE/L,C

COMMON/DRAC3/DRAC3

COMMON/OUTPUT/OUTPUT

COMMON/KALL/KEEPR,MNKL,KF,KKK,FKK,FK

DATA NAME/' QZ',' COR',' ZR',' OR',' AB',' AN',' LC',

*' NP',' KP',' HA',' THN','NACR',' AC','NAMT','KMTA',

*' DI',' WO',' HY',' OL','CAOR',' MG',' CR',' HM',

*' IL',' SP',' PV',' RT',' AP',' FL',' PY',' CC',

*' BI'/

! RB2O(186.96) & RB(85.48) ADDED FEB 15,2007

DATA WMT/60.09,101.96,79.90,71.85,159.70,40.32,70.94,56.08,61.98,

*94.20,141.95,153.36,103.63,19.,35.457,32.066,44.01,123.22,152.02,

*29.88,74.71,

*137.36,87.62,80.066,91.22,52.01,6.94,58.71,

*19.00,35.457,186.96,85.48,32.066/

! FOR FP & CP AND SP AS PPM - WATCH

DATA ATFM/60.09,101.96,183.3,556.64,524.42,278.20,436.48,284.10,

*316.32,58.44,142.04,105.99,461.99,122.06,154.28,216.55,116.16,

*100.39,140.7,172.24,231.54,223.84,159.69,151.75,196.06,135.98,

*79.90,336.21,78.08,119.98,100.09,652.74/

!======

DATA ALUMIN/'PERALUMINOUS','METALUMINOUS','SUBALUMINOUS',

1'PERALKALINE ' /

!======

! BELOW IS THE REQUISITE ELEMENT SEQUENCE BEFORE CALCULATION OF CIPW.

DATA TITLE/' SIO2','AL2O3',' TIO2',' FEO','FE2O3',' MGO',

*' MNO',' CAO', ' NA2O',' K2O',' P2O5',' BAO',' SRO',' F',

*' CL',' S',' CO2',' ZRO2','CR2O3',' LI2O',' NIO',' BA',

*' SR',' SO3',' ZR',' CR',' LI',' NI',' FP',' CP',

*' RB2O',' RB',' SP'/

!98(F=19.00),97(CL=35.457),96(S=32.066)

! SI(28.09),AL(26.98),TI(47.90),FE2(55.85),FE3(55.85),MG(24.32),MN(54.94),

! CA(40.08),NA(22.991),K(39.100),P(30.975),BA(137.36),SR(87.63),F(19.00),

! CL(35.457),S(32.066),C(12.011),ZR(91.22),CR(52.01),LI(6.940),NI(58.71),

! RB(85.48)

! MG/MGO=24.32/40.32=0.6032

! FE2/FEO=55.85/71.85=0.7773

! FE3/FE2O3=55.85 X 2/159.70=0.6994

! MN/MNO=54.94/70.94=0.7745

! DATA OTFLNM/1/ !0=IGBA-GROUP INPUT FILES, 1=NON-IGBA FILES

!======

! START COMMANDS

!======

! WRITE BANNER

! CALL CLRPAG

!======

! PAUSE 'BEFORE CALL SCREENBANNER'

CALL SCREENBANNER(0,0)

! WRITE(*,*)'BACK FROM SCREENBANNER'

! PAUSE

!======

ISTR=0 !COUNTER FOR INCONSISTENCIES-MAX=1000

NOSP=0 ! FOR NOW-FEB. 2013-IS IT NEEDED

FK=0 !;ARAN=' ';IBAN=0 !CIPW OR(=1-IGBA)

!======

OUTPUT=0

! TO TRACE AND CHECK FOR DEBUGS

KDBG=0 !0= NO DEBUG, 1=DEBUG

!======

! WRITE(*,*) SHAPE(OXIDE), SHAPE(TITLE),SHAPE(A)

IF(KDBG==1)CALL PAUSER('AFTER START COMMANDS')

!======

T=CHAR(9) ! 'SPACE' DELIMITER FOR SPREADSHEETS

KDBG=0 !=0/1, NO/YES TRACING

FIRST01: DO L=1,IEL

OXIDE(L)=' '

! WRITE(*,*)TITLE(L),WMT(L)

ENDDO FIRST01

SECOND01: DO K=1,KYN

OXRAT(K)=0.0; TTL(K)=0.0; EMGNUM(K)=0.0

THIRD01: DO L=1,IEL

WT(K,L)=0.0; WTWT(K,L)=0.0; A(K,L)=0.0; CI(K,L)=0.0

ENDDO THIRD01; ENDDO SECOND01

!======

NRML=0 ! !;ICAN=0 ! DEFAULT: NO CANCRINITE IN ROCK SUITE

! IFULL=2 !!FULL PLOTS, =0 FOR PARTIAL PLOTS, 2= FOR NO PLOTS

!======

DO L=1,22; ELMIDY(L)=' '; ENDDO

DO L=1,KYN

NOOX(L)=0 !SAMPLE(L)=' ';ALALK(L)=' ';MPTOX(L)=1!0- DO NOT CALCULATE CIPW

MPTOX(L)=1 !DEFAULT=SIO2,AL2O3,MGO,CAO ALL HAVE VALUES

AGPC(L)=0.0

NRMFAC(L)=1.0

DFI(L)=0.0

ENDDO

!======

62 CONTINUE

CALL FILENAME(CARD,CS,YN,'CIPWFULL',NOSP) !2,OTFLNM,0=SPSH IS POSSIBLE

! WRITE(*,*)'CS,YN,NOSP,CARD(1:10)= ',CS,YN,NOSP,CARD(1:10)

! CALL PAUSER('AFTER BACK FROM FILENAME')

!======

! PAUSE 'BEFORE CALL RESULTBANNER'

! CALL RESULTBANNER(0,0)

! WRITE(*,*)'BACK FROM RESULTBANNER---'

! PAUSE

!======

! FIRST LINE OF INPUT SHOULD BE LEFT BLANK OR '1' IN FIRST COLUMN

! FOR NORMALIZATION TO 100%

! OXIDATION IS AUTOMATIC FOR PURPOSES OF CIPW CALCULATIONS.

! CANCRINITE CORRECTION(ICN=1). ICN=0 IF CO2 GOES AS CALCITE.

! WRITE(*,*)' AFTER CANCRINITE CORRECTION'

! WRITE(2,*)' AFTER CANCRINITE CORRECTION'

READ(1,912)CARDY !CARD SHOULD BE BLANK OR '1' IN FIRST/SECOND POSITIONS

! WRITE(*,*)'CARDY(1:30)= ',CARDY(1:30)

! SET ICAN & NRML

READ(CARDY,9129)NRML,JOBTITL !CARD SHOULD BE BLANK OR '1' IN FIRST COLUMN(ICAN)

IF(NRML<0.OR.NRML.GT.1)THEN

WRITE(*,*)

1'ONLY "0" OR "1" IS ALLOWED IN FIRST POSITION OF FIRST DATA LINE.'

WRITE(*,*)' CORRECT INPUT AND SUBMIT AGAIN.'

STOP

ENDIF

9129 FORMAT(I1,A120)

! WRITE(*,*)' AFTER 0129'

!======

IF(CARDY(2:120).NE.' ')THEN

! WRITE(*,*)CARDY(1:50)

! READ(*,*)J

! IF(KDBG==1)CALL PAUSER('AFTER READ CARDY')

! WRITE(*,*)

! 1'FIRST LINE MUST BE EMPTY,EXCEPT FOR POSITION 1 FOR NORMALIZATION.'

! STOP

! 1' FIRST LINE IN DATA FILE CONTAINS ILLEGAL INPUT. JOB TERMINATED.'

ENDIF

!======

! READ ERROR MESSAGE HERE( IF ANYTHING OTHER THAN 1 IN FIRST COLUMN

911 FORMAT(2I1)

!======

! READ CARD STRING AND BREAK TO ELEMENT IDENTITY & CREATE 'TITLE' SEQUENCE

910 READ(1,912)CARDY

912 FORMAT(A120)

IF(CARDY.EQ.' ')THEN

WRITE(*,*)'NO ELEMENT NAMES AND DATA TITLES READ. JOB TERMINATED.'

! PAUSE 'BEFORE STOP ELEMENT MATCH'

STOP ' NO ELEMENT NAMES AND DATA TITLES READ. JOB TERMINATED.'

ENDIF

! READ(*,*)J

!======

CALL SBD(CARDY,NOELEM,ELMIDE,22,5,120)

! WRITE(*,*)'AFTER SBD'

! WRITE(2,*)'AFTER SBD'

! WRITE(*,*)'NOELEM= ',NOELEM

! WRITE(2,*)'ELMIDE= ',ELMIDE

DO L=1,NOELEM

CALL LCUC(ELMIDE(L),5)

! WRITE(2,*)'/',ELMIDE(L),'/'

ENDDO

!======

FKK=0

! CHECK DOUBLE ENTRY OF ELEMENT ENTRY

! PAUSE 'BEFORE CALL OOPS TWICE'

DO L=1,NOELEM-1

DO K=L+1,NOELEM

! WRITE(*,*)'ELMIDE(l)= ',ELMIDE(L),' ELMIDE(K)= ',ELMIDE(K)

IF(ELMIDE(L).EQ.ELMIDE(K))THEN

FKK=FKK+1

! WRITE(*,*)'FKK= ',FKK

! PAUSE 'FKK BEFORE OOPS'

IF(FKK==1)CALL OOPS()

WRITE(4,*)

1 (ELMIDE(l)),' IS DECLARED MORE THAN ONCE. NOT ALLOWED.'

ENDIF

ENDDO

ENDDO

! PAUSE 'BACK FROM OOPS - TWICE DECLARED'

!======

DO L=1,NOELEM

ELMIDY(L)=ELMIDE(L)

ELMIDE(L)=ADJUSTR(ELMIDE(L))

! WRITE(2,*)'/',ELMIDE(L),'/'

ENDDO

! PAUSE 'AFTER ELMIDE'

!======

! WRITE(*,*)'BEFORE READ DATA/NOELEM= ',NOELEM

! WRITE(2,*)'BEFORE READ DATA/NOELEM= ',NOELEM

! PAUSE 'BEFORE READ DATA'

! READ DATA - OXIDES AND TRACES IN ANY ORDER. LEAVE SPACES BETWEEN ENTRIES.

! RECORD LENGTH NOT TO EXCCED 120 CHARACTERS.

I=1;IRANK=0

!======

! ONE EMPTY LINE BEFORE ROCK GROUPS NAMES (0 IN FIRST POSITON).

!======

! HERE FIND A WAY TO REREAD BY BACKFILING

!======

10222 READ(1,10111)SAMPLE(I)

10111 FORMAT(A8)

! WRITE(*,*)'I/SAMPLE= ','/',,' ',I,' SAMPLE(I),'/'

! PAUSE 'AFTER 10111'

IF(SAMPLE(I).EQ.'0 ')THEN

! PAUSE 'BEFORE BACKSPACE'

CALL ROCKGROUP(IRANK)

! WRITE(*,*)(KEEPR(L),L=1,IRANK)

! WRITE(4,*)(KEEPR(L),L=1,IRANK)

! PAUSE 'AFTER BACK FROM ROCK GROUP'

! HERE THE READING OF THE FILE IS COMPLETE

GOTO 707

ENDIF

!======

BACKSPACE(UNIT=1)

914 READ(1,*,END=707)SAMPLE(I),VP(I),ICN(I),MARK(I),

1(WT(I,J),J=1,NOELEM)

! PAUSE 'AFTER 914'

! WRITE(2,*)'SAMPLE(I)= ',SAMPLE(I)

! WRITE(*,*)'SAMPLE(I)= ',SAMPLE(I)

! WRITE(*,*)SAMPLE(I),' ',MARK(I),' ',IRANK

! PAUSE 'BEFORE MARK COMPARISON'

IF(MARK(I).GT.IRANK)IRANK=MARK(I)

! WRITE(2,*)SAMPLE(I),' IRANK = ', IRANK

! WRITE(*,*)'IRANK = ', IRANK

! PAUSE

915 FORMAT(A8,A1,I1,I2,22F5.2)

!======

I=I+1

!======

GOTO 10222

! NEXT ARRAY ELEMENTS IN CIPW SEQUENCE

707 CONTINUE

!======

! PAUSE 'PAST 707'

NOSMPL=I-1

! WRITE(*,*)'NOSMPL= ',NOSMPL

! WRITE(2,*)'NUMBER OF SAMPLES=I= ', NOSMPL

! WRITE(2,*)'NUMBER OF ELEMENT=I= ', NOELEM

! PAUSE 'AFTER 707'

! READ(*,*) J

! DO J=1,NOELEM

! WRITE(2,*)ELMIDE(J),(WT(I,J),I=1,NOSMPL)

! ENDDO

! PAUSE 'BEFORE 12'

!======

! ARRAY SAMPLES TO ROCK SUITE VECTOR

DO K=1,NOSMPL;SUITE(K)=RGP(MARK(K))

! WRITE(*,*)SUITE(K);PAUSE

ENDDO

!======

12 FORMAT(I1,I1,I3,15I2)

C PLOTTING PARAMETERS(IFULL=0 PARTIAL PLOTS,=1 COMPLETE PLOTS,=2 NO PLOTS)

! I=0

! READ(*,*) L

!======

! write(*,*)elmide

! pause 'BEFORE LCUC'

KKK=0

DO J=1,NOELEM; DO I=1,IEL ! FULL SET OF ELEMENTS

! WRITE(*,*)ELMIDE(J),TITLE(I)

! PAUSE 'ELMIDE/TITLE='

! READ(*,*)JKLNM

! CAPITALIZE ELEMENT NAMES BEFORE COMPARISON

! WRITE(*,*)'ELMIDE(J)= ',ELMIDE(J)

! PAUSE 'BEFORE LCUC'

! WRITE(*,*)'ELMIDE(J)= ',ELMIDE(J)

! PAUSE 'AFTER LCUC'

IF(ELMIDE(J)==TITLE(I))THEN

! WRITE(*,*)'ELMIDE(J)/NO= ',ELMIDE(J),I! NO NOW ISOLATED-DEC.2012

IF(I.EQ.9)NSOD=J; IF(I.EQ.6)NMAG=J; IF(I.EQ.1)NSIL=J

IF(I.EQ.10)NPOT=J

IF(I.EQ.8)NCAL=J; IF(I.EQ.5)NFRC=J; IF(I.EQ.4)NFRS=J

GOTO 4030 ! MATCH FOUND

ENDIF

ENDDO

! PAUSE 'AFTER MATCH FOUND'

KKK=KKK+1

IF(KKK==1.AND.FKK==0)CALL OOPS()

IF(KKK==1)WRITE(4,1212)

1212 FORMAT(/)

IF(KKK>0)THEN

WRITE(*,*)'ELEMENT ',

1 ELMIDY(J),'IS NOT A RECOGNIZED ELEMENT IN CIPW CALCULATION !'

WRITE(4,*)'ELEMENT ',

1 ELMIDY(J),'IS NOT A RECOGNIZED ELEMENT IN CIPW CALCULATION !'

ENDIF

GOTO 55855

! WRITE(*,*)ELMIDY

! PAUSE 'BEFORE STOP MATCHING'

!======

! write(*,*)elmide

! pause 'AFTER LCUC/BEFOR 4030'

4030 OXIDE(I)=TITLE(I)

! PAUSE 'AFTER 4030'

! WRITE(*,*)'OXIDE(I)= ',OXIDE(I)

C 99 FOR FEO 26 FOR FE2O3

! WRITE(*,*)' # OF SAMPLES= ', NOSMPL

! PAUSE 'AFTER C 99'

DO K=1,NOSMPL

WTWT(K,I)=WT(K,J)

CI(K,I)=WT(K,J) ! IS THIS CORRECT????

! WRITE(*,*)'WT(K,J)/WTWT(K,I)/CI(K,I)= ',WT(K,J),WTWT(K,I),CI(K,I)

!======

! WRITE(*,*)'BEFORE CONVERT PPM'

! CONVERT PPM TO %

! FIRST CHANGE PPM TO % (NI,LI,CR,ZR,SR,BA,FP,CP,RB AND PPM OF SP,FP,CP)

! (BE CAREFUL WHEN S,F AND CL ARE %). WATCH WHEN S(%) OR SO3(%)

! WRITE(*,*)' I/OXIDE(I)/TITLE(I)/WTWT(K,I)= ',

! 1I,OXIDE(I),TITLE(I),WTWT(K,I)

! PAUSE 'BEFORE SELECT CASE'

SELECT CASE (I)

!SO3% TO S%

CASE(24); WTWT(K,I)=WTWT(K,I)*0.4005 ! 32.07/80.08)

!NI TO NIO (PPM TO %NIO)

CASE(28); WTWT(K,I)=WTWT(K,I)/PPMTOPER*1.2725 !74.71/58.71

!LI TO LI2O (PPM TO %LI2O)

CASE(27); WTWT(K,I)=WTWT(K,I)/PPMTOPER*4.3055 !29.88/6.94

!CR TO CR2O3(PPM TO %CR2O3)

CASE(26); WTWT(K,I)=WTWT(K,I)/PPMTOPER*2.9227 !152.01/52.01

!ZR TO ZRO2(PPM TO %ZRO2)

CASE(25); WTWT(K,I)=WTWT(K,I)/PPMTOPER*1.3508 !123.22/91.22

!SR TO SRO (PPM TO %SRO)

CASE(23); WTWT(K,I)=WTWT(K,I)/PPMTOPER*1.1826 !103.63/87.63

!BA TO BAO (PPM TO %BAO)

CASE(22); WTWT(K,I)=WTWT(K,I)/PPMTOPER*1.1209 !153.96/137.36

!RB PPM TO %RB2O

CASE(32); WTWT(K,I)=WTWT(K,I)/PPMTOPER*2.1872 !186.96/85.48

!FP (PPM TO %FLUORINE)

CASE(29); WTWT(K,I)=WTWT(K,I)/PPMTOPER*1.0

!CP (PPM TO %CHLORINE)

CASE(30); WTWT(K,I)=WTWT(K,I)/PPMTOPER*1.0

!SP (PPM TO %S)

CASE(33); WTWT(K,I)=WTWT(K,I)/PPMTOPER*1.0

!------

! S% (% TO% %S) ! HOW ASSIGN

! CASE(96); WTWT(K,I)=WTWT(K,I)

!______

END SELECT

! WRITE(*,*)'TITLE(I)/WTWT(K,I)= ',TITLE(I),WTWT(K,I)

! PAUSE 'AFTER CASE'

! READ(*,*)L

!======

! WRITE(*,*)WTWT(K,I),K,I,WT(K,J),K,J

ENDDO

55855 CONTINUE

ENDDO

!======

DO L=1,IEL

! WRITE(*,*)OXIDE(L),(WTWT(K,L),K=1,NOSMPL)

ENDDO

! READ(*,*)L

!======

! WRITE(*,*)SUM(WTWT,DIM=1) !DO ELSEWHERE !!!!

! PAUSE 'AFTER DIM=1'

IF(KDBG==1)CALL PAUSER('AFTER TOTALING ELEMENT INPUT')

!======

! WRITE(*,*)' # OF SAMPLES= ', NOSMPL'

DO K=1,NOSMPL

!======

C CALCULATE AGPAITIC COEFFICIENT

! MOLAR (NA2O+K2O)/AL2O3 - WINTER, P. 147 = PERALKALINITY INDEX

! PRINT *,CI(K,9),CI(K,10),CI(K,2)

IF(CI(K,2).GT.0.0)

1AGPC(K)=(CI(K,9)*0.032268+CI(K,10)*0.021231)/(CI(K,2)*0.01962)

! PRINT *,'AGPC= ', AGPC(K)

! READ(*,*)L

!======

! MPTOX()=0 (NO SIO2,AL2O3,MGO AND CAO)

! WRITE(*,*)WTWT(K,1),WTWT(K,2),WTWT(K,6),WTWT(K,8)

IF(WTWT(K,1)==0.0.AND.WTWT(K,2)==0.0.AND.WTWT(K,6)==0.0.

1AND.WTWT(K,8).EQ.0.0)MPTOX(K)=0

! GET ELEMENTS TOTAL IN EACH SAMPLE - USE 'SUMY' FUNCTION IN FORTRAN??

! WRITE(*,*)'MPTOX(K)= ',MPTOX(K)

! PAUSE

ANATTL(K)=0.0

DO L=1,IEL

ANATTL(K)=ANATTL(K)+WTWT(K,L) !DO AFTER SUMMATION WITH TRACE ELEMENTS

! WRITE(*,*)'WTWT(K,L),ANATTL(K)= ',WTWT(K,L),ANATTL(K)

ENDDO

! WRITE(*,*)ANATTL(K)

! CALCULATE NORMALIZATION FACTOR, IF NEEDED.

IF(NRML==1)NRMFAC(K)=100.0/ANATTL(K) !ANATTL MUST BE AFTER 'MINORS' IN

! WRITE(*,*)'SAMPLE TOTAL/NRM.FAC, ',ANATTL(K),NRMFAC(K)

ENDDO

!======

! DETECT DULICATION OF ELEMENTS HERE - IS THIS RIGHT PLACE

! WRITE(*,*)'ELMIDY= ',(ELMIDY(L),L=1,NOELEM)

! WRITE(*,*)'OXIDE= ',OXI

! WRITE(2,*)'OXIDE= ',OXIDE

! READ*,L

CALL RMDPEL(OXIDE)

IF(KF>0.OR.FKK>0.OR.KKK>0)CALL NAMDES()

! WRITE(*,*)(KEEPR(L),L=1,20)

! WRITE(4,*)(KEEPR(L),L=1,20)

! PAUSE 'AFTER RMDPEL'

! WRITE(*,*)'FK = ',FK

! PAUSE 'AFTER CALL RMDPEL'

!======

! WRITE(*,*)'MNKL= ',MNKL

! PAUSE ' GOING NEXT TO KEEP01'

! HERE CHECK ROCK SUITE PROBLEMS

IF(MNKL==1)CALL KEEP01(IRANK)

!======

! STOP IF INPUT ERROR

IF(KF>0.OR.FKK>0.OR.KKK>0.OR.MNKL>0)STOP

!======

! MG/MGO=24.32/40.32=0.6032

! FE2/FEO=55.85/71.85=0.7773

! FE3/FE2O3=55.85 X 2/159.70=0.6994

! MN/MNO=54.94/70.94=0.7745

! MG RATIO (#) (MG/(MG+FE2+FE3+MN))-ATOMIC

C MG-NUMBER(RATIO) - ATOMIC NOT MOLECULAR OXIDE-'A' NOT YET SET!!!

DO K=1,NOSMPL

TEMPASS=0.0

! WRITE(*,*)CI(K,6),CI(K,4),CI(K,5),CI(K,7)

! WRITE(2,*)CI(K,6),CI(K,4),CI(K,5),CI(K,7)

TEMPASS=

1CI(K,6)*0.6032+CI(K,4)*0.7773+CI(K,5)*.6994+CI(K,7)*0.7745

! WRITE(*,*)'MPTOX(K)/TEMPASS= ',MPTOX(K),TEMPASS

IF(MPTOX(K).EQ.1.AND.TEMPASS.GT.0.0)

1EMGNUM(K)=100.0*CI(K,4)*0.7773/TEMPASS ! MG/FE+MG

ENDDO

!======

! OXIDATION CORRECTION HERE

! LEMAITRE(1976): OXRAT=WT%FEO/<FEO+FE2O3>

DO K=1,NOSMPL

! WRITE(*,*)'SAMPL # = ',K

! WRITE(2,*)'SAMPL # = ',K

IF(WTWT(K,4).GT.0.0.AND.WTWT(K,5).GT.0.0)CYCLE !BOTH FE PRESENT

IF(WTWT(K,4).LE.0.0.AND.WTWT(K,5).LE.0.0)CYCLE !BOTH FE ABSENT

IF(WTWT(K,4).LE.0.0.OR.WTWT(K,5).LE.0.0)THEN

! FOXC(k)=1

! WRITE(*,*)SAMPLE(K),' FOXC(K)= ',FOXC(K)

! PAUSE 'IN OXIDATION BLOCK'

! OXIDATION CORRECTION APPLIED

! pause

! WRITE(*,*)'SIO2/NA2O,K2O= ',WTWT(K,1),WTWT(K,9),WTWT(K,10)

IF(VP(K).EQ.'V')THEN ! VOLCANIC ROCKS

! WRITE(*,*)'V/P= ',VP(K)

! WRITE(2,*)'V/P= ',VP(K)

OXRAT(K)=0.93-0.0042*WTWT(K,1)-0.022*(WTWT(K,9)+WTWT(K,10))

ELSE IF(VP(K).EQ.'P')THEN ! PLUTONIC ROCKS

! WRITE(*,*)'V/P= ',VP(K)

! WRITE(2,*)'V/P= ',VP(K)

OXRAT(K)=0.88-0.0016*WTWT(K,1)-0.027*(WTWT(K,9)+WTWT(K,10))

ENDIF

! WRITE(*,*)(OXRAT(K)= ',OXRAT(K)

IF(KDBG==1)CALL PAUSER('AFTER DETERMINATIO OF OXIDATION RATIO')

ENDIF

ENDDO

! WRITE(*,*)(FOXC(K), K=1,50)

! PAUSE 'BEFORE PARTITION'

! PARTITION IRON HERE

! WRITE(*,*)' NUMBER OF SAMPLES= ', NOSMPL

! PAUSE

3344 DO K=1,NOSMPL

O5O5=0.0

! WRITE(2,*)'OXRAT= ',OXRAT(K)

! WRITE(2,*)'WTWT4/5= ',WTWT(K,4),WTWT(K,5)

! WRITE(*,*)'OXRAT= ',OXRAT(K)

! WRITE(*,*)'WTWT4/5= ',WTWT(K,4),WTWT(K,5)

IF(.NOT.(WTWT(K,4).GT.0.0.AND.WTWT(K,5).GT.0.0))THEN !???

! WRITE(*,*)'OXIDATION CORRECTION IN SAMPLE ',K

! WRITE(2,*)'OXIDATION CORRECTION IN SAMPLE ',K

IF(WTWT(K,4).GT.WTWT(K,5).AND.WTWT(K,5).LE.0.0)THEN !FEO>FE2O3

O5O5=WTWT(K,4)*OXRAT(K)

WTWT(K,5)=WTWT(K,4)-O5O5

WTWT(K,4)=O5O5

ELSE IF(WTWT(K,4).LT.WTWT(K,5).AND.WTWT(K,4).LE.0.0)THEN !FEO<FE2O3

O5O5=WTWT(K,5)*(1.0-OXRAT(K))

WTWT(K,4)=WTWT(K,5)-O5O5

WTWT(K,5)=O5O5

ENDIF; ENDIF

! WRITE(*,*)'WTWT4/5= ',WTWT(K,4),WTWT(K,5)

! WRITE(2,*)'WTWT4/5= ',WTWT(K,4),WTWT(K,5)

! write(*,*)SAMPLE(K),' FOXC(K)= ',FOXC(K); PAUSE

ENDDO

! write(*,*)(FOXC(k),k=1,nosmpl)

! READ(*,*)K

!======

! NORMALIZATION OF ANALYSES

IF(NRML==1)THEN

! WRITE(*,*)'IN NORMALIZATION' ; PAUSE 'AFTER IN NORMALIZATION'

DO K=1,NOSMPL; DO L=1,IEL

WTWT(K,L)=WTWT(K,L)*NRMFAC(K) !OK TO THIS POINT

ENDDO; ENDDO

ENDIF

!======

CHECK OXIDES(& MINOR) JUST BEFORE NORMS

! WRITE(*,*)' NUMBER OF SAMPLES= ',NOSMPL

DO L=1,IEL !NOSMPL

! WRITE(*,*)OXIDE(L) !CIPW ORDER ??????

! WRITE(*,'(/,A,22F8.5)')OXIDE(L),(WTWT(K,L),K=1,NOSMPL) ! ELEMENTS-CHECKING ONLY.

ENDDO

! PAUSE 'BEFORE CREATE A ARRAY'

IF(KDBG==1)CALL PAUSER('JUST BEFORE NORM CALCULATION')

!======

! CREATE 'A' ARRAY FOR MOLECULAR COMPOSITION . ALL SPECIES AT THIS ATAGE

! ARE IN %.DIVISION BELOW MUST BY % OXIDE (N0T % ELEMENT). EXCEPT FOR S,F,CL.

! WRITE(*,*)' TITLE AFTER % CONVERSION= ',TITLE

! READ(*,*)K

DO K=1,NOSMPL

! FIRST SIO2 TO P2O5

DO J=1,11 ! SIO2 TO P2O5 !IEL

A(K,J)=WTWT(K,J)/WMT(J)

! WRITE(*,*)

! 1'TITLE(J),A(K,J),WTWT(K,J),WMT(J)= ',

! 2TITLE(J),A(K,J),WTWT(K,J),WMT(J)

ENDDO

! SECOND CO2

A(K,17)=WTWT(K,17)/WMT(17)

! THIRD BAO TO RB2O

DO J=12,33 !17=CO2-NOT A TRACE.

IF(J.EQ.12.OR.J.EQ.22)A(K,J)=WTWT(K,J)/WMT(12) !BAO%-BA%

IF(J.EQ.13.OR.J.EQ.23)A(K,J)=WTWT(K,J)/WMT(13) !SRO%-SR%

IF(J.EQ.18.OR.J.EQ.25)A(K,J)=WTWT(K,J)/WMT(18) !ZRO2%-ZR%

IF(J.EQ.19.OR.J.EQ.26)A(K,J)=WTWT(K,J)/WMT(19) !CR2O3%-CR%

IF(J.EQ.20.OR.J.EQ.27)A(K,J)=WTWT(K,J)/WMT(20) !LI2O%-LI%

IF(J.EQ.21.OR.J.EQ.28)A(K,J)=WTWT(K,J)/WMT(21) !NIO%-NI%

IF(J.EQ.31.OR.J.EQ.32)A(K,J)=WTWT(K,J)/WMT(31) !RB2O%-RB%

! NOW F,CL,S

IF(J.EQ.14.OR.J.EQ.29)A(K,J)=WTWT(K,J)/WMT(14) !F%-FP%

IF(J.EQ.15.OR.J.EQ.30)A(K,J)=WTWT(K,J)/WMT(15) !CL%-CP%

IF(J.EQ.16.OR.J.EQ.33)A(K,J)=WTWT(K,J)/WMT(16) !S%-SP%

! NOW SO3

IF(J.EQ.24)A(K,J)=WTWT(K,J)/WMT(16) !SO3%

! WRITE(*,*)

! 1'TITLE(J),A(K,J),WTWT(K,J)= ',TITLE(J),A(K,J),WTWT(K,J)

! NOW SP

IF(J.EQ.96.OR.J.EQ.33)A(K,J)=WTWT(K,J)/WMT(33) !S%-SP%

ENDDO

! WRITE(*,*)

! 1'TITLE(J),A(K,J),WTWT(K,J),WMT(J)= ',

! 2TITLE(J),A(K,J),WTWT(K,J),WMT(J)

IF(KDBG==1)CALL PAUSER('AFTER CREATION OF MOLECULAR COMPOSITIONS')

! WRITE(*,*)(A(K,J),J=1,IEL)

ENDDO

! WRITE(*,*)'AFTER CREATION OF "A" ARRAY'

!======

! PAUSE 'BEFORE ASSIGN TRACE ELEMENTS TO ARRAY'

! HERE ASSIGN TRACE ELEMENTS TO 'A' ARRAY - DO AFTER OXIDATION CORRECTION !!

! BA/BAO-SR/SRO-FP/F-CP/CL-SO3/S-ZR/ZRO2-CR/CR2O3-LI/LI2O-NI/NIO-RB/RB2O

! HERE ALL TRACE ELEMENTS AREPERCENT(%)-BE CAREFUL !!!

! WRITE(*,*)' BEFORE ASSIGN ARRAY/NOSMPL= ',NOSMPL

! PAUSE

! WRITE(*,*)' TITLE BEFORE K/L SELECT= ', TITLE

! PAUSE

DO K=1,NOSMPL;DO L=1,IEL

! WRITE(*,*)' L= ',L

SELECT CASE (L)

CASE(22) !BA

! PAUSE ' IN BA/BAO'

! WRITE(*,*)'A(K,22)= ',A(K,22)

CALL PPMTOTITLE(OXIDE, TITLE,A,12,KYN,K,L) !BA TO BAO

! WRITE(*,*)'A(K,12)= ',A(K,12)

CASE(23) !SR

! PAUSE ' IN SR/SRO'

! WRITE(*,*)'A(K,23)= ',A(K,23)

CALL PPMTOTITLE(OXIDE, TITLE,A,13,KYN,K,L) !SR TO SRO

! WRITE(*,*)'A(K,13)= ',A(K,13)

CASE(29) !FP

! PAUSE ' IN FP/F'

! WRITE(*,*)'A(K,29)= ',A(K,29)

CALL PPMTOTITLE(OXIDE, TITLE,A,14,KYN,K,L) !FP TO F

! WRITE(*,*)'A(K,14)= ',A(K,14)

CASE(30) !CL

! PAUSE ' IN CP/CL'

CALL PPMTOTITLE(OXIDE, TITLE,A,15,KYN,K,L) !CP TO CL

CASE(24) !SO3

! PAUSE ' IN SO3/S'

!======

! BOTH S AND SO3 ARE PERCENT-WATCH!!THIS IS TITLE ONLY-NO ARITHMATICS HERE.

CALL PPMTOTITLE(OXIDE, TITLE,A,16,KYN,K,L) !SO3 TO S

!======

CASE(25) !ZR

! PAUSE ' IN ZR/ZRO2'

! 17 IS CO2 - ALREADY IN MAJOR ELEMENTS LIST

CALL PPMTOTITLE(OXIDE, TITLE,A,18,KYN,K,L) !ZR TO ZRO2

CASE(26) !CR

! PAUSE ' IN CR/CR2O3'

CALL PPMTOTITLE(OXIDE, TITLE,A,19,KYN,K,L) !CR TO CR2O3

CASE(27) !LI

! PAUSE ' IN LI/LI2O'

CALL PPMTOTITLE(OXIDE, TITLE,A,20,KYN,K,L) !LI TO LI2O

CASE(28) !NI

! PAUSE ' IN NI/NIO'

CALL PPMTOTITLE(OXIDE, TITLE,A,21,KYN,K,L) !NI TO NIO

CASE(32) !RB

! PAUSE 'IN RB/RB2O'

CALL PPMTOTITLE(OXIDE, TITLE,A,31,KYN,K,L) !RB TO RB2O

CASE(33) !SP

! PAUSE ' IN SP/S'

CALL PPMTOTITLE(OXIDE, TITLE,A,16,KYN,K,L) !SP TO S

!======

END SELECT ! NO NEED FOR 'CASE DEFAULT'

!======

! NEED A DEFAULT OPTION

!======

ENDDO; ENDDO

! READ(*,*)I

! WRITE(*,*)'AFTER RE-ASSIGNMENT OF "A" ARRAY'

! WRITE(*,*)'NOELEM/IEL= ',NOELEM,IEL

! WRITE(2,*)'NOELEM/IEL= ',NOELEM,IEL

DO L=1,IEL

! WRITE(*,'(/,A5,10F7.4)')OXIDE(L),(A(K,L),K=1,3) !NOSMPL)!OK

ENDDO

! ORIGINAL # OF ELEMENTS IN CIPW CALCULATION

DO L=1,22

! WRITE(*,*)OXIDE(L),(A(K,L),K=1,NOSMPL)

ENDDO

! READ(*,*)L

!======

155 FORMAT(16X,22(1X,A5,2X))

!======

! WRITE(*,*)'NRML= ',NRML

! PAUSE

! WRITE JOB TITLE - USE REPEAT FUNCTION HERE

WRITE(2,*)REPEAT('=',160)

WRITE(2,*)REPEAT(' ',60),JOBTITL(1:80) !TRUNCATE OVER 80 CHAR.

WRITE(2,*)REPEAT('=',160)

! ONLY 80 CHARACTERS PRINTED NOW. CAN BE INCREASED LATER TO 120, IF NEEDED.

!======

IF(NRML==0)THEN

WRITE(2,654)'SAMPLE ','ROCK SUITE ',

1'V/P','CAN','TOTAL',(ELMIDE(J),J=1,NOELEM)

ELSE IF(NRML==1)THEN

WRITE(2,655)

1'SAMPLE ','ROCK SUITE ','V/P','CAN',

1' NRM.FAC .','TOTAL ',(ELMIDE(J),J=1,NOELEM)

ENDIF

654 FORMAT(A8,1X,A20,14X,A3,1X,A3,4X,A5,1X,22(3X,A5))

655 FORMAT(A8,1X,A20,16X,A3,2X,A3,1X,A8,4X,A5,1X,22(3X,A5))

!655 FORMAT(A8,A20,1X,A6,A4,A8,2X,A6,2X,22(3X,A5))

! WRITE(2,*)' NUMBER OF SAMPLES =', NOSMPL

! PAUSE 'BEFORE WRITE DATA'

DO L=1,NOSMPL

IF(NRML==0)THEN

WRITE(2,566)SAMPLE(L),SUITE(L),VP(L),ICN(L),ANATTL(L),

1(WT(L,J),J=1,NOELEM) !,OXRAT(L)

ELSE IF(NRML==1)THEN

WRITE(2,656)SAMPLE(L),SUITE(L),VP(L),ICN(L),NRMFAC(L),ANATTL(L),

1(WT(L,J),J=1,NOELEM)

ENDIF

566 FORMAT(A8,1X,A20,4X,A1,2X,6X,I1,7X,F6.2,2X,22(2x,F8.2))

656 FORMAT(A8,1X,A20,6X,A1,6X,I1,9X,F6.4,8X,F6.2,3X,22(2x,F8.2))

!656 FORMAT(A8,1X,A20,4X,A1,3X,I1,2X,F6.4,2X,F6.2,3X,22(F8.2))

ENDDO

IF(NRML==0)THEN

WRITE(2,654)'SAMPLE ','ROCK SUITE ',

1'V/P','CAN','TOTAL',(ELMIDE(J),J=1,NOELEM)

ELSE IF(NRML==1)THEN

WRITE(2,655)

1'SAMPLE ','ROCK SUITE ','V/P','CAN',

1' NRM.FAC .','TOTAL ',(ELMIDE(J),J=1,NOELEM)

ENDIF

! WRITE(4,*)'AFTER 791'

!======

! START CALCULATIONS OF PETROLOGIC INDECES

! WRITE(2,*)' BEFORE DO 1000'

! PAUSE 'BEFORE DO 1000'

! WRITE(2,*)ANATTL(L),L=1,NOSMPL)

! WRITE(2,*)NRMFAC(L),L=1,NOSMPL)

DO ME=1,IEL !IEL=33 AFTER APRIL15, 2013