*IF DEF,A70_1A,OR,DEF,A70_1B                                               APB4F405.5      
*IF DEF,A01_3A,OR,DEF,A02_3A                                               ASFX3A.2      
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved.    GTS2F400.13093  
C                                                                          GTS2F400.13094  
C Use, duplication or disclosure of this code is subject to the            GTS2F400.13095  
C restrictions as set forth in the contract.                               GTS2F400.13096  
C                                                                          GTS2F400.13097  
C                Meteorological Office                                     GTS2F400.13098  
C                London Road                                               GTS2F400.13099  
C                BRACKNELL                                                 GTS2F400.13100  
C                Berkshire UK                                              GTS2F400.13101  
C                RG12 2SZ                                                  GTS2F400.13102  
C                                                                          GTS2F400.13103  
C If no contract has been raised with this copy of the code, the use,      GTS2F400.13104  
C duplication or disclosure of it is strictly prohibited.  Permission      GTS2F400.13105  
C to do so must first be obtained in writing from the Head of Numerical    GTS2F400.13106  
C Modelling at the above address.                                          GTS2F400.13107  
C ******************************COPYRIGHT******************************    GTS2F400.13108  
C                                                                          GTS2F400.13109  
!+ Subroutine to assign fluxes to the final arrays.                        ASFX3A.3      
!                                                                          ASFX3A.4      
! Method:                                                                  ASFX3A.5      
!       The array FLUX_TOTAL holds the calculated total fluxes             ASFX3A.6      
!       (differential fluxes in the IR). These may be net or               ASFX3A.7      
!       upward and downward fluxes. Upward and downward fluxes             ASFX3A.8      
!       are passed to FLUX_UP and FLUX_DOWN and incremented by the         ASFX3A.9      
!       Planckian flux in the IR. Net downward fluxes are assigned         ASFX3A.10     
!       to FLUX_DOWN. Equivalent calculations may be performed for         ASFX3A.11     
!       the clear-sky fluxes.                                              ASFX3A.12     
!                                                                          ASFX3A.13     
! Current Owner of Code: J. M. Edwards                                     ASFX3A.14     
!                                                                          ASFX3A.15     
! History:                                                                 ASFX3A.16     
!       Version         Date                    Comment                    ASFX3A.17     
!       4.0             27-07-95                Original Code              ASFX3A.18     
!                                               (J. M. Edwards)            ASFX3A.19     
!                                                                          ASFX3A.20     
! Description of Code:                                                     ASFX3A.21     
!   FORTRAN 77  with extensions listed in documentation.                   ASFX3A.22     
!                                                                          ASFX3A.23     
!- ---------------------------------------------------------------------   ASFX3A.24     

      SUBROUTINE ASSIGN_FLUX(N_PROFILE, N_LAYER                             1ASFX3A.25     
     &   , FLUX_TOTAL, FLUX_TOTAL_CLEAR                                    ASFX3A.26     
     &   , ISOLIR                                                          ASFX3A.27     
     &   , PLANCK_FLUX                                                     ASFX3A.28     
     &   , L_CLEAR, L_NET                                                  ASFX3A.29     
     &   , FLUX_DOWN, FLUX_UP, FLUX_DOWN_CLEAR, FLUX_UP_CLEAR              ASFX3A.30     
     &   , NPD_PROFILE, NPD_LAYER                                          ASFX3A.31     
     &   )                                                                 ASFX3A.32     
!                                                                          ASFX3A.33     
!                                                                          ASFX3A.34     
      IMPLICIT NONE                                                        ASFX3A.35     
!                                                                          ASFX3A.36     
!                                                                          ASFX3A.37     
!     SIZES OF DUMMY ARRAYS.                                               ASFX3A.38     
      INTEGER   !, INTENT(IN)                                              ASFX3A.39     
     &     NPD_PROFILE                                                     ASFX3A.40     
!             MAXIMUM NUMBER OF PROFILES                                   ASFX3A.41     
     &   , NPD_LAYER                                                       ASFX3A.42     
!             MAXIMUM NUMBER OF LAYERS                                     ASFX3A.43     
!                                                                          ASFX3A.44     
!                                                                          ASFX3A.45     
!     INCLUDE COMDECKS.                                                    ASFX3A.46     
*CALL SPCRG3A                                                              ASFX3A.47     
!                                                                          ASFX3A.48     
!     DUMMY ARGUMENTS.                                                     ASFX3A.49     
      INTEGER                                                              ASFX3A.50     
     &     N_PROFILE                                                       ASFX3A.51     
!             NUMBER OF PROFILES                                           ASFX3A.52     
     &   , N_LAYER                                                         ASFX3A.53     
!             NUMBER OF LAYERS                                             ASFX3A.54     
     &   , ISOLIR                                                          ASFX3A.55     
!             SPECTRAL REGION                                              ASFX3A.56     
      LOGICAL   !, INTENT(IN)                                              ASFX3A.57     
     &     L_CLEAR                                                         ASFX3A.58     
!             CLEAR FLUX FLAG                                              ASFX3A.59     
     &   , L_NET                                                           ASFX3A.60     
!             CALCULATE NET FLUXES                                         ASFX3A.61     
      REAL      !, INTENT(IN)                                              ASFX3A.62     
     &     FLUX_TOTAL(NPD_PROFILE, 2*NPD_LAYER+2)                          ASFX3A.63     
!             LONG VECTOR OF TOTAL FLUXES                                  ASFX3A.64     
     &   , FLUX_TOTAL_CLEAR(NPD_PROFILE, 2*NPD_LAYER+2)                    ASFX3A.65     
!             LONG VECTOR OF TOTAL CLEAR FLUXES                            ASFX3A.66     
     &   , PLANCK_FLUX(NPD_PROFILE, 0: NPD_LAYER)                          ASFX3A.67     
!             PLANCKIAN FLUXES AT BOUNDARIES                               ASFX3A.68     
      REAL      !, INTENT(OUT)                                             ASFX3A.69     
     &     FLUX_DOWN(NPD_PROFILE, 0: NPD_LAYER)                            ASFX3A.70     
!             (NET) TOTAL DOWNWARD FLUXES                                  ASFX3A.71     
     &   , FLUX_UP(NPD_PROFILE, 0: NPD_LAYER)                              ASFX3A.72     
!             UPWARD FLUXES                                                ASFX3A.73     
     &   , FLUX_DOWN_CLEAR(NPD_PROFILE, 0: NPD_LAYER)                      ASFX3A.74     
!             CLEAR (NET) TOTAL DOWNWARD FLUXES                            ASFX3A.75     
     &   , FLUX_UP_CLEAR(NPD_PROFILE, 0: NPD_LAYER)                        ASFX3A.76     
!             CLEAR UPWARD FLUXES                                          ASFX3A.77     
                                                                           ASFX3A.78     
!     LOCAL VARIABLES.                                                     ASFX3A.79     
      INTEGER                                                              ASFX3A.80     
     &     I                                                               ASFX3A.81     
!             LOOP VARIABLE                                                ASFX3A.82     
     &   , L                                                               ASFX3A.83     
!             LOOP VARIABLE                                                ASFX3A.84     
!                                                                          ASFX3A.85     
!                                                                          ASFX3A.86     
      IF (ISOLIR.EQ.IP_SOLAR) THEN                                         ASFX3A.87     
         IF (L_NET) THEN                                                   ASFX3A.88     
            DO I=0, N_LAYER                                                ASFX3A.89     
               DO L=1, N_PROFILE                                           ASFX3A.90     
                  FLUX_DOWN(L, I)=FLUX_TOTAL(L, I+1)                       ASFX3A.91     
               ENDDO                                                       ASFX3A.92     
            ENDDO                                                          ASFX3A.93     
         ELSE                                                              ASFX3A.94     
            DO I=0, N_LAYER                                                ASFX3A.95     
               DO L=1, N_PROFILE                                           ASFX3A.96     
                  FLUX_UP(L, I)=FLUX_TOTAL(L, 2*I+1)                       ASFX3A.97     
                  FLUX_DOWN(L, I)=FLUX_TOTAL(L, 2*I+2)                     ASFX3A.98     
               ENDDO                                                       ASFX3A.99     
            ENDDO                                                          ASFX3A.100    
         ENDIF                                                             ASFX3A.101    
      ELSE IF (ISOLIR.EQ.IP_INFRA_RED) THEN                                ASFX3A.102    
         IF (L_NET) THEN                                                   ASFX3A.103    
!           NO PLANCKIAN CORRECTION IS NECESSARY TO THE NET FLUX.          ASFX3A.104    
            DO I=0, N_LAYER                                                ASFX3A.105    
               DO L=1, N_PROFILE                                           ASFX3A.106    
                  FLUX_DOWN(L, I)=FLUX_TOTAL(L, I+1)                       ASFX3A.107    
               ENDDO                                                       ASFX3A.108    
            ENDDO                                                          ASFX3A.109    
         ELSE                                                              ASFX3A.110    
            DO I=0, N_LAYER                                                ASFX3A.111    
               DO L=1, N_PROFILE                                           ASFX3A.112    
                  FLUX_UP(L, I)=FLUX_TOTAL(L, 2*I+1)                       ASFX3A.113    
     &               +PLANCK_FLUX(L, I)                                    ASFX3A.114    
                  FLUX_DOWN(L, I)=FLUX_TOTAL(L, 2*I+2)                     ASFX3A.115    
     &               +PLANCK_FLUX(L, I)                                    ASFX3A.116    
               ENDDO                                                       ASFX3A.117    
            ENDDO                                                          ASFX3A.118    
         ENDIF                                                             ASFX3A.119    
      ENDIF                                                                ASFX3A.120    
!                                                                          ASFX3A.121    
      IF (L_CLEAR) THEN                                                    ASFX3A.122    
         IF (ISOLIR.EQ.IP_SOLAR) THEN                                      ASFX3A.123    
            IF (L_NET) THEN                                                ASFX3A.124    
               DO I=0, N_LAYER                                             ASFX3A.125    
                  DO L=1, N_PROFILE                                        ASFX3A.126    
                     FLUX_DOWN_CLEAR(L, I)=FLUX_TOTAL_CLEAR(L, I+1)        ASFX3A.127    
                  ENDDO                                                    ASFX3A.128    
               ENDDO                                                       ASFX3A.129    
            ELSE                                                           ASFX3A.130    
               DO I=0, N_LAYER                                             ASFX3A.131    
                  DO L=1, N_PROFILE                                        ASFX3A.132    
                     FLUX_UP_CLEAR(L, I)=FLUX_TOTAL_CLEAR(L, 2*I+1)        ASFX3A.133    
                     FLUX_DOWN_CLEAR(L, I)=FLUX_TOTAL_CLEAR(L, 2*I+2)      ASFX3A.134    
                  ENDDO                                                    ASFX3A.135    
               ENDDO                                                       ASFX3A.136    
            ENDIF                                                          ASFX3A.137    
!                                                                          ASFX3A.138    
         ELSEIF (ISOLIR.EQ.IP_INFRA_RED) THEN                              ASFX3A.139    
            IF (L_NET) THEN                                                ASFX3A.140    
               DO I=0, N_LAYER                                             ASFX3A.141    
                  DO L=1, N_PROFILE                                        ASFX3A.142    
                     FLUX_DOWN_CLEAR(L, I)=FLUX_TOTAL_CLEAR(L, I+1)        ASFX3A.143    
                  ENDDO                                                    ASFX3A.144    
               ENDDO                                                       ASFX3A.145    
            ELSE                                                           ASFX3A.146    
               DO I=0, N_LAYER                                             ASFX3A.147    
                  DO L=1, N_PROFILE                                        ASFX3A.148    
                     FLUX_UP_CLEAR(L, I)=FLUX_TOTAL_CLEAR(L, 2*I+1)        ASFX3A.149    
     &                  +PLANCK_FLUX(L, I)                                 ASFX3A.150    
                     FLUX_DOWN_CLEAR(L, I)=FLUX_TOTAL_CLEAR(L, 2*I+2)      ASFX3A.151    
     &                  +PLANCK_FLUX(L, I)                                 ASFX3A.152    
                  ENDDO                                                    ASFX3A.153    
               ENDDO                                                       ASFX3A.154    
            ENDIF                                                          ASFX3A.155    
         ENDIF                                                             ASFX3A.156    
      ENDIF                                                                ASFX3A.157    
!                                                                          ASFX3A.158    
!     NET FLUXES ARE HABITUALLY USED IN THE UNIFIED MODEL, SO THE          ASFX3A.159    
!     FOLLOWING REDUCTION IS ALWAYS CARRIED OUT.                           ASFX3A.160    
      IF (.NOT.L_NET) THEN                                                 ASFX3A.161    
         DO I=0, N_LAYER                                                   ASFX3A.162    
            DO L=1, N_PROFILE                                              ASFX3A.163    
               FLUX_DOWN(L, I)=FLUX_DOWN(L, I)-FLUX_UP(L, I)               ASFX3A.164    
            ENDDO                                                          ASFX3A.165    
         ENDDO                                                             ASFX3A.166    
         IF (L_CLEAR) THEN                                                 ASFX3A.167    
            DO I=0, N_LAYER                                                ASFX3A.168    
               DO L=1, N_PROFILE                                           ASFX3A.169    
                  FLUX_DOWN_CLEAR(L, I)                                    ASFX3A.170    
     &               =FLUX_DOWN_CLEAR(L, I)-FLUX_UP_CLEAR(L, I)            ASFX3A.171    
               ENDDO                                                       ASFX3A.172    
            ENDDO                                                          ASFX3A.173    
         ENDIF                                                             ASFX3A.174    
      ENDIF                                                                ASFX3A.175    
!                                                                          ASFX3A.176    
!                                                                          ASFX3A.177    
      RETURN                                                               ASFX3A.178    
      END                                                                  ASFX3A.179    
*ENDIF DEF,A01_3A,OR,DEF,A02_3A                                            ASFX3A.180    
*ENDIF DEF,A70_1A,OR,DEF,A70_1B                                            APB4F405.6