source: branches/dev_2802_OBStools/NEMOGCM/TOOLS/OBSTOOLS/bufr2fb.F90 @ 2893

PROGRAM bufr2fb
#ifdef HAS_BUFR
   USE toolspar_kind
   USE obs_fbm
   USE bufrdata
   USE convmerge
   IMPLICIT NONE
   !
   ! Command line arguments for output file and input files
   !
#ifndef NOIARGCPROTO
   INTEGER,EXTERNAL :: iargc
#endif
   INTEGER :: nargs
   CHARACTER(len=256) :: cdtsfilem, cdtsfile1, cduvfilem, cduvfile1
   CHARACTER(len=256),ALLOCATABLE :: cdinfile(:)
   !
   ! Input data
   !
   TYPE(obfbdata), POINTER :: bufrtsm(:), bufrts1(:), bufruvm(:), bufruv1(:)
   INTEGER :: ninfiles
   INTEGER :: ntottsm, nmaxlevts, ntotts1
   INTEGER :: ntotuvm, nmaxlevuv, ntotuv1
   !
   ! Loop variables
   !
   INTEGER :: ia
   !
   ! Get number of command line arguments
   !
   nargs=IARGC()
   IF (nargs < 4) THEN
      WRITE(*,'(A)')'Usage:'
      WRITE(*,'(A)')'bufr2fb TS_outputfile_prof TS_outputfile_surf '//&
         &          'UV_outputfile_prof UV_outputfile_surf '//&
         &          'inputfile1 inputfile2 ...'
      CALL abort()
   ENDIF
   CALL getarg(1,cdtsfilem)
   CALL getarg(2,cdtsfile1)
   CALL getarg(3,cduvfilem)
   CALL getarg(4,cduvfile1)
   !
   ! Get input data
   !
   ALLOCATE( bufrtsm(MAX(nargs-4,1)) )
   ALLOCATE( bufrts1(MAX(nargs-4,1)) )
   ALLOCATE( bufruvm(MAX(nargs-4,1)) )
   ALLOCATE( bufruv1(MAX(nargs-4,1)) )
   ALLOCATE( cdinfile(MAX(nargs-4,1)) )
   ntottsm = 0
   ntotts1 = 0
   ntotuvm = 0
   ntotuv1 = 0
   ninfiles  = nargs - 4
   DO ia=1,ninfiles
      CALL getarg( ia + 4, cdinfile(ia) )
      CALL read_bufrfile( TRIM(cdinfile(ia)), &
         &                bufrtsm(ia), bufrts1(ia), &
         &                bufruvm(ia), bufruv1(ia) )
      WRITE(*,'(2A)')'File = ',TRIM(cdinfile(ia))
      WRITE(*,'(A,I9,A)')'has',bufrtsm(ia)%nobs,' TS profiles'
      WRITE(*,'(A,I9,A)')'and',bufruvm(ia)%nobs,' UV profiles'
      WRITE(*,'(A,I9,A)')'and',bufrts1(ia)%nobs,' TS single level'
      WRITE(*,'(A,I9,A)')'and',bufruv1(ia)%nobs,' UV single level'
      ntottsm = ntottsm + bufrtsm(ia)%nobs
      ntotuvm = ntotuvm + bufruvm(ia)%nobs
      ntotts1 = ntotts1 + bufrts1(ia)%nobs
      ntotuv1 = ntotuv1 + bufruv1(ia)%nobs
   ENDDO
   IF (ninfiles==0) THEN
      CALL init_obfbdata( bufrtsm(1) )
      CALL alloc_obfbdata( bufrtsm(1), 2, 0, 1, 0, 1, .FALSE. )
      bufrtsm(1)%cname(1) = 'POTM'
      bufrtsm(1)%cname(2) = 'PSAL'
      bufrtsm(1)%coblong(1) = 'Potential temperature'
      bufrtsm(1)%coblong(2) = 'Practical salinity'
      bufrtsm(1)%cobunit(1) = 'Degrees Celsius'
      bufrtsm(1)%cobunit(2) = 'PSU'
      bufrtsm(1)%cextname(1) = 'TEMP'
      bufrtsm(1)%cextlong(1) = 'Insitu temperature'
      bufrtsm(1)%cextunit(1) = 'Degrees Celsius'
      bufrtsm(1)%cdjuldref = '19500101000000'
      CALL init_obfbdata( bufrts1(1) )
      CALL alloc_obfbdata( bufrts1(1), 2, 0, 1, 0, 1, .FALSE. )
      bufrts1(1)%cname(1) = 'POTM'
      bufrts1(1)%cname(2) = 'PSAL'
      bufrts1(1)%coblong(1) = 'Potential temperature'
      bufrts1(1)%coblong(2) = 'Practical salinity'
      bufrts1(1)%cobunit(1) = 'Degrees Celsius'
      bufrts1(1)%cobunit(2) = 'PSU'
      bufrts1(1)%cextname(1) = 'TEMP'
      bufrts1(1)%cextlong(1) = 'Insitu temperature'
      bufrts1(1)%cextunit(1) = 'Degrees Celsius'
      bufrts1(1)%cdjuldref = '19500101000000'
      CALL init_obfbdata( bufruvm(1) )
      CALL alloc_obfbdata( bufruvm(1), 2, 0, 1, 0, 0, .FALSE. )
      bufruvm(1)%cname(1) = 'UVEL'
      bufruvm(1)%cname(2) = 'VVEL'
      bufruvm(1)%coblong(1) = 'Zonal current'
      bufruvm(1)%coblong(2) = 'Meridional current'
      bufruvm(1)%cobunit(1) = 'Meters per second'
      bufruvm(1)%cobunit(2) = 'Meters per second'
      bufruvm(1)%cdjuldref = '19500101000000'
      CALL init_obfbdata( bufruv1(1) )
      CALL alloc_obfbdata( bufruv1(1), 2, 0, 1, 0, 0, .FALSE. )
      bufruv1(1)%cname(1) = 'UVEL'
      bufruv1(1)%cname(2) = 'VVEL'
      bufruv1(1)%coblong(1) = 'Zonal current'
      bufruv1(1)%coblong(2) = 'Meridional current'
      bufruv1(1)%cobunit(1) = 'Meters per second'
      bufruv1(1)%cobunit(2) = 'Meters per second'
      bufruv1(1)%cdjuldref = '19500101000000'
   ENDIF
   WRITE(*,'(A,I8)') 'Total TS profiles : ',ntottsm
   WRITE(*,'(A,I8)') 'Total TS single   : ',ntotts1
   WRITE(*,'(A,I8)') 'Total UV profiles : ',ntotuvm
   WRITE(*,'(A,I8)') 'Total UV single   : ',ntotuv1
   !
   ! Merge and output the data.
   !
   IF (TRIM(cdtsfilem)/='none') THEN
      ! Convert insitu temperature to potential temperature using the model
      ! salinity if no potential temperature
      DO ia = 1, ninfiles
         call fbpotem( bufrtsm(ia) )
      ENDDO
      CALL conv_fbmerge( TRIM(cdtsfilem), ninfiles, bufrtsm )
   ENDIF
   IF (TRIM(cdtsfile1)/='none') THEN
      DO ia = 1, ninfiles
         call fbpotem( bufrts1(ia) )
      ENDDO
      CALL conv_fbmerge( TRIM(cdtsfile1), ninfiles, bufrts1 )
   ENDIF
   IF (TRIM(cduvfilem)/='none') THEN
      CALL conv_fbmerge( TRIM(cduvfilem), ninfiles, bufruvm )
   ENDIF
   IF (TRIM(cduvfile1)/='none') THEN
      CALL conv_fbmerge( TRIM(cduvfile1), ninfiles, bufruv1 )
   ENDIF

CONTAINS

#include "obs_conv.h90"
   
   SUBROUTINE fbpotem( fbdata )
      
      ! Convert insitu temperature to potential temperature 

      TYPE(obfbdata) :: fbdata
      REAL :: zpres
      INTEGER :: jo,jk

      DO jo = 1, fbdata%nobs
         IF ( fbdata%pphi(jo) < 9999.0 ) THEN
            DO jk = 1, fbdata%nlev
               IF ( ( fbdata%pob(jk,jo,1) >= 9999.0 ) .AND. &
                  & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. &
                  & ( fbdata%pob(jk,jo,2) < 9999.0 ) .AND. &
                  & ( fbdata%pext(jk,jo,1) < 9999.0 ) ) THEN
                  zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), &
                     &              REAL(fbdata%pphi(jo),wp) )
                  fbdata%pob(jk,jo,1) = potemp( &
                     &                     REAL(fbdata%pob(jk,jo,2), wp),  &
                     &                     REAL(fbdata%pext(jk,jo,1), wp), &
                     &                     REAL(zpres,wp), 0.0_wp )
               ENDIF
            ENDDO
         ENDIF
      ENDDO

   END SUBROUTINE fbpotem

#else
   
   WRITE(*,'(A)')'bufr2fb compiled without -DHAS_BUFR so '//&
      &          'running it is pointless'
   CALL abort

#endif   

END PROGRAM bufr2fb