goup.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\utils\bief\goup.f
00002 !
00091                      SUBROUTINE GOUP
00092 !                    ***************
00093 !
00094      &(X, A,B ,DITR,MESH,COPY)
00095 !
00096 !***********************************************************************
00097 ! BIEF   V6P0                                   21/08/2010
00098 !***********************************************************************
00099 !
00100 !
00101 !
00102 !
00103 !
00104 !
00105 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00106 !| A              |-->| MATRIX A IN LDU FORM
00107 !| B              |<--| RIGHT-HAND SIDE OF THE SYSTEM
00108 !| COPY           |-->| IF YES. B IS FIRST COPIED ON X.
00109 !| DITR           |-->| OPTION  'D' : MATRIX A IS TAKEN
00110 !|                |   |         'T' : MATRIX TRANSPOSED(A)
00111 !| MESH           |-->| MESH STRUCTURE
00112 !| X              |<--| SOLUTION OF SYSTEM AX = B
00113 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00114 !
00115       USE BIEF, EX_GOUP => GOUP
00116 !
00117       IMPLICIT NONE
00118       INTEGER LNG,LU
00119       COMMON/INFO/LNG,LU
00120 !
00121 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00122 !
00123       TYPE(BIEF_OBJ), INTENT(INOUT) :: X
00124       TYPE(BIEF_OBJ), INTENT(IN)    :: A,B
00125       TYPE(BIEF_MESH), INTENT(IN)   :: MESH
00126       CHARACTER(LEN=1), INTENT(IN)  :: DITR
00127       LOGICAL, INTENT(IN) :: COPY
00128 !
00129 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00130 !
00131       INTEGER S,SA,I
00132 !
00133 !-----------------------------------------------------------------------
00134 !
00135       IF(X%TYPE.EQ.4) THEN
00136         S = X%N
00137       ELSE
00138         S = 0
00139       ENDIF
00140 !
00141 !     CASE WHERE THE SYSTEM IS A BLOCK BUT WHERE ONLY ONE
00142 !     PRECONDITIONING MATRIX IS USED
00143 !
00144       IF(A%TYPE.EQ.3) THEN
00145         SA = 0
00146       ELSEIF(A%TYPE.EQ.4) THEN
00147         SA = A%N
00148       ELSE
00149         IF (LNG.EQ.1) WRITE(LU,300) A%TYPE
00150         IF (LNG.EQ.2) WRITE(LU,400) A%TYPE
00151 300     FORMAT(1X,'GOUP (BIEF) :',1I6,' TYPE DE A NON PREVU.')
00152 400     FORMAT(1X,'GOUP (BIEF) :',1I6,' UNEXPECTED TYPE FOR A.')
00153         CALL PLANTE(0)
00154         STOP
00155       ENDIF
00156 !
00157 !-----------------------------------------------------------------------
00158 !
00159       IF(S.EQ.0.AND.SA.EQ.0) THEN
00160 !
00161 !     CASE WHERE A IS A SIMPLE MATRIX AND X A SIMPLE VECTOR
00162 !
00163         CALL GOUP1(X, A,B ,DITR,MESH,COPY)
00164 !
00165       ELSEIF(S.GT.0.AND.S.EQ.SA) THEN
00166 !
00167 !     CASE WHERE BLOCK A ONLY HAS DIAGONALS
00168 !
00169         DO I=1,S
00170           CALL GOUP1( X%ADR(I)%P,A%ADR(I)%P,B%ADR(I)%P,DITR,MESH,COPY)
00171         ENDDO ! I
00172 !
00173       ELSEIF(S.GT.0.AND.S**2.EQ.SA) THEN
00174 !
00175 !     CASE WHERE BLOCK A HAS AS MANY MATRICES AS THE WHOLE SYSTEM :
00176 !     ONLY CONSIDERS THE DIAGONALS
00177 !
00178         DO I=1,S
00179           CALL GOUP1( X%ADR(I)%P,
00180      &                A%ADR(1+(S+1)*(I-1))%P,
00181      &                B%ADR(I)%P,
00182      &                DITR,MESH,COPY)
00183         ENDDO ! I
00184 !
00185 !     CASE WHERE A IS A SINGLE MATRIX AND X A BLOCK
00186 !
00187       ELSEIF(S.GT.0.AND.SA.EQ.0) THEN
00188 !
00189         DO I=1,S
00190           CALL GOUP1(X%ADR(I)%P,
00191      &                A,
00192      &                B%ADR(I)%P,
00193      &                DITR,MESH,COPY)
00194         ENDDO ! I
00195 !
00196       ELSE
00197         IF (LNG.EQ.1) WRITE(LU,301)
00198         IF (LNG.EQ.2) WRITE(LU,401)
00199 301     FORMAT(1X,'GOUP (BIEF) : CAS NON PREVU')
00200 401     FORMAT(1X,'GOUP (BIEF) : UNEXPECTED CASE')
00201         CALL PLANTE(1)
00202         STOP
00203       ENDIF
00204 !
00205 !-----------------------------------------------------------------------
00206 !
00207       RETURN
00208       END

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