prismdrv_get_all_grids.F90

Go to the documentation of this file.

  SUBROUTINE prismdrv_get_all_grids ( id_nb_grids,       &
                                      id_xml_grids,      &
                                      sda_smioc_grids,   &
                                      id_comp,           &
                                      id_error )

! !DESCRIPTION

! Called from prismdrv_init_smioc_struct for the second pass only 
! This routine creates all "User-defined" associated gridless grids
! for each input or output channel that uses a "user3D" interpolation method
!
!---------------------------------------------------------------------------
!
! !PUBLIC TYPES
  USE PRISM_Constants
  USE PSMILe_Common
  USE PSMILe_smioc
  USE PSMILE_smioc_interface

  IMPLICIT NONE

! 0. Declaration
!
! total number of grids (XML + Udef)
    INTEGER, INTENT(In) :: id_nb_grids

! number of XML grids (read from files)
    INTEGER, INTENT(In) :: id_xml_grids

! smioc grid  structure
    TYPE(smioc_grid), DIMENSION(id_nb_grids), INTENT(InOut) :: sda_smioc_grids

! Component id
    INTEGER, INTENT(In) :: id_comp

! returned error code
    INTEGER, INTENT(Out):: id_error

! Loop indices
    INTEGER :: ib, ib_bis, ib_nt, ib_xml, ib_xmlv, ib_xud
    INTEGER :: il_nb, il_nb_bis, il_nb_ter, il_nb_terbis, il_nb_terter
    INTEGER :: il_nb_qua, il_nb_cin, il_nb_six, il_nb_hep, il_nb_oct
    INTEGER :: il_nb_bisbis
    INTEGER :: il_dim_i, il_dim_o, il_ch, il_side
!
    CHARACTER(LEN=max_name)  :: cl_name,  cl_out
!
#ifdef DEBUG
    print *,"get_all_grids : id_xml_grids    = ", id_xml_grids
    print *,"get_all_grids : nb udef grids   = ", iga_comp_nb_udef(id_comp)
    print *,"get_all_grids : id_nb_grids     = ", id_nb_grids
#endif
!
!   Return if NO transient with "user3D" interpolation
!
    if ( iga_comp_nb_udef(id_comp) == 0 ) RETURN

!   Second pass only : for each transient involved with User_defined Interp
!                      we need to associate a gridless grid. 
!                      The name of this gridless grid is just the transient local name
!                      with a suffix : _glgrid_I_xx   (or O_xx)                    
!                      where xx is the input-origin  or the output channel number
!
!   Before entering this subroutine, the structure sla_driver_grids is filled
!   from index 1 to id_xml_grids : sla_driver_grids(1:id_xml_grids)

!   this subroutine creates the structures for the "gridless" grids
!   ib is "global index in component" of the "gridless" additional grids
!      ib values are from id_xml_grids + 1  to id_nb_grids
!
    ib = id_xml_grids

!   Loop on the sga_comp_udef_idx(id_comp)%ig_xml_udef  XML_udef transients
    DO ib_xud = 1, sga_comp_udef_idx(id_comp)%ig_xml_udef

!   Note that for 1 geographic grid, we can have several "gridless" auxilliary
!   grids : 1 for each input origin, or output with user3D interpolation
!   gridless grid index ib is therefore increased in the loop before each creation.

!   ib_xml is the index of the grid in component SMIOC file 
    ib_xml = sga_comp_udef_idx(id_comp)%iga_trans_udef(ib_xud)
#ifdef DEBUG
   print *, ' get_all_grids : ib, ib_xud, ib_xml = ', ib, ib_xud, ib_xml
#endif

!   Get real number of channels of ib_xml transient (In  "AND / OR"  Out)
    il_dim_i = sga_comp_udef_idx(id_comp)%sla_driver_udef(ib_xml)%ig_dim_orig
    il_dim_o = sga_comp_udef_idx(id_comp)%sla_driver_udef(ib_xml)%ig_dim_out

    IF ( il_dim_i .GT. 0 )  THEN

!   Transient In : create gridless grid if flag is .true.  (target side)
      DO il_ch = 1, il_dim_i
         IF ( sga_comp_udef_idx(id_comp)%sla_driver_udef(ib_xml)%  &
                    lga_trin_orig(il_ch) ) THEN
#ifdef DEBUG
   print *, ' get_all_grids : In,  ib_xml il_ch ib = ', ib_xml, il_ch, ib
#endif
            ib = ib + 1
            IF ( ib .GT. id_nb_grids ) THEN
               PRINT *, '********************************************************'
               PRINT *, 'Index overflow in psmile_smioc : prismdrv_get_all_grids '
               PRINT *, '********************************************************'
               CALL PSMILe_Flushstd
               CALL MPI_Abort(MPI_COMM_WORLD, 1, id_error)
            ENDIF
!    Internal check on the value of ib_xml
            ib_xmlv = sga_comp_udef_idx(id_comp)%iga_xml_trindex(ib-id_xml_grids)
            IF ( ib_xmlv .NE. ib_xml ) THEN
               PRINT *, '*****************************************************'
               PRINT *, 'Index error in psmile_smioc : prismdrv_get_all_grids '
               PRINT *, '*****************************************************'
               CALL PSMILe_Flushstd
               CALL MPI_Abort(MPI_COMM_WORLD, 1, id_error)
             ENDIF
!    Create gridless grid structure
             il_side = 1
!    Construct grid name from transient name + suffix
             cl_name = sga_comp_udef_idx(id_comp)%sla_driver_udef(ib_xml)%cg_local_name
             call put_udef_suffix ( cl_name, cl_out, il_ch, il_side )
             sda_smioc_grids(ib)%cg_grid_name = trim(adjustl(cl_out))
#ifdef VERBOSE
  PRINT *, '| | |  '
  PRINT *, '| | |  get_all_grids : chan side ib  gridname = ',il_ch, il_side, ib, &
                   sda_smioc_grids(ib)%cg_grid_name
  CALL PSMILe_Flushstd
#endif

          ENDIF        ! channel is "udef"
        ENDDO       ! loop on all input channels
      ENDIF      ! il_dim_i > 0
!
!
      IF ( il_dim_o .GT. 0 )  THEN
        DO il_ch = 1, il_dim_o
          IF ( sga_comp_udef_idx(id_comp)%sla_driver_udef(ib_xml)%  &
                    lga_trout(il_ch) ) THEN
#ifdef DEBUG
   print *, ' get_all_grids : Out, ib_xml il_ch ib = ', ib_xml, il_ch, ib
#endif
            ib = ib + 1
            IF ( ib .GT. id_nb_grids ) THEN
               PRINT *, '********************************************************'
               PRINT *, 'Index overflow in psmile_smioc : prismdrv_get_all_grids '
               PRINT *, '********************************************************'
               CALL PSMILe_Flushstd
               CALL MPI_Abort(MPI_COMM_WORLD, 1, id_error)
            ENDIF
!    Internal check on the value of ib_xml
            ib_xmlv = sga_comp_udef_idx(id_comp)%iga_xml_trindex(ib-id_xml_grids)
            IF ( ib_xmlv .NE. ib_xml ) THEN
               PRINT *, '*****************************************************'
               PRINT *, 'Index error in psmile_smioc : prismdrv_get_all_grids '
               PRINT *, '*****************************************************'
               CALL PSMILe_Flushstd
               CALL MPI_Abort(MPI_COMM_WORLD, 1, id_error)
             ENDIF
!    Create gridless transient structures
             il_side = 0
!    Construct grid name from transient name + suffix
             cl_name = sga_comp_udef_idx(id_comp)%sla_driver_udef(ib_xml)%cg_local_name
             call put_udef_suffix ( cl_name, cl_out, il_ch, il_side )
             sda_smioc_grids(ib)%cg_grid_name = trim(adjustl(cl_out))
#ifdef VERBOSE
  PRINT *, '| | |  '
  PRINT *, '| | |  get_all_grids : chan side ib  gridname = ',il_ch, il_side, ib, &
                   sda_smioc_grids(ib)%cg_grid_name
  CALL PSMILe_Flushstd
#endif

          ENDIF      ! channel is "udef"
       ENDDO       ! loop on all output channels
     ENDIF      ! il_dim_o > 0
!
     ENDDO            !  loop on "xml udef" transients to be copied

!
  END SUBROUTINE prismdrv_get_all_grids