CMS WKDATA(), a severe modification of SUMARY and RESUME. CMS look for severe mods in GETPHY() and WKOUT() (RESPHY() and ISORSP()). CMS This will open XYZPOS.DAT if warranted for inclusion of x-y CMS coordinates in the created label.WKD file. CMS CMS Michael Shaffer, University of Oregon, April 1991 CMS CMS **************************************************************** CMS CMS SUMARY, A REVISION OF RESUME TO PRINT OUT A COMMA CMS DELINEATED FILE FOR IMPORTING INTO SPREADSHEETS. CMS CMS 24-JAN-90 PRINTS HAVING ASSUMED RES>BO WAS SELECTED. cms 2-feb-90 references to ISOCRP changed to ISORCS CMS ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c PROGRAMME RESUME c c______print a summary of quantitative analysis results_______c c GIRAUD nov-86 c c HC aug-87 ( multilabel) c c sun mar-88 c c implem. sep-88 c c " feb-89 c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c C GETPHY() input arguments c c LEG : dimension parameter c c output arguments c a : atomic weight c aint : absolute primary intensity c aj : mean ionization potential c ajst : mean ionization potential (compound standard) c air : compound standard to pure intensity ratio c ast : atomic weight (compound standard) c bkst : backscattering factor (compound standard) c c : weight fraction c cst : weight fraction (compound standard) c eo : acceleration voltage (for each experimental condition) c eoi : acceleration voltage (for each element) c esp : fluorescence enhancement parameter c sym : atom symbol c syst : atom symbol (compound standard) c idx : application {l1,..,l(nb)} -> {1,..,nb} c according to D-H-Z sorting c itab : compound standard number c nv : valence c lna : xray line ascii code c nec : number of companions in the coumpound standard c nz : atomic number c nzst : (compound standard) c oxcpd : chemical formula c std : standard name c exci : excitation voltage c csc : cosecant of the take off angle c irf : number of records c isw : integer analysis mode c isws : integer submode of st and ge c if isws>0 -> extra anion c ndd : pointer to a record c nel : total number of elements in the unknown c na : number of measured elements c na1 : number of measured elements under condition no.1 c ncs : number of elements compared to a compound standard c ntab : number of different compound standards c preint : test for full computation c igr : species (geo) group number c nbox : number of oxygen (geo) c nbh2o : number of H2O c nex : if nex=1 : one extra element is inserted c nb : number of computed elements (oxygen excluded) c c c WKOUT() input arguments c c a : atomic weight c idx : application {l1,..,l(nel-1)} -> {1,..,nel-1} c according to D-H-Z sorting c naem : end member names c nv : valence c oxcpd : chemical formula c sym : atom symbol c cptox : switch for WT % oxide calculation c igr : species group number c imod : resume mode c isw : analysis mode c isws : number of negative valence(s) c mato : number of cations ( geo ) c mnel : loop parameter c na : number of measured elements c nbh2o : number of water mol. c nel : total number of elements in the unknown c npol : number of poles c LEG : maximum number of elements c c isorsp() output c c ato : atom% or number of cations c c : W% concentration or W% of oxide c pole : end member contribution c sigsk : sigma/k c cw : W% concentration or oxyde | c c WKOUT = 0 normal exit c WKOUT = 1 error exit c program WKDATA parameter (LEG=20) !maximum number of elements parameter (LPO=8) !maximum number of endmembers parameter (LPTM=4096) !maximum number of analyses logical cptox, XYCRD INTEGER*4 XYZ(3) character*10 oxcpd(LEG) character*1 YN character*19 fnam character*2 VRSN character*9 std(LEG),dnam,TARG0 character*4 naem(6) character*2 ch,sym(LEG),syst(LEG,LEG),lna(LEG),syd(LEG) character*80 bla CHARACTER*46 BLA2 character*26 fmt1 character*17 fmt2 dimension a(LEG),aint(LEG),air(LEG),aj(LEG),ajst(LEG,LEG),ak(LEG) &,ast(LEG,LEG),ato(LEG),bkst(LEG,LEG),c(LEG),cst(LEG,LEG),eo(2) &,eoi(LEG),esp(2),exci(LEG),idx(LEG) &,itab(LEG),nec(LEG),nv(LEG),nz(LEG) &,nzst(LEG,LEG),pole(LPO),sigsk(LEG),cw(LEG) common/lui/lu5,lu6,lu7,lu2,lu3,lu9,lu4 data lu5,lu6,lu7,lu2,lu3,lu9,lu4/5,6,5,2,3,9,4/ data fmt1/'(/'' Missing '',aNN,'' file'')'/ data fmt2/'(1h1,4x,aN/5x,aN)'/ 260 format(a80) 268 format(/) 270 format(a1) 281 format(a2) c label.cor 901 format(4(1x,i2),1x,f6.4,1x,i3,1x,i1,1x,i2) c label.cor 902 format(20(3x,a2)) c label.cor 903 format(20(1x,f4.1)) c label.cor 907 format(a80) C C Input label C 1000 FNAM=' ' call inlab(fnam,nf) if(nf.eq.0) go to 1000 write(fmt2(10:10),6000) nf write(fmt2(16:16),6000) nf 6000 format(i1.1) C C ANY PARTICULAR VERSION? C 1001 VRSN=' ' WRITE(LU7,1030) 1030 FORMAT(/2X,'Enter version of label.KEX and label.COR files & [CR=latest] ',$) READ(LU7,1031) VRSN 1031 FORMAT(A2) c c initialization of the application { user's index } -> { geo index } c do 4000 i=1,LEG idx(i)=i 4000 continue C C Open file of operating conditions - label.phy C fnam(nf+4:nf+7)='.PHY' open(lu2,file=fnam(1:nf+7),status='old',access='direct' &,recl=LEG,err=2000) WRITE(LU5,6661) FNAM 6661 FORMAT(/1X,'successfully opened ',a19) C C Open file of results after data reduction - label.cor C fnam(nf+4:nf+7)='.COR' IF (VRSN.EQ.' ') GO TO 4043 FNAM(NF+8:NF+8)=';' FNAM(NF+9:NF+10)=VRSN 4043 open(lu9,file=fnam(1:nf+10),status='old',err=2001 &,carriagecontrol='list') WRITE(LU5,6661) FNAM C C Open file of raw data - label.kex C fnam(nf+4:nf+7)='.KEX' IF (VRSN.EQ.' ') GO TO 4044 FNAM(NF+8:NF+8)=';' FNAM(NF+9:NF+10)=VRSN 4044 open(lu3,file=fnam(1:nf+10),status='old',err=2002 &,carriagecontrol='list') WRITE(LU5,6661) FNAM c c Initialize the label c c read label.phy - also get group number c call GETPHY(a,aint,aj,ajst,air,ast,bkst,c,cst,eo,eoi,esp &,sym,syst,idx,itab,nv,lna,nec,nz,nzst,oxcpd,std,exci,csc,irf,isw &,isws,LEG,ndd,nel,na,na1,ncs,ntab,preint,igr,nbox,nbh2o,nex,nb) close(lu2) WRITE(LU5,6662) 6662 FORMAT(/1X,'successfully retrieved physical data') c c Get number of significant points : nr39 and the number of records c for one point : ncor c if(igt39m(na,nel,isw,na1,sym,eoi,ncor,nr39,LPTM) .eq. 0) go to 87 close(lu3) close(lu9) write(lu7,5000) 5000 format(/' igt39 : error') stop 87 continue WRITE(LU5,6663) nr39 6663 FORMAT(/1X,'COR and KEX files imply ',i4,' analyses') WRITE(LU5,6666) fnam(4:nf+3) 6666 FORMAT(1X,'the target label is ',a10) C C Check xyzpos.dat file C 20 XYCRD=.FALSE. YN='N' NPT=0 WRITE(LU7,21) 21 FORMAT(/' Do you want to include x & y from XYZPOS.DAT? [N] ',$) READ(LU7,22) YN 22 FORMAT(A1) IF((YN.NE.('Y')).AND.(YN.NE.('y'))) GO TO 30 OPEN(UNIT=lu4,FILE='XYZPOS.DAT',STATUS='OLD',ERR=26 &,CARRIAGECONTROL='LIST') 23 READ(lu4,24,END=25) TARG0,XYZ,BLA2 24 FORMAT(A9,3(1X,I7),A46) IF(TARG0.NE.(fnam(4:nf+3))) GO TO 23 NPT=NPT+1 GO TO 23 STOP 25 IF((NPT).EQ.(NR39)) GO TO 30 GO TO 28 STOP 26 WRITE(LU7,27) 27 FORMAT(/' Problem opening the xyzpos.dat coordinate file ... & Wanna exit? [N] ',$) YN='N' READ(LU7,22) YN IF((YN.EQ.('Y')).OR.(YN.EQ.('y'))) GO TO 999 go to 20 STOP 28 CLOSE(lu4) WRITE(LU7,29) npt 29 FORMAT(1x,i4,' entries in XYZPOS.DAT does not match ... & Wanna exit? [N] ',$) YN='N' READ(LU7,22) YN IF((YN.EQ.('Y')).OR.(YN.EQ.('y'))) GO TO 999 go to 20 STOP 30 CLOSE(lu4) IF((NPT).EQ.(NR39)) XYCRD=.TRUE. if (xycrd) WRITE(LU5,6664) npt 6664 FORMAT(1X,i4,' entries in XYZPOS.DAT match') c C Open file for comma delineated data - label.WKD fnam(nf+4:nf+7)='.WKD' open(lu2,file=fnam(1:nf+7),status='new',err=2000,RECL=300 &,carriagecontrol='list') C C C end member definition ( geo only) C naem : end member name C npol : end member number C D write(lu7,1111) ncor D1111 format(' ncor -> ',i) npol=0 if(ncor .eq. 3) go to 88 dnam=' ' dnam(1:nf)=fnam(4:nf+3) npol=mbedgr(dnam,naem) if(npol .lt. 0) stop write(lu5,6667) (naem(i),i=1,npol) 6667 format(1x,6(a10),' are the endmembers ...') c c cptox switch ; if cptox : weight % of oxides must be calculated c mnel : substracted to nel , gives the number of listed c items c mato : number of listed atoms or cations c 88 cptox=.false. if(isw.eq.4) cptox=.true. if(isw.eq.2.and.isws.eq.0) cptox=.true. mnel=0 if(isw.eq.4.or.isw.eq.7) mnel=1 if(isw.eq.2.and.isws.eq.0) mnel=1 mato=nel if(isw.ne.7) go to 82 mato=nel-1 if(nbh2o.gt.0.) mato=mato-1 if(isws.gt.0) mato=mato-isws C C WKDATA mode ? (REMOVED, IMOD=3 ALWAYS) 82 imod=3 C IF (XYCRD) TARG0=(fnam(4:nf+3)) c c send pointer to the first significant record c rewind lu9 read(lu9,901) ncor read(lu9,902) (syd(i),i=1,nel) read(lu9,903) (eoi(i),i=1,na) WRITE(LU5,6665) fnam(4:NF+3) 6665 FORMAT(/1X,'writing to ',a8,'.WKD') c c Output WEIGHT % c 66 CWtest=CWOUT(a,ato,c,idx,naem,NR39,nv,oxcpd,pole,XYCRD,TARG0 &,sigsk,sym,cw &,cptox,igr,imod,isw,isws,mato,mnel,na,nbh2o,nel &,npol,LEG,LPO) if(CWtest.lt.0) stop WRITE(LU2,268) c c Output ERROR c rewind lu3 C ERtest=REROUT(a,ato,c,idx,naem,NR39,nv,oxcpd,pole,XYCRD,TARG0 &,sigsk,sym,cw &,cptox,igr,imod,isw,isws,mato,mnel,na,nbh2o,nel &,npol,LEG,LPO) if(ERtest.lt.0) stop CLOSE(lu3) WRITE(LU2,268) c c send pointer to the first significant record IN COR c rewind lu9 read(lu9,901) ncor read(lu9,902) (syd(i),i=1,nel) read(lu9,903) (eoi(i),i=1,na) ATtest=ATMOUT(a,ato,c,idx,naem,NR39,nv,oxcpd,pole,XYCRD,TARG0 &,sigsk,sym,cw &,cptox,igr,imod,isw,isws,mato,mnel,na,nbh2o,nel &,npol,LEG,LPO) if(ATtest.lt.0) stop WRITE(LU2,268) C IF (XYCRD) OPEN(UNIT=lu4,FILE='XYZPOS.DAT',STATUS='OLD',ERR=995 &,CARRIAGECONTROL='LIST') c c send pointer to the first significant record IN COR c rewind lu9 read(lu9,901) ncor read(lu9,902) (syd(i),i=1,nel) read(lu9,903) (eoi(i),i=1,na) XYtest=XYOUT(a,ato,c,idx,naem,NR39,nv,oxcpd,pole,XYCRD,TARG0 &,sigsk,sym,cw &,cptox,igr,imod,isw,isws,mato,mnel,na,nbh2o,nel &,npol,LEG,LPO) if(XYtest.lt.0) stop GO TO 999 c 2003 CLOSE(LU3) 2002 CLOSE(LU9) 2001 CLOSE(LU2) 2000 write(fmt1(16:17),3000) nf+4 write(lu7,fmt1) fnam(4:nf+7) 3000 format(i2.2) go to 998 C 995 WRITE(LU5,996) 996 FORMAT(1X,' PROBLEM OPENING XYZPOS.DAT FILE (2ND TIME) ..') c c standard exit c 999 CLOSE(LU2) ! LABEL.WDK IF (XYCRD) CLOSE(LU4) ! XYZPOS.DAT CLOSE(LU9) ! LABEL.COR 998 WRITE(LU7,927) 927 FORMAT(/' Another label? [N] ',$) YN='N' READ(LU7,22) YN IF((YN.EQ.('Y')).OR.(YN.EQ.('y'))) GO TO 1000 END