cb::compgb c program compgb c c********1*********2*********3*********4*********5*********6*********7** c Name: compgb c Version: 1.1 (9001.12) c Written by: ___________ & TJ Cacanindin c Purpose: This program compares a complete B-file (GPS Project and c Station Occupation Data) and a complete G-file (GPS c Vector Data Transfer file) against a definitive station c list (SERFIL) and each other in order to check c consistency and uniqueness of station IDs and serial c numbers. c c Local Variables and Constants: c ------------------------------ c bfile : user defined name of bfile c b25() : holds bfile *25* sess c b80 : bfile *80* station names c card : generic record read from a file c ch : single-digit character c day : UTC day of year baseline vector observed c dayi() : dayi(1) day observed c dayi(2) number of sess on a particular line c (< 17; max line length of direct access c files is 90) c dayprev : day read before current one c done1(90) : indicate whether bfile *25* sess/station IDs are c origin stations for the gfile baseline vectors c done2(90) : indicate whether bfile *25* sess/station IDs are c differential stations for gfile baseline vectors c errday : day of record to appear in output error message c errsess : sess/sta ID of record to appear in output errmsg c first : line index for single mode processing c flag : indicates existence of error condition c found : indicates whether a position is found to insert c bfile *25* sess in an existing line or whether a c new line must be established c gfile : user defined name of gfile c ios : I/O status indicator of control info list c ios=0 : successful op; no error/no eof c ios=-1 : eof condition occurred/no error; c occurs only for READ operations c ios>0 : error condition occurred; error c stat codes are in RM/FORTRAN Manual c ktemp : previously loaded SSN of station ID retrieved c when a duplicate exists c k25() : holds line numbers of bfile *25* records c k80 : line numbers of bfile *80* records c maxln : max number of lines in dayif c maxvln : max number of vectors calculated in vectorf c maxv2ln : max number of sess in intermediate step of c single mode calculations c mode : 1-char mode indicator c mmode : indicates multi (or session) mode c origin() : holds gfile origin stations c ostaprev : value of gfile origin station read just before c current one c outfile : user defined name of output file c second : line index for single mode processing c seen() : seen(1) -- indicates whether SSN/station ID c match in gfile corresponds to c station file match c : seen(2) -- indicates whether SSN/station ID c match in bfile corresponds to c station file match c : seen(3) -- indicates whether each station in the c station file has a bfile *80* record c sernum1 : origin station serial number (SSN) c sernum2 : differential station serial number (SSN) c sess : sess(1:1)=session; sess(2:5)=station ID c sfile : user dfned name of definitive station list c smode : indicates single mode c sta : definitive station list of SSNs and assigned 4-char c station identifications c statemp : previously loaded station ID which has been c retrieved to test whether a duplicate exists c station : 4-char station ID read from sta file c testline1 : origin sess/sta (1:5)//diff. sess/sta (6:10) c testline2 : diff. sess/sta (1:5)//origin sess/sta (6:10) c k27 : *27* record count for a session c first25 : first *25* record in bfile c c Global Variables and Constants: c ------------------------------- c baseline(366,90) : array of all baseline vectors in gfile indexed c by day (90 vectors/day are allowed) c max : maximum number of records in error files c c c This Module Called By : none c c This Module Calls : checkgf, look, title c c Include Files Used : none c c Common Blocks Used : /globls/ c c References: RM/FORTRAN Manual, COMPGB User's Documentation, OMNI c Programming Standards c c Comments: - (n = no. of stations) c single mode : (n(n-1))/2 = vectors/session c multi (or session) mode: n-1 = vectors/session c - baseline() handles up to 90 baseline vectors/day c - RM/FORTRAN has limitation of 14 access files c********1*********2*********3*********4*********5*********6*********7** c Modification History: c::9001.12, TJC, c:: Station serial number fields expanded to 4 digits c:: Max number of baseline vectors increased to 90 per day c:: Printing of program title c:: User prompts for I/O files c:: Improved error handling/trapping c:: Between session vector checking removed c:: OMNI documentation standards c:: Calculations for multi and single baseline mode reductions c:: c::9703.31, version 1.2, JBM, c:: modified 90 vectors per day to 5999 vectors per G-file by: c:: character*10 baseline(366,90) array changed to integer baselind(5999) c:: = day and character*10 baseline(5999) = baseline arrays. add integer c:: basecnt as array counter c:: increase character*1 done1(90),done2(90) arrays to done1(5999),done2(5999) c:: and make them global variables: add common/globs2/done1,done2. c:: removed files donef1 and donef2. c:: removed subroutine title and added logical function dup. c:: allowed gfile F records c:: c::9705.22, version 1.2 (same ver) JBM, c:: modified terminology to: c:: single baseline mode reduction - multi-receiver session computed as c:: if all vectors are independent. Thus for 4 stations there would be c:: 6 vectors and the record sequence is A,B,C,D,B,C,D,B,C,D,B,C,D,B,C,D, c:: B,C,D all in the same session. c:: multiple baseline (session) mode reduction - multi-receiver session c:: computed as if all vectors are processed simultaneously. Thus for 4 c:: stations there would be 3 vectors and the record sequence is A,B,C,C, c:: C,D,D,D,D,D,D,D,D all in the same session. c:: c::200107.13, version 1.3 JBM, c:: allow more than 2 bfile *27* records c********1*********2*********3*********4*********5*********6*********7** ce::compgb integer*4 ios integer*4 b25f,b80f,d,day,dayi(2),dayif,dayprev,donef1, $ donef2,errday,errf1,errf2,first,i,idup,j,k,kprev, $ ktemp,k25(16),k25f,k80,look,max,maxln,maxvln, $ maxv2ln,o,originf,outf,rn,second,seenf,sernum1, $ sernum2,sta,tempf,vectorf integer*4 basecnt integer*4 k27 character*80 card character*30 b80 character*15 bfile,gfile,sfile,outfile character*10 testline1,testline2,vector character*10 baseline(5999) integer*4 baselind(5999) character*5 b25(16),errsess,one,origin(7),ostaprev,sess,two character*4 statemp,station character*1 ch,done1(5999),done2(5999),mode,seen(3) logical dup25,flag,found,mmode,smode logical dup logical first25 common/globls/baselind,baseline,basecnt,max common/globls2/done1,done2 data b25f,b80f,dayif,donef1,donef2/400,410,420,430,440/, $ errf1,errf2,k25f,originf,outf/450,460,470,480,490/, $ seenf,sta,tempf,vectorf/500,510,520,530/, $ kprev,station/0,' '/, $ dayi/0,0/ max=0 basecnt = 0 mmode=.false. smode=.false. k27=0 first25=.true. print * print *,'Welcome to program compgb version 1.3' print * print *,'Initializing program............' print * c........ 1.0 Opens direct access files open(b25f,status='SCRATCH',access='DIRECT',form='FORMATTED', $ recl=80) open(b80f,status='SCRATCH',access='DIRECT',form='FORMATTED', $ recl=30) open(dayif,status='SCRATCH',access='DIRECT',form='FORMATTED', $ recl=35) open(errf1,status='SCRATCH',access='DIRECT',form='FORMATTED', $ recl=3) open(errf2,status='SCRATCH',access='DIRECT',form='FORMATTED', $ recl=5) open(k25f,status='SCRATCH',access='DIRECT',form='FORMATTED', $ recl=80) open(originf,status='SCRATCH',access='DIRECT',form='FORMATTED', $ recl=35) open(seenf,status='SCRATCH',access='DIRECT',form='FORMATTED', $ recl=3) open(sta,status='SCRATCH',access='DIRECT',form='FORMATTED', $ recl=4) open(tempf,status='SCRATCH',access='DIRECT',form='FORMATTED', $ recl=30) open(vectorf,status='SCRATCH',access='DIRECT',form='FORMATTED', $ recl=10) c........ 2.0 Initializes arrays and direct access files do 2000 i=1,3 seen(i)='f' 2000 continue do 2010 i=1,5999 done1(i)='f' done2(i)='f' 2010 continue do 2015 i=1,16 b25(i)=' ' k25(i)=0 2015 continue i=0 do 2040 sernum1=1,9999 write(sta,rec=sernum1,fmt=2020)station 2020 format(a4) write(seenf,rec=sernum1,fmt=2030)seen 2030 format(3a1) write(tempf,rec=sernum1,fmt=2035)i 2035 format(i5) 2040 continue origin(1)='eoln ' do 2060 day=1,366 write(originf,rec=day,fmt=2051)origin 2051 format(7a5) 2060 continue do 2080 i=1,5999 baseline(i)=' ' baselind(i) = 0 2080 continue c........ 3.0 Prints program title and prompts user for I/O files and c processing options c i: allows user to change echoed filename (error recovery) c j: assigned goto index c k: errormsg counter; when k>2, program execution halted i=1 j=1 k=1 3000 print *,'Please enter station filename (serfil): ' read(5,'(a15)') sfile if (i .le. 2) then print *,sfile,' entered as the correct station file? (y/n): ' read(5,'(a1)') ch if (.not.((ch .eq. 'Y') .or. (ch .eq. 'y'))) then i=i+1 goto 3000 endif endif open (100,file=sfile,iostat=ios,err=3030,status='old') i=1 j=2 k=1 3010 print *,'Please enter G-filename: ' read(5,'(a15)') gfile if (i .le. 2) then print *,gfile,' entered as the correct gfile? (y/n): ' read(5,'(a1)') ch if (.not.((ch .eq. 'Y') .or. (ch .eq. 'y'))) then i=i+1 goto 3010 endif endif open (200,file=gfile,iostat=ios,err=3030,status='old') i=1 j=3 k=1 3020 print *,'Please enter B-filename: ' read(5,'(a15)') bfile if (i .le. 2) then print *,bfile,' entered as the correct bfile? (y/n): ' read(5,'(a1)') ch if (.not.((ch .eq. 'Y') .or. (ch .eq. 'y'))) then i=i+1 goto 3020 endif endif open (300,file=bfile,iostat=ios,err=3030,status='old') 3030 if (ios .ne. 0) then if (k .le. 2) then print *,'Error condition occurred while trying to open', $ ' file.' print *,'Verify existence of filename.ext' print * k=k+1 goto (3000,3010,3020) j else stop 'Input file not found' endif endif i=1 3040 print *,'Please enter name of output file: ' read(5,'(a15)') outfile if (i .le. 2) then print *,outfile,' entered as correct output file? (y/n): ' read(5,'(a1)') ch if (.not.((ch .eq. 'Y') .or. (ch .eq. 'y'))) then i=i+1 goto 3040 endif endif open (outf,file=outfile,iostat=ios,err=3040,status='unknown') i=1 3050 print *,'Checking of single baseline mode reductions (s)' print *,'Checking of multiple baseline (session) mode ', $'reductions (m)' print *,'No checking (n) ? (s/m/n) : ' read(5,'(a1)') mode if (i .le. 2) then if ((mode .eq. 'S') .or. (mode .eq. 's')) then print *,'Single baseline mode reductions selected? (y/n): ' elseif ((mode .eq. 'M') .or. (mode .eq. 'm')) then print *,'Multiple baseline (session) mode reductions', $' selected? (y/n): ' elseif ((mode .eq. 'N') .or. (mode .eq. 'n')) then print *,'Mode reductions not calculated? (y/n): ' else i=i+1 print *,'Invalid response, try again' goto 3050 endif read(5,'(a1)') ch if (.not.((ch .eq. 'Y') .or. (ch .eq. 'y'))) then i=i+1 goto 3050 endif endif if ((mode .eq. 'S') .or. (mode .eq. 's')) then smode=.true. elseif ((mode .eq. 'M') .or. (mode .eq. 'm')) then mmode=.true. else print *,'Mode reductions will not be not calculated.' endif print *,'Continue with program? (y/n): ' 3055 read(5,'(a1)') ch if ((ch .eq. 'N') .or. (ch .eq. 'n')) then stop 'Execution terminated' else if (.not.((ch .eq. 'Y') .or. (ch .eq. 'y'))) then print *, 'invalid response, try y or n: ' goto 3055 else continue endif write(outf,3059) outfile 3059 format(' Program compgb version 1.3 (20010713) output file: ',a15) write(outf,3060) sfile,gfile,bfile 3060 format(' input files',/,7x,'station file: ',a15,/,7x,'gfile', $ 7x,': ',a15,/,7x,'bfile',7x,': ',a15) if (smode) then write(outf,3062) 3062 format(' Calculations of single baseline mode reductions') elseif (mmode) then write(outf,3064) 3064 format(' Calculations of multiple baseline (session) mode', $' reductions') else write(outf,3066) 3066 format(' Mode reductions not calculated') endif write(outf,3068) 3068 format(' * * * * * *') c........ 4.0 STATION FILE PROCEDURE. Sets up sta file with valid c station IDs from the station file c k: record counter print *,'* * * * * *' print * print *,'Loading ',sfile,' station file records into program ... ' write(outf,4000) sfile 4000 format(/,' Loading ',a15,' station file records into program ...') k=0 4001 read(100,'(a4,3x,i4)',iostat=ios,end=4010,err=4010)station,sernum1 k=k+1 4010 if (ios .gt. 0) then k=k+1 write(6,4020) k,sfile 4020 format(/,' Error occurred with record ',i5,' of ',a15) stop 'Error while reading station ID and serial number' elseif (ios .eq. -1) then if (k .eq. 0) then print * print *,sfile,' contains no records' stop 'Empty station file' else close(100,iostat=ios) if (ios .gt. 0) then print * print *,'Error condition occurred while closing ',sfile else print * print *,'At end of ',sfile write(outf,4025) sfile 4025 format(/,' At end of ',a15,/,' * * * * * *') endif endif elseif ((ios .eq. 0) .and. (sernum1 .le. 0)) then write(outf,4030) sernum1,k,sfile 4030 format(/,1x,i4.4,' is an illegal station number which occurs', $ ' in record ',i5,' of',/,' ',a15,'. Illegal value', $ ' disregarded. Valid range is 1:9999') goto 4001 elseif ((ios .eq. 0) .and. (sernum1 .ge. 1)) then flag=.false. c........ Checks for duplicate 4-char station ID do 4070 rn=1,9999 read(tempf,rec=rn,fmt=4035)i 4035 format(i5) if (i .eq. 0) then goto 4075 else read(sta,rec=i,fmt=4040) statemp 4040 format(a4) if (statemp .eq. station) then read(errf2,rec=i,fmt=4050) ktemp 4050 format(i5) flag=.true. idup=i write(outf,4060) sfile,station,i,ktemp,sernum1,k 4060 format(/,1x,a15,' assigns 4-char station ID ',a4, $ ' to station serial ',/,' numbers ',i4.4, $ ' (record ',i5,') and ',i4.4,' (record ',i5, $ '). The first',/,' assignment was loaded', $ ' into the program--the second disregarded.') endif endif 4070 continue c........ Checks for duplicate SSN 4075 read(sta,rec=sernum1,fmt=4040) statemp if ((statemp .eq. ' ') .and. (.not. flag)) then write(sta,rec=sernum1,fmt=4040) station write(errf2,rec=sernum1,fmt=4050) k do 4078 rn=1,9999 read(tempf,rec=rn,fmt=4035)i if (i .eq. 0) then write(tempf,rec=rn,fmt=4035) sernum1 goto 4001 endif 4078 continue elseif ((statemp .eq. ' ') .and. flag) then write(outf,4080) sernum1,k,station,idup,ktemp 4080 format(/,' Station serial number ',i4.4,' (record ',i5, $ ') is not a duplicate; however,',/,' its 4-char', $ ' station ID ',a4,' appears previously for serial', $ ' number ',/,4x,i4.4,' (record ',i5,'). Due to', $ ' error, record not loaded into program.') else read(errf2,rec=sernum1,fmt=4050) ktemp write(outf,4090) sfile,sernum1,statemp,ktemp,station,k 4090 format(/,1x,a15,' assigns station serial number ',i4.4, $ ' to 4-char station',/,' IDs ',a4,' (record ',i5, $ ') and ',a4,' (record ',i5,'). The first',/, $ ' assignment was loaded into the program--the', $ ' second disregarded.') endif goto 4001 endif c........ 5.0 GFILE PROCEDURE. Checks the gfile "C" Member Records c and the "F" Member Records for consistency of station c IDs and SSNs with those in the sta file c k: record counter print *,'* * * * * *' print * print *,'Processing the ',gfile,' gfile records ... ' write(outf,5000) gfile 5000 format(/,' Processing the ',a15,' gfile records ... ') k=0 ostaprev=' ' dayprev=0 5001 read(200,'(a80)',iostat=ios,end=5100,err=5100)card k=k+1 c........ 5.1 Error checking 5100 if (ios .gt. 0) then k=k+1 write(6,4020) k,gfile print *,'(Maximum length of gfile records is 80 characters)' stop 'Encountered error condition while reading file' elseif (ios .eq. -1) then if (k .eq. 0) then print * print *,gfile,' contains no records' stop 'Empty gfile' else close(200,iostat=ios) if (ios .gt. 0) then print * print *,'Error condition occurred while closing ',gfile else print * print *,'At end of ',gfile write(outf,5105) gfile 5105 format(/,' At end of ',a15,/,' * * * * * *') endif goto 6000 endif endif c........ 5.2 Processes the "C" Member Records of the gfile if(card(1:1).eq.'C') then read(card,'(1x,i4,i4)',iostat=ios,err=5200)sernum1,sernum2 read(card,'(59x,i3)',iostat=ios,err=5200)day 5200 if (ios .ne. 0) then write(outf,5201) k,gfile 5201 format(/,' Error condition occurred while reading record ', $ i7,' of ',a15,'.',/,' Problem is with either the', $ ' origin (2:5) or differential (6:9) station',/, $ ' serial numbers or with the day of the year', $ ' observed (60:62). Due to',/,' the error,', $ ' the record was not processed.') goto 5001 endif c........ Verifies valid range for day (1:366) if ((day .lt. 1) .or. (day .gt. 366)) then read(sta,rec=sernum1,fmt=5205)station read(sta,rec=sernum2,fmt=5205)statemp 5205 format(a4) write(outf,5206) day,k,sernum1,station,sernum2,statemp 5206 format(/,' Day ',i3,' for record ',i7,' is out of valid', $ ' range 1:366. Due to error,'/,' vector', $ ' consisting of origin serial number ',i4.4, $ ' station ID ',a4,' and',/,' differential serial', $ ' number ',i4.4,' station ID ',a4,' was not', $ ' processed.') goto 5001 endif c........ 5.21 Checks to see if origin SSN/station ID match is c consistent with the station file match. If not, prints c errmsg; otherwise, marks true in seen array read(sta,rec=sernum1,fmt=5210)station 5210 format(a4) if (station.ne.card(65:68)) then if (station .eq. ' ') then write(outf,5212) sernum1 5212 format(/,' Station serial number ',i4.4,' not loaded', $ ' into program from station file.') else write(outf,5214) station,sernum1 5214 format(/,' Station ',a4,' is assigned to serial number', $ 1x,i4.4,' in the station file.') endif write(outf,5216) card(65:68),day,k 5216 format(' Station ',a4,' is incorrectly assigned to', $ ' this number in the',/,' gfile (day # ',i3, $ ', record # ',i7,').') i=look(card(65:68)) if (i .eq. 0) then write(outf,5217) card(65:68) 5217 format(' Station ',a4,' is not in the list of 4-char', $ ' IDs loaded into program.') else write(outf,5218) card(65:68),i 5218 format(' Station ',a4,' is assigned to serial', $ ' number ',i4.4,' in the station file.') endif else read(seenf,rec=sernum1,fmt=5219)seen 5219 format(3a1) seen(1)='t' write(seenf,rec=sernum1,fmt=5219)seen endif c........ 5.22 Checks to see if differential SSN/station ID match is c consistent with the station file match. If not, prints c errmsg; otherwise, marks true in seen array read(sta,rec=sernum2,fmt=5210)station if (station.ne.card(75:78)) then if (station .eq. ' ') then write(outf,5212) sernum2 else write(outf,5214) station,sernum2 endif write(outf,5216) card(75:78),day,k i=look(card(75:78)) if (i .eq. 0) then write(outf,5217) card(75:78) else write(outf,5218) card(75:78),i endif else read(seenf,rec=sernum2,fmt=5219)seen seen(1)='t' write(seenf,rec=sernum2,fmt=5219)seen endif c........ 5.23 Converts lowercase characters in string to uppercase do 5230 i=64,68 ch=card(i:i) if (ch .ge. 'a') then ch=char(ichar(ch)-32) card(i:i)=ch endif 5230 continue do 5235 i=74,78 ch=card(i:i) if (ch .ge. 'a') then ch=char(ichar(ch)-32) card(i:i)=ch endif 5235 continue c........ 5.24 Loads originf with origin stations (baseline(day,i)(1:5), c if mmode) or origin sessions (baseline(day,i)(1:1), if c smode) flag=.false. if (day .ne. dayprev) then ostaprev=' ' endif if (((day .eq. dayprev) .and. $ ((mmode .and. (ostaprev .ne. card(64:68))) .or. $ (smode .and. (ostaprev .ne. card(64:64))))) .or. $ (day .ne. dayprev)) then read(originf,rec=day,fmt=5240) origin 5240 format(7a5) do 5242 i=1,7 if (mmode) then if (origin(i) .eq. card(64:68)) then flag=.true. elseif (origin(i) .eq. 'eoln ') then goto 5244 endif elseif (smode) then if (origin(i)(1:1) .eq. card(64:64)) then flag=.true. elseif (origin(i) .eq. 'eoln ') then goto 5244 endif endif 5242 continue 5244 if (.not. flag) then if ((origin(i) .eq. 'eoln ') .and. (i .lt. 7)) then if (mmode) then origin(i)=card(64:68) ostaprev=card(64:68) elseif (smode) then origin(i)(1:1)=card(64:64) ostaprev=card(64:64) endif origin(i+1)='eoln ' write(originf,rec=day,fmt=5240) origin dayprev=day endif endif endif c........ 5.25 Searches for appropriate place in baseline array to c insert the record's baseline vector testline1=card(64:68)//card(74:78) testline2=card(74:78)//card(64:68) c........ 5.251 check if duplicate baseline exists for the day if (dup(day,testline1,testline2)) then write(outf,5252) testline1,day,k 5252 format(/,' Baseline vector ',a10,' already exists for', $ ' day ',i5,'. Duplicate',/,' vector exists', $ ' for same day in gfile record ',i7,'.') c........ 5.252 check if vector limit exceeded. elseif (basecnt.ge.5999) then write(outf,5253) testline1,k,day 5253 format(/,' Program holds a max of 5999 gfile baseline', $ ' vectors. Any vector',/,' exceeding', $ ' the 5999 vector limit will not be processed. ', $ ' Vector',/,4x,a10,' (record ',i7,') for day ',i5, $ ' exceeds this limit.') else c........ 5.253 add baseline to array basecnt = basecnt + 1 baselind(basecnt) = day baseline(basecnt) = testline1 endif goto 5001 c........ 5.6 Processes the "F" Member Records of the gfile elseif(card(1:1).eq.'F') then read(card,'(1x,i4,i4)',iostat=ios,err=5600)sernum1,sernum2 read(card,'(65x,i3)',iostat=ios,err=5600)day 5600 if (ios .ne. 0) then write(outf,5601) k,gfile 5601 format(/,' Error condition occurred while reading F record ', $ i7,' of ',a15,'.',/,' Problem is with either the', $ ' origin (2:5) or differential (6:9) station',/, $ ' serial numbers or with the day of the year', $ ' observed (66:68). Due to',/,' the error,', $ ' the record was not processed.') goto 5001 endif c........ Verifies valid range for day (1:366) if ((day .lt. 1) .or. (day .gt. 366)) then read(sta,rec=sernum1,fmt=5605)station read(sta,rec=sernum2,fmt=5605)statemp 5605 format(a4) write(outf,5606) day,k,sernum1,station,sernum2,statemp 5606 format(/,' Day ',i3,' for record ',i7,' is out of valid', $ ' range 1:366. Due to error,'/,' vector', $ ' consisting of origin serial number ',i4.4, $ ' station ID ',a4,' and',/,' differential serial', $ ' number ',i4.4,' station ID ',a4,' was not', $ ' processed.') goto 5001 endif c........ 5.61 match F record origin ssn with station file ssn and assign c corresponding station file station ID to the F record c mark true in seen array read(sta,rec=sernum1,fmt=5610)station 5610 format(a4) read(seenf,rec=sernum1,fmt=5619)seen 5619 format(3a1) seen(1)='t' write(seenf,rec=sernum1,fmt=5219)seen c........ 5.62 match F record differential ssn with station file ssn and c assign corresponding station file station ID to the F record c mark true in seen array read(sta,rec=sernum2,fmt=5610)statemp read(seenf,rec=sernum2,fmt=5619)seen seen(1)='t' write(seenf,rec=sernum2,fmt=5619)seen c........ 5.63 Converts lowercase characters in string to uppercase ch=card(70:70) if (ch .ge. 'a') then ch=char(ichar(ch)-32) card(70:70)=ch endif ch=card(76:76) if (ch .ge. 'a') then ch=char(ichar(ch)-32) card(76:76)=ch endif c........ 5.24 Loads originf with origin stations (baseline(day,i)(1:5), c if mmode) or origin sessions (baseline(day,i)(1:1), if c smode) flag=.false. if (day .ne. dayprev) then ostaprev=' ' endif if (((day .eq. dayprev) .and. $ ((mmode .and. (ostaprev .ne. card(70:70)//station)) .or. $ (smode .and. (ostaprev .ne. card(70:70))))) .or. $ (day .ne. dayprev)) then read(originf,rec=day,fmt=5640) origin 5640 format(7a5) do 5642 i=1,7 if (mmode) then if (origin(i) .eq. card(70:70)//station) then flag=.true. elseif (origin(i) .eq. 'eoln ') then goto 5644 endif elseif (smode) then if (origin(i)(1:1) .eq. card(70:70)) then flag=.true. elseif (origin(i) .eq. 'eoln ') then goto 5644 endif endif 5642 continue 5644 if (.not. flag) then if ((origin(i) .eq. 'eoln ') .and. (i .lt. 7)) then if (mmode) then origin(i)=card(70:70)//station ostaprev=card(70:70)//station elseif (smode) then origin(i)(1:1)=card(70:70) ostaprev=card(70:70) endif origin(i+1)='eoln ' write(originf,rec=day,fmt=5640) origin dayprev=day endif endif endif c........ 5.65 Searches for appropriate place in baseline array to c insert the record's baseline vector testline1=card(70:70)//station//card(76:76)//statemp testline2=card(76:76)//statemp//card(70:70)//station c........ 5.651 check if duplicate baseline exists for the day if (dup(day,testline1,testline2)) then write(outf,5652) testline1,day,k 5652 format(/,' Baseline vector ',a10,' already exists for', $ ' day ',i5,'. Duplicate',/,' vector exists', $ ' for same day in gfile record ',i7,'.') c........ 5.652 check if vector limit exceeded. elseif (basecnt.ge.5999) then write(outf,5653) testline1,k,day 5653 format(/,' Program holds a max of 5999 gfile baseline', $ ' vectors. Any vector',/,' exceeding', $ ' the 5999 vector limit will not be processed. ', $ ' Vector',/,4x,a10,' (record ',i7,') for day ',i5, $ ' exceeds this limit.') else c........ 5.653 add baseline to array basecnt = basecnt + 1 baselind(basecnt) = day baseline(basecnt) = testline1 endif goto 5001 else goto 5001 endif c........ 6.0 BFILE PROCEDURE. Checks the bfile *25* records for c consistency of station IDs and SSNs with those in the c sta file and baseline array (gfile vectors); assures two c *27* records for each *25*; verifies existence of one c *80* per station; loads dayif and b25f in preparation c for reduction processing. c Allow more than 2 *27* records for each *25* (v 1.3) c k : record counter c kprev: *25* record line counter c k27 : *27* record count per session c first25 : first 25 record 6000 print *,'* * * * * *' print * print *,'Processing the ',bfile,' bfile records ... ' write(outf,6001) bfile 6001 format(/,' Processing the ',a15,' bfile records ... ') i=1 k=0 maxln=0 k27=0 first25= .true. c........ 6.1 Error checking 6100 read(300,'(a80)',iostat=ios,end=6110,err=6110)card k=k+1 6110 if (ios .gt. 0) then k=k+1 write(6,4020) k,bfile print *,'(Maximum length of bfile records is 80 characters)' stop 'Encountered error condition while reading file' elseif (ios .eq. -1) then if (k .eq. 0) then print * print *,bfile,' contains no records' stop 'Empty Bfile' else close(300,iostat=ios) if (ios .gt. 0) then print * print *,'Error condition occurred while closing ',bfile else do 6150 rn=1,max read(errf1,rec=rn,fmt=6120)errday 6120 format(i3) read(errf2,rec=rn,fmt=6130)errsess 6130 format(a5) write(outf,6140)errday,errsess(1:1),errsess(2:5) 6140 format(/,' No gfile "C/F" member record for day/', $ 'station: ',i3,a1,' ',a4) 6150 continue print * print *,'At end of ',bfile write(outf,6160) bfile 6160 format(/,' At end of ',a15,/,' * * * * * *') endif goto 7000 endif endif c........ 6.2 Processes *25* records if (card(8:9).eq.'25') then c.................check for a mininum of 2 *27* rec for preceding *25* rec if(first25) then first25 = .false. else if(k27 .lt. 2) then write(outf,6300)kprev,sernum1,sess(1:1),sess(2:5) 6300 format(/,' Less than 2 *27* records for *25*', $ ' record (line ',i4,') ',i4,a1,' ',a5) endif endif k27 = 0 c........................ read(card,'(10x,i4,1x,i3,1x,a5)')sernum1,day,sess c........ Verifies valid range for day (1:366) if ((day .lt. 1) .or. (day .gt. 366)) then write(outf,6200) day,k,sernum1,sess 6200 format(/,' Day ',i3,' for record ',i7,' is out of valid', $ ' range 1:366. Due to error,'/,' vector', $ ' consisting of station serial number ',i4.4, $ ', sess/station ID',/,4x,a5,' was not processed.') goto 6100 endif c........ 6.21 Checks to see if the SSN/station ID match is consistent c with the station file match. If not, prints errmsg; c otherwise, marks true in seen array read(sta,rec=sernum1,fmt=5210)station if (station.ne.card(21:24)) then if (station .eq. ' ') then write(outf,6210) sernum1 6210 format(/,' Station serial number ',i4.4,' not loaded', $ ' into program from station file.') else write(outf,6211) station,sernum1 6211 format(/,' Station ',a4,' is assigned to serial number', $ 1x,i4.4,' in the station file.') endif write(outf,6212) card(21:24),day,k 6212 format(' Station ',a4,' is incorrectly assigned to', $ ' this number in the',/,' bfile (day # ',i3, $ ', record # ',i7,').') i=look(card(21:24)) if (i .eq. 0) then write(outf,6213) card(21:24) 6213 format(' Station ',a4,' is not in the list of 4-char', $ ' IDs loaded into program.') else write(outf,6214) card(21:24),i 6214 format(' Station ',a4,' is assigned to serial', $ ' number ',i4.4,' in the station file.') endif else read(seenf,rec=sernum1,fmt=6215)seen 6215 format(3a1) seen(2)='t' write(seenf,rec=sernum1,fmt=6215)seen endif c........ 6.22 Converts lowercase characters in string to uppercase do 6220 i=20,24 ch=card(i:i) if (ch .ge. 'a') then ch=char(ichar(ch)-32) card(i:i)=ch endif 6220 continue c........ 6.23 Checks gfile for occurrences of station occupation data c in the bfile with no corresponding vector data in the c gfile i=0 n=0 dup25=.false. 6230 call checkgf(card(20:24),day,k,dup25) kprev=k c........ Loads dayif and b25f in preparation for mode reductions found=.false. if (.not. dup25) then if (maxln .eq. 0) then maxln=1 rn=1 dayi(1)=day i=1 dayi(2)=i write(dayif,rec=rn,fmt=6231)dayi 6231 format(2i5) b25(i)=card(20:24) k25(i)=k write(b25f,rec=rn,fmt=6232)b25 6232 format(16a5) write(k25f,rec=rn,fmt=6233)k25 6233 format(16i5) else do 6234 rn=1,maxln read(dayif,rec=rn,fmt=6231)dayi if (dayi(1) .eq. day) then i=dayi(2) if (i .lt. 16) then found = .true. i = i + 1 dayi(2)=i write(dayif,rec=rn,fmt=6231)dayi read(b25f,rec=rn,fmt=6232)b25 read(k25f,rec=rn,fmt=6233)k25 b25(i)=card(20:24) k25(i)=k write(b25f,rec=rn,fmt=6232)b25 write(k25f,rec=rn,fmt=6233)k25 endif endif 6234 continue if (.not. found) then maxln=maxln+1 dayi(1)=day i=1 dayi(2)=i write(dayif,rec=maxln,fmt=6231)dayi b25(i)=card(20:24) k25(i)=k write(b25f,rec=maxln,fmt=6232)b25 write(k25f,rec=maxln,fmt=6233)k25 endif endif elseif (dup25) then do 6238 rn=1,maxln read(dayif,rec=rn,fmt=6231)dayi if ((dayi(1) .eq. day) .and. (.not. found)) then i=dayi(2) read(b25f,rec=rn,fmt=6232)b25 do 6236 n=1,i if (b25(n) .eq. card(20:24)) then found=.true. read(k25f,rec=rn,fmt=6233)k25 write(outf,6235) k25(n),k,day,card(20:20), $ card(21:24) 6235 format(/,' Duplicate bfile *25* records', $ ' (lines ',i7,',',i7,') for ',i3,a1,' ', $ a4) endif 6236 continue endif 6238 continue endif goto 6100 c........ 6.3 Verifies existence of two *27* records for each station in each c session. c elseif(card(8:9) .eq. '27') then c read(card,'(t11,i4)')sernum2 c if (sernum2 .eq. sernum1) then c read(300,'(a80)') card c k = k+1 c read(card,'(t11,i4)')sernum2 c if ((card(8:9).ne.'27').or.(sernum2 .ne. sernum1)) then c write(outf,6300)kprev,sernum1,sess(1:1),sess(2:5) c6300 format(/,' Insufficient number of *27* records for *25*', c $ ' record (line ',i4,') ',i4,a1,' ',a5) c endif c else c write(outf,6300)kprev,sernum1,sess(1:1),sess(2:5) c endif c goto 6100 c........6.3 Verifies *27* record has same ssn as *25* record elseif(card(8:9) .eq. '27') then k27 = k27 + 1 read(card,'(t11,i4)')sernum2 if (sernum2 .ne. sernum1) then write(outf,6301)kprev,sernum1,sess(1:1),sess(2:5) 6301 format(/,' *27* record serial number mismatch', $ ' for *25* record (line ',i4,') ',i4,a1,' ',a5) endif goto 6100 c........ 6.4 Verifies existence of one *80* record per station. elseif(card(8:9).eq.'80') then read(card,'(10x,i4)')sernum1 read(sta,rec=sernum1,fmt=5210)station if (station.eq.' ') then write(outf,6400) sernum1,k,card(15:44) 6400 format(/,' Station serial number ',i4.4,' was not loaded', $ ' into the program from the',/,4x,'station file,', $ ' but is assigned to bfile *80* (record ',i7, $ ') station',/,4x,'name ',a30) else read(seenf,rec=sernum1,fmt=6410)seen 6410 format(3a1) ch=seen(3) if (ch .eq. 't') then read(b80f,rec=sernum1,fmt=6411)b80 6411 format(a30) read(vectorf,rec=sernum1,fmt=6412)k80 6412 format(i5) if (b80 .eq. card(15:44)) then write(outf,6413)k80,k,sernum1 6413 format(/,' Duplicate bfile *80* records (lines ',i7, $ ',',i7,') for serial number ',i4.4) else write(outf,6414)k80,k,sernum1 6414 format(/,' Bfile *80* records (lines ',i7,',',i7, $ ') both assigned to serial number',/,4x,i4.4, $ ', but have different 30-char station names.') endif else seen(3)='t' write(seenf,rec=sernum1,fmt=6410)seen b80=card(15:44) write(b80f,rec=sernum1,fmt=6411) b80 k80=k write(vectorf,rec=sernum1,fmt=6412) k80 endif endif goto 6100 c........ 6.5 Not *25*, *27*, or *80* so read next record. else goto 6100 endif c........ 7.0 Calculates mode reductions indicating which vectors have c been omitted from the gfile 7000 print *,'* * * * * *' print * if (.not. (smode .or. mmode)) then goto 7100 endif do 7090 day=1,366 read(originf,rec=day,fmt=7005)origin 7005 format(7a5) do 7080 o=1,7 if (origin(o) .eq. 'eoln ') then goto 7090 else maxvln=0 maxv2ln=0 do 7030 d=1,maxln read(dayif,rec=d,fmt=7010)dayi 7010 format(2i5) if (dayi(1) .eq. day) then i=dayi(2) read(b25f,rec=d,fmt=7015)b25 7015 format(16a5) do 7025 j=1,i if (mmode) then if ((origin(o)(1:1) .eq. b25(j)(1:1)) .and. $ (origin(o) .ne. b25(j))) then maxvln=maxvln+1 vector=origin(o)//b25(j) write(vectorf,rec=maxvln,fmt=7020)vector 7020 format(a10) endif elseif (smode) then if (origin(o)(1:1) .eq. b25(j)(1:1)) then maxv2ln=maxv2ln+1 write(tempf,rec=maxv2ln,fmt=7022)b25(j) 7022 format(a5) endif endif 7025 continue endif 7030 continue if (smode) then first=1 7032 if (first .lt. maxv2ln) then read(tempf,rec=first,fmt=7034)one 7034 format(a5) do 7038 second=first+1,maxv2ln read(tempf,rec=second,fmt=7022)two vector=one//two maxvln=maxvln+1 write(vectorf,rec=maxvln,fmt=7036)vector 7036 format(a10) 7038 continue first=first+1 goto 7032 endif endif do 7060 i=1,basecnt if (baselind(i) .eq. day) then do 7050 j=1,maxvln read(vectorf,rec=j,fmt=7040)vector 7040 format(a10) if (mmode) then if (baseline(i) .eq. vector) then vector(1:1)='9' write(vectorf,rec=j,fmt=7040)vector goto 7060 endif elseif (smode) then testline1=vector testline2=vector(6:10)//vector(1:5) if ((baseline(i) .eq. testline1) .or. $ (baseline(i) .eq. testline2)) then vector(1:1)='9' write(vectorf,rec=j,fmt=7040)vector goto 7060 endif endif 7050 continue endif 7060 continue do 7070 i=1,maxvln read(vectorf,rec=i,fmt=7040)vector if (vector(1:1) .ne. '9') then write(outf,7065) vector,day 7065 format(/,1x,a10,' omitted from gfile baseline', $ ' vectors for day ',i5) endif 7070 continue endif 7080 continue 7090 continue c........ 7.1 Reports inconsistencies of station ID/SSN match between c gfile and bfile when compared to the station file and c whether there exists an *80* for each station. 7100 do 7120 sernum1=1,9999 read(sta,rec=sernum1,fmt=7101)station 7101 format(a4) if(station.ne.' ') then read(seenf,rec=sernum1,fmt=7110)seen 7110 format(3a1) if ((seen(1).eq.'f') .and. (seen(2).eq.'f')) then write(outf,7111)sernum1,station 7111 format(/,' Serial number ',i4.4,' station ',a4,' not in', $ ' gfile or bfile.') elseif ((seen(1).eq.'f') .and. (seen(2).eq.'t')) then write(outf,7112)sernum1,station 7112 format(/,' Serial number ',i4.4,' station ',a4,' in', $ ' bfile, but not in gfile.') elseif ((seen(1).eq.'t') .and. (seen(2).eq.'f')) then write(outf,7113)sernum1,station 7113 format(/,' Serial number ',i4.4,' station ',a4,' in', $ ' gfile, but not in bfile.') endif if ((seen(3).eq.'f') .and. (seen(1).eq.'t')) then write(outf,7114)sernum1,station 7114 format(/,' No bfile *80* entry for serial number ',i4.4, $ ' station ',a4,'.') endif endif 7120 continue c........ 7.2 Checks whether there exists a bfile *25* record for each c gfile origin and differential station max=0 rn=1 do 7270 i=1,basecnt if (baselind(i).ne.0 ) then day = baselind(i) if (done1(i).ne.'t') then sess=baseline(i)(1:5) if (max .eq. 0) then write(errf1,rec=rn,fmt=7210) day 7210 format(i3) write(errf2,rec=rn,fmt=7220) sess 7220 format(a5) max=1 else do 7230 rn=1,max read(errf1,rec=rn,fmt=7210) errday read(errf2,rec=rn,fmt=7220) errsess if ((errday.eq.day).and.(errsess.eq.sess)) then goto 7240 endif 7230 continue max=max+1 write(errf1,rec=max,fmt=7210) day write(errf2,rec=max,fmt=7220) sess endif endif 7240 if (done2(i).ne.'t') then sess=baseline(i)(6:10) if (max .eq. 0) then write(errf1,rec=rn,fmt=7210) day write(errf2,rec=rn,fmt=7220) sess max=1 else do 7250 rn=1,max read(errf1,rec=rn,fmt=7210) errday read(errf2,rec=rn,fmt=7220) errsess if ((errday.eq.day).and.(errsess.eq.sess)) then goto 7270 endif 7250 continue max=max+1 write(errf1,rec=max,fmt=7210) day write(errf2,rec=max,fmt=7220) sess endif endif endif 7270 continue do 7290 rn=1,max read(errf1,rec=rn,fmt=7210) errday read(errf2,rec=rn,fmt=7220) errsess write(outf,7280)errday,errsess(1:1),errsess(2:5) 7280 format(/,' No bfile *25* record for day/station: ', $ i3,a1,' ',a4) 7290 continue print *,'* * * * * *' print * print *,'At end of compgb' print *,'output written to file ',outfile write(outf,7292) 7292 format(' * * * * * *',/,/,' At end of compgb') close(outf) stop end cb::look c function look(stacalled) c c********1*********2*********3*********4*********5*********6*********7** c Name: look c Version: 1.1 (9001.12) c Written by: ____________ & TJ Cacanindin c Purpose: This subprogram accepts a station ID from the calling c unit to find its appropriate station file SSN match in c the sta file. c c Local Variables and Constants: c ------------------------------ c sernum : station serial number (SSN) c stacalled : station ID sent by the calling unit c station : station ID read from sta file c c Global Variables and Constants: c ------------------------------- c sta : var containing the unit number assigned to the c direct access file consisting of the c definitive station list of SSNs and their c assigned station IDs c c c This Module Called By : compgb c c This Module Calls : none c c Include Files Used : none c c Common Blocks Used : none c c References: RM/FORTRAN Manual, COMPGB User's Documentation c c Comments: none c c********1*********2*********3*********4*********5*********6*********7** c Modification History: c::9001.12, TJC, Station serial number field expanded to 4 digits c********1*********2*********3*********4*********5*********6*********7** ce::look integer*4 look,sta,sernum character*4 station,stacalled sta=510 do 100 sernum=1,9999 read(sta,rec=sernum,fmt=50)station 50 format(a4) if (station.eq.stacalled) then look=sernum goto 110 endif 100 continue look=0 110 return end cb::checkgf c subroutine checkgf(station,day,k,dup25) c c********1*********2*********3*********4*********5*********6*********7** c Name: checkgf c Version: 1.1 (9001.12) c Written by: ______________ & TJ Cacanindin c Purpose: This subprogram checks the gfile to see if session and c station ID of the current bfile record are in the set c of allowable baseline vector entries for the day. c c Local Variables and Constants: c ------------------------------ c ch : 't'/'f' value which indicates whether a certain c bfile *25* record has previously appeared c day : UTC day of year baseline vector observed c done1(90) : indicate whether bfile *25* sess/station IDs are c origin stations for the gfile baseline vectors c done2(90) : indicate whether bfile *25* sess/station IDs are c differential stations for gfile baseline vectors c dup25 : indicates whether duplicate *25* exists for day c errday : day of record to appear in output error message c errsess : sess/sta ID of record to appear in output errmsg c ingfile : indicates whether a certain bfile vector is c recorded in the gfile c int : represents the starting position of "station" c within the baseline(day,i) character string c k : record line counter c rn : record number of the direct access file c station : station ID read from sta file c c Global Variables and Constants: c ------------------------------- c baseline(366,90) : array of all baseline vectors in gfile indexed c by day (90 vectors/day are allowed) c max : maximum number of records in error files c c c This Module Called By : compgb c c This Module Calls : none c c Include Files Used : none c c Common Blocks Used : /globls/ c c References: RM/FORTRAN Manual, COMPGB User's Documentation c c Comments: none c c********1*********2*********3*********4*********5*********6*********7** c Modification History: c::9001.12, TJC, Flags duplicate bfile *25*s and errmsgs c********1*********2*********3*********4*********5*********6*********7** ce::checkgf integer*4 day,i,donef1,donef2,int,max,rn,k,errf1,errf2,errday integer*4 basecnt character*10 baseline(5999) integer*4 baselind(5999) character*5 station,errsess character*1 done1(5999),done2(5999),ch logical dup25,ingfile common/globls/baselind,baseline,basecnt,max common/globls2/done1,done2 data donef1,donef2,errf1,errf2/430,440,450,460/ ingfile=.false. dup25=.false. do 20 i=1,basecnt if(baselind(i) .eq. day) then if (index(baseline(i),station).ne.0) then int=index(baseline(i),station) if (int .eq. 1) then ch=done1(i) if (ch .eq. 't') then dup25=.true. else done1(i)='t' endif else ch=done2(i) if (ch .eq. 't') then dup25=.true. else done2(i)='t' endif endif ingfile=.true. endif endif 20 continue c........ Loads errf1,errf2 so that "No gfile "C/F" member record for c day\station" message appears rn=1 if (.not.ingfile) then if (max .eq. 0) then write(errf1,rec=rn,fmt=25)day 25 format(i3) write(errf2,rec=rn,fmt=27)station 27 format(a5) max=1 else do 30 rn=1,max read(errf1,rec=rn,fmt=25)errday read(errf2,rec=rn,fmt=27)errsess if ((errday .eq. day) .and. (errsess .eq. station)) then dup25=.true. goto 40 endif 30 continue max=max+1 write(errf1,rec=max,fmt=25)day write(errf2,rec=max,fmt=27)station endif endif 40 return end cb::dup c logical function dup (day,testline1,testline2) c c********1*********2*********3*********4*********5*********6*********7** c Name: dup c Version: 1.2 (9703.14) c Written by: JBM c Purpose: This logical function checks if day,testline1,and C testline2 are in the baselind and baseline arrays c c Local Variables and Constants: c ------------------------------ c day : UTC day of year baseline vector observed c within the baseline(day,i) character string c c Global Variables and Constants: c ------------------------------- c baseline(5999) : array of all baseline vectors in gfile c baselind(5999) : array of days c basecnt : array count c c This Module Called By : compgb c c This Module Calls : none c c Include Files Used : none c c Common Blocks Used : /globls/ c c References: RM/FORTRAN Manual, COMPGB User's Documentation c c Comments: none c c********1*********2*********3*********4*********5*********6*********7** ce: dup integer*4 day,i,max integer*4 basecnt character*10 testline1,testline2 character*10 baseline(5999) integer*4 baselind(5999) common/globls/baselind,baseline,basecnt,max dup = .false. do 10 i = 1,basecnt if(baselind(i) .eq. day) then if((baseline(i) .eq. testline1) .or. $ (baseline(i) .eq. testline2)) then dup = .true. return endif endif 10 continue return end