Changeset 3000 for branches/dev_2802_OBStools/NEMOGCM/TOOLS/OBSTOOLS/src/fbcomb.F90

Timestamp:

2011-10-26T15:44:20+02:00 (13 years ago)

Author:

djlea

Message:

Updated obstools. Addition of headers to programs which explain what each utility does and how to run it. All the programs now build using the naketools utility.

File:

• branches/dev_2802_OBStools/NEMOGCM/TOOLS/OBSTOOLS/src/fbcomb.F90 (modified) (11 diffs)

branches/dev_2802_OBStools/NEMOGCM/TOOLS/OBSTOOLS/src/fbcomb.F90

@@ -1 +1 @@
 PROGRAM fbcomb
+   !!---------------------------------------------------------------------
+   !!
+   !!                     ** PROGRAM fbcomb **
+   !!
+   !!  ** Purpose : Combine MPI decomposed feedback files into one file
+   !!
+   !!  ** Method  : Use of utilities from obs_fbm.
+   !!
+   !!  ** Action  : 
+   !!
+   !!   Usage:
+   !!     fbcomb.exe outputfile inputfile1 inputfile2 ...
+   !!
+   !!   History :
+   !!        ! 2010 (K. Mogensen) Initial version
+   !!----------------------------------------------------------------------
    USE toolspar_kind
    USE obs_fbm
@@ -23 +39 @@
    REAL(KIND=dp),ALLOCATABLE :: zsort(:,:)
    INTEGER,ALLOCATABLE  :: iset(:),inum(:),iindex(:)
+   INTEGER :: iwmo
    !
    ! Output data
@@ -30 +47 @@
    ! Loop variables
    !
-   INTEGER :: ia,iv,ii,ij, ist
+   INTEGER :: ia,iv,ii,ij
    !
    ! Get number of command line arguments
@@ -48 +65 @@
    ntotobs = 0
    ninfiles = nargs - 1
-   ist=-1
    DO ia=1, ninfiles
       CALL getarg( ia+1, cdinfile(ia) )
@@ -55 +71 @@
       WRITE(*,'(2A)')'File = ', TRIM(cdinfile(ia))
       WRITE(*,'(A,I9,A)')'has', obsdata(ia)%nobs, ' observations'
-      IF (obsdata(ia)%nobs > 0 .AND. ist < 0) ist=ia             ! find first file with obs in
       ntotobs = ntotobs + obsdata(ia)%nobs
    ENDDO
@@ -62 +77 @@
    ! Check that the data is confirming
    !
-   DO ia=ist+1, ninfiles
-      IF ( obsdata(ia)%cdjuldref /= obsdata(ist)%cdjuldref ) THEN
+   DO ia=2, ninfiles
+      IF ( obsdata(ia)%cdjuldref /= obsdata(1)%cdjuldref ) THEN
          WRITE(*,*)'Different julian date reference. Aborting'
          CALL abort
       ENDIF
-      IF ( obsdata(ia)%nvar /= obsdata(ist)%nvar ) THEN
+      IF ( obsdata(ia)%nvar /= obsdata(1)%nvar ) THEN
          WRITE(*,*)'Different number of variables. Aborting'
          CALL abort
       ENDIF
-      IF  (obsdata(ia)%nadd /= obsdata(ist)%nadd ) THEN
+      IF  (obsdata(ia)%nadd /= obsdata(1)%nadd ) THEN
          WRITE(*,*)'Different number of additional entries. Aborting'
          CALL abort
       ENDIF
-      IF ( obsdata(ia)%next /= obsdata(ist)%next ) THEN
+      IF ( obsdata(ia)%next /= obsdata(1)%next ) THEN
          WRITE(*,*)'Different number of additional variables. Aborting'
          CALL abort
       ENDIF
-      IF ( obsdata(ia)%lgrid .NEQV. obsdata(ist)%lgrid ) THEN
+      IF ( obsdata(ia)%lgrid .NEQV. obsdata(1)%lgrid ) THEN
          WRITE(*,*)'Inconsistent grid search info. Aborting'
          CALL abort
       ENDIF
       DO iv=1, obsdata(ia)%nvar
-         IF ( obsdata(ia)%cname(iv) /= obsdata(ist)%cname(iv) ) THEN
+         IF ( obsdata(ia)%cname(iv) /= obsdata(1)%cname(iv) ) THEN
             WRITE(*,*)'Variable name ', TRIM(obsdata(ia)%cname(iv)), &
-               &      ' is different from ', TRIM(obsdata(ist)%cname(iv)), &
+               &      ' is different from ', TRIM(obsdata(1)%cname(iv)), &
                &      '. Aborting'
             CALL abort
          ENDIF
-         IF ( obsdata(ist)%lgrid .AND. obsdata(ia)%nobs > 0) THEN
-            IF ( obsdata(ia)%cgrid(iv) /= obsdata(ist)%cgrid(iv) ) THEN
-               WRITE(*,*)'Grid name ', TRIM(obsdata(ia)%cgrid(iv)), &
-                  &      ' is different from ', TRIM(obsdata(ist)%cgrid(iv)), &
-                  &      '. Aborting'
-               CALL abort
+         IF ( obsdata(1)%lgrid ) THEN
+            IF ( obsdata(ia)%cgrid(iv) /= obsdata(1)%cgrid(iv) ) THEN
+               IF (obsdata(1)%nobs==0) THEN
+                  obsdata(1)%cgrid(iv) = obsdata(ia)%cgrid(iv)
+               ELSE
+                  IF (obsdata(ia)%nobs>0) THEN
+                     WRITE(*,*)'Grid name ', TRIM(obsdata(ia)%cgrid(iv)), &
+                        &      ' is different from ', &
+                        &      TRIM(obsdata(1)%cgrid(iv)), '. Aborting'
+                     CALL abort
+                  ENDIF
+               ENDIF
             ENDIF
          ENDIF
       ENDDO
       DO iv=1,obsdata(ia)%nadd
-         IF ( obsdata(ia)%caddname(iv) /= obsdata(ist)%caddname(iv) ) THEN
+         IF ( obsdata(ia)%caddname(iv) /= obsdata(1)%caddname(iv) ) THEN
             WRITE(*,*)'Additional name ', TRIM(obsdata(ia)%caddname(iv)), &
-               &      ' is different from ', TRIM(obsdata(ist)%caddname(iv)), &
+               &      ' is different from ', TRIM(obsdata(1)%caddname(iv)), &
                &      '. Aborting'
             CALL abort
@@ -108 +129 @@
       ENDDO
       DO iv=1,obsdata(ia)%next
-         IF ( obsdata(ia)%cextname(iv) /= obsdata(ist)%cextname(iv) ) THEN
+         IF ( obsdata(ia)%cextname(iv) /= obsdata(1)%cextname(iv) ) THEN
             WRITE(*,*)'Extra name ', TRIM(obsdata(ia)%cextname(iv)), &
-               &      ' is different from ', TRIM(obsdata(ist)%cextname(iv)), &
+               &      ' is different from ', TRIM(obsdata(1)%cextname(iv)), &
                &      '. Aborting'
             CALL abort
@@ -119 +140 @@
    ! Construct sorting arrays
    !
-   ALLOCATE( zsort(3,ntotobs), iset(ntotobs), &
+   ALLOCATE( zsort(5,ntotobs), iset(ntotobs), &
       & inum(ntotobs), iindex(ntotobs))
    ii = 0
@@ -128 +149 @@
          zsort(2,ii) = obsdata(ia)%pphi(ij)
          zsort(3,ii) = obsdata(ia)%plam(ij)
+         iwmo = TRANSFER( obsdata(ia)%cdwmo(ij)(1:4), iwmo )
+         zsort(4,ii) = iwmo
+         iwmo = TRANSFER( obsdata(ia)%cdwmo(ij)(5:8), iwmo )
+         zsort(5,ii) = iwmo
          iset(ii) = ia
          inum(ii) = ij
@@ -135 +160 @@
    ! Get indexes for time sorting.
    !
-   CALL index_sort_dp_n(zsort,3,iindex,ntotobs)
+   CALL index_sort_dp_n(zsort,5,iindex,ntotobs)
    !
    ! Allocate output data
@@ -144 +169 @@
    ENDDO
    CALL init_obfbdata( obsoutdata )
-   CALL alloc_obfbdata( obsoutdata, obsdata(ist)%nvar, ntotobs, nlev, &
-      &                 obsdata(ist)%nadd, obsdata(ist)%next, obsdata(ist)%lgrid )
+   CALL alloc_obfbdata( obsoutdata, obsdata(1)%nvar, ntotobs, nlev, &
+      &                 obsdata(1)%nadd, obsdata(1)%next, obsdata(1)%lgrid )
    !
    ! Copy input data into output data