solve_mumps_par.F

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\utils\bief\solve_mumps_par.F
00002 !
00039                        SUBROUTINE SOLVE_MUMPS_PAR
00040      &    (NPOIN,NSEGB,GLOSEG,MAXSEG,DA,XA,XINC,RHS,INFOGR,TYPEXT,KNOLG,
00041      &     NPOIN_TOT,IPID)
00042 !                      *************************
00043 
00044 !***********************************************************************
00045 !     MUMPS VERSION 5.7     26/02/10   C. DENIS (SINETICS)
00046 !***********************************************************************
00047 !
00048 !     PARALLEL SOLVING USING MUMPS
00049       USE DECLARATIONS_PARALLEL
00050 
00051       IMPLICIT NONE
00052 !     structures MPI et MUMPS
00053 #if defined (HAVE_MUMPS)
00054       INCLUDE 'dmumps_struc.h'
00055 #endif
00056 !
00057 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00058 ! ARGUMENTS
00059       INTEGER, INTENT(IN)             :: NPOIN,NSEGB,MAXSEG,NPOIN_TOT,
00060      &     IPID
00061       INTEGER, INTENT(IN)             :: GLOSEG(MAXSEG,2)
00062       INTEGER LT
00063       LOGICAL, INTENT(IN)             :: INFOGR
00064       DOUBLE PRECISION, INTENT(INOUT) :: XA(*),RHS(NPOIN)
00065       DOUBLE PRECISION, INTENT(INOUT) :: XINC(NPOIN),DA(NPOIN)
00066       CHARACTER(LEN=1), INTENT(INOUT)    :: TYPEXT
00067       INTEGER, INTENT(IN) :: KNOLG(*)
00068 !
00069 !-----------------------------------------------------------------------
00070 !
00071       COMMON/INFO/LNG,LU
00072       INTEGER LNG,LU
00073 #if defined (HAVE_MUMPS)
00074 !
00075       DOUBLE PRECISION TIME_IN_SECONDS2
00076       EXTERNAL TIME_IN_SECONDS2
00077       DOUBLE PRECISION T1,T2,T3,T4,T5
00078       TYPE (DMUMPS_STRUC) MUMPS_PAR
00079 !     INDIRECT ARRAYS
00080       DOUBLE PRECISION ,ALLOCATABLE :: TEMP1(:),TEMP2(:),TEMP3(:)
00081       INTEGER TAILLE
00082       INTEGER I,J,K,ERR,NBELEM,IERR,II,NC,IER
00083 
00084 !     MUMPS INITIALISATION
00085       MUMPS_PAR%COMM = MPI_COMM_WORLD
00086       MUMPS_PAR%JOB = -1
00087       IF(TYPEXT.EQ.'S') THEN
00088         MUMPS_PAR%SYM = 2
00089       ELSE
00090         MUMPS_PAR%SYM = 0
00091       ENDIF
00092       MUMPS_PAR%PAR = 1
00093       CALL DMUMPS(MUMPS_PAR)
00094 !     NO INFORMATION COMING FROM MUMPS ARE PRINTED
00095 !     TO BE MODIFIED TO INTRODUCE A DEBGUGGING MODE
00096       MUMPS_PAR%ICNTL(3)=-1
00097       MUMPS_PAR%ICNTL(4)=0
00098 !     THE MATRIX IS DISTRIBUTED OVER PROCESSORS AND PROVIDED BY THE USER
00099       MUMPS_PAR%ICNTL(18)=3
00100 !     THE MATRIX IS ASSEMBLED
00101       MUMPS_PAR%ICNTL(5)=0
00102 !     AUTOMATIC SCALING OF THE MATRIX
00103       MUMPS_PAR%ICNTL(6)=7
00104 !     AUTOMATIC REORDERING OF THE MATRIX
00105       MUMPS_PAR%ICNTL(7)=7
00106       MUMPS_PAR%ICNTL(11)=1
00107 !
00108       MUMPS_PAR%ICNTL(8)=77
00109       MUMPS_PAR%ICNTL(11)=77
00110       MUMPS_PAR%ICNTL(10)=10
00111       MUMPS_PAR%ICNTL(14)=50
00112       MUMPS_PAR%ICNTL(13)=40
00113 
00114 !     SIZE OF THE MATRIX
00115       MUMPS_PAR%N = 2*NPOIN_TOT
00116       IF(TYPEXT.EQ.'S') THEN
00117         MUMPS_PAR%NZ_LOC = NPOIN+NSEGB
00118       ELSE
00119         MUMPS_PAR%NZ_LOC = NPOIN+2*NSEGB
00120       ENDIF
00121       IF (.NOT. ASSOCIATED(MUMPS_PAR%IRN_LOC)) THEN
00122         ALLOCATE(TEMP1(MUMPS_PAR%N),STAT=ERR)
00123         IF(ERR.NE.0) GOTO 100
00124         ALLOCATE(TEMP2(MUMPS_PAR%N),STAT=ERR)
00125         IF(ERR.NE.0) GOTO 100
00126         ALLOCATE(TEMP3(NPOIN),STAT=ERR)
00127         IF(ERR.NE.0) GOTO 100
00128         ALLOCATE(MUMPS_PAR%IRN_LOC(MUMPS_PAR%NZ_LOC),STAT=ERR)
00129         IF(ERR.NE.0) GOTO 100
00130         ALLOCATE(MUMPS_PAR%JCN_LOC(MUMPS_PAR%NZ_LOC),STAT=ERR)
00131         IF(ERR.NE.0) GOTO 100
00132         ALLOCATE(MUMPS_PAR%A_LOC(MUMPS_PAR%NZ_LOC),STAT=ERR)
00133         IF(ERR.NE.0) GOTO 100
00134         ALLOCATE(MUMPS_PAR%RHS(MUMPS_PAR%N),STAT=ERR)
00135         IF(ERR.NE.0) GOTO 100
00136         GOTO 101
00137  100    CONTINUE
00138         IF(LNG.EQ.1) WRITE(LU,1000) ERR
00139         IF(LNG.EQ.2) WRITE(LU,2000) ERR
00140         CALL PLANTE(1)
00141         STOP
00142  101    CONTINUE
00143       END IF
00144       TEMP1(:)=0.0
00145       TEMP2(:)=0.0
00146       TEMP3(:)=0
00147       MUMPS_PAR%IRN_LOC(:)=0
00148       MUMPS_PAR%JCN_LOC(:)=0
00149       MUMPS_PAR%A_LOC(:)=0.0
00150       MUMPS_PAR%RHS(:)=0.0
00151       DO K = 1,NPOIN
00152         IF (K  .LE.  NPOIN/2) THEN
00153           MUMPS_PAR%IRN_LOC(K) = KNOLG(K)
00154           MUMPS_PAR%JCN_LOC(K) = KNOLG(K)
00155           TEMP1(KNOLG(K))=RHS(K)
00156           TEMP3(K)=KNOLG(K)
00157         ELSE
00158           MUMPS_PAR%IRN_LOC(K) = KNOLG(K-NPOIN/2) + MUMPS_PAR%N/2
00159           MUMPS_PAR%JCN_LOC(K) = KNOLG(K-NPOIN/2) + MUMPS_PAR%N/2
00160           TEMP1(KNOLG(K-NPOIN/2)+ MUMPS_PAR%N/2)=RHS(K)
00161           TEMP3(K)=KNOLG(K-NPOIN/2)+ MUMPS_PAR%N/2
00162         END IF
00163         MUMPS_PAR%A_LOC(K) = DA(K)
00164       ENDDO
00165 !     GLOBAL REDUCTION OF RHS VECTOR
00166       CALL MPI_ALLREDUCE(TEMP1,TEMP2,MUMPS_PAR%N,MPI_DOUBLE_PRECISION,
00167      &     MPI_SUM,
00168      &     MPI_COMM_WORLD,IER)
00169       DO I=1,MUMPS_PAR%N
00170         MUMPS_PAR%RHS(I)=TEMP2(I)
00171       END DO
00172 
00173       NBELEM = NPOIN
00174       IF(TYPEXT.EQ.'S') THEN
00175         DO K = 1,NSEGB
00176           I = TEMP3(GLOSEG(K,1))
00177           J = TEMP3(GLOSEG(K,2))
00178           NBELEM = NBELEM + 1
00179           IF(I.LT.J) THEN
00180             MUMPS_PAR%IRN_LOC(NBELEM) = I
00181             MUMPS_PAR%JCN_LOC(NBELEM) = J
00182           ELSE
00183             MUMPS_PAR%IRN_LOC(NBELEM) = J
00184             MUMPS_PAR%JCN_LOC(NBELEM) = I
00185           ENDIF
00186           MUMPS_PAR%A_LOC(NBELEM) = XA(K)
00187         ENDDO
00188       ELSE
00189         DO K = 1,2*NSEGB
00190           I = TEMP3(GLOSEG(K,1))
00191           J = TEMP3(GLOSEG(K,2))
00192           NBELEM = NBELEM + 1
00193           MUMPS_PAR%IRN_LOC(NBELEM) = I
00194           MUMPS_PAR%JCN_LOC(NBELEM) = J
00195           MUMPS_PAR%A_LOC(NBELEM) = XA(K)
00196         ENDDO
00197       ENDIF
00198 
00199 
00200 !     -----------
00201 !     RESOLUTION
00202 !     -----------
00203       MUMPS_PAR%JOB = 6
00204       CALL DMUMPS(MUMPS_PAR)
00205       TEMP1(:)=0.0
00206       IF(MUMPS_PAR%MYID.EQ. 0 ) THEN
00207 !...  une erreur de resolution est survenue
00208         IF(MUMPS_PAR%INFO(1).LT.0) THEN
00209           IF(LNG.EQ.1) WRITE(LU,1001) MUMPS_PAR%INFO(1)
00210           IF(LNG.EQ.2) WRITE(LU,2001) MUMPS_PAR%INFO(1)
00211           CALL PLANTE(1)
00212           STOP
00213         ENDIF
00214         DO K = 1,MUMPS_PAR%N
00215           TEMP1(K)=MUMPS_PAR%RHS(K)
00216         END DO
00217       END IF
00218       TEMP2(:)=0.0
00219 
00220       CALL MPI_BCAST(TEMP1,MUMPS_PAR%N,
00221      &MPI_DOUBLE_PRECISION,
00222      &0,MPI_COMM_WORLD,IER)
00223       DO  K = 1,NPOIN
00224         I=TEMP3(K)
00225         XINC(K)=TEMP1(I)
00226       ENDDO
00227 !/////////////////////////////////////////////////////////////////////////////////////////////////////
00228 ! les lignes ci-dessous sont a decommenter s'il s'agit du dernier appel a MUMPS.
00229 ! Donc il faut prevoir de passer en argument  un flag (par ex. le nb de pas de temps max a simuler?)
00230 ! pour savoir quand le code appelant le solveur fait son dernier calcul.
00231 ! Actuellement on suppose que l'instance et les tableaux de travail de MUMPS sont
00232 ! automatiquement detruits a la sortie de l'execution de Telemac
00233 !/////////////////////////////////////////////////////////////////////////////////////////////////////
00234 ! Desallocation des tableaux de travail
00235 !       DEALLOCATE(TEMP1)
00236 !       DEALLOCATE(TEMP2)
00237 !       DEALLOCATE(TEMP3)
00238 !       DEALLOCATE(TEMP4)
00239 !       DEALLOCATE(MUMPS_PAR%IRN_LOC)
00240 !       DEALLOCATE(MUMPS_PAR%JCN_LOC)
00241 !       DEALLOCATE(MUMPS_PAR%A_LOC)
00242 !       DEALLOCATE(MUMPS_PAR%RHS)
00243 !     END IF
00244 !  Destruction de l'instance en cours
00245       MUMPS_PAR%JOB = -2
00246       CALL DMUMPS(MUMPS_PAR)
00247       RETURN
00248 1000  FORMAT(1X,'SOLVE_MUMPS : ERREUR A L''ALLOCATION DE MEMOIRE : '
00249      &,/,1X,'CODE D''ERREUR : ',1I6)
00250 1001  FORMAT(1X,'SOLVE_MUMPS : ERREUR LORS DE LA RESOLUTION : '
00251      &,/,1X,'CODE D''ERREUR INFO(1) : ',1I6)
00252 2000  FORMAT(1X,'SOLVE_MUMPS: ERROR DURING ALLOCATION OF MEMORY: '
00253      &,/,1X,'ERROR CODE: ',1I6)
00254 2001  FORMAT(1X,'SOLVE_MUMPS: ERROR DURING SOLVE: '
00255      &     ,/,1X,'ERROR CODE INFO(1): ',1I6)
00256 #else
00257       IF(LNG.EQ.1) WRITE(LU,2018)
00258       IF(LNG.EQ.2) WRITE(LU,2019)
00259 2018  FORMAT(1X,'MUMPS_PAR NON INSTALLE SUR CE SYSTEME,',/,1X,
00260      &     'CHOISIR UNE AUTRE METHODE',///)
00261 2019  FORMAT(1X,'MUMPS_PAR NOT INSTALLED IN THIS SYSTEM',/,1X,
00262      &     'CHOOSE OTHER METHOD ',///)
00263       CALL PLANTE(1)
00264       STOP
00265 !
00266 #endif
00267 !
00268         END SUBROUTINE SOLVE_MUMPS_PAR
00269 
00270 

Generated on Fri Aug 31 2013 18:12:58 by S.E.Bourban (HRW) using doxygen 1.7.0