proddl.f90

### TABLE OF CONTENTS

- 1. UTI/proddl

## UTI/proddl [ Modules ]

[ Top ] [ Modules ]

NOM

     proddl(w,bli,blo,co,ndim)

DESCRIPTION

     Initialise les ddls d un bloc du calcul co a partir des ddls du bloc du calcul ci
     les maillages des calculs sont eventuellement (de)raffine par 2.

     Initialise the dof of a co calculation block from the dof of the ci calculation block
     calculation meshes are eventually refined or coarsen

        ENTREES / INPUT
        w   variable primitives  du bloc initial / primitive variable of the initial block
        bli  objet bloc initial / initial block object
        blo  objet bloc final / final block object
        ndim  dimension du maillage 1,2 ou3 / mesh dimension 1,2 or 3

        SORTIES / OUTPUT
        co  objet calcul de sortie (out) / output calcul object

SOURCE

    ! Ce logiciel est regi par la licence [CeCILL-B]
    ! This software is governed by the [CeCILL-B] license
    !=========================== DEBUT DES DECLARATIONS ====================
    !.1-----  Implicit, Use
      use num
      IMPLICIT NONE
    !.2-----  Declaration
      type(bloc), intent(in)      :: bli,blo !! Bloc initial et final / Initial and final block
      type(list_vec), intent(inout)  :: w !! Variables primitives du bloc initial / Primitive variables of the initial block
      integer,intent(in)          :: ndim !! dimension du probleme / Problem dimension
      type(calcul), intent(inout) :: co  !! Objet calcul modifie / Modified calcul object

      integer                     :: i,j,k,nxi,nyi,nzi,nxo,nyo,nzo,nci,nco,ici,ico,ierr
    !=========================== DEBUT DU CODE EXECUTABLE ==================
    nxi=1;nyi=1;nzi=1;nxo=1;nyo=1;nzo=1

      SELECT CASE (ndim)
         CASE (1) ! Cas 1D
           nxi=bli%nx*2**(bli%nrb)
           nyi=1
           nzi=1
           nxo=blo%nx*2**(blo%nrb)
           nyo=1
           nzo=1
         CASE (2) ! Cas 2D
           nxi=bli%nx*2**(bli%nrb)
           nyi=bli%ny*2**(bli%nrb)
           nzi=1
           nxo=blo%nx*2**(blo%nrb)
           nyo=blo%ny*2**(blo%nrb)
           nzo=1
         CASE (3) ! Cas 3D
           nxi=bli%nx*2**(bli%nrb)
           nyi=bli%ny*2**(bli%nrb)
           nzi=bli%nz*2**(bli%nrb)
           nxo=blo%nx*2**(blo%nrb)
           nyo=blo%ny*2**(blo%nrb)
           nzo=blo%nz*2**(blo%nrb)
      END SELECT

      nci=nxi*nyi*nzi
      nco=nxo*nyo*nzo
      ierr=0
      DO i=1,nco
          co%msh%list_cell(i+blo%first_cell)%w%chi    =0.d0
          co%msh%list_cell(i+blo%first_cell)%w%vprim%v=0.d0
          co%msh%list_cell(i+blo%first_cell)%w%vbal%v =0.d0
          co%msh%list_cell(i+blo%first_cell)%w%gprim(1)%v=0.d0
          co%msh%list_cell(i+blo%first_cell)%w%gprim(2)%v=0.d0
          co%msh%list_cell(i+blo%first_cell)%w%gprim(3)%v=0.d0
      END DO

    !======================================================================
    ! projection des ddl dans le bloc
    !======================================================================
      IF (nci.eq.nco) THEN  ! le maillage interieur est identique
          ierr=1
          DO i=1,nco
              co%msh%list_cell(i+blo%first_cell)%w%vprim%v= w%vec(i)%v
              if(imodel_phy.eq.1.and. ngrad_bathy.eq.0)then ! on recupere le gradient de bathy si besoin
               SELECT CASE (ibathy)
                  CASE(0)
                  CASE(1) ! Initialisation de la bathymetrie par fonction utilisateur
                          CALL fct_bathy(co%msh%list_cell(i+blo%first_cell)%center%x, &
                                         co%msh%list_cell(i+blo%first_cell)%center%y, &
                                         co%msh%list_cell(i+blo%first_cell)%center%z, &
                                         co%msh%list_cell(i+blo%first_cell)%w%vprim%v(5), &
                                         co%msh%list_cell(i+blo%first_cell)%w%gprim(1)%v(5),&
                                         co%msh%list_cell(i+blo%first_cell)%w%gprim(2)%v(5), &
                                         co%msh%list_cell(i+blo%first_cell)%w%vprim%v(6))
                  !~CASE (2) ! Initialisation de la bathymetrie par interpolation lineaire par bloc
                  !~CASE (3) ! Initialisation de la bathymetrie par bloc sur le raffinement max
                  CASE DEFAULT
                     call print_err('proddl','Unforeseen case')
               END SELECT
              endif
          END DO
      END IF
    !----------------------
      IF (nci.eq.(nco*(2**ndim)))then ! le maillage est plus grossier
          ierr=1
          if(imodel_phy.eq.1)then
    !methode qui conserve eta et pas h !!
            do i=1,nxi
              do j=1,nyi
                do k=1,nzi
                  ici=i+(j-1)*nxi+(k-1)*nxi*nyi
                  ico=int((i+1)/2)+(int((j+1)/2)-1)*nxo+(int((k+1)/2)-1)*nxo*nyo+blo%first_cell
    !changement de repere h=eta
                  if(w%vec(ici)%v(1)>hzero_phy)then
                    w%vec(ici)%v(1)=w%vec(ici)%v(1)+w%vec(ici)%v(5)
                  else
                    w%vec(ici)%v(1:3)=0.d0
                  endif

                  co%msh%list_cell(ico)%w%vprim%v=co%msh%list_cell(ico)%w%vprim%v+w%vec(ici)%v
                enddo
              enddo
            enddo
            do i=1,nxo*nyo*nzo
              co%msh%list_cell(i+blo%first_cell)%w%vprim%v=co%msh%list_cell(i+blo%first_cell)%w%vprim%v/(2.d0**ndim)
    !changement de repere h=h
    ! on met a jour la bathymetrie
               SELECT CASE (ibathy)
                  CASE(0)
                  CASE(1) ! Initialisation de la bathymetrie par fonction utilisateur
                          CALL fct_bathy(co%msh%list_cell(i+blo%first_cell)%center%x, &
                                         co%msh%list_cell(i+blo%first_cell)%center%y, &
                                         co%msh%list_cell(i+blo%first_cell)%center%z, &
                                         co%msh%list_cell(i+blo%first_cell)%w%vprim%v(5), &
                                         co%msh%list_cell(i+blo%first_cell)%w%gprim(1)%v(5),&
                                         co%msh%list_cell(i+blo%first_cell)%w%gprim(2)%v(5), &
                                         co%msh%list_cell(i+blo%first_cell)%w%vprim%v(6))
                  !~CASE (2) ! Initialisation de la bathymetrie par interpolation lineaire par bloc
                  !~CASE (3) ! Initialisation de la bathymetrie par bloc sur le raffinement max
                  CASE DEFAULT
                     call print_err('proddl','Unforeseen case')
               END SELECT

              co%msh%list_cell(i+blo%first_cell)%w%vprim%v(1)=max(0.d0,&
              co%msh%list_cell(i+blo%first_cell)%w%vprim%v(1)-co%msh%list_cell(i+blo%first_cell)%w%vprim%v(5))
              call prim2bal(co%msh%list_cell(i+blo%first_cell)%w)
            enddo

          else

            DO i=1,nxi
              DO j=1,nyi
                  DO k=1,nzi
                      ici=i+(j-1)*nxi+(k-1)*nxi*nyi
                      ico=int((i+1)/2)+(int((j+1)/2)-1)*nxo+(int((k+1)/2)-1)*nxo*nyo+blo%first_cell
                      co%msh%list_cell(ico)%w%vprim%v=co%msh%list_cell(ico)%w%vprim%v+w%vec(ici)%v
                  END DO
              END DO
            END DO
            DO i=1,nxo*nyo*nzo
              co%msh%list_cell(i+blo%first_cell)%w%vprim%v=co%msh%list_cell(i+blo%first_cell)%w%vprim%v/(2.d0**ndim)
              CALL prim2bal(co%msh%list_cell(i+blo%first_cell)%w)
            END DO
          endif
      END IF
    !----------------------
      IF (nci.eq.(nco/(2**ndim))) THEN ! le maillage est plus fin
          ierr=1
          if(imodel_phy.eq.1)then !methode qui conserve eta et pas h !!
                DO i=1,nxo
                  DO j=1,nyo
                      DO k=1,nzo
                          ico=i+(j-1)*nxo+(k-1)*nxo*nyo+blo%first_cell
                          ici=int((i+1)/2)+(int((j+1)/2)-1)*nxi+(int((k+1)/2)-1)*nxi*nyi
                          co%msh%list_cell(ico)%w%vprim%v=w%vec(ici)%v
                          ! on met a jour la bathymetrie
                           SELECT CASE (ibathy)
                              CASE(0)
                              CASE(1) ! Initialisation de la bathymetrie par fonction utilisateur
                                      CALL fct_bathy(co%msh%list_cell(ico)%center%x, &
                                                     co%msh%list_cell(ico)%center%y, &
                                                     co%msh%list_cell(ico)%center%z, &
                                                     co%msh%list_cell(ico)%w%vprim%v(5), &
                                                     co%msh%list_cell(ico)%w%gprim(1)%v(5),&
                                                     co%msh%list_cell(ico)%w%gprim(2)%v(5), &
                                                     co%msh%list_cell(ico)%w%vprim%v(6))
                              !~CASE (2) ! Initialisation de la bathymetrie par interpolation lineaire par bloc
                              !~CASE (3) ! Initialisation de la bathymetrie par bloc sur le raffinement max
                              CASE DEFAULT
                                 call print_err('proddl','Unforeseen case')
                           END SELECT
                           co%msh%list_cell(ico)%w%vprim%v(1)=max(0.d0,w%vec(ici)%v(1)+&
                           w%vec(ici)%v(5)-co%msh%list_cell(ico)%w%vprim%v(5))
                      END DO
                  END DO
              END DO
          else
              DO i=1,nxo
                  DO j=1,nyo
                      DO k=1,nzo
                          ico=i+(j-1)*nxo+(k-1)*nxo*nyo+blo%first_cell
                          ici=int((i+1)/2)+(int((j+1)/2)-1)*nxi+(int((k+1)/2)-1)*nxi*nyi
                          co%msh%list_cell(ico)%w%vprim%v=w%vec(ici)%v
                      END DO
                  END DO
              END DO
          endif
      END IF
    !----------------------
      IF (ierr.eq.0) THEN ! Impossible
          write(*,*)nci,nco
          call print_err('proddl',' ERROR : Incompatible cell numbers')
      END IF
    !===========================   FIN DE LA ROUTINE    ====================
    END SUBROUTINE proddl