om5111.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\utils\bief\om5111.f
00002 !
00084                      SUBROUTINE OM5111
00085 !                    *****************
00086 !
00087      &(OP ,  DM,TYPDIM,XM,TYPEXM,   DN,TYPDIN,XN,TYPEXN,   C,
00088      & SIZDN,SZMDN,SIZXN,SZMXN,NETAGE, NELMAX3D)
00089 !
00090 !***********************************************************************
00091 ! BIEF   V6P1                                   21/08/2010
00092 !***********************************************************************
00093 !
00094 !
00095 !
00096 !
00097 !
00098 !
00099 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00100 !| C              |-->| A GIVEN CONSTANT USED IN OPERATION OP
00101 !| DM             |<->| DIAGONAL OF M
00102 !| DN             |-->| DIAGONAL OF N
00103 !| NELMAX3D       |-->| MAXIMUM NUMBER OF 3D ELEMENTS
00104 !| NETAGE         |-->| NUMBER OF PLANES - 1
00105 !| OP             |-->| OPERATION TO BE DONE (SEE ABOVE)
00106 !| SIZDN          |-->| SIZE OF DIAGONAL DN
00107 !| SIZXN          |-->| SIZE OF OFF-DIAGONAL TERMS XN
00108 !| SZMDN          |-->| MAXIMUM SIZE OF DIAGONAL DN
00109 !| SZMXN          |-->| MAXIMUM SIZE OF OFF-DIAGONAL TERMS XN
00110 !| TYPDIM         |<->| TYPE OF DIAGONAL OF M:
00111 !|                |   | TYPDIM = 'Q' : ANY VALUE
00112 !|                |   | TYPDIM = 'I' : IDENTITY
00113 !|                |   | TYPDIM = '0' : ZERO
00114 !| TYPDIN         |<->| TYPE OF DIAGONAL OF N:
00115 !|                |   | TYPDIN = 'Q' : ANY VALUE
00116 !|                |   | TYPDIN = 'I' : IDENTITY
00117 !|                |   | TYPDIN = '0' : ZERO
00118 !| TYPEXM         |-->| TYPE OF OFF-DIAGONAL TERMS OF M:
00119 !|                |   | TYPEXM = 'Q' : ANY VALUE
00120 !|                |   | TYPEXM = 'S' : SYMMETRIC
00121 !|                |   | TYPEXM = '0' : ZERO
00122 !| TYPEXN         |-->| TYPE OF OFF-DIAGONAL TERMS OF N:
00123 !|                |   | TYPEXN = 'Q' : ANY VALUE
00124 !|                |   | TYPEXN = 'S' : SYMMETRIC
00125 !|                |   | TYPEXN = '0' : ZERO
00126 !| XM             |-->| OFF-DIAGONAL TERMS OF M
00127 !| XN             |-->| OFF-DIAGONAL TERMS OF N
00128 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00129 !
00130       USE BIEF
00131 !
00132       IMPLICIT NONE
00133       INTEGER LNG,LU
00134       COMMON/INFO/LNG,LU
00135 !
00136 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00137 !
00138       INTEGER, INTENT(IN)             :: NETAGE,SIZDN,SZMXN,SZMDN,SIZXN
00139       INTEGER, INTENT(IN)             :: NELMAX3D
00140       CHARACTER(LEN=8), INTENT(IN)    :: OP
00141 !CC   DOUBLE PRECISION, INTENT(IN)    :: DN(*),XN(SZMXN,*)
00142       DOUBLE PRECISION, INTENT(IN)    :: DN(*),XN(NELMAX3D/(3*NETAGE),*)
00143       DOUBLE PRECISION, INTENT(INOUT) :: DM(SZMDN,*)
00144 !CC   DOUBLE PRECISION, INTENT(INOUT) :: XM(SZMXN,NETAGE,*)
00145       DOUBLE PRECISION,INTENT(INOUT)::XM(NELMAX3D/(3*NETAGE),3,NETAGE,*)
00146       CHARACTER(LEN=1), INTENT(INOUT) :: TYPDIM,TYPEXM,TYPDIN,TYPEXN
00147       DOUBLE PRECISION, INTENT(IN)    :: C
00148 !
00149 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00150 !
00151       INTEGER K
00152 !
00153       DOUBLE PRECISION Z(1)
00154 !
00155 !-----------------------------------------------------------------------
00156 !
00157       IF(OP(1:8).EQ.'M=M+NF  ') THEN
00158 !
00159         IF(TYPDIM.EQ.'Q'.AND.TYPDIN.EQ.'Q') THEN
00160           CALL OV( 'X=X+Y   ' , DM , DN , Z , C , SIZDN )
00161         ELSE
00162           IF (LNG.EQ.1) WRITE(LU,198) TYPDIM(1:1),OP(1:8),TYPDIN(1:1)
00163           IF (LNG.EQ.2) WRITE(LU,199) TYPDIM(1:1),OP(1:8),TYPDIN(1:1)
00164 198       FORMAT(1X,'OM5111 (BIEF) : TYPDIM = ',A1,' NON PROGRAMME',
00165      &      /,1X,'POUR L''OPERATION : ',A8,' AVEC TYPDIN = ',A1)
00166 199       FORMAT(1X,'OM5111 (BIEF) : TYPDIM = ',A1,' NOT IMPLEMENTED',
00167      &      /,1X,'FOR THE OPERATION : ',A8,' WITH TYPDIN = ',A1)
00168           CALL PLANTE(1)
00169           STOP
00170         ENDIF
00171 !
00172         IF(TYPEXM(1:1).EQ.'Q'.AND.TYPEXN(1:1).EQ.'Q') THEN
00173 !
00174 !          CASE WHERE BOTH MATRICES ARE NONSYMMETRICAL
00175 !
00176 !          XM(K,1,1,  )  K : TRIANGLE NUMBER
00177 !                        1 : T1 TETRAHEDRON, ONE SIDE OF WHICH IS AT THE BOTTOM
00178 !                        1 : 1ST LAYER, THAT AT THE BOTTOM
00179 !
00180            DO K = 1 , SIZXN
00181              XM(K,1,1,01) = XM(K,1,1,01) + XN(K,1)
00182              XM(K,1,1,02) = XM(K,1,1,02) + XN(K,2)
00183              XM(K,1,1,04) = XM(K,1,1,04) + XN(K,3)
00184              XM(K,1,1,07) = XM(K,1,1,07) + XN(K,4)
00185              XM(K,1,1,08) = XM(K,1,1,08) + XN(K,5)
00186              XM(K,1,1,10) = XM(K,1,1,10) + XN(K,6)
00187            ENDDO
00188 !
00189         ELSEIF(TYPEXM(1:1).EQ.'Q'.AND.TYPEXN(1:1).EQ.'S') THEN
00190 !
00191 !          CASE WHERE M CAN BE ANYTHING AND N IS SYMMETRICAL
00192 !
00193            DO K = 1 , SIZXN
00194              XM(K,1,1,01) = XM(K,1,1,01) + XN(K,1)
00195              XM(K,1,1,02) = XM(K,1,1,02) + XN(K,2)
00196              XM(K,1,1,04) = XM(K,1,1,04) + XN(K,3)
00197              XM(K,1,1,07) = XM(K,1,1,07) + XN(K,1)
00198              XM(K,1,1,08) = XM(K,1,1,08) + XN(K,2)
00199              XM(K,1,1,10) = XM(K,1,1,10) + XN(K,3)
00200            ENDDO
00201 !
00202         ELSEIF(TYPEXM(1:1).EQ.'S'.AND.TYPEXN(1:1).EQ.'S') THEN
00203 !
00204 !          CASE WHERE BOTH MATRICES ARE SYMMETRICAL
00205 !
00206            DO K = 1 , SIZXN
00207              XM(K,1,1,01) = XM(K,1,1,01) + XN(K,1)
00208              XM(K,1,1,02) = XM(K,1,1,02) + XN(K,2)
00209              XM(K,1,1,04) = XM(K,1,1,04) + XN(K,3)
00210            ENDDO
00211 !
00212         ELSE
00213            IF (LNG.EQ.1) WRITE(LU,98) TYPEXM(1:1),OP(1:8),TYPEXN(1:1)
00214            IF (LNG.EQ.2) WRITE(LU,99) TYPEXM(1:1),OP(1:8),TYPEXN(1:1)
00215 98         FORMAT(1X,'OM5111 (BIEF) : TYPEXM = ',A1,' NE CONVIENT PAS',
00216      &       /,1X,'POUR L''OPERATION : ',A8,' AVEC TYPEXN = ',A1)
00217 99         FORMAT(1X,'OM5111 (BIEF) : TYPEXM = ',A1,' DOES NOT GO',
00218      &       /,1X,'FOR THE OPERATION : ',A8,' WITH TYPEXN = ',A1)
00219            CALL PLANTE(1)
00220            STOP
00221         ENDIF
00222 !
00223 !-----------------------------------------------------------------------
00224 !
00225       ELSEIF(OP(1:8).EQ.'M=M+TNF ') THEN
00226 !
00227         CALL OV( 'X=X+Y   ' , DM , DN , Z , C , SIZDN )
00228 !
00229         IF(TYPEXM(1:1).EQ.'Q'.AND.TYPEXN(1:1).EQ.'Q') THEN
00230 !
00231 !          CASE WHERE BOTH MATRICES ARE NONSYMMETRICAL
00232 !
00233            DO K = 1 , SIZXN
00234              XM(K,1,1,01) = XM(K,1,1,01) + XN(K,4)
00235              XM(K,1,1,02) = XM(K,1,1,02) + XN(K,5)
00236              XM(K,1,1,04) = XM(K,1,1,04) + XN(K,6)
00237              XM(K,1,1,07) = XM(K,1,1,07) + XN(K,1)
00238              XM(K,1,1,08) = XM(K,1,1,08) + XN(K,2)
00239              XM(K,1,1,10) = XM(K,1,1,10) + XN(K,3)
00240            ENDDO
00241 !
00242         ELSEIF(TYPEXM(1:1).EQ.'Q'.AND.TYPEXN(1:1).EQ.'S') THEN
00243 !
00244 !          CASE WHERE M CAN BE ANYTHING AND N IS SYMMETRICAL
00245 !
00246            DO K = 1 , SIZXN
00247              XM(K,1,1,01) = XM(K,1,1,01) + XN(K,1)
00248              XM(K,1,1,02) = XM(K,1,1,02) + XN(K,2)
00249              XM(K,1,1,04) = XM(K,1,1,04) + XN(K,3)
00250              XM(K,1,1,07) = XM(K,1,1,07) + XN(K,1)
00251              XM(K,1,1,08) = XM(K,1,1,08) + XN(K,2)
00252              XM(K,1,1,10) = XM(K,1,1,10) + XN(K,3)
00253            ENDDO
00254 !
00255         ELSEIF(TYPEXM(1:1).EQ.'S'.AND.TYPEXN(1:1).EQ.'S') THEN
00256 !
00257 !          CASE WHERE BOTH MATRICES ARE SYMMETRICAL
00258 !
00259            DO K = 1 , SIZXN
00260              XM(K,1,1,01) = XM(K,1,1,01) + XN(K,1)
00261              XM(K,1,1,02) = XM(K,1,1,02) + XN(K,2)
00262              XM(K,1,1,04) = XM(K,1,1,04) + XN(K,3)
00263            ENDDO
00264 !
00265         ELSE
00266            IF (LNG.EQ.1) WRITE(LU,98) TYPEXM(1:1),OP(1:8),TYPEXN(1:1)
00267            IF (LNG.EQ.2) WRITE(LU,99) TYPEXM(1:1),OP(1:8),TYPEXN(1:1)
00268            CALL PLANTE(1)
00269            STOP
00270         ENDIF
00271 !
00272 !-----------------------------------------------------------------------
00273 !
00274       ELSEIF(OP(1:8).EQ.'M=M+NS  ') THEN
00275 !
00276         CALL OV( 'X=X+Y   ' , DM(1,NETAGE+1) , DN , Z , C , SIZDN )
00277 !
00278         IF(TYPEXM(1:1).EQ.'Q'.AND.TYPEXN(1:1).EQ.'Q') THEN
00279 !
00280 !          CASE WHERE BOTH MATRICES ARE NONSYMMETRICAL
00281 !
00282 !          XM(K,1,1,  )  K      : TRIANGLE NUMBER
00283 !                        2      : T2 TETRAHEDRON, ONE SIDE OF WHICH IS AT THE SURFACE
00284 !                        NETAGE : LAST LAYER, THAT AT THE SURFACE
00285 !
00286            DO K = 1 , SIZXN
00287              XM(K,2,NETAGE,02) = XM(K,2,NETAGE,02) + XN(K,1)
00288              XM(K,2,NETAGE,01) = XM(K,2,NETAGE,01) + XN(K,2)
00289              XM(K,2,NETAGE,10) = XM(K,2,NETAGE,10) + XN(K,3)
00290              XM(K,2,NETAGE,08) = XM(K,2,NETAGE,08) + XN(K,4)
00291              XM(K,2,NETAGE,07) = XM(K,2,NETAGE,07) + XN(K,5)
00292              XM(K,2,NETAGE,04) = XM(K,2,NETAGE,04) + XN(K,6)
00293            ENDDO
00294 !
00295         ELSEIF(TYPEXM(1:1).EQ.'Q'.AND.TYPEXN(1:1).EQ.'S') THEN
00296 !
00297 !          CASE WHERE M CAN BE ANYTHING AND N IS SYMMETRICAL
00298 !
00299            DO K = 1 , SIZXN
00300              XM(K,2,NETAGE,02) = XM(K,2,NETAGE,02) + XN(K,1)
00301              XM(K,2,NETAGE,01) = XM(K,2,NETAGE,01) + XN(K,2)
00302              XM(K,2,NETAGE,10) = XM(K,2,NETAGE,10) + XN(K,3)
00303              XM(K,2,NETAGE,08) = XM(K,2,NETAGE,08) + XN(K,1)
00304              XM(K,2,NETAGE,07) = XM(K,2,NETAGE,07) + XN(K,2)
00305              XM(K,2,NETAGE,04) = XM(K,2,NETAGE,04) + XN(K,3)
00306            ENDDO
00307 !
00308         ELSEIF(TYPEXM(1:1).EQ.'S'.AND.TYPEXN(1:1).EQ.'S') THEN
00309 !
00310 !          CASE WHERE BOTH MATRICES ARE SYMMETRICAL
00311 !
00312            DO K = 1 , SIZXN
00313              XM(K,2,NETAGE,02) = XM(K,2,NETAGE,02) + XN(K,1)
00314              XM(K,2,NETAGE,01) = XM(K,2,NETAGE,01) + XN(K,2)
00315              XM(K,2,NETAGE,04) = XM(K,2,NETAGE,04) + XN(K,3)
00316            ENDDO
00317 !
00318         ELSE
00319            IF (LNG.EQ.1) WRITE(LU,98) TYPEXM(1:1),OP(1:8),TYPEXN(1:1)
00320            IF (LNG.EQ.2) WRITE(LU,99) TYPEXM(1:1),OP(1:8),TYPEXN(1:1)
00321            CALL PLANTE(1)
00322            STOP
00323         ENDIF
00324 !
00325 !-----------------------------------------------------------------------
00326 !
00327       ELSEIF(OP(1:8).EQ.'M=M+TNS ') THEN
00328 !
00329         CALL OV( 'X=X+Y   ' , DM(1,NETAGE+1) , DN , Z , C , SIZDN )
00330 !
00331         IF(TYPEXM(1:1).EQ.'Q'.AND.TYPEXN(1:1).EQ.'Q') THEN
00332 !
00333 !          CASE WHERE BOTH MATRICES ARE NONSYMMETRICAL
00334 !
00335            DO K = 1 , SIZXN
00336              XM(K,2,NETAGE,02) = XM(K,2,NETAGE,02) + XN(K,4)
00337              XM(K,2,NETAGE,01) = XM(K,2,NETAGE,01) + XN(K,5)
00338              XM(K,2,NETAGE,10) = XM(K,2,NETAGE,10) + XN(K,6)
00339              XM(K,2,NETAGE,08) = XM(K,2,NETAGE,08) + XN(K,1)
00340              XM(K,2,NETAGE,07) = XM(K,2,NETAGE,07) + XN(K,2)
00341              XM(K,2,NETAGE,04) = XM(K,2,NETAGE,04) + XN(K,3)
00342            ENDDO
00343 !
00344         ELSEIF(TYPEXM(1:1).EQ.'Q'.AND.TYPEXN(1:1).EQ.'S') THEN
00345 !
00346 !          CASE WHERE M CAN BE ANYTHING AND N IS SYMMETRICAL
00347 !
00348            DO K = 1 , SIZXN
00349              XM(K,2,NETAGE,02) = XM(K,2,NETAGE,02) + XN(K,1)
00350              XM(K,2,NETAGE,01) = XM(K,2,NETAGE,01) + XN(K,2)
00351              XM(K,2,NETAGE,10) = XM(K,2,NETAGE,10) + XN(K,3)
00352              XM(K,2,NETAGE,08) = XM(K,2,NETAGE,08) + XN(K,1)
00353              XM(K,2,NETAGE,07) = XM(K,2,NETAGE,07) + XN(K,2)
00354              XM(K,2,NETAGE,04) = XM(K,2,NETAGE,04) + XN(K,3)
00355            ENDDO
00356 !
00357         ELSEIF(TYPEXM(1:1).EQ.'S'.AND.TYPEXN(1:1).EQ.'S') THEN
00358 !
00359 !          CASE WHERE BOTH MATRICES ARE SYMMETRICAL
00360 !
00361            DO K = 1 , SIZXN
00362              XM(K,2,NETAGE,02) = XM(K,2,NETAGE,02) + XN(K,1)
00363              XM(K,2,NETAGE,01) = XM(K,2,NETAGE,01) + XN(K,2)
00364              XM(K,2,NETAGE,04) = XM(K,2,NETAGE,04) + XN(K,3)
00365            ENDDO
00366 !
00367         ELSE
00368            IF (LNG.EQ.1) WRITE(LU,98) TYPEXM(1:1),OP(1:8),TYPEXN(1:1)
00369            IF (LNG.EQ.2) WRITE(LU,99) TYPEXM(1:1),OP(1:8),TYPEXN(1:1)
00370            CALL PLANTE(1)
00371            STOP
00372         ENDIF
00373 !
00374 !-----------------------------------------------------------------------
00375 !
00376       ELSE
00377 !
00378         IF (LNG.EQ.1) WRITE(LU,70) OP
00379         IF (LNG.EQ.2) WRITE(LU,71) OP
00380 70      FORMAT(1X,'OM5111 (BIEF) : OPERATION INCONNUE : ',A8)
00381 71      FORMAT(1X,'OM5111 (BIEF) : UNKNOWN OPERATION : ',A8)
00382         CALL PLANTE(1)
00383         STOP
00384 !
00385       ENDIF
00386 !
00387 !-----------------------------------------------------------------------
00388 !
00389       RETURN
00390       END

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