program chngmd c c B. Foster 6/93: c Read series of tigcm model history volumes, decrement model day by 1 c on the headers, and rewrite new volumes (to correct lex read error c made in a run of getndcs which was used in original model runs) c Original model vols (15 of them): hist 10.0-18.0, 7/10-18/82 82191-82199 c New model vols : hist 9.0-17.0, 7/09-17/82 82190-82198 c note: changed date(2) on new model hist to reflect julian days -- see jday0 c include "tgcmhdr.h" common/head/ ihead(512) c parameter(imx=73,kmx=25,jmx=36,nflds=16,imxp1=imx+1,nwlat=44475) parameter(imx=73,kmx=45,jmx=36,nflds=30,imxp1=imx+1,nwlat=143191) c parameter(nwlat=1+imxp1*kmx*nflds) ! # words in lat slice c parameter(nvol=7) parameter(nvol=1) dimension frd(nwlat),sum(100),hpwr(200),cpot(200),by(200) character*24 mssvol(nvol),mssnvol(nvol),diskflnm character*80 toplab dimension iasf(13) data iasf/13*1/ data luvol/9/, lunvol/10/, luasc/11/ c c Original volumes: c data mssvol c + /'/ROBLE/RGR93/TIJST1 ','/ROBLE/RGR93/TIJST2 '/ c data mssvol c + /'/ROBLE/RGR93/TIJST3 ','/ROBLE/RGR93/TIJST4 ', c + '/ROBLE/RGR93/TIJST5 ','/ROBLE/RGR93/TIJST6 ', c + '/ROBLE/RGR93/TIJST7 ','/ROBLE/RGR93/TIJST8 '/ c data mssvol c + /'/ROBLE/RGR93/TIJST9 ','/ROBLE/RGR93/TIJST10 ', c + '/ROBLE/RGR93/TIJST11 ','/ROBLE/RGR93/TIJST12 ', c + '/ROBLE/RGR93/TIJST13 ','/ROBLE/RGR93/TIJST14 ', c + '/ROBLE/RGR93/TIJST15 '/ data mssvol + /'/ROBLE/RGR94/TSFLXD7 '/ c c New volumes: c data mssnvol c + /'/FOSTER/BTF93/TIJST1 ','/FOSTER/BTF93/TIJST2 '/ c data mssnvol c + /'/FOSTER/BTF93/TIJST3 ','/FOSTER/BTF93/TIJST4 ', c + '/FOSTER/BTF93/TIJST5 ','/FOSTER/BTF93/TIJST6 ', c + '/FOSTER/BTF93/TIJST7 ','/FOSTER/BTF93/TIJST8 '/ c data mssnvol c + /'/FOSTER/BTF93/TIJST9 ','/FOSTER/BTF93/TIJST10 ', c + '/FOSTER/BTF93/TIJST11 ','/FOSTER/BTF93/TIJST12 ', c + '/FOSTER/BTF93/TIJST13 ','/FOSTER/BTF93/TIJST14 ', c + '/FOSTER/BTF93/TIJST15 '/ data mssnvol + /'/FOSTER/BTF94/TSFLXD7 '/ data iwrmss/1/ c c jday0 = julian day corresponding to corrected model day 0 c i.e., on new corrected vols, date(2) on header will be jday0+md c e.g., first model day 9 corresponds to julian day 190, (July 9) data jday0/181/ c call opngks call gsclip(0) call gsasf(iasf) call gsfais(1) call asign('hpcpby.dat',luasc,ier) c c Volume loop: nhistot = 0 do iv = 1,nvol lenvol = lenstr(mssvol(iv)) write(6,"(' ')") write(6,"('Acquiring vol ',a,' from mss (iv=',i2,')...')") + mssvol(iv)(1:lenvol),iv call getmss(mssvol(iv),luvol) write(6,"('chngmd: acquired mssvol(',i2,') ',a,' on unit ', + i2)") iv,mssvol(iv)(1:lenvol),luvol call tail(mssnvol(iv),diskflnm) lendisk = lenstr(diskflnm) diskflnm(lendisk+1:lendisk+4) = '.new' lendisk = lendisk+4 call asign(diskflnm(1:lendisk),lunvol,ier) write(6,"('chngmd: assigned new disk file ',a,' to unit ',i2)") + diskflnm(1:lendisk),lunvol nhist = 0 200 continue write(6,"(' ')") c c Read header of original volume: call rdhdr(luvol,ieof) if (ieof.gt.0) then write(6,"('EOF on vol ',a,' unit=',i3)") + mssvol(iv)(1:lenvol),luvol goto 100 else nhist = nhist+1 nhistot = nhistot+1 write(6,"('Read hdr from ',a,': mtime=',3i3,' date=',2i4, + ' nh=',i2,' nhtot=',i3)") + mssvol(iv)(1:lenvol),nday,nhr,nmin,date,nhist,nhistot endif c c Decrement model day and correct julian day on header c (the whole point of this code): c ihead(2) = ihead(2)-1 ihead(2) = 1 ! 12/12/94: using this code to change model day to 1 ihead(46) = jday0+ihead(2) call wrhdr(lunvol) ! write changed header to new file write(luasc,"(3i3,3f10.3)") (ihead(i),i=2,4),hp,cp,byimf hpwr(nhistot) = hp cpot(nhistot) = cp by(nhistot) = byimf if (nhistot.eq.1) then md1 = ihead(2) mh1 = ihead(3) mm1 = ihead(4) endif c c Read summary and echo to new file (no changes): read(luvol) sum write(lunvol) sum c c Read lat slices and echo to new file (no changes): do j=1,jmx buffer in(luvol,1)(frd(1),frd(nwlat)) if (unit(luvol)) 10,11,11 11 write(6,"(' >>> io problem buffering in j=', + i3,' luvol=',i3,' unit(luvol)=',e10.3,' iv=',i2, + ' mssvol=',a)") j,luvol,unit(luvol),iv,mssvol(iv)(1:lenvol) stop 'buf in' 10 continue c buffer out(lunvol,1)(frd(1),frd(nwlat)) if (unit(lunvol)) 12,13,13 13 write(6,"(' >>> io problem buffering out j=', + i3,' lunvol=',i3,' unit(lunvol)=',e10.3,' iv=',i2, + ' diskflnm=',a)") j,lunvol,unit(lunvol),iv, + diskflnm(1:lendisk) stop 'buf out' 12 continue enddo goto 200 ! return for next history c c EOF on read volume: 100 continue close(luvol) close(lunvol) c c Dispose new volume to mss (later, new volumes may be moved to old volume c names using msmv): c if (iwrmss.gt.0) then lennvol = lenstr(mssnvol(iv)) write(6,"('Disposing disk file ',a,' as mss file ',a, + ' ...')") diskflnm(1:lendisk),mssnvol(iv)(1:lennvol) call mswrite(ier,diskflnm(1:lendisk), + mssnvol(iv)(1:lennvol),',ECRIDLEY',367,' ') if (ier.ne.0) then write(6,"('>>> mswrite error ',i3,' disposing vol',a, + ' diskfile=',a)") + ier,mssnvol(iv)(1:lennvol),diskflnm(1:lendisk) else write(6,"('Completed mss write of disk file ',a,' to ', + ' mss file ',a)") diskflnm(1:lendisk), + mssnvol(iv)(1:lennvol) endif endif c c end volume loop: enddo close(luasc) mdlast = ihead(2) mhlast = ihead(3) mmlast = ihead(4) c c Plot hp,cp,by as read from headers (skip first point as it was from c source volume): c (these were unchanged, but now correspond to 1 model day earlier) c write(toplab,"('HP nx=',i3,' (',i2,':',i2,':',i2,' to ', + i2,':',i2,':',i2,')')") nhistot-1,md1,mh1,mm1,mdlast,mhlast, + mmlast call ezy(hpwr(2),nhistot-1,toplab(1:lenstr(toplab))) write(toplab,"('CP nx=',i3,' (',i2,':',i2,':',i2,' to ', + i2,':',i2,':',i2,')')") nhistot-1,md1,mh1,mm1,mdlast,mhlast, + mmlast call ezy(cpot(2),nhistot-1,toplab(1:lenstr(toplab))) write(toplab,"('BY nx=',i3,' (',i2,':',i2,':',i2,' to ', + i2,':',i2,':',i2,')')") nhistot-1,md1,mh1,mm1,mdlast,mhlast, + mmlast call ezy(by(2),nhistot-1,toplab(1:lenstr(toplab))) call clsgks stop end c c------------------------------------------------------------------ c Begin file /home/sting/foster/lib/getmss.f c------------------------------------------------------------------ c subroutine getmss(path,lu) c c Get file path from mss and attach to lu: c (use tail of path as local file name) c character*(*) path character*128 locf,errmsg,svpath c svpath = path call tail(path,locf) if (path.eq.' ') then write(6,"('>>> getmss: error in path from tail --', + ' path=',a)") svpath stop 'getmss' endif call msread(ier,locf,path,' ',' ') c c File already on disk: if (ier.eq.3) then write(6,"('getmss: msread found ',a,' on the disk',/ + 9x,'(file ',a,' was not read from mss)')") + locf,path c c Error reading file: elseif (ier.ne.0) then call mserror(errmsg) write(6,"('getmss: msread failed to read mss file ', + a,' to unix disk file ',a)") path,locf write(6,"('errmsg = ',a)") errmsg stop 'msread' c c Good read: else write(6,"('getmss: msread file ',a,' to unix file ',a)") + path,locf endif c c Assign local disk file: call asign(locf,lu) c return end c c------------------------------------------------------------------ c subroutine asign(dname,lu,ier) c c Attach file dname to unit lu (dname and lu defined on input) c 11/91: Like assign.f, but took out nblocks, and changed the ishell c command to a call assign to avoid the fork necessary in ishell c character*(*) dname character fmt*120, cmnd*120 c c Check input: c ier = 0 idch = lenstr(dname) if (idch.le.0.or.idch.gt.99) then write(6,"('asign: bad dname: idch=',i3,' dname=',a)") + idch,dname ier = 1 return endif if (lu.le.0.or.lu.gt.99) then write(6,"('asign: bad lu=',i5,'(dname=',a,')')") lu,dname ier = 2 return endif c c Make format for 'assign -a flnm' part of command: c write(fmt(1:15),"('(''assign -a '',A')") if (idch.lt.10) then write(fmt(16:16),"(i1)") idch nfmt = 16 elseif (idch.lt.100) then write(fmt(16:17),"(i2)") idch nfmt = 17 endif c c Add format for lu part of command: c if (lu.lt.10) then write(fmt(nfmt+1:nfmt+16),"(','' fort.'',I1)')") elseif (lu.lt.100) then write(fmt(nfmt+1:nfmt+17),"(','' fort.'',I2)')") endif nfmt = nfmt+16 c c Make the command, using format just made: c write(cmnd,fmt) dname(1:idch),lu ncmnd = lnblnk2(cmnd) c c Execute the command and check status: c istat = 999 call assign(cmnd(1:ncmnd),istat) if (istat.ne.0) then write(6,"('assign: bad return from call assign=',i5)") istat write(6,"(' command=',a)") cmnd(1:ncmnd) ier = 3 return else write(6,"('asign: successful assign of unit ',i3, + ' to file ',a)") lu,dname(1:idch) endif return end c c------------------------------------------------------------------ c function lnblnk2(str) character*(*) str c c Return number of characters up to first occurrence of 2 consecutive blanks c lnblnk2 = 0 lenstr = len(str) do 100 i=1,lenstr if (str(i:i+1).eq.' ') then lnblnk2 = i-1 return endif 100 continue lnblnk2 = lenstr return end c c------------------------------------------------------------------ c subroutine rdhdr(lu,ieof) include "tgcmhdr.h" dimension iheadc(168) common/head/ ihead(512) data ihead/512*0/ equivalence (iheadc,iter),(iheadc(2),nday),(iheadc(3),nhr), + (iheadc(4),nmin),(iheadc(5),label),(iheadc(45),date), + (iheadc(47),output),(iheadc(107),start),(iheadc(110),stp), + (iheadc(116),hist),(iheadc(122),sav),(iheadc(125),step), + (iheadc(126),mag),(iheadc(130),difhor),(iheadc(131),iuivi), + (iheadc(132),sdtide),(iheadc(142),ipower),(iheadc(143),aurora), + (iheadc(144),dispos),(iheadc(145),data),(iheadc(148),source), + (iheadc(151),sourct),(iheadc(154),dtide),(iheadc(156),dum), + (iheadc(164),rdate),(iheadc(165),naur),(iheadc(166),hp), + (iheadc(167),cp),(iheadc(168),byimf) dimension head(512) equivalence (ihead,head) c ieof = 0 buffer in(lu,1)(ihead,ihead(512)) if (unit(lu).eq.0.) then ieof = 1 return endif do i=1,168 iheadc(i) = ihead(i) enddo naurp = naur do i=1,60 aurp(i) = head(165+naurp+i) enddo do i=1,30 theta0(i) = aurp(i) enddo do i=1,30 rrad(i) = aurp(i+30) enddo rmodnum = head(165+naurp+60+1) colfac = head(165+naurp+60+2) f107d = head(165+naurp+60+3) f107a = head(165+naurp+60+4) return end c subroutine wrhdr(lu) include "tgcmhdr.h" common/head/ ihead(512) dimension head(512) equivalence (ihead,head) write(6,"('wrhdr: ihead(2-4)=',3i3,' ihead(45-46)=',2i4, + ' head(166-168)=',3f9.2)") + (ihead(i),i=2,4),(ihead(i),i=45,46),(head(i),i=166,168) buffer out(lu,1)(ihead,ihead(512)) return end c c------------------------------------------------------------------ c Begin file /home/sting/foster/lib/tail.f c------------------------------------------------------------------ c subroutine tail(path,file) c c Given path, return tail part (i.e., file name) c character*(*) path,file c lenpath = lenstr(path) if (lenpath.le.0) then write(6,"('tail: lenpath=',i3,' (path is all blanks)', + ' -- returning a single blank')") lenpath file = ' ' return endif islash = 0 ix = 1 do i=1,lenpath if (path(i:i).eq.'/') then islash = 1 else if (islash.gt.0) then ix = i islash = 0 endif endif enddo file = path(ix:lenpath) return end c function lenstr(str) character*(*) str c c Return index to last non-blank char in str c length = len(str) do i=length,1,-1 if (str(i:i).ne.' ') then lenstr = i return endif enddo lenstr = 0 return end c subroutine clearstr(str) c c Set given string to all blanks c character*(*) str length = len(str) do i=1,length str(i:i) = ' ' enddo return end