Changeset 2428 for LMDZ5/trunk/libf

LMDZ5/trunk/libf/phylmd/cosp/MISR_simulator.F

-                      r1907
+                      r2428
 ! Copyright (c) 2009,  Roger Marchand, version 1.2
 ! All rights reserved.
+! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/MISR_simulator/MISR_simulator.f $
+!
 ! Redistribution and use in source and binary forms, with or without modification, are permitted
 …
      &     ncol,
      &     sunlit,
      &     zfull,
      &     at,
+     &     zfull,
+     &     at,
      &     dtau_s,
+     &     dtau_c,
+     &     frac_out,
+     &     fq_MISR_TAU_v_CTH,
+     &     dist_model_layertops,
+     &     MISR_mean_ztop,
+     &     dtau_c,
+     &     frac_out,
+     &     missing_value,
+     &     fq_MISR_TAU_v_CTH,
+     &     dist_model_layertops,
+     &     MISR_mean_ztop,
      &     MISR_cldarea
      & )
       implicit none
 …
       INTEGER npoints                   !  if ncol ==1, the number of model points in the horizontal grid
                                         !   else        the number of GCM grid points
+                            !   else    the number of GCM grid points
       INTEGER nlev                      !  number of model vertical levels
       INTEGER ncol                      !  number of model sub columns
                                         !  (must already be generated in via scops and passed to this
                                         !   routine via the variable frac_out )
+                        !  (must already be generated in via scops and passed to this
+                        !   routine via the variable frac_out )
       INTEGER sunlit(npoints)           !  1 for day points, 0 for night time
       REAL zfull(npoints,nlev)          !  height (in meters) of full model levels (i.e. midpoints)
+      REAL zfull(npoints,nlev)          !  height (in meters) of full model levels (i.e. midpoints)
                                         !  zfull(npoints,1)    is    top level of model
                                         !  zfull(npoints,nlev) is bottom level of model (closest point to surface)
 …
       REAL dtau_s(npoints,nlev)         !  visible wavelength cloud optical depth ... for "stratiform" condensate
                                         !  NOTE:  this the cloud optical depth of only the
                                         !         the model cell (i,j)
+                    !     the model cell (i,j)
       REAL dtau_c(npoints,nlev)         !  visible wavelength cloud optical depth ... for "convective" condensate
                                         !  NOTE:  this the cloud optical depth of only the
                                         !         the model cell (i,j)
+                    !     the model cell (i,j)
       REAL frac_out(npoints,ncol,nlev)  !  NOTE: only need if columns>1 ... subgrid scheme in use.
+      REAL missing_value
 !     ------
 !     Outputs
 !     ------
       REAL fq_MISR_TAU_v_CTH(npoints,7,n_MISR_CTH)
       REAL dist_model_layertops(npoints,n_MISR_CTH)
       REAL MISR_cldarea(npoints)                       ! fractional area coverged by clouds
       REAL MISR_mean_ztop(npoints)                     ! mean cloud top hieght(m) MISR would observe
                                                        ! NOTE: == 0 if area ==0
+      REAL MISR_cldarea(npoints)               ! fractional area coverged by clouds
+      REAL MISR_mean_ztop(npoints)             ! mean cloud top hieght(m) MISR would observe
+                                   ! NOTE: == 0 if area ==0
 !     ------
 …
 !     ------
       REAL tau(npoints,ncol)            ! total column optical depth ...
       INTEGER j,ilev,ilev2,ibox
+      REAL tau(npoints,ncol)        ! total column optical depth ...
+      INTEGER j,ilev,ilev2,ibox,k
       INTEGER itau
 …
       real boxarea
       real tauchk
       REAL box_MISR_ztop(npoints,ncol)  ! cloud top hieght(m) MISR would observe
+      REAL box_MISR_ztop(npoints,ncol)  ! cloud top hieght(m) MISR would observe
       integer thres_crossed_MISR
 …
       DATA MISR_CTH_boundaries / -99, 0, 0.5, 1, 1.5, 2, 2.5, 3,
      c                                4, 5, 7, 9, 11, 13, 15, 17, 99 /
+     c                    4, 5, 7, 9, 11, 13, 15, 17, 99 /
       DATA isccp_taumin / 0.3 /
       tauchk = -1.*log(0.9999999)
+      !
       ! For each GCM cell or horizontal model grid point ...
+      !
       do j=1,npoints
+      ! For each GCM cell or horizontal model grid point ...
+      !
+      do j=1,npoints
+         !
          !      estimate distribution of Model layer tops
+         !
+         !  estimate distribution of Model layer tops
+         !
          dist_model_layertops(j,:)=0
+         do ilev=1,nlev
                 ! define location of "layer top"
                 if(ilev.eq.1 .or. ilev.eq.nlev) then
                         ztest=zfull(j,ilev)
                 else
                         ztest=0.5*(zfull(j,ilev)+zfull(j,ilev-1))
+                endif
                 ! find MISR layer that contains this level
                 ! note, the first MISR level is "no height" level
                 iMISR_ztop=2
                 do loop=2,n_MISR_CTH
                         if ( ztest .gt.
      &                            1000*MISR_CTH_boundaries(loop+1) ) then
                                 iMISR_ztop=loop+1
                         endif
                 enddo
                 dist_model_layertops(j,iMISR_ztop)=
      &                  dist_model_layertops(j,iMISR_ztop)+1
          enddo
+       do ilev=1,nlev
+        ! define location of "layer top"
+        if(ilev.eq.1 .or. ilev.eq.nlev) then
+            ztest=zfull(j,ilev)
+        else
+            ztest=0.5*(zfull(j,ilev)+zfull(j,ilev-1))
+        endif
+        ! find MISR layer that contains this level
+        ! note, the first MISR level is "no height" level
+        iMISR_ztop=2
+        do loop=2,n_MISR_CTH
+            if ( ztest .gt.
+     &                1000*MISR_CTH_boundaries(loop+1) ) then
+                iMISR_ztop=loop+1
+            endif
+        enddo
+        dist_model_layertops(j,iMISR_ztop)=
+     &          dist_model_layertops(j,iMISR_ztop)+1
+       enddo
+         !
          ! compute total cloud optical depth for each column
+         !
          do ibox=1,ncol
             ! Initialize tau to zero in each subcolum
             tau(j,ibox)=0.
             box_cloudy(j,ibox)=.false.
             box_MISR_ztop(j,ibox)=0
             ! initialize threshold detection for each sub column
             thres_crossed_MISR=0;
             do ilev=1,nlev
+       do ibox=1,ncol
+        ! Initialize tau to zero in each subcolum
+            tau(j,ibox)=0.
+        box_cloudy(j,ibox)=.false.
+        box_MISR_ztop(j,ibox)=0
+        ! initialize threshold detection for each sub column
+        thres_crossed_MISR=0;
+        do ilev=1,nlev
                  dtau=0
                  if (frac_out(j,ibox,ilev).eq.1) then
+             dtau=0
+             if (frac_out(j,ibox,ilev).eq.1) then
                         dtau = dtau_s(j,ilev)
                  endif
 …
                  if (frac_out(j,ibox,ilev).eq.2) then
                         dtau = dtau_c(j,ilev)
                  end if
+                 end if
                  tau(j,ibox)=tau(j,ibox)+ dtau
                 ! NOW for MISR ..
                 ! if there a cloud ... start the counter ... store this height
                 if(thres_crossed_MISR .eq. 0 .and. dtau .gt. 0.) then
                         ! first encountered a "cloud"
                         thres_crossed_MISR=1
+                        cloud_dtau=0
+                endif
                 if( thres_crossed_MISR .lt. 99 .and.
      &                  thres_crossed_MISR .gt. 0 ) then
+             tau(j,ibox)=tau(j,ibox)+ dtau
+        ! NOW for MISR ..
+        ! if there a cloud ... start the counter ... store this height
+        if(thres_crossed_MISR .eq. 0 .and. dtau .gt. 0.) then
+            ! first encountered a "cloud"
+            thres_crossed_MISR=1
+            cloud_dtau=0
+        endif
+        if( thres_crossed_MISR .lt. 99 .and.
+     &              thres_crossed_MISR .gt. 0 ) then
                         if( dtau .eq. 0.) then
                                 ! we have come to the end of the current cloud
                                 ! layer without yet selecting a CTH boundary.
                                 ! ... restart cloud tau counter
                                 cloud_dtau=0
                         else
                                 ! add current optical depth to count for
                                 ! the current cloud layer
                                 cloud_dtau=cloud_dtau+dtau
                         endif
                         ! if the cloud is continuous but optically thin (< 1)
                         ! from above the current layer cloud top to the current level
                         ! then MISR will like see a top below the top of the current
                         ! layer
                         if( dtau.gt.0 .and. (cloud_dtau-dtau) .lt. 1) then
                                 if(dtau .lt. 1 .or. ilev.eq.1 .or. ilev.eq.nlev) then
                                         ! MISR will likely penetrate to some point
                                         ! within this layer ... the middle
                                         MISR_penetration_height=zfull(j,ilev)
                                 else
                                         ! take the OD = 1.0 level into this layer
                                         MISR_penetration_height=
      &                                     0.5*(zfull(j,ilev)+zfull(j,ilev-1)) -
      &                                     0.5*(zfull(j,ilev-1)-zfull(j,ilev+1))
      &                                  /dtau
+                                endif
                                 box_MISR_ztop(j,ibox)=MISR_penetration_height
                         endif
                         ! check for a distinctive water layer
                         if(dtau .gt. 1 .and. at(j,ilev).gt.273 ) then
+                if( dtau .eq. 0.) then
+                    ! we have come to the end of the current cloud
+                ! layer without yet selecting a CTH boundary.
+                ! ... restart cloud tau counter
+                cloud_dtau=0
+            else
+                ! add current optical depth to count for
+                ! the current cloud layer
+                cloud_dtau=cloud_dtau+dtau
+            endif
+            ! if the cloud is continuous but optically thin (< 1)
+            ! from above the current layer cloud top to the current level
+            ! then MISR will like see a top below the top of the current
+            ! layer
+            if( dtau.gt.0 .and. (cloud_dtau-dtau) .lt. 1) then
+                if(dtau .lt. 1 .or. ilev.eq.1 .or. ilev.eq.nlev) then
+                    ! MISR will likely penetrate to some point
+                    ! within this layer ... the middle
+                    MISR_penetration_height=zfull(j,ilev)
+                else
+                    ! take the OD = 1.0 level into this layer
+                    MISR_penetration_height=
+     &                     0.5*(zfull(j,ilev)+zfull(j,ilev-1)) -
+     &                     0.5*(zfull(j,ilev-1)-zfull(j,ilev+1))
+     &                  /dtau
+                endif
+                box_MISR_ztop(j,ibox)=MISR_penetration_height
+            endif
+            ! check for a distinctive water layer
+            if(dtau .gt. 1 .and. at(j,ilev).gt.273 ) then
                                 ! must be a water cloud ...
                                 ! take this as CTH level
                                 thres_crossed_MISR=99
                         endif
                         ! if the total column optical depth is "large" than
                         ! MISR can't seen anything else ... set current point as CTH level
+                        if(tau(j,ibox) .gt. 5) then
+                                thres_crossed_MISR=99
                         endif
                 endif ! MISR CTH booundary not set
             enddo  !ilev - loop over vertical levesl
             ! written by roj 5/2006
             ! check to see if there was a cloud for which we didn't
             ! set a MISR cloud top boundary
             if( thres_crossed_MISR .eq. 1) then
                 ! if the cloud has a total optical depth of greater
                 ! than ~ 0.5 MISR will still likely pick up this cloud
                 ! with a height near the true cloud top
                 ! otherwise there should be no CTH
                 if( tau(j,ibox) .gt. 0.5) then
                         ! keep MISR detected CTH
                 elseif(tau(j,ibox) .gt. 0.2) then
                         ! MISR may detect but wont likley have a good height
                         box_MISR_ztop(j,ibox)=-1
                 else
                         ! MISR not likely to even detect.
                         ! so set as not cloudy
                         box_MISR_ztop(j,ibox)=0
                 endif
             endif
          enddo  ! loop of subcolumns
+                    ! must be a water cloud ...
+                ! take this as CTH level
+                thres_crossed_MISR=99
+            endif
+            ! if the total column optical depth is "large" than
+            ! MISR can't seen anything else ... set current point as CTH level
+            if(tau(j,ibox) .gt. 5) then
+                thres_crossed_MISR=99
+            endif
+        endif ! MISR CTH booundary not set
+        enddo  !ilev - loop over vertical levesl
+        ! written by roj 5/2006
+        ! check to see if there was a cloud for which we didn't
+        ! set a MISR cloud top boundary
+        if( thres_crossed_MISR .eq. 1) then
+        ! if the cloud has a total optical depth of greater
+        ! than ~ 0.5 MISR will still likely pick up this cloud
+        ! with a height near the true cloud top
+        ! otherwise there should be no CTH
+        if( tau(j,ibox) .gt. 0.5) then
+            ! keep MISR detected CTH
+        elseif(tau(j,ibox) .gt. 0.2) then
+            ! MISR may detect but wont likley have a good height
+            box_MISR_ztop(j,ibox)=-1
+        else
+            ! MISR not likely to even detect.
+            ! so set as not cloudy
+            box_MISR_ztop(j,ibox)=0
+        endif
+        endif
+       enddo  ! loop of subcolumns
        enddo    ! loop of gridpoints
+        !
         !       Modify MISR CTH for satellite spatial / pattern matcher effects
+        !
         !       Code in this region added by roj 5/2006 to account
         !       for spatial effect of the MISR pattern matcher.
         !       Basically, if a column is found between two neighbors
         !       at the same CTH, and that column has no hieght or
         !       a lower CTH, THEN misr will tend to but place the
         !       odd column at the same height as it neighbors.
+        !
         !       This setup assumes the columns represent a about a 1 to 4 km scale
         !       it will need to be modified significantly, otherwise
         if(ncol.eq.1) then
            ! adjust based on neightboring points ... i.e. only 2D grid was input
+        !   Modify MISR CTH for satellite spatial / pattern matcher effects
+    !
+    !   Code in this region added by roj 5/2006 to account
+    !   for spatial effect of the MISR pattern matcher.
+    !   Basically, if a column is found between two neighbors
+    !   at the same CTH, and that column has no hieght or
+    !   a lower CTH, THEN misr will tend to but place the
+    !   odd column at the same height as it neighbors.
+    !
+    !   This setup assumes the columns represent a about a 1 to 4 km scale
+    !   it will need to be modified significantly, otherwise
+        if(ncol.eq.1) then
+       ! adjust based on neightboring points ... i.e. only 2D grid was input
            do j=2,npoints-1
                         if(box_MISR_ztop(j-1,1).gt.0 .and.
      &                     box_MISR_ztop(j+1,1).gt.0       ) then
                                 if( abs( box_MISR_ztop(j-1,1) -
      &                                   box_MISR_ztop(j+1,1) ) .lt. 500
      &                          .and.
      &                                   box_MISR_ztop(j,1) .lt.
      &                                   box_MISR_ztop(j+1,1)     ) then
                                         box_MISR_ztop(j,1) =
      &                                          box_MISR_ztop(j+1,1)
                                 endif
                         endif
+            if(box_MISR_ztop(j-1,1).gt.0 .and.
+     &             box_MISR_ztop(j+1,1).gt.0       ) then
+                if( abs( box_MISR_ztop(j-1,1) -
+     &                   box_MISR_ztop(j+1,1) ) .lt. 500
+     &              .and.
+     &                   box_MISR_ztop(j,1) .lt.
+     &                   box_MISR_ztop(j+1,1)     ) then
+                    box_MISR_ztop(j,1) =
+     &                      box_MISR_ztop(j+1,1)
+                endif
+            endif
          enddo
       else
+        else
          ! adjust based on neighboring subcolumns ....
          do ibox=2,ncol-1
                         if(box_MISR_ztop(1,ibox-1).gt.0 .and.
      &                     box_MISR_ztop(1,ibox+1).gt.0            ) then
                                 if( abs( box_MISR_ztop(1,ibox-1) -
      &                                   box_MISR_ztop(1,ibox+1) ) .lt. 500
      &                          .and.
      &                                   box_MISR_ztop(1,ibox) .lt.
      &                                   box_MISR_ztop(1,ibox+1)     ) then
                                         box_MISR_ztop(1,ibox) =
      &                                          box_MISR_ztop(1,ibox+1)
                                 endif
                         endif
+            if(box_MISR_ztop(1,ibox-1).gt.0 .and.
+     &             box_MISR_ztop(1,ibox+1).gt.0        ) then
+                if( abs( box_MISR_ztop(1,ibox-1) -
+     &                   box_MISR_ztop(1,ibox+1) ) .lt. 500
+     &              .and.
+     &                   box_MISR_ztop(1,ibox) .lt.
+     &                   box_MISR_ztop(1,ibox+1)     ) then
+                    box_MISR_ztop(1,ibox) =
+     &                      box_MISR_ztop(1,ibox+1)
+                endif
+            endif
          enddo
       endif
+        endif
+        !
         !     DETERMINE CLOUD TYPE FREQUENCIES
+        !
         !     Now that ztop and tau have been determined,
         !     determine amount of each cloud type
       boxarea=1./real(ncol)
       do j=1,npoints
+    !     DETERMINE CLOUD TYPE FREQUENCIES
+    !
+    !     Now that ztop and tau have been determined,
+    !     determine amount of each cloud type
+        boxarea=1./real(ncol)
+        do j=1,npoints
          ! reset frequencies -- modified loop structure, roj 5/2006
          do ilev=1,7  ! "tau loop"
             do  ilev2=1,n_MISR_CTH
                 fq_MISR_TAU_v_CTH(j,ilev,ilev2)=0.
+         do ilev=1,7  ! "tau loop"
+            do  ilev2=1,n_MISR_CTH
+            fq_MISR_TAU_v_CTH(j,ilev,ilev2)=0.
             enddo
          enddo
          MISR_cldarea(j)=0.
          MISR_mean_ztop(j)=0.
+         enddo
+         MISR_cldarea(j)=0.
+         MISR_mean_ztop(j)=0.
          do ibox=1,ncol
 …
             endif
             itau = 0
+            itau = 0
             if (box_cloudy(j,ibox)) then
               !determine optical depth category
+          !determine optical depth category
               if (tau(j,ibox) .lt. isccp_taumin) then
                   itau=1
 …
               endif
            endif
            ! update MISR histograms and summary metrics - roj 5/2005
            if (sunlit(j).eq.1) then
+             endif
+       ! update MISR histograms and summary metrics - roj 5/2005
+       if (sunlit(j).eq.1) then
               !if cloudy added by roj 5/2005
               if( box_MISR_ztop(j,ibox).eq.0) then
                         ! no cloud detected
                         iMISR_ztop=0
               elseif( box_MISR_ztop(j,ibox).eq.-1) then
                         ! cloud can be detected but too thin to get CTH
                         iMISR_ztop=1
                         fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)=
      &                          fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea
               else
+                        !
                         ! determine index for MISR bin set
+                        !
                         iMISR_ztop=2
                         do loop=2,n_MISR_CTH
                                 if ( box_MISR_ztop(j,ibox) .gt.
      &                            1000*MISR_CTH_boundaries(loop+1) ) then
                                   iMISR_ztop=loop+1
                                 endif
                         enddo
                         if(box_cloudy(j,ibox)) then
                                 ! there is an isccp clouds so itau(j) is defined
                                 fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)=
      &                                  fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea
+          if( box_MISR_ztop(j,ibox).eq.0) then
+            ! no cloud detected
+            iMISR_ztop=0
+          elseif( box_MISR_ztop(j,ibox).eq.-1) then
+            ! cloud can be detected but too thin to get CTH
+            iMISR_ztop=1
+            fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)=
+     &            fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea
+          else
+            !
+            ! determine index for MISR bin set
+            !
+            iMISR_ztop=2
+            do loop=2,n_MISR_CTH
+                if ( box_MISR_ztop(j,ibox) .gt.
+     &                1000*MISR_CTH_boundaries(loop+1) ) then
+                  iMISR_ztop=loop+1
+                endif
+            enddo
+            if(box_cloudy(j,ibox)) then
+               ! there is an isccp clouds so itau(j) is defined
+               fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)=
+     &            fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea
                         else
                                 ! MISR CTH resolution is trying to fill in a
                                 ! broken cloud scene where there is no condensate.
                                 ! The MISR CTH-1D-OD product will only put in a cloud
                                 ! if the MISR cloud mask indicates cloud.
                                 ! therefore we will not include this column in the histogram
                                 ! in reality aerosoal and 3D effects or bright surfaces
                                 ! could fool the MISR cloud mask
                                 ! the alternative is to count as very thin cloud ??
 !                               fq_MISR_TAU_v_CTH(1,iMISR_ztop)=
 !     &                                 fq_MISR_TAU_v_CTH(1,iMISR_ztop) + boxarea
                         endif
                         MISR_mean_ztop(j)=MISR_mean_ztop(j)+
      &                                       box_MISR_ztop(j,ibox)*boxarea
                         MISR_cldarea(j)=MISR_cldarea(j) + boxarea
+            else
+                ! MISR CTH resolution is trying to fill in a
+                ! broken cloud scene where there is no condensate.
+                ! The MISR CTH-1D-OD product will only put in a cloud
+                ! if the MISR cloud mask indicates cloud.
+                ! therefore we will not include this column in the histogram
+                ! in reality aerosoal and 3D effects or bright surfaces
+                ! could fool the MISR cloud mask
+                ! the alternative is to count as very thin cloud ??
+!               fq_MISR_TAU_v_CTH(1,iMISR_ztop)=
+!     &                     fq_MISR_TAU_v_CTH(1,iMISR_ztop) + boxarea
+            endif
+            MISR_mean_ztop(j)=MISR_mean_ztop(j)+
+     &                       box_MISR_ztop(j,ibox)*boxarea
+            MISR_cldarea(j)=MISR_cldarea(j) + boxarea
+              endif
+           endif ! is sunlight ?
+        enddo ! ibox - loop over subcolumns
+        if( MISR_cldarea(j) .gt. 0.) then
+                MISR_mean_ztop(j)= MISR_mean_ztop(j) / MISR_cldarea(j)   ! roj 5/2006
+        endif
+      enddo  ! loop over grid points
+          endif
+       else
+          ! Set to issing data. A. Bodas - 14/05/2010
+          do loop=1,n_MISR_CTH
+             do k=1,7
+                fq_MISR_TAU_v_CTH(j,k,loop) = missing_value
+             enddo
+             dist_model_layertops(j,loop) = missing_value
+          enddo
+          MISR_cldarea(j) = missing_value
+          MISR_mean_ztop(npoints) = missing_value
+       endif ! is sunlight ?
+       enddo ! ibox - loop over subcolumns
+       if( MISR_cldarea(j) .gt. 0.) then
+        MISR_mean_ztop(j)= MISR_mean_ztop(j) / MISR_cldarea(j)   ! roj 5/2006
+       endif
+       enddo  ! loop over grid points
       return

LMDZ5/trunk/libf/phylmd/cosp/array_lib.F90

r1907	r2428
	1	! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
	2	! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/array_lib.f90 $
1	3	! ARRAY_LIB: Array procedures for F90
2	4	! Compiled/Modified:

LMDZ5/trunk/libf/phylmd/cosp/atmos_lib.F90

-                      r1907
+                      r2428
+! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/atmos_lib.f90 $
 ! ATMOS_LIB: Atmospheric science procedures for F90
 ! Compiled/Modified:
 …
 .2000, 27.7000, 13.2000, 6.52000, 3.33000, 1.76000, &
 .951000,0.0671000,0.000300000/)
     tk =  (/294.000, 290.000, 285.000, 279.000, 273.000, 267.000, &
 .000, 255.000, 248.000, 242.000, 235.000, 229.000, &
 …
 .55162,1.37966,0.229799,0.0245943,0.00373686,0.000702138, &
 .000162076,0.000362055,7.68645e-06/)
   case default
     print *, 'Must enter a profile type'

LMDZ5/trunk/libf/phylmd/cosp/congvec.h

r1907	r2428
3	3	! (c) British Crown Copyright 2009, the Met Office.
4	4	! All rights reserved.
	5	! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
	6	! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/icarus-scops-4.1-bsd/congvec.f $
5	7	!
6	8	! Redistribution and use in source and binary forms, with or without

LMDZ5/trunk/libf/phylmd/cosp/cosp.F90

-                      r1907
+                      r2428
 ! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 !!#include "cosp_defs.h"
+#include "cosp_defs.h"
 MODULE MOD_COSP
   USE MOD_COSP_TYPES
   USE MOD_COSP_SIMULATOR
+  USE mod_phys_lmdz_para
+  USE mod_grid_phy_lmdz
+  USE MOD_COSP_MODIS_SIMULATOR
   IMPLICIT NONE
 …
 !--------------------- SUBROUTINE COSP ---------------------------
 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar)
+!#ifdef RTTOV
+!SUBROUTINE COSP(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar)
+!#else
+SUBROUTINE COSP(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar)
+!#endif
   ! Arguments
   integer,intent(in) :: overlap !  overlap type in SCOPS: 1=max, 2=rand, 3=max/rand
 …
   type(cosp_isccp),intent(inout)   :: isccp   ! Output from ISCCP simulator
   type(cosp_misr),intent(inout)    :: misr    ! Output from MISR simulator
+  type(cosp_modis),intent(inout)   :: modis   ! Output from MODIS simulator
+!#ifdef RTTOV
+!  type(cosp_rttov),intent(inout)   :: rttov   ! Output from RTTOV
+!#endif
   type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator
   type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator
 …
   integer :: Niter     ! Number of calls to cosp_simulator
   integer :: i_first,i_last ! First and last gridbox to be processed in each iteration
   integer :: i,j,k,Ni
+  integer :: i,Ni
   integer,dimension(2) :: ix,iy
   logical :: reff_zero
-  real :: minv,maxv
   real :: maxp,minp
   integer,dimension(:),save,  allocatable :: & ! Dimensions nPoints
+  integer,dimension(:),allocatable :: & ! Dimensions nPoints
                   seed    !  It is recommended that the seed is set to a different value for each model
                           !  gridbox it is called on, as it is possible that the choice of the same
                           !  seed value every time may introduce some statistical bias in the results,
                           !  particularly for low values of NCOL.
-!$OMP THREADPRIVATE(seed)
-  real,dimension(:),allocatable :: rseed    !  It is recommended that the seed is set to a different value for each model
   ! Types used in one iteration
   type(cosp_gridbox) :: gbx_it
 …
   type(cosp_sglidar) :: sglidar_it
   type(cosp_isccp)   :: isccp_it
+  type(cosp_modis)   :: modis_it
   type(cosp_misr)    :: misr_it
+!#ifdef RTTOV
+!  type(cosp_rttov)   :: rttov_it
+!#endif
   type(cosp_radarstats) :: stradar_it
   type(cosp_lidarstats) :: stlidar_it
+  logical,save :: first_cosp=.TRUE.
+!$OMP THREADPRIVATE(first_cosp)
+  !++++++++++ Dimensions ++++++++++++
+!++++++++++ Dimensions ++++++++++++
   Npoints  = gbx%Npoints
   Nlevels  = gbx%Nlevels
   Nhydro   = gbx%Nhydro
+!++++++++++ Depth of model layers ++++++++++++
+  do i=1,Nlevels-1
+    gbx%dlev(:,i) = gbx%zlev_half(:,i+1) - gbx%zlev_half(:,i)
+  enddo
+  gbx%dlev(:,Nlevels) = 2.0*(gbx%zlev(:,Nlevels) - gbx%zlev_half(:,Nlevels))
 !++++++++++ Apply sanity checks to inputs ++++++++++
 …
       !     and reff_zero    == .false.  Reff use in lidar and set to 0 for radar
   endif
-!  if ((gbx%use_reff) .and. (reff_zero)) then ! Inconsistent choice. Want to use Reff but not inputs passed
-!        print *, '---------- COSP ERROR ------------'
-!        print *, ''
-!        print *, 'use_reff==.true. but Reff is always zero'
-!        print *, ''
-!        print *, '----------------------------------'
-!        stop
-!  endif
   if ((.not. gbx%use_reff) .and. (reff_zero)) then ! No Reff in radar. Default in lidar
         gbx%Reff = DEFAULT_LIDAR_REFF
 …
   endif
-  if (first_cosp) then
    ! We base the seed in the decimal part of the surface pressure.
+     allocate(seed(Npoints))
+     allocate(rseed(klon_glo))
+     CALL gather(gbx%psfc,rseed)
+     call bcast(rseed)
+!   seed = int(gbx%psfc) ! This is to avoid division by zero when Npoints = 1
+   allocate(seed(Npoints))
+   seed = int(gbx%psfc) ! This is to avoid division by zero when Npoints = 1
       ! Roj Oct/2008 ... Note: seed value of 0 caused me some problems + I want to
       ! randomize for each call to COSP even when Npoints ==1
+     minp = minval(rseed)
+     maxp = maxval(rseed)
+     if (Npoints .gt. 1) THEN
+       seed=int((gbx%psfc-minp)/(maxp-minp)*100000) + 1
+     else
+       seed=int(gbx%psfc-minp)
+     endif
+     deallocate(rseed)
+     first_cosp=.false.
+   endif
+   minp = minval(gbx%psfc)
+   maxp = maxval(gbx%psfc)
+   if (Npoints .gt. 1) seed=int((gbx%psfc-minp)/(maxp-minp)*100000) + 1
+   ! Below it's how it was done in the original implementation of the ISCCP simulator.
+   ! The one above is better for offline data, when you may have packed data
+   ! that subsamples the decimal fraction of the surface pressure.
+!    if (Npoints .gt. 1) seed=(gbx%psfc-int(gbx%psfc))*1000000
    if (gbx%Npoints_it >= gbx%Npoints) then ! One iteration gbx%Npoints
+        call cosp_iter(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar)
+!#ifdef RTTOV
+!        call cosp_iter(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar)
+!#else
+        call cosp_iter(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar)
+!#endif
    else ! Several iterations to save memory
         Niter = gbx%Npoints/gbx%Npoints_it ! Integer division
 …
             if (i == 1) then
                 ! Allocate types for all but last iteration
+                call construct_cosp_gridbox(gbx%time,gbx%radar_freq,gbx%surface_radar,gbx%use_mie_tables,gbx%use_gas_abs, &
+                                            gbx%do_ray,gbx%melt_lay,gbx%k2,Ni,Nlevels,Ncolumns,N_HYDRO,gbx%Nprmts_max_hydro, &
+                call construct_cosp_gridbox(gbx%time,gbx%time_bnds,gbx%radar_freq,gbx%surface_radar,gbx%use_mie_tables, &
+                                            gbx%use_gas_abs,gbx%do_ray,gbx%melt_lay,gbx%k2,Ni,Nlevels, &
+                                            Ncolumns,N_HYDRO,gbx%Nprmts_max_hydro, &
                                             gbx%Naero,gbx%Nprmts_max_aero,Ni,gbx%lidar_ice_type,gbx%isccp_top_height, &
                                             gbx%isccp_top_height_direction,gbx%isccp_overlap,gbx%isccp_emsfc_lw, &
 …
                 call construct_cosp_sglidar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar_it)
                 call construct_cosp_isccp(cfg,Ni,Ncolumns,Nlevels,isccp_it)
+                call construct_cosp_modis(cfg, Ni, modis_it)
                 call construct_cosp_misr(cfg,Ni,misr_it)
+!#ifdef RTTOV
+!                call construct_cosp_rttov(Ni,gbx%nchan,rttov_it)
+!#endif
                 call construct_cosp_radarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar_it)
                 call construct_cosp_lidarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar_it)
 …
                 call free_cosp_sglidar(sglidar_it)
                 call free_cosp_isccp(isccp_it)
+                call free_cosp_modis(modis_it)
                 call free_cosp_misr(misr_it)
+!#ifdef RTTOV
+!                call free_cosp_rttov(rttov_it)
+!#endif
                 call free_cosp_radarstats(stradar_it)
                 call free_cosp_lidarstats(stlidar_it)
                 ! Allocate types for iterations
+                call construct_cosp_gridbox(gbx%time,gbx%radar_freq,gbx%surface_radar,gbx%use_mie_tables,gbx%use_gas_abs, &
+                                            gbx%do_ray,gbx%melt_lay,gbx%k2,Ni,Nlevels,Ncolumns,N_HYDRO,gbx%Nprmts_max_hydro, &
+                call construct_cosp_gridbox(gbx%time,gbx%time_bnds,gbx%radar_freq,gbx%surface_radar,gbx%use_mie_tables, &
+                                            gbx%use_gas_abs,gbx%do_ray,gbx%melt_lay,gbx%k2,Ni,Nlevels, &
+                                            Ncolumns,N_HYDRO,gbx%Nprmts_max_hydro, &
                                             gbx%Naero,gbx%Nprmts_max_aero,Ni,gbx%lidar_ice_type,gbx%isccp_top_height, &
                                             gbx%isccp_top_height_direction,gbx%isccp_overlap,gbx%isccp_emsfc_lw, &
 …
                 call construct_cosp_sglidar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar_it)
                 call construct_cosp_isccp(cfg,Ni,Ncolumns,Nlevels,isccp_it)
+                call construct_cosp_modis(cfg,Ni, modis_it)
                 call construct_cosp_misr(cfg,Ni,misr_it)
+!#ifdef RTTOV
+!                call construct_cosp_rttov(Ni,gbx%nchan,rttov_it)
+!#endif
                 call construct_cosp_radarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar_it)
                 call construct_cosp_lidarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar_it)
 …
             if (cfg%Llidar_sim) call cosp_sglidar_cpsection(ix,iy,sglidar,sglidar_it)
             if (cfg%Lisccp_sim) call cosp_isccp_cpsection(ix,iy,isccp,isccp_it)
+            if (cfg%Lmodis_sim) call cosp_modis_cpsection(ix,iy,modis,modis_it)
             if (cfg%Lmisr_sim)  call cosp_misr_cpsection(ix,iy,misr,misr_it)
+!#ifdef RTTOV
+!            if (cfg%Lrttov_sim) call cosp_rttov_cpsection(ix,iy,rttov,rttov_it)
+!#endif
             if (cfg%Lradar_sim) call cosp_radarstats_cpsection(ix,iy,stradar,stradar_it)
             if (cfg%Llidar_sim) call cosp_lidarstats_cpsection(ix,iy,stlidar,stlidar_it)
+            print *,'---------ix: ',ix
+!#ifdef RTTOV
+!            call cosp_iter(overlap,seed(ix(1):ix(2)),cfg,vgrid_it,gbx_it,sgx_it,sgradar_it, &
+!                           sglidar_it,isccp_it,misr_it,modis_it,rttov_it,stradar_it,stlidar_it)
+!#else
             call cosp_iter(overlap,seed(ix(1):ix(2)),cfg,vgrid_it,gbx_it,sgx_it,sgradar_it, &
                            sglidar_it,isccp_it,misr_it,stradar_it,stlidar_it)
+                           sglidar_it,isccp_it,misr_it,modis_it,stradar_it,stlidar_it)
+!#endif
             ! --- Copy results to output structures ---
-!             call cosp_gridbox_cphp(gbx_it,gbx)
             ix=(/1,Ni/)
             iy=(/i_first,i_last/)
 …
             if (cfg%Llidar_sim) call cosp_sglidar_cpsection(ix,iy,sglidar_it,sglidar)
             if (cfg%Lisccp_sim) call cosp_isccp_cpsection(ix,iy,isccp_it,isccp)
+            if (cfg%Lmodis_sim) call cosp_modis_cpsection(ix,iy,modis_it,modis)
             if (cfg%Lmisr_sim)  call cosp_misr_cpsection(ix,iy,misr_it,misr)
+!#ifdef RTTOV
+!            if (cfg%Lrttov_sim) call cosp_rttov_cpsection(ix,iy,rttov_it,rttov)
+!#endif
             if (cfg%Lradar_sim) call cosp_radarstats_cpsection(ix,iy,stradar_it,stradar)
             if (cfg%Llidar_sim) call cosp_lidarstats_cpsection(ix,iy,stlidar_it,stlidar)
 …
         call free_cosp_sglidar(sglidar_it)
         call free_cosp_isccp(isccp_it)
+        call free_cosp_modis(modis_it)
         call free_cosp_misr(misr_it)
+!#ifdef RTTOV
+!        call free_cosp_rttov(rttov_it)
+!#endif
         call free_cosp_radarstats(stradar_it)
         call free_cosp_lidarstats(stlidar_it)
    endif
+   deallocate(seed)
 …
 !--------------------- SUBROUTINE COSP_ITER ----------------------
 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_ITER(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar)
+!#ifdef RTTOV
+!SUBROUTINE COSP_ITER(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar)
+!#else
+SUBROUTINE COSP_ITER(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar)
+!#endif
   ! Arguments
   integer,intent(in) :: overlap !  overlap type in SCOPS: 1=max, 2=rand, 3=max/rand
 …
   type(cosp_isccp),intent(inout)   :: isccp   ! Output from ISCCP simulator
   type(cosp_misr),intent(inout)    :: misr    ! Output from MISR simulator
+  type(cosp_modis),intent(inout)   :: modis   ! Output from MODIS simulator
+!#ifdef RTTOV
+!  type(cosp_rttov),intent(inout)   :: rttov   ! Output from RTTOV
+!#endif
   type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator
   type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator
 …
   integer :: Nlevels   ! Number of levels
   integer :: Nhydro    ! Number of hydrometeors
-  integer :: Niter     ! Number of calls to cosp_simulator
   integer :: i,j,k
   integer :: I_HYDRO
+  integer :: I_HYDRO
   real,dimension(:,:),pointer :: column_frac_out ! Array with one column of frac_out
   integer,parameter :: scops_debug=0    !  set to non-zero value to print out inputs for debugging in SCOPS
+  real,dimension(:,:),pointer :: column_prec_out ! Array with one column of prec_frac
+  integer :: scops_debug=0    !  set to non-zero value to print out inputs for debugging in SCOPS
   real,dimension(:, :),allocatable :: cca_scops,ls_p_rate,cv_p_rate, &
                      tca_scops ! Cloud cover in each model level (HORIZONTAL gridbox fraction) of total cloud.
 …
   real,dimension(:,:),allocatable :: frac_ls,prec_ls,frac_cv,prec_cv ! Cloud/Precipitation fraction in each model level
                                                                      ! Levels are from SURFACE to TOA
   real,dimension(:,:),allocatable :: rho ! (Npoints, Nlevels). Atmospheric dens
+  real,dimension(:,:),allocatable :: rho ! (Npoints, Nlevels). Atmospheric density
   type(cosp_sghydro) :: sghydro   ! Subgrid info for hydrometeors en each iteration
 …
   Nhydro   = gbx%Nhydro
   !++++++++++ Climate/NWP mode ++++++++++
   if (Ncolumns > 1) then
 …
        ! Deallocate arrays that will no longer be used
         deallocate(tca_scops,cca_scops,ls_p_rate,cv_p_rate)
         ! Populate the subgrid arrays
         call construct_cosp_sghydro(Npoints,Ncolumns,Nlevels,Nhydro,sghydro)
 …
                 sghydro%mr_hydro(:,k,:,I_LSCLIQ) = gbx%mr_hydro(:,:,I_LSCLIQ)
                 sghydro%mr_hydro(:,k,:,I_LSCICE) = gbx%mr_hydro(:,:,I_LSCICE)
                 sghydro%Reff(:,k,:,I_LSCLIQ)     = gbx%Reff(:,:,I_LSCLIQ)
                 sghydro%Reff(:,k,:,I_LSCICE)     = gbx%Reff(:,:,I_LSCICE)
+                sghydro%Reff(:,k,:,I_LSRAIN)     = gbx%Reff(:,:,I_LSRAIN)
+                sghydro%Reff(:,k,:,I_LSSNOW)     = gbx%Reff(:,:,I_LSSNOW)
+                sghydro%Reff(:,k,:,I_LSGRPL)     = gbx%Reff(:,:,I_LSGRPL)
+                sghydro%Np(:,k,:,I_LSCLIQ)     = gbx%Np(:,:,I_LSCLIQ)
+                sghydro%Np(:,k,:,I_LSCICE)     = gbx%Np(:,:,I_LSCICE)
             elsewhere (column_frac_out == I_CVC) !+++++++++++ CONV clouds ++++++++
+                sghydro%mr_hydro(:,k,:,I_CVCLIQ) = gbx%mr_hydro(:,:,I_CVCLIQ)
+                sghydro%mr_hydro(:,k,:,I_CVCICE) = gbx%mr_hydro(:,:,I_CVCICE)
+                sghydro%Reff(:,k,:,I_CVCLIQ)     = gbx%Reff(:,:,I_CVCLIQ)
+                sghydro%Reff(:,k,:,I_CVCICE)     = gbx%Reff(:,:,I_CVCICE)
+                sghydro%Reff(:,k,:,I_CVRAIN)     = gbx%Reff(:,:,I_CVRAIN)
+                sghydro%Reff(:,k,:,I_CVSNOW)     = gbx%Reff(:,:,I_CVSNOW)
+            end where
+                sghydro%mr_hydro(:,k,:,I_CVCLIQ) = gbx%mr_hydro(:,:,I_CVCLIQ)
+                sghydro%mr_hydro(:,k,:,I_CVCICE) = gbx%mr_hydro(:,:,I_CVCICE)
+                sghydro%Reff(:,k,:,I_CVCLIQ)     = gbx%Reff(:,:,I_CVCLIQ)
+                sghydro%Reff(:,k,:,I_CVCICE)     = gbx%Reff(:,:,I_CVCICE)
+                sghydro%Np(:,k,:,I_CVCLIQ)     = gbx%Np(:,:,I_CVCLIQ)
+                sghydro%Np(:,k,:,I_CVCICE)     = gbx%Np(:,:,I_CVCICE)
+            end where
+            column_prec_out => sgx%prec_frac(:,k,:)
+            where ((column_prec_out == 1) .or. (column_prec_out == 3) )  !++++ LS precip ++++
+                sghydro%Reff(:,k,:,I_LSRAIN) = gbx%Reff(:,:,I_LSRAIN)
+                sghydro%Reff(:,k,:,I_LSSNOW) = gbx%Reff(:,:,I_LSSNOW)
+                sghydro%Reff(:,k,:,I_LSGRPL) = gbx%Reff(:,:,I_LSGRPL)
+                sghydro%Np(:,k,:,I_LSRAIN)     = gbx%Np(:,:,I_LSRAIN)
+                sghydro%Np(:,k,:,I_LSSNOW)     = gbx%Np(:,:,I_LSSNOW)
+                sghydro%Np(:,k,:,I_LSGRPL)     = gbx%Np(:,:,I_LSGRPL)
+            elsewhere ((column_prec_out == 2) .or. (column_prec_out == 3)) !++++ CONV precip ++++
+                sghydro%Reff(:,k,:,I_CVRAIN) = gbx%Reff(:,:,I_CVRAIN)
+                sghydro%Reff(:,k,:,I_CVSNOW) = gbx%Reff(:,:,I_CVSNOW)
+                sghydro%Np(:,k,:,I_CVRAIN)     = gbx%Np(:,:,I_CVRAIN)
+                sghydro%Np(:,k,:,I_CVSNOW)     = gbx%Np(:,:,I_CVSNOW)
+            end where
             !--------- Precip -------
             if (.not. gbx%use_precipitation_fluxes) then
 …
                     sghydro%mr_hydro(:,k,:,I_LSGRPL) = gbx%mr_hydro(:,:,I_LSGRPL)
                 elsewhere (column_frac_out == I_CVC) !+++++++++++ CONV Precipitation ++++++++
                     sghydro%mr_hydro(:,k,:,I_CVRAIN) = gbx%mr_hydro(:,:,I_CVRAIN)
                     sghydro%mr_hydro(:,k,:,I_CVSNOW) = gbx%mr_hydro(:,:,I_CVSNOW)
+                    sghydro%mr_hydro(:,k,:,I_CVRAIN) = gbx%mr_hydro(:,:,I_CVRAIN)
+                    sghydro%mr_hydro(:,k,:,I_CVSNOW) = gbx%mr_hydro(:,:,I_CVSNOW)
                 end where
             endif
 …
         if (gbx%use_precipitation_fluxes) then
+            ! convert precipitation flux into mixing ratio
+            call pf_to_mr(Npoints,Nlevels,Ncolumns,gbx%rain_ls,gbx%snow_ls,gbx%grpl_ls, &
+                        gbx%rain_cv,gbx%snow_cv,sgx%prec_frac,gbx%p,gbx%T, &
+                        sghydro%mr_hydro(:,:,:,I_LSRAIN),sghydro%mr_hydro(:,:,:,I_LSSNOW),sghydro%mr_hydro(:,:,:,I_LSGRPL), &
+                        sghydro%mr_hydro(:,:,:,I_CVRAIN),sghydro%mr_hydro(:,:,:,I_CVSNOW))
+       endif
+#ifdef MMF_V3p5_TWO_MOMENT
+        write(*,*) 'Precipitation Flux to Mixing Ratio conversion not (yet?) supported ', &
+               'for MMF3.5 Two Moment Microphysics'
+        stop
+#else
+            ! Density
+            allocate(rho(Npoints,Nlevels))
+            I_HYDRO = I_LSRAIN
+            call cosp_precip_mxratio(Npoints,Nlevels,Ncolumns,gbx%p,gbx%T,sgx%prec_frac,1., &
+                    n_ax(I_HYDRO),n_bx(I_HYDRO),alpha_x(I_HYDRO),c_x(I_HYDRO),d_x(I_HYDRO), &
+                    g_x(I_HYDRO),a_x(I_HYDRO),b_x(I_HYDRO), &
+                    gamma_1(I_HYDRO),gamma_2(I_HYDRO),gamma_3(I_HYDRO),gamma_4(I_HYDRO), &
+                    gbx%rain_ls,sghydro%mr_hydro(:,:,:,I_HYDRO),sghydro%Reff(:,:,:,I_HYDRO))
+            I_HYDRO = I_LSSNOW
+            call cosp_precip_mxratio(Npoints,Nlevels,Ncolumns,gbx%p,gbx%T,sgx%prec_frac,1., &
+                    n_ax(I_HYDRO),n_bx(I_HYDRO),alpha_x(I_HYDRO),c_x(I_HYDRO),d_x(I_HYDRO), &
+                    g_x(I_HYDRO),a_x(I_HYDRO),b_x(I_HYDRO), &
+                    gamma_1(I_HYDRO),gamma_2(I_HYDRO),gamma_3(I_HYDRO),gamma_4(I_HYDRO), &
+                    gbx%snow_ls,sghydro%mr_hydro(:,:,:,I_HYDRO),sghydro%Reff(:,:,:,I_HYDRO))
+            I_HYDRO = I_CVRAIN
+            call cosp_precip_mxratio(Npoints,Nlevels,Ncolumns,gbx%p,gbx%T,sgx%prec_frac,2., &
+                    n_ax(I_HYDRO),n_bx(I_HYDRO),alpha_x(I_HYDRO),c_x(I_HYDRO),d_x(I_HYDRO), &
+                    g_x(I_HYDRO),a_x(I_HYDRO),b_x(I_HYDRO), &
+                    gamma_1(I_HYDRO),gamma_2(I_HYDRO),gamma_3(I_HYDRO),gamma_4(I_HYDRO), &
+                    gbx%rain_cv,sghydro%mr_hydro(:,:,:,I_HYDRO),sghydro%Reff(:,:,:,I_HYDRO))
+            I_HYDRO = I_CVSNOW
+            call cosp_precip_mxratio(Npoints,Nlevels,Ncolumns,gbx%p,gbx%T,sgx%prec_frac,2., &
+                    n_ax(I_HYDRO),n_bx(I_HYDRO),alpha_x(I_HYDRO),c_x(I_HYDRO),d_x(I_HYDRO), &
+                    g_x(I_HYDRO),a_x(I_HYDRO),b_x(I_HYDRO), &
+                    gamma_1(I_HYDRO),gamma_2(I_HYDRO),gamma_3(I_HYDRO),gamma_4(I_HYDRO), &
+                    gbx%snow_cv,sghydro%mr_hydro(:,:,:,I_HYDRO),sghydro%Reff(:,:,:,I_HYDRO))
+            I_HYDRO = I_LSGRPL
+            call cosp_precip_mxratio(Npoints,Nlevels,Ncolumns,gbx%p,gbx%T,sgx%prec_frac,1., &
+                    n_ax(I_HYDRO),n_bx(I_HYDRO),alpha_x(I_HYDRO),c_x(I_HYDRO),d_x(I_HYDRO), &
+                    g_x(I_HYDRO),a_x(I_HYDRO),b_x(I_HYDRO), &
+                    gamma_1(I_HYDRO),gamma_2(I_HYDRO),gamma_3(I_HYDRO),gamma_4(I_HYDRO), &
+                    gbx%grpl_ls,sghydro%mr_hydro(:,:,:,I_HYDRO),sghydro%Reff(:,:,:,I_HYDRO))
+            if(allocated(rho)) deallocate(rho)
+#endif
+        endif
    !++++++++++ CRM mode ++++++++++
    else
+      call construct_cosp_sghydro(Npoints,Ncolumns,Nlevels,Nhydro,sghydro)
       sghydro%mr_hydro(:,1,:,:) = gbx%mr_hydro
       sghydro%Reff(:,1,:,:) = gbx%Reff
+      sghydro%Np(:,1,:,:) = gbx%Np      ! added by Roj with Quickbeam V3.0
       !--------- Clouds -------
       where ((gbx%dtau_s > 0.0))
 …
    endif ! Ncolumns > 1
    !++++++++++ Simulator ++++++++++
+    call cosp_simulator(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,stradar,stlidar)
+!#ifdef RTTOV
+!    call cosp_simulator(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar)
+!#else
+    call cosp_simulator(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,stradar,stlidar)
+!#endif
     ! Deallocate subgrid arrays

LMDZ5/trunk/libf/phylmd/cosp/cosp_constants.F90

-                      r2080
+                      r2428
 ! Jul 2008 - A. Bodas-Salcedo - Added definitions of ISCCP axes
 ! Oct 2008 - H. Chepfer       - Added PARASOL_NREFL
+! Jun 2010 - R. Marchand      - Modified to support quickbeam V3, added ifdef for hydrometeor definitions
+!
+!
+!
+#include "cosp_defs.h"
 MODULE MOD_COSP_CONSTANTS
     use netcdf, only: nf90_fill_real
     IMPLICIT NONE
+    character(len=32) :: COSP_VERSION='COSP v1.4'
     ! Indices to address arrays of LS and CONV hydrometeors
     integer,parameter :: I_LSCLIQ = 1
 …
     integer,parameter :: I_CVSNOW = 8
     integer,parameter :: I_LSGRPL = 9
     ! Missing value
+!!    real,parameter :: R_UNDEF = -1.0E30
+!     real,parameter :: R_UNDEF = 9.96921e+36
+      real,parameter :: R_UNDEF = nf90_fill_real
+    real,parameter :: R_UNDEF = -1.0E30
+!    real,parameter :: R_UNDEF = nf90_fill_real
     ! Number of possible output variables
+    integer,parameter :: N_OUT_LIST = 27
+    integer,parameter :: N_OUT_LIST = 63
+    integer,parameter :: N3D = 8
+    integer,parameter :: N2D = 14
+    integer,parameter :: N1D = 40
     ! Value for forward model result from a level that is under the ground
     real,parameter :: R_GROUND = -1.0E20
 …
     integer, parameter :: I_LSC = 1, & ! Large-scale clouds
                           I_CVC = 2    ! Convective clouds
+    ! Timing of different simulators, including statistics module
+    integer, parameter :: N_SIMULATORS = 7
+    integer,parameter :: I_RADAR = 1
+    integer,parameter :: I_LIDAR = 2
+    integer,parameter :: I_ISCCP = 3
+    integer,parameter :: I_MISR  = 4
+    integer,parameter :: I_MODIS = 5
+    integer,parameter :: I_RTTOV = 6
+    integer,parameter :: I_STATS = 7
+    character*32, dimension(N_SIMULATORS) :: SIM_NAME = (/'Radar','Lidar','ISCCP','MISR ','MODIS','RTTOV','Stats'/)
+    integer,dimension(N_SIMULATORS) :: tsim
+    data tsim/N_SIMULATORS*0.0/
     !--- Radar constants
     ! CFAD constants
 …
     real,parameter    :: CFAD_ZE_WIDTH =    5.0 ! Bin width (dBZe)
     !--- Lidar constants
     ! CFAD constants
 …
     integer,parameter :: DPOL_BINS     =   6
     real,parameter    :: LIDAR_UNDEF   =   999.999
     ! Other constants
     integer,parameter :: LIDAR_NCAT    =   4
     integer,parameter :: PARASOL_NREFL =   5 ! parasol
+    real,parameter,dimension(PARASOL_NREFL) :: PARASOL_SZA = (/0.0, 20.0, 40.0, 6.0, 80.0/)
+!    real,parameter,dimension(PARASOL_NREFL) :: PARASOL_SZA = (/1.0, 2.0, 3.0, 4.0, 5.0/)
+    real,parameter,dimension(PARASOL_NREFL) :: PARASOL_SZA = (/0.0, 20.0, 40.0, 60.0, 80.0/)
     real,parameter    :: DEFAULT_LIDAR_REFF = 30.0e-6 ! Default lidar effective radius
+    integer,parameter :: LIDAR_NTEMP = 40
+    real,parameter,dimension(LIDAR_NTEMP) :: LIDAR_PHASE_TEMP=(/-91.5,-88.5,-85.5,-82.5,-79.5,-76.5,-73.5,-70.5,-67.5,-64.5, &
+                   -61.5,-58.5,-55.5,-52.5,-49.5,-46.5,-43.5,-40.5,-37.5,-34.5, &
+                   -31.5,-28.5,-25.5,-22.5,-19.5,-16.5,-13.5,-10.5, -7.5, -4.5, &
+                    -1.5,  1.5,  4.5,  7.5, 10.5, 13.5, 16.5, 19.5, 22.5, 25.5/)
+    real,parameter,dimension(2,LIDAR_NTEMP) :: LIDAR_PHASE_TEMP_BNDS=reshape(source=(/-273.15,-90.,-90.,-87.,-87.,-84.,-84.,-81.,-81.,-78., &
+                   -78.,-75.,-75.,-72.,-72.,-69.,-69.,-66.,-66.,-63., &
+                   -63.,-60.,-60.,-57.,-57.,-54.,-54.,-51.,-51.,-48., &
+                   -48.,-45.,-45.,-42.,-42.,-39.,-39.,-36.,-36.,-33., &
+                   -33.,-30.,-30.,-27.,-27.,-24.,-24.,-21.,-21.,-18., &
+                   -18.,-15.,-15.,-12.,-12., -9., -9., -6., -6., -3., &
+                    -3.,  0.,  0.,  3.,  3.,  6.,  6.,  9.,  9., 12., &
+., 15., 15., 18., 18., 21., 21., 24., 24.,100./),shape=(/2,40/))
     !--- MISR constants
     integer,parameter :: MISR_N_CTH = 16
 …
     !--- RTTOV constants
     integer,parameter :: RTTOV_MAX_CHANNELS = 20
     ! ISCCP tau-Pc axes
     real,parameter,dimension(7) :: ISCCP_TAU = (/0.15, 0.80, 2.45, 6.5, 16.2, 41.5, 50000.0/)
+    real,parameter,dimension(7) :: ISCCP_TAU = (/0.15, 0.80, 2.45, 6.5, 16.2, 41.5, 100.0/)
     real,parameter,dimension(2,7) :: ISCCP_TAU_BNDS = reshape(source=(/0.0,0.3,0.3,1.30,1.30,3.6,3.6,9.4, &
 .4,23.0,23.0,60.0,60.0,100000.0/), shape=(/2,7/))
+!     real,parameter,dimension(7) :: ISCCP_PC = (/9000., 24500., 37500., 50000., 62000., 74000., 90000./)
+!     real,parameter,dimension(2,7) :: ISCCP_PC_BNDS = reshape(source=(/0.0,18000.0,18000.0,31000.0,31000.0, &
+!                                44000.0,44000.0,56000.0,56000.0,68000.0,68000.0,80000.0,80000.0,100000.0/), shape=(/2,7/))
     real,parameter,dimension(7) :: ISCCP_PC = (/90000., 74000., 62000., 50000., 37500., 24500., 9000./)
     real,parameter,dimension(2,7) :: ISCCP_PC_BNDS = reshape(source=(/100000.0,80000.0,80000.0,68000.0,68000.0,56000.0 &
                                ,56000.0,44000.0,44000.0,31000.0,31000.0,18000.0,18000.0,0.0/), shape=(/2,7/))
     real,parameter,dimension(MISR_N_CTH) :: MISR_CTH = (/ 0., 0.25, 0.75, 1.25, 1.75, 2.25, 2.75, 3.5, &
+    real,parameter,dimension(MISR_N_CTH) :: MISR_CTH = 1000.0*(/ 0., 0.25, 0.75, 1.25, 1.75, 2.25, 2.75, 3.5, &
 .5, 6., 8., 10., 12., 14.5, 16., 18./)
     real,parameter,dimension(2,MISR_N_CTH) :: MISR_CTH_BNDS = reshape(source=(/ &
+    real,parameter,dimension(2,MISR_N_CTH) :: MISR_CTH_BNDS = 1000.0*reshape(source=(/ &
                                             -99.0,  0.0,       0.0,  0.5,       0.5,  1.0,      1.0,  1.5, &
 .5,  2.0,       2.0,  2.5,       2.5,  3.0,      3.0,  4.0, &
 …
 .0, 13.0,      13.0, 15.0,      15.0, 17.0,     17.0, 99.0/), &
                                              shape=(/2,MISR_N_CTH/))
+    !  Table hclass for quickbeam
+    !
+    ! The following code was modifed by Roj with implementation of quickbeam V3
+    !   (1) use ifdef to support more than one microphyscis scheme
+    !   (2) added constants  microphysic_scheme_name, LOAD_scale_LUTs, and SAVE_scale_LUTs
+    !
+    ! directory where LUTs will be stored
+    character*120 :: RADAR_SIM_LUT_DIRECTORY = './'
+#ifdef MMF_V3_SINGLE_MOMENT
+    !
+    !  Table hclass for quickbeam to support one-moment (bulk) microphysics scheme used by MMF V3.0 & V3.5
+    !
+    !
+    ! NOTE:  if ANY value in this section of code is changed, the existing LUT
+    !        (i.e., the associated *.dat file) MUST be deleted so that a NEW
+    !        LUT will be created !!!
+    !
+    character*120 :: RADAR_SIM_MICROPHYSICS_SCHEME_NAME = 'MMF_v3_single_moment'
+    logical :: RADAR_SIM_LOAD_scale_LUTs_flag   = .false.
+    logical :: RADAR_SIM_UPDATE_scale_LUTs_flag = .false.
     integer,parameter :: N_HYDRO = 9
+    real :: HCLASS_TYPE(N_HYDRO),HCLASS_COL(N_HYDRO),HCLASS_PHASE(N_HYDRO), &
+            HCLASS_CP(N_HYDRO),HCLASS_DMIN(N_HYDRO),HCLASS_DMAX(N_HYDRO)
+    real :: HCLASS_APM(N_HYDRO),HCLASS_BPM(N_HYDRO),HCLASS_RHO(N_HYDRO), &
+    integer :: HCLASS_TYPE(N_HYDRO),HCLASS_PHASE(N_HYDRO)
+    real :: HCLASS_DMIN(N_HYDRO),HCLASS_DMAX(N_HYDRO), &
+            HCLASS_APM(N_HYDRO),HCLASS_BPM(N_HYDRO),HCLASS_RHO(N_HYDRO), &
             HCLASS_P1(N_HYDRO),HCLASS_P2(N_HYDRO),HCLASS_P3(N_HYDRO)
+    data HCLASS_TYPE/5,1,2,2,5,1,2,2,2/
+    data HCLASS_COL/1,2,3,4,5,6,7,8,9/
+    data HCLASS_PHASE/0,1,0,1,0,1,0,1,1/
+    data HCLASS_CP/0,0,1,1,0,0,1,1,1/
+    data HCLASS_DMIN/-1,-1,-1,-1,-1,-1,-1,-1,-1/
+    data HCLASS_DMAX/-1,-1,-1,-1,-1,-1,-1,-1,-1/
+    data HCLASS_APM/524,110.8,524,-1,524,110.8,524,-1,-1/
+    data HCLASS_BPM/3,2.91,3,-1,3,2.91,3,-1,-1/
+    data HCLASS_RHO/-1,-1,-1,100,-1,-1,-1,100,400/
+    data HCLASS_P1/-1,-1,8000000.,3000000.,-1,-1,8000000.,3000000.,4000000./
+    data HCLASS_P2/6,40,-1,-1,6,40,-1,-1,-1/
+    data HCLASS_P3/0.3,2,-1,-1,0.3,2,-1,-1,-1/
+    ! HCLASS_CP is not used in the version of Quickbeam included in COSP
+    !                   LSL    LSI      LSR     LSS   CVL    CVI   CVR     CVS   LSG
+    data HCLASS_TYPE/    5,      1,      2,      2,     5,     1,   2,      2,    2/
+    data HCLASS_PHASE/   0,      1,      0,      1,     0,     1,   0,      1,    1/
+    data HCLASS_DMIN/   -1,     -1,     -1,     -1,    -1,    -1,   -1,    -1,   -1/
+    data HCLASS_DMAX/   -1,     -1,     -1,     -1,    -1,    -1,   -1,    -1,   -1/
+    data HCLASS_APM/   524,  110.8,    524,     -1,   524, 110.8,  524,    -1,   -1/
+    data HCLASS_BPM/     3,   2.91,      3,     -1,     3,  2.91,    3,    -1,   -1/
+    data HCLASS_RHO/    -1,     -1,     -1,    100,    -1,    -1,   -1,   100,  400/
+    data HCLASS_P1/     -1,     -1,   8.e6,   3.e6,    -1,    -1, 8.e6,  3.e6, 4.e6/
+    data HCLASS_P2/      6,     40,     -1,      -1,    6,    40,   -1,    -1,   -1/
+    data HCLASS_P3/    0.3,      2,     -1,      -1,  0.3,     2,   -1,    -1,   -1/
+    ! NOTES on HCLASS variables
+    !
+    ! TYPE - Set to
+    ! 1 for modified gamma distribution,
+    ! 2 for exponential distribution,
+    ! 3 for power law distribution,
+    ! 4 for monodisperse distribution,
+    ! 5 for lognormal distribution.
+    ! PHASE - Set to 0 for liquid, 1 for ice.
+    ! DMIN - The minimum drop size for this class (micron), ignored for monodisperse.
+    ! DMAX - The maximum drop size for this class (micron), ignored for monodisperse.
+    ! Important note: The settings for DMIN and DMAX are
+    ! ignored in the current version for all distributions except for power
+    ! law. Except when the power law distribution is used, particle size
+    ! is fixed to vary from zero to infinity, a restriction that is expected
+    ! to be lifted in future versions. A placeholder must still be specified
+    ! for each.
+    ! Density of particles is given by apm*D^bpm or a fixed value rho. ONLY specify ONE of these two!!
+    ! APM - The alpha_m coefficient in equation (1) (kg m**-beta_m )
+    ! BPM - The beta_m coefficient in equation (1), see section 4.1.
+    ! RHO - Hydrometeor density (kg m-3 ).
+    ! P1, P2, P3 - are default distribution parameters that depend on the type
+    ! of distribution (see quickmbeam documentation for more information)
+    !
+    ! Modified Gamma (must set P3 and one of P1 or P2)
+    ! P1 - Set to the total particle number concentration Nt /rho_a (kg-1 ), where
+    ! rho_a is the density of air in the radar volume.
+    ! P2 - Set to the particle mean diameter D (micron).
+    ! P3 - Set to the distribution width nu.
+    !
+    ! Exponetial (set one of)
+    ! P1 - Set to a constant intercept parameter N0 (m-4).
+    ! P2 - Set to a constant lambda (micron-1).
+    !
+    ! Power Law
+    ! P1 - Set this to the value of a constant power law parameter br
+    !
+    ! Monodisperse
+    ! P1 - Set to a constant diameter D0 (micron) = Re.
+    !
+    ! Log-normal (must set P3 and one of P1 or P2)
+    ! P1 - Set to the total particle number concentration Nt /rho_a (kg-1 )
+    ! P2 - Set to the geometric mean particle radius rg (micron).
+    ! P3 - Set to the natural logarithm of the geometric standard deviation.
+    !
+    real,dimension(N_HYDRO) :: N_ax,N_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma_1,gamma_2,gamma_3,gamma_4
+    ! Microphysical settings for the precipitation flux to mixing ratio conversion
+    !                LSL    LSI       LSR       LSS   CVL    CVI       CVR       CVS      LSG
+    data N_ax/       -1.,   -1.,     8.e6,     3.e6,  -1.,   -1.,     8.e6,     3.e6,     4.e6/
+    data N_bx/       -1.,   -1.,      0.0,      0.0,  -1.,   -1.,      0.0,      0.0,      0.0/
+    data alpha_x/    -1.,   -1.,      0.0,      0.0,  -1.,   -1.,      0.0,      0.0,      0.0/
+    data c_x/        -1.,   -1.,    842.0,     4.84,  -1.,   -1.,    842.0,     4.84,     94.5/
+    data d_x/        -1.,   -1.,      0.8,     0.25,  -1.,   -1.,      0.8,     0.25,      0.5/
+    data g_x/        -1.,   -1.,      0.5,      0.5,  -1.,   -1.,      0.5,      0.5,      0.5/
+    data a_x/        -1.,   -1.,    524.0,    52.36,  -1.,   -1.,    524.0,    52.36,   209.44/
+    data b_x/        -1.,   -1.,      3.0,      3.0,  -1.,   -1.,      3.0,      3.0,      3.0/
+    data gamma_1/    -1.,   -1., 17.83725, 8.284701,  -1.,   -1., 17.83725, 8.284701, 11.63230/
+    data gamma_2/    -1.,   -1.,      6.0,      6.0,  -1.,   -1.,      6.0,      6.0,      6.0/
+    data gamma_3/    -1.,   -1.,      2.0,      2.0,  -1.,   -1.,      2.0,      2.0,      2.0/
+    data gamma_4/    -1.,   -1.,      6.0,      6.0,  -1.,   -1.,      6.0,      6.0,      6.0/
+#endif
+#ifdef MMF_V3p5_TWO_MOMENT
+    !
+    !  Table hclass for quickbeam to support two-moment "morrison" microphysics scheme used by V3.5 (SAM 6.8)
+    !
+    !  This Number concentriation Np in [1/kg] MUST be input to COSP/radar simulator
+    !
+    !  NOTE:  Be sure to check that the ice-density (rho) set it this tables matches what you used
+    !
+    !
+    ! NOTE:  if ANY value in this section of code is changed, the existing LUT
+    !        (i.e., the associated *.dat file) MUST be deleted so that a NEW
+    !        LUT will be created !!!
+    !
+    character*120 :: RADAR_SIM_MICROPHYSICS_SCHEME_NAME = 'MMF_v3.5_two_moment'
+    logical :: RADAR_SIM_LOAD_scale_LUTs_flag   = .false.
+    logical :: RADAR_SIM_UPDATE_scale_LUTs_flag = .false.
+    integer,parameter :: N_HYDRO = 9
+    integer :: HCLASS_TYPE(N_HYDRO),HCLASS_PHASE(N_HYDRO)
+    real :: HCLASS_DMIN(N_HYDRO),HCLASS_DMAX(N_HYDRO), &
+            HCLASS_APM(N_HYDRO),HCLASS_BPM(N_HYDRO),HCLASS_RHO(N_HYDRO), &
+            HCLASS_P1(N_HYDRO),HCLASS_P2(N_HYDRO),HCLASS_P3(N_HYDRO)
+    ! HCLASS_CP is not used in the version of Quickbeam included in COSP
+    !                   LSL    LSI      LSR     LSS   CVL    CVI   CVR     CVS   LSG
+    data HCLASS_TYPE/    1,      1,      1,      1,     1,     1,    1,      1,    1/
+    data HCLASS_PHASE/   0,      1,      0,      1,     0,     1,    0,      1,    1/
+    data HCLASS_DMIN/   -1,     -1,     -1,     -1,    -1,    -1,   -1,     -1,   -1/
+    data HCLASS_DMAX/   -1,     -1,     -1,     -1,    -1,    -1,   -1,     -1,   -1/
+    data HCLASS_APM/   524,     -1,    524,     -1,   524,    -1,  524,     -1,   -1/
+    data HCLASS_BPM/     3,     -1,      3,     -1,     3,    -1,    3,     -1,   -1/
+    data HCLASS_RHO/    -1,    500,     -1,    100,    -1,   500,   -1,    100,  900/
+    data HCLASS_P1/     -1,     -1,     -1,     -1,    -1,    -1,   -1,     -1,   -1/
+    data HCLASS_P2/     -1,     -1,     -1,     -1,    -1,    -1,   -1,     -1,   -1/
+    data HCLASS_P3/     -2,      1,      1,      1,    -2,     1,    1,      1,    1/
+    ! Note: value of "-2" for HCLASS_P3 uses martin 1994 parameteriztion of gamma function width with Number concentration
+#endif
 END MODULE MOD_COSP_CONSTANTS

LMDZ5/trunk/libf/phylmd/cosp/cosp_isccp_simulator.F90

-                      r1907
+                      r2428
 ! (c) British Crown Copyright 2008, the Met Office.
 ! All rights reserved.
+! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_isccp_simulator.F90 $
+!
 ! Redistribution and use in source and binary forms, with or without modification, are permitted
 …
   ! Local variables
   integer :: i,Nlevels,Npoints
+  integer :: Nlevels,Npoints
   real :: pfull(gbx%Npoints, gbx%Nlevels)
   real :: phalf(gbx%Npoints, gbx%Nlevels + 1)
 …
   y%fq_isccp(:,:,:) = y%fq_isccp(:,:,7:1:-1)
+  ! Change boxptop from hPa to Pa. This avoids using UDUNITS in CMOR
+!  y%boxptop = y%boxptop*100.0
   ! Check if there is any value slightly greater than 1
   where ((y%totalcldarea > 1.0-1.e-5) .and. (y%totalcldarea < 1.0+1.e-5))

LMDZ5/trunk/libf/phylmd/cosp/cosp_lidar.F90

-                      r1907
+                      r2428
 ! (c) British Crown Copyright 2008, the Met Office.
 ! All rights reserved.
+! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_lidar.F90 $
+!
 ! Redistribution and use in source and binary forms, with or without modification, are permitted
 …
 !                               Call lidar_simulator changed (lsca, gbx%cca and depol removed;
 !                               frac_out changed in sgx%frac_out)
+! Jun 2011 - G. Cesana        - Added betaperp_tot argument
+!
+!
 …
 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 SUBROUTINE COSP_LIDAR(gbx,sgx,sghydro,y)
   ! Arguments
   type(cosp_gridbox),intent(in) :: gbx  ! Gridbox info
 …
   type(cosp_sghydro),intent(in) :: sghydro  ! Subgrid info for hydrometeors
   type(cosp_sglidar),intent(inout) :: y ! Subgrid output
   ! Local variables
   integer :: i
   real :: presf(sgx%Npoints, sgx%Nlevels + 1)
-  real :: frac_out(sgx%Npoints, sgx%Nlevels)
   real,dimension(sgx%Npoints, sgx%Nlevels) :: lsca,mr_ll,mr_li,mr_cl,mr_ci
   real,dimension(sgx%Npoints, sgx%Nlevels) :: beta_tot,tau_tot
+  real,dimension(sgx%Npoints, sgx%Nlevels) :: betaperp_tot
   real,dimension(sgx%Npoints, PARASOL_NREFL)  :: refle
   presf(:,1:sgx%Nlevels) = gbx%ph
   presf(:,sgx%Nlevels + 1) = 0.0
-!   presf(:,sgx%Nlevels + 1) = gbx%p(:,sgx%Nlevels) - (presf(:,sgx%Nlevels) - gbx%p(:,sgx%Nlevels))
   lsca = gbx%tca-gbx%cca
   do i=1,sgx%Ncolumns
 …
       mr_cl(:,:) = sghydro%mr_hydro(:,i,:,I_CVCLIQ)
       mr_ci(:,:) = sghydro%mr_hydro(:,i,:,I_CVCICE)
+      frac_out(:,:) = sgx%frac_out(:,i,:)
+      call lidar_simulator(sgx%Npoints, sgx%Nlevels, 4 &
+                 , PARASOL_NREFL, LIDAR_UNDEF  &
+                 , gbx%p, presf, gbx%T &
+                 , mr_ll, mr_li, mr_cl, mr_ci &
+                 , gbx%Reff(:,:,I_LSCLIQ), gbx%Reff(:,:,I_LSCICE), gbx%Reff(:,:,I_CVCLIQ), gbx%Reff(:,:,I_CVCICE) &
+                 , frac_out, gbx%lidar_ice_type, y%beta_mol, beta_tot, tau_tot  &
+                 , refle ) ! reflectance
+      call lidar_simulator(sgx%Npoints, sgx%Nlevels, 4, PARASOL_NREFL, LIDAR_UNDEF  &
+                 , gbx%p, presf, gbx%T, mr_ll, mr_li, mr_cl, mr_ci &
+                 , gbx%Reff(:,:,I_LSCLIQ), gbx%Reff(:,:,I_LSCICE) &
+                 , gbx%Reff(:,:,I_CVCLIQ), gbx%Reff(:,:,I_CVCICE) &
+                 , gbx%lidar_ice_type, y%beta_mol, beta_tot &
+                 , betaperp_tot, tau_tot, refle )
+      y%betaperp_tot(:,i,:) = betaperp_tot(:,:)
       y%beta_tot(:,i,:) = beta_tot(:,:)
       y%tau_tot(:,i,:)  = tau_tot(:,:)

LMDZ5/trunk/libf/phylmd/cosp/cosp_misr_simulator.F90

-                      r1907
+                      r2428
 ! (c) British Crown Copyright 2008, the Met Office.
 ! All rights reserved.
+! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_misr_simulator.F90 $
+!
 ! Redistribution and use in source and binary forms, with or without modification, are permitted
 …
   ! Local variables
   integer :: i,Nlevels,Npoints
+  integer :: Nlevels,Npoints
   real :: dtau_s(gbx%Npoints, gbx%Nlevels)
   real :: dtau_c(gbx%Npoints, gbx%Nlevels)
 …
                                           !  zfull(npoints,1)    is    top level of model
                                           !  zfull(npoints,nlev) is bottom level of model
-  real :: phy_t0p1_mean_ztop              ! mean cloud top height(m) of 0.1 tau treshold
-  real :: fq_phy_t0p1_TAU_v_CTH(7,16)
   Nlevels = gbx%Nlevels
   Npoints = gbx%Npoints
 …
   call MISR_simulator(gbx%npoints,gbx%nlevels,gbx%ncolumns,&
                      sunlit,zfull,at,dtau_s,dtau_c,frac_out, &
+                     sunlit,zfull,at,dtau_s,dtau_c,frac_out, R_UNDEF, &
                      y%fq_MISR,y%MISR_dist_model_layertops,y%MISR_meanztop,y%MISR_cldarea)

LMDZ5/trunk/libf/phylmd/cosp/cosp_output_mod.F90

-                      r2367
+                      r2428
   USE MOD_COSP_CONSTANTS
   USE MOD_COSP_TYPES
+  use MOD_COSP_Modis_Simulator, only : cosp_modis
 ! cosp_output_mod
 …
       INTEGER, DIMENSION(3), SAVE  :: cosp_nidfiles
 !$OMP THREADPRIVATE(cosp_outfilekeys, cosp_nidfiles)
       INTEGER, DIMENSION(3), SAVE  :: nhoricosp, nvert, nvertmcosp, nvertcol, nvertisccp, nvertp
+      INTEGER, DIMENSION(3), SAVE  :: nhoricosp,nvert,nvertmcosp,nvertcol,nvertisccp,nvertp,nverttemp,nvertmisr
       REAL, DIMENSION(3), SAVE                :: zoutm_cosp
 !$OMP THREADPRIVATE(nhoricosp, nvert, nvertmcosp, nvertcol, nvertisccp, nvertp, zoutm_cosp)
+!$OMP THREADPRIVATE(nhoricosp, nvert, nvertmcosp, nvertcol, nvertisccp, nvertp, zoutm_cosp, nverttemp, nvertmisr)
       REAL, SAVE                   :: zdtimemoy_cosp
 !$OMP THREADPRIVATE(zdtimemoy_cosp)
 …
      CHARACTER(len=20),DIMENSION(3)  :: cosp_typeecrit        !!! Operation (ave, inst, ...)
   END TYPE ctrl_outcosp
 ! CALIPSO vars
   TYPE(ctrl_outcosp), SAVE :: o_cllcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
          "cllcalipso", "Lidar Low-level Cloud Fraction", "1", (/ ('', i=1, 3) /))
+         "cllcalipso", "Lidar Low-level Cloud Fraction", "%", (/ ('', i=1, 3) /))
   TYPE(ctrl_outcosp), SAVE :: o_clmcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
          "clmcalipso", "Lidar Mid-level Cloud Fraction", "1", (/ ('', i=1, 3) /))
+         "clmcalipso", "Lidar Mid-level Cloud Fraction", "%", (/ ('', i=1, 3) /))
   TYPE(ctrl_outcosp), SAVE :: o_clhcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
          "clhcalipso", "Lidar Hight-level Cloud Fraction", "1", (/ ('', i=1, 3) /))
+         "clhcalipso", "Lidar Hight-level Cloud Fraction", "%", (/ ('', i=1, 3) /))
   TYPE(ctrl_outcosp), SAVE :: o_cltcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
          "cltcalipso", "Lidar Total Cloud Fraction", "1", (/ ('', i=1, 3) /))
+         "cltcalipso", "Lidar Total Cloud Fraction", "%", (/ ('', i=1, 3) /))
   TYPE(ctrl_outcosp), SAVE :: o_clcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
          "clcalipso", "Lidar Cloud Fraction (532 nm)", "1", (/ ('', i=1, 3) /))
+         "clcalipso", "Lidar Cloud Fraction (532 nm)", "%", (/ ('', i=1, 3) /))
   TYPE(ctrl_outcosp), SAVE :: o_cfad_lidarsr532 = ctrl_outcosp((/ .FALSE., .FALSE., .FALSE. /), &
          "cfad_lidarsr532", "Lidar Scattering Ratio CFAD (532 nm)", "1", (/ ('', i=1, 3) /))
 …
   TYPE(ctrl_outcosp), SAVE :: o_beta_mol532 = ctrl_outcosp((/ .FALSE., .FALSE., .FALSE. /), &
          "beta_mol532", "Lidar Molecular Backscatter (532 nm)","m-1 sr-1", (/ ('', i=1, 3) /))
+!! AI  11 2015
+  TYPE(ctrl_outcosp), SAVE :: o_cllcalipsoice = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "cllcalipsoice", "CALIPSO Ice-Phase Low Level Cloud Fraction", "%", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_cllcalipsoliq = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "cllcalipsoliq", "CALIPSO Liq-Phase Low Level Cloud Fraction", "%", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_clmcalipsoice = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clmcalipsoice", "CALIPSO Ice-Phase Mid Level Cloud Fraction", "%", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_clmcalipsoliq = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clmcalipsoliq", "CALIPSO Liq-Phase Mid Level Cloud Fraction", "%", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_clhcalipsoice = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clhcalipsoice", "CALIPSO Ice-Phase High Level Cloud Fraction", "%", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_clhcalipsoliq = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clhcalipsoliq", "CALIPSO Liq-Phase High Level Cloud Fraction", "%", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_cltcalipsoice = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "cltcalipsoice", "CALIPSO Ice-Phase Tot Level Cloud Fraction", "%", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_cltcalipsoliq = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "cltcalipsoliq", "CALIPSO Liq-Phase Tot Level Cloud Fraction", "%", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_cllcalipsoun = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "cllcalipsoun", "CALIPSO Undefined-Phase Low Level Cloud Fraction", "%", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_clmcalipsoun = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clmcalipsoun", "CALIPSO Undefined-Phase Mid Level Cloud Fraction", "%", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_clhcalipsoun = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clhcalipsoun", "CALIPSO Undefined-Phase High Level Cloud Fraction", "%", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_cltcalipsoun = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "cltcalipsoun", "CALIPSO Undefined-Phase Tot Level Cloud Fraction", "%", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_clcalipsoice = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clcalipsoice", "Lidar Ice-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_clcalipsoliq = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clcalipsoliq", "Lidar Liq-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_clcalipsoun = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clcalipsoun", "Lidar Undef-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_clcalipsotmpice = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clcalipsotmpice", "Lidar Ice-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_clcalipsotmpliq = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clcalipsotmpliq", "Lidar Liq-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_clcalipsotmpun = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clcalipsotmpun", "Lidar Undef-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_clcalipsotmp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clcalipsotmp", "Lidar Cloud Fraction", "%", (/ ('', i=1, 3) /))
+! Radar Cloudsat
+  TYPE(ctrl_outcosp), SAVE :: o_cfadDbze94 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "cfadDbze94", "CloudSat Radar Reflectivity CFAD", "%", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_dbze94 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "dbze94", "CloudSat Radar Reflectivity", "%", (/ ('', i=1, 3) /))
+! Calipso + Cloudsat
+  TYPE(ctrl_outcosp), SAVE :: o_clcalipso2 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clcalipso2", "CALIPSO Cloud Fraction Undetected by CloudSat", "1", (/ ('', i=1, 3) /))
 ! ISCCP vars
   TYPE(ctrl_outcosp), SAVE :: o_sunlit = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
 …
            by the ISCCP Simulator","K", (/ ('', i=1, 3) /))
+! MISR simulator
+  TYPE(ctrl_outcosp), SAVE :: o_clMISR = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clMISR", "Cloud Fraction as Calculated by the MISR Simulator","1", (/ ('', i=1, 3) /))
+! MODIS simulator
+  TYPE(ctrl_outcosp), SAVE :: o_cllmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "cllmodis", "MODIS Low-level Cloud Fraction", "1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_clmmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clmmodis", "MODIS Mid-level Cloud Fraction", "1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_clhmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clhmodis", "MODIS Hight-level Cloud Fraction", "1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_cltmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "cltmodis", "MODIS Total Cloud Fraction", "1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_clwmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clwmodis", "MODIS Cloud Fraction water mean", "1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_climodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "climodis", "MODIS Cloud Fraction ice mean", "1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_tautmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "tautmodis", "MODIS Optical_Thickness_Total_Mean", "1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_tauwmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "tauwmodis", "MODIS Optical_Thickness_Water_Mean", "1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_tauimodis= ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "tauimodis", "MODIS Optical_Thickness_Ice_Mean", "1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_tautlogmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "tautlogmodis", "MODIS Optical_Thickness_Total_logMean", "1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_tauwlogmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "tauwlogmodis", "MODIS Optical_Thickness_Water_logMean", "1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_tauilogmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "tauilogmodis", "MODIS Optical_Thickness_Ice_logMean", "1", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_reffclwmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "reffclwmodis", "Modis Cloud_Particle_Size_Water_Mean", "m", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_reffclimodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "reffclimodis", "Modis Cloud_Particle_Size_Ice_Mean", "m", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_pctmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "pctmodis", "Modis Cloud_Top_Pressure_Total_Mean", "Pa", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_lwpmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "lwpmodis", "Modis Liquid_Water_Path_Mean", "kg m-2", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_iwpmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "iwpmodis", "Modis Ice_Water_Path_Mean", "kg m-2", (/ ('', i=1, 3) /))
+  TYPE(ctrl_outcosp), SAVE :: o_clmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "clmodis", "MODIS Cloud Area Fraction", "%", (/ ('', i=1, 3) /))
+! Rttovs simulator
+  TYPE(ctrl_outcosp), SAVE :: o_tbrttov = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "tbrttov", "Rttovs Cloud Area Fraction", "%", (/ ('', i=1, 3) /))
+! Scops and others
+  TYPE(ctrl_outcosp), SAVE :: o_fracout = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), &
+         "fracout", "Subcolumn output from SCOPS", "%", (/ ('', i=1, 3) /))
   LOGICAL, SAVE :: cosp_varsdefined = .FALSE. ! ug PAS THREADPRIVATE ET C'EST NORMAL
   REAL, SAVE  :: Cosp_fill_value
 …
           Cosp_fill_value=0.
          print*,'Cosp_fill_value=',Cosp_fill_value
-    ! ug R\'eglage du calendrier xios
-    !Temps julian => an, mois, jour, heure
-!    CALL ju2ymds(zjulian, x_an, x_mois, x_jour, x_heure)
-!    CALL ju2ymds(zjulian_start, ini_an, ini_mois, ini_jour, ini_heure)
-!    CALL wxios_set_cal(dtime, calend, x_an, x_mois, x_jour, x_heure, ini_an, &
-!                       ini_mois, ini_jour, ini_heure )
-       ! ug dï¿½claration des axes verticaux de chaque fichier:
 !    if (use_vgrid) then
+!      print*,'vgrid%Nlvgrid, vgrid%z = ',vgrid%Nlvgrid, vgrid%z
         CALL wxios_add_vaxis("height", vgrid%Nlvgrid, vgrid%z)
+     print*,'wxios_add_vaxis '
 !    else
 !         WRITE(lunout,*) 'wxios_add_vaxis "presnivs", vgrid%Nlvgrid ',vgrid%Nlvgrid
 …
     WRITE(lunout,*) 'wxios_add_vaxis column ',Ncolumns
     CALL wxios_add_vaxis("column", Ncolumns, column_ax)
+! AI nov 2015
+   CALL wxios_add_vaxis("temp", LIDAR_NTEMP, LIDAR_PHASE_TEMP)
+   CALL wxios_add_vaxis("cth16", MISR_N_CTH, MISR_CTH)
 #endif
 …
            CALL histbeg_phy_all(cosp_outfilenames(iff),itau_phy,zjulian,&
              dtime,nhoricosp(iff),cosp_nidfiles(iff))
            print*,'histbeg_phy nhoricosp(iff),cosp_nidfiles(iff)', &
                     nhoricosp(iff),cosp_nidfiles(iff)
+!           print*,'histbeg_phy nhoricosp(iff),cosp_nidfiles(iff)', &
+!                    nhoricosp(iff),cosp_nidfiles(iff)
 #ifdef CPP_XIOS
 …
       CALL histvert(cosp_nidfiles(iff),"column","column","count",Ncolumns,column_ax(1:Ncolumns),nvertcol(iff))
+      CALL histvert(cosp_nidfiles(iff),"temp","temperature","C",LIDAR_NTEMP,LIDAR_PHASE_TEMP,nverttemp(iff))
+      CALL histvert(cosp_nidfiles(iff),"cth16","altitude","m",MISR_N_CTH,MISR_CTH,nvertmisr(iff))
 !!! Valeur indefinie en cas IOIPSL
      Cosp_fill_value=0.

LMDZ5/trunk/libf/phylmd/cosp/cosp_output_write_mod.F90

-                      r2345
+                      r2428
   SUBROUTINE cosp_output_write(Nlevlmdz, Npoints, Ncolumns, itap, dtime, freq_COSP, &
+                               cfg, gbx, vgrid, sglidar, stlidar, isccp)
+                               cfg, gbx, vgrid, sglidar, sgradar, stlidar, stradar, &
+                               isccp, misr, modis)
     USE ioipsl
 …
   type(cosp_gridbox)    :: gbx     ! Gridbox information. Input for COSP
   type(cosp_sglidar)    :: sglidar ! Output from lidar simulator
+  type(cosp_sgradar)    :: sgradar ! Output from radar simulator
   type(cosp_isccp)      :: isccp   ! Output from ISCCP simulator
   type(cosp_lidarstats) :: stlidar ! Summary statistics from lidar simulator
+  type(cosp_radarstats) :: stradar
+  type(cosp_misr)       :: misr    ! Output from MISR
+  type(cosp_modis)      :: modis   ! Outputs from Modis
   type(cosp_vgrid)      :: vgrid   ! Information on vertical grid of stats
 …
    enddo
+! AI 11 / 2015
+   where(stlidar%parasolrefl == R_UNDEF) stlidar%parasolrefl = 0.0
+   where(stlidar%lidarcldtmp == R_UNDEF) stlidar%lidarcldtmp = 0.0
+   where(stlidar%cldlayerphase == R_UNDEF) stlidar%cldlayerphase = 0.0
+   where(stlidar%lidarcldphase == R_UNDEF) stlidar%lidarcldphase = 0.0
+   where(stlidar%lidarcldtmp == R_UNDEF) stlidar%lidarcldtmp = 0.0
    print*,'Appel histwrite2d_cosp'
    CALL histwrite2d_cosp(o_cllcalipso,stlidar%cldlayer(:,1))
 …
    CALL histwrite2d_cosp(o_cltcalipso,stlidar%cldlayer(:,4))
    CALL histwrite3d_cosp(o_clcalipso,stlidar%lidarcld,nvert)
+   CALL histwrite3d_cosp(o_clcalipsotmp,stlidar%lidarcldtmp(:,:,1),nverttemp)
+   CALL histwrite2d_cosp(o_cllcalipsoice,stlidar%cldlayerphase(:,1,1))
+   CALL histwrite2d_cosp(o_clhcalipsoice,stlidar%cldlayerphase(:,3,1))
+   CALL histwrite2d_cosp(o_clmcalipsoice,stlidar%cldlayerphase(:,2,1))
+   CALL histwrite2d_cosp(o_cltcalipsoice,stlidar%cldlayerphase(:,4,1))
+   CALL histwrite3d_cosp(o_clcalipsoice,stlidar%lidarcldphase(:,:,1),nvert)
+   CALL histwrite3d_cosp(o_clcalipsotmpice,stlidar%lidarcldtmp(:,:,2),nverttemp)
+   CALL histwrite2d_cosp(o_cllcalipsoliq,stlidar%cldlayerphase(:,1,2))
+   CALL histwrite2d_cosp(o_clhcalipsoliq,stlidar%cldlayerphase(:,3,2))
+   CALL histwrite2d_cosp(o_clmcalipsoliq,stlidar%cldlayerphase(:,2,2))
+   CALL histwrite2d_cosp(o_cltcalipsoliq,stlidar%cldlayerphase(:,4,2))
+   CALL histwrite3d_cosp(o_clcalipsoliq,stlidar%lidarcldphase(:,:,2),nvert)
+   CALL histwrite3d_cosp(o_clcalipsotmpliq,stlidar%lidarcldtmp(:,:,3),nverttemp)
+   CALL histwrite2d_cosp(o_cllcalipsoun,stlidar%cldlayerphase(:,1,3))
+   CALL histwrite2d_cosp(o_clhcalipsoun,stlidar%cldlayerphase(:,3,3))
+   CALL histwrite2d_cosp(o_clmcalipsoun,stlidar%cldlayerphase(:,2,3))
+   CALL histwrite2d_cosp(o_cltcalipsoun,stlidar%cldlayerphase(:,4,3))
+   CALL histwrite3d_cosp(o_clcalipsoice,stlidar%lidarcldphase(:,:,3),nvert)
+   CALL histwrite3d_cosp(o_clcalipsotmpun,stlidar%lidarcldtmp(:,:,4),nverttemp)
    do icl=1,SR_BINS
 …
  endif !Lidar
+ if (cfg%Lradar_sim) then
+   do icl=1,Ncolumns
+      CALL histwrite3d_cosp(o_dbze94,sgradar%Ze_tot(:,icl,:),nvertmcosp,icl)
+   enddo
+   do icl=1,DBZE_BINS
+    CALL histwrite3d_cosp(o_cfadDbze94,stradar%cfad_ze(:,icl,:),nvert,icl)
+   enddo
+ endif
+ if (cfg%Llidar_sim .and. cfg%Lradar_sim) then
+   where(stradar%lidar_only_freq_cloud == R_UNDEF) &
+                           stradar%lidar_only_freq_cloud = 0.0
+   CALL histwrite3d_cosp(o_clcalipso2,stradar%lidar_only_freq_cloud,nvert)
+ endif
  if (cfg%Lisccp_sim) then
 ! Traitement des valeurs indefinies
    do ip = 1,Npoints
     if(isccp%totalcldarea(ip).eq.-1.E+30)then
+    if(isccp%totalcldarea(ip).eq.R_UNDEF)then
       isccp%totalcldarea(ip)=Cosp_fill_value
     endif
     if(isccp%meanptop(ip).eq.-1.E+30)then
+    if(isccp%meanptop(ip).eq.R_UNDEF)then
       isccp%meanptop(ip)=Cosp_fill_value
     endif
     if(isccp%meantaucld(ip).eq.-1.E+30)then
+    if(isccp%meantaucld(ip).eq.R_UNDEF)then
       isccp%meantaucld(ip)=Cosp_fill_value
     endif
     if(isccp%meanalbedocld(ip).eq.-1.E+30)then
+    if(isccp%meanalbedocld(ip).eq.R_UNDEF)then
       isccp%meanalbedocld(ip)=Cosp_fill_value
     endif
     if(isccp%meantb(ip).eq.-1.E+30)then
+    if(isccp%meantb(ip).eq.R_UNDEF)then
       isccp%meantb(ip)=Cosp_fill_value
     endif
     if(isccp%meantbclr(ip).eq.-1.E+30)then
+    if(isccp%meantbclr(ip).eq.R_UNDEF)then
       isccp%meantbclr(ip)=Cosp_fill_value
     endif
 …
     do k=1,7
      do ii=1,7
      if(isccp%fq_isccp(ip,ii,k).eq.-1.E+30)then
+     if(isccp%fq_isccp(ip,ii,k).eq.R_UNDEF)then
       isccp%fq_isccp(ip,ii,k)=Cosp_fill_value
      endif
 …
     do ii=1,Ncolumns
      if(isccp%boxtau(ip,ii).eq.-1.E+30)then
+     if(isccp%boxtau(ip,ii).eq.R_UNDEF)then
        isccp%boxtau(ip,ii)=Cosp_fill_value
      endif
 …
     do ii=1,Ncolumns
      if(isccp%boxptop(ip,ii).eq.-1.E+30)then
+     if(isccp%boxptop(ip,ii).eq.R_UNDEF)then
        isccp%boxptop(ip,ii)=Cosp_fill_value
      endif
 …
    CALL histwrite2d_cosp(o_meantbclrisccp,isccp%meantbclr)
  endif ! Isccp
+! MISR simulator
+ if (cfg%Lmisr_sim) then
+   do ip=1,Npoints
+     do ii=1,7
+       do k=1,MISR_N_CTH
+        if(misr%fq_MISR(ip,ii,k).eq.R_UNDEF)then
+              misr%fq_MISR(ip,ii,k)=Cosp_fill_value
+        endif
+       enddo
+     enddo
+   enddo
+   do icl=1,7
+      CALL histwrite3d_cosp(o_clMISR,misr%fq_MISR(:,icl,:),nvertmisr,icl)
+   enddo
+ endif
+! Modis simulator
+ if (cfg%Lmodis_sim) then
+  do ip=1,Npoints
+    if(modis%Cloud_Fraction_Low_Mean(ip).eq.R_UNDEF)then
+       modis%Cloud_Fraction_Low_Mean(ip)=Cosp_fill_value
+    endif
+    if(modis%Cloud_Fraction_High_Mean(ip).eq.R_UNDEF)then
+       modis%Cloud_Fraction_High_Mean(ip)=Cosp_fill_value
+    endif
+    if(modis%Cloud_Fraction_Mid_Mean(ip).eq.R_UNDEF)then
+       modis%Cloud_Fraction_Mid_Mean(ip)=Cosp_fill_value
+    endif
+    if(modis%Cloud_Fraction_Total_Mean(ip).eq.R_UNDEF)then
+       modis%Cloud_Fraction_Total_Mean(ip)=Cosp_fill_value
+    endif
+    if(modis%Cloud_Fraction_Water_Mean(ip).eq.R_UNDEF)then
+       modis%Cloud_Fraction_Water_Mean(ip)=Cosp_fill_value
+    endif
+    if(modis%Cloud_Fraction_Ice_Mean(ip).eq.R_UNDEF)then
+       modis%Cloud_Fraction_Ice_Mean(ip)=Cosp_fill_value
+    endif
+    if(modis%Optical_Thickness_Total_Mean(ip).eq.R_UNDEF)then
+       modis%Optical_Thickness_Total_Mean(ip)=Cosp_fill_value
+    endif
+    if(modis%Optical_Thickness_Water_Mean(ip).eq.R_UNDEF)then
+       modis%Optical_Thickness_Water_Mean(ip)=Cosp_fill_value
+    endif
+    if(modis%Optical_Thickness_Ice_Mean(ip).eq.R_UNDEF)then
+       modis%Optical_Thickness_Ice_Mean(ip)=Cosp_fill_value
+    endif
+    if(modis%Cloud_Particle_Size_Water_Mean(ip).eq.R_UNDEF)then
+       modis%Cloud_Particle_Size_Water_Mean(ip)=Cosp_fill_value
+    endif
+    if(modis%Cloud_Top_Pressure_Total_Mean(ip).eq.R_UNDEF)then
+       modis%Cloud_Top_Pressure_Total_Mean(ip)=Cosp_fill_value
+    endif
+    if(modis%Liquid_Water_Path_Mean(ip).eq.R_UNDEF)then
+       modis%Liquid_Water_Path_Mean(ip)=Cosp_fill_value
+    endif
+    if(modis%Ice_Water_Path_Mean(ip).eq.R_UNDEF)then
+       modis%Ice_Water_Path_Mean(ip)=Cosp_fill_value
+    endif
+  enddo
+   CALL histwrite2d_cosp(o_cllmodis,modis%Cloud_Fraction_Low_Mean)
+   CALL histwrite2d_cosp(o_clhmodis,modis%Cloud_Fraction_High_Mean)
+   CALL histwrite2d_cosp(o_clmmodis,modis%Cloud_Fraction_Mid_Mean)
+   CALL histwrite2d_cosp(o_cltmodis,modis%Cloud_Fraction_Total_Mean)
+   CALL histwrite2d_cosp(o_clwmodis,modis%Cloud_Fraction_Water_Mean)
+   CALL histwrite2d_cosp(o_climodis,modis%Cloud_Fraction_Ice_Mean)
+   CALL histwrite2d_cosp(o_tautmodis,modis%Optical_Thickness_Total_Mean)
+   CALL histwrite2d_cosp(o_tauwmodis,modis%Optical_Thickness_Water_Mean)
+   CALL histwrite2d_cosp(o_tauimodis,modis%Optical_Thickness_Ice_Mean)
+   CALL histwrite2d_cosp(o_tautlogmodis,modis%Optical_Thickness_Total_LogMean)
+   CALL histwrite2d_cosp(o_tauwlogmodis,modis%Optical_Thickness_Water_LogMean)
+   CALL histwrite2d_cosp(o_tauilogmodis,modis%Optical_Thickness_Ice_LogMean)
+   CALL histwrite2d_cosp(o_reffclwmodis,modis%Cloud_Particle_Size_Water_Mean)
+   CALL histwrite2d_cosp(o_reffclimodis,modis%Cloud_Particle_Size_Ice_Mean)
+   CALL histwrite2d_cosp(o_pctmodis,modis%Cloud_Top_Pressure_Total_Mean)
+   CALL histwrite2d_cosp(o_lwpmodis,modis%Liquid_Water_Path_Mean)
+   CALL histwrite2d_cosp(o_iwpmodis,modis%Ice_Water_Path_Mean)
+   do ip=1,Npoints
+     do ii=1,7
+       do k=1,7
+       if(modis%Optical_Thickness_vs_Cloud_Top_Pressure(ip,ii,k).eq.R_UNDEF)then
+          modis%Optical_Thickness_vs_Cloud_Top_Pressure(ip,ii,k)=0.
+        endif
+       enddo
+     enddo
+    enddo
+   do icl=1,7
+   CALL histwrite3d_cosp(o_clmodis, &
+     modis%Optical_Thickness_vs_Cloud_Top_Pressure(:,icl,:),nvertisccp,icl)
+   enddo
+ endif
  IF(.NOT.cosp_varsdefined) THEN
 …
           klevs=Ncolout
           nam_axvert="column"
+      ELSE IF (nvertsave.eq.nverttemp(iff)) THEN
+          klevs=LIDAR_NTEMP
+          nam_axvert="temp"
+      ELSE IF (nvertsave.eq.nvertmisr(iff)) THEN
+          klevs=MISR_N_CTH
+           nam_axvert="cth16"
       ELSE
            klevs=Nlevout
 …
 #ifdef CPP_XIOS
       IF (ok_all_xml) THEN
         if (prt_level >= 10) then
+        if (prt_level >= 1) then
               WRITE(lunout,*)'xios_send_field variable ',var%name
         endif
 …
     IF (ok_all_xml) THEN
      CALL xios_send_field(nom, Field3d(:,:,1:nlev))
      IF (prt_level >= 9) WRITE(lunout,*)'xios_send_field ',var%name
+     IF (prt_level >= 1) WRITE(lunout,*)'xios_send_field ',var%name
     ENDIF
 #endif

LMDZ5/trunk/libf/phylmd/cosp/cosp_radar.F90

-                      r1907
+                      r2428
   USE MOD_COSP_CONSTANTS
   USE MOD_COSP_TYPES
+  USE MOD_COSP_UTILS
   use radar_simulator_types
   use array_lib
 …
   use format_input
   IMPLICIT NONE
   INTERFACE
+    subroutine radar_simulator(freq,k2,do_ray,use_gas_abs,use_mie_table,mt, &
+        nhclass,hp,nprof,ngate,nsizes,D,hgt_matrix,hm_matrix,re_matrix,p_matrix,t_matrix, &
+        rh_matrix,Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe, &
+    subroutine radar_simulator(hp,nprof,ngate,undef, &
+        hgt_matrix,hm_matrix,re_matrix,Np_matrix, &
+        p_matrix,t_matrix,rh_matrix, &
+        Ze_non,Ze_ray,g_to_vol,a_to_vol,dBZe, &
         g_to_vol_in,g_to_vol_out)
         use m_mrgrnk
+        use m_mrgrnk
         use array_lib
         use math_lib
 …
         use radar_simulator_types
         implicit none
         ! ----- INPUTS -----
-        type(mie), intent(in) :: mt
         type(class_param) :: hp
+        real*8, intent(in) :: freq,k2
         integer, intent(in) ::  do_ray,use_gas_abs,use_mie_table, &
+            nhclass,nprof,ngate,nsizes
         real*8, dimension(nsizes), intent(in) :: D
+        integer, intent(in) :: nprof,ngate
+        real undef
         real*8, dimension(nprof,ngate), intent(in) :: hgt_matrix, p_matrix, &
             t_matrix,rh_matrix
+        real*8, dimension(nhclass,nprof,ngate), intent(in) :: hm_matrix
+        real*8, dimension(nhclass,nprof,ngate), intent(inout) :: re_matrix
+        real*8, dimension(hp%nhclass,nprof,ngate), intent(in) :: hm_matrix
+        real*8, dimension(hp%nhclass,nprof,ngate), intent(inout) :: re_matrix
+        real*8, dimension(hp%nhclass,nprof,ngate), intent(inout) :: Np_matrix
         ! ----- OUTPUTS -----
         real*8, dimension(nprof,ngate), intent(out) :: Ze_non,Ze_ray, &
             g_atten_to_vol,dBZe,h_atten_to_vol
+            g_to_vol,dBZe,a_to_vol
         ! ----- OPTIONAL -----
         real*8, optional, dimension(ngate,nprof) :: &
+        real*8, optional, dimension(nprof,ngate) :: &
             g_to_vol_in,g_to_vol_out
      end subroutine radar_simulator
 …
   ! Arguments
   type(cosp_gridbox),intent(in) :: gbx  ! Gridbox info
+  type(cosp_gridbox),intent(inout) :: gbx  ! Gridbox info
   type(cosp_subgrid),intent(in) :: sgx  ! Subgrid info
   type(cosp_sghydro),intent(in) :: sghydro  ! Subgrid info for hydrometeors
 …
   ! Local variables
   integer :: &
   nsizes                        ! num of discrete drop sizes
+  nsizes            ! num of discrete drop sizes
-  real*8 :: &
-  freq, &                       ! radar frequency (GHz)
-  k2                            ! |K|^2, -1=use frequency dependent default
   real*8, dimension(:,:), allocatable :: &
   g_to_vol ! integrated atten due to gases, r>v (dB)
   real*8, dimension(:,:), allocatable :: &
   Ze_non, &                     ! radar reflectivity withOUT attenuation (dBZ)
   Ze_ray, &                     ! Rayleigh reflectivity (dBZ)
   h_atten_to_vol, &             ! attenuation by hydromets, radar to vol (dB)
   g_atten_to_vol, &             ! gaseous atteunation, radar to vol (dB)
   dBZe, &                       ! effective radar reflectivity factor (dBZ)
   hgt_matrix, &                 ! height of hydrometeors (km)
+  Ze_non, &         ! radar reflectivity withOUT attenuation (dBZ)
+  Ze_ray, &         ! Rayleigh reflectivity (dBZ)
+  h_atten_to_vol, &     ! attenuation by hydromets, radar to vol (dB)
+  g_atten_to_vol, &     ! gaseous atteunation, radar to vol (dB)
+  dBZe, &           ! effective radar reflectivity factor (dBZ)
+  hgt_matrix, &         ! height of hydrometeors (km)
   t_matrix, &                   !temperature (k)
   p_matrix, &                   !pressure (hPa)
   rh_matrix                     !relative humidity (%)
   real*8, dimension(:,:,:), allocatable :: &
+  hm_matrix, &                  ! hydrometeor mixing ratio (g kg^-1)
+  re_matrix
+  hm_matrix, &          ! hydrometeor mixing ratio (g kg^-1)
+  re_matrix, &          ! effective radius (microns).   Optional. 0 ==> use Np_matrix or defaults
+  Np_matrix         ! total number concentration (kg^-1).   Optional 0==> use defaults
   integer, parameter :: one = 1
+  logical :: hgt_reversed
+  integer :: pr,i,j,k,unt
+  ! logical :: hgt_reversed
+  logical :: hgt_descending
+  integer :: pr,i,j,k,unt,ngate
 ! ----- main program settings ------
-  freq = gbx%radar_freq
-  k2 = gbx%k2
+  !
-  ! note:  intitialization section that was here has been relocated to SUBROUTINE CONSTRUCT_COSP_GRIDBOX by roj, Feb 2008
+  !
-  mt_ttl=gbx%mt_ttl  ! these variables really should be moved into the mt structure rather than kept as global arrays.
-  mt_tti=gbx%mt_tti
   ! Inputs to Quickbeam
   allocate(hgt_matrix(gbx%Npoints,gbx%Nlevels),p_matrix(gbx%Npoints,gbx%Nlevels), &
            t_matrix(gbx%Npoints,gbx%Nlevels),rh_matrix(gbx%Npoints,gbx%Nlevels))
   allocate(hm_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels))
+  allocate(hm_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels))
   allocate(re_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels))
+  allocate(Np_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels))
   ! Outputs from Quickbeam
 …
   allocate(g_atten_to_vol(gbx%Npoints,gbx%Nlevels))
   allocate(dBZe(gbx%Npoints,gbx%Nlevels))
   ! Optional argument. It is computed and returned in the first call to
   ! radar_simulator, and passed as input in the rest
+  allocate(g_to_vol(gbx%Nlevels,gbx%Npoints))
+  allocate(g_to_vol(gbx%Npoints,gbx%Nlevels))
+  ! Even if there is no unit conversion, they are needed for type conversion
   p_matrix   = gbx%p/100.0     ! From Pa to hPa
   hgt_matrix = gbx%zlev/1000.0 ! From m to km
   t_matrix   = gbx%T-273.15    ! From K to C
+  t_matrix   = gbx%T
   rh_matrix  = gbx%q
   re_matrix  = 0.0
+  ! Quickbeam assumes the first row is closest to the radar
+  call order_data(hgt_matrix,hm_matrix,p_matrix,t_matrix, &
+      rh_matrix,gbx%surface_radar,hgt_reversed)
+  ! set flag denoting position of radar relative to hgt_matrix orientation
+          ngate = size(hgt_matrix,2)
+          hgt_descending = hgt_matrix(1,1) > hgt_matrix(1,ngate)
+          if ( &
+             (gbx%surface_radar == 1 .and. hgt_descending) .or.  &
+             (gbx%surface_radar == 0 .and. (.not. hgt_descending)) &
+             ) &
+          then
+            gbx%hp%radar_at_layer_one = .false.
+          else
+            gbx%hp%radar_at_layer_one = .true.
+          endif
   ! ----- loop over subcolumns -----
   do pr=1,sgx%Ncolumns
+      !  NOTE:
       !  atmospheric profiles are the same within the same gridbox
+      !  only hydrometeor profiles will be different
+      if (hgt_reversed) then
+         do i=1,gbx%Nhydro
+            hm_matrix(i,:,:) = sghydro%mr_hydro(:,pr,gbx%Nlevels:1:-1,i)*1000.0 ! Units from kg/kg to g/kg
+            if (gbx%use_reff) then
+              re_matrix(i,:,:) = sghydro%Reff(:,pr,gbx%Nlevels:1:-1,i)*1.e6     ! Units from m to micron
+            endif
+         enddo
+      else
+      !  only hydrometeor profiles will be different for each subgridbox
          do i=1,gbx%Nhydro
             hm_matrix(i,:,:) = sghydro%mr_hydro(:,pr,:,i)*1000.0 ! Units from kg/kg to g/kg
             if (gbx%use_reff) then
               re_matrix(i,:,:) = sghydro%Reff(:,pr,:,i)*1.e6       ! Units from m to micron
+              Np_matrix(i,:,:) = sghydro%Np(:,pr,:,i)              ! Units [#/kg]
             endif
          enddo
-      endif
       !   ----- call radar simulator -----
       if (pr == 1) then ! Compute gaseous attenuation for all profiles
+         j=0
+         if (gbx%Npoints == 53) then
+           unt=10
+           j=1
+         endif
+         if (gbx%Npoints == 153) then
+           unt=11
+           j=101
+         endif
+         call radar_simulator(freq,k2,gbx%do_ray,gbx%use_gas_abs,gbx%use_mie_tables,gbx%mt, &    !  v0.2: mt changed to gbx%mt, roj
+           gbx%Nhydro,gbx%hp,gbx%Npoints,gbx%Nlevels,gbx%nsizes,gbx%D, &                         !  v0.2: hp->gbx%hp, D->gbx%d, nsizes->gbx%nsizes, roj
+           hgt_matrix,hm_matrix,re_matrix,p_matrix,t_matrix,rh_matrix, &
+         call radar_simulator(gbx%hp,gbx%Npoints,gbx%Nlevels,R_UNDEF, &
+           hgt_matrix,hm_matrix,re_matrix,Np_matrix, &
+           p_matrix,t_matrix,rh_matrix, &
            Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe,g_to_vol_out=g_to_vol)
       else ! Use gaseous atteunuation for pr = 1
          call radar_simulator(freq,k2,gbx%do_ray,gbx%use_gas_abs,gbx%use_mie_tables,gbx%mt, &
            gbx%Nhydro,gbx%hp,gbx%Npoints,gbx%Nlevels,gbx%nsizes,gbx%D, &
            hgt_matrix,hm_matrix,re_matrix,p_matrix,t_matrix,rh_matrix, &
+         call radar_simulator(gbx%hp,gbx%Npoints,gbx%Nlevels,R_UNDEF, &
+           hgt_matrix,hm_matrix,re_matrix,Np_matrix, &
+           p_matrix,t_matrix,rh_matrix, &
            Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe,g_to_vol_in=g_to_vol)
       endif
-      ! ----- BEGIN output section -----
-      ! spaceborne radar : from TOA to SURFACE
-      if (gbx%surface_radar == 1) then
-        z%Ze_tot(:,pr,:)=dBZe(:,:)
-      else if (gbx%surface_radar == 0) then ! Spaceborne
-        z%Ze_tot(:,pr,:)=dBZe(:,gbx%Nlevels:1:-1)
-      endif
+      ! store caluculated dBZe values for later output/processing
+      z%Ze_tot(:,pr,:)=dBZe(:,:)
   enddo !pr
-  ! Change undefined value to one defined in COSP
-  where (z%Ze_tot == -999.0) z%Ze_tot = R_UNDEF
   deallocate(hgt_matrix,p_matrix,t_matrix,rh_matrix)
 …
       Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe)
   deallocate(g_to_vol)
-  ! deallocate(mt_ttl,mt_tti)   !v0.2: roj feb 2008 can not be done here,
-                                !these variables now part of gbx structure and dealocated later
 END SUBROUTINE COSP_RADAR

LMDZ5/trunk/libf/phylmd/cosp/cosp_simulator.F90

-                      r1907
+                      r2428
 ! (c) British Crown Copyright 2008, the Met Office.
 ! All rights reserved.
+! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_simulator.F90 $
+!
 ! Redistribution and use in source and binary forms, with or without modification, are permitted
 …
 ! History:
 ! Jul 2007 - A. Bodas-Salcedo - Initial version
+! Jan 2013 - G. Cesana - Add new variables linked to the lidar cloud phase
+!
+!
+#include "cosp_defs.h"
 MODULE MOD_COSP_SIMULATOR
+  USE MOD_COSP_CONSTANTS, ONLY: I_RADAR, I_LIDAR, I_ISCCP, I_MISR, I_MODIS, &
+                                I_RTTOV, I_STATS, tsim
   USE MOD_COSP_TYPES
   USE MOD_COSP_RADAR
   USE MOD_COSP_LIDAR
   USE MOD_COSP_ISCCP_SIMULATOR
+  USE MOD_COSP_MODIS_SIMULATOR
   USE MOD_COSP_MISR_SIMULATOR
+!#ifdef RTTOV
+!  USE MOD_COSP_RTTOV_SIMULATOR
+!#endif
   USE MOD_COSP_STATS
   IMPLICIT NONE
 …
 !--------------------- SUBROUTINE COSP_SIMULATOR ------------------
 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_SIMULATOR(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,stradar,stlidar)
+!#ifdef RTTOV
+!SUBROUTINE COSP_SIMULATOR(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar)
+!#else
+SUBROUTINE COSP_SIMULATOR(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,stradar,stlidar)
+!#endif
   ! Arguments
   type(cosp_gridbox),intent(in) :: gbx      ! Grid-box inputs
+  type(cosp_gridbox),intent(inout) :: gbx      ! Grid-box inputs
   type(cosp_subgrid),intent(in) :: sgx      ! Subgrid inputs
   type(cosp_sghydro),intent(in) :: sghydro  ! Subgrid info for hydrometeors
   type(cosp_config),intent(in) :: cfg       ! Configuration options
+  type(cosp_config),intent(in)  :: cfg      ! Configuration options
   type(cosp_vgrid),intent(in)   :: vgrid    ! Information on vertical grid of stats
   type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator
 …
   type(cosp_isccp),intent(inout)   :: isccp   ! Output from ISCCP simulator
   type(cosp_misr),intent(inout)    :: misr    ! Output from MISR simulator
+  type(cosp_modis),intent(inout)   :: modis   ! Output from MODIS simulator
+!#ifdef RTTOV
+!  type(cosp_rttov),intent(inout)    :: rttov    ! Output from RTTOV
+!#endif
   type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator
   type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator
   ! Local variables
+  ! ***Timing variables (to be deleted in final version)
+  integer :: t0,t1,count_rate,count_max
+  !+++++++++ Radar model ++++++++++
+  integer :: i,j,k,isim
+  logical :: inconsistent
+  ! Timing variables
+  integer :: t0,t1
+  t0 = 0
+  t1 = 0
+  inconsistent=.false.
+!   do k=1,gbx%Nhydro
+!   do j=1,gbx%Nlevels
+!   do i=1,gbx%Npoints
+!     if ((gbx%mr_hydro(i,j,k)>0.0).and.(gbx%Reff(i,j,k)<=0.0)) inconsistent=.true.
+!   enddo
+!   enddo
+!   enddo
+!  if (inconsistent)  print *, '%%%% COSP_SIMULATOR: inconsistency in mr_hydro and Reff'
+  !+++++++++ Radar model ++++++++++
+  isim = I_RADAR
   if (cfg%Lradar_sim) then
+    call system_clock(t0)
     call cosp_radar(gbx,sgx,sghydro,sgradar)
+  endif
+    call system_clock(t1)
+    tsim(isim) = tsim(isim) + (t1 -t0)
+  endif
   !+++++++++ Lidar model ++++++++++
+  isim = I_LIDAR
   if (cfg%Llidar_sim) then
+    call system_clock(t0)
     call cosp_lidar(gbx,sgx,sghydro,sglidar)
+  endif
+    call system_clock(t1)
+    tsim(isim) = tsim(isim) + (t1 -t0)
+  endif
   !+++++++++ ISCCP simulator ++++++++++
+  isim = I_ISCCP
   if (cfg%Lisccp_sim) then
+    call system_clock(t0)
     call cosp_isccp_simulator(gbx,sgx,isccp)
+  endif
+    call system_clock(t1)
+    tsim(isim) = tsim(isim) + (t1 -t0)
+  endif
   !+++++++++ MISR simulator ++++++++++
+  isim = I_MISR
   if (cfg%Lmisr_sim) then
+    call system_clock(t0)
     call cosp_misr_simulator(gbx,sgx,misr)
+  endif
+    call system_clock(t1)
+    tsim(isim) = tsim(isim) + (t1 -t0)
+  endif
+  !+++++++++ MODIS simulator ++++++++++
+  isim = I_MODIS
+  if (cfg%Lmodis_sim) then
+    call system_clock(t0)
+    call cosp_modis_simulator(gbx,sgx,sghydro,isccp, modis)
+    call system_clock(t1)
+    tsim(isim) = tsim(isim) + (t1 -t0)
+  endif
+  !+++++++++ RTTOV ++++++++++
+  isim = I_RTTOV
+!#ifdef RTTOV
+!  if (cfg%Lrttov_sim) then
+!    call system_clock(t0)
+!    call cosp_rttov_simulator(gbx,rttov)
+!    call system_clock(t1)
+!    tsim(isim) = tsim(isim) + (t1 -t0)
+!  endif
+!#endif
   !+++++++++++ Summary statistics +++++++++++
+  isim = I_STATS
   if (cfg%Lstats) then
+    call system_clock(t0)
     call cosp_stats(gbx,sgx,cfg,sgradar,sglidar,vgrid,stradar,stlidar)
+!    print *, '%%%%%%  Stats:', (t1-t0)*1.0/count_rate, ' s'
+  endif
+    call system_clock(t1)
+    tsim(isim) = tsim(isim) + (t1 -t0)
+  endif
+  !+++++++++++ Change of units after computation of statistics +++++++++++
+  ! This avoids using UDUNITS in CMOR
+  ! Cloud fractions from 1 to %
+  if (cfg%Lclcalipso) then
+    where(stlidar%lidarcld /= R_UNDEF) stlidar%lidarcld = stlidar%lidarcld*100.0
+  endif
+  if (cfg%Lcltcalipso.OR.cfg%Lcllcalipso.OR.cfg%Lclmcalipso.OR.cfg%Lclhcalipso) then
+    where(stlidar%cldlayer /= R_UNDEF) stlidar%cldlayer = stlidar%cldlayer*100.0
+  endif
+  if (cfg%Lclcalipso2) then
+    where(stradar%lidar_only_freq_cloud /= R_UNDEF) stradar%lidar_only_freq_cloud = stradar%lidar_only_freq_cloud*100.0
+  endif
+  if (cfg%Lcltcalipsoliq.OR.cfg%Lcllcalipsoliq.OR.cfg%Lclmcalipsoliq.OR.cfg%Lclhcalipsoliq.OR. &
+      cfg%Lcltcalipsoice.OR.cfg%Lcllcalipsoice.OR.cfg%Lclmcalipsoice.OR.cfg%Lclhcalipsoice.OR. &
+      cfg%Lcltcalipsoun.OR.cfg%Lcllcalipsoun.OR.cfg%Lclmcalipsoun.OR.cfg%Lclhcalipsoun ) then
+    where(stlidar%cldlayerphase /= R_UNDEF) stlidar%cldlayerphase = stlidar%cldlayerphase*100.0
+  endif
+  if (cfg%Lclcalipsoliq.OR.cfg%Lclcalipsoice.OR.cfg%Lclcalipsoun) then
+    where(stlidar%lidarcldphase /= R_UNDEF) stlidar%lidarcldphase = stlidar%lidarcldphase*100.0
+  endif
+  if (cfg%Lclcalipsotmp.OR.cfg%Lclcalipsotmpliq.OR.cfg%Lclcalipsotmpice.OR.cfg%Lclcalipsotmpun) then
+    where(stlidar%lidarcldtmp /= R_UNDEF) stlidar%lidarcldtmp = stlidar%lidarcldtmp*100.0
+  endif
+  if (cfg%Lcltisccp) then
+     where(isccp%totalcldarea /= R_UNDEF) isccp%totalcldarea = isccp%totalcldarea*100.0
+! Test
+!     where(isccp%totalcldarea == R_UNDEF) isccp%totalcldarea = 0.
+  endif
+  if (cfg%Lclisccp) then
+    where(isccp%fq_isccp /= R_UNDEF) isccp%fq_isccp = isccp%fq_isccp*100.0
+  endif
+  if (cfg%LclMISR) then
+    where(misr%fq_MISR /= R_UNDEF) misr%fq_MISR = misr%fq_MISR*100.0
+  endif
+  if (cfg%Lcltlidarradar) then
+    where(stradar%radar_lidar_tcc /= R_UNDEF) stradar%radar_lidar_tcc = stradar%radar_lidar_tcc*100.0
+  endif
+  if (cfg%Lclmodis) then
+    where(modis%Optical_Thickness_vs_Cloud_Top_Pressure /= R_UNDEF) modis%Optical_Thickness_vs_Cloud_Top_Pressure = &
+                                                      modis%Optical_Thickness_vs_Cloud_Top_Pressure*100.0
+  endif
+  if (cfg%Lcltmodis) then
+     where(modis%Cloud_Fraction_Total_Mean /= R_UNDEF) modis%Cloud_Fraction_Total_Mean = modis%Cloud_Fraction_Total_Mean*100.0
+  endif
+  if (cfg%Lclwmodis) then
+     where(modis%Cloud_Fraction_Water_Mean /= R_UNDEF) modis%Cloud_Fraction_Water_Mean = modis%Cloud_Fraction_Water_Mean*100.0
+  endif
+  if (cfg%Lclimodis) then
+     where(modis%Cloud_Fraction_Ice_Mean /= R_UNDEF) modis%Cloud_Fraction_Ice_Mean = modis%Cloud_Fraction_Ice_Mean*100.0
+  endif
+  if (cfg%Lclhmodis) then
+     where(modis%Cloud_Fraction_High_Mean /= R_UNDEF) modis%Cloud_Fraction_High_Mean = modis%Cloud_Fraction_High_Mean*100.0
+  endif
+  if (cfg%Lclmmodis) then
+     where(modis%Cloud_Fraction_Mid_Mean /= R_UNDEF) modis%Cloud_Fraction_Mid_Mean = modis%Cloud_Fraction_Mid_Mean*100.0
+  endif
+  if (cfg%Lcllmodis) then
+     where(modis%Cloud_Fraction_Low_Mean /= R_UNDEF) modis%Cloud_Fraction_Low_Mean = modis%Cloud_Fraction_Low_Mean*100.0
+  endif
+  ! Change pressure from hPa to Pa.
+  if (cfg%Lboxptopisccp) then
+    where(isccp%boxptop /= R_UNDEF) isccp%boxptop = isccp%boxptop*100.0
+  endif
+  if (cfg%Lpctisccp) then
+    where(isccp%meanptop /= R_UNDEF) isccp%meanptop = isccp%meanptop*100.0
+  endif
 END SUBROUTINE COSP_SIMULATOR

LMDZ5/trunk/libf/phylmd/cosp/cosp_stats.F90

-                      r1907
+                      r2428
 ! (c) British Crown Copyright 2008, the Met Office.
 ! All rights reserved.
+! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_stats.F90 $
+!
 ! Redistribution and use in source and binary forms, with or without modification, are permitted
 …
 ! Oct 2008 - H. Chepfer       - Added PARASOL reflectance arguments
 ! Jun 2010 - T. Yokohata, T. Nishimura and K. Ogochi - Added NEC SXs optimisations
+!
+!
+! Jan 2013 - G. Cesana        - Added betaperp and temperature arguments
+!                             - Added phase 3D/3Dtemperature/Map output variables in diag_lidar
+!
+!
+#include "cosp_defs.h"
 MODULE MOD_COSP_STATS
   USE MOD_COSP_CONSTANTS
 …
    real,dimension(:,:,:),allocatable :: Ze_out,betatot_out,betamol_in,betamol_out,ph_in,ph_out
    real,dimension(:,:),allocatable :: ph_c,betamol_c
+   real,dimension(:,:,:),allocatable ::  betaperptot_out, temp_in, temp_out
+   real,dimension(:,:),allocatable :: temp_c
    Npoints  = gbx%Npoints
 …
    Nlr      = vgrid%Nlvgrid
    if (cfg%Lcfad_Lidarsr532) ok_lidar_cfad=.true.
+   if (cfg%LcfadLidarsr532) ok_lidar_cfad=.true.
    if (vgrid%use_vgrid) then ! Statistics in a different vertical grid
 …
         ph_out  = 0.0
         ph_c    = 0.0
+        allocate(betaperptot_out(Npoints,Ncolumns,Nlr),temp_in(Npoints,1,Nlevels),temp_out(Npoints,1,Nlr), &
+                 temp_c(Npoints,Nlr))
+        betaperptot_out = 0.0
+        temp_in = 0.0
+        temp_out = 0.0
+        temp_c = 0.0
         !++++++++++++ Radar CFAD ++++++++++++++++
         if (cfg%Lradar_sim) then
 …
             call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sglidar%beta_tot, &
                                            Nlr,vgrid%zl,vgrid%zu,betatot_out)
+            temp_in(:,1,:) = gbx%T(:,:)
+            call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sglidar%betaperp_tot, &
+                                           Nlr,vgrid%zl,vgrid%zu,betaperptot_out)
+            call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,temp_in, &
+                                           Nlr,vgrid%zl,vgrid%zu,temp_out)
+            temp_c(:,:) = temp_out(:,1,:)
             call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,ph_in, &
                                            Nlr,vgrid%zl,vgrid%zu,ph_out)
 …
             ! Stats from lidar_stat_summary
             call diag_lidar(Npoints,Ncolumns,Nlr,SR_BINS,PARASOL_NREFL &
                             ,betatot_out,betamol_c,sglidar%refl,gbx%land,ph_c &
+                            ,temp_c,betatot_out,betaperptot_out,betamol_c,sglidar%refl,gbx%land,ph_c &
                             ,LIDAR_UNDEF,ok_lidar_cfad &
                             ,stlidar%cfad_sr,stlidar%srbval &
+                            ,LIDAR_NCAT,stlidar%lidarcld,stlidar%cldlayer,stlidar%parasolrefl)
+                            ,LIDAR_NCAT,stlidar%lidarcld,stlidar%lidarcldphase &
+                            ,stlidar%cldlayer,stlidar%cldlayerphase,stlidar%lidarcldtmp &
+                            ,stlidar%parasolrefl)
         endif
         !++++++++++++ Lidar-only cloud amount and lidar&radar total cloud mount ++++++++++++++++
         if (cfg%Lradar_sim.and.cfg%Llidar_sim) call cosp_lidar_only_cloud(Npoints,Ncolumns,Nlr, &
                                     betatot_out,betamol_c,Ze_out, &
+                                    temp_c,betatot_out,betaperptot_out,betamol_c,Ze_out, &
                                     stradar%lidar_only_freq_cloud,stradar%radar_lidar_tcc)
+        deallocate(temp_out,temp_c,betaperptot_out)
         ! Deallocate arrays at coarse resolution
         deallocate(Ze_out,betatot_out,betamol_in,betamol_out,betamol_c,ph_in,ph_out,ph_c)
 …
         ! Stats from lidar_stat_summary
         if (cfg%Llidar_sim) call diag_lidar(Npoints,Ncolumns,Nlr,SR_BINS,PARASOL_NREFL &
                         ,sglidar%beta_tot,sglidar%beta_mol,sglidar%refl,gbx%land,gbx%ph &
+                        ,sglidar%temp_tot,sglidar%beta_tot,sglidar%betaperp_tot,sglidar%beta_mol,sglidar%refl,gbx%land,gbx%ph &
                         ,LIDAR_UNDEF,ok_lidar_cfad &
                         ,stlidar%cfad_sr,stlidar%srbval &
+                        ,LIDAR_NCAT,stlidar%lidarcld,stlidar%cldlayer,stlidar%parasolrefl)
+                        ,LIDAR_NCAT,stlidar%lidarcld,stlidar%lidarcldphase,stlidar%cldlayer,stlidar%cldlayerphase &
+                        ,stlidar%lidarcldtmp,stlidar%parasolrefl)
         !++++++++++++ Lidar-only cloud amount and lidar&radar total cloud mount ++++++++++++++++
         if (cfg%Lradar_sim.and.cfg%Llidar_sim) call cosp_lidar_only_cloud(Npoints,Ncolumns,Nlr, &
                                     sglidar%beta_tot,sglidar%beta_mol,sgradar%Ze_tot, &
+                                    sglidar%temp_tot,sglidar%beta_tot,sglidar%betaperp_tot,sglidar%beta_mol,sgradar%Ze_tot, &
                                     stradar%lidar_only_freq_cloud,stradar%radar_lidar_tcc)
    endif
 …
    where (stlidar%cldlayer  == LIDAR_UNDEF) stlidar%cldlayer  = R_UNDEF
    where (stlidar%parasolrefl == LIDAR_UNDEF) stlidar%parasolrefl = R_UNDEF
+   where (stlidar%cldlayerphase  == LIDAR_UNDEF) stlidar%cldlayerphase  = R_UNDEF
+   where (stlidar%lidarcldphase  == LIDAR_UNDEF) stlidar%lidarcldphase  = R_UNDEF
+   where (stlidar%lidarcldtmp  == LIDAR_UNDEF) stlidar%lidarcldtmp  = R_UNDEF
 END SUBROUTINE COSP_STATS
 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 !---------- SUBROUTINE COSP_CHANGE_VERTICAL_GRID ----------------
 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 SUBROUTINE COSP_CHANGE_VERTICAL_GRID(Npoints,Ncolumns,Nlevels,zfull,zhalf,y,M,zl,zu,r,log_units)
+SUBROUTINE COSP_CHANGE_VERTICAL_GRID(Npoints,Ncolumns,Nlevels,zfull,zhalf,y,Nglevels,newgrid_bot,newgrid_top,r,log_units)
    implicit none
    ! Input arguments
 …
    real,dimension(Npoints,Nlevels),intent(in) :: zhalf ! Height at half model levels [m] (Bottom of model layer)
    real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: y     ! Variable to be changed to a different grid
    integer,intent(in) :: M  !# levels in the new grid
    real,dimension(M),intent(in) :: zl ! Lower boundary of new levels  [m]
    real,dimension(M),intent(in) :: zu ! Upper boundary of new levels  [m]
+   integer,intent(in) :: Nglevels  !# levels in the new grid
+   real,dimension(Nglevels),intent(in) :: newgrid_bot ! Lower boundary of new levels  [m]
+   real,dimension(Nglevels),intent(in) :: newgrid_top ! Upper boundary of new levels  [m]
    logical,optional,intent(in) :: log_units ! log units, need to convert to linear units
    ! Output
    real,dimension(Npoints,Ncolumns,M),intent(out) :: r ! Variable on new grid
+   real,dimension(Npoints,Ncolumns,Nglevels),intent(out) :: r ! Variable on new grid
    ! Local variables
    integer :: i,j,k
    logical :: lunits
    integer :: l
+   real,dimension(Npoints) :: ws,sumwyp
+   real,dimension(Npoints,Nlevels) :: xl,xu
+   real,dimension(Npoints,Nlevels) :: w
+   real,dimension(Npoints,Ncolumns,Nlevels) :: yp
+   real :: w ! Weight
+   real :: dbb, dtb, dbt, dtt ! Distances between edges of both grids
+   integer :: Nw  ! Number of weights
+   real :: wt  ! Sum of weights
+   real,dimension(Nlevels) :: oldgrid_bot,oldgrid_top ! Lower and upper boundaries of model grid
+   real :: yp ! Local copy of y at a particular point.
+              ! This allows for change of units.
    lunits=.false.
    if (present(log_units)) lunits=log_units
+   r(:,:,:) = R_GROUND
+   ! Vertical grid at that point
+   xl(:,:) = zhalf(:,:)
+   xu(:,1:Nlevels-1) = xl(:,2:Nlevels)
+   xu(:,Nlevels) = zfull(:,Nlevels) +  zfull(:,Nlevels) - zhalf(:,Nlevels) ! Top level symmetric
+   yp(:,:,:) = y(:,:,:) ! Temporary variable to regrid
+   ! Check for dBZ and change if necessary
+   if (lunits) then
+     where (y /= R_UNDEF)
+       yp = 10.0**(y/10.0)
+     elsewhere
+       yp = 0.0
+     end where
+   endif
+   do k=1,M
+     ! Find weights
+     w(:,:) = 0.0
+     do j=1,Nlevels
+       do i=1,Npoints
+         if ((xl(i,j) < zl(k)).and.(xu(i,j) > zl(k)).and.(xu(i,j) <= zu(k))) then
+           !xl(j)-----------------xu(j)
+           !      zl(k)------------------------------zu(k)
+           w(i,j) = xu(i,j) - zl(k)
+         else if ((xl(i,j) >= zl(k)).and.(xu(i,j) <= zu(k))) then
+           !           xl(j)-----------------xu(j)
+           !      zl(k)------------------------------zu(k)
+           w(i,j) = xu(i,j) - xl(i,j)
+         else if ((xl(i,j) >= zl(k)).and.(xl(i,j) < zu(k)).and.(xu(i,j) >= zu(k))) then
+           !                           xl(j)-----------------xu(j)
+           !      zl(k)------------------------------zu(k)
+           w(i,j) = zu(k) - xl(i,j)
+         else if ((xl(i,j) <= zl(k)).and.(xu(i,j) >= zu(k))) then
+           !  xl(j)---------------------------xu(j)
+           !        zl(k)--------------zu(k)
+           w(i,j) = zu(k) - zl(k)
+   r = 0.0
+   do i=1,Npoints
+     ! Calculate tops and bottoms of new and old grids
+     oldgrid_bot = zhalf(i,:)
+     oldgrid_top(1:Nlevels-1) = oldgrid_bot(2:Nlevels)
+     oldgrid_top(Nlevels) = zfull(i,Nlevels) +  zfull(i,Nlevels) - zhalf(i,Nlevels) ! Top level symmetric
+     l = 0 ! Index of level in the old grid
+     ! Loop over levels in the new grid
+     do k = 1,Nglevels
+       Nw = 0 ! Number of weigths
+       wt = 0.0 ! Sum of weights
+       ! Loop over levels in the old grid and accumulate total for weighted average
+       do
+         l = l + 1
+         w = 0.0 ! Initialise weight to 0
+         ! Distances between edges of both grids
+         dbb = oldgrid_bot(l) - newgrid_bot(k)
+         dtb = oldgrid_top(l) - newgrid_bot(k)
+         dbt = oldgrid_bot(l) - newgrid_top(k)
+         dtt = oldgrid_top(l) - newgrid_top(k)
+         if (dbt >= 0.0) exit ! Do next level in the new grid
+         if (dtb > 0.0) then
+           if (dbb <= 0.0) then
+             if (dtt <= 0) then
+               w = dtb
+             else
+               w = newgrid_top(k) - newgrid_bot(k)
+             endif
+           else
+             if (dtt <= 0) then
+               w = oldgrid_top(l) - oldgrid_bot(l)
+             else
+               w = -dbt
+             endif
+           endif
+           ! If layers overlap (w/=0), then accumulate
+           if (w /= 0.0) then
+             Nw = Nw + 1
+             wt = wt + w
+             do j=1,Ncolumns
+               if (lunits) then
+                 if (y(i,j,l) /= R_UNDEF) then
+                   yp = 10.0**(y(i,j,l)/10.0)
+                 else
+                   yp = 0.0
+                 endif
+               else
+                 yp = y(i,j,l)
+               endif
+               r(i,j,k) = r(i,j,k) + w*yp
+             enddo
+           endif
          endif
        enddo
+       l = l - 2
+       if (l < 1) l = 0
+       ! Calculate average in new grid
+       if (Nw > 0) then
+         do j=1,Ncolumns
+           r(i,j,k) = r(i,j,k)/wt
+         enddo
+       endif
      enddo
+     ! Do the weighted mean
+   enddo
+   ! Set points under surface to R_UNDEF, and change to dBZ if necessary
+   do k=1,Nglevels
      do j=1,Ncolumns
+       ws    (:) = 0.0
+       sumwyp(:) = 0.0
+       do l=1,Nlevels
+         do i=1,Npoints
+           if (zu(k) > zhalf(i,1)) then ! Level above model bottom level
+             ws    (i) = ws    (i) + w(i,l)
+             sumwyp(i) = sumwyp(i) + w(i,l)*yp(i,j,l)
+       do i=1,Npoints
+         if (newgrid_top(k) > zhalf(i,1)) then ! Level above model bottom level
+           if (lunits) then
+             if (r(i,j,k) <= 0.0) then
+               r(i,j,k) = R_UNDEF
+             else
+               r(i,j,k) = 10.0*log10(r(i,j,k))
+             endif
            endif
+         enddo
+       enddo
+       do i=1,Npoints
+         if (zu(k) > zhalf(i,1)) then ! Level above model bottom level
+           if (ws(i) > 0.0) r(i,j,k) = sumwyp(i)/ws(i)
+         else ! Level below surface
+           r(i,j,k) = R_GROUND
          endif
        enddo
      enddo
    enddo
-   ! Check for dBZ and change if necessary
-   if (lunits) then
-     do k=1,M
-       do j=1,Ncolumns
-         do i=1,Npoints
-           if (zu(k) > zhalf(i,1)) then ! Level above model bottom level
-             if (r(i,j,k) <= 0.0) then
-                 r(i,j,k) = R_UNDEF
-             else
-                 r(i,j,k) = 10.0*log10(r(i,j,k))
-             endif
-           endif
-         enddo
-       enddo
-     enddo
-   endif
 END SUBROUTINE COSP_CHANGE_VERTICAL_GRID

LMDZ5/trunk/libf/phylmd/cosp/cosp_types.F90

-                      r1907
+                      r2428
 ! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
-! History:
-! Jul 2007 - A. Bodas-Salcedo - Initial version
-! Feb 2008 - R. Marchand      - Added Quickbeam types and initialisation
-! Oct 2008 - H. Chepfer       - Added PARASOL reflectance diagnostic
-! Nov 2008 - R. Marchand      - Added MISR diagnostics
-! Nov 2008 - V. John          - Added RTTOV diagnostics
+!
+!
 MODULE MOD_COSP_TYPES
     USE MOD_COSP_CONSTANTS
     USE MOD_COSP_UTILS
     use radar_simulator_types, only: class_param, mie, nd, mt_nd, dmax, dmin, mt_ttl, mt_tti, cnt_liq, cnt_ice  ! added by roj Feb 2008
+    use radar_simulator_types, only: class_param, nd, mt_nd, dmax, dmin
     IMPLICIT NONE
 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 !----------------------- DERIVED TYPES ----------------------------
 …
   ! Configuration choices (simulators, variables)
   TYPE COSP_CONFIG
+     logical :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim,Lstats,Lwrite_output, &
+                Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfad_dbze94, &
+                Lcfad_lidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp2,Lcllcalipso, &
+                Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lctpisccp,Ldbze94,Ltauisccp,Ltclisccp, &
+                Llongitude,Llatitude,Lparasol_refl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
+                Lfrac_out,Lbeta_mol532,Ltbrttov
+     logical :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim,Lstats,Lwrite_output, &
+                Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,LcfadDbze94, &
+                LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp,Lcllcalipso, &
+                Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp,Lcltisccp, &
+                Ltoffset,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
+                Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun, &
+                Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun, &
+                      Lcltcalipsoliq,Lcltcalipsoice,Lcltcalipsoun, &
+                Lclhcalipsoliq,Lclhcalipsoice,Lclhcalipsoun, &
+                Lclmcalipsoliq,Lclmcalipsoice,Lclmcalipsoun, &
+                Lcllcalipsoliq,Lcllcalipsoice,Lcllcalipsoun, &
+                Lfracout,LlidarBetaMol532,Ltbrttov, &
+                Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, &
+                Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, &
+                Liwpmodis,Lclmodis
      character(len=32) :: out_list(N_OUT_LIST)
   END TYPE COSP_CONFIG
 …
     ! Arrays with dimensions (Npoints,Nlevels)
     real,dimension(:,:),pointer :: beta_mol   ! Molecular backscatter
+    real,dimension(:,:),pointer :: temp_tot
     ! Arrays with dimensions (Npoints,Ncolumns,Nlevels)
+    real,dimension(:,:,:),pointer :: betaperp_tot   ! Total backscattered signal
     real,dimension(:,:,:),pointer :: beta_tot   ! Total backscattered signal
     real,dimension(:,:,:),pointer :: tau_tot    ! Optical thickness integrated from top to level z
 …
     real, dimension(:,:),pointer :: lidarcld    ! 3D "lidar" cloud fraction
     ! Arrays with dimensions (Npoints,LIDAR_NCAT)
+    real, dimension(:,:),pointer :: cldlayer      ! low, mid, high-level lidar cloud cover
+    real, dimension(:,:),pointer :: cldlayer      ! low, mid, high-level, total lidar cloud cover
+   ! Arrays with dimensions (Npoints,Nlevels,Nphase)
+    real, dimension(:,:,:),pointer :: lidarcldphase    ! 3D "lidar" phase cloud fraction
+     ! Arrays with dimensions (Npoints,LIDAR_NCAT,Nphase)
+    real, dimension(:,:,:),pointer :: cldlayerphase      ! low, mid, high-level lidar phase cloud cover
+    ! Arrays with dimensions (Npoints,Ntemps,Nphase)
+    real, dimension(:,:,:),pointer :: lidarcldtmp    ! 3D "lidar" phase cloud temperature
     ! Arrays with dimensions (Npoints,PARASOL_NREFL)
     real, dimension(:,:),pointer :: parasolrefl   ! mean parasol reflectance
 …
                                                 ! (Reff==0 means use default size)
                                                 ! (Npoints,Ncolumns,Nlevels,Nhydro) [m]
+    real,dimension(:,:,:,:),pointer :: Np       ! Total # concentration each hydrometeor
+                                                ! (Optional, ignored if Reff > 0).
+                                                ! (Npoints,Ncolumns,Nlevels,Nhydro) [#/kg]
+                                                ! Np = Ntot / rho_a  = [#/m^3] / [kg/m^3)
+                                                ! added by Roj with Quickbeam V3
   END TYPE COSP_SGHYDRO
 …
     ! Time [days]
     double precision :: time
+    double precision :: time_bnds(2)
     ! Radar ancillary info
 …
             k2 ! |K|^2, -1=use frequency dependent default
     integer :: surface_radar, & ! surface=1, spaceborne=0
                use_mie_tables, & ! use a precomputed loopup table? yes=1,no=0
                use_gas_abs, & ! include gaseous absorption? yes=1,no=0
                do_ray, & ! calculate/output Rayleigh refl=1, not=0
                melt_lay ! melting layer model off=0, on=1
+           use_mie_tables, & ! use a precomputed loopup table? yes=1,no=0
+           use_gas_abs, & ! include gaseous absorption? yes=1,no=0
+           do_ray, & ! calculate/output Rayleigh refl=1, not=0
+           melt_lay ! melting layer model off=0, on=1
     ! structures used by radar simulator that need to be set only ONCE per radar configuration (e.g. freq, pointing direction) ... added by roj Feb 2008
+    type(class_param) ::  hp    ! structure used by radar simulator to store Ze and N scaling constants and other information
+    type(mie)::  mt             ! structure used by radar simulator to store mie LUT information
+    integer :: nsizes           ! number of discrete drop sizes (um) used to represent the distribution
+    real*8, dimension(:), pointer :: D ! array of discrete drop sizes (um) used to represent the distribution
+    real*8, dimension(:), pointer :: mt_ttl, mt_tti ! array of temperatures used with Ze_scaling (also build into mie LUT)
+    type(class_param) ::  hp    ! structure used by radar simulator to store Ze and N scaling constants and other information
+    integer :: nsizes       ! number of discrete drop sizes (um) used to represent the distribution
     ! Lidar
 …
     ! Radar
     logical ::  use_precipitation_fluxes  ! True if precipitation fluxes are input to the algorithm
+    logical ::  use_reff  ! True if Reff is to be used by radar
+    logical ::  use_reff          ! True if Reff is to be used by radar (memory not allocated
     ! Geolocation (Npoints)
+    real,dimension(:),pointer :: toffset   ! Time offset of esch point from the value in time
     real,dimension(:),pointer :: longitude ! longitude [degrees East]
     real,dimension(:),pointer :: latitude  ! latitude [deg North]
 …
     real,dimension(:),pointer :: sunlit ! (npoints) 1 for day points, 0 for nightime
     real,dimension(:),pointer :: skt  ! Skin temperature (K)
-    real,dimension(:),pointer :: sfc_height  ! Surface height [m]
     real,dimension(:),pointer :: u_wind  ! eastward wind [m s-1]
     real,dimension(:),pointer :: v_wind  ! northward wind [m s-1]
 …
     real,dimension(:,:,:),pointer :: mr_hydro ! Mixing ratio of each hydrometeor (Npoints,Nlevels,Nhydro) [kg/kg]
     real,dimension(:,:),pointer   :: dist_prmts_hydro !Distributional parameters for hydrometeors (Nprmts_max_hydro,Nhydro)
+    ! Effective radius [m]. (Npoints,Nlevels,Nhydro)
+    ! Effective radius [m]. (Npoints,Nlevels,Nhydro) -- OPTIONAL, value of 0 mean use fixed default
     real,dimension(:,:,:),pointer :: Reff
+    ! Total Number Concentration [#/kg]. (Npoints,Nlevels,Nhydro) -- OPTIONAL, value of 0 mean use fixed default
+    real,dimension(:,:,:),pointer :: Np ! added by Roj with Quickbeam V3
     ! Aerosols concentration and distribution parameters
     real,dimension(:,:,:),pointer :: conc_aero ! Aerosol concentration for each species (Npoints,Nlevels,Naero)
 …
 !------------- SUBROUTINE CONSTRUCT_COSP_RTTOV -------------------
 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE CONSTRUCT_COSP_RTTOV(Npoints,Nchan,x)
+  SUBROUTINE CONSTRUCT_COSP_RTTOV(cfg,Npoints,Nchan,x)
+    type(cosp_config),intent(in) :: cfg ! Configuration options
     integer,intent(in) :: Npoints  ! Number of sampled points
     integer,intent(in) :: Nchan ! Number of channels
     type(cosp_rttov),intent(out) :: x
+    ! Dimensions
+    x%Npoints  = Npoints
+    x%Nchan    = Nchan
+    ! Local variables
+    integer :: i,j
+    ! Allocate minumum storage if simulator not used
+    if (cfg%Lrttov_sim) then
+      i = Npoints
+      j = Nchan
+    else
+      i = 1
+      j = 1
+    endif
+    x%Npoints  = i
+    x%Nchan    = j
     ! --- Allocate arrays ---
     allocate(x%tbs(Npoints, Nchan))
+    allocate(x%tbs(i, j))
     ! --- Initialise to zero ---
     x%tbs     = 0.0
 …
     ! --- Allocate arrays ---
     allocate(x%beta_mol(i,k), x%beta_tot(i,j,k), &
+             x%tau_tot(i,j,k),x%refl(i,j,m))
+             x%tau_tot(i,j,k),x%refl(i,j,m), &
+             x%temp_tot(i,k),x%betaperp_tot(i,j,k))
     ! --- Initialise to zero ---
     x%beta_mol   = 0.0
 …
     x%tau_tot    = 0.0
     x%refl       = 0.0 ! parasol
+    x%temp_tot          = 0.0
+    x%betaperp_tot      = 0.0
   END SUBROUTINE CONSTRUCT_COSP_SGLIDAR
 …
     type(cosp_sglidar),intent(inout) :: x
+    deallocate(x%beta_mol, x%beta_tot, x%tau_tot, x%refl)
+    deallocate(x%beta_mol, x%beta_tot, x%tau_tot, x%refl, &
+               x%temp_tot, x%betaperp_tot)
   END SUBROUTINE FREE_COSP_SGLIDAR
 …
     ! --- Allocate arrays ---
     allocate(x%srbval(SR_BINS),x%cfad_sr(i,SR_BINS,k), &
+    allocate(x%srbval(SR_BINS),x%cfad_sr(i,SR_BINS,k), &
              x%lidarcld(i,k), x%cldlayer(i,LIDAR_NCAT), x%parasolrefl(i,m))
+    allocate(x%lidarcldphase(i,k,6),x%lidarcldtmp(i,LIDAR_NTEMP,5),&
+             x%cldlayerphase(i,LIDAR_NCAT,6))
     ! --- Initialise to zero ---
     x%srbval    = 0.0
 …
     x%cldlayer  = 0.0
     x%parasolrefl  = 0.0
+  END SUBROUTINE CONSTRUCT_COSP_LIDARSTATS
+    x%lidarcldphase  = 0.0
+    x%cldlayerphase  = 0.0
+    x%lidarcldtmp  = 0.0
+   END SUBROUTINE CONSTRUCT_COSP_LIDARSTATS
 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 …
     deallocate(x%srbval, x%cfad_sr, x%lidarcld, x%cldlayer, x%parasolrefl)
+    deallocate(x%cldlayerphase, x%lidarcldtmp, x%lidarcldphase)
   END SUBROUTINE FREE_COSP_LIDARSTATS
 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 …
     ! --- Allocate arrays ---
     allocate(y%mr_hydro(Npoints,Ncolumns,Nlevels,Nhydro), &
+             y%Reff(Npoints,Ncolumns,Nlevels,Nhydro))
+             y%Reff(Npoints,Ncolumns,Nlevels,Nhydro), &
+             y%Np(Npoints,Ncolumns,Nlevels,Nhydro)) ! added by roj with Quickbeam V3
     ! --- Initialise to zero ---
     y%mr_hydro = 0.0
     y%Reff     = 0.0
+    y%Np       = 0.0                    ! added by roj with Quickbeam V3
   END SUBROUTINE CONSTRUCT_COSP_SGHYDRO
 …
     ! --- Deallocate arrays ---
     deallocate(y%mr_hydro, y%Reff)
+    deallocate(y%mr_hydro, y%Reff, y%Np)        ! added by Roj with Quickbeam V3
   END SUBROUTINE FREE_COSP_SGHYDRO
 …
 !------------- SUBROUTINE CONSTRUCT_COSP_GRIDBOX ------------------
 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
   SUBROUTINE CONSTRUCT_COSP_GRIDBOX(time,radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, &
                                    Npoints,Nlevels,Ncolumns,Nhydro,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, &
+  SUBROUTINE CONSTRUCT_COSP_GRIDBOX(time,time_bnds,radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, &
+                                   Npoints,Nlevels,Ncolumns,Nhydro,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, &
                                    lidar_ice_type,isccp_top_height,isccp_top_height_direction,isccp_overlap,isccp_emsfc_lw, &
                                    use_precipitation_fluxes,use_reff, &
                                    ! RTTOV inputs
                                    Plat,Sat,Inst,Nchan,ZenAng,Ichan,SurfEm,co2,ch4,n2o,co,&
                                    y)
+                                   y,load_LUT)
     double precision,intent(in) :: time ! Time since start of run [days]
+    double precision,intent(in) :: time_bnds(2) ! Time boundaries
     real,intent(in)    :: radar_freq, & ! Radar frequency [GHz]
                           k2            ! |K|^2, -1=use frequency dependent default
 …
     real,intent(in)    :: co2,ch4,n2o,co
     type(cosp_gridbox),intent(out) :: y
+    logical,intent(in),optional :: load_LUT
     ! local variables
+    integer i, cnt_ice, cnt_liq
+    character*200 :: mie_table_name ! Mie table name
+    real*8  :: delt, deltp
+    character*240 :: LUT_file_name
+    logical :: local_load_LUT
+    if (present(load_LUT)) then
+      local_load_LUT = load_LUT
+    else
+      local_load_LUT = RADAR_SIM_LOAD_scale_LUTs_flag
+    endif
     ! Dimensions and scalars
     y%radar_freq       = radar_freq
 …
     y%use_reff = use_reff
+    y%time = time
+    y%time      = time
+    y%time_bnds = time_bnds
     ! RTTOV parameters
 …
     ! Surface information and geolocation (Npoints)
     allocate(y%longitude(Npoints),y%latitude(Npoints),y%psfc(Npoints), y%land(Npoints), &
              y%sunlit(Npoints),y%skt(Npoints),y%sfc_height(Npoints),y%u_wind(Npoints),y%v_wind(Npoints))
+    allocate(y%toffset(Npoints), y%longitude(Npoints),y%latitude(Npoints),y%psfc(Npoints), y%land(Npoints), &
+             y%sunlit(Npoints),y%skt(Npoints),y%u_wind(Npoints),y%v_wind(Npoints))
     ! Hydrometeors concentration and distribution parameters
     allocate(y%mr_hydro(Npoints,Nlevels,Nhydro), &
              y%dist_prmts_hydro(Nprmts_max_hydro,Nhydro), &
+             y%Reff(Npoints,Nlevels,Nhydro))
+             y%Reff(Npoints,Nlevels,Nhydro), &
+             y%Np(Npoints,Nlevels,Nhydro))      ! added by Roj with Quickbeam V3
     ! Aerosols concentration and distribution parameters
     allocate(y%conc_aero(Npoints,Nlevels,Naero), y%dist_type_aero(Naero), &
 …
     y%snow_cv   = 0.0
     y%Reff      = 0.0
+    y%Np        = 0.0 ! added by Roj with Quickbeam V3
     y%mr_ozone  = 0.0
     y%u_wind    = 0.0
 …
     ! (Npoints)
+!     call zero_real(y%psfc, y%land)
+    y%toffset = 0.0
     y%longitude = 0.0
     y%latitude = 0.0
 …
     y%sunlit = 0.0
     y%skt = 0.0
-    y%sfc_height = 0.0
     ! (Npoints,Nlevels,Nhydro)
 !     y%fr_hydro = 0.0
 …
     y%dist_prmts_aero  = 0.0 ! (Npoints,Nlevels,Nprmts_max_aero,Naero)
+    y%hp%p1 = 0.0
+    y%hp%p2 = 0.0
+    y%hp%p3 = 0.0
+    y%hp%dmin = 0.0
+    y%hp%dmax = 0.0
+    y%hp%apm = 0.0
+    y%hp%bpm = 0.0
+    y%hp%rho = 0.0
+    y%hp%dtype = 0
+    y%hp%col = 0
+    y%hp%cp = 0
+    y%hp%phase = 0
+    y%hp%scaled = .false.
+    y%hp%z_flag = .false.
+    y%hp%Ze_scaled = 0.0
+    y%hp%Zr_scaled = 0.0
+    y%hp%kr_scaled = 0.0
+    y%hp%fc = 0.0
+    y%hp%rho_eff = 0.0
+    y%hp%ifc = 0
+    y%hp%idd = 0
+    y%mt%freq = 0.0
+    y%mt%tt = 0.0
+    y%mt%f = 0.0
+    y%mt%D = 0.0
+    y%mt%qext = 0.0
+    y%mt%qbsca = 0.0
+    y%mt%phase = 0
+    ! --- Initialize the distributional parameters for hydrometeors
+    y%dist_prmts_hydro( 1,:) = HCLASS_TYPE(:)
+    y%dist_prmts_hydro( 2,:) = HCLASS_COL(:)
+    y%dist_prmts_hydro( 3,:) = HCLASS_PHASE(:)
+    y%dist_prmts_hydro( 4,:) = HCLASS_CP(:)
+    y%dist_prmts_hydro( 5,:) = HCLASS_DMIN(:)
+    y%dist_prmts_hydro( 6,:) = HCLASS_DMAX(:)
+    y%dist_prmts_hydro( 7,:) = HCLASS_APM(:)
+    y%dist_prmts_hydro( 8,:) = HCLASS_BPM(:)
+    y%dist_prmts_hydro( 9,:) = HCLASS_RHO(:)
+    y%dist_prmts_hydro(10,:) = HCLASS_P1(:)
+    y%dist_prmts_hydro(11,:) = HCLASS_P2(:)
+    y%dist_prmts_hydro(12,:) = HCLASS_P3(:)
+    ! the following code added by roj to initialize structures used by radar simulator, Feb 2008
+    call load_hydrometeor_classes(y%Nprmts_max_hydro,y%dist_prmts_hydro(:,:),y%hp,y%Nhydro)
+    ! load mie tables ?
+    if (y%use_mie_tables == 1) then
+        ! ----- Mie tables ----
+            mie_table_name='mie_table.dat'
+        call load_mie_table(mie_table_name,y%mt)
+            !   :: D specified by table ... not must match that used when mie LUT generated!
+        y%nsizes = mt_nd
+        allocate(y%D(y%nsizes))
+        y%D = y%mt%D
+    else
+           ! otherwise we still need to initialize temperature arrays for Ze scaling (which is only done when not using mie table)
+           cnt_ice=19
+           cnt_liq=20
+       if (.not.(allocated(mt_ttl).and.allocated(mt_tti))) then
+          allocate(mt_ttl(cnt_liq),mt_tti(cnt_ice))  ! note needed as this is global array ...
+                                                     ! which should be changed in the future
+       endif
+           do i=1,cnt_ice
+                  mt_tti(i)=(i-1)*5-90
+           enddo
+           do i=1,cnt_liq
+                  mt_ttl(i)=(i-1)*5 - 60
+           enddo
+           allocate(y%mt_ttl(cnt_liq),y%mt_tti(cnt_ice))
+       y%mt_ttl = mt_ttl
+       y%mt_tti = mt_tti
+! !------ OLD code in v0.1 ---------------------------
+!        allocate(mt_ttl(2),mt_tti(2))
+!        allocate(y%mt_ttl(2),y%mt_tti(2))
+!        mt_ttl = 0.0
+!        mt_tti = 0.0
+!        y%mt_ttl = mt_ttl
+!        y%mt_tti = mt_tti
+! !---------------------------------------------------
+       ! :: D created on a log-linear scale
+       y%nsizes = nd
+       delt = (log(dmax)-log(dmin))/(y%nsizes-1)
+       deltp = exp(delt)
+       allocate(y%D(y%nsizes))
+       y%D(1) = dmin
+       do i=2,y%nsizes
+          y%D(i) = y%D(i-1)*deltp
+       enddo
+    ! NOTE: This location use to contain initialization of some radar simulator variables
+    ! this initialization (including use of the variable "dist_prmts_hydro" - now obselete)
+    ! has been unified in the quickbeam v3 subroutine "radar_simulator_init".   Roj, June 2010
+    ! --- Initialize the distributional parameters for hydrometeors in radar simulator
+    write(*,*) 'RADAR_SIM microphysics scheme is set to: ', &
+            trim(RADAR_SIM_MICROPHYSICS_SCHEME_NAME)
+    if(y%Nhydro.ne.N_HYDRO) then
+        write(*,*) 'Number of hydrometeor input to subroutine', &
+               ' CONSTRUCT_COSP_GRIDBOX does not match value', &
+               ' specified in cosp_constants.f90!'
+        write(*,*)
     endif
+    ! NOTE: SAVE_scale_LUTs_flag is hard codded as .false. here
+    ! so that radar simulator will NOT update LUT each time it
+    ! is called, but rather will update when "Free_COSP_GRIDBOX" is called!
+    ! Roj, June 2010
+    LUT_file_name = trim(RADAR_SIM_LUT_DIRECTORY) // &
+                trim(RADAR_SIM_MICROPHYSICS_SCHEME_NAME)
+    call radar_simulator_init(radar_freq,k2, &
+                      use_gas_abs,do_ray,R_UNDEF, &
+                      y%Nhydro, &
+                      HCLASS_TYPE,HCLASS_PHASE, &
+                      HCLASS_DMIN,HCLASS_DMAX, &
+                      HCLASS_APM,HCLASS_BPM,HCLASS_RHO, &
+                      HCLASS_P1,HCLASS_P2,HCLASS_P3, &
+                      local_load_LUT,    &
+                      .false., &
+                      LUT_file_name, &
+                      y%hp)
 END SUBROUTINE CONSTRUCT_COSP_GRIDBOX
 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 !------------- SUBROUTINE FREE_COSP_GRIDBOX -----------------------
 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE FREE_COSP_GRIDBOX(y,dglobal)
+  SUBROUTINE FREE_COSP_GRIDBOX(y,dglobal,save_LUT)
+    use scale_LUTs_io
     type(cosp_gridbox),intent(inout) :: y
     logical,intent(in),optional :: dglobal
+    ! --- Free arrays ---
+    deallocate(y%D,y%mt_ttl,y%mt_tti)   ! added by roj Feb 2008
+    if (.not.present(dglobal)) deallocate(mt_ttl,mt_tti)
+!     deallocate(y%hp%p1,y%hp%p2,y%hp%p3,y%hp%dmin,y%hp%dmax,y%hp%apm,y%hp%bpm,y%hp%rho, &
+!               y%hp%dtype,y%hp%col,y%hp%cp,y%hp%phase,y%hp%scaled, &
+!               y%hp%z_flag,y%hp%Ze_scaled,y%hp%Zr_scaled,y%hp%kr_scaled, &
+!               y%hp%fc, y%hp%rho_eff, y%hp%ifc, y%hp%idd)
+!     deallocate(y%mt%freq, y%mt%tt, y%mt%f, y%mt%D, y%mt%qext, y%mt%qbsca, y%mt%phase)
+    logical,intent(in),optional :: save_LUT
+    logical :: local_save_LUT
+    if (present(save_LUT)) then
+      local_save_LUT = save_LUT
+    else
+      local_save_LUT = RADAR_SIM_UPDATE_scale_LUTs_flag
+    endif
+    ! save any updates to radar simulator LUT
+    if (local_save_LUT) call save_scale_LUTs(y%hp)
     deallocate(y%zlev, y%zlev_half, y%dlev, y%p, y%ph, y%T, y%q, &
                y%sh, y%dtau_s, y%dtau_c, y%dem_s, y%dem_c, &
                y%longitude,y%latitude,y%psfc, y%land, y%tca, y%cca, &
+               y%toffset, y%longitude,y%latitude,y%psfc, y%land, y%tca, y%cca, &
                y%mr_hydro, y%dist_prmts_hydro, &
                y%conc_aero, y%dist_type_aero, y%dist_prmts_aero, &
                y%rain_ls, y%rain_cv, y%snow_ls, y%snow_cv, y%grpl_ls, &
+               y%sunlit, y%skt, y%sfc_height, y%Reff,y%ichan,y%surfem, &
+               y%sunlit, y%skt, y%Reff,y%Np, &
+               y%ichan,y%surfem, &
                y%mr_ozone,y%u_wind,y%v_wind)
   END SUBROUTINE FREE_COSP_GRIDBOX
 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 …
     type(cosp_gridbox),intent(in) :: x
     type(cosp_gridbox),intent(inout) :: y
     integer :: i,j,k,sz(3)
     double precision :: tny
     tny = tiny(tny)
     y%hp%p1      = x%hp%p1
 …
     y%hp%fc      = x%hp%fc
     y%hp%rho_eff = x%hp%rho_eff
     y%hp%ifc     = x%hp%ifc
     y%hp%idd     = x%hp%idd
     sz = shape(x%hp%z_flag)
+    ! y%hp%ifc     = x%hp%ifc       obsolete, Roj, June 2010
+    ! y%hp%idd     = x%hp%idd
+    sz = shape(x%hp%Z_scale_flag)
     do k=1,sz(3)
       do j=1,sz(2)
         do i=1,sz(1)
            if (x%hp%scaled(i,k))   y%hp%scaled(i,k)      = .true.
            if (x%hp%z_flag(i,j,k)) y%hp%z_flag(i,j,k)    = .true.
+           if (x%hp%N_scale_flag(i,k))   y%hp%N_scale_flag(i,k)      = .true.
+           if (x%hp%Z_scale_flag(i,j,k)) y%hp%Z_scale_flag(i,j,k)    = .true.
            if (abs(x%hp%Ze_scaled(i,j,k)) > tny) y%hp%Ze_scaled(i,j,k) = x%hp%Ze_scaled(i,j,k)
            if (abs(x%hp%Zr_scaled(i,j,k)) > tny) y%hp%Zr_scaled(i,j,k) = x%hp%Zr_scaled(i,j,k)
 …
     type(cosp_gridbox),intent(inout) :: y
-    integer :: i,j,k,sz(3)
     ! --- Copy arrays without Npoints as dimension ---
     y%dist_prmts_hydro = x%dist_prmts_hydro
     y%dist_type_aero   = x%dist_type_aero
+    y%D                = x%D
+    y%mt_ttl           = x%mt_ttl
+    y%mt_tti           = x%mt_tti
 !     call cosp_gridbox_cphp(x,y)
 …
     y%sunlit(iy(1):iy(2))     = x%sunlit(ix(1):ix(2))
     y%skt(iy(1):iy(2))        = x%skt(ix(1):ix(2))
-    y%sfc_height(iy(1):iy(2)) = x%sfc_height(ix(1):ix(2))
     y%u_wind(iy(1):iy(2))     = x%u_wind(ix(1):ix(2))
     y%v_wind(iy(1):iy(2))     = x%v_wind(ix(1):ix(2))
 …
     ! 3D
     y%Reff(iy(1):iy(2),:,:)      = x%Reff(ix(1):ix(2),:,:)
+    y%Np(iy(1):iy(2),:,:)      = x%Np(ix(1):ix(2),:,:)   ! added by Roj with Quickbeam V3
     y%conc_aero(iy(1):iy(2),:,:) = x%conc_aero(ix(1):ix(2),:,:)
     y%mr_hydro(iy(1):iy(2),:,:)  = x%mr_hydro(ix(1):ix(2),:,:)
 …
     type(cosp_sglidar),intent(in) :: x
     type(cosp_sglidar),intent(inout) :: y
+    y%temp_tot(iy(1):iy(2),:)       = x%temp_tot(ix(1):ix(2),:)
+    y%betaperp_tot(iy(1):iy(2),:,:) = x%betaperp_tot(ix(1):ix(2),:,:)
     y%beta_mol(iy(1):iy(2),:)       = x%beta_mol(ix(1):ix(2),:)
     y%beta_tot(iy(1):iy(2),:,:)     = x%beta_tot(ix(1):ix(2),:,:)
 …
     type(cosp_isccp),intent(in) :: x
     type(cosp_isccp),intent(inout) :: y
     y%fq_isccp(iy(1):iy(2),:,:)  = x%fq_isccp(ix(1):ix(2),:,:)
     y%totalcldarea(iy(1):iy(2))  = x%totalcldarea(ix(1):ix(2))
 …
     y%cldlayer(iy(1):iy(2),:)    = x%cldlayer(ix(1):ix(2),:)
     y%parasolrefl(iy(1):iy(2),:) = x%parasolrefl(ix(1):ix(2),:)
+    y%lidarcldphase(iy(1):iy(2),:,:)  = x%lidarcldphase(ix(1):ix(2),:,:)
+    y%cldlayerphase(iy(1):iy(2),:,:)  = x%cldlayerphase(ix(1):ix(2),:,:)
+    y%lidarcldtmp(iy(1):iy(2),:,:)    = x%lidarcldtmp(ix(1):ix(2),:,:)
 END SUBROUTINE COSP_LIDARSTATS_CPSECTION
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- PRINT SUBROUTINES --------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_GRIDBOX_PRINT(x)
+    type(cosp_gridbox),intent(in) :: x
+    print *, '%%%%----- Information on COSP_GRIDBOX ------'
+    ! Scalars and dimensions
+    print *,  x%Npoints
+    print *,  x%Nlevels
+    print *,  x%Ncolumns
+    print *,  x%Nhydro
+    print *,  x%Nprmts_max_hydro
+    print *,  x%Naero
+    print *,  x%Nprmts_max_aero
+    print *,  x%Npoints_it
+    ! Time [days]
+    print *,  x%time
+    ! Radar ancillary info
+    print *,  x%radar_freq, &
+            x%k2
+    print *,  x%surface_radar, &
+              x%use_mie_tables, &
+              x%use_gas_abs, &
+              x%do_ray, &
+              x%melt_lay
+!               print *,  'shape(x%): ',shape(x%)
+!     type(class_param) ::  hp  ! structure used by radar simulator to store Ze and N scaling constants and other information
+!     type(mie)::  mt           ! structure used by radar simulator to store mie LUT information
+    print *,  x%nsizes
+    ! Lidar
+    print *,  x%lidar_ice_type
+    ! Radar
+    print *,  x%use_precipitation_fluxes
+    print *,  x%use_reff
+    ! Geolocation (Npoints)
+    print *,  'shape(x%longitude): ',shape(x%longitude)
+    print *,  'shape(x%latitude): ',shape(x%latitude)
+    ! Gridbox information (Npoints,Nlevels)
+    print *,  'shape(x%zlev): ',shape(x%zlev)
+    print *,  'shape(x%zlev_half): ',shape(x%zlev_half)
+    print *,  'shape(x%dlev): ',shape(x%dlev)
+    print *,  'shape(x%p): ',shape(x%p)
+    print *,  'shape(x%ph): ',shape(x%ph)
+    print *,  'shape(x%T): ',shape(x%T)
+    print *,  'shape(x%q): ',shape(x%q)
+    print *,  'shape(x%sh): ',shape(x%sh)
+    print *,  'shape(x%dtau_s): ',shape(x%dtau_s)
+    print *,  'shape(x%dtau_c): ',shape(x%dtau_c)
+    print *,  'shape(x%dem_s): ',shape(x%dem_s)
+    print *,  'shape(x%dem_c): ',shape(x%dem_c)
+    print *,  'shape(x%mr_ozone): ',shape(x%mr_ozone)
+    ! Point information (Npoints)
+    print *,  'shape(x%land): ',shape(x%land)
+    print *,  'shape(x%psfc): ',shape(x%psfc)
+    print *,  'shape(x%sunlit): ',shape(x%sunlit)
+    print *,  'shape(x%skt): ',shape(x%skt)
+    print *,  'shape(x%u_wind): ',shape(x%u_wind)
+    print *,  'shape(x%v_wind): ',shape(x%v_wind)
+    ! TOTAL and CONV cloud fraction for SCOPS
+    print *,  'shape(x%tca): ',shape(x%tca)
+    print *,  'shape(x%cca): ',shape(x%cca)
+    ! Precipitation fluxes on model levels
+    print *,  'shape(x%rain_ls): ',shape(x%rain_ls)
+    print *,  'shape(x%rain_cv): ',shape(x%rain_cv)
+    print *,  'shape(x%snow_ls): ',shape(x%snow_ls)
+    print *,  'shape(x%snow_cv): ',shape(x%snow_cv)
+    print *,  'shape(x%grpl_ls): ',shape(x%grpl_ls)
+    ! Hydrometeors concentration and distribution parameters
+    print *,  'shape(x%mr_hydro): ',shape(x%mr_hydro)
+    print *,  'shape(x%dist_prmts_hydro): ',shape(x%dist_prmts_hydro)
+    ! Effective radius [m]. (Npoints,Nlevels,Nhydro)
+    print *,  'shape(x%Reff): ',shape(x%Reff)
+    print *,  'shape(x%Np): ',shape(x%Np)       ! added by roj with Quickbeam V3
+    ! Aerosols concentration and distribution parameters
+    print *,  'shape(x%conc_aero): ',shape(x%conc_aero)
+    print *,  'shape(x%dist_type_aero): ',shape(x%dist_type_aero)
+    print *,  'shape(x%dist_prmts_aero): ',shape(x%dist_prmts_aero)
+    ! ISCCP simulator inputs
+    print *, x%isccp_top_height
+    print *, x%isccp_top_height_direction
+    print *, x%isccp_overlap
+    print *, x%isccp_emsfc_lw
+    ! RTTOV inputs/options
+    print *, x%plat
+    print *, x%sat
+    print *, x%inst
+    print *, x%Nchan
+    print *,  'shape(x%Ichan): ',x%Ichan
+    print *,  'shape(x%Surfem): ',x%Surfem
+    print *, x%ZenAng
+    print *, x%co2,x%ch4,x%n2o,x%co
+END SUBROUTINE COSP_GRIDBOX_PRINT
+SUBROUTINE COSP_MISR_PRINT(x)
+    type(cosp_misr),intent(in) :: x
+    print *, '%%%%----- Information on COSP_MISR ------'
+     ! Dimensions
+    print *, x%Npoints
+    print *, x%Ntau
+    print *, x%Nlevels
+     ! --- (npoints,ntau,nlevels)
+     !  the fraction of the model grid box covered by each of the MISR cloud types
+     print *,  'shape(x%fq_MISR): ',shape(x%fq_MISR)
+     ! --- (npoints)
+     print *,  'shape(x%MISR_meanztop): ',shape(x%MISR_meanztop)
+     print *,  'shape(x%MISR_cldarea): ',shape(x%MISR_cldarea)
+     ! --- (npoints,nlevels)
+     print *,  'shape(x%MISR_dist_model_layertops): ',shape(x%MISR_dist_model_layertops)
+END SUBROUTINE COSP_MISR_PRINT
+SUBROUTINE COSP_ISCCP_PRINT(x)
+    type(cosp_isccp),intent(in) :: x
+    print *, x%Npoints
+    print *, x%Ncolumns
+    print *, x%Nlevels
+    print *, '%%%%----- Information on COSP_ISCCP ------'
+     print *, 'shape(x%fq_isccp): ',shape(x%fq_isccp)
+     print *, 'shape(x%totalcldarea): ',shape(x%totalcldarea)
+     print *, 'shape(x%meantb): ',shape(x%meantb)
+     print *, 'shape(x%meantbclr): ',shape(x%meantbclr)
+     print *, 'shape(x%meanptop): ',shape(x%meanptop)
+     print *, 'shape(x%meantaucld): ',shape(x%meantaucld)
+     print *, 'shape(x%meanalbedocld): ',shape(x%meanalbedocld)
+     print *, 'shape(x%boxtau): ',shape(x%boxtau)
+     print *, 'shape(x%boxptop): ',shape(x%boxptop)
+END SUBROUTINE COSP_ISCCP_PRINT
+SUBROUTINE COSP_VGRID_PRINT(x)
+    type(cosp_vgrid),intent(in) :: x
+    print *, '%%%%----- Information on COSP_VGRID ------'
+    print *, x%use_vgrid
+    print *, x%csat_vgrid
+    print *, x%Npoints
+    print *, x%Ncolumns
+    print *, x%Nlevels
+    print *, x%Nlvgrid
+    ! Array with dimensions (Nlvgrid)
+    print *, 'shape(x%z): ',shape(x%z)
+    print *, 'shape(x%zl): ',shape(x%zl)
+    print *, 'shape(x%zu): ',shape(x%zu)
+    ! Array with dimensions (Nlevels)
+    print *, 'shape(x%mz): ',shape(x%mz)
+    print *, 'shape(x%mzl): ',shape(x%mzl)
+    print *, 'shape(x%mzu): ',shape(x%mzu)
+END SUBROUTINE COSP_VGRID_PRINT
+SUBROUTINE COSP_SGLIDAR_PRINT(x)
+    type(cosp_sglidar),intent(in) :: x
+    print *, '%%%%----- Information on COSP_SGLIDAR ------'
+    ! Dimensions
+    print *, x%Npoints
+    print *, x%Ncolumns
+    print *, x%Nlevels
+    print *, x%Nhydro
+    print *, x%Nrefl
+    ! Arrays with dimensions (Npoints,Nlevels)
+    print *, 'shape(x%beta_mol): ',shape(x%beta_mol)
+    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels)
+    print *, 'shape(x%beta_tot): ',shape(x%beta_tot)
+    print *, 'shape(x%tau_tot): ',shape(x%tau_tot)
+    ! Arrays with dimensions (Npoints,Ncolumns,Nrefl)
+    print *, 'shape(x%refl): ',shape(x%refl)
+END SUBROUTINE COSP_SGLIDAR_PRINT
+SUBROUTINE COSP_SGRADAR_PRINT(x)
+    type(cosp_sgradar),intent(in) :: x
+    print *, '%%%%----- Information on COSP_SGRADAR ------'
+    print *, x%Npoints
+    print *, x%Ncolumns
+    print *, x%Nlevels
+    print *, x%Nhydro
+    ! output vertical levels: spaceborne radar -> from TOA to SURFACE
+    ! Arrays with dimensions (Npoints,Nlevels)
+    print *, 'shape(x%att_gas): ', shape(x%att_gas)
+    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels)
+    print *, 'shape(x%Ze_tot): ', shape(x%Ze_tot)
+END SUBROUTINE COSP_SGRADAR_PRINT
+SUBROUTINE COSP_RADARSTATS_PRINT(x)
+    type(cosp_radarstats),intent(in) :: x
+    print *, '%%%%----- Information on COSP_SGRADAR ------'
+    print *, x%Npoints
+    print *, x%Ncolumns
+    print *, x%Nlevels
+    print *, x%Nhydro
+    print *, 'shape(x%cfad_ze): ',shape(x%cfad_ze)
+    print *, 'shape(x%radar_lidar_tcc): ',shape(x%radar_lidar_tcc)
+    print *, 'shape(x%lidar_only_freq_cloud): ',shape(x%lidar_only_freq_cloud)
+END SUBROUTINE COSP_RADARSTATS_PRINT
+SUBROUTINE COSP_LIDARSTATS_PRINT(x)
+    type(cosp_lidarstats),intent(in) :: x
+    print *, '%%%%----- Information on COSP_SGLIDAR ------'
+    print *, x%Npoints
+    print *, x%Ncolumns
+    print *, x%Nlevels
+    print *, x%Nhydro
+    print *, x%Nrefl
+    ! Arrays with dimensions (SR_BINS)
+    print *, 'shape(x%srbval): ',shape(x%srbval)
+    ! Arrays with dimensions (Npoints,SR_BINS,Nlevels)
+    print *, 'shape(x%cfad_sr): ',shape(x%cfad_sr)
+    ! Arrays with dimensions (Npoints,Nlevels)
+    print *, 'shape(x%lidarcld): ',shape(x%lidarcld)
+    ! Arrays with dimensions (Npoints,LIDAR_NCAT)
+    print *, 'shape(x%cldlayer): ',shape(x%cldlayer)
+    ! Arrays with dimensions (Npoints,PARASOL_NREFL)
+    print *, 'shape(x%parasolrefl): ',shape(x%parasolrefl)
+     ! Arrays with dimensions (Npoints,Nlevels,Nphase)
+    print *, 'shape(x%lidarcldphase): ',shape(x%lidarcldphase)
+     ! Arrays with dimensions (Npoints,LIDAR_NCAT,Nphase)
+    print *, 'shape(x%cldlayerphase): ',shape(x%cldlayerphase)
+     ! Arrays with dimensions (Npoints,Ntemps,Nphase)
+    print *, 'shape(x%lidarcldphase): ',shape(x%lidarcldtmp)
+END SUBROUTINE COSP_LIDARSTATS_PRINT
+SUBROUTINE COSP_SUBGRID_PRINT(x)
+    type(cosp_subgrid),intent(in) :: x
+    print *, '%%%%----- Information on COSP_SUBGRID ------'
+    print *, x%Npoints
+    print *, x%Ncolumns
+    print *, x%Nlevels
+    print *, x%Nhydro
+    print *, 'shape(x%prec_frac): ',shape(x%prec_frac)
+    print *, 'shape(x%frac_out): ',shape(x%frac_out)
+END SUBROUTINE COSP_SUBGRID_PRINT
+SUBROUTINE COSP_SGHYDRO_PRINT(x)
+    type(cosp_sghydro),intent(in) :: x
+    print *, '%%%%----- Information on COSP_SGHYDRO ------'
+    print *, x%Npoints
+    print *, x%Ncolumns
+    print *, x%Nlevels
+    print *, x%Nhydro
+    print *, 'shape(x%mr_hydro): ',shape(x%mr_hydro)
+    print *, 'shape(x%Reff): ',shape(x%Reff)
+    print *, 'shape(x%Np): ',shape(x%Np)         ! added by roj with Quickbeam V3
+END SUBROUTINE COSP_SGHYDRO_PRINT
 END MODULE MOD_COSP_TYPES

LMDZ5/trunk/libf/phylmd/cosp/cosp_utils.F90

-                      r1907
+                      r2428
 ! (c) British Crown Copyright 2008, the Met Office.
 ! All rights reserved.
+! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_utils.F90 $
+!
 ! Redistribution and use in source and binary forms, with or without modification, are permitted
 …
 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 SUBROUTINE COSP_PRECIP_MXRATIO(Npoints,Nlevels,Ncolumns,p,T,prec_frac,prec_type, &
                           n_ax,n_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma1,gamma2, &
                           flux,mxratio)
+                          n_ax,n_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma1,gamma2,gamma3,gamma4, &
+                          flux,mxratio,reff)
     ! Input arguments, (IN)
 …
     real,intent(in),dimension(Npoints,Nlevels) :: p,T,flux
     real,intent(in),dimension(Npoints,Ncolumns,Nlevels) :: prec_frac
     real,intent(in) :: n_ax,n_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma1,gamma2,prec_type
+    real,intent(in) :: n_ax,n_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma1,gamma2,gamma3,gamma4,prec_type
     ! Input arguments, (OUT)
     real,intent(out),dimension(Npoints,Ncolumns,Nlevels) :: mxratio
+    real,intent(inout),dimension(Npoints,Ncolumns,Nlevels) :: reff
     ! Local variables
     integer :: i,j,k
     real :: sigma,one_over_xip1,xi,rho0,rho
+    real :: sigma,one_over_xip1,xi,rho0,rho,lambda_x,gamma_4_3_2,delta
     mxratio = 0.0
     if (n_ax >= 0.0) then ! N_ax is used to control which hydrometeors need to be computed
-        !gamma1  = gamma(alpha_x + b_x + d_x + 1.0)
-        !gamma2  = gamma(alpha_x + b_x + 1.0)
         xi      = d_x/(alpha_x + b_x - n_bx + 1.0)
         rho0    = 1.29
         sigma   = (gamma2/(gamma1*c_x))*(n_ax*a_x*gamma2)**xi
         one_over_xip1 = 1.0/(xi + 1.0)
+        gamma_4_3_2 = 0.5*gamma4/gamma3
+        delta = (alpha_x + b_x + d_x - n_bx + 1.0)
         do k=1,Nlevels
 …
                         mxratio(i,j,k)=(flux(i,k)*((rho/rho0)**g_x)*sigma)**one_over_xip1
                         mxratio(i,j,k)=mxratio(i,j,k)/rho
+                        ! Compute effective radius
+                        if ((reff(i,j,k) <= 0.0).and.(flux(i,k) /= 0.0)) then
+                           lambda_x = (a_x*c_x*((rho0/rho)**g_x)*n_ax*gamma1/flux(i,k))**(1./delta)
+                           reff(i,j,k) = gamma_4_3_2/lambda_x
+                        endif
                     endif
                 enddo

LMDZ5/trunk/libf/phylmd/cosp/dsd.F90

-                      r1907
+                      r2428
   subroutine dsd(Q,Re,D,N,nsizes,dtype,rho_a,tc, &
              dmin,dmax,apm,bpm,rho_c,p1,p2,p3,fc,scaled)
+  subroutine dsd(Q,Re,Np,D,N,nsizes,dtype,rho_a,tk, &
+             dmin,dmax,apm,bpm,rho_c,p1,p2,p3)
   use array_lib
   use math_lib
 …
 ! Purpose:
 !   Create a discrete drop size distribution
+!   Part of QuickBeam v1.03 by John Haynes
+!
+!   Starting with Quickbeam V3, this routine now allows input of
+!   both effective radius (Re) and total number concentration (Nt)
+!   Roj Marchand July 2010
+!
+!   The version in Quickbeam v.104 was modified to allow Re but not Nt
+!   This is a significantly modified form for the version
+!
+!   Originally Part of QuickBeam v1.03 by John Haynes
 !   http://reef.atmos.colostate.edu/haynes/radarsim
+!
 ! Inputs:
+!
 !   [Q]        hydrometeor mixing ratio (g/kg)
+!   [Re]       Optional Effective Radius (microns).  0 = use default.
+!   [D]        discrete drop sizes (um)
+!   [Re]       Optional Effective Radius (microns).  0 = use defaults (p1, p2, p3)
+!
+!   [D]        array of discrete drop sizes (um) where we desire to know the number concentraiton n(D).
 !   [nsizes]   number of elements of [D]
+!
 !   [dtype]    distribution type
 !   [rho_a]    ambient air density (kg m^-3)
 !   [tc]       temperature (C)
+!   [tk]       temperature (K)
 !   [dmin]     minimum size cutoff (um)
 !   [dmax]     maximum size cutoff (um)
 …
+!
 ! Input/Output:
-!   [fc]       scaling factor for the distribution
-!   [scaled]   has this hydrometeor type been scaled?
 !   [apm]      a parameter for mass (kg m^[-bpm])
 !   [bmp]      b params for mass
 …
 !   01/31/06  Port from IDL to Fortran 90
 !   07/07/06  Rewritten for variable DSD's
+!   10/02/06  Rewritten using scaling factors (Roger Marchand and JMH)
+!   10/02/06  Rewritten using scaling factors (Roger Marchand and JMH), Re added V1.04
+!   July 2020 "N Scale factors" (variable fc) removed (Roj Marchand).
 ! ----- INPUTS -----
   integer*4, intent(in) :: nsizes
+  integer, intent(in) :: nsizes
   integer, intent(in) :: dtype
+  real*8, intent(in) :: Q,D(nsizes),rho_a,tc,dmin,dmax, &
+    rho_c,p1,p2,p3
+! ----- INPUT/OUTPUT -----
+  real*8, intent(inout) :: fc(nsizes),apm,bpm,Re
+  logical, intent(inout) :: scaled
+  real*8, intent(in)  :: Q,Re,Np,D(nsizes)
+  real*8, intent(in)  :: rho_a,tk,dmin,dmax,rho_c,p1,p2,p3
+  real*8, intent(inout) :: apm,bpm
 ! ----- OUTPUTS -----
 …
 ! ----- INTERNAL -----
+   real*8 :: fc(nsizes)
   real*8 :: &
   N0,D0,vu,np,dm,ld, &                  ! gamma, exponential variables
   dmin_mm,dmax_mm,ahp,bhp, &            ! power law variables
   rg,log_sigma_g, &                     ! lognormal variables
   rho_e                                 ! particle density (kg m^-3)
+  N0,D0,vu,local_np,dm,ld, &            ! gamma, exponential variables
+  dmin_mm,dmax_mm,ahp,bhp, &        ! power law variables
+  rg,log_sigma_g, &         ! lognormal variables
+  rho_e                 ! particle density (kg m^-3)
   real*8 :: tmp1, tmp2
   real*8 :: pi,rc
+  real*8 :: pi,rc,tc
   integer k,lidx,uidx
+  tc = tk - 273.15
   pi = acos(-1.0)
 ! // if density is constant, store equivalent values for apm and bpm
+  ! // if density is constant, store equivalent values for apm and bpm
   if ((rho_c > 0) .and. (apm < 0)) then
     apm = (pi/6)*rho_c
 …
   endif
+  ! will preferentially use Re input over Np.
+  ! if only Np given then calculate Re
+  ! if neigher than use other defaults (p1,p2,p3) following quickbeam documentation
+  if(Re==0 .and. Np>0) then
+        call calc_Re(Q,Np,rho_a, &
+             dtype,dmin,dmax,apm,bpm,rho_c,p1,p2,p3, &
+             Re)
+  endif
   select case(dtype)
 …
 ! // modified gamma                                        !
 ! ---------------------------------------------------------!
+! :: N0 = total number concentration (m^-3)
+! :: np = fixed number concentration (kg^-1)
+! :: np = total number concentration
 ! :: D0 = characteristic diameter (um)
 ! :: dm = mean diameter (um)
+! :: dm = mean diameter (um) - first moment over zeroth moment
 ! :: vu = distribution width parameter
   case(1)
+    if (abs(p1+1) < 1E-8) then
+!     // D0, vu are given
+    if( abs(p3+2) < 1E-8) then
+    if( Np>1E-30) then
+        ! Morrison scheme with Martin 1994 shape parameter (NOTE: vu = pc +1)
+        ! fixed Roj. Dec. 2010 -- after comment by S. Mcfarlane
+        vu = (1/(0.2714 + 0.00057145*Np*rho_a*1E-6))**2.0 ! units of Nt = Np*rhoa = #/cm^3
+    else
+        print *, 'Error: Must specify a value for Np in each volume', &
+             ' with Morrison/Martin Scheme.'
+            stop
+    endif
+    elseif (abs(p3+1) > 1E-8) then
+      ! vu is fixed in hp structure
       vu = p3
+      if(Re.le.0) then
+        dm = p2
+        D0 = gamma(vu)/gamma(vu+1)*dm
+      else
+        D0 = 2.0*Re*gamma(vu+2)/gamma(vu+3)
+      endif
+      if (scaled .eqv. .false.) then
+    else
+      ! vu isn't specified
+      print *, 'Error: Must specify a value for vu for Modified Gamma distribution'
+      stop
+    endif
+      if(Re>0) then
+    D0 = 2.0*Re*gamma(vu+2)/gamma(vu+3)
         fc = ( &
              ((D*1E-6)**(vu-1)*exp(-1*D/D0)) / &
              (apm*((D0*1E-6)**(vu+bpm))*gamma(vu+bpm)) &
+             ) * 1E-12
+        scaled = .true.
+      endif
+      N = fc*rho_a*(Q*1E-3)
+    elseif (abs(p2+1) < 1E-8) then
+!     // N0, vu are given
+      np = p1
+      vu = p3
+      tmp1 = (Q*1E-3)**(1./bpm)
+      if (scaled .eqv. .false.) then
+        fc = (D*1E-6 / (gamma(vu)/(apm*np*gamma(vu+bpm)))** &
+         ) * 1E-12
+        N = fc*rho_a*(Q*1E-3)
+      elseif( p2+1 > 1E-8) then     ! use default value for MEAN diameter
+        dm = p2
+    D0 = gamma(vu)/gamma(vu+1)*dm
+        fc = ( &
+             ((D*1E-6)**(vu-1)*exp(-1*D/D0)) / &
+             (apm*((D0*1E-6)**(vu+bpm))*gamma(vu+bpm)) &
+         ) * 1E-12
+        N = fc*rho_a*(Q*1E-3)
+      elseif(abs(p3+1) > 1E-8)  then! use default number concentration
+        local_np = p1 ! total number concentration / pa check
+    tmp1 = (Q*1E-3)**(1./bpm)
+        fc = (D*1E-6 / (gamma(vu)/(apm*local_np*gamma(vu+bpm)))** &
              (1./bpm))**vu
+        scaled = .true.
+        N = ( &
+          (rho_a*local_np*fc*(D*1E-6)**(-1.))/(gamma(vu)*tmp1**vu) * &
+          exp(-1.*fc**(1./vu)/tmp1) &
+      ) * 1E-12
+      else
+        print *, 'Error:  No default value for Dm or Np provided!  '
+        stop
       endif
+      N = ( &
+          (rho_a*np*fc*(D*1E-6)**(-1.))/(gamma(vu)*tmp1**vu) * &
+          exp(-1.*fc**(1./vu)/tmp1) &
+          ) * 1E-12
+    else
+!     // vu isn't given
+      print *, 'Error: Must specify a value for vu'
+      stop
+    endif
 ! ---------------------------------------------------------!
 …
   case(2)
+    if (abs(p1+1) > 1E-8) then
+!     // N0 has been specified, determine ld
+      N0 = p1
+      if(Re>0) then
+        ! if Re is set and No is set than the distribution is fully defined.
+        ! so we assume Re and No have already been chosen consistant with
+        ! the water content, Q.
+        ! print *,'using Re pass ...'
+        ld = 1.5/Re   ! units 1/um
+        N = ( &
+                N0*exp(-1*ld*D) &
+        ) * 1E-12
+      else
+        tmp1 = 1./(1.+bpm)
+        if (scaled .eqv. .false.) then
+                fc = ((apm*gamma(1.+bpm)*N0)**tmp1)*(D*1E-6)
+                scaled = .true.
+        endif
+    if(Re>0) then
+        ld = 1.5/Re   ! units 1/um
+    fc = (ld*1E6)**(1.+bpm)/(apm*gamma(1+bpm))* &
+               exp(-1.*(ld*1E6)*(D*1E-6))*1E-12
+        N = ( &
+                N0*exp(-1.*fc*(1./(rho_a*Q*1E-3))**tmp1) &
+        ) * 1E-12
+      endif
+        N = fc*rho_a*(Q*1E-3)
+    elseif (abs(p1+1) > 1E-8) then
+    ! use N0 default value
+        N0 = p1
+        tmp1 = 1./(1.+bpm)
+        fc = ((apm*gamma(1.+bpm)*N0)**tmp1)*(D*1E-6)
+        N = ( &
+            N0*exp(-1.*fc*(1./(rho_a*Q*1E-3))**tmp1) &
+    ) * 1E-12
     elseif (abs(p2+1) > 1E-8) then
+!     // ld has been specified, determine N0
+      ld = p2
+      if (scaled .eqv. .false.) then
+    !     used default value for lambda
+        ld = p2
         fc = (ld*1E6)**(1.+bpm)/(apm*gamma(1+bpm))* &
              exp(-1.*(ld*1E6)*(D*1E-6))*1E-12
+        scaled = .true.
+      endif
+      N = fc*rho_a*(Q*1E-3)
+    else
+!     // ld will be determined from temperature, then N0 follows
+        N = fc*rho_a*(Q*1E-3)
+    else
+      !  ld "parameterized" from temperature (carry over from original Quickbeam).
       ld = 1220*10.**(-0.0245*tc)*1E-6
       N0 = ((ld*1E6)**(1+bpm)*Q*1E-3*rho_a)/(apm*gamma(1+bpm))
 …
   case(3)
+    if(Re>0) then
+        print *, 'Variable Re not supported for ', &
+         'Power-Law distribution'
+    stop
+    elseif(Np>0) then
+        print *, 'Variable Np not supported for ', &
+         'Power-Law distribution'
+    stop
+    endif
 !   :: br parameter
 …
 !   :: commented lines are original method with constant density
       ! rc = 500.               ! (kg/m^3)
+      ! rc = 500.       ! (kg/m^3)
       ! tmp1 = 6*rho_a*(bhp+4)
       ! tmp2 = pi*rc*(dmax_mm**(bhp+4))*(1-(dmin_mm/dmax_mm)**(bhp+4))
 …
       do k=lidx,uidx
         N(k) = ( &
+        N(k) = ( &
         ahp*(D(k)*1E-3)**bhp &
         ) * 1E-12
+    ) * 1E-12
       enddo
         ! print *,'test=',ahp,bhp,ahp/(rho_a*Q),D(100),N(100),bpm,dmin_mm,dmax_mm
+    ! print *,'test=',ahp,bhp,ahp/(rho_a*Q),D(100),N(100),bpm,dmin_mm,dmax_mm
 ! ---------------------------------------------------------!
 …
   case(4)
+    if (scaled .eqv. .false.) then
+      D0 = p1
+    if (Re>0) then
+        D0 = Re
+    else
+        D0 = p1
+    endif
       rho_e = (6/pi)*apm*(D0*1E-6)**(bpm-3)
       fc(1) = (6./(pi*D0**3*rho_e))*1E12
+      scaled = .true.
+    endif
+    N(1) = fc(1)*rho_a*(Q*1E-3)
+      N(1) = fc(1)*rho_a*(Q*1E-3)
 ! ---------------------------------------------------------!
 …
   case(5)
     if (abs(p1+1) < 1E-8) then
+    if (abs(p1+1) < 1E-8 .or. Re>0 ) then
 !     // rg, log_sigma_g are given
 …
       tmp2 = (bpm*log_sigma_g)**2.
       if(Re.le.0) then
         rg = p2
       else
         rg =Re*exp(-2.5*(log_sigma_g**2))
+        rg = p2
+      else
+    rg =Re*exp(-2.5*(log_sigma_g**2))
       endif
+      if (scaled .eqv. .false.) then
+        fc = 0.5 * ( &
+             (1./((2.*rg*1E-6)**(bpm)*apm*(2.*pi)**(0.5) * &
+             log_sigma_g*D*0.5*1E-6)) * &
+             exp(-0.5*((log(0.5*D/rg)/log_sigma_g)**2.+tmp2)) &
+             ) * 1E-12
+        scaled = .true.
+         fc = 0.5 * ( &
+         (1./((2.*rg*1E-6)**(bpm)*apm*(2.*pi)**(0.5) * &
+         log_sigma_g*D*0.5*1E-6)) * &
+         exp(-0.5*((log(0.5*D/rg)/log_sigma_g)**2.+tmp2)) &
+         ) * 1E-12
+      N = fc*rho_a*(Q*1E-3)
+    elseif (abs(p2+1) < 1E-8 .or. Np>0) then
+!     // Np, log_sigma_g are given
+      if(Np>0) then
+        local_Np=Np
+      else
+        local_Np = p1
       endif
+      N = fc*rho_a*(Q*1E-3)
+    elseif (abs(p2+1) < 1E-8) then
+!     // N0, log_sigma_g are given
+      Np = p1
       log_sigma_g = p3
       N0 = np*rho_a
+      N0 = local_np*rho_a
       tmp1 = (rho_a*(Q*1E-3))/(2.**bpm*apm*N0)
       tmp2 = exp(0.5*bpm**2.*(log_sigma_g))**2.
 …
       N = 0.5*( &
         N0 / ((2.*pi)**(0.5)*log_sigma_g*D*0.5*1E-6) * &
+        exp((-0.5*(log(0.5*D/rg)/log_sigma_g)**2.)) &
+        ) * 1E-12
+    else
+!     // vu isn't given
+    exp((-0.5*(log(0.5*D/rg)/log_sigma_g)**2.)) &
+    ) * 1E-12
+    else
       print *, 'Error: Must specify a value for sigma_g'
       stop

LMDZ5/trunk/libf/phylmd/cosp/format_input.F90

r1907	r2428
	1	! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
	2	! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/format_input.f90 $
1	3	! FORMAT_INPUT: Procedures to prepare data for input to the simulator
2	4	! Compiled/Modified:

LMDZ5/trunk/libf/phylmd/cosp/gases.F90

-                      r1907
+                      r2428
+! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/gases.f90 $
   function gases(PRES_mb,T,RH,f)
   implicit none
 …
   real*8, dimension(nbands_o2) :: v0, a1, a2, a3, a4, a5, a6
   real*8, dimension(nbands_h2o) :: v1, b1, b2, b3
+  real*8 :: e_th,one_th,pth3,eth35,aux1,aux2,aux3,aux4
+  real*8 :: gm,delt,x,y,gm2
+  real*8 :: fpp_o2,fpp_h2o,s_o2,s_h2o
   integer :: i
 …
 ! // conversions
+  th = 300./T           ! unitless
+  e = (RH*th**5)/(41.45*10**(9.834*th-10))      ! kPa
+  p = PRES_mb/10.-e     ! kPa
+  th = 300./T       ! unitless
+  e = (RH*th**5)/(41.45*10**(9.834*th-10))   ! kPa
+  p = PRES_mb/10.-e ! kPa
+  e_th = e*th
+  one_th = 1 - th
+  pth3 = p*th**(3)
+  eth35 = e*th**(3.5)
 ! // term1
   sumo = 0.
+  aux1 = 1.1*e_th
   do i=1,nbands_o2
+    sumo = sumo + fpp_o2(p,th,e,a3(i),a4(i),a5(i),a6(i),f,v0(i)) &
+           * s_o2(p,th,a1(i),a2(i))
+    aux2 = f/v0(i)
+    aux3 = v0(i)-f
+    aux4 = v0(i)+f
+    gm = a3(i)*(p*th**(0.8-a4(i))+aux1)
+    gm2 = gm**2
+    delt = a5(i)*p*th**a6(i)
+    x = aux3**2+gm2
+    y = aux4**2+gm2
+    fpp_o2 = (((1./x)+(1./y))*(gm*aux2) - (delt*aux2)*((aux3/(x))-(aux4/(x))))
+    s_o2 = a1(i)*pth3*exp(a2(i)*one_th)
+    sumo = sumo + fpp_o2 * s_o2
   enddo
   term1 = sumo
 …
 ! // term3
   sumo = 0.
+  aux1 = 4.8*e_th
   do i=1,nbands_h2o
+    sumo = sumo + fpp_h2o(p,th,e,b3(i),f,v1(i)) &
+           * s_h2o(th,e,b1(i),b2(i))
+    aux2 = f/v1(i)
+    aux3 = v1(i)-f
+    aux4 = v1(i)+f
+    gm = b3(i)*(p*th**(0.8)+aux1)
+    gm2 = gm**2
+    x = aux3**2+gm2
+    y = aux4**2+gm2
+    !delt = 0.
+    fpp_h2o = ((1./x)+(1./y))*(gm*aux2) ! - (delt*aux2)*((aux3/(x))-(aux4/(x)))
+    s_h2o = b1(i)*eth35*exp(b2(i)*one_th)
+    sumo = sumo + fpp_h2o * s_h2o
   enddo
   term3 = sumo
 …
   gases = 0.182*f*npp
-! ----- SUB FUNCTIONS -----
-  contains
-  function fpp_o2(p,th,e,a3,a4,a5,a6,f,v0)
-  real*8 :: fpp_o2,p,th,e,a3,a4,a5,a6,f,v0
-  real*8 :: gm, delt, x, y
-  gm = a3*(p*th**(0.8-a4)+1.1*e*th)
-  delt = a5*p*th**(a6)
-  x = (v0-f)**2+gm**2
-  y = (v0+f)**2+gm**2
-  fpp_o2 = ((1./x)+(1./y))*(gm*f/v0) - (delt*f/v0)*(((v0-f)/(x))-((v0+f)/(x)))
-  end function fpp_o2
-  function fpp_h2o(p,th,e,b3,f,v0)
-  real*8 :: fpp_h2o,p,th,e,b3,f,v0
-  real*8 :: gm, delt, x, y
-  gm = b3*(p*th**(0.8)+4.8*e*th)
-  delt = 0.
-  x = (v0-f)**2+gm**2
-  y = (v0+f)**2+gm**2
-  fpp_h2o = ((1./x)+(1./y))*(gm*f/v0) - (delt*f/v0)*(((v0-f)/(x))-((v0+f)/(x)))
-  end function fpp_h2o
-  function s_o2(p,th,a1,a2)
-  real*8 :: s_o2,p,th,a1,a2
-  s_o2 = a1*p*th**(3)*exp(a2*(1-th))
-  end function s_o2
-  function s_h2o(th,e,b1,b2)
-  real*8 :: s_h2o,th,e,b1,b2
-  s_h2o = b1*e*th**(3.5)*exp(b2*(1-th))
-  end function s_h2o
   end function gases

LMDZ5/trunk/libf/phylmd/cosp/icarus.F

r1907	r2428
	1	! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
	2	! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/icarus-scops-4.1-bsd/icarus.f $
1	3	SUBROUTINE ICARUS(
2	4	& debug,

LMDZ5/trunk/libf/phylmd/cosp/lidar_simulator.F90

-                      r1907
+                      r2428
 ! Copyright (c) 2009, Centre National de la Recherche Scientifique
 ! All rights reserved.
+! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/actsim/lidar_simulator.F90 $
+!
 ! Redistribution and use in source and binary forms, with or without modification, are permitted
 …
                 , q_lsliq, q_lsice, q_cvliq, q_cvice &
                 , ls_radliq, ls_radice, cv_radliq, cv_radice &
+                , frac_out, ice_type &
+                , pmol, pnorm, tautot, refl )
+                , ice_type, pmol, pnorm, pnorm_perp_tot,tautot, refl )
+!
 !---------------------------------------------------------------------------------
 …
 ! - Bug fix in computation of pmol and pnorm, thanks to Masaki Satoh: a factor 2
 ! was missing. This affects the ATB values but not the cloud fraction.
+!
+! January 2013, G. Cesana and H. Chepfer:
+! - Add the perpendicular component of the backscattered signal (pnorm_perp_tot) in the arguments
+! - Add the temperature for each levels (temp) in the arguments
+! - Add the computation of the perpendicular component of the backscattered lidar signal
+! Reference: Cesana G. and H. Chepfer (2013): Evaluation of the cloud water phase
+! in a climate model using CALIPSO-GOCCP, J. Geophys. Res., doi: 10.1002/jgrd.50376
+!
 !---------------------------------------------------------------------------------
 …
 !  cv_radliq: effective radius of CONV liquid particles (meters)
 !  cv_radice: effective radius of CONV ice particles (meters)
-!  frac_out : cloud cover in each sub-column of the gridbox (output from scops)
 !  ice_type : ice particle shape hypothesis (ice_type=0 for spheres, ice_type=1
 !             for non spherical particles)
 …
 !  pmol : molecular attenuated backscatter lidar signal power (m^-1.sr^-1)
 !  pnorm: total attenuated backscatter lidar signal power (m^-1.sr^-1)
+!  pnorm_perp_tot: perpendicular attenuated backscatter lidar signal power (m^-1.sr^-1)
 !  tautot: optical thickess integrated from top to level z
 !  refl : parasol(polder) reflectance
 …
       REAL pres(npoints,nlev)    ! pressure full levels
       REAL presf(npoints,nlev+1) ! pressure half levels
-      REAL temp(npoints,nlev)
       REAL q_lsliq(npoints,nlev), q_lsice(npoints,nlev)
       REAL q_cvliq(npoints,nlev), q_cvice(npoints,nlev)
       REAL ls_radliq(npoints,nlev), ls_radice(npoints,nlev)
       REAL cv_radliq(npoints,nlev), cv_radice(npoints,nlev)
-      REAL frac_out(npoints,nlev)
 ! outputs (for each subcolumn):
 …
 !   sub-column variables:
-      REAL frac_sub(npoints,nlev)
       REAL qpart(npoints,nlev,npart) ! mixing ratio particles in each subcolumn
       REAL alpha_part(npoints,nlev,npart)
 …
       REAL tautot_lay(npoints)   ! temporary variable, total opt. thickness of layer k
 !     Optical thickness from TOA to surface for Parasol
+      REAL tautot_S_liq(npoints),tautot_S_ice(npoints)     ! for liq and ice clouds
+! Abderrahmane 8-2-2011
+      Logical iflag_testlidar
+      PARAMETER (iflag_testlidar=.false.)
+     REAL tautot_S_liq(npoints),tautot_S_ice(npoints)     ! for liq and ice clouds
+! Local variables
+      REAL Alpha, Beta, Gamma  ! Polynomial coefficient for ATBperp computation
+      REAL temp(npoints,nlev)                   ! temperature of layer k
+      REAL betatot_ice(npoints,nlev)    ! backscatter coefficient for ice particles
+      REAL beta_perp_ice(npoints,nlev)  ! perpendicular backscatter coefficient for ice
+      REAL betatot_liq(npoints,nlev)    ! backscatter coefficient for liquid particles
+      REAL beta_perp_liq(npoints,nlev)  ! perpendicular backscatter coefficient for liq
+      REAL tautot_ice(npoints,nlev)     ! total optical thickness of ice
+      REAL tautot_liq(npoints,nlev)     ! total optical thickness of liq
+      REAL tautot_lay_ice(npoints)    ! total optical thickness of ice in the layer k
+      REAL tautot_lay_liq(npoints)    ! total optical thickness of liq in the layer k
+      REAL pnorm_liq(npoints,nlev)    ! lidar backscattered signal power for liquid
+      REAL pnorm_ice(npoints,nlev)    ! lidar backscattered signal power for ice
+      REAL pnorm_perp_ice(npoints,nlev) ! perpendicular lidar backscattered signal power for ice
+      REAL pnorm_perp_liq(npoints,nlev) ! perpendicular lidar backscattered signal power for liq
+! Output variable
+      REAL pnorm_perp_tot (npoints,nlev) ! perpendicular lidar backscattered signal power
+!------------------------------------------------------------
+!---- 0. Initialisation :
+!------------------------------------------------------------
+betatot_ice(:,:)=0
+betatot_liq(:,:)=0
+beta_perp_ice(:,:)=0
+beta_perp_liq(:,:)=0
+tautot_ice(:,:)=0
+tautot_liq(:,:)=0
+tautot_lay_ice(:)=0;
+tautot_lay_liq(:)=0;
+pnorm_liq(:,:)=0
+pnorm_ice(:,:)=0
+pnorm_perp_ice(:,:)=0
+pnorm_perp_liq(:,:)=0
+pnorm_perp_tot(:,:)=0
+! Polynomial coefficients (Alpha, Beta, Gamma) which allow to compute the ATBperpendicular
+! as a function of the ATB for ice or liquid cloud particles derived from CALIPSO-GOCCP
+! observations at 120m vertical grid (Cesana and Chepfer, JGR, 2013).
+!
+! Relationship between ATBice and ATBperp,ice for ice particles
+!  ATBperp,ice = Alpha*ATBice
+         Alpha = 0.2904
+! Relationship between ATBice and ATBperp,ice for liquid particles
+!  ATBperp,ice = Beta*ATBice^2 + Gamma*ATBice
+         Beta = 0.4099
+         Gamma = 0.009
 !------------------------------------------------------------
 …
 ! We repeat the same coefficients for LS and CONV cloud to make code more readable
 !*     LS Liquid water coefficients:
          polpart(INDX_LSLIQ,1) =  2.6980e-8
+         polpart(INDX_LSLIQ,1) =  2.6980e-8
          polpart(INDX_LSLIQ,2) = -3.7701e-6
          polpart(INDX_LSLIQ,3) =  1.6594e-4
 …
 !*     LS Ice coefficients:
       if (ice_type.eq.0) then
          polpart(INDX_LSICE,1) = -1.0176e-8
+         polpart(INDX_LSICE,1) = -1.0176e-8
          polpart(INDX_LSICE,2) =  1.7615e-6
          polpart(INDX_LSICE,3) = -1.0480e-4
 …
 !*     LS Ice NS coefficients:
       if (ice_type.eq.1) then
          polpart(INDX_LSICE,1) = 1.3615e-8
          polpart(INDX_LSICE,2) = -2.04206e-6
+         polpart(INDX_LSICE,1) = 1.3615e-8
+         polpart(INDX_LSICE,2) = -2.04206e-6
          polpart(INDX_LSICE,3) = 7.51799e-5
          polpart(INDX_LSICE,4) = 0.00078213
 …
       endif
 !*     CONV Liquid water coefficients:
          polpart(INDX_CVLIQ,1) =  2.6980e-8
+         polpart(INDX_CVLIQ,1) =  2.6980e-8
          polpart(INDX_CVLIQ,2) = -3.7701e-6
          polpart(INDX_CVLIQ,3) =  1.6594e-4
 …
 !*     CONV Ice coefficients:
       if (ice_type.eq.0) then
          polpart(INDX_CVICE,1) = -1.0176e-8
+         polpart(INDX_CVICE,1) = -1.0176e-8
          polpart(INDX_CVICE,2) =  1.7615e-6
          polpart(INDX_CVICE,3) = -1.0480e-4
 …
                   -(presf(:,k)-presf(:,k-1))/(rhoair(:,k-1)*9.81)
       enddo
-! cloud fraction (0 or 1) in each sub-column:
-! (if frac_out=1or2 -> frac_sub=1; if frac_out=0 -> frac_sub=0)
-      frac_sub = MIN( frac_out, 1.0 )
 !------------------------------------------------------------
 …
 !------------------------------------------------------------
 !---- 4. Backscatter signal:
+!---- 4.1 Total Backscatter signal:
 !------------------------------------------------------------
 …
         END WHERE
       END DO
+!
 ! Total signal (molecular + particules):
+!
+!
 ! For performance reason on vector computers, the 2 following lines should not be used
 …
       pnorm(:,nlev) = betatot(:,nlev) / (2.*tautot(:,nlev)) &
             & * (1.-exp(-2.0*tautot(:,nlev)))
 !     Other layers
       DO k= nlev-1, 1, -1
         tautot_lay(:) = tautot(:,k)-tautot(:,k+1) ! optical thickness of layer k
+          tautot_lay(:) = tautot(:,k)-tautot(:,k+1) ! optical thickness of layer k
         WHERE (tautot_lay(:).GT.0.)
+       pnorm(:,k) = betatot(:,k) * EXP(-2.0*tautot(:,k+1)) / (2.*tautot_lay(:)) &
+!correc          pnorm(:,k) = betatot(:,k) * EXP(-2.0*tautot(:,k+1)) & ! correc Satoh
+!correc               &               / (2.0*tautot_lay(:)) &          ! correc Satoh
+          pnorm(:,k) = betatot(:,k) * EXP(-2.0*tautot(:,k+1)) / (2.*tautot_lay(:)) &
                & * (1.-EXP(-2.0*tautot_lay(:)))
         ELSEWHERE
 …
       END DO
+     if (iflag_testlidar) then
+!+JLD test
+!     do k=1,nlev
+!      print*,'Min val de frac_out=',k,minval(frac_out(:,k))
+!      print*,'Max val de frac_out=',k,maxval(frac_out(:,k))
+!     enddo
+       where ( frac_out(:,:).ge.0.5)
+! Correction AI 9 5 11          pnorm(:,:) = pmol(:,:)*10.
+       pnorm(:,:) = pmol(:,:)*50.
+        elsewhere
+          pnorm(:,:) = pmol(:,:)
+        endwhere
+!-JLD test
+     endif
+!------------------------------------------------------------
+!---- 4.2 Ice/Liq Backscatter signal:
+!------------------------------------------------------------
+! Contribution of the molecular to beta
+      betatot_ice(:,:) = beta_mol(:,:)
+      betatot_liq(:,:) = beta_mol(:,:)
+      tautot_ice(:,:) = tau_mol(:,:)
+      tautot_liq(:,:) = tau_mol(:,:)
+      DO i = 2, npart,2
+           betatot_ice(:,:) = betatot_ice(:,:)+ kp_part(:,:,i)*alpha_part(:,:,i)
+           tautot_ice(:,:) = tautot_ice(:,:)  + tau_part(:,:,i)
+      ENDDO ! i
+      DO i = 1, npart,2
+           betatot_liq(:,:) = betatot_liq(:,:)+ kp_part(:,:,i)*alpha_part(:,:,i)
+           tautot_liq(:,:) = tautot_liq(:,:)  + tau_part(:,:,i)
+      ENDDO ! i
+! Computation of the ice and liquid lidar backscattered signal (ATBice and ATBliq)
+!     Ice only
+!     Upper layer
+      pnorm_ice(:,nlev) = betatot_ice(:,nlev) / (2.*tautot_ice(:,nlev)) &
+            & * (1.-exp(-2.0*tautot_ice(:,nlev)))
+      DO k= nlev-1, 1, -1
+          tautot_lay_ice(:) = tautot_ice(:,k)-tautot_ice(:,k+1)
+        WHERE (tautot_lay_ice(:).GT.0.)
+         pnorm_ice(:,k)=betatot_ice(:,k)*EXP(-2.0*tautot_ice(:,k+1))/(2.*tautot_lay_ice(:)) &
+               & * (1.-EXP(-2.0*tautot_lay_ice(:)))
+        ELSEWHERE
+         pnorm_ice(:,k)=betatot_ice(:,k)*EXP(-2.0*tautot_ice(:,k+1))
+        END WHERE
+      ENDDO
+!     Liquid only
+!     Upper layer
+      pnorm_liq(:,nlev) = betatot_liq(:,nlev) / (2.*tautot_liq(:,nlev)) &
+            & * (1.-exp(-2.0*tautot_liq(:,nlev)))
+      DO k= nlev-1, 1, -1
+          tautot_lay_liq(:) = tautot_liq(:,k)-tautot_liq(:,k+1)
+        WHERE (tautot_lay_liq(:).GT.0.)
+          pnorm_liq(:,k)=betatot_liq(:,k)*EXP(-2.0*tautot_liq(:,k+1))/(2.*tautot_lay_liq(:)) &
+               & * (1.-EXP(-2.0*tautot_lay_liq(:)))
+        ELSEWHERE
+          pnorm_liq(:,k)=betatot_liq(:,k)*EXP(-2.0*tautot_liq(:,k+1))
+        END WHERE
+      ENDDO
+! Computation of ATBperp,ice/liq from ATBice/liq including the multiple scattering
+! contribution (Cesana and Chepfer 2013, JGR)
+!  ATBperp,ice = Alpha*ATBice
+!  ATBperp,liq = Beta*ATBliq^2 + Gamma*ATBliq
+      DO k= nlev, 1, -1
+              pnorm_perp_ice(:,k) = Alpha * pnorm_ice(:,k) ! Ice particles
+              pnorm_perp_liq(:,k) = 1000*Beta * pnorm_liq(:,k)**2 + Gamma * pnorm_liq(:,k) ! Liquid particles
+      ENDDO
+! Computation of beta_perp_ice/liq using the lidar equation
+!     Ice only
+!     Upper layer
+      beta_perp_ice(:,nlev) = pnorm_perp_ice(:,nlev) * (2.*tautot_ice(:,nlev)) &
+            & / (1.-exp(-2.0*tautot_ice(:,nlev)))
+      DO k= nlev-1, 1, -1
+        tautot_lay_ice(:) = tautot_ice(:,k)-tautot_ice(:,k+1)
+        WHERE (tautot_lay_ice(:).GT.0.)
+         beta_perp_ice(:,k) = pnorm_perp_ice(:,k)/ EXP(-2.0*tautot_ice(:,k+1)) * (2.*tautot_lay_ice(:)) &
+            & / (1.-exp(-2.0*tautot_lay_ice(:)))
+        ELSEWHERE
+         beta_perp_ice(:,k)=pnorm_perp_ice(:,k)/EXP(-2.0*tautot_ice(:,k+1))
+        END WHERE
+      ENDDO
+!     Liquid only
+!     Upper layer
+      beta_perp_liq(:,nlev) = pnorm_perp_liq(:,nlev) * (2.*tautot_liq(:,nlev)) &
+            & / (1.-exp(-2.0*tautot_liq(:,nlev)))
+      DO k= nlev-1, 1, -1
+          tautot_lay_liq(:) = tautot_liq(:,k)-tautot_liq(:,k+1)
+        WHERE (tautot_lay_liq(:).GT.0.)
+         beta_perp_liq(:,k) = pnorm_perp_liq(:,k)/ EXP(-2.0*tautot_liq(:,k+1)) * (2.*tautot_lay_liq(:)) &
+            & / (1.-exp(-2.0*tautot_lay_liq(:)))
+        ELSEWHERE
+         beta_perp_liq(:,k)=pnorm_perp_liq(:,k)/EXP(-2.0*tautot_liq(:,k+1))
+        END WHERE
+      ENDDO
+!------------------------------------------------------------
+!---- 4.3 Perpendicular Backscatter signal:
+!------------------------------------------------------------
+! Computation of the total perpendicular lidar signal (ATBperp for liq+ice)
+!     Upper layer
+    WHERE(tautot(:,nlev).GT.0)
+          pnorm_perp_tot(:,nlev) = &
+              (beta_perp_ice(:,nlev)+beta_perp_liq(:,nlev)-(beta_mol(:,nlev)/(1+1/0.0284))) / (2.*tautot(:,nlev)) &
+              & * (1.-exp(-2.0*tautot(:,nlev)))
+    ELSEWHERE
+    pnorm_perp_tot(:,nlev) = 0.
+    ENDWHERE
+!     Other layers
+      DO k= nlev-1, 1, -1
+          tautot_lay(:) = tautot(:,k)-tautot(:,k+1) ! optical thickness of layer k
+          ! The perpendicular component of the molecular backscattered signal (Betaperp) has been
+          ! taken into account two times (once for liquid and once for ice).
+          ! We remove one contribution using
+          ! Betaperp=beta_mol(:,k)/(1+1/0.0284)) [bodhaine et al. 1999] in the following equations:
+            WHERE (pnorm(:,k).eq.0)
+                  pnorm_perp_tot(:,k)=0.
+                  ELSEWHERE
+                    WHERE (tautot_lay(:).GT.0.)
+                      pnorm_perp_tot(:,k) = &
+                          (beta_perp_ice(:,k)+beta_perp_liq(:,k)-(beta_mol(:,k)/(1+1/0.0284))) * &
+                          EXP(-2.0*tautot(:,k+1)) / (2.*tautot_lay(:)) &
+                          & * (1.-EXP(-2.0*tautot_lay(:)))
+                    ELSEWHERE
+          !         This must never happen, but just in case, to avoid div. by 0
+                      pnorm_perp_tot(:,k) = &
+                           (beta_perp_ice(:,k)+beta_perp_liq(:,k)-(beta_mol(:,k)/(1+1/0.0284))) * &
+                          EXP(-2.0*tautot(:,k+1))
+                    END WHERE
+            ENDWHERE
+      END DO
 !-------- End computation Lidar --------------------------

LMDZ5/trunk/libf/phylmd/cosp/llnl_stats.F90

-                      r1907
+                      r2428
 ! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation.
 ! All rights reserved.
+! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/llnl/llnl_stats.F90 $
+!
 ! Redistribution and use in source and binary forms, with or without modification, are permitted
 …
 ! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
 ! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History
+!
+! Jan 2013 - G. Cesana        - Added betaperp_tot and temp_tot arguments
+!
 MODULE MOD_LLNL_STATS
 …
 !------------- SUBROUTINE COSP_LIDAR_ONLY_CLOUD -----------------
 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_LIDAR_ONLY_CLOUD(Npoints,Ncolumns,Nlevels,beta_tot,beta_mol,Ze_tot,lidar_only_freq_cloud,tcc)
+SUBROUTINE COSP_LIDAR_ONLY_CLOUD(Npoints,Ncolumns,Nlevels,temp_tot,beta_tot, &
+                   betaperp_tot,beta_mol,Ze_tot,lidar_only_freq_cloud,tcc)
    ! Input arguments
    integer,intent(in) :: Npoints,Ncolumns,Nlevels
    real,dimension(Npoints,Nlevels),intent(in) :: beta_mol   ! Molecular backscatter
    real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: beta_tot   ! Total backscattered signal
+   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: temp_tot   ! Total backscattered signal
+   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: betaperp_tot   ! perpendicular Total backscattered signal
    real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: Ze_tot     ! Radar reflectivity
    ! Output arguments
    real,dimension(Npoints,Nlevels),intent(out) :: lidar_only_freq_cloud
    real,dimension(Npoints),intent(out) :: tcc
    ! local variables
    real :: sc_ratio
    real :: s_cld, s_att
+!      parameter (S_cld = 3.0)  ! Previous thresold for cloud detection
+   parameter (S_cld = 5.0)  ! New (dec 2008) thresold for cloud detection
+   parameter (S_cld = 5.0)
    parameter (s_att = 0.01)
    integer :: flag_sat !first saturated level encountered from top
    integer :: flag_cld !cloudy column
    integer :: pr,i,j
    lidar_only_freq_cloud = 0.0
    tcc = 0.0
 …
        do j=Nlevels,1,-1 !top->surf
         sc_ratio = beta_tot(pr,i,j)/beta_mol(pr,j)
-!         if ((pr == 1).and.(j==8)) print *, pr,i,j,sc_ratio,Ze_tot(pr,i,j)
         if ((sc_ratio .le. s_att) .and. (flag_sat .eq. 0)) flag_sat = j
         if (Ze_tot(pr,i,j) .lt. -30.) then  !radar can't detect cloud
          if ( (sc_ratio .gt. s_cld) .or. (flag_sat .eq. j) ) then  !lidar sense cloud
-!             if ((pr == 1).and.(j==8)) print *, 'L'
             lidar_only_freq_cloud(pr,j)=lidar_only_freq_cloud(pr,j)+1. !top->surf
             flag_cld=1
          endif
         else  !radar sense cloud (z%Ze_tot(pr,i,j) .ge. -30.)
-!            if ((pr == 1).and.(j==8)) print *, 'R'
            flag_cld=1
         endif
 …
        if (flag_cld .eq. 1) tcc(pr)=tcc(pr)+1.
      enddo !columns
-!      if (tcc(pr) > Ncolumns) then
-!      print *, 'tcc(',pr,'): ', tcc(pr)
-!      tcc(pr) = Ncolumns
-!      endif
    enddo !points
    lidar_only_freq_cloud=lidar_only_freq_cloud/Ncolumns

LMDZ5/trunk/libf/phylmd/cosp/lmd_ipsl_stats.F90

-                      r1907
+                      r2428
 ! Copyright (c) 2009, Centre National de la Recherche Scientifique
 ! All rights reserved.
+! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/actsim/lmd_ipsl_stats.F90 $
+!
 ! Redistribution and use in source and binary forms, with or without modification, are permitted
 …
 CONTAINS
       SUBROUTINE diag_lidar(npoints,ncol,llm,max_bin,nrefl &
                   ,pnorm,pmol,refl,land,pplay,undef,ok_lidar_cfad &
                   ,cfad2,srbval &
                   ,ncat,lidarcld,cldlayer,parasolrefl)
+                  ,tmp,pnorm,pnorm_perp,pmol,refl,land,pplay,undef,ok_lidar_cfad &
+                  ,cfad2,srbval,ncat,lidarcld,lidarcldphase,cldlayer,cldlayerphase &
+                  ,lidarcldtmp,parasolrefl)
+!
 ! -----------------------------------------------------------------------------------
 ! Lidar outputs :
+!
+! Diagnose cloud fraction (3D cloud fraction + low/middle/high/total cloud fraction
+! from the lidar signals (ATB and molecular ATB) computed from model outputs
+! Diagnose cloud fraction (3D cloud fraction + low/middle/high/total cloud fraction)
+! and phase cloud fraction (3D, low/mid/high/total and 3D temperature)
+! from the lidar signals (ATB, ATBperp and molecular ATB) computed from model outputs
 !      +
 ! Compute CFADs of lidar scattering ratio SR and of depolarization index
 …
 ! Optimisation of COSP_CFAD_SR
+!
+! Version 1.0 (June 2007)
+! Version 1.1 (May 2008)
+! Version 1.2 (June 2008)
+! Version 2.0 (October 2008)
+! Version 2.1 (December 2008)
+! c------------------------------------------------------------------------------------
+! January 2013, G. Cesana, H. Chepfer:
+! - Add the perpendicular component of the backscattered signal (pnorm_perp) in the arguments
+! - Add the temperature (tmp) in the arguments
+! - Add the 3D Phase cloud fraction (lidarcldphase) in the arguments
+! - Add the Phase low mid high cloud fraction (cldlayerphase) in the arguments
+! - Add the 3D Phase cloud fraction as a function of temperature (lidarcldtmp) in the arguments
+! - Modification of the phase diagnosis within the COSP_CLDFRAC routine to integrate the phase
+!   diagnosis (3D, low/mid/high, 3D temperature)
+! Reference: Cesana G. and H. Chepfer (2013): Evaluation of the cloud water phase
+! in a climate model using CALIPSO-GOCCP, J. Geophys. Res., doi: 10.1002/jgrd.50376
+!
+! ------------------------------------------------------------------------------------
 ! c inputs :
 …
       logical ok_lidar_cfad         ! true if lidar CFAD diagnostics need to be computed
       real refl(npoints,ncol,nrefl) ! subgrid parasol reflectance ! parasol
+      real tmp(npoints,llm)         ! temp at each levels
+      real pnorm_perp(npoints,ncol,llm)  ! lidar perpendicular ATB
 ! c outputs :
       real lidarcld(npoints,llm)     ! 3D "lidar" cloud fraction
+      real cldlayer(npoints,ncat)    ! "lidar" cloud fraction (low, mid, high, total)
+      real sub(npoints,llm)     ! 3D "lidar" indice
+      real cldlayer(npoints,ncat)    ! "lidar" cloud layer fraction (low, mid, high, total)
       real cfad2(npoints,max_bin,llm) ! CFADs of SR
       real srbval(max_bin)           ! SR bins in CFADs
 …
       parameter (S_clr = 1.2)
       real S_cld
+!      parameter (S_cld = 3.0)  ! Previous thresold for cloud detection
+      parameter (S_cld = 5.0)  ! New (dec 2008) thresold for cloud detection
+      parameter (S_cld = 5.)  ! Thresold for cloud detection
       real S_att
       parameter (S_att = 0.01)
 ! c local variables :
       integer ic,k
+      integer ic,k,i,j
       real x3d(npoints,ncol,llm)
       real x3d_c(npoints,llm),pnorm_c(npoints,llm)
       real xmax
+! Output variables
+      integer,parameter :: nphase = 6 ! nb of cloud layer phase types (ice,liquid,undefined,false ice,false liquid,Percent of ice)
+      real lidarcldphase(npoints,llm,nphase)   ! 3D "lidar" phase cloud fraction
+      real lidarcldtmp(npoints,40,5)          ! 3D "lidar" phase cloud fraction as a function of temp
+      real cldlayerphase(npoints,ncat,nphase)  ! "lidar" phase low mid high cloud fraction
+! SR detection threshold
+      real, parameter  ::  S_cld_att = 30. ! New threshold for undefine cloud phase detection
+!
 ! c -------------------------------------------------------
 …
 ! c -------------------------------------------------------
+!
 !  Should be modified in future version
       xmax=undef-1.0
 …
 ! c 1- Lidar scattering ratio :
 ! c -------------------------------------------------------
+!
+!       where ((pnorm.lt.xmax) .and. (pmol.lt.xmax) .and. (pmol.gt. 0.0 ))
+!          x3d = pnorm/pmol
+!       elsewhere
+!           x3d = undef
+!       end where
+! A.B-S: pmol reduced to 2D (npoints,llm) (Dec 08)
       do ic = 1, ncol
         pnorm_c = pnorm(:,ic,:)
 …
             x3d_c = undef
         end where
         x3d(:,ic,:) = x3d_c
+         x3d(:,ic,:) = x3d_c
       enddo
 …
 ! c -------------------------------------------------------
       CALL COSP_CLDFRAC(npoints,ncol,llm,ncat,  &
               x3d,pplay, S_att,S_cld,undef,lidarcld, &
               cldlayer)
+    CALL COSP_CLDFRAC(npoints,ncol,llm,ncat,nphase,  &
+              tmp,x3d,pnorm,pnorm_perp,pplay, S_att,S_cld,S_cld_att,undef,lidarcld, &
+              cldlayer,lidarcldphase,sub,cldlayerphase,lidarcldtmp)
 ! c -------------------------------------------------------
 …
 ! c c- Compute CFAD
 ! c -------------------------------------------------------
       do j = 1, Nlevels
          do ib = 1, Nbins
 …
       END SUBROUTINE COSP_CFAD_SR
 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 !-------------------- SUBROUTINE COSP_CLDFRAC -------------------
 ! c Purpose: Cloud fraction diagnosed from lidar measurements
 !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+      SUBROUTINE COSP_CLDFRAC(Npoints,Ncolumns,Nlevels,Ncat, &
+                  x,pplay,S_att,S_cld,undef,lidarcld, &
+                  cldlayer)
+      SUBROUTINE COSP_CLDFRAC(Npoints,Ncolumns,Nlevels,Ncat,Nphase, &
+                  tmp,x,ATB,ATBperp,pplay,S_att,S_cld,S_cld_att,undef,lidarcld, &
+                  cldlayer,lidarcldphase,nsub,cldlayerphase,lidarcldtemp)
       IMPLICIT NONE
 ! Input arguments
       integer Npoints,Ncolumns,Nlevels,Ncat
       real x(Npoints,Ncolumns,Nlevels)
+! Local parameters
+      integer nphase ! nb of cloud layer phase types
+                                      ! (ice,liquid,undefined,false ice,false liquid,Percent of ice)
+      integer,parameter  ::  Ntemp=40 ! indice of the temperature vector
+      integer ip, k, iz, ic, ncol, nlev, i, itemp  ! loop indice
+      real  S_cld_att ! New threshold for undefine cloud phase detection (SR=30)
+      integer toplvlsat  ! level of the first cloud with SR>30
+      real alpha50, beta50, gamma50, delta50, epsilon50, zeta50 ! Polynomial Coef of the phase
+                                                                ! discrimination line
+! Input variables
+      real tmp(Npoints,Nlevels)                 ! temperature
+      real ATB(Npoints,Ncolumns,Nlevels) ! 3D Attenuated backscatter
+      real ATBperp(Npoints,Ncolumns,Nlevels) ! 3D perpendicular attenuated backscatter
       real pplay(Npoints,Nlevels)
       real S_att,S_cld
       real undef
+! Output :
+! Output variables
+      real lidarcldtemp(Npoints,Ntemp,5) ! 3D Temperature 1=tot,2=ice,3=liq,4=undef,5=ice/ice+liq
+      real tempmod(Ntemp+1)     ! temperature bins
+      real lidarcldphase(Npoints,Nlevels,Nphase)    ! 3D cloud phase fraction
+      real cldlayerphase(Npoints,Ncat,Nphase) ! low, middle, high, total cloud fractions for ice liquid and undefine phase
       real lidarcld(Npoints,Nlevels) ! 3D cloud fraction
       real cldlayer(Npoints,Ncat)    ! low, middle, high, total cloud fractions
 ! Local variables
+      integer ip, k, iz, ic
+      real tmpi(Npoints,Ncolumns,Nlevels)       ! temperature of ice cld
+      real tmpl(Npoints,Ncolumns,Nlevels)       ! temperature of liquid cld
+      real tmpu(Npoints,Ncolumns,Nlevels)       ! temperature of undef cld
+      real checktemp, ATBperp_tmp ! temporary variable
+      real checkcldlayerphase, checkcldlayerphase2 ! temporary variable
+      real sumlidarcldtemp(Npoints,Ntemp) ! temporary variable
+      real cldlayphase(Npoints,Ncolumns,Ncat,Nphase) ! subgrided low mid high phase cloud fraction
+      real cldlayerphasetmp(Npoints,Ncat) ! temporary variable
+      real cldlayerphasesum(Npoints,Ncat) ! temporary variable
+      real lidarcldtempind(Npoints,Ntemp) ! 3D Temperature indice
+      real lidarcldphasetmp(Npoints,Nlevels)  ! 3D sum of ice and liquid cloud occurences
+! Local variables
       real p1
       real cldy(Npoints,Ncolumns,Nlevels)
 …
       real nsub(Npoints,Nlevels)
+#ifdef SYS_SX
       real cldlay1(Npoints,Ncolumns)
       real cldlay2(Npoints,Ncolumns)
 …
       real nsublay2(Npoints,Ncolumns)
       real nsublay3(Npoints,Ncolumns)
+#endif
 …
       cldlay = 0.0
       nsublay = 0.0
+      ATBperp_tmp = 0.
+      lidarcldphase(:,:,:) = 0.
+      cldlayphase(:,:,:,:) = 0.
+      cldlayerphase(:,:,:) = 0.
+      tmpi(:,:,:) = 0.
+      tmpl(:,:,:) = 0.
+      tmpu(:,:,:) = 0.
+      cldlayerphasesum(:,:) = 0.
+      lidarcldtemp(:,:,:) = 0.
+      lidarcldtempind(:,:) = 0.
+      sumlidarcldtemp(:,:) = 0.
+      toplvlsat=0
+      lidarcldphasetmp(:,:) = 0.
+! temperature bins
+      tempmod=(/-273.15,-90.,-87.,-84.,-81.,-78.,-75.,-72.,-69.,-66.,-63.,-60.,-57., &
+                -54.,-51.,-48.,-45.,-42.,-39.,-36.,-33.,-30.,-27.,-24.,-21.,-18.,  &
+                -15.,-12.,-9.,-6.,-3.,0.,3.,6.,9.,12.,15.,18.,21.,24.,200. /)
+! convert C to K
+      tempmod=tempmod+273.15
+! Polynomial coefficient of the phase discrimination line used to separate liquid from ice
+! (Cesana and Chepfer, JGR, 2013)
+! ATBperp = ATB^5*alpha50 + ATB^4*beta50 + ATB^3*gamma50 + ATB^2*delta50 + ATB*epsilon50 + zeta50
+      alpha50   = 9.0322e+15
+      beta50    = -2.1358e+12
+      gamma50   = 173.3963e06
+      delta50   = -3.9514e03
+      epsilon50 = 0.2559
+      zeta50    = -9.4776e-07
 ! ---------------------------------------------------------------
 …
       enddo ! k
 ! ---------------------------------------------------------------
 ! 3- grid-box 3D cloud fraction and layered cloud fractions (ISCCP pressure
 …
       lidarcld = 0.0
       nsub = 0.0
+#ifdef SYS_SX
 !! XXX: Use cldlay[1-3] and nsublay[1-3] to avoid bank-conflicts.
       cldlay1 = 0.0
 …
       nsublay3 = 0.0
       nsublay(:,:,4) = 0.0
       do k = Nlevels, 1, -1
        do ic = 1, Ncolumns
         do ip = 1, Npoints
+         if(srok(ip,ic,k).gt.0.)then
+           ! Computation of the cloud fraction as a function of the temperature
+           ! instead of height, for ice,liquid and all clouds
+           do itemp=1,Ntemp
+             if( (tmp(ip,k).ge.tempmod(itemp)).and.(tmp(ip,k).lt.tempmod(itemp+1)) )then
+               lidarcldtempind(ip,itemp)=lidarcldtempind(ip,itemp)+1.
+             endif
+           enddo
+         endif
+         if (cldy(ip,ic,k).eq.1.) then
+           do itemp=1,Ntemp
+             if( (tmp(ip,k).ge.tempmod(itemp)).and.(tmp(ip,k).lt.tempmod(itemp+1)) )then
+               lidarcldtemp(ip,itemp,1)=lidarcldtemp(ip,itemp,1)+1.
+             endif
+           enddo
+         endif
          p1 = pplay(ip,k)
 …
       nsublay(:,:,2) = nsublay2
       nsublay(:,:,3) = nsublay3
+#else
+      cldlay = 0.0
+      nsublay = 0.0
+      do k = Nlevels, 1, -1
+       do ic = 1, Ncolumns
+        do ip = 1, Npoints
+          ! Computation of the cloud fraction as a function of the temperature
+          ! instead of height, for ice,liquid and all clouds
+          if(srok(ip,ic,k).gt.0.)then
+          do itemp=1,Ntemp
+            if( (tmp(ip,k).ge.tempmod(itemp)).and.(tmp(ip,k).lt.tempmod(itemp+1)) )then
+              lidarcldtempind(ip,itemp)=lidarcldtempind(ip,itemp)+1.
+            endif
+          enddo
+          endif
+          if(cldy(ip,ic,k).eq.1.)then
+          do itemp=1,Ntemp
+            if( (tmp(ip,k).ge.tempmod(itemp)).and.(tmp(ip,k).lt.tempmod(itemp+1)) )then
+              lidarcldtemp(ip,itemp,1)=lidarcldtemp(ip,itemp,1)+1.
+            endif
+          enddo
+          endif
+!
+          iz=1
+          p1 = pplay(ip,k)
+          if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high clouds
+            iz=3
+          else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then  ! mid clouds
+            iz=2
+         endif
+         cldlay(ip,ic,iz) = MAX(cldlay(ip,ic,iz),cldy(ip,ic,k))
+         cldlay(ip,ic,4) = MAX(cldlay(ip,ic,4),cldy(ip,ic,k))
+         lidarcld(ip,k)=lidarcld(ip,k) + cldy(ip,ic,k)
+         nsublay(ip,ic,iz) = MAX(nsublay(ip,ic,iz),srok(ip,ic,k))
+         nsublay(ip,ic,4) = MAX(nsublay(ip,ic,4),srok(ip,ic,k))
+         nsub(ip,k)=nsub(ip,k) + srok(ip,ic,k)
+        enddo
+       enddo
+      enddo
+#endif
 ! -- grid-box 3D cloud fraction
 …
       endwhere
+      RETURN
+! ---------------------------------------------------------------
+! 4- grid-box 3D cloud Phase :
+! ---------------------------------------------------------------
+! ---------------------------------------------------------------
+! 4.1 - For Cloudy pixels with 8.16km < z < 19.2km
+! ---------------------------------------------------------------
+do ncol=1,Ncolumns
+do i=1,Npoints
+      do nlev=Nlevels,18,-1  ! from 19.2km until 8.16km
+         p1 = pplay(i,nlev)
+! Avoid zero values
+        if( (cldy(i,ncol,nlev).eq.1.) .and. (ATBperp(i,ncol,nlev).gt.0.) )then
+! Computation of the ATBperp along the phase discrimination line
+           ATBperp_tmp = (ATB(i,ncol,nlev)**5)*alpha50 + (ATB(i,ncol,nlev)**4)*beta50 + &
+                         (ATB(i,ncol,nlev)**3)*gamma50 + (ATB(i,ncol,nlev)**2)*delta50 + &
+                          ATB(i,ncol,nlev)*epsilon50 + zeta50
+!____________________________________________________________________________________________________
+!
+!4.1.a Ice: ATBperp above the phase discrimination line
+!____________________________________________________________________________________________________
+!
+           if( (ATBperp(i,ncol,nlev)-ATBperp_tmp).ge.0. )then   ! Ice clouds
+             ! ICE with temperature above 273,15°K = Liquid (false ice)
+            if(tmp(i,nlev).gt.273.15)then                ! Temperature above 273,15 K
+              ! Liquid: False ice corrected by the temperature to Liquid
+               lidarcldphase(i,nlev,2)=lidarcldphase(i,nlev,2)+1.   ! false ice detection ==> added to Liquid
+               tmpl(i,ncol,nlev)=tmp(i,nlev)
+               lidarcldphase(i,nlev,5)=lidarcldphase(i,nlev,5)+1.   ! keep the information "temperature criterium used"
+                                                    ! to classify the phase cloud
+                   cldlayphase(i,ncol,4,2) = 1.                         ! tot cloud
+                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
+                   cldlayphase(i,ncol,3,2) = 1.
+                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
+                   cldlayphase(i,ncol,2,2) = 1.
+                else                                                    ! low cloud
+                   cldlayphase(i,ncol,1,2) = 1.
+                endif
+                   cldlayphase(i,ncol,4,5) = 1.                         ! tot cloud
+                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
+                   cldlayphase(i,ncol,3,5) = 1.
+                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
+                   cldlayphase(i,ncol,2,5) = 1.
+                else                                                    ! low cloud
+                   cldlayphase(i,ncol,1,5) = 1.
+                endif
+             else
+             ! ICE with temperature below 273,15°K
+              lidarcldphase(i,nlev,1)=lidarcldphase(i,nlev,1)+1.
+              tmpi(i,ncol,nlev)=tmp(i,nlev)
+                   cldlayphase(i,ncol,4,1) = 1.                         ! tot cloud
+                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
+                   cldlayphase(i,ncol,3,1) = 1.
+                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
+                   cldlayphase(i,ncol,2,1) = 1.
+                else                                                    ! low cloud
+                   cldlayphase(i,ncol,1,1) = 1.
+                endif
+              endif
+!____________________________________________________________________________________________________
+!
+! 4.1.b Liquid: ATBperp below the phase discrimination line
+!____________________________________________________________________________________________________
+!
+             else                                        ! Liquid clouds
+              ! Liquid with temperature above 231,15°K
+            if(tmp(i,nlev).gt.231.15)then
+               lidarcldphase(i,nlev,2)=lidarcldphase(i,nlev,2)+1.
+               tmpl(i,ncol,nlev)=tmp(i,nlev)
+                   cldlayphase(i,ncol,4,2) = 1.                         ! tot cloud
+                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
+                   cldlayphase(i,ncol,3,2) = 1.
+                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
+                   cldlayphase(i,ncol,2,2) = 1.
+                else                                                    ! low cloud
+                   cldlayphase(i,ncol,1,2) = 1.
+                endif
+             else
+             ! Liquid with temperature below 231,15°K = Ice (false liquid)
+               tmpi(i,ncol,nlev)=tmp(i,nlev)
+               lidarcldphase(i,nlev,1)=lidarcldphase(i,nlev,1)+1.   ! false liquid detection ==> added to ice
+               lidarcldphase(i,nlev,4)=lidarcldphase(i,nlev,4)+1.   ! keep the information "temperature criterium used"
+                                                    ! to classify the phase cloud
+                   cldlayphase(i,ncol,4,4) = 1.                         ! tot cloud
+                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
+                   cldlayphase(i,ncol,3,4) = 1.
+                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
+                   cldlayphase(i,ncol,2,4) = 1.
+                else                                                    ! low cloud
+                   cldlayphase(i,ncol,1,4) = 1.
+                endif
+                   cldlayphase(i,ncol,4,1) = 1.                         ! tot cloud
+                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
+                   cldlayphase(i,ncol,3,1) = 1.
+                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
+                   cldlayphase(i,ncol,2,1) = 1.
+                else                                                    ! low cloud
+                   cldlayphase(i,ncol,1,1) = 1.
+                endif
+             endif
+            endif  ! end of discrimination condition
+         endif  ! end of cloud condition
+      enddo ! end of altitude loop
+! ---------------------------------------------------------------
+! 4.2 - For Cloudy pixels with 0km < z < 8.16km
+! ---------------------------------------------------------------
+      toplvlsat=0
+      do nlev=17,1,-1  ! from 8.16km until 0km
+         p1 = pplay(i,nlev)
+        if( (cldy(i,ncol,nlev).eq.1.) .and. (ATBperp(i,ncol,nlev).gt.0.) )then
+! Phase discrimination line : ATBperp = ATB^5*alpha50 + ATB^4*beta50 + ATB^3*gamma50 + ATB^2*delta50
+!                                  + ATB*epsilon50 + zeta50
+! Computation of the ATBperp of the phase discrimination line
+           ATBperp_tmp = (ATB(i,ncol,nlev)**5)*alpha50 + (ATB(i,ncol,nlev)**4)*beta50 + &
+                         (ATB(i,ncol,nlev)**3)*gamma50 + (ATB(i,ncol,nlev)**2)*delta50 + &
+                          ATB(i,ncol,nlev)*epsilon50 + zeta50
+!____________________________________________________________________________________________________
+!
+! 4.2.a Ice: ATBperp above the phase discrimination line
+!____________________________________________________________________________________________________
+!
+            ! ICE with temperature above 273,15°K = Liquid (false ice)
+          if( (ATBperp(i,ncol,nlev)-ATBperp_tmp).ge.0. )then   ! Ice clouds
+            if(tmp(i,nlev).gt.273.15)then
+               lidarcldphase(i,nlev,2)=lidarcldphase(i,nlev,2)+1.  ! false ice ==> liq
+               tmpl(i,ncol,nlev)=tmp(i,nlev)
+               lidarcldphase(i,nlev,5)=lidarcldphase(i,nlev,5)+1.
+                   cldlayphase(i,ncol,4,2) = 1.                         ! tot cloud
+               if ( p1.gt.0. .and. p1.lt.(440.*100.)) then              ! high cloud
+                   cldlayphase(i,ncol,3,2) = 1.
+                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
+                   cldlayphase(i,ncol,2,2) = 1.
+                else                                                    ! low cloud
+                   cldlayphase(i,ncol,1,2) = 1.
+                endif
+                   cldlayphase(i,ncol,4,5) = 1.                         ! tot cloud
+                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
+                   cldlayphase(i,ncol,3,5) = 1.
+                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
+                   cldlayphase(i,ncol,2,5) = 1.
+                else                                                    ! low cloud
+                   cldlayphase(i,ncol,1,5) = 1.
+                endif
+             else
+              ! ICE with temperature below 273,15°K
+              lidarcldphase(i,nlev,1)=lidarcldphase(i,nlev,1)+1.
+              tmpi(i,ncol,nlev)=tmp(i,nlev)
+                   cldlayphase(i,ncol,4,1) = 1.                         ! tot cloud
+                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
+                   cldlayphase(i,ncol,3,1) = 1.
+                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
+                   cldlayphase(i,ncol,2,1) = 1.
+                else                                                    ! low cloud
+                   cldlayphase(i,ncol,1,1) = 1.
+                endif
+              endif
+!____________________________________________________________________________________________________
+!
+! 4.2.b Liquid: ATBperp below the phase discrimination line
+!____________________________________________________________________________________________________
+!
+          else
+             ! Liquid with temperature above 231,15°K
+            if(tmp(i,nlev).gt.231.15)then
+               lidarcldphase(i,nlev,2)=lidarcldphase(i,nlev,2)+1.
+               tmpl(i,ncol,nlev)=tmp(i,nlev)
+                   cldlayphase(i,ncol,4,2) = 1.                         ! tot cloud
+                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
+                   cldlayphase(i,ncol,3,2) = 1.
+                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
+                   cldlayphase(i,ncol,2,2) = 1.
+                else                                                    ! low cloud
+                   cldlayphase(i,ncol,1,2) = 1.
+                endif
+             else
+             ! Liquid with temperature below 231,15°K = Ice (false liquid)
+               tmpi(i,ncol,nlev)=tmp(i,nlev)
+               lidarcldphase(i,nlev,1)=lidarcldphase(i,nlev,1)+1.  ! false liq ==> ice
+               lidarcldphase(i,nlev,4)=lidarcldphase(i,nlev,4)+1.  ! false liq ==> ice
+                   cldlayphase(i,ncol,4,4) = 1.                         ! tot cloud
+                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
+                   cldlayphase(i,ncol,3,4) = 1.
+                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
+                   cldlayphase(i,ncol,2,4) = 1.
+                else                                                    ! low cloud
+                   cldlayphase(i,ncol,1,4) = 1.
+                endif
+                   cldlayphase(i,ncol,4,1) = 1.                         ! tot cloud
+                if ( p1.gt.0. .and. p1.lt.(440.*100.)) then             ! high cloud
+                   cldlayphase(i,ncol,3,1) = 1.
+                else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud
+                   cldlayphase(i,ncol,2,1) = 1.
+                else                                                    ! low cloud
+                   cldlayphase(i,ncol,1,1) = 1.
+                endif
+             endif
+           endif  ! end of discrimination condition
+            toplvlsat=0
+           ! Find the level of the highest cloud with SR>30
+            if(x(i,ncol,nlev).gt.S_cld_att)then  ! SR > 30.
+                toplvlsat=nlev-1
+                goto 99
+            endif
+        endif  ! end of cloud condition
+       enddo  ! end of altitude loop
+continue
+!____________________________________________________________________________________________________
+!
+! Undefined phase: For a cloud located below another cloud with SR>30
+! see Cesana and Chepfer 2013 Sect.III.2
+!____________________________________________________________________________________________________
+!
+if(toplvlsat.ne.0)then
+      do nlev=toplvlsat,1,-1
+         p1 = pplay(i,nlev)
+        if(cldy(i,ncol,nlev).eq.1.)then
+           lidarcldphase(i,nlev,3)=lidarcldphase(i,nlev,3)+1.
+           tmpu(i,ncol,nlev)=tmp(i,nlev)
+                   cldlayphase(i,ncol,4,3) = 1.                         ! tot cloud
+          if ( p1.gt.0. .and. p1.lt.(440.*100.)) then              ! high cloud
+             cldlayphase(i,ncol,3,3) = 1.
+          else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then  ! mid cloud
+             cldlayphase(i,ncol,2,3) = 1.
+          else                                                     ! low cloud
+             cldlayphase(i,ncol,1,3) = 1.
+          endif
+        endif
+      enddo
+endif
+      toplvlsat=0
+enddo
+enddo
+!____________________________________________________________________________________________________
+!
+! Computation of final cloud phase diagnosis
+!____________________________________________________________________________________________________
+!
+! Compute the Ice percentage in cloud = ice/(ice+liq) as a function
+! of the occurrences
+lidarcldphasetmp(:,:)=lidarcldphase(:,:,1)+lidarcldphase(:,:,2);
+WHERE (lidarcldphasetmp(:,:).gt. 0.)
+   lidarcldphase(:,:,6)=lidarcldphase(:,:,1)/lidarcldphasetmp(:,:)
+ELSEWHERE
+   lidarcldphase(:,:,6) = undef
+ENDWHERE
+! Compute Phase 3D Cloud Fraction
+     WHERE ( nsub(:,:).gt.0.0 )
+       lidarcldphase(:,:,1)=lidarcldphase(:,:,1)/nsub(:,:)
+       lidarcldphase(:,:,2)=lidarcldphase(:,:,2)/nsub(:,:)
+       lidarcldphase(:,:,3)=lidarcldphase(:,:,3)/nsub(:,:)
+       lidarcldphase(:,:,4)=lidarcldphase(:,:,4)/nsub(:,:)
+       lidarcldphase(:,:,5)=lidarcldphase(:,:,5)/nsub(:,:)
+     ELSEWHERE
+       lidarcldphase(:,:,1) = undef
+       lidarcldphase(:,:,2) = undef
+       lidarcldphase(:,:,3) = undef
+       lidarcldphase(:,:,4) = undef
+       lidarcldphase(:,:,5) = undef
+     ENDWHERE
+! Compute Phase low mid high cloud fractions
+    do iz = 1, Ncat
+       do i=1,Nphase-3
+       do ic = 1, Ncolumns
+          cldlayerphase(:,iz,i)=cldlayerphase(:,iz,i) + cldlayphase(:,ic,iz,i)
+          cldlayerphasesum(:,iz)=cldlayerphasesum(:,iz)+cldlayphase(:,ic,iz,i)
+       enddo
+      enddo
+    enddo
+    do iz = 1, Ncat
+       do i=4,5
+       do ic = 1, Ncolumns
+          cldlayerphase(:,iz,i)=cldlayerphase(:,iz,i) + cldlayphase(:,ic,iz,i)
+       enddo
+       enddo
+    enddo
+! Compute the Ice percentage in cloud = ice/(ice+liq)
+cldlayerphasetmp(:,:)=cldlayerphase(:,:,1)+cldlayerphase(:,:,2)
+    WHERE (cldlayerphasetmp(:,:).gt. 0.)
+       cldlayerphase(:,:,6)=cldlayerphase(:,:,1)/cldlayerphasetmp(:,:)
+    ELSEWHERE
+       cldlayerphase(:,:,6) = undef
+    ENDWHERE
+    do i=1,Nphase-1
+      WHERE ( cldlayerphasesum(:,:).gt.0.0 )
+         cldlayerphase(:,:,i) = (cldlayerphase(:,:,i)/cldlayerphasesum(:,:)) * cldlayer(:,:)
+      ENDWHERE
+    enddo
+    do i=1,Npoints
+       do iz=1,Ncat
+          checkcldlayerphase=0.
+          checkcldlayerphase2=0.
+          if (cldlayerphasesum(i,iz).gt.0.0 )then
+             do ic=1,Nphase-3
+                checkcldlayerphase=checkcldlayerphase+cldlayerphase(i,iz,ic)
+             enddo
+             checkcldlayerphase2=cldlayer(i,iz)-checkcldlayerphase
+             if( (checkcldlayerphase2.gt.0.01).or.(checkcldlayerphase2.lt.-0.01) ) print *, checkcldlayerphase,cldlayer(i,iz)
+          endif
+       enddo
+    enddo
+    do i=1,Nphase-1
+      WHERE ( nsublayer(:,:).eq.0.0 )
+         cldlayerphase(:,:,i) = undef
+      ENDWHERE
+   enddo
+! Compute Phase 3D as a function of temperature
+do nlev=1,Nlevels
+do ncol=1,Ncolumns
+do i=1,Npoints
+do itemp=1,Ntemp
+if(tmpi(i,ncol,nlev).gt.0.)then
+      if( (tmpi(i,ncol,nlev).ge.tempmod(itemp)).and.(tmpi(i,ncol,nlev).lt.tempmod(itemp+1)) )then
+        lidarcldtemp(i,itemp,2)=lidarcldtemp(i,itemp,2)+1.
+      endif
+elseif(tmpl(i,ncol,nlev).gt.0.)then
+      if( (tmpl(i,ncol,nlev).ge.tempmod(itemp)).and.(tmpl(i,ncol,nlev).lt.tempmod(itemp+1)) )then
+        lidarcldtemp(i,itemp,3)=lidarcldtemp(i,itemp,3)+1.
+      endif
+elseif(tmpu(i,ncol,nlev).gt.0.)then
+      if( (tmpu(i,ncol,nlev).ge.tempmod(itemp)).and.(tmpu(i,ncol,nlev).lt.tempmod(itemp+1)) )then
+        lidarcldtemp(i,itemp,4)=lidarcldtemp(i,itemp,4)+1.
+      endif
+endif
+enddo
+enddo
+enddo
+enddo
+! Check temperature cloud fraction
+do i=1,Npoints
+   do itemp=1,Ntemp
+checktemp=lidarcldtemp(i,itemp,2)+lidarcldtemp(i,itemp,3)+lidarcldtemp(i,itemp,4)
+        if(checktemp.NE.lidarcldtemp(i,itemp,1))then
+          print *, i,itemp
+          print *, lidarcldtemp(i,itemp,1:4)
+        endif
+   enddo
+enddo
+! Compute the Ice percentage in cloud = ice/(ice+liq)
+!   sumlidarcldtemp=sum(lidarcldtemp(:,:,2:3),3)
+   sumlidarcldtemp(:,:)=lidarcldtemp(:,:,2)+lidarcldtemp(:,:,3)
+WHERE(sumlidarcldtemp(:,:)>0.)
+  lidarcldtemp(:,:,5)=lidarcldtemp(:,:,2)/sumlidarcldtemp(:,:)
+ELSEWHERE
+  lidarcldtemp(:,:,5)=undef
+ENDWHERE
+do i=1,4
+  WHERE(lidarcldtempind(:,:).gt.0.)
+     lidarcldtemp(:,:,i) = lidarcldtemp(:,:,i)/lidarcldtempind(:,:)
+  ELSEWHERE
+     lidarcldtemp(:,:,i) = undef
+  ENDWHERE
+enddo
+       RETURN
       END SUBROUTINE COSP_CLDFRAC
 ! ---------------------------------------------------------------
 END MODULE MOD_LMD_IPSL_STATS

LMDZ5/trunk/libf/phylmd/cosp/math_lib.F90

-                      r1907
+                      r2428
+! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/math_lib.f90 $
 ! MATH_LIB: Mathematics procedures for F90
 ! Compiled/Modified:
 …
   integer :: k,m1,m
   pi = acos(-1.)
+  pi = acos(-1.)
   if (x ==int(x)) then
     if (x > 0.0) then

LMDZ5/trunk/libf/phylmd/cosp/optics_lib.F90

-                      r1907
+                      r2428
+! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/optics_lib.f90 $
 ! OPTICS_LIB: Optical proecures for for F90
 ! Compiled/Modified:
 …
 ! subroutine M_WAT
 ! ----------------------------------------------------------------------------
   subroutine m_wat(freq, t, n_r, n_i)
+  subroutine m_wat(freq, tk, n_r, n_i)
   implicit none
+!
 …
 ! Inputs:
 !   [freq]    frequency (GHz)
 !   [t]       temperature (C)
+!   [tk]       temperature (K)
+!
 ! Outputs:
 …
 ! ----- INPUTS -----
   real*8, intent(in) :: freq,t
+  real*8, intent(in) :: freq,tk
 ! ----- OUTPUTS -----
 …
   real*8 e_r,e_i
   real*8 pi
+  real*8 tc
   complex*16 e_comp, sq
+  tc = tk - 273.15
   ld = 100.*2.99792458E8/(freq*1E9)
   es = 78.54*(1-(4.579E-3*(t-25.)+1.19E-5*(t-25.)**2 &
        -2.8E-8*(t-25.)**3))
   ei = 5.27137+0.021647*t-0.00131198*t**2
   a = -(16.8129/(t+273.))+0.0609265
   ls = 0.00033836*exp(2513.98/(t+273.))
+  es = 78.54*(1-(4.579E-3*(tc-25.)+1.19E-5*(tc-25.)**2 &
+       -2.8E-8*(tc-25.)**3))
+  ei = 5.27137+0.021647*tc-0.00131198*tc**2
+  a = -(16.8129/(tc+273.))+0.0609265
+  ls = 0.00033836*exp(2513.98/(tc+273.))
   sg = 12.5664E8
 …
 ! Inputs:
 !   [freq]    frequency (GHz)
 !   [t]       temperature (C)
+!   [t]       temperature (K)
+!
 ! Outputs:
 …
   parameter(nwl=468,nwlt=62)
   real*8 :: alam,cutice,pi,t1,t2,tk,wlmax,wlmin, &
             x,x1,x2,y,y1,y2,ylo,yhi
+  real*8 :: alam,cutice,pi,t1,t2,wlmax,wlmin, &
+            x,x1,x2,y,y1,y2,ylo,yhi,tk
   real*8 :: &
 …
   n_i=0.0
+  tk = t
 ! // convert frequency to wavelength (um)
   alam=3E5/freq
 …
     stop
   endif
-! // convert temperature to K
-  tk = t + 273.16
   if (alam < cutice) then
 …
          Dqsc = Tnp1 * (A*Conjg(A) + B*Conjg(B)) + Dqsc
          If (N.Gt.1) then
             Dg = Dg + (dN*dN - 1) * Dble(ANM1*Conjg(A) + BNM1 * Conjg(B)) / dN + TNM1 * Dble(ANM1*Conjg(BNM1)) / (dN*dN - dN)
+         Dg = Dg + (dN*dN - 1) * Dble(ANM1*Conjg(A) + BNM1 * Conjg(B)) / dN + TNM1 * Dble(ANM1*Conjg(BNM1)) / (dN*dN - dN)
          End If
          Anm1 = A

LMDZ5/trunk/libf/phylmd/cosp/pf_to_mr.F

-                      r1907
+                      r2428
 ! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation.
 ! All rights reserved.
+! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/llnl/pf_to_mr.f $
+!
 ! Redistribution and use in source and binary forms, with or without modification, are permitted
 …
       INTEGER ncol          !  number of subcolumns
       INTEGER i,j,ilev,ibox
+      INTEGER j,ilev,ibox
       REAL rain_ls(npoints,nlev),snow_ls(npoints,nlev) ! large-scale precipitation flux
+      REAL rain_ls(npoints,nlev),snow_ls(npoints,nlev) ! large-scale precip. flux
       REAL grpl_ls(npoints,nlev)
       REAL rain_cv(npoints,nlev),snow_cv(npoints,nlev) ! convective precipitation flux
+      REAL rain_cv(npoints,nlev),snow_cv(npoints,nlev) ! convective precip. flux
       REAL prec_frac(npoints,ncol,nlev) ! 0 -> clear sky
 …
       REAL term1x2r,term1x2s,term1x2g,t123r,t123s,t123g
       ! method from Khairoutdinov and Randall (2003 JAS)
+      ! method from Khairoutdinov and Randall (2003 JAS)
       ! --- List of constants from Appendix B

LMDZ5/trunk/libf/phylmd/cosp/phys_cosp.F90

-                      r2345
+                      r2428
 ! ISCCP, Radar (QuickBeam), Lidar et Parasol (ACTSIM), MISR, RTTOVS
+!Idelkadi Abderrahmane Aout-Septembre 2009
+!Idelkadi Abderrahmane Aout-Septembre 2009 First Version
+!Idelkadi Abderrahmane Nov 2015 version v1.4.0
   subroutine phys_cosp( itap,dtime,freq_cosp, &
 …
 ! meantbisccp,                          !Mean all-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator
 ! meantbclrisccp                        !Mean clear-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator
+!!! AI rajouter les nouvelles sorties
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! AI rajouter
+  #include "cosp_defs.h"
   USE MOD_COSP_CONSTANTS
   USE MOD_COSP_TYPES
 …
   use cosp_output_mod
   use cosp_output_write_mod
+!  use MOD_COSP_Modis_Simulator, only : cosp_modis
   IMPLICIT NONE
 …
   type(cosp_sglidar) :: sglidar ! Output from lidar simulator
   type(cosp_isccp)   :: isccp   ! Output from ISCCP simulator
+!! AI rajout modis
+  type(cosp_modis)   :: modis   ! Output from MODIS simulator
+!!
   type(cosp_misr)    :: misr    ! Output from MISR simulator
+!! AI rajout rttovs
+!  type(cosp_rttov)   :: rttov   ! Output from RTTOV
+!!
   type(cosp_vgrid)   :: vgrid   ! Information on vertical grid of stats
   type(cosp_radarstats) :: stradar ! Summary statistics from radar simulator
 …
   integer :: t0,t1,count_rate,count_max
   integer :: Nlon,Nlat,geomode
+  integer :: Nlon,Nlat
   real,save :: radar_freq,k2,ZenAng,co2,ch4,n2o,co,emsfc_lw
 !$OMP THREADPRIVATE(emsfc_lw)
 …
   integer                         :: itap,k,ip
   real                            :: dtime,freq_cosp
+  real,dimension(2)               :: time_bnds
+!
    namelist/COSP_INPUT/overlap,isccp_topheight,isccp_topheight_direction, &
               npoints_it,ncolumns,use_vgrid,nlr,csat_vgrid, &
 …
   print*,' Cles des differents simulateurs cosp :'
   print*,' Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim', &
           cfg%Lradar_sim,cfg%Llidar_sim,cfg%Lisccp_sim,cfg%Lmisr_sim,cfg%Lrttov_sim
+  print*,'Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lmodis_sim,Lrttov_sim', &
+          cfg%Lradar_sim,cfg%Llidar_sim,cfg%Lisccp_sim,cfg%Lmisr_sim,cfg%Lmodis_sim,cfg%Lrttov_sim
   endif ! debut_cosp
+  time_bnds(1) = dtime-dtime/2.
+  time_bnds(2) = dtime+dtime/2.
 !  print*,'Debut phys_cosp itap,dtime,freq_cosp,ecrit_mth,ecrit_day,ecrit_hf ', &
 …
 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
         print *, 'Allocating memory for gridbox type...'
+        call construct_cosp_gridbox(dble(itap),radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, &
+!! AI
+!        call construct_cosp_gridbox(dble(itap),radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, &
+!                                    Npoints,Nlevels,Ncolumns,N_HYDRO,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, &
+!                                    lidar_ice_type,isccp_topheight,isccp_topheight_direction,overlap,emsfc_lw, &
+!                                    use_precipitation_fluxes,use_reff, &
+!                                    Platform,Satellite,Instrument,Nchannels,ZenAng, &
+!                                    channels(1:Nchannels),surfem(1:Nchannels),co2,ch4,n2o,co,gbx)
+! Surafce emissivity
+        emsfc_lw = 1.
+        call construct_cosp_gridbox(dtime,time_bnds,radar_freq,surface_radar,use_mie_tables,use_gas_abs, &
+                                    do_ray,melt_lay,k2, &
                                     Npoints,Nlevels,Ncolumns,N_HYDRO,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, &
                                     lidar_ice_type,isccp_topheight,isccp_topheight_direction,overlap,emsfc_lw, &
 …
 ! sunlit calcule a partir de la fraction d ensoleillement par jour
+      do ip = 1, Npoints
+        if (sunlit(ip).le.0.) then
+           gbx%sunlit(ip)=0.
+        else
+           gbx%sunlit(ip)=1.
+        endif
+      enddo
+!      do ip = 1, Npoints
+!        if (sunlit(ip).le.0.) then
+!           gbx%sunlit(ip)=0.
+!        else
+!           gbx%sunlit(ip)=1.
+!        endif
+!      enddo
+       gbx%sunlit=sunlit
 ! A voir l equivalent LMDZ
 …
      gbx%Reff(:,:,I_LSCLIQ) = ref_liq*1e-6
      gbx%Reff(:,:,I_LSCICE) = ref_ice*1e-6
+!! AI A revoir
      gbx%Reff(:,:,I_CVCLIQ) = ref_liq*1e-6
      gbx%Reff(:,:,I_CVCICE) = ref_ice*1e-6
 …
         gbx%dem_c    = 0.
-! Surafce emissivity
-       emsfc_lw = 1.
 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
         ! Define new vertical grid
 …
         call construct_cosp_lidarstats(cfg,Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar)
         call construct_cosp_isccp(cfg,Npoints,Ncolumns,Nlevels,isccp)
+!! AI rajout
+        call construct_cosp_modis(cfg,Npoints,modis)
+!!
         call construct_cosp_misr(cfg,Npoints,misr)
+!        call construct_cosp_rttov(cfg,Npoints,Nchannels,rttov)
 !+++++++++++++ Open output files and define output files axis !+++++++++++++
 …
 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
         print *, 'Calling simulator...'
+        call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar)
+!! AI
+!        call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar)
+!#ifdef RTTOV
+!        call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar)
+!#else
+        call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar)
+!#endif
+!!
 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 !!!!!!!!!!!!!!!!!! Ecreture des sorties Cosp !!!!!!!!!!!!!!r!!!!!!:!!!!!
        print *, 'Calling write output'
         call cosp_output_write(Nlevlmdz, Npoints, Ncolumns, itap, dtime, freq_COSP, &
+                               cfg, gbx, vgrid, sglidar, stlidar, isccp)
+                               cfg, gbx, vgrid, sglidar, sgradar, stlidar, stradar, &
+                               isccp, misr, modis)
 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 …
         call free_cosp_isccp(isccp)
         call free_cosp_misr(misr)
+!! AI
+        call free_cosp_modis(modis)
+!        call free_cosp_rttov(rttov)
+!!
         call free_cosp_vgrid(vgrid)

LMDZ5/trunk/libf/phylmd/cosp/prec_scops.F

-                      r1907
+                      r2428
 ! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation.
 ! All rights reserved.
+! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/llnl/prec_scops.f $
+!
 ! Redistribution and use in source and binary forms, with or without modification, are permitted
 …
                                         ! 1 -> LS precipitation
                                         ! 2 -> CONV precipitation
                                         ! 3 -> both
+                    ! 3 -> both
                                         !TOA to SURFACE!!!!!!!!!!!!!!!!!!
       INTEGER flag_ls, flag_cv
       INTEGER frac_out_ls(npoints,ncol),frac_out_cv(npoints,ncol) !flag variables for
 …
       do ilev=1,nlev
+      do ibox=1,ncol
+        do j=1,npoints
+        prec_frac(j,ibox,ilev) = 0
+        do ibox=1,ncol
+          do j=1,npoints
+            prec_frac(j,ibox,ilev) = 0
+          enddo
         enddo
-      enddo
       enddo
       do j=1,npoints
        do ibox=1,ncol
        frac_out_ls(j,ibox)=0
        frac_out_cv(j,ibox)=0
        flag_ls=0
        flag_cv=0
+        frac_out_ls(j,ibox)=0
+        frac_out_cv(j,ibox)=0
+        flag_ls=0
+        flag_cv=0
         do ilev=1,nlev
          if (frac_out(j,ibox,ilev) .eq. 1) then
           flag_ls=1
          endif
          if (frac_out(j,ibox,ilev) .eq. 2) then
           flag_cv=1
          endif
         enddo !loop over nlev
         if (flag_ls .eq. 1) then
          frac_out_ls(j,ibox)=1
         endif
         if (flag_cv .eq. 1) then
          frac_out_cv(j,ibox)=1
         endif
+          if (frac_out(j,ibox,ilev) .eq. 1) then
+            flag_ls=1
+          endif
+          if (frac_out(j,ibox,ilev) .eq. 2) then
+            flag_cv=1
+          endif
+        enddo !loop over nlev
+        if (flag_ls .eq. 1) then
+           frac_out_ls(j,ibox)=1
+        endif
+        if (flag_cv .eq. 1) then
+           frac_out_cv(j,ibox)=1
+        endif
        enddo  ! loop over ncol
       enddo ! loop over npoints
 …
        do j=1,npoints
         flag_ls=0
         flag_cv=0
+        flag_cv=0
         if (ls_p_rate(j,1) .gt. 0.) then
          do ibox=1,ncol ! possibility ONE
           if (frac_out(j,ibox,1) .eq. 1) then
            prec_frac(j,ibox,1) = 1
            flag_ls=1
           endif
          enddo ! loop over ncol
          if (flag_ls .eq. 0) then ! possibility THREE
           do ibox=1,ncol
            if (frac_out(j,ibox,2) .eq. 1) then
             prec_frac(j,ibox,1) = 1
             flag_ls=1
            endif
           enddo ! loop over ncol
          endif
          if (flag_ls .eq. 0) then ! possibility Four
           do ibox=1,ncol
            if (frac_out_ls(j,ibox) .eq. 1) then
             prec_frac(j,ibox,1) = 1
             flag_ls=1
            endif
           enddo ! loop over ncol
          endif
          if (flag_ls .eq. 0) then ! possibility Five
           do ibox=1,ncol
 !         prec_frac(j,1:ncol,1) = 1
           prec_frac(j,ibox,1) = 1
           enddo ! loop over ncol
          endif
         endif
+            do ibox=1,ncol ! possibility ONE
+                if (frac_out(j,ibox,1) .eq. 1) then
+                    prec_frac(j,ibox,1) = 1
+                    flag_ls=1
+                endif
+            enddo ! loop over ncol
+            if (flag_ls .eq. 0) then ! possibility THREE
+                do ibox=1,ncol
+                    if (frac_out(j,ibox,2) .eq. 1) then
+                        prec_frac(j,ibox,1) = 1
+                        flag_ls=1
+                    endif
+                enddo ! loop over ncol
+            endif
+        if (flag_ls .eq. 0) then ! possibility Four
+        do ibox=1,ncol
+        if (frac_out_ls(j,ibox) .eq. 1) then
+            prec_frac(j,ibox,1) = 1
+            flag_ls=1
+        endif
+        enddo ! loop over ncol
+        endif
+        if (flag_ls .eq. 0) then ! possibility Five
+        do ibox=1,ncol
+    !     prec_frac(j,1:ncol,1) = 1
+        prec_frac(j,ibox,1) = 1
+        enddo ! loop over ncol
+            endif
+        endif
        ! There is large scale precipitation
         if (cv_p_rate(j,1) .gt. 0.) then
          do ibox=1,ncol ! possibility ONE
           if (frac_out(j,ibox,1) .eq. 2) then
            if (prec_frac(j,ibox,1) .eq. 0) then
             prec_frac(j,ibox,1) = 2
            else
             prec_frac(j,ibox,1) = 3
            endif
            flag_cv=1
           endif
          enddo ! loop over ncol
          if (flag_cv .eq. 0) then ! possibility THREE
           do ibox=1,ncol
            if (frac_out(j,ibox,2) .eq. 2) then
             if (prec_frac(j,ibox,1) .eq. 0) then
              prec_frac(j,ibox,1) = 2
             else
              prec_frac(j,ibox,1) = 3
             endif
             flag_cv=1
            endif
           enddo ! loop over ncol
          endif
          if (flag_cv .eq. 0) then ! possibility Four
           do ibox=1,ncol
            if (frac_out_cv(j,ibox) .eq. 1) then
             if (prec_frac(j,ibox,1) .eq. 0) then
              prec_frac(j,ibox,1) = 2
             else
              prec_frac(j,ibox,1) = 3
             endif
             flag_cv=1
            endif
           enddo ! loop over ncol
          endif
          if (flag_cv .eq. 0) then  ! possibility Five
           do ibox=1,cv_col
             if (prec_frac(j,ibox,1) .eq. 0) then
              prec_frac(j,ibox,1) = 2
             else
              prec_frac(j,ibox,1) = 3
             endif
           enddo !loop over cv_col
          endif
         endif
        ! There is convective precipitation
        enddo ! loop over npoints
+        prec_frac(j,ibox,1) = 2
+       else
+        prec_frac(j,ibox,1) = 3
+       endif
+       flag_cv=1
+      endif
+        enddo ! loop over ncol
+        if (flag_cv .eq. 0) then ! possibility THREE
+        do ibox=1,ncol
+        if (frac_out(j,ibox,2) .eq. 2) then
+                if (prec_frac(j,ibox,1) .eq. 0) then
+            prec_frac(j,ibox,1) = 2
+            else
+            prec_frac(j,ibox,1) = 3
+            endif
+            flag_cv=1
+        endif
+        enddo ! loop over ncol
+        endif
+        if (flag_cv .eq. 0) then ! possibility Four
+        do ibox=1,ncol
+        if (frac_out_cv(j,ibox) .eq. 1) then
+                if (prec_frac(j,ibox,1) .eq. 0) then
+            prec_frac(j,ibox,1) = 2
+            else
+            prec_frac(j,ibox,1) = 3
+            endif
+            flag_cv=1
+        endif
+        enddo ! loop over ncol
+        endif
+        if (flag_cv .eq. 0) then  ! possibility Five
+        do ibox=1,cv_col
+                if (prec_frac(j,ibox,1) .eq. 0) then
+            prec_frac(j,ibox,1) = 2
+            else
+            prec_frac(j,ibox,1) = 3
+            endif
+        enddo !loop over cv_col
+            endif
+        endif
+        ! There is convective precipitation
+        enddo ! loop over npoints
 !      end of initializing the top layer
 …
        do j=1,npoints
         flag_ls=0
         flag_cv=0
+        flag_cv=0
         if (ls_p_rate(j,ilev) .gt. 0.) then
          do ibox=1,ncol ! possibility ONE&TWO
 …
      &       .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then
            prec_frac(j,ibox,ilev) = 1
            flag_ls=1
+           flag_ls=1
           endif
          enddo ! loop over ncol
          if ((flag_ls .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE
           do ibox=1,ncol
            if (frac_out(j,ibox,ilev+1) .eq. 1) then
             prec_frac(j,ibox,ilev) = 1
             flag_ls=1
            endif
           enddo ! loop over ncol
          endif
          if (flag_ls .eq. 0) then ! possibility Four
           do ibox=1,ncol
            if (frac_out_ls(j,ibox) .eq. 1) then
             prec_frac(j,ibox,ilev) = 1
             flag_ls=1
            endif
           enddo ! loop over ncol
          endif
          if (flag_ls .eq. 0) then ! possibility Five
           do ibox=1,ncol
 !         prec_frac(j,1:ncol,ilev) = 1
           prec_frac(j,ibox,ilev) = 1
           enddo ! loop over ncol
          endif
         endif ! There is large scale precipitation
+        enddo ! loop over ncol
+        if ((flag_ls .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE
+        do ibox=1,ncol
+        if (frac_out(j,ibox,ilev+1) .eq. 1) then
+            prec_frac(j,ibox,ilev) = 1
+            flag_ls=1
+        endif
+        enddo ! loop over ncol
+        endif
+        if (flag_ls .eq. 0) then ! possibility Four
+        do ibox=1,ncol
+        if (frac_out_ls(j,ibox) .eq. 1) then
+            prec_frac(j,ibox,ilev) = 1
+            flag_ls=1
+        endif
+        enddo ! loop over ncol
+        endif
+        if (flag_ls .eq. 0) then ! possibility Five
+        do ibox=1,ncol
+!     prec_frac(j,1:ncol,ilev) = 1
+        prec_frac(j,ibox,ilev) = 1
+        enddo ! loop over ncol
+         endif
+      endif ! There is large scale precipitation
         if (cv_p_rate(j,ilev) .gt. 0.) then
          do ibox=1,ncol ! possibility ONE&TWO
 …
      &       .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then
             if (prec_frac(j,ibox,ilev) .eq. 0) then
              prec_frac(j,ibox,ilev) = 2
             else
              prec_frac(j,ibox,ilev) = 3
             endif
            flag_cv=1
           endif
          enddo ! loop over ncol
          if ((flag_cv .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE
           do ibox=1,ncol
            if (frac_out(j,ibox,ilev+1) .eq. 2) then
             if (prec_frac(j,ibox,ilev) .eq. 0) then
              prec_frac(j,ibox,ilev) = 2
             else
              prec_frac(j,ibox,ilev) = 3
             endif
             flag_cv=1
            endif
           enddo ! loop over ncol
          endif
          if (flag_cv .eq. 0) then ! possibility Four
           do ibox=1,ncol
            if (frac_out_cv(j,ibox) .eq. 1) then
             if (prec_frac(j,ibox,ilev) .eq. 0) then
              prec_frac(j,ibox,ilev) = 2
             else
              prec_frac(j,ibox,ilev) = 3
             endif
             flag_cv=1
            endif
           enddo ! loop over ncol
          endif
          if (flag_cv .eq. 0) then  ! possibility Five
           do ibox=1,cv_col
             if (prec_frac(j,ibox,ilev) .eq. 0) then
              prec_frac(j,ibox,ilev) = 2
             else
              prec_frac(j,ibox,ilev) = 3
             endif
           enddo !loop over cv_col
          endif
         endif ! There is convective precipitation
        enddo ! loop over npoints
       enddo ! loop over nlev
+         prec_frac(j,ibox,ilev) = 2
+        else
+         prec_frac(j,ibox,ilev) = 3
+        endif
+        flag_cv=1
+        endif
+       enddo ! loop over ncol
+        if ((flag_cv .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE
+        do ibox=1,ncol
+        if (frac_out(j,ibox,ilev+1) .eq. 2) then
+                if (prec_frac(j,ibox,ilev) .eq. 0) then
+            prec_frac(j,ibox,ilev) = 2
+            else
+            prec_frac(j,ibox,ilev) = 3
+            endif
+            flag_cv=1
+        endif
+        enddo ! loop over ncol
+        endif
+        if (flag_cv .eq. 0) then ! possibility Four
+        do ibox=1,ncol
+        if (frac_out_cv(j,ibox) .eq. 1) then
+                if (prec_frac(j,ibox,ilev) .eq. 0) then
+            prec_frac(j,ibox,ilev) = 2
+            else
+            prec_frac(j,ibox,ilev) = 3
+            endif
+            flag_cv=1
+        endif
+        enddo ! loop over ncol
+        endif
+        if (flag_cv .eq. 0) then  ! possibility Five
+        do ibox=1,cv_col
+                if (prec_frac(j,ibox,ilev) .eq. 0) then
+            prec_frac(j,ibox,ilev) = 2
+            else
+            prec_frac(j,ibox,ilev) = 3
+            endif
+        enddo !loop over cv_col
+            endif
+        endif ! There is convective precipitation
+        enddo ! loop over npoints
+        enddo ! loop over nlev
       end

LMDZ5/trunk/libf/phylmd/cosp/radar_simulator.F90

-                      r1907
+                      r2428
+  subroutine radar_simulator(freq,k2,do_ray,use_gas_abs,use_mie_table,mt, &
+    nhclass,hp,nprof,ngate,nsizes,D,hgt_matrix,hm_matrix,re_matrix,p_matrix,t_matrix, &
+    rh_matrix,Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe, &
+  subroutine radar_simulator( &
+    hp, &
+    nprof,ngate, &
+    undef, &
+    hgt_matrix,hm_matrix,re_matrix,Np_matrix, &
+    p_matrix,t_matrix,rh_matrix, &
+    Ze_non,Ze_ray,a_to_vol,g_to_vol,dBZe, &
     g_to_vol_in,g_to_vol_out)
-!     rh_matrix,Ze_non,Ze_ray,kr_matrix,g_atten_to_vol,dBZe)
   use m_mrgrnk
 …
   use optics_lib
   use radar_simulator_types
+  use scale_LUTs_io
   implicit none
 ! Purpose:
+!
 !   Simulates a vertical profile of radar reflectivity
+!   Part of QuickBeam v1.04 by John Haynes & Roger Marchand
+!   Originally Part of QuickBeam v1.04 by John Haynes & Roger Marchand.
+!   but has been substantially modified since that time by
+!   Laura Fowler and Roger Marchand (see modifications below).
+!
 ! Inputs:
+!   [freq]            radar frequency (GHz), can be anything unless
+!                     use_mie_table=1, in which case one of 94,35,13.8,9.6,3
+!   [k2]              |K|^2, the dielectric constant, set to -1 to use the
+!                     frequency dependent default
+!   [do_ray]          1=do Rayleigh calcs, 0=not
+!   [use_gas_abs]     1=do gaseous abs calcs, 0=not,
+!                     2=use same as first profile (undocumented)
+!   [use_mie_table]   1=use Mie tables, 0=not
+!   [mt]              Mie look up table
+!   [nhclass]         number of hydrometeor types
+!   [hp]              structure that defines hydrometeor types
+!
+!   [hp]              structure that defines hydrometeor types and other radar properties
+!
 !   [nprof]           number of hydrometeor profiles
 !   [ngate]           number of vertical layers
+!   [nsizes]          number of discrete particles in [D]
+!   [D]               array of discrete particles (um)
+!
+!
+!   [undef]           missing data value
 !   (The following 5 arrays must be in order from closest to the radar
 !    to farthest...)
+!
 !   [hgt_matrix]      height of hydrometeors (km)
+!   [p_matrix]        pressure profile (hPa)
+!   [t_matrix]        temperature profile (K)
+!   [rh_matrix]       relative humidity profile (%) -- only needed if gaseous aborption calculated.
+!
 !   [hm_matrix]       table of hydrometeor mixing rations (g/kg)
+!   [re_matrix]       OPTIONAL table of hydrometeor effective radii (microns)
+!   [p_matrix]        pressure profile (hPa)
+!   [t_matrix]        temperature profile (C)
+!   [rh_matrix]       relative humidity profile (%)
+!   [re_matrix]       table of hydrometeor effective radii.  0 ==> use defaults. (units=microns)
+!   [Np_matrix]       table of hydrometeor number concentration.  0 ==> use defaults. (units = 1/kg)
+!
 ! Outputs:
+!
 !   [Ze_non]          radar reflectivity without attenuation (dBZ)
 !   [Ze_ray]          Rayleigh reflectivity (dBZ)
 …
 ! Created:
 !   11/28/2005  John Haynes (haynes@atmos.colostate.edu)
+!
 ! Modified:
 !   09/2006  placed into subroutine form, scaling factors (Roger Marchand,JMH)
+!   09/2006  placed into subroutine form (Roger Marchand,JMH)
 !   08/2007  added equivalent volume spheres, Z and N scalling most distrubtion types (Roger Marchand)
 !   01/2008  'Do while' to determine if hydrometeor(s) present in volume
 !             changed for vectorization purposes (A. Bodas-Salcedo)
+!
+!   07/2010  V3.0 ... Modified to load or save scale factors to disk as a Look-Up Table (LUT)
+!  ... All hydrometeor and radar simulator properties now included in hp structure
+!  ... hp structure should be initialized by call to radar_simulator_init prior
+!  ... to calling this subroutine.
+!     Also ... Support of Morrison 2-moment style microphyscis (Np_matrix) added
+!  ... Changes implement by Roj Marchand following work by Laura Fowler
+!
+!   10/2011  Modified ngate loop to go in either direction depending on flag
+!     hp%radar_at_layer_one.  This affects the direction in which attenuation is summed.
+!
+!     Also removed called to AVINT for gas and hydrometeor attenuation and replaced with simple
+!     summation. (Roger Marchand)
+!
+!
 ! ----- INPUTS -----
+  type(mie), intent(in) :: mt
+  logical, parameter  ::  DO_LUT_TEST = .false.
+  logical, parameter  ::  DO_NP_TEST = .false.
   type(class_param), intent(inout) :: hp
+  real*8, intent(in) :: freq,k2
+  integer, intent(in) ::  do_ray,use_gas_abs,use_mie_table, &
+    nhclass,nprof,ngate,nsizes
+  real*8, dimension(nsizes), intent(in) :: D
+  real*8, dimension(nprof,ngate), intent(in) :: hgt_matrix, p_matrix, &
+    t_matrix,rh_matrix
+  real*8, dimension(nhclass,nprof,ngate), intent(in) :: hm_matrix
+  real*8, dimension(nhclass,nprof,ngate), intent(inout) :: re_matrix
+  integer, intent(in) ::  nprof,ngate
+  real undef
+  real*8, dimension(nprof,ngate), intent(in) :: &
+    hgt_matrix, p_matrix,t_matrix,rh_matrix
+  real*8, dimension(hp%nhclass,nprof,ngate), intent(in) :: hm_matrix
+  real*8, dimension(hp%nhclass,nprof,ngate), intent(inout) :: re_matrix
+  real*8, dimension(hp%nhclass,nprof,ngate), intent(in)    :: Np_matrix
 ! ----- OUTPUTS -----
   real*8, dimension(nprof,ngate), intent(out) :: Ze_non,Ze_ray, &
         g_atten_to_vol,dBZe,h_atten_to_vol
+       g_to_vol,dBZe,a_to_vol
 ! ----- OPTIONAL -----
   real*8, optional, dimension(ngate,nprof) :: &
+  real*8, optional, dimension(nprof,ngate) :: &
   g_to_vol_in,g_to_vol_out ! integrated atten due to gases, r>v (dB). This allows to output and then input
                            ! the same gaseous absorption in different calls. Optional to allow compatibility
                            ! with original version. A. Bodas April 2008.
 !  real*8, dimension(nprof,ngate) :: kr_matrix
 ! ----- INTERNAL -----
+  real, parameter :: one_third = 1.0/3.0
+  real*8 :: t_kelvin
   integer :: &
+  phase, &                      ! 0=liquid, 1=ice
+  ns                            ! number of discrete drop sizes
+  integer*4, dimension(ngate) :: &
+  hydro                         ! 1=hydrometeor in vol, 0=none
+  phase, & ! 0=liquid, 1=ice
+  ns       ! number of discrete drop sizes
+  logical :: hydro      ! true=hydrometeor in vol, false=none
   real*8 :: &
   rho_a, &                      ! air density (kg m^-3)
   gases                         ! function: 2-way gas atten (dB/km)
+  rho_a, &   ! air density (kg m^-3)
+  gases      ! function: 2-way gas atten (dB/km)
   real*8, dimension(:), allocatable :: &
   Di, Deq, &                    ! discrete drop sizes (um)
   Ni, Ntemp, &                  ! discrete concentrations (cm^-3 um^-1)
   rhoi                          ! discrete densities (kg m^-3)
   real*8, dimension(ngate) :: &
   z_vol, &                      ! effective reflectivity factor (mm^6/m^3)
+  Di, Deq, &   ! discrete drop sizes (um)
+  Ni, &        ! discrete concentrations (cm^-3 um^-1)
+  rhoi         ! discrete densities (kg m^-3)
+  real*8, dimension(nprof, ngate) :: &
+  z_vol, &      ! effective reflectivity factor (mm^6/m^3)
   z_ray, &                      ! reflectivity factor, Rayleigh only (mm^6/m^3)
+  kr_vol, &                     ! attenuation coefficient hydro (dB/km)
+  g_vol, &                      ! attenuation coefficient gases (dB/km)
+  a_to_vol, &                   ! integrated atten due to hydometeors, r>v (dB)
+  g_to_vol                      ! integrated atten due to gases, r>v (dB)
+  kr_vol, &     ! attenuation coefficient hydro (dB/km)
+  g_vol         ! attenuation coefficient gases (dB/km)
   integer,parameter :: KR8 = selected_real_kind(15,300)
   real*8, parameter :: xx = -1.0_KR8
   real*8,  dimension(:), allocatable :: xxa
+  real*8 :: kr, ze, zr, pi, scale_factor, tc, Re, ld, tmp1, ze2, kr2,apm,bpm
+  real*8 :: kr, ze, zr, pi, scale_factor, tc, Re, ld, tmp1, ze2, kr2, apm, bpm
+  real*8 :: half_a_atten_current,half_a_atten_above
+  real*8 :: half_g_atten_current,half_g_atten_above
   integer*4 :: tp, i, j, k, pr, itt, iff
   real*8 bin_length,step,base,step_list(25),base_list(25)
+  real*8    step,base, Np
   integer*4 iRe_type,n,max_bin
+  integer   start_gate,end_gate,d_gate
   logical :: g_to_vol_in_present, g_to_vol_out_present
   ! Logicals to avoid calling present within the loops
   g_to_vol_in_present  = present(g_to_vol_in)
   g_to_vol_out_present = present(g_to_vol_out)
+    ! set up Re bins for z_scalling
+        bin_length=50;
+        max_bin=25
+        step_list(1)=1
+        base_list(1)=75
+        do j=2,max_bin
+                step_list(j)=3*(j-1);
+                if(step_list(j)>bin_length) then
+                        step_list(j)=bin_length;
+                endif
+                base_list(j)=base_list(j-1)+floor(bin_length/step_list(j-1));
+        enddo
+  !
+  ! load scaling matricies from disk -- but only the first time this subroutine is called
+  !
+  if(hp%load_scale_LUTs) then
+    call load_scale_LUTs(hp)
+    hp%load_scale_LUTs=.false.
+    hp%Z_scale_added_flag = .false. ! will be set true if scaling Look Up Tables are modified during run
+  endif
   pi = acos(-1.0)
+  if (use_mie_table == 1) iff = infind(mt%freq,freq,sort=1)
+!   ----- Initialisation -----
+  g_to_vol = 0.0
+  a_to_vol = 0.0
+  z_vol    = 0.0
+  z_ray    = 0.0
+  kr_vol   = 0.0
+!   // loop over each range gate (ngate) ... starting with layer closest to the radar !
+  if(hp%radar_at_layer_one) then
+    start_gate=1
+    end_gate=ngate
+    d_gate=1
+  else
+    start_gate=ngate
+    end_gate=1
+    d_gate=-1
+  endif
+  do k=start_gate,end_gate,d_gate
   ! // loop over each profile (nprof)
+  do pr=1,nprof
+!   ----- calculations for each volume -----
+    z_vol(:) = 0
+    z_ray(:) = 0
+    kr_vol(:) = 0
+    hydro(:) = 0
+!   // loop over eacho range gate (ngate)
+    do k=1,ngate
+    do pr=1,nprof
+      t_kelvin = t_matrix(pr,k)
 !     :: determine if hydrometeor(s) present in volume
       hydro(k) = 0
       do j=1,nhclass ! Do while changed for vectorization purposes (A. B-S)
+      hydro = .false.
+      do j=1,hp%nhclass
         if ((hm_matrix(j,pr,k) > 1E-12) .and. (hp%dtype(j) > 0)) then
           hydro(k) = 1
+          hydro = .true.
           exit
         endif
       enddo
+      if (hydro(k) == 1) then
+!     :: if there is hydrometeor in the volume
+        rho_a = (p_matrix(pr,k)*100.)/(287*(t_matrix(pr,k)+273.15))
+!     :: if there is hydrometeor in the volume
+      if (hydro) then
+        rho_a = (p_matrix(pr,k)*100.)/(287.0*(t_kelvin))
 !       :: loop over hydrometeor type
+        do tp=1,nhclass
+        do tp=1,hp%nhclass
           if (hm_matrix(tp,pr,k) <= 1E-12) cycle
+          phase = hp%phase(tp)
+          if(phase==0) then
+                itt = infind(mt_ttl,t_matrix(pr,k))
+          else
+                itt = infind(mt_tti,t_matrix(pr,k))
+          phase = hp%phase(tp)
+          if (phase==0) then
+            itt = infind(hp%mt_ttl,t_kelvin)
+          else
+            itt = infind(hp%mt_tti,t_kelvin)
+          endif
+          if (re_matrix(tp,pr,k).eq.0) then
+            call calc_Re(hm_matrix(tp,pr,k),Np_matrix(tp,pr,k),rho_a, &
+              hp%dtype(tp),hp%dmin(tp),hp%dmax(tp),hp%apm(tp),hp%bpm(tp), &
+              hp%rho(tp),hp%p1(tp),hp%p2(tp),hp%p3(tp),Re)
+            re_matrix(tp,pr,k)=Re
+          else
+            if (Np_matrix(tp,pr,k)>0) then
+               print *, 'Warning: Re and Np set for the same ', &
+                        'volume & hydrometeor type.  Np is being ignored.'
+            endif
+            Re = re_matrix(tp,pr,k)
+          endif
+          iRe_type=1
+          if(Re.gt.0) then
+            ! determine index in to scale LUT
+            !
+            ! distance between Re points (defined by "base" and "step") for
+            ! each interval of size Re_BIN_LENGTH
+            ! Integer asignment, avoids calling floor intrinsic
+            n=Re/Re_BIN_LENGTH
+            if (n>=Re_MAX_BIN) n=Re_MAX_BIN-1
+            step=hp%step_list(n+1)
+            base=hp%base_list(n+1)
+            iRe_type=Re/step
+            if (iRe_type.lt.1) iRe_type=1
+            Re=step*(iRe_type+0.5)      ! set value of Re to closest value allowed in LUT.
+            iRe_type=iRe_type+base-int(n*Re_BIN_LENGTH/step)
+            ! make sure iRe_type is within bounds
+            if (iRe_type.ge.nRe_types) then
+!               write(*,*) 'Warning: size of Re exceed value permitted ', &
+!                    'in Look-Up Table (LUT).  Will calculate. '
+               ! no scaling allowed
+               iRe_type=nRe_types
+               hp%Z_scale_flag(tp,itt,iRe_type)=.false.
+            else
+               ! set value in re_matrix to closest values in LUT
+              if (.not. DO_LUT_TEST) re_matrix(tp,pr,k)=Re
+            endif
+          endif
+          ! use Ze_scaled, Zr_scaled, and kr_scaled ... if know them
+          ! if not we will calculate Ze, Zr, and Kr from the distribution parameters
+          if( (.not. hp%Z_scale_flag(tp,itt,iRe_type)) .or. DO_LUT_TEST)  then
+            ! :: create a distribution of hydrometeors within volume
+            select case(hp%dtype(tp))
+              case(4)
+                ns = 1
+                allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns))
+                Di = hp%p1(tp)
+                Ni = 0.
+              case default
+                ns = nd   ! constant defined in radar_simulator_types.f90
+                allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns))
+                Di = hp%D
+                Ni = 0.
+            end select
+            call dsd(hm_matrix(tp,pr,k),re_matrix(tp,pr,k),Np_matrix(tp,pr,k), &
+                     Di,Ni,ns,hp%dtype(tp),rho_a,t_kelvin, &
+                     hp%dmin(tp),hp%dmax(tp),hp%apm(tp),hp%bpm(tp), &
+                     hp%rho(tp),hp%p1(tp),hp%p2(tp),hp%p3(tp))
+            ! calculate particle density
+            if (phase == 1) then
+              if (hp%rho(tp) < 0) then
+                ! Use equivalent volume spheres.
+                hp%rho_eff(tp,1:ns,iRe_type) = 917                              ! solid ice == equivalent volume approach
+                Deq = ( ( 6/pi*hp%apm(tp)/917 ) ** (1.0/3.0) ) * ( (Di*1E-6) ** (hp%bpm(tp)/3.0) )  * 1E6
+                ! alternative is to comment out above two lines and use the following block
+                ! MG Mie approach - adjust density of sphere with D = D_characteristic to match particle density
+                !
+                ! hp%rho_eff(tp,1:ns,iRe_type) = (6/pi)*hp%apm(tp)*(Di*1E-6)**(hp%bpm(tp)-3)   !MG Mie approach
+                ! as the particle size gets small it is possible that the mass to size relationship of
+                ! (given by power law in hclass.data) can produce impossible results
+                ! where the mass is larger than a solid sphere of ice.
+                ! This loop ensures that no ice particle can have more mass/density larger than an ice sphere.
+                ! do i=1,ns
+                ! if(hp%rho_eff(tp,i,iRe_type) > 917 ) then
+                ! hp%rho_eff(tp,i,iRe_type) = 917
+                ! endif
+                ! enddo
+              else
+                ! Equivalent volume sphere (solid ice rho_ice=917 kg/m^3).
+                hp%rho_eff(tp,1:ns,iRe_type) = 917
+                Deq=Di * ((hp%rho(tp)/917)**(1.0/3.0))
+                ! alternative ... coment out above two lines and use the following for MG-Mie
+                ! hp%rho_eff(tp,1:ns,iRe_type) = hp%rho(tp)   !MG Mie approach
+              endif
+            else
+              ! I assume here that water phase droplets are spheres.
+              ! hp%rho should be ~ 1000  or hp%apm=524 .and. hp%bpm=3
+              Deq = Di
+            endif
+            ! calculate effective reflectivity factor of volume
+            xxa = -9.9
+            rhoi = hp%rho_eff(tp,1:ns,iRe_type)
+            call zeff(hp%freq,Deq,Ni,ns,hp%k2,t_kelvin,phase,hp%do_ray, &
+                      ze,zr,kr,xxa,xxa,rhoi)
+            ! test code ... compare Np value input to routine with sum of DSD
+            ! NOTE: if .not. DO_LUT_TEST, then you are checking the LUT approximation
+            ! not just the DSD representation given by Ni
+            if(Np_matrix(tp,pr,k)>0 .and. DO_NP_TEST ) then
+              Np = path_integral(Ni,Di,1,ns-1)/rho_a*1E6
+              ! Note: Representation is not great or small Re < 2
+              if( (Np_matrix(tp,pr,k)-Np)/Np_matrix(tp,pr,k)>0.1 ) then
+                write(*,*) 'Error: Np input does not match sum(N)'
+                write(*,*) tp,pr,k,Re,Ni(1),Ni(ns),10*log10(ze)
+                write(*,*) Np_matrix(tp,pr,k),Np,(Np_matrix(tp,pr,k)-Np)/Np_matrix(tp,pr,k)
+                write(*,*)
+              endif
+            endif
+            deallocate(Di,Ni,rhoi,xxa,Deq)
+            ! LUT test code
+            ! This segment of code compares full calculation to scaling result
+            if ( hp%Z_scale_flag(tp,itt,iRe_type) .and. DO_LUT_TEST )  then
+              scale_factor=rho_a*hm_matrix(tp,pr,k)
+              ! if more than 2 dBZe difference print error message/parameters.
+              if ( abs(10*log10(ze) - 10*log10(hp%Ze_scaled(tp,itt,iRe_type) * &
+                   scale_factor)) > 2 ) then
+                write(*,*) 'Roj Error: ',tp,itt,iRe_type,hp%Z_scale_flag(tp,itt,iRe_type),n,step,base
+                write(*,*) 10*log10(ze),10*log10(hp%Ze_scaled(tp,itt,iRe_type) * scale_factor)
+                write(*,*) hp%Ze_scaled(tp,itt,iRe_type),scale_factor
+                write(*,*) re_matrix(tp,pr,k),Re
+                write(*,*)
+              endif
+            endif
+          else ! can use z scaling
+            scale_factor=rho_a*hm_matrix(tp,pr,k)
+            zr = hp%Zr_scaled(tp,itt,iRe_type) * scale_factor
+            ze = hp%Ze_scaled(tp,itt,iRe_type) * scale_factor
+            kr = hp%kr_scaled(tp,itt,iRe_type) * scale_factor
+          endif  ! end z_scaling
+          kr_vol(pr,k) = kr_vol(pr,k) + kr
+          z_vol(pr,k)  = z_vol(pr,k)  + ze
+          z_ray(pr,k)  = z_ray(pr,k)  + zr
+          ! construct Ze_scaled, Zr_scaled, and kr_scaled ... if we can
+          if ( .not. hp%Z_scale_flag(tp,itt,iRe_type) ) then
+            if (iRe_type>1) then
+              scale_factor=rho_a*hm_matrix(tp,pr,k)
+              hp%Ze_scaled(tp,itt,iRe_type) = ze/ scale_factor
+              hp%Zr_scaled(tp,itt,iRe_type) = zr/ scale_factor
+              hp%kr_scaled(tp,itt,iRe_type) = kr/ scale_factor
+              hp%Z_scale_flag(tp,itt,iRe_type) = .true.
+              hp%Z_scale_added_flag(tp,itt,iRe_type)=.true.
+            endif
+          endif
+        enddo   ! end loop of tp (hydrometeor type)
+      else
+!     :: volume is hydrometeor-free
+        kr_vol(pr,k) = 0
+        z_vol(pr,k)  = undef
+        z_ray(pr,k)  = undef
       endif
+          ! calculate Re if we have an exponential distribution with fixed No ... precipitation type particle
+          if( hp%dtype(tp)==2 .and. abs(hp%p2(tp)+1) < 1E-8)  then
+                apm=hp%apm(tp)
+                bpm=hp%bpm(tp)
+                if ((hp%rho(tp) > 0) .and. (apm < 0)) then
+                        apm = (pi/6)*hp%rho(tp)
+                        bpm = 3.
+                endif
+                tmp1 = 1./(1.+bpm)
+                ld = ((apm*gamma(1.+bpm)*hp%p1(tp))/(rho_a*hm_matrix(tp,pr,k)*1E-3))**tmp1
+                Re = 1.5E6/ld
+                re_matrix(tp,pr,k) = Re;
+          endif
+          if(re_matrix(tp,pr,k).eq.0) then
+                iRe_type=1
+                Re=0
+          else
+                iRe_type=1
+                Re=re_matrix(tp,pr,k)
+                n=floor(Re/bin_length)
+                if(n==0) then
+                        if(Re<25) then
+                                step=0.5
+                                base=0
+                        else
+                                step=1
+                                base=25
+                        endif
+                else
+                        if(n>max_bin) then
+                                n=max_bin
+                        endif
+                        step=step_list(n)
+                        base=base_list(n)
+                endif
+                iRe_type=floor(Re/step)
+                if(iRe_type.lt.1) then
+                        iRe_type=1
+                endif
+                Re=step*(iRe_type+0.5)
+                iRe_type=iRe_type+base-floor(n*bin_length/step)
+                ! make sure iRe_type is within bounds
+                if(iRe_type.ge.nRe_types) then
+                        ! print *, tp, re_matrix(tp,pr,k), Re, iRe_type
+                        ! no scaling allowed
+                        Re=re_matrix(tp,pr,k)
+                        iRe_type=nRe_types
+                        hp%z_flag(tp,itt,iRe_type)=.false.
+                        hp%scaled(tp,iRe_type)=.false.
+                endif
+          endif
+          ! use Ze_scaled, Zr_scaled, and kr_scaled ... if know them
+          ! if not we will calculate Ze, Zr, and Kr from the distribution parameters
+          if( .not. hp%z_flag(tp,itt,iRe_type) )  then
+!         :: create a distribution of hydrometeors within volume
+          select case(hp%dtype(tp))
+          case(4)
+            ns = 1
+            allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns))
+            if (use_mie_table == 1) allocate(mt_qext(ns),mt_qbsca(ns),Ntemp(ns))
+            Di = hp%p1(tp)
+            Ni = 0.
+          case default
+            ns = nsizes
+            allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns))
+            if (use_mie_table == 1) allocate(mt_qext(ns),mt_qbsca(ns),Ntemp(ns))
+            Di = D
+            Ni = 0.
+          end select
+!         :: create a DSD (using scaling factor if applicable)
+          ! hp%scaled(tp,iRe_type)=.false.   ! turn off N scaling
+          call dsd(hm_matrix(tp,pr,k),Re,Di,Ni,ns,hp%dtype(tp),rho_a, &
+            t_matrix(pr,k),hp%dmin(tp),hp%dmax(tp),hp%apm(tp),hp%bpm(tp), &
+            hp%rho(tp),hp%p1(tp),hp%p2(tp),hp%p3(tp),hp%fc(tp,1:ns,iRe_type), &
+            hp%scaled(tp,iRe_type))
+!         :: calculate particle density
+          ! if ((hp%rho_eff(tp,1,iRe_type) < 0) .and. (phase == 1)) then
+          if (phase == 1) then
+            if (hp%rho(tp) < 0) then
+                ! MG Mie approach - adjust density of sphere with D = D_characteristic to match particle density
+                ! hp%rho_eff(tp,1:ns,iRe_type) = (6/pi)*hp%apm(tp)*(Di*1E-6)**(hp%bpm(tp)-3)   !MG Mie approach
+                ! as the particle size gets small it is possible that the mass to size relationship of
+                ! (given by power law in hclass.data) can produce impossible results
+                ! where the mass is larger than a solid sphere of ice.
+                ! This loop ensures that no ice particle can have more mass/density larger than an ice sphere.
+                ! do i=1,ns
+                ! if(hp%rho_eff(tp,i,iRe_type) > 917 ) then
+                !       hp%rho_eff(tp,i,iRe_type) = 917
+                !endif
+                !enddo
+                ! alternative is to use equivalent volume spheres.
+                hp%rho_eff(tp,1:ns,iRe_type) = 917                              ! solid ice == equivalent volume approach
+                Deq = ( ( 6/pi*hp%apm(tp)/917 ) ** (1.0/3.0) ) * &
+                           ( (Di*1E-6) ** (hp%bpm(tp)/3.0) )  * 1E6             ! Di now really Deq in microns.
+      !     :: attenuation due to hydrometeors between radar and volume
+      !
+      ! NOTE old scheme integrates attenuation only for the layers ABOVE
+      ! the current layer ... i.e. 1 to k-1 rather than 1 to k ...
+      ! which may be a problem.   ROJ
+      ! in the new scheme I assign half the attenuation to the current layer
+      if(d_gate==1) then
+        ! dheight calcuations assumes hgt_matrix points are the cell mid-points.
+        if (k>2) then
+          ! add to previous value to half of above layer + half of current layer
+          a_to_vol(pr,k)=  a_to_vol(pr,k-1) + &
+             (kr_vol(pr,k-1)+kr_vol(pr,k))*(hgt_matrix(pr,k-1)-hgt_matrix(pr,k))
+        else
+          a_to_vol(pr,k)=  kr_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k+1))
+        endif
+      else   ! d_gate==-1
+        if(k<ngate) then
+          ! add to previous value half of above layer + half of current layer
+          a_to_vol(pr,k) = a_to_vol(pr,k+1) + &
+              (kr_vol(pr,k+1)+kr_vol(pr,k))*(hgt_matrix(pr,k+1)-hgt_matrix(pr,k))
+        else
+          a_to_vol(pr,k)= kr_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k-1))
+        endif
+      endif
+      !     :: attenuation due to gaseous absorption between radar and volume
+      if (g_to_vol_in_present) then
+        g_to_vol(pr,k) = g_to_vol_in(pr,k)
+      else
+        if ( (hp%use_gas_abs == 1) .or. ((hp%use_gas_abs == 2) .and. (pr == 1)) ) then
+          g_vol(pr,k) = gases(p_matrix(pr,k),t_kelvin,rh_matrix(pr,k),hp%freq)
+          if (d_gate==1) then
+            if (k>1) then
+              ! add to previous value to half of above layer + half of current layer
+              g_to_vol(pr,k) =  g_to_vol(pr,k-1) + &
+.5*(g_vol(pr,k-1)+g_vol(pr,k))*(hgt_matrix(pr,k-1)-hgt_matrix(pr,k))
             else
+                ! hp%rho_eff(tp,1:ns,iRe_type) = hp%rho(tp)   !MG Mie approach
+                ! Equivalent volume sphere (solid ice rho_ice=917 kg/m^3).
+                hp%rho_eff(tp,1:ns,iRe_type) = 917
+                Deq=Di * ((hp%rho(tp)/917)**(1.0/3.0))
+            endif
+                ! if using equivalent volume spheres
+                if (use_mie_table == 1) then
+                        Ntemp=Ni
+                        ! Find N(Di) from N(Deq) which we know
+                        do i=1,ns
+                                j=infind(Deq,Di(i))
+                                Ni(i)=Ntemp(j)
+                        enddo
+                else
+                        ! just use Deq and D variable input to mie code
+                        Di=Deq;
+                endif
+          endif
+          rhoi = hp%rho_eff(tp,1:ns,iRe_type)
+!         :: calculate effective reflectivity factor of volume
+          if (use_mie_table == 1) then
+            if ((hp%dtype(tp) == 4) .and. (hp%idd(tp) < 0)) then
+              hp%idd(tp) = infind(mt%D,Di(1))
+            endif
+            if (phase == 0) then
+              ! itt = infind(mt_ttl,t_matrix(pr,k))
+              select case(hp%dtype(tp))
+              case(4)
+                mt_qext(1) = mt%qext(hp%idd(tp),itt,1,iff)
+                mt_qbsca(1) = mt%qbsca(hp%idd(tp),itt,1,iff)
+              case default
+                mt_qext = mt%qext(:,itt,1,iff)
+                mt_qbsca = mt%qbsca(:,itt,1,iff)
+              end select
+          call zeff(freq,Di,Ni,ns,k2,mt_ttl(itt),0,do_ray, &
+                ze,zr,kr,mt_qext,mt_qbsca,xx)
+            else
+              ! itt = infind(mt_tti,t_matrix(pr,k))
+              select case(hp%dtype(tp))
+              case(4)
+                if (hp%ifc(tp,1,iRe_type) < 0) then
+                  hp%ifc(tp,1,iRe_type) = infind(mt%f,rhoi(1)/917.)
+                endif
+                mt_qext(1) = &
+                  mt%qext(hp%idd(tp),itt+cnt_liq,hp%ifc(tp,1,iRe_type),iff)
+                mt_qbsca(1) = &
+                  mt%qbsca(hp%idd(tp),itt+cnt_liq,hp%ifc(tp,1,iRe_type),iff)
+              case default
+                do i=1,ns
+                  if (hp%ifc(tp,i,iRe_type) < 0) then
+                    hp%ifc(tp,i,iRe_type) = infind(mt%f,rhoi(i)/917.)
+                  endif
+                  mt_qext(i) = mt%qext(i,itt+cnt_liq,hp%ifc(tp,i,iRe_type),iff)
+                  mt_qbsca(i) = mt%qbsca(i,itt+cnt_liq,hp%ifc(tp,i,iRe_type),iff)
+                enddo
+              end select
+                   call zeff(freq,Di,Ni,ns,k2,mt_tti(itt),1,do_ray, &
+                ze,zr,kr,mt_qext,mt_qbsca,xx)
+            endif
+          else
+            xxa = -9.9
+            call zeff(freq,Di,Ni,ns,k2,t_matrix(pr,k),phase,do_ray, &
+              ze,zr,kr,xxa,xxa,rhoi)
+          endif  ! end of use mie table
+                ! xxa = -9.9
+                !call zeff(freq,Di,Ni,ns,k2,t_matrix(pr,k),phase,do_ray, &
+                !       ze2,zr,kr2,xxa,xxa,rhoi)
+                ! if(abs(ze2-ze)/ze2 > 0.1) then
+                ! if(abs(kr2-kr)/kr2 > 0.1) then
+                ! write(*,*) pr,k,tp,ze2,ze2-ze,abs(ze2-ze)/ze2,itt+cnt_liq,iff
+                ! write(*,*) pr,k,tp,ze2,kr2,kr2-kr,abs(kr2-kr)/kr2
+                ! stop
+                !endif
+          deallocate(Di,Ni,rhoi,xxa,Deq)
+          if (use_mie_table == 1) deallocate(mt_qext,mt_qbsca,Ntemp)
+          else ! can use z scaling
+                if( hp%dtype(tp)==2 .and. abs(hp%p2(tp)+1) < 1E-8 )  then
+                        ze = hp%Ze_scaled(tp,itt,iRe_type)
+                        zr = hp%Zr_scaled(tp,itt,iRe_type)
+                        kr = hp%kr_scaled(tp,itt,iRe_type)
+                else
+                        scale_factor=rho_a*hm_matrix(tp,pr,k)
+                        zr = hp%Zr_scaled(tp,itt,iRe_type) * scale_factor
+                        ze = hp%Ze_scaled(tp,itt,iRe_type) * scale_factor
+                        kr = hp%kr_scaled(tp,itt,iRe_type) * scale_factor
+                endif
+          endif  ! end z_scaling
+          ! kr=0
+          kr_vol(k) = kr_vol(k) + kr
+          z_vol(k) = z_vol(k) + ze
+          z_ray(k) = z_ray(k) + zr
+          ! construct Ze_scaled, Zr_scaled, and kr_scaled ... if we can
+          if( .not. hp%z_flag(tp,itt,iRe_type) .and. 1.eq.1 ) then
+                if( ( (hp%dtype(tp)==1 .or. hp%dtype(tp)==5 .or.  hp%dtype(tp)==2)  .and. abs(hp%p1(tp)+1) < 1E-8  ) .or. &
+                    (  hp%dtype(tp)==3 .or. hp%dtype(tp)==4 )  &
+                ) then
+                        scale_factor=rho_a*hm_matrix(tp,pr,k)
+                        hp%Ze_scaled(tp,itt,iRe_type) = ze/ scale_factor
+                        hp%Zr_scaled(tp,itt,iRe_type) = zr/ scale_factor
+                        hp%kr_scaled(tp,itt,iRe_type) = kr/ scale_factor
+                        hp%z_flag(tp,itt,iRe_type)=.True.
+                elseif( hp%dtype(tp)==2 .and. abs(hp%p2(tp)+1) < 1E-8 ) then
+                        hp%Ze_scaled(tp,itt,iRe_type) = ze
+                        hp%Zr_scaled(tp,itt,iRe_type) = zr
+                        hp%kr_scaled(tp,itt,iRe_type) = kr
+                        hp%z_flag(tp,itt,iRe_type)=.True.
+                endif
+          endif
+        enddo   ! end loop of tp (hydrometeor type)
+              g_to_vol(pr,k)=  0.5*g_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k+1))
+            endif
+          else   ! d_gate==-1
+            if (k<ngate) then
+              ! add to previous value to half of above layer + half of current layer
+              g_to_vol(pr,k) = g_to_vol(pr,k+1) + &
+.5*(g_vol(pr,k+1)+g_vol(pr,k))*(hgt_matrix(pr,k+1)-hgt_matrix(pr,k))
+            else
+              g_to_vol(pr,k)= 0.5*g_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k-1))
+            endif
+          endif
+        elseif(hp%use_gas_abs == 2) then
+          ! using value calculated for the first column
+          g_to_vol(pr,k) = g_to_vol(1,k)
+        elseif (hp%use_gas_abs == 0) then
+          g_to_vol(pr,k) = 0
+        endif
+      endif
+      ! Compute Rayleigh reflectivity, and full, attenuated reflectivity
+      if ((hp%do_ray == 1) .and. (z_ray(pr,k) > 0)) then
+        Ze_ray(pr,k) = 10*log10(z_ray(pr,k))
       else
+!     :: volume is hydrometeor-free
+        kr_vol(k) = 0
+        z_vol(k) = -999
+        z_ray(k) = -999
+        Ze_ray(pr,k) = undef
       endif
+!     :: attenuation due to hydrometeors between radar and volume
+      a_to_vol(k) = 2*path_integral(kr_vol,hgt_matrix(pr,:),1,k-1)
+!     :: attenuation due to gaseous absorption between radar and volume
+      if (g_to_vol_in_present) then
+        g_to_vol(k) = g_to_vol_in(k,pr)
+      if (z_vol(pr,k) > 0) then
+        Ze_non(pr,k) = 10*log10(z_vol(pr,k))
+        dBZe(pr,k) = Ze_non(pr,k)-a_to_vol(pr,k)-g_to_vol(pr,k)
       else
+        if ( (use_gas_abs == 1) .or. ((use_gas_abs == 2) .and. (pr == 1)) )  then
+            g_vol(k) = gases(p_matrix(pr,k),t_matrix(pr,k)+273.15, &
+            rh_matrix(pr,k),freq)
+            g_to_vol(k) = path_integral(g_vol,hgt_matrix(pr,:),1,k-1)
+        elseif (use_gas_abs == 0) then
+            g_to_vol(k) = 0
+        endif
+        dBZe(pr,k) = undef
+        Ze_non(pr,k) = undef
       endif
+!      kr_matrix(pr,:)=kr_vol
+!     :: store results in matrix for return to calling program
+      h_atten_to_vol(pr,k)=a_to_vol(k)
+      g_atten_to_vol(pr,k)=g_to_vol(k)
+      if ((do_ray == 1) .and. (z_ray(k) > 0)) then
+        Ze_ray(pr,k) = 10*log10(z_ray(k))
+      else
+        Ze_ray(pr,k) = -999
+      endif
+      if (z_vol(k) > 0) then
+        dBZe(pr,k) = 10*log10(z_vol(k))-a_to_vol(k)-g_to_vol(k)
+        Ze_non(pr,k) = 10*log10(z_vol(k))
+      else
+        dBZe(pr,k) = -999
+        Ze_non(pr,k) = -999
+      endif
+    enddo       ! end loop of k (range gate)
+    ! Output array with gaseous absorption
+    if (g_to_vol_out_present) g_to_vol_out(:,pr) = g_to_vol
+  enddo         ! end loop over pr (profile)
+    enddo   ! end loop over pr (profile)
+  enddo ! end loop of k (range gate)
+  ! Output array with gaseous absorption
+  if (g_to_vol_out_present) g_to_vol_out = g_to_vol
+  ! save any updates made
+  if (hp%update_scale_LUTs) call save_scale_LUTs(hp)
   end subroutine radar_simulator

LMDZ5/trunk/libf/phylmd/cosp/radar_simulator_types.F90

-                      r1907
+                      r2428
 ! Collection of common variables and types
 ! Part of QuickBeam v1.03 by John Haynes
 ! http://reef.atmos.colostate.edu/haynes/radarsim
+! Updated by Roj Marchand June 2010
   integer, parameter ::       &
+  maxhclass = 20             ,& ! max number of hydrometeor classes
+  nd = 85                    ,& ! number of discrete particles
+  nRe_types = 250               ! number or Re size bins allowed in N and Z_scaled look up table
+  maxhclass = 20         ,& ! max number of hydrometeor classes
+  nRe_types = 550       ! max number or Re size bins allowed in N and Z_scaled look up table
+  ! These variables define discrete diameters used to represent the DSDs.
+  integer, parameter ::       &
+  nd = 85               ! number of discrete particles used in construction DSDs
   real*8, parameter ::        &
   dmin = 0.1                 ,& ! min size of discrete particle
   dmax = 10000.                 ! max size of discrete particle
+  dmax = 10000.                 ! max size of discrete particle
   integer, parameter :: &
+  integer, parameter :: &   ! These parameters used to define temperature intervals in mie LUTs
   mt_nfreq = 5              , &
+  mt_ntt = 39               , & ! num temperatures in table
+  mt_nf = 14                , & ! number of ice fractions in table
+  mt_nd = 85                   ! num discrete mode-p drop sizes in table
+  mt_ntt = 39               , & ! num temperatures in table
+  mt_nf = 14            , & ! number of ice fractions in table
+  mt_nd = 85                    ! num discrete mode-p drop sizes in table
+  integer, parameter :: &   ! These parameters used to defines Re intervals in scale LUTs
+  Re_BIN_LENGTH=10, &
+  Re_MAX_BIN=250
+  integer, parameter :: &   ! These parameters used to define Temperature invervals in scale LUTs
+  cnt_liq = 19, &       ! liquid temperature count
+  cnt_ice = 20          ! ice temperature count
 …
   type class_param
+    ! variables used to store hydrometeor "default" properties
     real*8,  dimension(maxhclass) :: p1,p2,p3,dmin,dmax,apm,bpm,rho
     integer, dimension(maxhclass) :: dtype,col,cp,phase
+    logical, dimension(maxhclass,nRe_types) :: scaled
+    logical, dimension(maxhclass,mt_ntt,nRe_types) :: z_flag
+    ! Radar properties
+    real*8  :: freq,k2
+    integer :: nhclass      ! number of hydrometeor classes in use
+    integer :: use_gas_abs, do_ray
+    ! defines location of radar relative to hgt_matrix.
+    logical :: radar_at_layer_one       ! if true radar is assume to be at the edge
+                                        ! of the first layer, if the first layer is the
+                                        ! surface than a ground-based radar.   If the
+                                        ! first layer is the top-of-atmosphere, then
+                                        ! a space borne radar.
+    ! variables used to store Z scale factors
+    character*240 :: scale_LUT_file_name
+    logical :: load_scale_LUTs, update_scale_LUTs
+    logical, dimension(maxhclass,nRe_types) :: N_scale_flag
+    logical, dimension(maxhclass,mt_ntt,nRe_types) :: Z_scale_flag,Z_scale_added_flag
     real*8,  dimension(maxhclass,mt_ntt,nRe_types) :: Ze_scaled,Zr_scaled,kr_scaled
     real*8,  dimension(maxhclass,nd,nRe_types) :: fc, rho_eff
+    integer, dimension(maxhclass,nd,nRe_types) :: ifc
+    integer, dimension(maxhclass) :: idd
+    ! used to determine Re index
+    real*8  :: step_list(Re_MAX_BIN),base_list(Re_MAX_BIN)
+    ! used to determine temperature index
+    real*8 :: &
+        mt_ttl(cnt_liq), &  ! liquid temperatures (K)
+        mt_tti(cnt_ice)     ! ice temperatures (K)
+    real*8 :: D(nd) ! set of discrete diameters used to represent DSDs
   end type class_param
-! ----- mie table structure -----
+  type mie
+    real*8 :: freq(mt_nfreq), tt(mt_ntt), f(mt_nf), D(mt_nd)
+    real*8, dimension(mt_nd,mt_ntt,mt_nf,mt_nfreq) :: qext, qbsca
+    integer :: phase(mt_ntt)
+  end type mie
+  real*8, dimension(:), save, allocatable :: &
+    mt_ttl, &                   ! liquid temperatures (C)
+    mt_tti, &                   ! ice temperatures (C)
+    mt_qext, mt_qbsca           ! extincion/backscatter efficiency
+!$OMP THREADPRIVATE(mt_ttl,mt_tti,mt_qext, mt_qbsca)
+  integer*4,save :: &
+    cnt_liq, &                  ! liquid temperature count
+    cnt_ice                     ! ice temperature count
+!$OMP THREADPRIVATE(cnt_liq,cnt_ice)
   end module radar_simulator_types

LMDZ5/trunk/libf/phylmd/cosp/read_cosp_output_nl.F90

-                      r1907
+                      r2428
   integer :: i
+  logical, save ::   Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim, &
+             Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfad_dbze94, &
+             Lcfad_lidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp2,Lcllcalipso, &
+             Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lctpisccp,Ldbze94,Ltauisccp,Ltclisccp, &
+             Llongitude,Llatitude,Lparasol_refl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
+             Lfrac_out,Lbeta_mol532,Ltbrttov
+  namelist/COSP_OUTPUT/Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim, &
+             Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfad_dbze94, &
+             Lcfad_lidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp2, &
+             Lcllcalipso,Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lctpisccp,Ldbze94,Ltauisccp, &
+             Ltclisccp,Llongitude,Llatitude,Lparasol_refl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
+             Lfrac_out,Lbeta_mol532,Ltbrttov
+!! AI
+!  logical, save ::   Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim, &
+!             Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfad_dbze94, &
+!             Lcfad_lidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp2,Lcllcalipso, &
+!             Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lctpisccp,Ldbze94,Ltauisccp,Ltclisccp, &
+!             Llongitude,Llatitude,Lparasol_refl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
+!             Lfrac_out,Lbeta_mol532,Ltbrttov
+!  namelist/COSP_OUTPUT/Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim, &
+!             Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfad_dbze94, &
+!             Lcfad_lidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp2, &
+!             Lcllcalipso,Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lctpisccp,Ldbze94,Ltauisccp, &
+!             Ltclisccp,Llongitude,Llatitude,Lparasol_refl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
+!             Lfrac_out,Lbeta_mol532,Ltbrttov
+!!
+ logical, save :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim, &
+             Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,LcfadDbze94, &
+             LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp,Lcllcalipso, &
+             Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp,Lcltisccp, &
+             Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun, &
+             Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun, &
+             Lcltcalipsoliq,Lcltcalipsoice,Lcltcalipsoun, &
+             Lclhcalipsoliq,Lclhcalipsoice,Lclhcalipsoun, &
+             Lclmcalipsoliq,Lclmcalipsoice,Lclmcalipsoun, &
+             Lcllcalipsoliq,Lcllcalipsoice,Lcllcalipsoun, &
+             Ltoffset,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
+             Lfracout,LlidarBetaMol532,Ltbrttov, &
+             Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, &
+             Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, &
+             Liwpmodis,Lclmodis
+  namelist/COSP_OUTPUT/Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim, &
+             Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,LcfadDbze94, &
+             LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp, &
+             Lcllcalipso,Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp, &
+             Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun, &
+             Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun, &
+             Lcltcalipsoliq,Lcltcalipsoice,Lcltcalipsoun, &
+             Lclhcalipsoliq,Lclhcalipsoice,Lclhcalipsoun, &
+             Lclmcalipsoliq,Lclmcalipsoice,Lclmcalipsoun, &
+             Lcllcalipsoliq,Lcllcalipsoice,Lcllcalipsoun, &
+             Lcltisccp,Ltoffset,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
+             Lfracout,LlidarBetaMol532,Ltbrttov, &
+             Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, &
+             Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, &
+             Liwpmodis,Lclmodis
   do i=1,N_OUT_LIST
     cfg%out_list(i)=''
 …
   CALL bcast(Llidar_sim)
   CALL bcast(Lisccp_sim)
+  CALL bcast(Lmodis_sim)
   CALL bcast(Lmisr_sim)
   CALL bcast(Lrttov_sim)
 …
   CALL bcast(Lclcalipso)
   CALL bcast(Lclhcalipso)
+  CALL bcast(Lclcalipsoliq)
+  CALL bcast(Lclcalipsoice)
+  CALL bcast(Lclcalipsoun)
+  CALL bcast(Lclcalipsotmp)
+  CALL bcast(Lclcalipsotmpliq)
+  CALL bcast(Lclcalipsotmpice)
+  CALL bcast(Lclcalipsotmpun)
+  CALL bcast(Lcltcalipsoliq)
+  CALL bcast(Lcltcalipsoice)
+  CALL bcast(Lcltcalipsoun)
+  CALL bcast(Lclhcalipsoliq)
+  CALL bcast(Lclhcalipsoice)
+  CALL bcast(Lclhcalipsoun)
+  CALL bcast(Lclmcalipsoliq)
+  CALL bcast(Lclmcalipsoice)
+  CALL bcast(Lclmcalipsoun)
+  CALL bcast(Lcllcalipsoliq)
+  CALL bcast(Lcllcalipsoice)
+  CALL bcast(Lcllcalipsoun)
   CALL bcast(Lclisccp2)
   CALL bcast(Lcllcalipso)
 …
   CALL bcast(Ldbze94)
   CALL bcast(Ltauisccp)
+  CALL bcast(Ltclisccp)
+  CALL bcast(Llongitude)
+  CALL bcast(Llatitude)
+  CALL bcast(Lcltisccp)
   CALL bcast(Lparasol_refl)
   CALL bcast(LclMISR)
 …
   CALL bcast(Lfrac_out)
   CALL bcast(Lbeta_mol532)
+  CALL bcast(Lcltmodis)
+  CALL bcast(Lclwmodis)
+  CALL bcast(Lclimodis)
+  CALL bcast(Lclhmodis)
+  CALL bcast(Lclmmodis)
+  CALL bcast(Lcllmodis)
+  CALL bcast(Ltautmodis)
+  CALL bcast(Ltauwmodis)
+  CALL bcast(Ltauimodis)
+  CALL bcast(Ltautlogmodis)
+  CALL bcast(Ltauwlogmodis)
+  CALL bcast(Ltauilogmodis)
+  CALL bcast(Lreffclwmodis)
+  CALL bcast(Lreffclimodis)
+  CALL bcast(Lpctmodis)
+  CALL bcast(Llwpmodis)
+  CALL bcast(Liwpmodis)
+  CALL bcast(Lclmodis)
   CALL bcast(Ltbrttov)
 !$OMP BARRIER
 …
     Lparasol_refl    = .false.
     Lbeta_mol532     = .false.
+!! AI
+    Lclcalipsoliq    = .false.
+    Lclcalipsoice    = .false.
+    Lclcalipsoun    = .false.
+    Lclcalipsotmp    = .false.
+    Lclcalipsotmpun    = .false.
+    Lclcalipsotmpliq    = .false.
+    Lclcalipsotmpice    = .false.
+    Lclhcalipsoliq      = .false.
+    Lcllcalipsoliq      = .false.
+    Lclmcalipsoliq     = .false.
+    Lcltcalipsoliq      = .false.
+    Lclhcalipsoice      = .false.
+    Lcllcalipsoice      = .false.
+    Lclmcalipsoice      = .false.
+    Lcltcalipsoice      = .false.
+    Lclhcalipsoun      = .false.
+    Lcllcalipsoun      = .false.
+    Lclmcalipsoun      = .false.
+    Lcltcalipsoun      = .false.
   endif
   if (.not.Lisccp_sim) then
 …
     Lfrac_out = .false.
   endif
+ if (.not.Lmodis_sim) then
+    Lcltmodis=.false.
+    Lclwmodis=.false.
+    Lclimodis=.false.
+    Lclhmodis=.false.
+    Lclmmodis=.false.
+    Lcllmodis=.false.
+    Ltautmodis=.false.
+    Ltauwmodis=.false.
+    Ltauimodis=.false.
+    Ltautlogmodis=.false.
+    Ltauwlogmodis=.false.
+    Ltauilogmodis=.false.
+    Lreffclwmodis=.false.
+    Lreffclimodis=.false.
+    Lpctmodis=.false.
+    Llwpmodis=.false.
+    Liwpmodis=.false.
+    Lclmodis=.false.
+  endif
+  if (Lmodis_sim) Lisccp_sim = .true.
   ! Diagnostics that use Radar and Lidar
 …
   cfg%Llidar_sim = Llidar_sim
   cfg%Lisccp_sim = Lisccp_sim
+  cfg%Lmodis_sim = Lmodis_sim
   cfg%Lmisr_sim  = Lmisr_sim
   cfg%Lrttov_sim = Lrttov_sim
 …
   if (Lboxtauisccp)     cfg%out_list(i) = 'boxtauisccp'
   i = i+1
   if (Lcfad_dbze94)     cfg%out_list(i) = 'cfad_dbze94'
   i = i+1
   if (Lcfad_lidarsr532) cfg%out_list(i) = 'cfad_lidarsr532'
+  if (LcfadDbze94)      cfg%out_list(i) = 'cfadDbze94'
+  i = i+1
+  if (LcfadLidarsr532)  cfg%out_list(i) = 'cfadLidarsr532'
   i = i+1
   if (Lclcalipso2)      cfg%out_list(i) = 'clcalipso2'
 …
   if (Lclhcalipso)      cfg%out_list(i) = 'clhcalipso'
   i = i+1
   if (Lclisccp2)        cfg%out_list(i) = 'clisccp2'
+  if (Lclisccp)         cfg%out_list(i) = 'clisccp'
   i = i+1
   if (Lcllcalipso)      cfg%out_list(i) = 'cllcalipso'
 …
   if (Lcltcalipso)      cfg%out_list(i) = 'cltcalipso'
   i = i+1
+  if (Lcllcalipsoice)      cfg%out_list(i) = 'cllcalipsoice'
+  i = i+1
+  if (Lclmcalipsoice)      cfg%out_list(i) = 'clmcalipsoice'
+  i = i+1
+  if (Lclhcalipsoice)      cfg%out_list(i) = 'clhcalipsoice'
+  i = i+1
+  if (Lcltcalipsoice)      cfg%out_list(i) = 'cltcalipsoice'
+  i = i+1
+  if (Lcllcalipsoliq)      cfg%out_list(i) = 'cllcalipsoliq'
+  i = i+1
+  if (Lclmcalipsoliq)      cfg%out_list(i) = 'clmcalipsoliq'
+  i = i+1
+  if (Lclhcalipsoliq)      cfg%out_list(i) = 'clhcalipsoliq'
+  i = i+1
+  if (Lcltcalipsoliq)      cfg%out_list(i) = 'cltcalipsoliq'
+  i = i+1
+  if (Lcllcalipsoun)      cfg%out_list(i) = 'cllcalipsoun'
+  i = i+1
+  if (Lclmcalipsoun)      cfg%out_list(i) = 'clmcalipsoun'
+  i = i+1
+  if (Lclhcalipsoun)      cfg%out_list(i) = 'clhcalipsoun'
+  i = i+1
+  if (Lcltcalipsoun)      cfg%out_list(i) = 'cltcalipsoun'
+  i = i+1
+  if (Lclcalipsoice)       cfg%out_list(i) = 'clcalipsoice'
+  i = i+1
+  if (Lclcalipsoliq)       cfg%out_list(i) = 'clcalipsoliq'
+  i = i+1
+  if (Lclcalipsoun)       cfg%out_list(i) = 'clcalipsoun'
+  i = i+1
+  if (Lclcalipsotmp)       cfg%out_list(i) = 'clcalipsotmp'
+  i = i+1
+  if (Lclcalipsotmpice)       cfg%out_list(i) = 'clcalipsotmpice'
+  i = i+1
+  if (Lclcalipsotmpliq)       cfg%out_list(i) = 'clcalipsotmpliq'
+  i = i+1
+  if (Lclcalipsotmpun)       cfg%out_list(i) = 'clcalipsotmpun'
+  i = i+1
   if (Lcltlidarradar)   cfg%out_list(i) = 'cltlidarradar'
   i = i+1
   if (Lctpisccp)        cfg%out_list(i) = 'ctpisccp'
+  if (Lpctisccp)        cfg%out_list(i) = 'pctisccp'
   i = i+1
   if (Ldbze94)          cfg%out_list(i) = 'dbze94'
 …
   if (Ltauisccp)        cfg%out_list(i) = 'tauisccp'
   i = i+1
+  if (Ltclisccp)        cfg%out_list(i) = 'tclisccp'
+  i = i+1
+  if (Llongitude)       cfg%out_list(i) = 'lon'
+  i = i+1
+  if (Llatitude)        cfg%out_list(i) = 'lat'
+  i = i+1
+  if (Lparasol_refl)    cfg%out_list(i) = 'parasol_refl'
+  if (Lcltisccp)        cfg%out_list(i) = 'cltisccp'
+  i = i+1
+  if (Ltoffset)         cfg%out_list(i) = 'toffset'
+  i = i+1
+  if (LparasolRefl)     cfg%out_list(i) = 'parasolRefl'
   i = i+1
   if (LclMISR)          cfg%out_list(i) = 'clMISR'
 …
   if (Lmeantbclrisccp)  cfg%out_list(i) = 'meantbclrisccp'
   i = i+1
   if (Lfrac_out)        cfg%out_list(i) = 'frac_out'
   i = i+1
   if (Lbeta_mol532)     cfg%out_list(i) = 'beta_mol532'
+  if (Lfracout)         cfg%out_list(i) = 'fracout'
+  i = i+1
+  if (LlidarBetaMol532) cfg%out_list(i) = 'lidarBetaMol532'
   i = i+1
   if (Ltbrttov)         cfg%out_list(i) = 'tbrttov'
+  i = i+1
+  if (Lcltmodis)        cfg%out_list(i) = 'cltmodis'
+  i = i+1
+  if (Lclwmodis)        cfg%out_list(i) = 'clwmodis'
+  i = i+1
+  if (Lclimodis)        cfg%out_list(i) = 'climodis'
+  i = i+1
+  if (Lclhmodis)        cfg%out_list(i) = 'clhmodis'
+  i = i+1
+  if (Lclmmodis)        cfg%out_list(i) = 'clmmodis'
+  i = i+1
+  if (Lcllmodis)        cfg%out_list(i) = 'cllmodis'
+  i = i+1
+  if (Ltautmodis)       cfg%out_list(i) = 'tautmodis'
+  i = i+1
+  if (Ltauwmodis)       cfg%out_list(i) = 'tauwmodis'
+  i = i+1
+  if (Ltauimodis)       cfg%out_list(i) = 'tauimodis'
+  i = i+1
+  if (Ltautlogmodis)    cfg%out_list(i) = 'tautlogmodis'
+  i = i+1
+  if (Ltauwlogmodis)    cfg%out_list(i) = 'tauwlogmodis'
+  i = i+1
+  if (Ltauilogmodis)    cfg%out_list(i) = 'tauilogmodis'
+  i = i+1
+  if (Lreffclwmodis)    cfg%out_list(i) = 'reffclwmodis'
+  i = i+1
+  if (Lreffclimodis)    cfg%out_list(i) = 'reffclimodis'
+  i = i+1
+  if (Lpctmodis)        cfg%out_list(i) = 'pctmodis'
+  i = i+1
+  if (Llwpmodis)        cfg%out_list(i) = 'lwpmodis'
+  i = i+1
+  if (Liwpmodis)        cfg%out_list(i) = 'iwpmodis'
+  i = i+1
+  if (Lclmodis)         cfg%out_list(i) = 'clmodis'
   if (i /= N_OUT_LIST) then
      print *, 'COSP_IO: wrong number of output diagnostics'
+     print *, i,N_OUT_LIST
      stop
   endif
   ! Copy diagnostic flags to cfg structure
+  ! ISCCP simulator
   cfg%Lalbisccp = Lalbisccp
   cfg%Latb532 = Latb532
   cfg%Lboxptopisccp = Lboxptopisccp
   cfg%Lboxtauisccp = Lboxtauisccp
+  cfg%Lcfad_dbze94 = Lcfad_dbze94
+  cfg%Lcfad_lidarsr532 = Lcfad_lidarsr532
+  cfg%Lmeantbisccp = Lmeantbisccp
+  cfg%Lmeantbclrisccp = Lmeantbclrisccp
+  cfg%Lclisccp = Lclisccp
+  cfg%Lpctisccp = Lpctisccp
+  cfg%Ltauisccp = Ltauisccp
+  cfg%Lcltisccp = Lcltisccp
+  ! CloudSat simulator
+  cfg%Ldbze94 = Ldbze94
+  cfg%LcfadDbze94 = LcfadDbze94
+  ! CALIPSO/PARASOL simulator
+  cfg%LcfadLidarsr532 = LcfadLidarsr532
   cfg%Lclcalipso2 = Lclcalipso2
   cfg%Lclcalipso = Lclcalipso
   cfg%Lclhcalipso = Lclhcalipso
-  cfg%Lclisccp2 = Lclisccp2
   cfg%Lcllcalipso = Lcllcalipso
   cfg%Lclmcalipso = Lclmcalipso
   cfg%Lcltcalipso = Lcltcalipso
+  cfg%Lclhcalipsoice = Lclhcalipsoice
+  cfg%Lcllcalipsoice = Lcllcalipsoice
+  cfg%Lclmcalipsoice = Lclmcalipsoice
+  cfg%Lcltcalipsoice = Lcltcalipsoice
+  cfg%Lclhcalipsoliq = Lclhcalipsoliq
+  cfg%Lcllcalipsoliq = Lcllcalipsoliq
+  cfg%Lclmcalipsoliq = Lclmcalipsoliq
+  cfg%Lcltcalipsoliq = Lcltcalipsoliq
+  cfg%Lclhcalipsoun = Lclhcalipsoun
+  cfg%Lcllcalipsoun = Lcllcalipsoun
+  cfg%Lclmcalipsoun = Lclmcalipsoun
+  cfg%Lcltcalipsoun = Lcltcalipsoun
+  cfg%Lclcalipsoice = Lclcalipsoice
+  cfg%Lclcalipsoliq = Lclcalipsoliq
+  cfg%Lclcalipsoun = Lclcalipsoun
+  cfg%Lclcalipsotmp = Lclcalipsotmp
+  cfg%Lclcalipsotmpice = Lclcalipsotmpice
+  cfg%Lclcalipsotmpliq = Lclcalipsotmpliq
+  cfg%Lclcalipsotmpun = Lclcalipsotmpun
   cfg%Lcltlidarradar = Lcltlidarradar
+  cfg%Lctpisccp = Lctpisccp
+  cfg%Ldbze94 = Ldbze94
+  cfg%Ltauisccp = Ltauisccp
+  cfg%Ltclisccp = Ltclisccp
+  cfg%Llongitude = Llongitude
+  cfg%Llatitude = Llatitude
+  cfg%Lparasol_refl = Lparasol_refl
+  cfg%LparasolRefl = LparasolRefl
+  ! MISR simulator
   cfg%LclMISR = LclMISR
+  cfg%Lmeantbisccp = Lmeantbisccp
+  cfg%Lmeantbclrisccp = Lmeantbclrisccp
+  cfg%Lfrac_out = Lfrac_out
+  cfg%Lbeta_mol532 = Lbeta_mol532
+  ! Other
+  cfg%Ltoffset = Ltoffset
+  cfg%Lfracout = Lfracout
+  cfg%LlidarBetaMol532 = LlidarBetaMol532
+  ! RTTOV
   cfg%Ltbrttov = Ltbrttov
+  ! MODIS simulator
+  cfg%Lcltmodis=Lcltmodis
+  cfg%Lclwmodis=Lclwmodis
+  cfg%Lclimodis=Lclimodis
+  cfg%Lclhmodis=Lclhmodis
+  cfg%Lclmmodis=Lclmmodis
+  cfg%Lcllmodis=Lcllmodis
+  cfg%Ltautmodis=Ltautmodis
+  cfg%Ltauwmodis=Ltauwmodis
+  cfg%Ltauimodis=Ltauimodis
+  cfg%Ltautlogmodis=Ltautlogmodis
+  cfg%Ltauwlogmodis=Ltauwlogmodis
+  cfg%Ltauilogmodis=Ltauilogmodis
+  cfg%Lreffclwmodis=Lreffclwmodis
+  cfg%Lreffclimodis=Lreffclimodis
+  cfg%Lpctmodis=Lpctmodis
+  cfg%Llwpmodis=Llwpmodis
+  cfg%Liwpmodis=Liwpmodis
+  cfg%Lclmodis=Lclmodis
  END SUBROUTINE READ_COSP_OUTPUT_NL

LMDZ5/trunk/libf/phylmd/cosp/scops.F

-                      r1907
+                      r2428
 ! (c) British Crown Copyright 2009, the Met Office.
 ! All rights reserved.
+! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/icarus-scops-4.1-bsd/scops.f $
+!
 ! Redistribution and use in source and binary forms, with or without
 …
 ! *****************************COPYRIGHT*******************************
-      USE mod_phys_lmdz_para
-      USE mod_grid_phy_lmdz
       implicit none
 …
           ELSE
               DO ibox=1,ncol
+!                include 'congvec_para.h'
+                 include 'congvec.h'
+                include 'congvec.h'
                 ! select random pixels from the non-convective
                 ! part the gridbox ( some will be converted into
 …
           do j=1,npoints
             if (boxpos(j,ibox).le.conv(j,ilev)) then
               maxocc(j,ibox) = 1.
+              maxocc(j,ibox) = 1
             else
               maxocc(j,ibox) = 0.
+              maxocc(j,ibox) = 0
             end if
           enddo

LMDZ5/trunk/libf/phylmd/cosp/zeff.F90

-                      r1907
+                      r2428
+! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/zeff.f90 $
   subroutine zeff(freq,D,N,nsizes,k2,tt,ice,xr,z_eff,z_ray,kr,qe,qs,rho_e)
   use math_lib
 …
 !   [nsizes]    number of discrete drop sizes
 !   [k2]        |K|^2, -1=use frequency dependent default
 !   [tt]        hydrometeor temperature (C)
+!   [tt]        hydrometeor temperature (K)
 !   [ice]       indicates volume consists of ice
 !   [xr]        perform Rayleigh calculations?
 …
 ! ----- INTERNAL -----
   integer :: &
   correct_for_rho               ! correct for density flag
+  correct_for_rho        ! correct for density flag
   real*8, dimension(nsizes) :: &
+  D0, &                         ! D in (m)
+  N0, &                         ! N in m^-3 m^-1
+  sizep, &                      ! size parameter
+  qext, &                       ! extinction efficiency
+  qbsca, &                      ! backscatter efficiency
+  rho_ice, &                    ! bulk density ice (kg m^-3)
+  f                             ! ice fraction
+  D0, &                  ! D in (m)
+  N0, &                  ! N in m^-3 m^-1
+  sizep, &               ! size parameter
+  qext, &           ! extinction efficiency
+  qbsca, &               ! backscatter efficiency
+  rho_ice, &             ! bulk density ice (kg m^-3)
+  f                 ! ice fraction
+  real*8, dimension(nsizes) :: xtemp
   real*8 :: &
   wl, &                         ! wavelength (m)
+  wl, &                  ! wavelength (m)
   cr                            ! kr(dB/km) = cr * kr(1/km)
   complex*16 :: &
   m                             ! complex index of refraction of bulk form
+  m                 ! complex index of refraction of bulk form
   complex*16, dimension(nsizes) :: &
   m0                            ! complex index of refraction
+  m0                ! complex index of refraction
   integer*4 :: i,one
   real*8 :: pi
   real*8 :: eta_sum, eta_mie, const, z0_eff, z0_ray, k_sum, &
             n_r, n_i, dqv(1), dqxt, dqsc, dbsc, dg, dph(1)
+            n_r, n_i, dqv(1), dqsc, dg, dph(1)
   integer*4 :: err
   complex*16 :: Xs1(1), Xs2(1)
 …
 ! // conversions
   D0 = d*1E-6                   ! m
   N0 = n*1E12                   ! 1/(m^3 m)
   wl = 2.99792458/(freq*10)     ! m
+  D0 = d*1E-6            ! m
+  N0 = n*1E12            ! 1/(m^3 m)
+  wl = 2.99792458/(freq*10)   ! m
 ! // dielectric constant |k^2| defaults
 …
     eta_sum = qbsca(1)*(n(1)*1E6)*D0(1)**2
   else
+    call avint(qbsca*N0*D0**2,D0,nsizes,D0(1),D0(size(D0,1)),eta_sum)
+    xtemp = qbsca*N0*D0**2
+    call avint(xtemp,D0,nsizes,D0(1),D0(size(D0,1)),eta_sum)
   endif
 …
     k_sum = qext(1)*(n(1)*1E6)*D0(1)**2
   else
+    call avint(qext*N0*D0**2,D0,nsizes,D0(1),D0(size(D0,1)),k_sum)
+    xtemp = qext*N0*D0**2
+    call avint(xtemp,D0,nsizes,D0(1),D0(size(D0,1)),k_sum)
   endif
   cr = 10./log(10.)
   kr = k_sum*0.25*pi*(1000.*cr)
 ! // z_ray = sum[D^6*N(D)*deltaD]
   if (xr == 1) then
 …
       z0_ray = (n(1)*1E6)*D0(1)**6
     else
+      call avint(N0*D0**6,D0,nsizes,D0(1),D0(size(D0)),z0_ray)
+      xtemp = N0*D0**6
+      call avint(xtemp,D0,nsizes,D0(1),D0(size(D0)),z0_ray)
     endif
   endif

LMDZ5/trunk/libf/phylmd/physiq_mod.F90

r2424	r2428
4041	4041	ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, &
4042	4042	klon,klev,longitude_deg,latitude_deg,presnivs,overlap, &
4043		~~frac~~t,ref_liq,ref_ice, &
	4043	JrNt,ref_liq,ref_ice, &
4044	4044	pctsrf(:,is_ter)+pctsrf(:,is_lic), &
4045	4045	zu10m,zv10m,pphis, &

Context Navigation

Legend:

LMDZ5/trunk/libf/phylmd/cosp/MISR_simulator.F

LMDZ5/trunk/libf/phylmd/cosp/array_lib.F90

LMDZ5/trunk/libf/phylmd/cosp/atmos_lib.F90

LMDZ5/trunk/libf/phylmd/cosp/congvec.h

LMDZ5/trunk/libf/phylmd/cosp/cosp.F90

LMDZ5/trunk/libf/phylmd/cosp/cosp_constants.F90

LMDZ5/trunk/libf/phylmd/cosp/cosp_isccp_simulator.F90

LMDZ5/trunk/libf/phylmd/cosp/cosp_lidar.F90

LMDZ5/trunk/libf/phylmd/cosp/cosp_misr_simulator.F90

LMDZ5/trunk/libf/phylmd/cosp/cosp_output_mod.F90

LMDZ5/trunk/libf/phylmd/cosp/cosp_output_write_mod.F90

LMDZ5/trunk/libf/phylmd/cosp/cosp_radar.F90

LMDZ5/trunk/libf/phylmd/cosp/cosp_simulator.F90

LMDZ5/trunk/libf/phylmd/cosp/cosp_stats.F90

LMDZ5/trunk/libf/phylmd/cosp/cosp_types.F90

LMDZ5/trunk/libf/phylmd/cosp/cosp_utils.F90

LMDZ5/trunk/libf/phylmd/cosp/dsd.F90

LMDZ5/trunk/libf/phylmd/cosp/format_input.F90

LMDZ5/trunk/libf/phylmd/cosp/gases.F90

LMDZ5/trunk/libf/phylmd/cosp/icarus.F

LMDZ5/trunk/libf/phylmd/cosp/lidar_simulator.F90

LMDZ5/trunk/libf/phylmd/cosp/llnl_stats.F90

LMDZ5/trunk/libf/phylmd/cosp/lmd_ipsl_stats.F90

LMDZ5/trunk/libf/phylmd/cosp/math_lib.F90

LMDZ5/trunk/libf/phylmd/cosp/optics_lib.F90

LMDZ5/trunk/libf/phylmd/cosp/pf_to_mr.F

LMDZ5/trunk/libf/phylmd/cosp/phys_cosp.F90

LMDZ5/trunk/libf/phylmd/cosp/prec_scops.F

LMDZ5/trunk/libf/phylmd/cosp/radar_simulator.F90

LMDZ5/trunk/libf/phylmd/cosp/radar_simulator_types.F90

LMDZ5/trunk/libf/phylmd/cosp/read_cosp_output_nl.F90

LMDZ5/trunk/libf/phylmd/cosp/scops.F

LMDZ5/trunk/libf/phylmd/cosp/zeff.F90

LMDZ5/trunk/libf/phylmd/physiq_mod.F90

Download in other formats: