Iasi debug fix

src/enkf/enkf_obs_sensitivity.f90

@@ -547,7 +547,7 @@ subroutine print_ob_sens
            if(nob_sat(nchan) > 0) then
               rate_sat(nchan,1:3) = rate_sat(nchan,1:3) &
                    & / real(nob_sat(nchan),r_kind) * 100._r_kind
-              write(*,'(a20,i5,i7,3(1x,e12.5),3(1x,f7.2))') &
+              write(*,'(a22,i6,i7,3(1x,e12.5),3(1x,f7.2))') &
                    & trim(adjustl(nusis(nchan))), &
                    & nuchan(nchan),nob_sat(nchan),sumsense_sat(nchan,1:3), &
                    & rate_sat(nchan,1:3)

src/enkf/innovstats.f90

@@ -278,7 +278,7 @@ subroutine print_innovstats(obfit,obsprd)
                   sqrt(sumerr_sat(nchan))
      end if
   end do
-9805 format(a20,i4,1x,i5,5(1x,e10.3))
+9805 format(a20,i6,1x,i5,5(1x,e10.3))
 end if !nobs_sat>0
 end subroutine print_innovstats
 

src/gsi/combine_radobs.f90

@@ -1,5 +1,5 @@
 subroutine combine_radobs(mype_sub,mype_root,&
-     npe_sub,mpi_comm_sub,nele,itxmax,nread,ndata,&
+     npe_sub,mpi_comm_sub,nele,itxmax,nread,number_profiles,ndata,&
      data_all,data_crit,nrec)
 !$$$  subprogram documentation block
 !                .      .    .                                       .
@@ -24,6 +24,7 @@ subroutine combine_radobs(mype_sub,mype_root,&
 !     itxmax   - maximum number of observations
 !     data_all - observation data array
 !     data_crit- array containing observation "best scores"
+!     number_profiles - task specific number of radiance profiless passing quality control
 !     nread    - task specific number of obesrvations read from data file
 !     ndata    - task specific number of observations keep for assimilation
 !
@@ -50,6 +51,7 @@ subroutine combine_radobs(mype_sub,mype_root,&
   integer(i_kind)                    ,intent(in   ) :: npe_sub,itxmax
   integer(i_kind)                    ,intent(in   ) :: nele
   integer(i_kind)                    ,intent(in   ) :: mpi_comm_sub
+  integer(i_kind)                    ,intent(in   ) :: number_profiles
   integer(i_kind)                    ,intent(inout) :: nread,ndata
   integer(i_kind),dimension(itxmax)  ,intent(in   ) :: nrec
   real(r_kind),dimension(itxmax)     ,intent(inout) :: data_crit
@@ -74,7 +76,7 @@ subroutine combine_radobs(mype_sub,mype_root,&
 
      nread=0
      if (mype_sub==mype_root) nread = ncounts1
-     if (ncounts1 == 0)return
+     if (ncounts1 <= 0)return
 
 !    Allocate arrays to hold data
 
@@ -83,7 +85,7 @@ subroutine combine_radobs(mype_sub,mype_root,&
 !    is only needed on task mype_root
      call mpi_allreduce(data_crit,data_crit_min,itxmax,mpi_rtype,mpi_min,mpi_comm_sub,ierror)
 
-     allocate(nloc(min(ncounts1,itxmax)),icrit(min(ncounts1,itxmax)))
+     allocate(nloc(itxmax),icrit(itxmax))
      icrit=1e9
      ndata=0
      ndata1=0

src/gsi/radinfo.f90

@@ -805,7 +805,7 @@ subroutine radinfo_read
     end do
     close(lunin)
 100 format(a1,a120)
-110 format(i4,1x,a20,' chan= ',i5,  &
+110 format(i6,1x,a20,' chan= ',i5,  &
           ' var= ',f7.3,' varch_cld=',f7.3,' use= ',i2,' ermax= ',F7.3, &
           ' b_rad= ',F7.2,' pg_rad=',F7.2,' icld_det=',I2,' icloud=',I2,' iaeros=',I2)
 111 format(i4,1x,a20,' chan= ',i5,  &
@@ -1135,7 +1135,7 @@ subroutine radinfo_read
                 nusis(j),nuchan(j),' not found in satbias_in file - set to zero '
              endif
           end do
-140       format(i4,1x,a20,12f12.6)
+140       format(i5,1x,a20,12f12.6)
 
        endif
 
@@ -1687,7 +1687,6 @@ subroutine init_predx
    integer(i_kind),parameter:: lntemp = 51
 
    integer(i_kind),parameter:: nthreshold = 100
-   integer(i_kind),parameter:: maxchn = 3000
    integer(i_kind),parameter:: maxdat = 100
    real(r_kind),   parameter:: atiny  = 1.0e-10_r_kind
 
@@ -1712,7 +1711,7 @@ subroutine init_predx
    integer(i_kind):: np,new_chan,nc
    integer(i_kind):: counttmp, jjstart, sensor_start, sensor_end
    integer(i_kind):: radedge_min, radedge_max
-   integer(i_kind),dimension(maxchn):: ich
+   integer(i_kind),allocatable,dimension(:):: ich
    integer(i_kind),dimension(maxdat):: ipoint
 
    real(r_kind):: bias,scan,errinv,rnad
@@ -1814,6 +1813,7 @@ subroutine init_predx
            mype, trim(fdiag_rad), header_fix%idate
       satsens = header_fix%isis
       n_chan = header_fix%nchan
+      allocate(ich(n_chan))
 
 !     Check for consistency between specified and retrieved satellite id
 !     after first sorting out some historical naming conventions
@@ -2063,7 +2063,7 @@ subroutine init_predx
                if ( nuchan(jj) == header_chan(j)%nuchan ) then
                   jjstart = jj + 1
                   write(lntemp,220) jj,tlapmean(jj),tsum_tlapmean(jj),count_tlapmean(jj)
-220               format(I5,1x,2e15.6,1x,I5)
+220               format(I5,1x,2e15.6,1x,I6)
                   cycle loop_c
                endif
             end do

src/gsi/read_abi.f90

@@ -92,7 +92,7 @@ subroutine read_abi(mype,val_abi,ithin,rmesh,jsatid,&
   integer(i_kind) nmind,lnbufr,idate,ilat,ilon,nhdr,nchn,ncld,nbrst,jj
   integer(i_kind) ireadmg,ireadsb,iret,nreal,nele,itt
   integer(i_kind) itx,i,k,isflg,kidsat,n,iscan,idomsfc
-  integer(i_kind) idate5(5),maxinfo
+  integer(i_kind) idate5(5),maxinfo, number_profiles
   integer(i_kind),allocatable,dimension(:)::nrec
 
   real(r_kind) dg2ew,sstime,tdiff,t4dv,sfcr
@@ -501,11 +501,14 @@ subroutine read_abi(mype,val_abi,ithin,rmesh,jsatid,&
      enddo read_loop
   enddo read_msg
 
+!  number of profiles kept after thinning and QC
+  number_profiles = count(nrec(:) /= 999999,dim=1)
+
   call closbf(lnbufr)
   close(lnbufr)
 
   call combine_radobs(mype_sub,mype_root,npe_sub,mpi_comm_sub,&
-     nele,itxmax,nread,ndata,data_all,score_crit,nrec)
+     nele,itxmax,nread,number_profiles,ndata,data_all,score_crit,nrec)
 
 ! Allow single task to check for bad obs, update superobs sum,
 ! and write out data to scratch file for further processing.

src/gsi/read_aerosol.f90

@@ -152,7 +152,7 @@ subroutine read_aerosol(nread,ndata,nodata,jsatid,infile,gstime,lunout, &
       'SAID CLATH CLONH YEAR MNTH DAYS HOUR MINU SOZA SOLAZI RSST AOTQ RETRQ'
 
   integer(i_kind), parameter :: mxib  = 20,imax=6
-  integer(i_kind) :: nib
+  integer(i_kind) :: nib, number_profiles
   integer(i_kind) :: ibit(mxib)
 
   integer(i_kind) :: itx, itt, irec
@@ -351,8 +351,11 @@ subroutine read_aerosol(nread,ndata,nodata,jsatid,infile,gstime,lunout, &
 
            end do read_modis
 
+!  number of profiles kept after thinning and QC
+           number_profiles = count(nrec(:) /= 999999,dim=1)
+
            call combine_radobs(mype_sub,mype_root,npe_sub,mpi_comm_sub,&
-              naerodat,itxmax,nread,ndata,aeroout,score_crit,nrec)
+              naerodat,itxmax,nread,number_profiles,ndata,aeroout,score_crit,nrec)
 
            if ( mype_sub == mype_root ) then
               do n = 1, ndata
@@ -579,8 +582,10 @@ subroutine read_aerosol(nread,ndata,nodata,jsatid,infile,gstime,lunout, &
               nrec(itx)=irec
            end do read_viirs
 
+           number_profiles = count(nrec(:) /= 999999,dim=1)
+
            call combine_radobs(mype_sub,mype_root,npe_sub,mpi_comm_sub,&
-              naerodat,itxmax,nread,ndata,aeroout,score_crit,nrec)
+              naerodat,itxmax,nread,number_profiles,ndata,aeroout,score_crit,nrec)
 
            if ( mype_sub == mype_root ) then
               do n = 1, ndata

src/gsi/read_ahi.f90

@@ -98,7 +98,7 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,&
   integer(i_kind) nmind,lnbufr,idate,ilat,ilon
   integer(i_kind) ireadmg,ireadsb,iret,nreal,nele,itt
   integer(i_kind) itx,i,k,isflg,kidsat,n,iscan,idomsfc
-  integer(i_kind) idate5(5)
+  integer(i_kind) idate5(5),number_profiles
   integer(i_kind),allocatable,dimension(:)::nrec
 
   real(r_kind) dg2ew,sstime,tdiff,t4dv,sfcr
@@ -511,11 +511,15 @@ subroutine read_ahi(mype,val_img,ithin,rmesh,jsatid,gstime,&
 
      enddo read_loop
   enddo read_msg
+
+!  number of profiles kept after thinning and QC
+  number_profiles = count(nrec(:) /= 999999,dim=1)
+
   call closbf(lnbufr)
   close(lnbufr)
 
   call combine_radobs(mype_sub,mype_root,npe_sub,mpi_comm_sub,&
-     nele,itxmax,nread,ndata,data_all,score_crit,nrec)
+     nele,itxmax,nread,number_profiles,ndata,data_all,score_crit,nrec)
 
 ! If no observations read, jump to end of routine.
   if (mype_sub==mype_root.and.ndata>0) then

src/gsi/read_airs.f90

@@ -160,7 +160,7 @@ subroutine read_airs(mype,val_airs,ithin,isfcalc,rmesh,jsatid,gstime,&
   character(len=512)  :: table_file
   integer(i_kind)     :: lnbufr = 10
   integer(i_kind)     :: lnbufrtab = 11
-  integer(i_kind)     :: irec,next
+  integer(i_kind)     :: irec,next, number_profiles
 
 ! Variables for BUFR IO    
   real(r_double) :: crchn_reps
@@ -860,6 +860,10 @@ subroutine read_airs(mype,val_airs,ithin,isfcalc,rmesh,jsatid,gstime,&
      enddo read_loop
 
   enddo read_subset
+
+!  number of profiles kept after thinning and QC
+  number_profiles = count(nrec(:) /= 999999,dim=1)
+
   deallocate(allchan, chan_map, bufr_chan_test)
   call closbf(lnbufr)  ! Close bufr file
   close(lnbufr)
@@ -868,7 +872,7 @@ subroutine read_airs(mype,val_airs,ithin,isfcalc,rmesh,jsatid,gstime,&
 ! information it retained and then let single task merge files together
 
   call combine_radobs(mype_sub,mype_root,npe_sub,mpi_comm_sub,&
-     nele,itxmax,nread,ndata,data_all,score_crit,nrec)
+     nele,itxmax,nread,number_profiles,data_all,score_crit,nrec)
 
 ! Allow single task to check for bad obs, update superobs sum,
 ! and write out data to scratch file for further processing.

src/gsi/read_amsr2.f90

@@ -128,7 +128,7 @@ subroutine read_amsr2(mype,val_amsr2,ithin,rmesh,jsatid,gstime,&
   real(r_kind)     :: dist1   
   real(r_kind),allocatable,dimension(:,:):: data_all
   integer(i_kind),allocatable,dimension(:)::nrec
-  integer(i_kind):: irec,next
+  integer(i_kind):: irec,next, number_profiles
   integer(i_kind):: method,iobs,num_obs   
   integer(i_kind),parameter  :: maxobs=2e7
 
@@ -659,11 +659,14 @@ subroutine read_amsr2(mype,val_amsr2,ithin,rmesh,jsatid,gstime,&
 
      enddo obsloop
 
+!  number of profiles kept after thinning and QC
+     number_profiles = count(nrec(:) /= 999999,dim=1)
+
 ! If multiple tasks read input bufr file, allow each tasks to write out
 ! information it retained and then let single task merge files together
 
   call combine_radobs(mype_sub,mype_root,npe_sub,mpi_comm_sub,&
-     nele,itxmax,nread,ndata,data_all,score_crit,nrec)
+     nele,itxmax,nread,number_profiles,ndata,data_all,score_crit,nrec)
 
 ! Allow single task to check for bad obs, update superobs sum,
 ! and write out data to scratch file for further processing.

src/gsi/read_amsre.f90

@@ -169,7 +169,7 @@ subroutine read_amsre(mype,val_amsre,ithin,isfcalc,rmesh,jsatid,gstime,&
   real(r_kind)     :: pred, crit1, dist1
   real(r_kind),allocatable,dimension(:,:):: data_all
   integer(i_kind),allocatable,dimension(:)::nrec
-  integer(i_kind):: irec,next
+  integer(i_kind):: irec,next,number_profiles
   real(r_kind),dimension(0:3):: sfcpct
   real(r_kind),dimension(0:4):: rlndsea
   real(r_kind),dimension(0:3):: ts
@@ -644,14 +644,18 @@ subroutine read_amsre(mype,val_amsre,ithin,isfcalc,rmesh,jsatid,gstime,&
 
      enddo read_loop
   enddo read_msg
+
+!  number of profiles kept after thinning and QC
+  number_profiles = count(nrec(:) /= 999999,dim=1)
+
   call closbf(lnbufr)
   close(lnbufr)
 
 ! If multiple tasks read input bufr file, allow each tasks to write out
 ! information it retained and then let single task merge files together
 
   call combine_radobs(mype_sub,mype_root,npe_sub,mpi_comm_sub,&
-     nele,itxmax,nread,ndata,data_all,score_crit,nrec)
+     nele,itxmax,nread,number_profiles,ndata,data_all,score_crit,nrec)
 
 
 ! Allow single task to check for bad obs, update superobs sum,

src/gsi/read_atms.f90

@@ -134,7 +134,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,&
   character(80) hdr1b,hdr2b
 
   integer(i_kind) ireadsb,ireadmg,nrec_startx
-  integer(i_kind) i,j,k,ntest,iob,llll
+  integer(i_kind) i,j,k,ntest,iob,llll, number_profiles
   integer(i_kind) iret,idate,nchanl,n,idomsfc(1)
   integer(i_kind) ich1,ich2,ich8,ich15,ich16,ich17
   integer(i_kind) kidsat,maxinfo
@@ -792,8 +792,11 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,&
   DEALLOCATE(solazi_save) 
   DEALLOCATE(bt_save)
 
+!  number of profiles kept after thinning and QC
+  number_profiles = count(nrec(:) /= 999999,dim=1)
+
   call combine_radobs(mype_sub,mype_root,npe_sub,mpi_comm_sub,&
-       nele,itxmax,nread,ndata,data_all,score_crit,nrec)
+       nele,itxmax,nread,number_profiles,ndata,data_all,score_crit,nrec)
 
 ! 
   if(mype_sub==mype_root)then

src/gsi/read_avhrr.f90

@@ -166,7 +166,7 @@ subroutine read_avhrr(mype,val_avhrr,ithin,rmesh,jsatid,&
 
   real(r_double), dimension(13) :: hdr
   real(r_double), dimension(3,5) :: bufrf
-  integer(i_kind) :: lnbufr,ireadsb,ireadmg,iskip,irec,next
+  integer(i_kind) :: lnbufr,ireadsb,ireadmg,iskip,irec,next,number_profiles
   integer(i_kind), allocatable, dimension(:) :: nrec
   real(r_kind), allocatable, dimension(:) :: amesh
   real(r_kind), allocatable, dimension(:) :: hsst_thd
@@ -562,10 +562,14 @@ subroutine read_avhrr(mype,val_avhrr,ithin,rmesh,jsatid,&
 
         enddo read_loop
      enddo read_msg
+
      call closbf(lnbufr)
 
+!  number of profiles kept after thinning and QC
+     number_profiles = count(nrec(:) /= 999999,dim=1)
+
      call combine_radobs(mype_sub,mype_root,npe_sub,mpi_comm_sub,&
-          nele,itxmax,nread,ndata_mesh,data_mesh,score_crit,nrec)
+          nele,itxmax,nread,number_profiles,ndata_mesh,data_mesh,score_crit,nrec)
 
      if ( nread > 0 ) then
         write(*,'(a,a10,I3,F6.1,3I10)') 'read_avhrr,satid,imesh,amesh,itxmax,nread,ndata_mesh : ',jsatid,imesh,amesh(imesh),itxmax,nread,ndata_mesh

src/gsi/read_avhrr_navy.f90

@@ -135,7 +135,7 @@ subroutine read_avhrr_navy(mype,val_avhrr,ithin,rmesh,jsatid,&
   integer(i_kind) itx,k,i,bufsat
   integer(i_kind) ireadsb,ireadmg
   integer(i_kind) nreal,nele,itt
-  integer(i_kind) nlat_sst,nlon_sst,irec,next
+  integer(i_kind) nlat_sst,nlon_sst,irec,next, number_profiles
   integer(i_kind),allocatable,dimension(:)::nrec
 
   real(r_kind) dlon,dlat,sfcr
@@ -255,6 +255,7 @@ subroutine read_avhrr_navy(mype,val_avhrr,ithin,rmesh,jsatid,&
   next=0
 
 ! Read BUFR Navy data
+  nrec = 999999
   irec=0
   read_msg: do while (ireadmg(lnbufr,subset,idate) >= 0)
      irec=irec+1
@@ -463,8 +464,11 @@ subroutine read_avhrr_navy(mype,val_avhrr,ithin,rmesh,jsatid,&
 ! Normal exit
 700 continue
 
+!  number of profiles kept after thinning and QC
+  number_profiles = count(nrec(:) /= 999999,dim=1)
+
   call combine_radobs(mype_sub,mype_root,npe_sub,mpi_comm_sub,&
-     nele,itxmax,nread,ndata,data_all,score_crit,nrec)
+     nele,itxmax,nread,number_profiles,ndata,data_all,score_crit,nrec)
 
 
 ! Now that we've identified the "best" observations, pull out best obs

src/gsi/read_bufrtovs.f90

@@ -192,7 +192,7 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,&
   character(len=8) :: subset
   character(len=80):: hdr1b,hdr2b
 
-  integer(i_kind) ireadsb,ireadmg,irec,next,nrec_startx
+  integer(i_kind) ireadsb,ireadmg,irec,next,nrec_startx, number_profiles
   integer(i_kind) i,j,k,ifov,ntest,llll
   integer(i_kind) sacv
   integer(i_kind) iret,idate,nchanl,n,idomsfc(1)
@@ -490,7 +490,7 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,&
   hdr2b ='SAZA SOZA BEARAZ SOLAZI'
   allocate(data_all(nele,itxmax),data1b8(nchanl),data1b4(nchanl),nrec(itxmax))
 
-
+  nrec = 999999
   next=0
   irec=0
 ! Big loop over standard data feed and possible ears/db data
@@ -1061,8 +1061,11 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,&
   end do ears_db_loop
   deallocate(data1b8,data1b4)
 
+!  number of profiles kept after thinning and QC
+  number_profiles = count(nrec(:) /= 999999,dim=1)
+
   call combine_radobs(mype_sub,mype_root,npe_sub,mpi_comm_sub,&
-     nele,itxmax,nread,ndata,data_all,score_crit,nrec)
+     nele,itxmax,nread,number_profiles,ndata,data_all,score_crit,nrec)
 
 ! 
   if(mype_sub==mype_root)then