*ID ADB1F406B
*/ 
*/ This is a FAMOUS mod.
*/
*/ Revised version of DIAG3A and its call from FXCA3A.
*/
*DECLARE LWRAD3A
*I ADB2F404.631
!       4.6             10-05-98                Land flag passed to
!                                               FLUX_CALC.
!                                               (J. M. Edwards)
*/ call flux_calc
*D LWRAD3A.629
*/CNG     &   , ALBEDO_SEA_DIFF, ALBEDO_SEA_DIR, LAND, LWSEA
*/C REPLACED BY Nic Gedney:
     &   , ALBEDO_SEA_DIFF, ALBEDO_SEA_DIR, LAND, FLANDG
     &   , LWSEA
*/
*DECLARE SWRAD3A
*I ADB2F404.1504
!       4.6             10-05-98                Land flag passed to
!                                               FLUX_CALC.
!                                               (J. M. Edwards)
*/ call flux_calc
*D SWRAD3A.760
*/CNG     &   , ALBEDO_SEA_DIFF_G, ALBEDO_SEA_DIR_G, LAND_G
*/C REPLACED BY Nic Gedney:
     &   , ALBEDO_SEA_DIFF_G, ALBEDO_SEA_DIR_G, LAND_G, FLANDG_G
*/
*/ subroutine flux_calc
*DECLARE FXCA3A
*I ADB2F404.557
!       4.6             10-05-98                Land flag added to
!                                               the argument list for
!                                               diagnostics.
!                                               (J. M. Edwards)
*D FXCA3A.80
*/CNG     &   , ALBEDO_SEA_DIFF, ALBEDO_SEA_DIR, LAND
*/C REPLACED BY Nic Gedney:
     &   , ALBEDO_SEA_DIFF, ALBEDO_SEA_DIR, LAND, FLANDG
*I FXCA3A.458
      LOGICAL   !, INTENT(IN)
     &     LAND(NPD_PROFILE)
!            Flag for land points
*/th      REAL     !, INTENT(IN)
*/th     &     FLANDG(NPD_PROFILE)
*/th!            Land fraction
*D ADB1F401.446
!             SEA-ICE FRACTION OF SEA PORTION OF GRID BOX
*D FXCA3A.1515,ADB1F401.471
         CALL R2_COUPLE_DIAG(N_PROFILE, ISOLIR
     &      , ALBEDO_FIELD_DIFF(1, I_BAND), ALBEDO_FIELD_DIR(1, I_BAND)
     &      , ALBEDO_SEA_DIFF(1, I_BAND), ALBEDO_SEA_DIR(1, I_BAND)
*/CNG     &      , LAND, PLANCK_FREEZE_SEA
*/C REPLACED BY Nic Gedney:
     &      , LAND, FLANDG, ICE_FRACTION
     &      , PLANCK_LEADS_SEA
     &      , PLANCK_SOURCE_BAND(1, N_LAYER), THERMAL_GROUND_BAND
     &      , FLUX_TOTAL_BAND(1, 2*N_LAYER+2)
     &      , FLUX_TOTAL_BAND(1, 2*N_LAYER+1)
     &      , FLUX_DIRECT_BAND(1, N_LAYER)
     &      , FLUX_TOTAL_CLEAR_BAND(1, 2*N_LAYER+2)
     &      , FLUX_TOTAL_CLEAR_BAND(1, 2*N_LAYER+1)
*DECLARE DIAG3A
*D DIAG3A.29
!     Dummy arguments
*D DIAG3A.31,DIAG3A.32   
     &    N
!           Length of array
*D DIAG3A.34,DIAG3A.35   
     &    X(N)
!           Array to be zeroed
*D DIAG3A.37
!     Local variables
*D DIAG3A.39,DIAG3A.40   
     &    I
!           loop variable
*D DIAG3A.45
        X(I)=0.0E+00
*D DIAG3A.72,DIAG3A.76  
     &  , SEA_FLUX
     &  , L_SURFACE_DOWN_FLUX, SURFACE_DOWN_FLUX
     &  , L_SURF_DOWN_CLR, SURF_DOWN_CLR
     &  , L_SURF_UP_CLR, SURF_UP_CLR
*/CNG     &  , L_FLUX_BELOW_690NM_SURF, FLUX_BELOW_690NM_SURF
*/CNG replaced by:
     &  , L_FLUX_BELOW_690NM_SURF
*D DIAG3A.85
!     Dummy arguments
*D DIAG3A.87
!     Dimensions of arrays
*D DIAG3A.89,DIAG3A.90   
     &    NPD_PROFILE
!           Maximum number of atmospheric profiles
*D DIAG3A.93,DIAG3A.94   
     &    N_PROFILE
!           Number of atmospheric profiles
*D DIAG3A.96
!     Switches for diagnostics:
*D DIAG3A.98,DIAG3A.105  
     &    L_FLUX_BELOW_690NM_SURF
!           Flux below 690nm at surface to be calculated
     &  , L_SURFACE_DOWN_FLUX
!           Downward surface flux required
     &  , L_SURF_DOWN_CLR
!           Calculate downward clear flux
     &  , L_SURF_UP_CLR
!           Calculate upward clear flux
*D DIAG3A.107
!     Surface fluxes for coupling or diagnostic use
*D DIAG3A.109,DIAG3A.118  
     &    SEA_FLUX(NPD_PROFILE)
!           Net downward flux into sea
     &  , SURFACE_DOWN_FLUX(NPD_PROFILE)
!           Downward flux at surface
     &  , SURF_DOWN_CLR(NPD_PROFILE)
!           Clear-sky downward flux at surface
     &  , SURF_UP_CLR(NPD_PROFILE)
!           Clear-sky upward flux at surface
*/CNG     &  , FLUX_BELOW_690NM_SURF(NPD_PROFILE)
*/CNG!           Surface flux below 690nm
*D DIAG3A.125
        CALL R2_ZERO_1D(N_PROFILE, SURFACE_DOWN_FLUX)
*D DIAG3A.129
        CALL R2_ZERO_1D(N_PROFILE, SURF_DOWN_CLR)
*D DIAG3A.133
        CALL R2_ZERO_1D(N_PROFILE, SURF_UP_CLR)
*D DIAG3A.137
*/CNG        CALL R2_ZERO_1D(N_PROFILE, FLUX_BELOW_690NM_SURF)
*I ADB1F401.131   
!       4.6             07-05-99                Calculation of fluxes
!                                               into the sea changed
!                                               to use albedos for
!                                               sea. Code for obsolete
!                                               net solvers removed.
!                                               (J. M. Edwards)
*D DIAG3A.163,DIAG3A.174  
      SUBROUTINE R2_COUPLE_DIAG(N_PROFILE, ISOLIR
     &  , ALBEDO_FIELD_DIFF, ALBEDO_FIELD_DIR
     &  , ALBEDO_SEA_DIFF, ALBEDO_SEA_DIR
*/CNG     &  , LAND, PLANCK_FREEZE_SEA
*/CNG Replaced by Nic Gedney:
     &  , LAND, FLANDG, ICE_FRACTION
     &  , PLANCK_LEADS_SEA
     &  , PLANCK_AIR_SURFACE, THERMAL_SOURCE_GROUND
     &  , FLUX_DOWN, FLUX_UP, FLUX_DIRECT
     &  , FLUX_DOWN_CLEAR, FLUX_UP_CLEAR, FLUX_DIRECT_CLEAR
     &  , WEIGHT_690NM
     &  , SEA_FLUX
     &  , L_SURFACE_DOWN_FLUX, SURFACE_DOWN_FLUX
     &  , L_SURF_DOWN_CLR, SURF_DOWN_CLR
     &  , L_SURF_UP_CLR, SURF_UP_CLR
*/CNG     &  , L_FLUX_BELOW_690NM_SURF, FLUX_BELOW_690NM_SURF
*/CNG replaced by:
     &  , L_FLUX_BELOW_690NM_SURF
*/
*D DIAG3A.183,DIAG3A.184  
!     Comdecks included
!     Spectral regions
*D DIAG3A.187
!     Dummy Arguments
*D DIAG3A.189
!     Dimensions of arrays
*D DIAG3A.191,DIAG3A.192  
     &    NPD_PROFILE
!           Maximum number of atmospheric profiles
*D DIAG3A.195,DIAG3A.198  
     &    N_PROFILE
!           Number of atmospheric profiles
     &  , ISOLIR
!           Spectral region
*D DIAG3A.200
!     Logical switches for the code
*D DIAG3A.202,DIAG3A.203  
     &    L_NET
!           Flag for net fluxes
*D DIAG3A.205
!     Switches for diagnostics:
*D DIAG3A.207,DIAG3A.214  
     &    L_FLUX_BELOW_690NM_SURF
!           Flux below 690nm at surface to be calculated
     &  , L_SURFACE_DOWN_FLUX
!           Downward surface flux required
     &  , L_SURF_DOWN_CLR
!           Calculate downward clear flux
     &  , L_SURF_UP_CLR
!           Calculate upward clear flux
*D DIAG3A.216
!     Albedos
*D DIAG3A.218,DIAG3A.225  
     &    ALBEDO_FIELD_DIFF(NPD_PROFILE)
!           Diffuse albedo meaned over grid box
     &  , ALBEDO_FIELD_DIR(NPD_PROFILE)
!           Direct albedo meaned over grid box
     &  , ALBEDO_SEA_DIFF(NPD_PROFILE)
!           Diffuse albedo of open sea
     &  , ALBEDO_SEA_DIR(NPD_PROFILE)
!           Direct albedo meaned of open sea
*D DIAG3A.228,ADB1F401.136  
     &    THERMAL_SOURCE_GROUND(NPD_PROFILE)
!           Thermal source at ground
     &  , PLANCK_AIR_SURFACE(NPD_PROFILE)
!           Planck function at near-surface air temperature in band
*D ADB1F401.137,ADB1F401.142  
!     Arguments relating to sea ice.
      LOGICAL   !, INTENT(IN)
     &    LAND(NPD_PROFILE)
!           Land-sea mask
*/CNG Next 5 lines added by N. Gedney:
      REAL      !, INTENT(IN)
     &     FLANDG(NPD_PROFILE)
!            Land fraction
     &   , ICE_FRACTION(NPD_PROFILE)
!            FRACTION OF SEA-ICE IN SEA PORTION OF GRID BOX!
*/
*D ADB1F401.144,ADB1F401.148  
*/CNG     &    PLANCK_FREEZE_SEA
*/CNG!           Planck function over freezing sea
     &    PLANCK_LEADS_SEA(NPD_PROFILE)
!           Planck function over sea leads
*D DIAG3A.232,DIAG3A.233  
     &    WEIGHT_690NM
!           Weighting applied to band for region below 690 nm
*D DIAG3A.235
!     Calculated fluxes
*D DIAG3A.237,DIAG3A.248  
     &    FLUX_DOWN(NPD_PROFILE)
!           Total downward or net flux at surface
     &  , FLUX_DIRECT(NPD_PROFILE)
!           Direct solar flux at surface
     &  , FLUX_UP(NPD_PROFILE)
!           Upward flux at surface
     &  , FLUX_DOWN_CLEAR(NPD_PROFILE)
!           Total clear-sky downward or net flux at surface
     &  , FLUX_UP_CLEAR(NPD_PROFILE)
!           Clear-sky upward flux at surface
     &  , FLUX_DIRECT_CLEAR(NPD_PROFILE)
!           Clear-sky direct solar flux at surface
*D DIAG3A.251
!     Surface fluxes for coupling or diagnostic use
*D DIAG3A.253,DIAG3A.262  
     &    SEA_FLUX(NPD_PROFILE)
!           Net downward flux into sea
     &  , SURFACE_DOWN_FLUX(NPD_PROFILE)
!           Downward flux at surface
     &  , SURF_DOWN_CLR(NPD_PROFILE)
!           Clear-sky downward flux at surface
     &  , SURF_UP_CLR(NPD_PROFILE)
!           Clear-sky upward flux at surface
*/CNG     &  , FLUX_BELOW_690NM_SURF(NPD_PROFILE)
*/CNG!           Surface flux below 690nm
*D DIAG3A.265
!     Local variables
*D DIAG3A.267,DIAG3A.268  
     &    L
!           Loop variable
*D DIAG3A.272,DIAG3A.313  
!     This is the flux into the sea over the ice-free parts of the
!     grid-box. The model is that the downward fluxes are uniform
!     across the grid-box, but the upward fluxes are not. At this
!     stage no weighting by the actual ice-free area is carried out:
!     that will be done later.
      IF (ISOLIR.EQ.IP_SOLAR) THEN
        DO L=1, N_PROFILE
*/CNG          IF (.NOT.LAND(L)) THEN
*/CNG Replaced by Nic Gedney:
          IF (FLANDG(L).LT.1.0.AND.ICE_FRACTION(L).LT.1.0) THEN
            SEA_FLUX(L)=SEA_FLUX(L)
     &        +FLUX_DOWN(L)*(1.0E+00-ALBEDO_SEA_DIFF(L))
     &        +FLUX_DIRECT(L)*(ALBEDO_SEA_DIFF(L)-ALBEDO_SEA_DIR(L))
*/
          ENDIF
        ENDDO
      ELSE IF (ISOLIR.EQ.IP_INFRA_RED) THEN
        DO L=1, N_PROFILE
*/CNG          IF (.NOT.LAND(L)) THEN
*/CNG Replaced by Nic Gedney:
          IF (FLANDG(L).LT.1.0.AND.ICE_FRACTION(L).LT.1.0) THEN
            SEA_FLUX(L)=SEA_FLUX(L)
     &        +(1.0E+00-ALBEDO_SEA_DIFF(L))
     &        *(FLUX_DOWN(L)+PLANCK_AIR_SURFACE(L)
     &        -PLANCK_LEADS_SEA(L))
*/
          ENDIF
         ENDDO
*D DIAG3A.317,DIAG3A.338  
        IF (ISOLIR.EQ.IP_SOLAR) THEN
          DO L=1, N_PROFILE
            SURFACE_DOWN_FLUX(L)=SURFACE_DOWN_FLUX(L)
     &        +FLUX_DOWN(L)
*/
          ENDDO
        ELSE IF (ISOLIR.EQ.IP_INFRA_RED) THEN
          DO L=1, N_PROFILE
            SURFACE_DOWN_FLUX(L)=SURFACE_DOWN_FLUX(L)
     &        +FLUX_DOWN(L)+PLANCK_AIR_SURFACE(L)
          ENDDO
        ENDIF
*D DIAG3A.342,DIAG3A.365  
        IF (ISOLIR.EQ.IP_SOLAR) THEN
          DO L=1, N_PROFILE
            SURF_DOWN_CLR(L)=SURF_DOWN_CLR(L)
     &        +FLUX_DOWN_CLEAR(L)
          ENDDO
        ELSE IF (ISOLIR.EQ.IP_INFRA_RED) THEN
          DO L=1, N_PROFILE
            SURF_DOWN_CLR(L)=SURF_DOWN_CLR(L)
     &        +FLUX_DOWN_CLEAR(L)+PLANCK_AIR_SURFACE(L)
          ENDDO
        ENDIF
*D DIAG3A.369,DIAG3A.393  
        IF (ISOLIR.EQ.IP_SOLAR) THEN
          DO L=1, N_PROFILE
            SURF_UP_CLR(L)=SURF_UP_CLR(L)
     &        +FLUX_UP_CLEAR(L)
          ENDDO
        ELSE IF (ISOLIR.EQ.IP_INFRA_RED) THEN
          DO L=1, N_PROFILE
            SURF_UP_CLR(L)=SURF_UP_CLR(L)
     &        +FLUX_UP_CLEAR(L)+PLANCK_AIR_SURFACE(L)
          ENDDO
        ENDIF

*D DIAG3A.396
*/CNG!     This diagnostic is available only in the solar region. Over
*/CNG!     sea-points it refers only to the flux over the open sea
*/CNG!     (see the comments about sea_flux above). Over land, both the
*/CNG!     upward and downward fluxes are taken as uniform.
*D DIAG3A.398,DIAG3A.413  
*/CNG        IF (ISOLIR.EQ.IP_SOLAR) THEN
*/CNG          DO L=1, N_PROFILE
*/CNG            IF (LAND(L)) THEN
*/CNG              FLUX_BELOW_690NM_SURF(L)=FLUX_BELOW_690NM_SURF(L)
*/CNG     &          +WEIGHT_690NM*(FLUX_DOWN(L)-FLUX_UP(L))
*/CNG            ELSE
*/CNG              FLUX_BELOW_690NM_SURF(L)=FLUX_BELOW_690NM_SURF(L)
*/CNG     &          +WEIGHT_690NM
*/CNG     &          *(FLUX_DOWN(L)*(1.0E+00-ALBEDO_SEA_DIFF(L))
*/CNG     &          +FLUX_DIRECT(L)*(ALBEDO_SEA_DIFF(L)-ALBEDO_SEA_DIR(L)))
*/CNG            ENDIF
*/CNG          ENDDO
*/CNG        ENDIF
*/CNG Replaced by Nic Gedney:






