program swash c---------------------------------------------------------------------- c ************************ c * * c * swash.may.10.1995 * c * * c ************************ c---------------------------------------------------------------------- c swash is a fortran program that appends pseudocompound c entries for a vertex format thermodynamic data file, c from a solution model file (unit n9) and the c selected thermodynamic data file (unit n2) c----------------------------------------------------------------------- c files (see vertex program documentation for additional information): c c l.u.n i/o purpose c ----- --- -------------------------------------------------------- c n2 i data file containing the names, compositional vectors, c and standard state thermodynamic data for potentially c stable condensed phases and fluid species. c n7 i terminal input for interactive systems. c n8 o terminal output for interactive systems. c n9 i optional data file which contains data on the c compositional equations of state and subdivision schemes c to be used for solution phases. c----------------------------------------------------------------------- implicit double precision (a-g,o-y),integer (h-m,z) parameter (k0=25,k1=1200,k4=16,k5=12,k6=7,h5=7,nb=20, * h8=100,h9=18,i9=90,j9=1200,l2=5) character*8 blank8,exname,n9name*14, * blank5*5,blnk10*10,n4name*14,n5name*14, * dname*40,cmpnt*5,vname*8,gname*78,xname*18, * title*72,phase,y*1,n2name*14, blah*10, * n3name*14, name, crap*5, b1, b2 integer icout(k0) double precision cblk(nb,k5) character*8 names,uname(k0),fname*10,tname(i9)*10, * mname(k5)*5,nname(k5)*5,oname(k5)*5,qname(k0)*5 common/ cst6 /icomp,istct,iphct,icp/ cst8 /names(k1) * / cst207 /ctrans(k0,k5),ictr(k5),itrans * / csta2 /xname(k6),vname(l2),gname(l2)/ cst83 /ig(l2) * / cst5 /v(l2),tr,pr,r,ps/ cst9 /vmax(l2),vmin(l2),dv(l2) * / cst10 /iff(2),idss(h5),ifug,ifyn,isyn * / cst24 /ipot,jv(l2),iv(l2)/ cst112 /buf(5) * / cst100 /dlnfo2,elag,gz,gy,gx,ibuf,hu,hv,hw,hx * / cst60 /iasmbl(j9),ipoint,imyn/ csta7 /fname(h9) * / cst41 /n1,n2,n3,n4,n5,n6,n7,n8,n9,io3,io4,io5,io9 * / cst41a /n2name/ cst36 /exname(h8)/ cst79 /isoct * / cst37 /iprct,ixct,iexyn,istbyn/ csta6 /name * / cst59 /istbct,idst(10,5),ister(10) * / cst43 /therm(k4),comp(k0),atwt(k0),idh2o,idco2,ikind * / csta5 /dname(8),cmpnt(k0)/ cst42 /icin(k5),idbase save blank5, blank8, blnk10 data blank5,blank8,blnk10/' ',' ',' '/ c----------------------------------------------------------------------- write (*,7020) c assign data files call fopen do 71 i = 1, h9 71 fname(i) = blnk10 isct=0 imct=1 ifct=1 c Read THERMODYNAMIC DATA (N2) call topn2 (4, icmpn) icomp = icmpn 35 call getphi (name,ibase,icmpn,*18) if (ibase.ne.idbase) goto 35 iphct = iphct + 1 call loadme (iphct) goto 35 c --------------------- c read solution phases. c --------------------- c get the file containing the solution models 18 write (*,3010) read (*,3040) n9name open (n9,file=n9name,iostat=ierr,status='old') if (ierr.ne.0) then c system could not find the file write (*,3020) n9name 5033 write (*,7050) read (*,3030,iostat=ier) y call rerror (ier,*5033) if (y.ne.'Y'.AND.y.ne.'y') goto 999 goto 18 c try again end if ict = 0 ipoint = iphct c read candidates: 110 call rmodel (blah,istot) c istot = 0 = eof if (istot.eq.0) goto 90 c check for endmembers: call cmodel (im,idsol,blah,istot,jstot,1,b1,b2) if (jstot.eq.0) goto 110 c if missing endmembers, c revise model if (jstot.lt.istot) then call emodel (blah,istot) c istot = 0, model could not c be revised. if (istot.eq.0) goto 110 end if ict = ict + 1 if (ict.gt.i9) call error (24,r,i9,'build') tname(ict) = blah goto 110 90 if (ict.eq.0) then write (*,7040) else write (*,2510) write (*,2520) (tname(i), i = 1, ict) write (*,*) isoct=1 191 read (*,2530) fname(isoct) if (fname(isoct).eq.blnk10) goto 200 do 193 i = 1, ict 193 if (fname(isoct).eq.tname(i)) goto 194 write (*,*) fname(isoct),' is not a valid name, try again' goto 191 194 isoct = isoct + 1 if (isoct.gt.h9) call error (25,r,h9,'BUILD') goto 191 end if 200 call input9 999 stop 190 call error (21,r,i,n2name) 2510 format (' Select phases from the following list, enter', * ' one per line,',/,' left justified, ', * ' to finish',/) 2520 format (6(2X,a10)) 2530 format (a10) 3010 format (' Enter solution model file name (e.g. ', * 'solut.dat),',/,' left justified, < 15 characters: ') 3020 format (/,' **ERROR VER191** FOPEN file ',a14, * ' could not be opened',/) 3030 format (a1) 3040 format (A14,20x,a40) 7020 format (//,' NO is the default answer to all Y/N prompts',/) 7040 format (/,' The solution model file contains no', * ' models valid for your problem.',/) 7050 format (' Try again (Y/N)? ') end block data c----------------------------------------------------------------------- implicit double precision (a-g,o-y),integer (h-m,z) common/ cst41 /n1,n2,n3,n4,n5,n6,n7,n8,n9,io3,io4,io5,io9 c----------------------------------------------------------------------- c the following data statement assigns c logical unit numbers for i/o. data n1,n2,n3,n4,n5,n6,n7,n8,n9/21,22,23,24,25,26, 5, 6,29/ end subroutine fopen c----------------------------------------------------------------------- implicit double precision (a-g,o-y),integer (h-m,z) character*14 n2name, y*1 common/ cst41 /n1,n2,n3,n4,n5,n6,n7,n8,n9,io3,io4,io5,io9 c----------------------------------------------------------------------- c first the thermo data file 1 write (*,1000) read (*,1030) n2name open (n2,file=n2name,iostat=ierr,status='old') if (ierr.ne.0) then c system could not find the file write (*,1010) n2name read (*,1020) y if (y.ne.'Y'.and.y.ne.'y') goto 999 goto 1 c try again end if write (n1,1030) n2name return 999 write (*,1060) stop 1000 format (/,' Enter thermodynamic data file name (e.g.', * ' hp94ver.dat), left justified:') 1010 format (/,' **warning ver191** FOPEN file ',A14, * ' could not be opened',//,' try again (y/n)? ') 1020 format (a1) 1030 format (a14) 1040 format (/,' Enter name of computational option file to' * ,' be created',/,' <15 characters, left justified:') 1050 format (/,' File ',a14,' exists, overwrite it (y/n)? ') 1060 format (/,' O.K., then i am quitting also.') end subroutine rename (jcmpn,qname,kset,*) implicit double precision (a-g,o-y),integer (h-m,z) parameter (k0=25) character*5 xcname(k0), qname(k0) save xcname, kcmpn if (kset.eq.1) then do 1 i = 1, jcmpn 1 xcname(i) = qname(i) kcmpn = jcmpn else write (*,100) do 2 i = 1, kcmpn 2 qname(i) = xcname(i) jcmpn = kcmpn return 1 end if 100 format (/,' You made a mistake, try again.',/, * ' Check spelling and upper/lower case matches',//) end function grxn (i) c-------------------------------------------------------------------- c a dummy routine to allow rk to be linked with rlib.f c-------------------------------------------------------------------- implicit double precision (g) grxn = 0.d0 end subroutine loadme (id) c--------------------------------------------------------------------- c loadit loads descriptive data for phases and species (name,comp, c and therm) into the appropriate arrays (names,comps,thermo,vf, c and vs). the arguement 'id' indexes the phase in the arrays. c note that loadit also computes reference state constants which c are dependent on the state function being used and on its c analytical expression. c--------------------------------------------------------------------- implicit double precision (a-g,o-y),integer (h-m,z) parameter (k0=25,k1=1200,k2=1200,k3=1200,k4=16,k5=12,k6=7) parameter (m9=50,k9=50,m6=3,m7=9,m8=9,h5=7,h6=500,j9=1200) parameter (nb=20) character*8 names, name, cmpnt*5, dname*40 common/ cst60 /iasmbl(j9),ipoint,imyn/ csta6 /name * / cst88 /vu(2,k1),jprct,jmct,jmyn * / cst61 /ikp(k1),ivarrx(k2),ivarip(k3),isudo,ivar * / cst1 /thermo(k4,k1),vf(2,k1),vs(h5,k1),uf(2),us(h5) * / cst10 /iff(2),idss(h5),ifug,ifyn,isyn * / cst20 /comps(k1,k5)/ cst8 /names(k1) * / cst5 /p,t,xco2,u1,u2,tr,pr,r,ps/ cst12 /cp(k6,k1) * / cst6 /icomp,istct,iphct,icp * / cst40 /ids(h5,h6),isct(h5),icp1,isat,io2 * / csta5 /dname(8),cmpnt(k0)/ cst42 /ic(k5),idbase * / cst202 /tm(m7,m6),td(m8),ilam,idiso,lamin,idsin * / cst203 /therdi(m8,m9),therlm(m7,m6,k9) * / cst43 /therm(k4),comp(k0),atwt(k0),idh2o,idco2,ikind * / cst300 /cblk(nb,k5),atw(k1),vol(k1),iblk,jcby,jcth * / cst204 /ltyp(k1),lmda(k1),idis(k1) c--------------------------------------------------------------------- c load name and phase flag 50 names(id)=name ikp(id)=ikind c load stoichiometry of components. do 30 i = 1, icomp 30 comps(id,i) = comp(i) do 1 i = 1, k4 1 thermo(i,id) = therm(i) c lmda transitions: idis(id) = 0 lmda(id) = 0 if (ilam.ne.0) then lamin=lamin+1 if (ilam.ge.10.and.ilam.le.12) then c holland and powell, landau model: lct = ilam - 9 do 140 j = 1, lct therlm (1,j,lamin) = tm(1,j) therlm (2,j,lamin) = tm(2,j) 140 continue else if (ilam.le.3) then c ubc: do 90 j = 1, ilam do 80 k = 1, 8 80 therlm(k,j,lamin)=tm(k,j) 90 continue else if (ilam.gt.3.and.ilam.lt.8) then c helgeson: jlam = 1 c set transition type to null c for call to gphase lmda(id) = 0 c set P and T to Transition T and Pr do 120 j = 1, 7 120 therlm(j,1,lamin) = tm(j,1) c if 3 < ilam < 7 load other transitions if (ilam.eq.4.or.ilam.eq.7) goto 130 jlam = ilam - 3 lmda(id)=lamin do 100 j = 2, jlam c increment transition type ltyp(id) = 2 + j do 110 k = 1, 7 110 therlm(k,j,lamin) = tm(k,j) 100 continue end if 130 lmda(id)=lamin ltyp(id)=ilam end if c t dependent order: load berman and brown c parameters, (this should be cleaned up) if (idiso.ne.0) then idsin = idsin+1 idis(id) = idsin do 70 j = 1, m8 70 therdi(j,idsin) = td(j) end if end subroutine soldme (z,isolct,tname) implicit double precision (a-g,o-z),integer (h-n) parameter (k1=1200,k2=1200,k3=1200,k4=16,k5=12,k6=7,m0=5) parameter (m9=50,k9=50,m6=3,m7=9,m8=9,h5=7,h6=500,nb=20) character*10 tname, names*8 double precision z(3,3) common / cst41 /n1,n2,n3,n4,n5,n6,n7,n8,n9,io3,io4,io5,io9 common/ cst108 /wg(27,11),xmn(3,3),xmx(3,3),xnc(3,3),xfx(3), * iend(4,3,3),isub(27,9,2),imd(3),imsol(4,3,3), * ijk(3),insp(3,4),jsp(3),jsitp(3),iosp(3), * jst(3),jfix,idfc(3),ist(3),isp(3),isite, * ispct(3,4),jnsp(3,4),jsite,iterm,iord common/ cst107 /a0(5,5),acoef(5,5,m0),smult(5),ecoef(3,3,3), * nsite,nspm1(5),nterm(5,5), * nsub1(5,5,m0,4),nsub2(5,5,m0,4),nttyp(5,5,m0) common/ cst1 /thermo(k4,k1),vf(2,k1),vs(h5,k1),uf(2),us(h5) * / cst202 /tm(m7,m6),td(m8),ilam,idiso,lamin,idsin * / cst203 /therdi(m8,m9),therlm(m7,m6,k9) * / cst10 /iff(2),idss(h5),ifug,ifyn,isyn * / cst20 /comps(k1,k5)/ cst8 /names(k1) * / cst204 /ltyp(k1),lmda(k1),idis(k1) * / cst6 /icomp,istct,iphct,icp/ cst42 /icin(k5),idbase * / cst61 /ikp(k1),ivarrx(k2),ivarip(k3),isudo,ivar * / cst5 /p,t,xco2,u1,u2,tr,pr,r,ps/ cst12 /cp(k6,k1) * / cst40 /ids(h5,h6),isct(h5),icp1,isat,io2 * / cst88 /vu(2,k1),jprct,jmct,jmyn * / cst300 /cblk(nb,k5),atw(k1),vol(k1),iblk,jcby,jcth c eliminate end-member compositions do 10 i = 1, isp(1) call zchk (z(1,i),tname) do 20 j = 1, isp(2) call zchk (z(2,j),tname) do 30 k = 1, isp(3) call zchk (z(3,k),tname) 30 if (z(1,i)*z(2,j)*z(3,k).gt.0.999) goto 999 20 continue 10 continue c eliminate out of range compositions: c is this necessary? do 50 i = 1, isite if (imd(i).gt.0) goto 50 do 60 j = 1, isp(i) - 1 60 if (z(i,j).gt.xmx(i,j).or.z(i,j).lt.xmn(i,j)) goto 999 50 continue c the composition is acceptable. iphct = iphct + 1 jltyp = -1 if (iphct.gt.k1) call error (180,z(1,1),k1,'PRIME9') ikp(iphct) = isolct idis(iphct) = 0 lmda(iphct) = 0 c encode a name if (isite.eq.1) then if (isp(1).eq.2) then if (z(1,1).eq.1.0) then write (names(iphct),1050) names(imsol(1,1,1)),100 else if (z(1,1).ge.0.04.and.z(1,1).le.0.96) then write (names(iphct),1030) names(imsol(1,1,1)), * idint(1.d2*z(1,1)) else write (names(iphct),1070) names(imsol(1,1,1)), * 100.*z(1,1) end if else c ternary solutions write (names(iphct),1040) names(imsol(1,1,1)), * idint(z(1,1)*1.d2),names(imsol(2,1,1)),idint(z(1,2)*1.d2) end if else if (isite.eq.2.and.isp(1).eq.2.and.isp(2).eq.2) then int1 = idint (1.d2*z(1,1)) int2 = idint (1.d2*z(2,1)) if (int1.gt.99) int1 = 99 if (int2.gt.99) int2 = 99 write (names(iphct),1020) names(imsol(1,1,1)),int1,int2 else c this is a pretty shitty name c but for the time being your going to c have live with it. write (names(iphct),1010) ((idint(1.d1*z(i,j)), * j = 1, isp(i) - 1), i = 1, isite) write (n3,1000) names(iphct),(((z(1,i)*z(2,j)*z(3,k), * names(imsol(i,j,k)),i=1,isp(1)), * j=1,isp(2)), * k=1,isp(3)) end if c get blanks out of name: call unblnk (names(iphct),8) c initialize constants: smix = 0.0 esum = 0. do 140 i = 1, k4 140 thermo(i,iphct) = 0. do 150 i = 1, icomp 150 comps(iphct,i) = 0. c load constants: do 160 i = 1, isp(1) if (z(1,i).eq.0.) goto 160 do 170 j = 1, isp(2) if (z(2,j).eq.0.) goto 170 do 180 k = 1, isp(3) if (z(3,k).eq.0.) goto 180 zp = z(1,i)*z(2,j)*z(3,k) id = imsol(i,j,k) esum = esum + zp * ecoef(i,j,k) do 200 l = 1, icomp 200 comps(iphct,l) = comps(iphct,l) + zp * comps(id,l) do 210 l = 1, k4 210 thermo(l,iphct) = thermo(l,iphct) * + zp * thermo(l,id) c t dependent disordering: if (idis(id).ne.0) then idsin = idsin + 1 idis(iphct) = idsin do 330 l = 1, 7 330 therdi(l,idsin) = zp * therdi(l,id) do 340 l = 8, 9 340 therdi(l,idsin) = therdi(l,id) end if c lamda-like transitions: ld = lmda(id) if (ld.ne.0) then if (jltyp.eq.-1) lamin = lamin + 1 jltyp = jltyp + 1 ltyp(iphct) = ltyp(id) lmda(iphct) = lamin ld = lmda(id) if (ltyp(id).eq.1) then c ubc-approach: do 350 l = 1, 3 therlm(1,l,lamin) = therlm(1,l,ld)*zp therlm(2,l,lamin) = therlm(2,l,ld)*zp therlm(3,l,lamin) = therlm(3,l,ld) therlm(4,l,lamin) = therlm(4,l,ld) therlm(5,l,lamin) = therlm(5,l,ld)*zp therlm(6,l,lamin) = therlm(6,l,ld)*zp therlm(7,l,lamin) = therlm(7,l,ld) 350 therlm(8,l,lamin) = therlm(8,l,ld)*zp c else if (ltyp(id).lt.8) then c helgeson approach: if (ltyp(id).gt.4.and.ltyp(id).lt.7) then jlam = ltyp(id) - 3 else jlam = 1 end if do 365 m = 1, jlam therlm(1,m,lamin) = therlm(1,m,ld) therlm(2,m,lamin) = therlm(2,m,ld) do 360 l = 3, 8 360 therlm(l,m,lamin) = therlm(l,m,ld)*zp 365 continue else if (ltyp(id).eq.10) then c holland and powell landau model: h = jltyp + 1 therlm(1,h,lamin) = therlm(1,1,ld) therlm(1,h,lamin) = therlm(1,2,ld)*zp end if end if 180 continue 170 continue 160 continue c compute ideal configurational negentropy: if (nsite.eq.0.and.ist(1).ne.0) then do 220 i = 1, isite do 230 j = 1, isp(i) 230 if (z(i,j).ne.0.0) smix = * smix + float(ist(i))*z(i,j)*dlog(z(i,j)) 220 continue else if (nsite.ne.0) then call omega (z,dlnw,tname) smix = -dlnw + esum end if c save it: thermo(2,iphct) = thermo(2,iphct) + r * smix c load excess terms: if (iterm.ne.0) then do 240 i = 1, iterm zp = 1.0 do 250 j = 1, iord if (isub(i,j,1).eq.0) goto 250 zp = zp * z(isub(i,j,1),isub(i,j,2)) 250 continue do 260 j = 1, 11 260 thermo(j,iphct) = thermo(j,iphct) + zp * wg(i,j) 240 continue end if write (n2,1060) names(iphct),idbase,0,ltyp(iphct), * idis(iphct),tname write (n2,1080) (comps(iphct,i),i=1,icomp) write (n2,1090) (thermo(j,iphct),j=1,k4) if (ltyp(iphct).ne.0) then c determine number of transitions from c flag ilam: jlam=ilam if (ilam.gt.3) jlam = ilam-3 if (ilam.gt.6) jlam = ilam-6 if (ilam.gt.9) jlam = ilam-9 do 1 i= 1, jlam 1 write (n2,1090) (therlm(j,i,lamin), j = 1, m7) end if if (idis(iphct).ne.0) then write (n2,1090) (therdi(i,idsin),i=1,m8) end if 1000 format (' icky name ',a8,' = ',4(4(f5.3,1x,a4,1x),/)) 1010 format (8i1) 1020 format (a2,i2,'-',i2) 1030 format (a2,i2) 1040 format (a1,i2,a1,i2) 1050 format (a2,i3) 1060 format (a8,i2,i2,i2,i2,1x,a10) 1070 format (a2,f4.1) 1080 format (12(f5.2,1x)) 1090 format (5(g13.7,1x)) 999 end subroutine input9 c----------------------------------------------------------------------- c given a list of solution phase names (fname(h9)) input9 searches a c data file (on unit n9) for the relevant data and subdivides the c solutions into pseudo-compounds. c----------------------------------------------------------------------- implicit double precision (a-g,o-z),integer (h-n) parameter (k1=1200,k2=1200,k3=1200,k4=16, * j9=1200,h5=7,h9=18,m0=5) character*10 tname, uname(2)*8, sname(h9), fname, names*8 character*1 yes double precision z(3,3) common/ cst108 /wg(27,11),xmn(3,3),xmx(3,3),xnc(3,3),xfx(3), * iend(4,3,3),isub(27,9,2),imd(3),imsol(4,3,3), * ijk(3),insp(3,4),jsp(3),jsitp(3),iosp(3), * jst(3),jfix,idfc(3),ist(3),isp(3),isite, * ispct(3,4),jnsp(3,4),jsite,iterm,iord * / cst86 /xy(2,k1),y(k1,3,2),ntot,npairs/ cst8 /names(k1) * / cst107 /a0(5,5),acoef(5,5,m0),smult(5),ecoef(3,3,3), * nsite,nspm1(5),nterm(5,5), * nsub1(5,5,m0,4),nsub2(5,5,m0,4),nttyp(5,5,m0) * / cst60 /iasmbl(j9),ipoint,imyn/ csta7 /fname(h9) common/ cst41 /n1,n2,n3,n4,n5,n6,n7,n8,n9,io3,io4,io5,io9 * / cst79 /isoct/ cst6 /icomp,istct,iphct,icp * / cst1 /thermo(k4,k1),vf(2,k1),vs(h5,k1),uf(2),us(h5) * / cst61 /ikp(k1),ivarrx(k2),ivarip(k3),isudo,ivar save uname data uname/' ',' '/ c----------------------------------------------------------------------- c set compound counter ipoint. ipoint = iphct rewind (n9) c no request for solutions, goto 999: goto (999),io9 c initialize match flag: im = 0 c read the solution name 10 call rmodel (tname,istot) if (istot.eq.0) goto 99 c check the solution model: call cmodel (im,idsol,tname,istot,jstot,0,uname(1),uname(2)) if (jstot.eq.0) goto 10 c if (jstot.lt.istot) then c if ok, determine a valid c endmember subset. call emodel (tname,istot) c edit model parameters: if (istot.eq.0) then c couldn't revise model im = im - 1 goto 10 end if call nmodel end if c save found solutions: sname(im) = tname c if nsite ne 0 get "normalization" c constants for entropy model: if (nsite.ne.0) call snorm (tname) c generate pseudocompound compositions. c subdiv returns the total c number of pseudocompounds (ipcps) and c array y, of which element y(h,i,j) is c the site fraction of the jth species on c the ith site of the hth pseudocompound. call subdiv (tname) c load default site fractions c into the unused sites of the c site fraction array: if (isite.lt.3) then do 20 i = isite + 1, 3 z(i,1) = 1.0 z(i,2) = 0.0 20 z(i,3) = 0.0 end if write (*,1050) tname read (*,1060) yes if (yes.ne.'Y'.and.yes.ne.'y') then c subdiv generates ntot compositions, c generate the compound data for c each solution: do 30 h = 1, ntot c load the composition into c a the site fraction array: do 40 i = 1, isite zt = 0.0 do 50 j = 1, isp(i) - 1 z(i,j) = y(h,i,j) 50 zt = zt + z(i,j) 40 z(i,isp(i)) = 1. - zt c generate the pseudocompound: call soldme (z,idsol,tname) 30 continue else 80 do 60 i = 1, isite zt = 0.0 do 70 j = 1, isp(i) - 1 write (*,1070) j,i read (*,*) z(i,j) 70 zt = zt + z(i,j) 60 z(i,isp(i)) = 1. - zt call soldme (z,idsol,tname) write (*,1080) tname read (*,1060) yes if (yes.eq.'y'.or.yes.eq.'Y') goto 80 end if if (im.eq.isoct) goto 999 c next solution goto 10 c at least one solution phase referenced c in the input is not included in the c solution phase data file, write warning: 99 call warn (43,zt,isoct-im,'INPUT9') c 1000 format (/,' the following solution models will be', * ' considered:',/) 1010 format (7(2x,a10)) 1020 format (/,' Of the requested solution models:',/) 1030 format (' **warning ver044** a solution model has destabilized', * ' the endmember: ',a8,' (iend=2)',/) 1040 format (/,' no models will be considered.',/) 1050 format (/,' Enter ',a10,' compositions yourself (y/n)?',/) 1060 format (a1) 1070 format (/,' Enter site fraction of species ',i1,' on site ',i1) 1080 format (/,' Make another ',a10,' pseudocompund (y/n)?',/) 999 end