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