program build c---------------------------------------------------------------------- c ************************ c * * c * build.mar.10.1991 * c * * c ************************ c---------------------------------------------------------------------- c build is a fortran program which interactively creates the input c file read from unit n1 by the vertex program. build reads data c from three sources n2, *, and n9. the output file is written to c unit n1 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-n) parameter (k0=25,k1=5000,k4=22,k5=12,h5=7, * h8=100,h9=30,i9=90,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, * names,uname(k0),fname(h9)*10,tname(i9)*10 character*5 mname(k5),nname(k5),oname(k5),qname(k0),pname(k5) integer icout(k0), jc(k5) double precision cblk(k5) common/ cst6 /icomp,istct,iphct,icp/ cst8 /names(k1) * / cst207 /ctrans(k0,k5),ictr(k5),itrans/ cst60 /ipoint,imyn * / csta2 /xname(k5),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)/ cst41a /n2name * / cst100 /dlnfo2,elag,gz,gy,gx,ibuf,hu,hv,hw,hx * / cst41 /n1,n2,n3,n4,n5,n6,n7,n8,n9,io3,io4,io5,io9 * / cst37 /iprct,ixct,iexyn,istbyn * / cst59 /istbct,idst(10,5),ister(10)/ cst36 /exname(h8) * / 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 iprct = 0 iexyn = 0 isudo = 1 ifugy = 0 im = 0 jfix = 0 do 16 i = 1, 5 iv(i) = i vmin(i) = 0.0 vmax(i) = 0.0 16 dv(i) = 1.0 do 71 i = 1, h9 71 fname(i) = blnk10 do 1 i= 1, k5 mname(i) = blank5 oname(i) = blank5 nname(i) = blank5 1 qname(i) = blank5 do 2 i = 1, h8 2 exname(i) = blank8 n5name = blnk10 n4name = blnk10 n3name = blnk10 isct=0 jbulk = 0 imct=1 ifct=1 io3 = 1 io3p = 1 io4 = 1 c card 2: 5003 write (*,2020) read (*,*,iostat=ier) icopt call rerror (ier,*5003) if (icopt.eq.2) then 6001 write (*,7110) read (*,3030) y jbulk = 1 icopt = 0 if (y.eq.'Y'.or.y.eq.'y') then write (*,7140) read (*,*,IOSTAT=IER) jbulk call rerror (IER,*6001) if (jbulk.gt.2.or.jbulk.lt.1) goto 6001 if (jbulk.eq.1) then icopt = 3 else if (jbulk.eq.2) then icopt = 1 end if end if end if c card 1: write (*,2000) ' print ' read (*,3030) y if (y.eq.'Y'.or.y.eq.'y') then io3 = 0 if (icopt.eq.1) then c print file format, only an c option on SPDP's write (*,1200) read (*,3030) y if (y.eq.'Y'.or.y.eq.'y') io3p = 0 end if end if write (*,2000) 'graphics' read (*,3030) y if (y.eq.'Y'.or.y.eq.'y') io4 = 0 io5 = 1 c write (*,2000) ' list ' c read (*,*) io5 write (n1,1280) io3,io4,io5, * 'print, plot, & phase field file flags' if (io3.eq.0) then write (*,2010) ' print ' read (*,3040) n3name end if if (io4.eq.0) then write (*,2010) 'graphics' read (*,3040) n4name end if if (io5.eq.0) then write (*,2010) ' list ' read (*,3040) n5name end if write (n1,3040) n3name,'print file name' write (n1,3040) n4name,'plot file name' write (n1,3040) n5name,'list file name' c security level isec = 3 ifull = 0 imsg = 0 if (icopt.eq.1) then 7001 write (*,7000) read (*,7010,iostat=ier) isec call rerror (ier,*7001) if (isec.gt.5.or.isec.lt.1) isec = 3 end if if (icopt.ne.0) then write (*,7090) read (*,3030) y if (y.eq.'Y'.or.y.eq.'y') then ifull = 1 call warn (174,r,ifull,n3name) write (*,7120) read (*,3030) y if (y.eq.'Y'.or.y.eq.'y') ifull = 2 write (*,7100) read (*,3030) y if (y.eq.'Y'.or.y.eq.'y') ifull = ifull + 2 end if write (*,7130) read (*,3030) y if (y.eq.'Y'.or.y.eq.'y') imsg = 1 end if write (*,7030) read (*,3030) y jpot = 1 if (y.eq.'Y'.or.y.eq.'y') jpot = 0 jtest = 1 write (n1,1290) icopt, isec, jpot, jtest, ifull, imsg, * io3p,' icopt, isec, jpot, jtest, ifull, imsg, io3p' c Read THERMODYNAMIC DATA (N2) c and do component transformations: call topn2 (3, icmpn) c Component stuff: c--------------------------------------------------------------------- write (n1,1300) itrans, icmpn, * 'number of component transformations, c' if (itrans.gt.0) then do 711 i = 1, itrans write (n1,1120) cmpnt(ictr(i)), ictr(i) 711 write (n1,1125) (ctrans(j,i), j = 1, icmpn) end if c----------------------------------------------------------------------- IVCT=2 JCMPN = ICMPN do I = 1, ICMPN uname(i) = cmpnt(i) qname(i) = cmpnt(i) end do c components of saturated phase: PHASE=' FLUID ' 91 write (*,2030) PHASE,cmpnt(IDH2O),cmpnt(IDCO2),VNAME(3) read (*,3030) y IV(5)=3 ifyn = 0 if (y.eq.'y'.or.y.eq.'Y') then 5005 write (*,2022) PHASE read (*,*,iostat=ier) ifct if (ifct.gt.2.or.ifct.lt.1) then call warn (17,r,i,'BUILD') goto 5005 end if call rerror (ier,*5005) ifyn = 1 if (ifct.eq.1) then write (*,2120) read (*,3000) (mname(i),i=1,ifct) if (mname(1).eq.cmpnt(idh2o)) then vmax(3) = 0d0 else vmax(3) = 1d0 end if vmin(3) = vmax(3) else mname(1)=cmpnt(idh2o) mname(2)=cmpnt(idco2) iv(3)=3 ivct = ivct + 1 end if jcmpn=0 do 6 i=1,icmpn do j=1,ifct if (cmpnt(i).eq.mname(j)) goto 6 end do jcmpn = jcmpn+1 qname(jcmpn) = cmpnt(i) 6 continue if (icmpn-jcmpn.ne.ifct) then write (*,2300) goto 91 end if end if c saturated components call rename (jcmpn,qname,1,*92) 92 write (*,2110) read (*,3030) y if (y.eq.'Y'.or.y.eq.'y') then 5007 write (*,2032) (QNAME(I),I=1,JCMPN) write (*,2031) h5+1 read (*,*,IOSTAT=IER) isct if (isct.gt.h5) call error (16,r,h5,'BUILD') if (isct.gt.1) call warn (15,r,i,'BUILD') call rerror (IER,*5007) write (*,2021) read (*,3000) (NNAME(I),I=1,isct) IT=0 do 8 I = 1, JCMPN do J = 1, isct if (QNAME(I).EQ.NNAME(J)) goto 8 end do IT=IT+1 ICOUT(I) = 1 QNAME(IT)=QNAME(I) 8 CONTINUE do j = 1, isct if (nname(j).eq.uname(idh2o).or. * nname(j).eq.uname(idco2)) call error (18,r,i,nname(j)) end do if (JCMPN-IT.ne.isct) call rename (jcmpn,qname,0,*92) JCMPN=IT end if c mobile components: call rename (jcmpn,qname,1,*93) 93 write (*,2040) read (*,3030) y if (y.eq.'y'.or.y.eq.'Y') then write (*,2200) 5009 write (*,2050) (QNAME(I),I=1,JCMPN) write (*,2051) read (*,*,IOSTAT=IER) IMCT call rerror (IER,*5009) write (*,2021) read (*,3000) (ONAME(I),I=1,IMCT) IT=0 do 10 I=1,JCMPN do J=1,IMCT if (QNAME(I).EQ.ONAME(J)) goto 10 end do IT=IT+1 QNAME(IT)=QNAME(I) 10 CONTINUE if (JCMPN-IT.ne.IMCT) call rename (jcmpn,qname,0,*93) JCMPN=IT do i = 1, imct write (VNAME(3+i),5000) 'U(',ONAME(i),')' ivct = ivct + 1 end do end if if (ifCT.EQ.2) then IV(4)=4 IV(5)=5 else IV(3)=4 IV(4)=5 end if c Thermodynamic components: do i = 1, k5 cmpnt(i) = blank5 end do 94 write (*,2070) (qname(i),i=1,jcmpn) 5010 write (*,2060) jcmpn read (*,*,iostat=ier) itct call rerror (ier,*5010) icp = itct if (itct.lt.1.or.itct.gt.k5) then call warn (19,r,k5,'build') goto 94 end if write (*,2021) read (*,3000) (cmpnt(i),i=1,itct) i1 = 0 i2 = 0 do 31 i = 1, itct if (cmpnt(i).eq.uname(idh2o).or. * cmpnt(i).eq.uname(idco2)) then call warn (16,r,i,cmpnt(i)) ifugy = ifugy + 1 if (cmpnt(i).eq.uname(idh2o)) i1 = i end if do j = 1,jcmpn if (qname(j).eq.cmpnt(i)) goto 31 end do write (*,2310) cmpnt(i) goto 94 31 continue if (ifugy.gt.0) then itic = 0 if (i1.ne.0) then crap = cmpnt(1) cmpnt(1) = cmpnt(i1) cmpnt(i1) = crap itic = itic + 1 end if do 73 i = 1, itct 73 if (cmpnt(i).eq.uname(idco2)) i2 = i if (i2.ne.0) then itic = itic + 1 crap = cmpnt(itic) cmpnt(itic) = cmpnt(i2) cmpnt(i2) = crap end if end if c Write the slections to n1: write (n1,4000) (cmpnt(I),I=1,k5),'Thermodynamic comps' write (n1,4000) (NNAME(I),I=1,k5),'Sat components' write (n1,4000) (MNAME(I),I=1,k5),'Sat phase comps' write (n1,4000) (ONAME(I),I=1,k5),'Mobile components' c constrained bulk composition data: if (jbulk.ne.0) then c now components: icth = icp + isct write (*,1380) jcth = 0 do i = 1, icp pname(i) = cmpnt(i) end do if (isct.ne.0) then do i = icp + 1, icp + isct pname(i) = nname(i-icp) end do end if c determine the indices of the selected c components in the data base array: do 20 i = 1, icth do j = 1, icmpn if (uname(j).eq.pname(i)) then jc(i) = j goto 20 end if end do 20 continue do i = 1, icth write (*,1430) pname(i) read (*,3030) y if (y.eq.'Y'.or.y.eq.'y') then jcth = jcth + 1 else goto 6040 end if end do 6040 if (jcth.eq.0) iblk = 0 write (n1,*) jcth,' # of constrained components' c ask if weight fraction, otherwise c use molar fractions. write (*,1420) read (*,3030) y iwt = 0 if (y.eq.'Y'.or.y.eq.'y') iwt = 1 c get the bulk composition: 5041 if (iwt.eq.0) then write (*,1390) else write (*,1440) end if write (*,1400) (pname(j), j = 1, jcth) write (*,1410) read (*,*,iostat=ier) (cblk(j), j = 1, jcth) call rerror (ier,*5041) if (iwt.eq.1) then do i = 1, jcth cblk(i) = cblk(i)/atwt(jc(i)) end do end if write (n1,*) (cblk(j), j = 1, jcth) else write (n1,*) '0 no constraints on bulk comp.' end if c figure out remaining components it=0 do 37 i = 1, jcmpn do 202 j = 1, itct 202 if (qname(i).eq.cmpnt(j)) goto 37 it = it + 1 qname(it) = qname(i) 37 continue icp = 0 do 33 i = 1, icmpn icout(i) = 0 do 203 j = 1, it 203 if (qname(j).eq.uname(i)) goto 33 icp = icp + 1 icin(icp) = i icout(i) = 1 33 continue c get fluid equation of state if (ifyn.ne.0.or.ifugy.ne.0) call rfluid (1,ifug,n3) c get consistent phases iphct = 0 write (*,1140) 35 call getphi (name,ibase,icmpn,*34) call chkphi (1,name,icout,ibase,icmpn,*35) iphct = iphct + 1 names(iphct) = name goto 35 c Excluded phases: 34 write (*,2080) read (*,3030) y if (y.eq.'Y'.or.y.eq.'y') then write (*,2034) read (*,3030) y if (y.ne.'y'.and.y.ne.'Y') then 5012 write (*,2033) h8 + 1 read (*,*,iostat=ier) ixct call rerror (ier,*5012) write (*,2090) read (*,2100) (exname(i),i=1,ixct) else ixct = 0 do 204 i = 1, iphct write (*,1130) names(i) read (*,3030) y if (y.eq.'Y'.or.y.eq.'y') then ixct = ixct + 1 if (ixct.gt.h8) call error (13,r,h8,'BUILD') exname(ixct) = names(i) end if 204 continue end if end if write (n1,4010) (exname(i), i = 1, h8) c eliminate composition variable c for saturated fluid if constrained c fugacity EoS is used: if (ifug.ge.7.and.ifug.le.9.and.ifct.gt.1) ivct = ivct - 1 c Independent variables: if (icopt.eq.1.or.icopt.eq.2) then c Select the x variable (IV(1)): write (*,2111) 5013 write (*,2140) (j,vname(iv(j)), j = 1, ivct) read (*,*,iostat=ier) ic call rerror (ier,*5013) if (ic.gt.ivct.or.ic.lt.1) then write (*,1150) goto 5013 end if ix = iv(1) iv(1) = iv(ic) iv(ic) = ix 5014 write (*,2150) vname(iv(1)) read (*,*,iostat=ier) vmin(iv(1)),vmax(iv(1)) call rerror (ier,*5014) c select the y variable (iv(2)): if (ivct.gt.2) then write (*,2130) 5015 write (*,2140) (j,vname(iv(j)), j = 2, ivct) read (*,*,iostat=ier) ic call rerror (ier,*5015) if (ic.gt.ivct.or.ic.lt.1) then write (*,1150) goto 5015 end if else ic=2 end if ix = iv(2) iv(2) = iv(ic) iv(ic) = ix 5016 write (*,2150) vname(iv(2)) read (*,*,iostat=ier) vmin(iv(2)),vmax(iv(2)) call rerror (ier,*5016) c define default variable increments: do 13 i = 1, 2 13 dv(iv(i)) = (vmax(iv(i)) - vmin(iv(i))) / 40.0 c specify sectioning variables (iv(3)): if (ivct.gt.2) then c check if multiple sections are desired: write (*,2160) read (*,3030) y c if (y.eq.'y'.or.y.eq.'Y') then c Select sectioning variable: if (ivct.gt.3) then write (*,2170) 5018 write (*,2140) (j,vname(iv(j)), j = 3, ivct) read (*,*,iostat=ier) ic call rerror (ier,*5018) if (ic.gt.ivct.or.ic.lt.1) then write (*,1150) goto 5018 end if ix = iv(3) iv(3) = iv(ic) iv(ic) = ix end if 5019 write (*,2150) vname(iv(3)) read (*,*,iostat=ier) vmin(iv(3)),vmax(iv(3)) call rerror (ier,*5019) 5020 write (*,2035) read (*,*,iostat=ier) ic call rerror (ier,*5020) del = vmax(iv(3)) - vmin(iv(3)) if (ic.lt.2.or.del.le.0.) then dv(iv(3)) = 1. vmax(iv(3)) = vmin(iv(3)) else dv(iv(3)) = del / float(ic - 1) end if c Specify remaining sectioning constraints: if (ivct.gt.3) then do 14 j = 4, ivct 5021 write (*,2180) vname(iv(j)) read (*,*,iostat=ier) vmin(iv(j)) call rerror (ier,*5021) vmax(iv(j)) = vmin(iv(j)) 14 dv(iv(j)) = 1. end if c Only one section is to be calculated: else do 17 j= 3, ivct 5022 write (*,2180) vname(iv(j)) read (*,*,iostat=ier) vmin(iv(j)) call rerror (ier,*5022) vmax(iv(j)) = vmin(iv(j)) 17 dv(iv(j)) = 1. end if end if else if (icopt.eq.3) then c select the y variable (iv(1)): write (*,2210) 5023 write (*,2140) (j,vname(iv(j)), j = 1, ivct) read (*,*,iostat=ier) ic call rerror (ier,*5023) if (ic.gt.ivct.or.ic.lt.1) then write (*,1150) goto 5023 end if ix = iv(1) iv(1) = iv(ic) iv(ic) = ix 5024 write (*,2150) vname(iv(1)) read (*,*,iostat=ier) vmin(iv(1)),vmax(iv(1)) call rerror (ier,*5024) c define default variable increment: dv(iv(1)) = (vmax(iv(1)) - vmin(iv(1))) / 40.0 c specify sectioning variable (iv(2)): c check if multiple sections are desired: write (*,2220) read (*,3030) y C if (y.eq.'Y'.or.y.eq.'y') then c Select sectioning variable: if (ivct.gt.2) then write (*,2170) 5026 write (*,2140) (j,vname(iv(j)), j = 2, ivct) read (*,*,iostat=ier) ic call rerror (ier,*5026) if (ic.gt.ivct.or.ic.lt.1) then write (*,1150) goto 5026 end if ix = iv(2) iv(2) = iv(ic) iv(ic) = ix end if write (*,2150) vname(iv(2)) read (*,*,iostat=ier) vmin(iv(2)),vmax(iv(2)) 5027 write (*,2035) read (*,*,iostat=ier) ic call rerror (ier,*5027) ddv = vmax(iv(2))-vmin(iv(2)) if (ddv.eq.0.) then dv(iv(2)) = 0. else dv(iv(2)) = ddv / (ic-1.) end if c specify remaining sectioning constraints: if (ivct.gt.2) then do 23 j=3,ivct 5028 write (*,2180) vname(iv(j)) read (*,*,iostat=ier) vmin(iv(j)) call rerror (ier,*5028) vmax(iv(j)) = vmin(iv(j)) 23 dv(iv(j)) = 1. end if c only one section is to be calculated: else do 24 j=2,ivct 5029 write (*,2180) vname(iv(j)) read (*,*,iostat=ier) vmin(iv(j)) call rerror (ier,*5029) vmax(iv(j)) = vmin(iv(j)) 24 dv(iv(j)) = 1. end if end if c check that X(O) is not 0 or 1 c for fluid speciation routines: if (ifyn.eq.1.and.(ifug.ge.10.and.ifug.ne.13.and.ifug.ne.14 * .and.ifug.ne.15.and.ifug.ne.18)) then if (vmin(3).eq.vmax(3)) then if (vmin(3).lt.0.000001) then vmin(3) = 0.000001 vmax(3) = vmin(3) else if (vmin(3).gt.0.999999) then vmin(3) = 0.999999 vmax(3) = vmin(3) end if else if (vmin(3).lt.0.000001) vmin(3) = 0.000001 if (vmax(3).gt.0.999999) vmax(3) = 0.999999 end if end if c output variable choices and values: write (n1,4020) (vmax(i), i= 1, 5),'max p, t, xco2, u1, u2' write (n1,4020) (vmin(i), i= 1, 5),'min p, t, xco2, u1, u2' write (n1,4020) (dv(i), i= 1, 5),'increment p, t, xco2, u1, u2' write (n1,1310) (iv(i), i = 1, 5),'iv1, iv2, iv3, iv4, iv5' c output data base choice: write (n1,1320) idbase,'idbase data base code' c output saturated phase eos choice: if (ifyn.eq.0.and.ifugy.eq.0) then write (n1,1320) 0,'ifug equation of state for saturated phase' else write (n1,1320) ifug, * 'ifug equation of state for saturated phase' if (ifug.ge.7.and.ifug.le.12.and.ifug.ne.9.or. * ifug.eq.14.or.ifug.eq.16.or.ifug.eq.17) * write (n1,1330) ibuf, hu, dlnfo2, elag, * 'ibuf, ipro, dlnfo2, ln(ag)' if (ibuf.eq.5) write (*,4020) buf,'a-e' end if c --------------------- c read solution phases. c --------------------- n9name = ' ' write (*,2500) read (*,3030) y if (y.ne.'y'.and.y.ne.'Y') then write (n1,4500) fname write (n1,3040) n9name,'solution model data file' else c get the file containing the solution models 18 write (*,3010) read (*,3040) n9name write (*,*) ' ' 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 if (ifugy.eq.0) then b1 = uname(idh2o) b2 = uname(idco2) else b1 = ' ' b2 = ' ' end if 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 c if (jfix.eq.0) goto 110 c write (*,1190) tname(ict),(zname(idfx(i)),xfx(i),i=1,jfix) c write (*,1195) n9name goto 110 90 if (ict.eq.0) then write (*,7040) write (n1,4500) fname write (n1,3040) n9name,' Solution model data file name' else write (*,2510) write (*,2520) (tname(i), i = 1, ict) write (*,*) isct=1 191 read (*,2530) fname(isct) if (fname(isct).eq.blnk10) goto 192 do 193 i = 1, ict 193 if (fname(isct).eq.tname(i)) goto 194 write (*,*) fname(isct),' is not a valid name, try again' goto 191 194 isct = isct + 1 if (isct.gt.h9) call error (25,r,h9,'BUILD') goto 191 192 write (n1,4500) fname write (n1,3040) n9name,' Solution model data file name' if (icopt.eq.1.or.icopt.eq.2.and.isct.gt.1.and. * jcth.eq.0) then c allow setting of variance flag c only for icopt 1 or 2. write (*,7060) read (*,3030) Y if (y.eq.'y'.or.y.eq.'Y') isudo = 0 else isudo = 0 end if end if end if write (n1,1320) isudo,' ISUDO variance flag' c Write a title card: write (*,7070) read (*,6000) title write (n1,6000) title c get conditions for composition c diagrams: if (icopt.eq.0) then 5035 write (*,7080) read (*,*,iostat=ier) ict call rerror (ier,*5035) do 200 i = 1, ict write (*,6020) (vname(iv(j)),j=1,ivct) 5036 write (*,6010) i read (*,*,iostat=ier) (vmin(iv(j)),j=1,ivct) call rerror (ier,*5036) 200 write (n1,1340) vmin write (n1,1340) -9999.,0.,0.,0.,0. end if endfile (n1) close (n1) 999 stop c190 call error (21,r,i,n2name) 1120 format (a5,1x,i2,' component transformation') 1125 format (13(f6.2,1x)) 1130 format (' Exclude ',a8,' (Y/N)? ') 1140 format (/,' working...',/) 1150 format (/,' huh? ',/) 1190 format (/,' In solution ',a10,' the following', * ' endmembers have fixed compositions:',//, * 4(2x,a8,' X = ',g12.6) ) 1195 format (/,' To relax or change these constraints', * ' modify ',a14,'.'/) 1200 format (' Long print file format (Y/N)? ') 1280 format (3(i2,1x),6x,a60) 1290 format (7(i2,1x),a59) 1300 format (2(i2,1x),8x,a60) 1310 format (5(i2,1x),2x,a60) 1320 format (i2,11x,a60) 1330 format (i2,1x,i2,1x,g13.6,1x,g13.6,1x,a26) 1340 format (5(g13.6,1x)) 1350 format (' Constrained bulk compositions (y/n)? ') 1380 format (/,' You will now be prompted for each component to', * ' be constrained.',/,' Answering no at any point', * ' will complete the set of constraints.', * /,' The prompts are for thermodynamic components,', * ' followed by',/,' saturated components, in the ', * ' order you entered them above.',/, * ' For example, to constrain Fe:Mg', * ' enter FEO and MGO as the first two',/, * ' thermodynamic components, and specify', * ' the relative amounts of both.',/) 1390 format (' Enter molar proportions of the components:') 1400 format (2x,12(a5,1x)) 1410 format (' for the bulk composition of interest:') 1420 format (' Specify constraints by weight proportion (Y/N)?') 1430 format (' Constrain component ',a5,' (Y/N)? ') 1440 format (' Enter weight proportions of the components:') 2000 format (' Do you want a ',a8,' file (Y/N)? ') 2010 format (' Enter ',a8,' file name, <15 characters,' * ,' left justified: ') 2020 format (//,' Specify type of calculation:',//, * ' 0 - Composition diagram',/, * ' 1 - Schreinemakers-type diagram',/, * ' 2 - Constrained bulk compositions',/, * ' 3 - Mixed-variable diagram',/) 2021 format (' Enter component names, left justified, 1 per line:') 2022 format (' Enter number of components in the ',a8,/, * ' (1 or 2 for COH fluids): ') 2030 format (' Calculations with a saturated phase', * ' (Y/N)?',/,' The phase is: ',A8,/, * ' Its components can be: ',A5,' ',A5,/ * ' Its compositional variable is: ',A8) 2031 format (' How many saturated components (<',i1,')? ') 2032 format (' Select saturated components from the set:'/ * ,3(12(1X,A5))) 2033 format (' How many phases do you want to exclude (<',i3,')? ') 2034 format (' Do you want to be prompted for phases (Y/N)? ') 2035 format (' Enter the number of sections (>1): ') 2040 format (' Use chemical potentials as independent variables' * ' (Y/N)? ') 2050 format (' Select "mobile" components from the set:',/ * ,3(12(1X,A5))) 2051 format (' How many "mobile" components (<3)? ') 2060 format (' How many thermodynamic components (<',i2,')? ') 2070 format (' Select thermodynamic components from the' * ,' set:',/,3(12(1X,A5))) 2080 format (' Exclude phases (Y/N)? ') 2090 format (' Enter phases, left justified, one per line:') 2100 format (A8) 2110 format (' Calculations with saturated components (Y/N)? ') 2111 format (' Select x-axis variable:') 2120 format (' Enter component name, left justified: ') 2130 format (' Select y-axis variable:') 2140 format (10X,I1,' - ',A8) 2150 format (' Enter minimum and maximum values, respectively,', * ' for: ',A8) 2160 format (' Calculate sections as a function of a', * ' third variable (Y/N)? ') 2170 format (' Select sectioning variable:') 2180 format (' Specify sectioning value for: ',A8) 2210 format (' Select vertical axis variable: ') 2220 format (' Calculate sections as a function of a', * ' second variable (Y/N)? ') 2500 format (' Do you want to treat solution phases (Y/N)? ') 2200 format (' NOTE: The potential of a component,', * ' i.e. a "mobile component,"',/, * ' is symbolized, here and in VERTEX, by an uppercase U', * ' followed by the component',/, * ' name enclosed in parentheses, e.g. the', * ' potential of A is written U(A).',/) 2300 format (//,' You made a mistake, try again.',/ * ' Check spelling and upper/lower case matches.',//) 2310 format (/,1x,A5,' is invalid',/ * ' Check spelling and upper/lower case matches.',//) 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) 3000 format (A5) 4000 format (12(A5,1X),a20) 4010 format (6(A8,1X),'Excluded phases') 4020 format (2(g11.5,1x),f10.8,1x,2(g11.5,1x),a35) 4500 format (10(a10,1x),' Solutions') 5000 format (A2,A5,A1) 6000 format (A72) 6020 format (' Specify values for :',/,(10X,5(A8,2X))) 6010 format (' For calculation number ',I1) 7000 format ( * ' Specify reliability level [1-5, default is 3]:',/, * ' 1 - gives lowest efficiency, highest reliability',/ * ' 5 - gives highest efficiency, lowest reliability',/ * ' High values increase probability that a curve',/, * ' may be partially determined or skipped. ') 7010 format (bn,i80) 7020 format (//,' NO is the default answer to all Y/N prompts',/) 7030 format (' Print dependent potentials for chemographies?',/, * ' Answer no if you do not know what this means. ') 7040 format (/,' The solution model file contains no', * ' models valid for your problem.',/) 7050 format (' Try again (Y/N)? ') 7060 format (' Calculate high variance phase fields (Y/N)? ') 7070 format (' Enter a title for your calculation: ') 7080 format (' How many composition diagrams? ') 7090 format (' Write full reaction equations (Y/N)? ') 7100 format (' With stoichiometries (Y/N)? ') 7110 format (' Calculate phase relations (i.e., a phase', * ' diagram section) as a function of',/, * ' additional variables (e.g., P-T-YCO2, Y/N)? ') 7120 format (' With entropy and negative volume (Y/N)? ') 7130 format (' Suppress console status messages (Y/N)? ') 7140 format (' How many additional variables (<3)? ') end block data c----------------------------------------------------------------------- implicit double precision (a-g,o-y),integer (h-n) 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-n) character*14 n2name, y*1 common/ cst41 /n1,n2,n3,n4,n5,n6,n7,n8,n9,io3,io4,io5,io9 c----------------------------------------------------------------------- c now the input data file to c be created for vertex. 10 write (*,1040) read (*,1030) n2name open (n1,file=n2name,iostat=ierr,status='new') if (ierr.ne.0) then write (*,1050) n2name read (*,1020) y if (y.ne.'Y'.and.y.ne.'y') goto 10 open (n1,file=n2name) end if 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-n) 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 = 0d0 end