var/da/da_setup_structures/da_scale_background_errors.inc

   1 subroutine da_scale_background_errors ( be, it )
   2 !
   3    TYPE (be_type), INTENT(INOUT) :: be     ! Back. errors structure
   4    INTEGER,        INTENT(IN)    :: it     ! outer-loop index
   5 !
   6    real, allocatable, dimension(:,:) :: v1_val , v2_val , v3_val , &
   7                                         v4_val , v5_val
   8    real*8, allocatable, dimension(:) :: rf_len1, rf_len2, rf_len3, &
   9                                         rf_len4, rf_len5,          &
  10                                         rf_len6, rf_len7, rf_len8, &
  11                                         rf_len9, rf_len10,rf_len11
  12 !
  13    integer                     :: be_rf_unit, be_print_unit
  14    integer  :: i, ix, jy, kz, v1_mz, v2_mz, v3_mz, v4_mz, v5_mz
  15    real     :: ds
  16
  17 #if (WRF_CHEM == 1)
  18    !real, allocatable, dimension(:,:,:) :: v12_val
  19    real*8, allocatable, dimension(:,:) :: rf_len12
  20    !integer  :: v12_mz(num_chem)
  21    integer  :: ic
  22 #endif
  23
  24    if ( jb_factor <= 0.0 ) return
  25 !
  26 ! Rewind the unit:
  27     !be_rf_unit    = unit_end + 1
  28     !be_print_unit = unit_end + 2
  29     call da_get_unit(be_rf_unit)
  30     call da_get_unit(be_print_unit)
  31     open(be_rf_unit   , file="be_rf.dat"   ,status="old", form="unformatted")
  32     open(be_print_unit, file="be_print.dat",status="old", position="append")
  33     rewind (be_rf_unit)
  34 !
  35 ! Read the dimensions and allocate the arrays:
  36     read(be_rf_unit) kz, jy, ix, v1_mz, v2_mz, v3_mz, v4_mz, v5_mz, ds
  37 !
  38     allocate ( v1_val (1:jy,1:v1_mz) )
  39     allocate ( rf_len1(1:kz) )
  40     allocate ( v2_val (1:jy,1:v2_mz) )
  41     allocate ( rf_len2(1:kz) )
  42     allocate ( v3_val (1:jy,1:v3_mz) )
  43     allocate ( rf_len3(1:kz) )
  44     allocate ( v4_val (1:jy,1:v4_mz) )
  45     allocate ( rf_len4(1:kz) )
  46     allocate ( v5_val (1:jy,1:v5_mz) )
  47     allocate ( rf_len5(1:1) )
  48 !
  49 ! Read the variances and scale-lengths and restore them to be:
  50     read(be_rf_unit) v1_val , v2_val , v3_val , v4_val , v5_val , &
  51                      rf_len1, rf_len2, rf_len3, rf_len4, rf_len5
  52 !
  53     be % v1 % val = v1_val
  54     be % v2 % val = v2_val
  55     be % v3 % val = v3_val
  56     be % v4 % val = v4_val
  57     be % v5 % val = v5_val
  58 !
  59 ! Rescale the scale-lengths and variances:
  60    CALL da_rescale_background_errors( var_scaling1(it), len_scaling1(it), &
  61                                       ds, rf_len1, be % v1 )
  62 !  .........................................................
  63    CALL da_rescale_background_errors( var_scaling2(it), len_scaling2(it), &
  64                                       ds, rf_len2, be % v2 )
  65 ! ..........................................................
  66    CALL da_rescale_background_errors( var_scaling3(it), len_scaling3(it), &
  67                                       ds, rf_len3, be % v3 )
  68 ! ...............................................................
  69    CALL da_rescale_background_errors( var_scaling4(it), len_scaling4(it), &
  70                                       ds, rf_len4, be % v4 )
  71 ! ..............................................................
  72    CALL da_rescale_background_errors( var_scaling5(it), len_scaling5(it), &
  73                                       ds, rf_len5, be % v5 )
  74 !
  75 ! Print the variances and RF (Recursive Filter) factors rf_alpha:
  76     write(unit=stdout,fmt='(/5x,"Complete the Rescale BES in outer-loop:" i2)') it
  77
  78     if ( print_detail_be ) then
  79        write(be_print_unit,'(/"============================================================")')
  80        write(be_print_unit,'("For outer loop ",i2)') it
  81        write(be_print_unit,'("it=",i2,2x,"kz=",i3,2x,"jy=",i4,2x,"ix=",i4,2x,"ds=",e12.5)') &
  82                                                       it, kz, jy, ix, ds
  83        write(be_print_unit,'("Namelist options specified for this iteration:")')
  84        write(be_print_unit,'("var_scaling1(it) = ",e12.5,2x,"len_scaling1(it) = "e12.5)')var_scaling1(it),len_scaling1(it)
  85        write(be_print_unit,'("var_scaling2(it) = ",e12.5,2x,"len_scaling2(it) = "e12.5)')var_scaling2(it),len_scaling2(it)
  86        write(be_print_unit,'("var_scaling3(it) = ",e12.5,2x,"len_scaling3(it) = "e12.5)')var_scaling3(it),len_scaling3(it)
  87        write(be_print_unit,'("var_scaling4(it) = ",e12.5,2x,"len_scaling4(it) = "e12.5)')var_scaling4(it),len_scaling4(it)
  88        write(be_print_unit,'("var_scaling5(it) = ",e12.5,2x,"len_scaling5(it) = "e12.5)')var_scaling5(it),len_scaling5(it)
  89        write(be_print_unit,'("Background error statistics for this iteration:")')
  90        write(be_print_unit,'("mz=",i3,2x,"be%v1%val:"/(10e12.5))') be%v1%mz, be%v1%val(1,:)
  91        write(be_print_unit,'("mz=",i3,2x,"be%v2%val:"/(10e12.5))') be%v2%mz, be%v2%val(1,:)
  92        write(be_print_unit,'("mz=",i3,2x,"be%v3%val:"/(10e12.5))') be%v3%mz, be%v3%val(1,:)
  93        write(be_print_unit,'("mz=",i3,2x,"be%v4%val:"/(10e12.5))') be%v4%mz, be%v4%val(1,:)
  94        write(be_print_unit,'("mz=",i3,2x,"be%v5%val:"/(10e12.5))') be%v5%mz, be%v5%val(1,:)
  95        write(be_print_unit,'("be%v1%rf_alpha:"/(10e12.5))') be % v1 % rf_alpha(:)
  96        write(be_print_unit,'("be%v2%rf_alpha:"/(10e12.5))') be % v2 % rf_alpha(:)
  97        write(be_print_unit,'("be%v3%rf_alpha:"/(10e12.5))') be % v3 % rf_alpha(:)
  98        write(be_print_unit,'("be%v4%rf_alpha:"/(10e12.5))') be % v4 % rf_alpha(:)
  99        write(be_print_unit,'("be%v5%rf_alpha:"/(10e12.5))') be % v5 % rf_alpha(:)
 100        write(be_print_unit,'(/"scale-length: kz=",i3)') kz
 101        do i = 1,kz
 102           if (i == 1) then
 103              write(be_print_unit,'(i3,2x,5e15.5)') i, rf_len1(i), rf_len2(i), rf_len3(i), rf_len4(i), rf_len5(i)
 104           else
 105              write(be_print_unit,'(i3,2x,4e15.5)') i, rf_len1(i), rf_len2(i), rf_len3(i), rf_len4(i)
 106           endif
 107        enddo
 108     endif
 109 !
 110 ! Deallocate the arrays:
 111     deallocate ( v1_val )
 112     deallocate ( rf_len1 )
 113     deallocate ( v2_val )
 114     deallocate ( rf_len2 )
 115     deallocate ( v3_val )
 116     deallocate ( rf_len3 )
 117     deallocate ( v4_val )
 118     deallocate ( rf_len4 )
 119     deallocate ( v5_val )
 120     deallocate ( rf_len5 )
 121
 122     if ( cloud_cv_options >= 2 ) then
 123        allocate ( rf_len6(1:kz) )
 124        allocate ( rf_len7(1:kz) )
 125        allocate ( rf_len8(1:kz) )
 126        allocate ( rf_len9(1:kz) )
 127        allocate ( rf_len10(1:kz) )
 128        read (be_rf_unit) be%v6%val, be%v7%val, be%v8%val, &
 129                          be%v9%val, be%v10%val
 130        read (be_rf_unit) rf_len6, rf_len7, rf_len8, rf_len9, rf_len10
 131        call da_rescale_background_errors( var_scaling6(it), len_scaling6(it), &
 132                                           ds, rf_len6, be % v6 )
 133        call da_rescale_background_errors( var_scaling7(it), len_scaling7(it), &
 134                                           ds, rf_len7, be % v7 )
 135        call da_rescale_background_errors( var_scaling8(it), len_scaling8(it), &
 136                                           ds, rf_len8, be % v8 )
 137        call da_rescale_background_errors( var_scaling9(it), len_scaling9(it), &
 138                                           ds, rf_len9, be % v9 )
 139        call da_rescale_background_errors( var_scaling10(it), len_scaling10(it), &
 140                                           ds, rf_len10, be % v10)
 141        deallocate ( rf_len6 )
 142        deallocate ( rf_len7 )
 143        deallocate ( rf_len8 )
 144        deallocate ( rf_len9 )
 145        deallocate ( rf_len10 )
 146     end if
 147
 148 #if (WRF_CHEM == 1)
 149   if (chem_cv_options >=10) then
 150      !allocate ( v12_val (num_chem,1:jy,1:maxval(v12_mz(1:num_chem-1))) )
 151      allocate ( rf_len12(num_chem,1:kz) )
 152
 153      do ic=PARAM_FIRST_SCALAR, num_chem
 154         read(be_rf_unit) be % v12(ic-1) % val !!= v12_val(ic-1,:,1:v12_mz(ic-1))
 155      end do
 156
 157      do ic=PARAM_FIRST_SCALAR, num_chem
 158         read(be_rf_unit) rf_len12(ic-1,:)
 159      end do
 160
 161      do ic=PARAM_FIRST_SCALAR, num_chem
 162         call da_rescale_background_errors( var_scaling12((it-1)*(num_chem-1)+ic-1), len_scaling12((it-1)*(num_chem-1)+ic-1), &
 163                                            ds, rf_len12(ic-1,:), be % v12(ic-1) )
 164      end do
 165
 166      deallocate ( rf_len12 )
 167   end if
 168 #endif
 169
 170     if ( use_cv_w ) then
 171        allocate ( rf_len11(1:kz) )
 172        read (be_rf_unit) be%v11%val
 173        read (be_rf_unit) rf_len11
 174        call da_rescale_background_errors( var_scaling11(it), len_scaling11(it), &
 175                                           ds, rf_len11, be % v11)
 176        deallocate ( rf_len11 )
 177     end if
 178
 179    close(be_rf_unit)
 180    close(be_print_unit)
 181    call da_free_unit(be_rf_unit)
 182    call da_free_unit(be_print_unit)
 183
 184 end subroutine da_scale_background_errors
 185