os.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\utils\bief\os.f
00002 !
00113                      SUBROUTINE OS
00114 !                    *************
00115 !
00116      & ( OP , X , Y , Z , C , IOPT , INFINI , ZERO )
00117 !
00118 !***********************************************************************
00119 ! BIEF   V6P1                                   21/08/2010
00120 !***********************************************************************
00121 !
00122 !
00123 !
00124 !
00125 !
00126 !
00127 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00128 !| C              |-->| A GIVEN CONSTANT
00129 !| INFINI         |-->| PRESCRIBED VALUE IN CASE OF DIVISION BY 0.
00130 !| IOPT           |-->| OPTION FOR DIVISIONS BY ZERO
00131 !|                |   | 1: NO TEST DONE (WILL CRASH IF DIVISION BY 0.).
00132 !|                |   | 2: INFINITE TERMS REPLACED BY CONSTANT INFINI.
00133 !|                |   | 3: STOP IF DIVISION BY ZERO.
00134 !|                |   | 4: DIVISIONS BY 0. REPLACED BY DIVISIONS/ZERO
00135 !|                |   |    ZERO BEING AN OPTIONAL ARGUMENT
00136 !| OP             |-->| STRING INDICATING THE OPERATION TO BE DONE
00137 !| X              |<--| RESULT (A BIEF_OBJ STRUCTURE)
00138 !| Y              |-->| TO BE USED IN THE OPERATION
00139 !| Z              |-->| TO BE USED IN THE OPERATION
00140 !| ZERO           |-->| A THRESHOLD MINIMUM VALUE FOR DIVISIONS
00141 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00142 !
00143       USE BIEF, EX_OS => OS
00144 !
00145       IMPLICIT NONE
00146       INTEGER LNG,LU
00147       COMMON/INFO/LNG,LU
00148 !
00149 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00150 !
00151 !     OPTIONAL ARGUMENTS
00152 !
00153       INTEGER,          INTENT(IN), OPTIONAL :: IOPT
00154       DOUBLE PRECISION, INTENT(IN), OPTIONAL :: INFINI
00155       DOUBLE PRECISION, INTENT(IN), OPTIONAL :: ZERO
00156 !
00157 !     ARGUMENTS
00158 !
00159       TYPE(BIEF_OBJ),   INTENT(INOUT), OPTIONAL, TARGET :: X
00160       TYPE(BIEF_OBJ),   INTENT(IN)   , OPTIONAL, TARGET :: Y,Z
00161       DOUBLE PRECISION, INTENT(IN)   , OPTIONAL :: C
00162       CHARACTER(LEN=8), INTENT(IN)              :: OP
00163 !
00164 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00165 !
00166 !     LOCAL VARIABLES
00167 !
00168       INTEGER IBL,TYPX,IDIM,N,NMAX
00169       LOGICAL YAY,YAZ,YAC
00170       TYPE(BIEF_OBJ), POINTER :: YY,ZZ
00171       DOUBLE PRECISION CC
00172 !
00173 !-----------------------------------------------------------------------
00174 !
00175       TYPX = X%TYPE
00176 !
00177       YAY=.FALSE.
00178       YAZ=.FALSE.
00179       YAC=.FALSE.
00180       IF(OP(3:3).EQ.'Y'.OR.OP(4:4).EQ.'Y'.OR.OP(5:5).EQ.'Y'.OR.
00181      &   OP(6:6).EQ.'Y'.OR.OP(7:7).EQ.'Y'.OR.OP(8:8).EQ.'Y') YAY=.TRUE.
00182       IF(OP(3:3).EQ.'Z'.OR.OP(4:4).EQ.'Z'.OR.OP(5:5).EQ.'Z'.OR.
00183      &   OP(6:6).EQ.'Z'.OR.OP(7:7).EQ.'Z'.OR.OP(8:8).EQ.'Z') YAZ=.TRUE.
00184 !
00185 !     CHECKS THAT CONSTANT C IS IN THE REQUIRED OPERATION
00186 !     I.E. IF THERE IS C IN OP, EXCEPT WHEN IT IS X=COS(Y)
00187 !
00188       IF((OP(3:3).EQ.'C'.AND.OP(4:4).NE.'O').OR.
00189      &    OP(4:4).EQ.'C'.OR.OP(5:5).EQ.'C'.OR.
00190      &    OP(6:6).EQ.'C'.OR.OP(7:7).EQ.'C'.OR.OP(8:8).EQ.'C') YAC=.TRUE.
00191 !
00192       IF(PRESENT(C)) THEN
00193         CC=C
00194       ELSE
00195         IF(YAC) THEN
00196           IF (LNG.EQ.1) WRITE(LU,1) OP
00197           IF (LNG.EQ.2) WRITE(LU,2) OP
00198 1         FORMAT(1X,'OS (BIEF) : C ABSENT ET OPERATION ',A8,' DEMANDEE')
00199 2         FORMAT(1X,'OS (BIEF) : C MISSING AND OPERATION ',A8,' ASKED')
00200           CALL PLANTE(1)
00201           STOP
00202         ENDIF
00203       ENDIF
00204 !
00205       IF(YAY) THEN
00206         IF(PRESENT(Y)) THEN
00207           YY=>Y
00208         ELSE
00209           IF (LNG.EQ.1) WRITE(LU,10) OP
00210           IF (LNG.EQ.2) WRITE(LU,11) OP
00211 10        FORMAT(1X,'OS (BIEF) : Y ABSENT ET OPERATION ',A8,' DEMANDEE')
00212 11        FORMAT(1X,'OS (BIEF) : Y MISSING AND OPERATION ',A8,' ASKED')
00213           CALL PLANTE(1)
00214           STOP
00215         ENDIF
00216       ELSE
00217         YY=>X
00218       ENDIF
00219 !
00220 !     OPERATION WITH Y AND Z (IF THERE IS Z THERE SHOULD BE Y)
00221 !
00222       IF(YAZ) THEN
00223 !
00224         IF(PRESENT(Z)) THEN
00225 !
00226         ZZ=>Z
00227 !
00228 !       COMPARES TYPES OF Y AND Z
00229 !
00230         IF(.NOT.CMPOBJ(Y,Z)) THEN
00231           IF (LNG.EQ.1) WRITE(LU,40) Y%NAME,Y%ELM,Z%NAME,Z%ELM
00232           IF (LNG.EQ.2) WRITE(LU,41) Y%NAME,Y%ELM,Z%NAME,Z%ELM
00233 40        FORMAT(1X,'OS (BIEF) : TYPES DIFFERENTS POUR ',A6,' (',1I2,
00234      &              ') ET ',A6,' (',1I2,')')
00235 41        FORMAT(1X,'OS (BIEF) : DIFFERENT TYPES FOR ',A6,' (',1I2,
00236      &              ') AND ',A6,' (',1I2,')')
00237           CALL PLANTE(1)
00238           STOP
00239         ENDIF
00240 !
00241         ELSE
00242 !
00243           IF (LNG.EQ.1) WRITE(LU,20) OP
00244           IF (LNG.EQ.2) WRITE(LU,21) OP
00245 20        FORMAT(1X,'OS (BIEF) : Z ABSENT ET OPERATION ',A8,' DEMANDEE')
00246 21        FORMAT(1X,'OS (BIEF) : Z MISSING AND OPERATION ',A8,' ASKED')
00247           CALL PLANTE(1)
00248           STOP
00249 !
00250         ENDIF
00251 !
00252       ELSE
00253         ZZ=>X
00254       ENDIF
00255 !
00256 !-----------------------------------------------------------------------
00257 !     VECTORS
00258 !-----------------------------------------------------------------------
00259 !
00260       IF(TYPX.EQ.2) THEN
00261 !
00262 !     OPERATION WITH Y : Y IS CHECKED
00263 !
00264         IF(YAY) THEN
00265 !         DIFFERENT TYPES: X THEN TAKES ITS STRUCTURE FROM Y
00266           IF(.NOT.CMPOBJ(X,Y)) CALL CPSTVC(Y,X)
00267         ENDIF
00268 !
00269 !       CHECKS MEMORY
00270 !
00271         IF(X%DIM1.GT.X%MAXDIM1) THEN
00272           IF (LNG.EQ.1) WRITE(LU,100) X%NAME
00273           IF (LNG.EQ.2) WRITE(LU,101) X%NAME
00274 100       FORMAT(1X,'OS (BIEF) : DEPASSEMENT DE MEMOIRE SUR : ',A6)
00275 101       FORMAT(1X,'OS (BIEF) : BEYOND ALLOWED MEMORY IN: ',A6)
00276           CALL PLANTE(1)
00277           STOP
00278         ENDIF
00279 !
00280         IF(.NOT.PRESENT(IOPT)) THEN
00281 !
00282         IF(X%DIM2.GT.1) THEN
00283 !
00284           DO IDIM = 1 , X%DIM2
00285             CALL OV_2(OP,X%R,IDIM,YY%R,IDIM,
00286      &                            ZZ%R,IDIM,CC,X%MAXDIM1,X%DIM1)
00287           END DO
00288 !
00289         ELSE
00290 !
00291           CALL OV(OP,X%R,YY%R,ZZ%R,CC,X%DIM1)
00292 !
00293         ENDIF
00294 !
00295         ELSE
00296 !
00297         IF(X%DIM2.GT.1) THEN
00298 !
00299           DO IDIM = 1 , X%DIM2
00300             CALL OVD_2(OP,X%R,IDIM,YY%R,IDIM,ZZ%R,IDIM,CC,
00301      &                 X%MAXDIM1,X%DIM1,IOPT,INFINI,ZERO)
00302           END DO
00303 !
00304         ELSE
00305 !
00306           CALL OVD(OP,X%R,YY%R,ZZ%R,CC,X%DIM1,IOPT,INFINI,ZERO)
00307 !
00308         ENDIF
00309 !
00310         ENDIF
00311 !
00312 !-----------------------------------------------------------------------
00313 !
00314       ELSEIF(TYPX.EQ.4) THEN
00315 !
00316 !-----------------------------------------------------------------------
00317 !     BLOCKS
00318 !-----------------------------------------------------------------------
00319 !
00320         DO IBL = 1 , X%N
00321           IF(YAY) THEN
00322             IF(.NOT.CMPOBJ(X%ADR(IBL)%P,Y%ADR(IBL)%P)) THEN
00323               CALL CPSTVC(Y%ADR(IBL)%P,X%ADR(IBL)%P)
00324             ENDIF
00325           ENDIF
00326 !
00327 !         CHECKS MEMORY
00328 !
00329           N = X%ADR(IBL)%P%DIM1
00330           NMAX = X%ADR(IBL)%P%MAXDIM1
00331           IF(N.GT.NMAX) THEN
00332             IF (LNG.EQ.1) WRITE(LU,100) X%ADR(IBL)%P%NAME
00333             IF (LNG.EQ.2) WRITE(LU,101) X%ADR(IBL)%P%NAME
00334             IF (LNG.EQ.1) WRITE(LU,200) X%NAME
00335             IF (LNG.EQ.2) WRITE(LU,201) X%NAME
00336 200         FORMAT(1X,'            CE VECTEUR EST DANS LE BLOC : ',A6)
00337 201         FORMAT(1X,'            THIS VECTOR IS IN BLOCK: ',A6)
00338             CALL PLANTE(1)
00339             STOP
00340           ENDIF
00341 !
00342           IF(.NOT.PRESENT(IOPT)) THEN
00343 !
00344           IF(X%ADR(IBL)%P%DIM2.GT.1) THEN
00345 !
00346           DO IDIM = 1 , X%ADR(IBL)%P%DIM2
00347             CALL OV_2(OP,X%ADR(IBL)%P%R,IDIM,
00348      &                  YY%ADR(IBL)%P%R,IDIM,
00349      &                  ZZ%ADR(IBL)%P%R,IDIM, CC , NMAX , N )
00350           END DO
00351 !
00352           ELSE
00353 !
00354             CALL OV(OP,X%ADR(IBL)%P%R,
00355      &                YY%ADR(IBL)%P%R,
00356      &                ZZ%ADR(IBL)%P%R, CC , N )
00357 !
00358           ENDIF
00359 !
00360           ELSE
00361 !
00362           IF(X%ADR(IBL)%P%DIM2.GT.1) THEN
00363 !
00364           DO IDIM = 1 , X%ADR(IBL)%P%DIM2
00365             CALL OVD_2(OP,X%ADR(IBL)%P%R,IDIM,
00366      &                   YY%ADR(IBL)%P%R,IDIM,
00367      &                   ZZ%ADR(IBL)%P%R,IDIM, CC , NMAX , N ,
00368      &                   IOPT,INFINI,ZERO)
00369           END DO
00370 !
00371           ELSE
00372 !
00373             CALL OVD(OP,X%ADR(IBL)%P%R,
00374      &                 YY%ADR(IBL)%P%R,
00375      &                 ZZ%ADR(IBL)%P%R, CC , N ,IOPT,INFINI,ZERO)
00376 !
00377           ENDIF
00378 !
00379           ENDIF
00380 !
00381 !
00382         ENDDO ! IBL
00383 !
00384 !-----------------------------------------------------------------------
00385 !
00386 !     ERROR OR OBJECT NOT TREATED
00387 !
00388       ELSE
00389 !
00390         IF (LNG.EQ.1) WRITE(LU,1000) X%TYPE,X%NAME
00391         IF (LNG.EQ.2) WRITE(LU,1001) X%TYPE,X%NAME
00392 1000    FORMAT(1X,'OS (BIEF) : TYPE D''OBJET NON TRAITE: ',1I3,/,
00393      &         1X,'NOM : ',1A6)
00394 1001    FORMAT(1X,'OS (BIEF): OBJECT TYPE NOT IMPLEMENTED: ',1I3,/,
00395      &         1X,'NAME: ',1A6)
00396         CALL PLANTE(1)
00397         STOP
00398 !
00399       ENDIF
00400 !
00401 !-----------------------------------------------------------------------
00402 !
00403       RETURN
00404       END

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