pre4_mumps.F

Go to the documentation of this file.

!                   *********************
                    SUBROUTINE pre4_mumps
!                   *********************
!
     &(npoin,nsegb,glosegb,dab1,dab2,dab3,dab4,xab1,xab2,xab3,xab4,
     & xx1,xx2,cvb1,cvb2,typext1,typext2,typext3,typext4,
     & knolg,npoin_tot)
!
!***********************************************************************
! MUMPSVOID   V7P1
!***********************************************************************
!
!brief    CALLS THE DIRECT SOLVER MUMPS.
!+        IF MUMPS IS NOT INSTALLED : EMPTY SUBROUTINES ARE USED INSTEAD.
!
!history  E. RAZAFINDRAKOTO (LNH)
!+        20/11/2006
!+
!+
!
!history  C. DENIS (SINETICS)
!+        14/10/2009
!+        V5P9
!+
!
!history  N.DURAND (HRW), S.E.BOURBAN (HRW)
!+        13/07/2010
!+        V6P0
!+   Translation of French comments within the FORTRAN sources into
!+   English comments
!
!history  N.DURAND (HRW), S.E.BOURBAN (HRW)
!+        21/08/2010
!+        V6P0
!+   Creation of DOXYGEN tags for automated documentation and
!+   cross-referencing of the FORTRAN sources
!
!history  J-M HERVOUET (EDF LAB, LNHE)
!+        23/02/2015
!+        V7P1
!+   Arguments TYPEXT1,2,3,4 added, for calling SD_FABSG4
!
!history  S.E.BOURBAN (HRW)
!+        21/08/2015
!+        V7P1
!+   Final tweak to the arguments of SOLVE_MUMPS_PAR for linkage with
!+   MUMPS ... It now works !
!+   Although letting MUMPS recreate a new split of the mesh is not
!+   helpful at this stage.
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!| CVB1,CVB2      |-->| SECONDS MEMBRES
!| DAB1           |---|
!| DAB2           |---|
!| DAB3           |---|
!| DAB4           |---|
!| GLOSEGB        |---|
!| NPOIN          |-->| NOMBRE D'INCONNUES
!| NSEGB          |-->| NOMBRE DE SEGMENTS
!| TYPEXT         |-->| TYPE OF EXTRA-DIAGONAL TERMS OF MATRICES
!| XAB1           |---|
!| XAB2           |---|
!| XAB3           |---|
!| XAB4           |---|
!| XX1,XX2        |<--| SOLUTIONS
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
      USE declarations_telemac, ONLY : gloseg4_p4m,xa_p4m,da_p4m,
     &                                 rhs_p4m,xinc_p4m,size_rhs_p4m,
     &                                 size_da_p4m,size_xa_p4m,
     &                                 size_xinc_p4m,size_gloseg4_p4m
      USE bief
!
      USE declarations_special
      IMPLICIT NONE
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
      INTEGER, INTENT(IN) :: NPOIN,NSEGB,NPOIN_TOT
      INTEGER, INTENT(IN) :: GLOSEGB(nsegb*2),KNOLG(*)
      DOUBLE PRECISION, INTENT(IN)    :: DAB1(npoin),DAB2(npoin)
      DOUBLE PRECISION, INTENT(IN)    :: DAB3(npoin),DAB4(npoin)
      DOUBLE PRECISION, INTENT(IN)    :: XAB1(2*nsegb),XAB2(2*nsegb)
      DOUBLE PRECISION, INTENT(IN)    :: XAB3(2*nsegb),XAB4(2*nsegb)
      DOUBLE PRECISION, INTENT(INOUT) :: XX1(npoin),XX2(npoin)
      DOUBLE PRECISION, INTENT(IN)    :: CVB1(npoin),CVB2(npoin)
      CHARACTER(LEN=1), INTENT(IN)    :: TYPEXT1,TYPEXT2
      CHARACTER(LEN=1), INTENT(IN)    :: TYPEXT3,TYPEXT4
!
#if defined HAVE_MUMPS
      INTEGER NPBLK,NSEGBLK,I
!
!-----------------------------------------------------------------------
!
      npblk=npoin*2
      nsegblk=4*nsegb+npoin
!
      IF(size_gloseg4_p4m.EQ.0) THEN
        ALLOCATE(gloseg4_p4m(2*nsegblk))
        size_gloseg4_p4m=    2*nsegblk
      ELSEIF(            2*nsegblk.GT.size_gloseg4_p4m) THEN
        DEALLOCATE(gloseg4_p4m)
        ALLOCATE(gloseg4_p4m(2*nsegblk))
        size_gloseg4_p4m=    2*nsegblk
      ENDIF
      IF(size_da_p4m.EQ.0) THEN
        ALLOCATE(da_p4m(npblk))
        size_da_p4m=    npblk
      ELSEIF(       npblk.GT.size_da_p4m) THEN
        DEALLOCATE(da_p4m)
        ALLOCATE(da_p4m(npblk))
        size_da_p4m=    npblk
      ENDIF
      IF(size_xa_p4m.EQ.0) THEN
        ALLOCATE(xa_p4m(2*nsegblk))
        size_xa_p4m=    2*nsegblk
      ELSEIF(       2*nsegblk.GT.size_xa_p4m) THEN
        DEALLOCATE(xa_p4m)
        ALLOCATE(xa_p4m(2*nsegblk))
        size_xa_p4m=    2*nsegblk
      ENDIF
      IF(size_rhs_p4m.EQ.0) THEN
        ALLOCATE(rhs_p4m(npblk))
        size_rhs_p4m=    npblk
      ELSEIF(        npblk.GT.size_rhs_p4m) THEN
        DEALLOCATE(rhs_p4m)
        ALLOCATE(rhs_p4m(npblk))
        size_rhs_p4m=    npblk
      ENDIF
      IF(size_xinc_p4m.EQ.0) THEN
        ALLOCATE(xinc_p4m(npblk))
        size_xinc_p4m=    npblk
      ELSEIF(         npblk.GT.size_xinc_p4m) THEN
        DEALLOCATE(xinc_p4m)
        ALLOCATE(xinc_p4m(npblk))
        size_xinc_p4m=    npblk
      ENDIF
!
!-----------------------------------------------------------------------
!
!     1. SECOND MEMBRE DU SYSTEME
!     ===========================
!
      DO i=1,npoin
        rhs_p4m(i)      = cvb1(i)
        rhs_p4m(i+npoin)= cvb2(i)
      ENDDO
!
!     2. CONSTRUCTION STOCKAGE SEGMENT MATRICE BLOCK (DE 4)
!     =====================================================
!
      CALL sd_strsg4(npoin,nsegb,glosegb,nsegblk,gloseg4_p4m)
!
      CALL sd_fabsg4(npoin,nsegb,dab1,dab2,dab3,dab4,
     &               xab1,xab2,xab3,xab4,npblk,nsegblk,da_p4m,xa_p4m,
     &               typext1,typext2,typext3,typext4)
!
!     3. RESOLUTION : APPEL A MUMPS
!     =============================
!

!
      CALL solve_mumps_par(npblk,nsegblk,gloseg4_p4m,nsegblk,da_p4m,
     &                     xa_p4m,xinc_p4m,rhs_p4m,'Q',knolg,
     &                     npoin_tot)
!
!     4. RECUPERATION DES INCONNUES
!     =============================
!
      DO i=1,npoin
        xx1(i)= xinc_p4m(i)
        xx2(i)= xinc_p4m(i+npoin)
      ENDDO
!
#else
      WRITE(lu,2019)
2019  FORMAT(1x,'MUMPS NOT INSTALLED IN THIS SYSTEM',/,1x,
     &     'CHOOSE OTHER METHOD ',///)
      CALL plante(1)
      stop
#endif
!
!-----------------------------------------------------------------------
!
      RETURN
      END