!--------( GTRIM : trim-off data of undef.range in ref.data )-------- implicit none integer :: lwkdir, lrtrim real,allocatable :: f(:,:), g(:,:) character(80) :: wdr, flog, fnam1, fnam2, fnam3, buf character(72) :: out; character(20) :: sdtm; character(10) :: anul character(8) :: area, area1, area2, narea, salt, salt2 integer :: ldr, i, j integer :: nc, ncc, iorg, korg, ispa, ispb integer :: nc1, ncc1, iorg1, korg1, ispa1, ispb1 integer :: nc2, ncc2, iorg2, korg2, ispa2, ispb2 integer :: ixs, iys, mszx, mszy, mx, my integer :: ixs1, iys1, mszx1, mszy1, mx1, my1 integer :: ixs2, iys2, mszx2, mszy2, mx2, my2 real :: vnul, alt, xs, ys, xs2, ys2, vnul1, vnul2, alt2 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') read(1,'(a)') buf do while (buf(1:1) == '#') read(1,'(a)') buf enddo if (buf(13:16) == ' ') then !-- v2005 read(buf,'(a8,i4,4x,4i8)') area, ncc, iorg, korg, ispa, ispb if ((ncc<0) .or. (ncc>=400)) call abendm('invalid coord.no.') nc = ncc if (ncc < 200) then nc = ncc; ncc = nc + 800 else ncc = ncc - 200; nc = ncc endif else !-- v2018 read(buf,'(a8,4x,i4,4i8)') area, ncc, iorg, korg, ispa, ispb nc = ncc if ((ncc >= 800) .and. (ncc < 1000)) nc = ncc - 800 endif if ((nc >= 1) .and. (nc <= 62)) then iorg = 0; ispa = 0; ispb = 0 korg = (nc-30)*360 - 180 if (nc > 60) korg = 0 if (nc == 61) iorg = +5400 if (nc == 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 == 0.) salt = ' var.' if (alt < 0.) salt = ' undef' xs = float(ixs)/1000. ys = float(iys)/1000. allocate(f(mx,my)); allocate(g(mx,my)) write(anul,'(f9.2)') vnul if ((anul(9:9) /= '0') .or. (anul(1:1) /= ' ')) then call abendm('unable to handle vnul value') endif call gparma('Enter Range reference filename ==> ', 81-ldr, fnam2(ldr:80)) open(2,file=fnam2,status='old') read(2,'(a)') buf do while (buf(1:1) == '#') read(2,'(a)') buf enddo if (buf(13:16) == ' ') then !-- v2005 read(buf,'(a8,i4,4x,4i8)') area2, ncc2, iorg2,korg2, ispa2,ispb2 if ((ncc2<0) .or. (ncc2>=400)) call abendm('invalid coord.no.') nc2 = ncc2 if (ncc2 < 200) then nc2 = ncc2; ncc2 = nc2 + 800 else ncc2 = ncc2 - 200; nc2 = ncc2 endif else !-- v2018 read(buf,'(a8,4x,i4,4i8)') area2, ncc2, iorg2,korg2, ispa2,ispb2 nc2 = ncc2 if ((ncc2 >= 800) .and. (ncc2 < 1000)) nc2 = ncc2 - 800 endif if ((nc2 >= 1) .and. (nc2 <= 62)) then iorg2 = 0; ispa2 = 0; ispb2 = 0 korg2 = (nc2-30)*360 - 180 if (nc2 > 60) korg2 = 0 if (nc2 == 61) iorg2 = +5400 if (nc2 == 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 == 0.) salt2 = ' var.' if (alt2 < 0.) salt2 = ' undef' xs2 = float(ixs2)/1000. ys2 = float(iys2)/1000. write(anul,'(f10.3)') vnul2 if ((anul(9:10) /= '00') .or. (anul(1:1) /= ' ')) then call abendm('unable to handle vnul2 value') endif write(out,'(a12,a8,6x,a6,i4,4x,4i8)') & '--- Area : ', area, 'Coord.', ncc, iorg,korg, ispa,ispb call premsg(out) if (ncc2 /= ncc) then write(out,'(12x,a8,12x,4x,i4,4i8)') area2, ncc2, iorg2,korg2, ispa2,ispb2 call premsg(out) call abendm('Header inconsistent') endif if (area2 /= area) call premsg(' ' // area2) write(out,'(a14,2a10,2x,2a8,2a6,a8)') & '--- (mesh) ', 'xs', 'ys', 'msz-x', 'msz-y', 'mx', 'my', 'alt ' call premsg(out) write(out,'(a16,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 /= ixs) .or. (iys2 /= iys) .or. (mszx2 /= mszx) .or. & (mszy2 /= mszy) .or. (mx2 /= mx) .or. (my2 /= 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,'(a12,a8,6x,a6,i4,4x,4i8)') & 'Areaname : ', narea, 'Coord.', ncc, iorg,korg, ispa,ispb write(6,'(4x,a)') & ' (mesh) xs ys msz-x msz-y mx my alt ' write(6,'(4x,a12,2f10.2,2i8,2i6,a8)') & 'grid out=in ', xs, ys, mszx, mszy, mx, my, salt write(3,'(a,a)') '# Source : ', fnam1(1:lrtrim(fnam1)) write(3,'(a2,a8,4x,i4,4i8)') '# ', area, ncc, iorg,korg, ispa,ispb write(3,'(a,a)') '# Reference: ', fnam2(1:lrtrim(fnam2)) write(3,'(a2,a8,4x,i4,4i8)') '# ', area2, ncc, iorg,korg, ispa,ispb write(3,'(a)') '# prog.GTRIM applied to 2 files above' write(3,'(a8,4x,i4,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 do j=1,my; do i=1,mx if (g(i,j) == vnul2) f(i,j) = vnul enddo; enddo do j=1,my write(3,'((f7.1,9(1x,f7.1)))') (f(i,j),i=1,mx) enddo if (alt == 0.) then read(1,'(a)') buf do while (buf(1:1) == '#') read(1,'(a)') buf enddo if (buf(13:16) == ' ') then !-- v2005 read(buf,'(a8,i4,4x,4i8)') area1, ncc1, iorg1,korg1, ispa1,ispb1 if ((ncc1<0) .or. (ncc1>=400)) call abendm('invalid coord.no.') nc1 = ncc1 if (ncc1 < 200) then nc1 = ncc1; ncc1 = nc1 + 800 else ncc1 = ncc1 - 200; nc1 = ncc1 endif else !-- v2018 read(buf,'(a8,4x,i4,4i8)') area1, ncc1, iorg1,korg1, ispa1,ispb1 nc1 = ncc1 if ((ncc1 >= 800) .and. (ncc1 < 1000)) nc1 = ncc1 - 800 endif if ((nc1 >= 1) .and. (nc1 <= 62)) then iorg1 = 0; ispa1 = 0; ispb1 = 0 korg1 = (nc1-30)*360 - 180 if (nc1 > 60) korg1 = 0 if (nc1 == 61) iorg1 = +5400 if (nc1 == 62) iorg1 = -5400 endif if ((area1 /= area) .or. (ncc1 /= ncc) .or. (iorg1 /= iorg) .or. & (korg1 /= korg) .or. (ispa1 /= ispa) .or. (ispb1 /= ispb)) & call abendm('Header1 inconsistent') read(1,*) ixs1, iys1, mszx1, mszy1, mx1, my1, vnul1 if ((ixs1 /= ixs) .or. (iys1 /= iys) .or. (mszx1 /= mszx) .or. & (mszy1 /= mszy) .or. (mx1 /= mx) .or. (my1 /= my)) & call abendm('Header2 inconsistent') write(anul,'(f10.3)') vnul1 if ((anul(9:10) /= '00') .or. (anul(1:1) /= ' ')) & call abendm('unable to handle vnul1 value') read(1,*) ((f(i,j),i=1,mx),j=1,my) do j=1,my; do i=1,mx if (g(i,j) == vnul2) f(i,j) = vnul enddo; enddo write(3,'(a8,4x,i4,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 j=1,my write(3,'((f7.1,9(1x,f7.1)))') (f(i,j),i=1,mx) enddo endif close(1) close(3) if (flog(ldr:ldr) /= ' ') 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,'(a12,a8,6x,a6,i4,4x,4i8)') & 'Areaname : ', narea, 'Coord.', ncc, iorg,korg, ispa,ispb write(99,'(4x,a)') & ' (mesh) xs ys msz-x msz-y mx my alt ' write(99,'(4x,a12,2f10.2,2i8,2i6,a8)') & 'grid out=in ', xs, ys, mszx, mszy, mx, my, salt call strdtm(sdtm) write(99,'(a,a,a)') '=============== ', sdtm, '===============' close(99) endif stop end