c - program xntd c - "Extract and Translate Deflection files" c - Program can do one or both of the following to one file: c - 1) Extract a sub-region of a deflection (*asc or *.bin) grid c - 2) a) Translate a deflection grid from ASCII (*.asc) to binary (*.bin) c - OR c - b) Translate a deflection grid from binary (*.bin) to ASCII (*.asc) c - Note that "*.bin" format is binary, unformatted, direct access c - and that the order of bytes depends on which platform the c - file was created. c c VERSION DATE PRIMARY CONTACT c 1.0 Sep 24, 1999 Dru A. Smith c c For further information, questions, or comments: c Dru A. Smith, Ph.D. c NOAA, National Geodetic Survey, N/NGS5 c U.S.A. c Phone : 301-713-3202 c Fax : 301-713-4172 c e-mail : dru@ngs.noaa.gov *********************************************************************** * * * DISCLAIMER * * * * THIS PROGRAM AND SUPPORTING INFORMATION IS FURNISHED BY THE * * GOVERNMENT OF THE UNITED STATES OF AMERICA, AND IS ACCEPTED AND * * USED BY THE RECIPIENT WITH THE UNDERSTANDING THAT THE UNITED STATES * * GOVERNMENT MAKES NO WARRANTIES, EXPRESS OR IMPLIED, CONCERNING THE * * ACCURACY, COMPLETENESS, RELIABILITY, OR SUITABILITY OF THIS * * PROGRAM, OF ITS CONSTITUENT PARTS, OR OF ANY SUPPORTING DATA. * * * * THE GOVERNMENT OF THE UNITED STATES OF AMERICA SHALL BE UNDER NO * * LIABILITY WHATSOEVER RESULTING FROM ANY USE OF THIS PROGRAM. THIS * * PROGRAM SHOULD NOT BE RELIED UPON AS THE SOLE BASIS FOR SOLVING A * * PROBLEM WHOSE INCORRECT SOLUTION COULD RESULT IN INJURY TO PERSON * * OR PROPERTY. * * * * THIS PROGRAM IS PROPERTY OF THE GOVERNMENT OF THE UNITED STATES * * OF AMERICA. THEREFORE, THE RECIPIENT FURTHER AGREES NOT TO ASSERT * * PROPRIETARY RIGHTS THEREIN AND NOT TO REPRESENT THIS PROGRAM TO * * ANYONE AS BEING OTHER THAN A GOVERNMENT PROGRAM. * * * *********************************************************************** implicit real*8(a-h,o-z) c - Variables for the header of the input file real*8 glamn,glomn,dla,dlo integer*4 nla,nlo,ikind real*8 glamx,glomx c - Variables for the header of the output file real*8 glamno,glomno real*8 dlao,dloo integer*4 nlao,nloo,ikindo real*8 glamxo,glomxo c - Variables for statistics of input file real*4 mini,maxi integer*4 ilamini,ilomini,ilamaxi,ilomaxi,kounti real*8 xlamini,xlomini,xlamaxi,xlomaxi real*8 avei,stdi,rmsi,facti c - Variables for statistics of output file real*4 mino,maxo integer*4 ilamino,ilomino,ilamaxo,ilomaxo,kounto real*8 xlamino,xlomino,xlamaxo,xlomaxo real*8 aveo,stdo,rmso,facto c - Variables to get around the recl=4 issue for our real*8 c - header variables real*4 glamnx(2),glomnx(2),dlax(2),dlox(2) real*4 glamnox(2),glomnox(2),dlaox(2),dloox(2) character*256 ifnam,ofnam character*80 b80 character*1 keyb integer*4 ilen,olen character*80 nbound,sbound,wbound,ebound character*3 iext,oext integer*4 lin,lout,ityp,otyp real*8 xla,dd1,dd2 real*4 dov(1081,1921) c - Needed for input header (8 byte variables, recl = 4) equivalence(glamnx(1),glamn) equivalence(glomnx(1),glomn) equivalence(dlax(1),dla) equivalence(dlox(1),dlo) c - Needed for output header (8 byte variables, recl = 4) equivalence(glamnox(1),glamno) equivalence(glomnox(1),glomno) equivalence(dlaox(1),dlao) equivalence(dloox(1),dloo) ccccccccccccccccccccccccccccccccccccccccccccccccccc c - Write out the introductory/disclaimer screens ccccccccccccccccccccccccccccccccccccccccccccccccccc call intro ccccccccccccccccccccccccccccccccccccccccccccccccccc c - Define the file numbers, and an 80 character c - blank ccccccccccccccccccccccccccccccccccccccccccccccccccc lin = 1 lout = 10 b80=' '// * ' '// * ' '// * ' ' ccccccccccccccccccccccccccccccccccccccccccccccccccc c - Get input file name and type ccccccccccccccccccccccccccccccccccccccccccccccccccc write(6,101) 101 format(/,1x,70('-'),/, * ' What is the input file name? ',//, * ' -> ',$) read(5,'(a)')ifnam ilen = lnblnk(ifnam) if(ifnam(ilen-2:ilen).eq.'asc')then ityp = 1 elseif(ifnam(ilen-2:ilen).eq.'bin')then ityp = 2 else write(6,201) 201 format(/,' *** WARNING(201): I do not', * ' recognize the extension of that file.') 202 write(6,203) 203 format(/,' Which format is that file? ',//, * ' 1 = asc',/, * ' 2 = bin',//, * ' -> ',$) read(5,*)ityp if(ityp.lt.1 .or. ityp.gt.2)goto 202 endif ccccccccccccccccccccccccccccccccccccccccccccccccccc c - Open input file and read header ccccccccccccccccccccccccccccccccccccccccccccccccccc if(ityp.eq.1)then open(lin,file=ifnam,status='old',form='formatted') read(lin,*)glamn,glomn,dla,dlo,nla,nlo,ikind else open(lin,file=ifnam,status='old',form='unformatted', * access='direct',recl=4) read(lin,rec= 1)glamnx(1) read(lin,rec= 2)glamnx(2) read(lin,rec= 3)glomnx(1) read(lin,rec= 4)glomnx(2) read(lin,rec= 5)dlax(1) read(lin,rec= 6)dlax(2) read(lin,rec= 7)dlox(1) read(lin,rec= 8)dlox(2) read(lin,rec= 9)nla read(lin,rec=10)nlo read(lin,rec=11)ikind endif ccccccccccccccccccccccccccccccccccccccccccccccccccc c - Compute maximum lat/lon for input file ccccccccccccccccccccccccccccccccccccccccccccccccccc glamx = glamn + (nla-1)*dla glomx = glomn + (nlo-1)*dlo ccccccccccccccccccccccccccccccccccccccccccccccccccc c - Find out what we're gonna do with the file: c 1) Extract? c A) If extracting, get the boundaries. c 2a) Convert bin to asc? c 2b) Convert asc to bin? c 3) Just get statistics? ccccccccccccccccccccccccccccccccccccccccccccccccccc c - Deal with a *.asc file if(ityp.eq.1)then write(6,102) 102 format(/,1x,70('-'),/, * ' Which function to perform? ',//, * ' 1 = Extract a sub-grid and convert "*.asc" to "*.bin"',/, * ' 2 = Extract a sub-grid without converting format',/, * ' 3 = Convert a "*.asc" file to "*.bin" ',/, * ' 4 = Just give statistics on the file',//, * ' -> ',$) c - OR, Deal with a *.bin file else write(6,103) 103 format(/,1x,70('-'),/, * ' Which function to perform? ',//, * ' 1 = Extract a sub-grid and convert "*.bin" to "*.asc"',/, * ' 2 = Extract a sub-grid without converting format',/, * ' 3 = Convert a "*.bin" file to "*.asc"',/, * ' 4 = Just give statistics on the file',//, * ' -> ',$) endif read(5,*)itask ccccccccccccccccccccccccccccccccccccccccccccccccccc c - Determine the output file type c - otyp = 0 => No output file c - otyp = 1 => *.asc c - otyp = 2 => *.bin ccccccccccccccccccccccccccccccccccccccccccccccccccc if(itask.eq.4)then otyp = 0 elseif( (ityp.eq.1 .and. itask.eq.2) .or. * (ityp.eq.2 .and. itask.eq.1) .or. * (ityp.eq.2 .and. itask.eq.3) )then otyp = 1 else otyp = 2 endif ccccccccccccccccccccccccccccccccccccccccccccccccccc c - Get sub-grid boundaries if we're extracting c - otherwise set "sub-grid boundaries" to the c - boundaries of the input grid. c - Don't allow sub-regions to exceed the c - input boundaries c - Use subroutine "bound" to convert the ascii c - string of boundaries into a real*8 value ccccccccccccccccccccccccccccccccccccccccccccccccccc if(itask.eq.1 .or. itask.eq.2)then write(6,104) 104 format(/,1x,70('-'),/, * ' Input the boundaries of the sub-grid in any of the',/, * ' following two formats: ',/, * ' (a) decimal/integer degrees', * ' (one number)',/, * ' (b) integer degrees, decimal/integer minutes', * ' (two numbers)',/, * ' The latitude must be positive North. The longitude',/, * ' must be positive *EAST*, to accomodate U.S. territories',/, * ' which are on either side of the international date line.',//) c - North 109 write(6,108)glamx 108 format(' North Boundary (default: ',f10.6,') -> ',$) read(5,'(a80)')nbound c - The following line fails with older FORTRAN compilers c if(nbound.eq.'')then if(nbound.eq.b80)then glamxo = glamx else call bound(nbound,glamxo) endif if(glamxo.gt.glamx)then write(6,*) ' North boundary too large...try again...' goto 109 endif c - South 110 write(6,105)glamn 105 format(' South Boundary (default: ',f10.6,') -> ',$) read(5,'(a80)')sbound c - The following line fails with older FORTRAN compilers c if(sbound.eq.'')then if(sbound.eq.b80)then glamno = glamn else call bound(sbound,glamno) endif if(glamno.lt.glamn)then write(6,*) ' South boundary too small...try again...' goto 110 elseif(glamno.gt.glamxo)then write(6,*) ' South boundary too large...try again...' goto 110 endif c - West 111 write(6,106)glomn 106 format(' West Boundary (default: ',f10.6,') -> ',$) read(5,'(a80)')wbound c - The following line fails with older FORTRAN compilers c if(wbound.eq.'')then if(wbound.eq.b80)then glomno = glomn else call bound(wbound,glomno) endif if(glomno.lt.glomn)then write(6,*) ' West boundary too small...try again...' goto 111 endif c - East 112 write(6,107)glomx 107 format(' East Boundary (default: ',f10.6,') -> ',$) read(5,'(a80)')ebound c - The following line fails with older FORTRAN compilers c if(ebound.eq.'')then if(ebound.eq.b80)then glomxo = glomx else call bound(ebound,glomxo) endif if(glomxo.gt.glomx)then write(6,*) ' East boundary too large...try again...' goto 112 elseif(glomxo.lt.glomno)then write(6,*) ' East boundary too small...try again...' goto 112 endif c - No extraction, just set output boundaries to input boundaries else glamno = glamn glamxo = glamx glomno = glomn glomxo = glomx endif ccccccccccccccccccccccccccccccccccccccccccccccccccc c - Compute the header of the output file, and c - some other relevant information ccccccccccccccccccccccccccccccccccccccccccccccccccc dlao = dla dloo = dlo nlao = nint((glamxo - glamno) / dlao) + 1 nloo = nint((glomxo - glomno) / dloo) + 1 ikindo = ikind ifirst = nint((glomno - glomn) / dloo) + 1 ilast = nint((glomxo - glomn) / dloo) + 1 if(ilast-ifirst+1 .ne. nloo)stop 88888 ccccccccccccccccccccccccccccccccccccccccccccccccccc c - Get output file name, if necessary, and open c - that file. ccccccccccccccccccccccccccccccccccccccccccccccccccc if(otyp.ne.0)then write(6,113) 113 format(/,1x,70('-'),/, * ' What is the output file name? ',//, * ' -> ',$) read(5,'(a)')ofnam olen = lnblnk(ofnam) c - Output to be *.asc if(otyp.eq.1)then open(lout,file=ofnam,status='new',form='formatted') c - Output to be *.bin else open(lout,file=ofnam,status='new',form='unformatted', * access='direct',recl=4) endif endif ccccccccccccccccccccccccccccccccccccccccccccccccccc c - Read the input data ccccccccccccccccccccccccccccccccccccccccccccccccccc if(ityp.eq.1)then do 114 i = 1,nla read(lin,9001)(dov(i,j),j=1,nlo) 114 continue else do 115 i = 1,nla do 116 j = 1,nlo irec = 11 + (i-1)*nlo + j read(lin,rec=irec)dov(i,j) 116 continue 115 continue endif ccccccccccccccccccccccccccccccccccccccccccccccccccc c - Compute input file statistics ccccccccccccccccccccccccccccccccccccccccccccccccccc avei=0.d0 stdi=0.d0 rmsi=0.d0 kounti = nla*nlo maxi = -99999999. mini = +99999999. do 301 i=1,nla xla = glamn + (i-1)*dla do 302 j=1,nlo xlo = glomn + (j-1)*dlo avei = avei + dov(i,j) rmsi = rmsi + dov(i,j)*dov(i,j) if(dov(i,j).lt.mini)then mini = dov(i,j) xlamini = xla xlomini = xlo ilamini = i ilomini = j endif if(dov(i,j).gt.maxi)then maxi = dov(i,j) xlamaxi = xla xlomaxi = xlo ilamaxi = i ilomaxi = j endif 302 continue 301 continue avei = avei / kounti rmsi = sqrt(rmsi / kounti) facti = dble(kounti) / dble(kounti - 1) stdi = sqrt(facti*(rmsi**2 - avei**2)) ccccccccccccccccccccccccccccccccccccccccccccccccccc c - Write out the new file, extracting, translating c - and computing statistics on the fly c - PC version ccccccccccccccccccccccccccccccccccccccccccccccccccc if(otyp.ne.0)then aveo=0.d0 stdo=0.d0 rmso=0.d0 kounto = nlao*nloo maxo = -99999999. mino = +99999999. c - *.asc output if(otyp.eq.1)then iout = 0 write(lout,*)glamno,glomno,dlao,dloo,nlao,nloo,ikindo do 120 i=1,nla xla = glamn + (i-1)*dla dd1 = glamxo - xla dd2 = xla - glamno if(dd1.gt.-1d-8 .and. dd2.gt.-1.d-8)then c - For whatever reason, this gets quirky sometimes :( c if(xla.ge.glamno .and. xla.le.glamxo)then iout = iout + 1 write(lout,9001)(dov(i,j),j=ifirst,ilast) c - Compile the statistics of the *.asc output file do 141 j=ifirst,ilast xlo = glomn + (j-1)*dlo aveo = aveo + dov(i,j) rmso = rmso + dov(i,j)*dov(i,j) if(dov(i,j).lt.mino)then mino = dov(i,j) xlamino = xla xlomino = xlo ilamino = iout ilomino = j-ifirst+1 endif if(dov(i,j).gt.maxo)then maxo = dov(i,j) xlamaxo = xla xlomaxo = xlo ilamaxo = iout ilomaxo = j-ifirst+1 endif 141 continue endif 120 continue c - *.bin output else write(lout,rec= 1)glamnox(1) write(lout,rec= 2)glamnox(2) write(lout,rec= 3)glomnox(1) write(lout,rec= 4)glomnox(2) write(lout,rec= 5)dlaox(1) write(lout,rec= 6)dlaox(2) write(lout,rec= 7)dloox(1) write(lout,rec= 8)dloox(2) write(lout,rec= 9)nlao write(lout,rec=10)nloo write(lout,rec=11)ikind iout = 0 c - Spin through all input rows, only outputting when necessary irec = 11 do 130 i=1,nla xla = glamn + (i-1)*dla dd1 = glamxo - xla dd2 = xla - glamno if(dd1.gt.-1d-8 .and. dd2.gt.-1.d-8)then c - For whatever reason, this gets quirky sometimes :( c if(xla.ge.glamno .and. xla.le.glamxo)then iout = iout + 1 do 160 j=ifirst,ilast irec = irec + 1 write(lout,rec=irec)dov(i,j) 160 continue c - Compile some statistics do 132 j=ifirst,ilast xlo = glomn + (j-1)*dlo aveo = aveo + dov(i,j) rmso = rmso + dov(i,j)*dov(i,j) if(dov(i,j).lt.mino)then mino = dov(i,j) xlamino = xla xlomino = xlo ilamino = iout ilomino = j - ifirst + 1 endif if(dov(i,j).gt.maxo)then maxo = dov(i,j) xlamaxo = xla xlomaxo = xlo ilamaxo = iout ilomaxo = j - ifirst + 1 endif 132 continue endif 130 continue endif c - Finish computing statistics for either ASCII or BIN output file aveo = aveo / kounto rmso = sqrt(rmso / kounto) facto = dble(kounto) / dble(kounto - 1) stdo = sqrt(facto*(rmso**2 - aveo**2)) endif 9001 format(8(1x,f9.4)) ccccccccccccccccccccccccccccccccccccccccccccccccccc c - Write out final report on tasks completed c - and statistics computed ccccccccccccccccccccccccccccccccccccccccccccccccccc if(ityp.eq.1)then iext = 'asc' else iext = 'bin' endif if(otyp.eq.0)then oext = ' ' elseif(otyp.eq.1)then oext = 'asc' else oext = 'bin' endif write(6,143) write(6,144)ifnam(1:ilen) write(6,145)iext,nla,nlo,kounti, * glamn,glamx,dla, * glomn,glomx,dlo, * mini,ilamini,ilomini,xlamini,xlomini, * maxi,ilamaxi,ilomaxi,xlamaxi,xlomaxi, * avei,stdi,rmsi 143 format(/,1x,70('-'),/ *' REPORT ON INPUT FILE:',/, *' File Name : ',$) 144 format(a) 145 format( *' File type : ',a3,/, *' Rows / Columns in file : ',i8,1x,i8,/, *' Number of points in file : ',i12,/, *' South Edge (Degrees North) : ',f10.6,/, *' North Edge (Degrees North) : ',f10.6,/, *' Latitude Spacing (Degrees) : ',f10.6,/, *' West Edge (Degrees East) : ',f10.6,/, *' East Edge (Degrees East) : ',f10.6,/, *' Longitude Spacing (Degrees) : ',f10.6,/, *' Minimum deflection of vert. : ',f10.6,/, *' -- Row/Col of minimum : ',i8,2x,i8,/, *' -- Lat/Lon of minimum : ',f10.6,2x,f10.6,/, *' Maximum deflection of vert. : ',f10.6,/, *' -- Row/Col of maximum : ',i8,2x,i8,/, *' -- Lat/Lon of maximum : ',f10.6,2x,f10.6,/, *' Average deflection of vert. : ',f10.6,/, *' Standard deviation : ',f10.6,/, *' Root Mean Square : ',f10.6) if(otyp.ne.0)then write(6,150) read(5,'(a)')keyb write(6,146) write(6,147)ofnam(1:ilen) write(6,148)oext,nlao,nloo,kounto, * glamno,glamxo,dlao, * glomno,glomxo,dloo, * mino,ilamino,ilomino,xlamino,xlomino, * maxo,ilamaxo,ilomaxo,xlamaxo,xlomaxo, * aveo,stdo,rmso 150 format(/,' ') 146 format(/,1x,70('-'),/ * ' REPORT ON OUTPUT FILE:',/, * ' File Name : ',$) 147 format(a) 148 format( * ' File type : ',a3,/, * ' Rows / Columns in file : ',i8,1x,i8,/, * ' Number of points in file : ',i12,/, * ' South Edge (Degrees North) : ',f10.6,/, * ' North Edge (Degrees North) : ',f10.6,/, * ' Latitude Spacing (Degrees) : ',f10.6,/, * ' West Edge (Degrees East) : ',f10.6,/, * ' East Edge (Degrees East) : ',f10.6,/, * ' Longitude Spacing (Degrees) : ',f10.6,/, * ' Minimum deflection of vert. : ',f10.6,/, * ' -- Row/Col of minimum : ',i8,2x,i8,/, * ' -- Lat/Lon of minimum : ',f10.6,2x,f10.6,/, * ' Maximum deflection of vert. : ',f10.6,/, * ' -- Row/Col of maximum : ',i8,2x,i8,/, * ' -- Lat/Lon of maximum : ',f10.6,2x,f10.6,/, * ' Average deflection of vert. : ',f10.6,/, * ' Standard deviation : ',f10.6,/, * ' Root Mean Square : ',f10.6) endif end c c c subroutine bound(xbound,value) c - Subroutine to extract a real*4 degree value c - from a character string 'xbound'. real*8 xval integer*4 bkt,ekt,ival,iflag integer*4 b(50),e(50) character*80 xbound real*8 deg,min,value bkt = 0 ekt = 0 c - Search for the beginnings c - and endings of numbers, assuming only c - that we'll find the numbers '0' throuth '9' as c - well as spaces, ' ', and decimals '.'. c - Comma delimeted data will not work ilen = lnblnk(xbound) if(xbound(1:1).ne.' ')then bkt = bkt + 1 b(bkt) = 1 endif do 1 i=2,ilen if(xbound(i:i).eq.' ')then if(xbound(i-1:i-1).ne.' ')then ekt = ekt + 1 e(ekt) = i-1 endif else if(xbound(i-1:i-1).eq.' ')then bkt = bkt + 1 b(bkt) = i endif endif 1 continue c - Count the last space as an end, since we've c - already defined it's length as the last c - non-space character ekt = ekt + 1 e(ekt) = i-1 if(bkt .ne. ekt)stop 80808 c - Integer/Decimal Degrees (1 number) if(bkt .eq. 1)then c - The following line doesn't work on old FORTRAN compilers c read(xbound,*)deg call val(xbound(b(1):e(1)),iflag,ival,xval) if(iflag.eq.0)deg = ival if(iflag.eq.1)deg = xval value = deg c - Integer Degrees & Integer/Decimal minutes (2 numbers) elseif(bkt .eq. 2)then c - The following line doesn't work on old FORTRAN compilers c read(xbound,*)deg,min call val(xbound(b(1):e(1)),iflag,ival,xval) if(iflag.eq.0)deg = ival if(iflag.eq.1)deg = xval call val(xbound(b(2):e(2)),iflag,ival,xval) if(iflag.eq.0)min = ival if(iflag.eq.1)min = xval value = deg+(min/60.d0) c - Otherwise there's an error and the boundaries must be re-input else value = -9999.d0 endif return end c c c subroutine intro c - Subroutine to print out introductory screens and c - disclaimers c - PC version character*1 keyb c - Introduction and version write(6,1) 1 format(////////////, * 10x,' Welcome to the ',/, * 10x,' National Geodetic Survey''s ',/, * 10x,' XNTD PROGRAM',/, * 10x,' (Extract and Translate Deflection files). ',//, * 10x,' For use when a DEFLECTION grid need be',/, * 10x,' translated between ASCII (*.asc) and binary (*.bin) ',/, * 10x,' AND / OR ',/, * 10x,' when a sub-grid, covering a smaller area ',/, * 10x,' needs to be extracted from a larger DEFLECTION grid.',/, * 10x,' AND / OR ',/, * 10x,' for obtaining statistical information ',/, * 10x,' about a DEFLECTION grid.',//) write(6,2) 2 format( * 10x,' VERSION 1.0',/, * 10x,' September 24, 1999',/, * 10x,' Dru A. Smith, Ph.D.',//, * 10x,' (Hit RETURN to continue)') read(5,'(a)')keyb c - Disclaimer WRITE (6,932) 932 format(/,70('-'),/, * /, 32X, 'DISCLAIMER' ,//, + ' This program and supporting information is furnished by', + ' the government of', /, + ' the United States of America, and is accepted/used by the', + ' recipient with', /, + ' the understanding that the U. S. government makes no', + ' warranties, express or', /, + ' implied, concerning the accuracy, completeness, reliability,', + ' or suitability', /, + ' of this program, of its constituent parts, or of any', + ' supporting data.', //, + ' The government of the United States of America shall be', + ' under no liability', /, + ' whatsoever resulting from any use of this program.', + ' This program should', /, + ' not be relied upon as the sole basis for solving a problem', + ' whose incorrect', /, + ' solution could result in injury to person or property.') WRITE (6,933) 933 FORMAT ( /, + ' This program is the property of the government of the', + ' United States of', /, + ' America. Therefore, the recipient further agrees not to', + ' assert proprietary', /, + ' rights therein and not to represent this program to anyone as', + ' being other', /, + ' than a government program.', //, * ' (Hit RETURN to continue)') read(5,'(a)')keyb return end c c c integer function lnblnk(card) ccccccccccccccccccccccccccccccccccccccccccccccccccc c - Function to return the position of the last c - non - blank character of a string. c - This function is found in most FORTRAN c - language compilers. It is included here c - because some compilers do not yet recognize c - it. ccccccccccccccccccccccccccccccccccccccccccccccccccc character *(*) card il = len(card) do 1 i=1,il if(card(i:i).ne.' ')ix = i 1 continue lnblnk = ix return end c c c subroutine val(card,it,iv,xv) ccccccccccccccccccccccccccccccccccccccccccccccccccc c - Subroutine to return the value of a character c - string as either an integer (iv) or a c - real (xv), with "it" telling which value c - to use (it = 0 means int, it=1 means real) c - This subroutine is included to alleviate c - the trouble that old compilers have in c - doing simple character manipulations c - For now, it is assumed that NO BLANKS c - come through in card...only numbers (0-9) c - and maybe ONE decimal. THAT'S ALL. ccccccccccccccccccccccccccccccccccccccccccccccccccc character*(*) card integer*4 it,iv real*8 xv,xsum il = len(card) iv = -999 xv = -999.d0 idec = -1 do 1 i=1,il if(card(i:i).eq.'.')then if(idec.eq.-1)then idec = i else stop 'bad value in val' endif endif 1 continue c - Interpret the integer if(idec.eq.-1)then isum = 0 it = 0 do 2 i=1,il iexp = (il-i) read(card(i:i),'(i1)')idum isum = isum + idum * 10**iexp 2 continue iv = isum c - Interpret the real else xsum = 0.d0 it = 1 c - Real left of decimal do 3 i=1,idec-1 iexp = (idec-1)-i read(card(i:i),'(i1)')idum xsum = xsum + idum * 10.d0**iexp 3 continue c - Real right of decimal do 4 i=idec+1,il iexp = (idec )-i read(card(i:i),'(i1)')idum iiexp = -iexp xsum = xsum + dble(idum) / 10**(iiexp) 4 continue xv = xsum endif return end