!$$$ MAIN PROGRAM DOCUMENTATION BLOCK ! ! MAIN PROGRAM: TMSRTPRF ! PRGMMR: David W. Behringer ORG: NP23 DATE: 2003-07-24 ! ! ABSTRACT: Sort by date and time the profiles in a file of ! subsurface temperature data ! ! PROGRAM HISTORY LOG: ! 2003-07-24 David W. Behringer ! 2004-01-30 David W. Behringer - cosmetic change in declaring and setting ! the array ndxd ! ! USAGE: ! INPUT FILES: ! UNIT 11 - TEMPERATURE PROFILE DATA IN IEEE ! ! OUTPUT FILES: ! UNIT 51 - SORTED TEMPERATURE PROFILE DATA IN IEEE ! UNIT 06 - UNIT 6 (STANDARD PRINTFILE) ! ! WORK FILES: (INCLUDING SCRATCH FILES) ! UNIT 80 - SCRATCH FILE FOR PROFILE DATA ! ! SUBPROGRAMS CALLED FROM PROGRAM: (LIST ALL CALLED FROM ANYWHERE IN CODES) ! UNIQUE: - qSort, swap ! LIBRARY: ! W3LIB - w3tagb, w3tage, errexit ! ! SUBPROGRAMS CALLED FROM MAIN: (LIST ALL CALLED FROM MAIN) ! UNIQUE: - qSort, swap ! LIBRARY: ! W3LIB - w3tagb, w3tage, errexit ! ! EXIT STATES: ! COND = 0 - SUCCESSFUL RUN ! COND = 11 - ERROR OPENING UNIT 11 ! COND = 12 - ERROR READING UNIT 11 ! COND = 51 - ERROR OPENING UNIT 51 ! COND = 52 - ERROR WRITING UNIT 51 ! ! REMARKS AND IMPORTANT LOCAL VARIABLES: ! None ! ! ATTRIBUTES: (LIST MACHINES FOR WHICH CODE IS USED AND CHECKED OUT) ! ! MACHINE: IBM SP ! LANGUAGE: F90 ! ! !$$$ ! program tmSrtPrf ! ! tmSrtPrf sorts profiles by time ! character csign*8,sid*2,dtyp*2,qkey*1 character str*80 real, allocatable, dimension(:) :: pt, pz integer(kind=8), allocatable, dimension(:) :: ndxd integer(kind=8), parameter :: iyfct = 100000000 integer, allocatable, dimension(:) :: nprfl ! call w3tagb('GODAS_TMSRTPRF',2003,0164,0164,'NP23') ! ! open profile file ! open (11, form='unformatted', status='old', & & access='sequential', err=110) ! nprf = 0 npmx = 0 do while (.true.) read (11, end=100, err=120) iyear,idate,csign,sid, & & dtyp,qkey,yp,xp,np nprf = nprf + 1 if (np .gt. npmx) npmx = np end do 100 continue ! rewind 11 ! allocate(pt(npmx)) allocate(pz(npmx)) allocate(ndxd(nprf)) allocate(nprfl(nprf)) ! ! open direct access scratch file ! nb = 4*(2*npmx + 5) + 13 open (80, status='scratch', form='unformatted', & & access='direct',recl=nb) ! ! begin loop on profile file ! do n=1,nprf read (11, err=120) iyear,idate,csign,sid, & & dtyp,qkey,yp,xp,np,(pz(k),pt(k),k=1,np) ndxd(n) = iyear*iyfct + idate nprfl(n) = n write (80,rec=n) iyear,idate,csign,sid,dtyp,qkey,yp,xp, & & np,pz,pt end do ! close (11) ! ! sort on ndxd ! imn = 1 imx = nprf call qSort(ndxd,nprfl,imn,imx) ! ! write a new profile file in time sequence ! open (51, form='unformatted', access='sequential', err=510) ! ! begin loop on list file ! do n=1,nprf read (80,rec=nprfl(n)) iyear,idate,csign,sid,dtyp,qkey, & & yp,xp,np,pz,pt write (51, err=520) iyear,idate,csign,sid,dtyp,qkey,yp,xp, & & np,(pz(k),pt(k),k=1,np) end do ! close (51) close (80) ! call w3tage('GODAS_TMSRTPRF') call errexit(0) ! 110 write(6,'(a)') 'Error opening profile file on unit 11' call w3tage('GODAS_TMSRTPRF') call errexit(11) ! 120 write(6,'(a)') 'Error reading profile file on unit 11' call w3tage('GODAS_TMSRTPRF') call errexit(12) ! 510 write(6,'(a)') 'Error opening profile file on unit 51' call w3tage('GODAS_TMSRTPRF') call errexit(51) ! 520 write(6,'(a)') 'Error writing profile file on unit 51' call w3tage('GODAS_TMSRTPRF') call errexit(52) ! contains ! ! -------------------------------------------------------------- ! recursive subroutine qSort(a, b, lo0, hi0) ! integer*8 a(*), mid integer b(*), lo0, hi0, lo, hi ! lo = lo0 hi = hi0 ! if (hi0 .gt. lo0) then ! mid = a( ( lo0 + hi0 ) / 2 ) ! do while( lo .le. hi ) ! do while( (lo .lt. hi0) .and. (a(lo) .lt. mid) ) lo = lo + 1 end do ! do while( (hi .gt. lo0) .and. (a(hi) .gt. mid) ) hi = hi - 1 end do ! if ( lo .le. hi ) then call swap(a, b, lo, hi) lo = lo + 1 hi = hi - 1 end if ! end do ! if (lo0 .lt. hi) then call qSort(a, b, lo0, hi) end if ! if (lo .lt. hi0) then call qSort(a, b, lo, hi0) end if ! end if ! end subroutine qSort ! ! ------------------------------------------------------------------- ! subroutine swap(a, b, i, j) ! integer*8 a(*), Ta integer b(*), i, j, Tb ! Ta = a(i) a(i) = a(j) a(j) = Ta ! Tb = b(i) b(i) = b(j) b(j) = Tb ! end subroutine swap ! end program tmSrtPrf