program actcor c---------------------------------------------------------------------- c ************************ c * * c * actcor.may.1989 * c * * c ************************ c---------------------------------------------------------------------- c a fortran program for making fixed activity corrections to the c thermodynamic data file for vertex. actcor creates a new data file c with the corrected data on unit n6 c----------------------------------------------------------------------- c files (see vertex program documentation for additional information): c----------------------------------------------------------------------- implicit double precision (a-g,o-y),integer (h-m) character*8 blank8,name,y*1,test common/ cst41 /n1,n2,n3,n4,n5,n6,n7,n8,n9,io3,io4,io5,io9 data blank8/' '/ c----------------------------------------------------------------------- write (*,1300) c open files call fopen c read and echo file header call topn2 (4,icmpn) write (*,1010) 1010 format (' This program will create a new thermodynamic data',/, * ' file with (optionally) activity corrected entries.',/, * ' You must specify all phases that are to be included',/, * ' in the new data file (actcor.dat).',//) c allow user to enter names: write (*,*) 'Prompt for phases (y/n)?' read (*,1090) y if (y.ne.'y'.and.y.ne.'Y') then c get the name: 100 write (*,*) 'Enter a phase to be included' write (*,*) '[<8 characters, blanks to finish]:' read (*,1000) test if (test.eq.blank8) goto 999 rewind n2 call eohead (n2) 120 call getphi (name,ibase,icmpn,*110) if (name.eq.test) then call gotcha (name,ibase,icmpn) goto 100 end if goto 120 110 write (*,*) 'No such phase as: ',test goto 100 else c read and modify individual entries 220 call getphi (name,ibase,icmpn,*999) write (*,*) 'Include (y/n): ',name read (*,1090) y if (y.eq.'y'.or.y.eq.'Y') call gotcha (name,ibase,icmpn) goto 220 end if 1000 format (a8) 1090 format (a1) 1210 format (/,' The file ',a14,' exists, do you', * ' really want to overwrite it (y/n)? ') 1300 format (/,' NO is the default answer to all prompts',/) 999 end block data c----------------------------------------------------------------------- implicit double precision (a-g,o-y),integer (h-m) 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) character*14 n2name,yes*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) yes if (yes.ne.'Y'.and.yes.ne.'y') goto 999 goto 1 c try again end if write (*,1070) open (n6,file='actcor.dat') return 999 write (*,1060) stop 1000 format (/,' Enter the thermo data file name (e.g.', * ' hp90ver.dat),',/, * ' < 15 characters, left justified: ') 1010 format (/,' **warning ver191** FOPEN file ',a14, * ' could not be opened',//,' try again (y/n)? ') 1020 format (a1) 1030 format (a14) 1060 format (/,' O.K., then i am quitting also.',/) 1070 format (/,' Ouput will be written to file: actcor.dat',/) end function grxn (i) implicit integer (h-m) end subroutine cfluid (x,y) implicit double precision (a-z) end subroutine gotcha (name,ibase,icmpn) implicit double precision (a-g,o-y),integer (h-m) parameter (k0=25,k4=22,m6=3,m7=12) character*8 blank8,dname*40,cmpnt*5,name,y*1 common/ cst43 /therm(k4),comp(k0),atwt(k0),idh2o,idco2,ikind * / cst202 /tm(m7,m6),td(9),ilam,idiso,lamin,idsin * / cst41 /n1,n2,n3,n4,n5,n6,n7,n8,n9,io3,io4,io5,io9 * / cst5 /p,t,xco2,u1,u2,tr,pr,r,ps * / csta5 /dname(8),cmpnt(k0) data blank8/' '/ write (*,*) 'make an activity correction ', * 'for ',name,' (y/n)?' read (*,1090) y if (y.eq.'y'.or.y.eq.'Y') then c write (*,*) 'enter phase that ',name, * ' is a solution in (left justified): ' read (*,1020) blank8 c write (*,*) 'the stoichiometry of ',name,' is: ' write (*,2000) (cmpnt(i),i=1,icmpn) write (*,1040) (comp(i),i=1,icmpn) write (*,*) write (*,*) 'ideal activity model (y/n)?' read (*,1090) y if (y.eq.'y'.or.y.eq.'Y') then write (*,*) 'enter mole fraction (x) of ',name, * ' in ',blank8,' :' read (*,*) xmole write (*,*) 'activity of ',name,' will be computed as ', * 'x**n' write (*,*) 'enter number of mixing sites (n):' read (*,*) xmix act = xmole**xmix else write (*,*) 'enter activity of ',name,' :' read (*,*) act end if write (*,*) 'activity of ',name,' in ',blank8,' is:', * act therm(1) = therm(1) + t * 8.314413 * dlog(act) therm(2) = therm(2) - 8.314413 * dlog(act) name = blank8 end if jlam = ilam if (ilam.gt.3) jlam = ilam - 3 if (ilam.gt.6) jlam = ilam - 6 if (ilam.gt.9) jlam = ilam - 9 write (n6,1030) name,ibase,ikind,ilam,idiso write (n6,1040) (comp(i),i=1,icmpn) write (n6,1050) (therm(i),i=1,18) if (ilam.ne.0) then do 52 i = 1, jlam 52 write (n6,1050) (tm(j,i), j = 1, m7-2) end if if (idiso.ne.0) write (n6,1050) td 1000 format (a8) 1020 format (a8,i2,i2,i2,i2) 1030 format (a8,i2,i2,i2,i2,a60) 1040 format (13(f5.2,1x)) 1050 format (5(g13.7,1x)) 1090 format (a1) 1210 format (/,' The file ',a14,' exists, do you', * ' really want to overwrite it (y/n)? ') 1300 format (/,' NO is the default answer to all prompts',/) 2000 format (/,1x,13(a5,1x),/,1x,13(a5,1x)) end