c--------( GTRIM : trim-off data of undef.range in ref.data )-------- parameter (LX=4001, LY=4001) c dimension f(LX,LY), g(LX,LY) character*80 wdr, flog, fnam1, fnam2, fnam3 character area*8, area2*8, narea*8, area1*8, anul*10 character buf*80, out*72, salt*8, salt2*8, sdtm*20 c call premsg('GTRIM : trim-off data of undef.range in ref.data') call opnpin() ldr = lwkdir(50,wdr) + 1 flog = wdr fnam1 = wdr fnam2 = wdr fnam3 = wdr call gparma('Enter LOG filename ==> ', 81-ldr, flog(ldr:80)) call gparma('Enter Input source data filename ==> ', * 81-ldr, fnam1(ldr:80)) open(1,file=fnam1,status='old') 1 read(1,'(a)') buf if(buf(1:1).eq.'#') goto 1 read(buf,'(a8,i4,4x,4i8)') area, ncc, iorg,korg, ispa,ispb nc = ncc if(ncc.ge.200) nc = ncc - 200 if(nc.ge.1.and.nc.le.62) then iorg = 0 ispa = 0 ispb = 0 korg = (nc-30)*360 - 180 if(nc.gt.60) korg = 0 if(nc.eq.61) iorg = +5400 if(nc.eq.62) iorg = -5400 endif read(1,'(a)') buf read(buf,*) ixs, iys, mszx, mszy, mx, my, vnul, alt write(salt,'(1x,f7.0)') alt if (alt.eq.0.) salt = ' var.' if (alt.lt.0.) salt = ' undef' xs = float(ixs)/1000. ys = float(iys)/1000. if(mx.gt.LX.or.my.gt.LY) call abendm('too large array size') write(anul,'(f9.2)') vnul if(anul(9:9).ne.'0'.or.anul(1:1).ne.' ') * call abendm('unable to handle vnul value') call gparma('Enter Range reference filename ==> ', * 81-ldr, fnam2(ldr:80)) open(2,file=fnam2,status='old') 2 read(2,'(a)') buf if(buf(1:1).eq.'#') goto 2 read(buf,'(a8,i4,4x,4i8)') area2, ncc2, iorg2,korg2, ispa2,ispb2 nc2 = ncc2 if(ncc2.ge.200) nc2 = ncc2 - 200 if(nc2.ge.1.and.nc2.le.62) then iorg2 = 0 ispa2 = 0 ispb2 = 0 korg2 = (nc2-30)*360 - 180 if(nc2.gt.60) korg2 = 0 if(nc2.eq.61) iorg2 = +5400 if(nc2.eq.62) iorg2 = -5400 endif read(2,'(a)') buf read(buf,*) ixs2, iys2, mszx2, mszy2, mx2, my2, vnul2, alt2 write(salt2,'(1x,f7.0)') alt2 if (alt2.eq.0.) salt2 = ' var.' if (alt2.lt.0.) salt2 = ' undef' xs2 = float(ixs2)/1000. ys2 = float(iys2)/1000. write(anul,'(f10.3)') vnul2 if(anul(9:10).ne.'00'.or.anul(1:1).ne.' ') * call abendm('unable to handle vnul2 value') write(out,'(a,a8,a,i4,4x,4i8)') * '--- Area : ', area, ' Coord.', ncc, iorg,korg, ispa,ispb call premsg(out) if(ncc2.ne.ncc) then write(out,'(11x,a8,6x,i4,4x,4i8)') * area2, ncc2, iorg2,korg2, ispa2,ispb2 call premsg(out) call abendm('Header inconsistent') endif if(area2.ne.area) call premsg(' ' // area2) write(out,'(a,2a10,2x,2a8,2a6,a7)') * '--- (mesh) ', 'xs', 'ys', 'msz-x', 'msz-y', 'mx', 'my', * 'alt' call premsg(out) write(out,'(a,2f10.2,2i8,2i6,a8)') * '--- source ', xs, ys, mszx, mszy, mx, my, salt call premsg(out) write(out,'(a,2f10.2,2i8,2i6,a8)') * '--- reference ', xs2, ys2, mszx2, mszy2, mx2, my2, salt2 call premsg(out) if(ixs2.ne.ixs.or.iys2.ne.iys .or. * mszx2.ne.mszx.or.mszy2.ne.mszy .or. * mx2.ne.mx.or.my2.ne.my) * call abendm('Header inconsistent') read(1,*) ((f(i,j),i=1,mx),j=1,my) read(2,*) ((g(i,j),i=1,mx),j=1,my) close(2) call premsg('') call gparma('Enter Name-label for new file ==> ', 8, narea) call gparma('Enter output new data filename ==> ', * 81-ldr, fnam3(ldr:80)) call clspin() open(3,file=fnam3,status='new') write(6,'(a)') '----------------------------------------' write(6,'(a)') 'GTRIM : trim-off data of undef.range in ref.data' write(6,'(a,a)') ' Source infile : ', fnam1(1:lrtrim(fnam1)) write(6,'(a,a)') ' areaname : ', area write(6,'(a,a)') ' Reference file : ', fnam2(1:lrtrim(fnam2)) write(6,'(a,a)') ' areaname : ', area2 write(6,'(a,a)') ' Output new file : ', fnam3(1:lrtrim(fnam3)) write(6,1000) narea, ncc, iorg,korg, ispa,ispb, * xs, ys, mszx, mszy, mx, my, salt c write(3,'(a,a)') '# Source : ', fnam1(1:lrtrim(fnam1)) write(3,'(a2,a8,i4,4x,4i8)') * '# ', area, ncc, iorg,korg, ispa,ispb write(3,'(a,a)') '# Reference: ', fnam2(1:lrtrim(fnam2)) write(3,'(a2,a8,i4,4x,4i8)') * '# ', area2, ncc, iorg,korg, ispa,ispb write(3,'(a)') '# prog.GTRIM applied to 2 files above' write(3,'(a8,i4,4x,4i8)') narea, ncc, iorg,korg, ispa,ispb write(3,'(2i12,4i6,1x,f7.1,1x,f7.0)') * ixs,iys, mszx,mszy, mx,my, vnul, alt c do 100 j=1,my do 100 i=1,mx if(g(i,j).eq.vnul2) f(i,j) = vnul 100 continue do 200 j=1,my write(3,'((f7.1,9(1x,f7.1)))') (f(i,j),i=1,mx) 200 continue c if(alt.ne.0.) goto 8 3 read(1,'(a)') buf if(buf(1:1).eq.'#') goto 3 read(buf,'(a8,i4,4x,4i8)') area1, ncc1, iorg1,korg1, ispa1,ispb1 nc1 = ncc1 if(ncc1.ge.200) nc1 = ncc1 - 200 if(nc1.ge.1.and.nc1.le.62) then iorg1 = 0 ispa1 = 0 ispb1 = 0 korg1 = (nc1-30)*360 - 180 if(nc1.gt.60) korg1 = 0 if(nc1.eq.61) iorg1 = +5400 if(nc1.eq.62) iorg1 = -5400 endif if(area1.ne.area.or.ncc1.ne.ncc .or. * iorg1.ne.iorg.or.korg1.ne.korg .or. * ispa1.ne.ispa.or.ispb1.ne.ispb) * call abendm('Header1 inconsistent') read(1,*) ixs1, iys1, mszx1, mszy1, mx1, my1, vnul1 if(ixs1.ne.ixs.or.iys1.ne.iys .or. * mszx1.ne.mszx.or.mszy1.ne.mszy .or. * mx1.ne.mx.or.my1.ne.my) * call abendm('Header2 inconsistent') write(anul,'(f10.3)') vnul1 if(anul(9:10).ne.'00'.or.anul(1:1).ne.' ') * call abendm('unable to handle vnul1 value') read(1,*) ((f(i,j),i=1,mx),j=1,my) do 300 j=1,my do 300 i=1,mx if(g(i,j).eq.vnul2) f(i,j) = vnul 300 continue write(3,'(a8,i4,4x,4i8)') narea, ncc, iorg,korg, ispa,ispb write(3,'(2i12,4i6,1x,f7.1,1x,f7.0)') * ixs,iys, mszx,mszy, mx,my, vnul1, -1. do 400 j=1,my write(3,'((f7.1,9(1x,f7.1)))') (f(i,j),i=1,mx) 400 continue c 8 close(1) close(3) c if(flog(ldr:ldr).ne.' ') then open(99,file=flog,access='append') write(99,'(//a)') * 'GTRIM : trim-off data of undef.range in ref.data' write(99,'(a,a)') ' Source infile : ', fnam1(1:lrtrim(fnam1)) write(99,'(a,a)') ' areaname : ', area write(99,'(a,a)') ' Reference file : ', fnam2(1:lrtrim(fnam2)) write(99,'(a,a)') ' areaname : ', area2 write(99,'(a,a)') ' Output new file : ', fnam3(1:lrtrim(fnam3)) write(99,1000) narea, ncc, iorg,korg, ispa,ispb, * xs, ys, mszx, mszy, mx, my, salt call strdtm(sdtm) write(99,'(a,a,a)') '=============== ', sdtm, '===============' close(99) endif stop c 1000 format('Areaname : ', a8, 5x, 'Coord.', i4, 4x, 4i8/ * 3x, ' (mesh) ', ' xs ', ' ys ', * ' msz-x', ' msz-y', ' mx', ' my', ' alt '/ * 3x, 'grid out=in ', 2f10.2, 2i8, 2i6, a8) end