os.f

Go to the documentation of this file.

!                   *************
                    SUBROUTINE os
!                   *************
!
     & ( op , x , y , z , c , iopt , infini , zero )
!
!***********************************************************************
! BIEF   V6P1                                   21/08/2010
!***********************************************************************
!
!brief    OPERATIONS ON STRUCTURES.
!code
!+   OP IS A STRING OF 8 CHARACTERS, WHICH INDICATES THE OPERATION TO BE
!+   PERFORMED ON VECTORS X,Y AND Z AND CONSTANT C.
!+
!+   THE RESULT IS VECTOR X.
!+
!+   ON ARRAYS OR VECTORS :
!+
!+   OP = 'X=C     '     :  SETS X TO C
!+   OP = 'X=0     '     :  SETS X TO 0
!+   OP = 'X=Y     '     :  COPIES Y IN X
!+   OP = 'X=+Y    '     :  IDEM
!+   OP = 'X=-Y    '     :  COPIES -Y IN X
!+   OP = 'X=1/Y   '     :  COPIES INVERSE OF Y IN X
!+   OP = 'X=Y+Z   '     :  ADDS Y AND Z
!+   OP = 'X=Y-Z   '     :  SUBTRACTS Z TO Y
!+   OP = 'X=YZ    '     :  Y.Z
!+   OP = 'X=-YZ   '     :  -Y.Z
!+   OP = 'X=XY    '     :  X.Y
!+   OP = 'X=X+YZ  '     :  ADDS Y.Z TO X
!+   OP = 'X=X-YZ  '     :  SUBTRACTS Y.Z FROM X
!+   OP = 'X=CXY   '     :  C.X.Y
!+   OP = 'X=CYZ   '     :  C.Y.Z
!+   OP = 'X=CXYZ  '     :  C.X.Y.Z
!+   OP = 'X=X+CYZ '     :  ADDS C.Y.Z TO X
!+   OP = 'X=Y/Z   '     :  DIVIDES Y BY Z
!+   OP = 'X=CY/Z  '     :  DIVIDES C.Y BY Z
!+   OP = 'X=CXY/Z '     :  DIVIDES C.X.Y BY Z
!+   OP = 'X=X+CY/Z'     :  ADDS C.Y/Z TO X
!+   OP = 'X=X+Y   '     :  ADDS Y TO X
!+   OP = 'X=X-Y   '     :  SUBTRACTS Y FROM X
!+   OP = 'X=CX    '     :  MULTIPLIES X BY C
!+   OP = 'X=CY    '     :  MULTIPLIES Y BY C
!+   OP = 'X=Y+CZ  '     :  ADDS C.Z TO Y
!+   OP = 'X=X+CY  '     :  ADDS C.Y TO X
!+   OP = 'X=SQR(Y)'     :  SQUARE ROOT OF Y
!+   OP = 'X=ABS(Y)'     :  ABSOLUTE VALUE OF Y
!+   OP = 'X=N(Y,Z)'     :  NORM OF THE VECTOR WITH COMPONENTS Y AND Z
!+   OP = 'X=Y+C   '     :  ADDS C TO Y
!+   OP = 'X=X+C   '     :  ADDS C TO X
!+   OP = 'X=Y**C  '     :  Y TO THE POWER C
!+   OP = 'X=COS(Y)'     :  COSINE OF Y
!+   OP = 'X=SIN(Y)'     :  SINE OF Y
!+   OP = 'X=ATN(Y)'     :  ARC TANGENT OF Y
!+   OP = 'X=A(Y,Z)'     :  ATAN2(Y,Z)
!+   OP = 'X=+(Y,C)'     :  MAXIMUM OF Y AND C
!+   OP = 'X=-(Y,C)'     :  MINIMUM OF Y AND C
!+   OP = 'X=+(Y,Z)'     :  MAXIMUM OF Y AND Z
!+   OP = 'X=-(Y,Z)'     :  MINIMUM OF Y AND Z
!+   OP = 'X=YIFZ<C'     :  COPIES Y IN X IF Z < C , FOR EACH POINT
!+   OP = 'X=C(Y-Z)'     :  MULTIPLIES C BY (Y-Z)
!
!warning  OPERATIONS 1/Y AND Y/Z INTERNALLY TAKE CARE OF DIVISIONS
!+            BY 0. SUCCESSFUL EXIT OF OS IS THEREFORE NOT A PROOF THAT
!+            Y OR Z ARE NOT 0
!
!history  J-M HERVOUET (LNHE)
!+        18/08/05
!+        V5P6
!+
!
!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  R.NHEILI (Univerte de Perpignan, DALI)
!+        24/02/2016
!+        V7P3
!+        ADD MODASS=3
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!| C              |-->| A GIVEN CONSTANT
!| INFINI         |-->| PRESCRIBED VALUE IN CASE OF DIVISION BY 0.
!| IOPT           |-->| OPTION FOR DIVISIONS BY ZERO
!|                |   | 1: NO TEST DONE (WILL CRASH IF DIVISION BY 0.).
!|                |   | 2: INFINITE TERMS REPLACED BY CONSTANT INFINI.
!|                |   | 3: STOP IF DIVISION BY ZERO.
!|                |   | 4: DIVISIONS BY 0. REPLACED BY DIVISIONS/ZERO
!|                |   |    ZERO BEING AN OPTIONAL ARGUMENT
!| OP             |-->| STRING INDICATING THE OPERATION TO BE DONE
!| X              |<--| RESULT (A BIEF_OBJ STRUCTURE)
!| Y              |-->| TO BE USED IN THE OPERATION
!| Z              |-->| TO BE USED IN THE OPERATION
!| ZERO           |-->| A THRESHOLD MINIMUM VALUE FOR DIVISIONS
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
      USE bief, ex_os => os
      USE declarations_telemac, ONLY : modass
!
      USE declarations_special
      IMPLICIT NONE
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
!     OPTIONAL ARGUMENTS
!
      INTEGER,          INTENT(IN), OPTIONAL :: IOPT
      DOUBLE PRECISION, INTENT(IN), OPTIONAL :: INFINI
      DOUBLE PRECISION, INTENT(IN), OPTIONAL :: ZERO
!
!     ARGUMENTS
!
      TYPE(bief_obj),   INTENT(INOUT), OPTIONAL, TARGET :: X
      TYPE(bief_obj),   INTENT(IN)   , OPTIONAL, TARGET :: Y,Z
      DOUBLE PRECISION, INTENT(IN)   , OPTIONAL :: C
      CHARACTER(LEN=8), INTENT(IN)              :: OP
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
!     LOCAL VARIABLES
!
      INTEGER IBL,TYPX,IDIM,N,NMAX
      LOGICAL YAY,YAZ,YAC
      TYPE(bief_obj), POINTER :: YY,ZZ
      DOUBLE PRECISION CC
!
!-----------------------------------------------------------------------
!
      typx = x%TYPE
!
      yay=.false.
      yaz=.false.
      yac=.false.
      IF(op(3:3).EQ.'Y'.OR.op(4:4).EQ.'Y'.OR.op(5:5).EQ.'Y'.OR.
     &   op(6:6).EQ.'Y'.OR.op(7:7).EQ.'Y'.OR.op(8:8).EQ.'Y') yay=.true.
      IF(op(3:3).EQ.'Z'.OR.op(4:4).EQ.'Z'.OR.op(5:5).EQ.'Z'.OR.
     &   op(6:6).EQ.'Z'.OR.op(7:7).EQ.'Z'.OR.op(8:8).EQ.'Z') yaz=.true.
!
!     CHECKS THAT CONSTANT C IS IN THE REQUIRED OPERATION
!     I.E. IF THERE IS C IN OP, EXCEPT WHEN IT IS X=COS(Y)
!
      IF((op(3:3).EQ.'C'.AND.op(4:4).NE.'O').OR.
     &    op(4:4).EQ.'C'.OR.op(5:5).EQ.'C'.OR.
     &    op(6:6).EQ.'C'.OR.op(7:7).EQ.'C'.OR.op(8:8).EQ.'C') yac=.true.
!
      IF(PRESENT(c)) THEN
        cc=c
      ELSE
        IF(yac) THEN
          WRITE(lu,2) op
2         FORMAT(1x,'OS (BIEF) : C MISSING AND OPERATION ',a8,' ASKED')
          CALL plante(1)
          stop
        ENDIF
      ENDIF
!
      IF(yay) THEN
        IF(PRESENT(y)) THEN
          yy=>y
        ELSE
          WRITE(lu,11) op
11        FORMAT(1x,'OS (BIEF) : Y MISSING AND OPERATION ',a8,' ASKED')
          CALL plante(1)
          stop
        ENDIF
      ELSE
        yy=>x
      ENDIF
!
!     OPERATION WITH Y AND Z (IF THERE IS Z THERE SHOULD BE Y)
!
      IF(yaz) THEN
!
        IF(PRESENT(z)) THEN
!
        zz=>z
!
!       COMPARES TYPES OF Y AND Z
!
        IF(.NOT.cmpobj(y,z)) THEN
          WRITE(lu,41) y%NAME,y%ELM,z%NAME,z%ELM
41        FORMAT(1x,'OS (BIEF) : DIFFERENT TYPES FOR ',a6,' (',1i2,
     &              ') AND ',a6,' (',1i2,')')
          CALL plante(1)
          stop
        ENDIF
!
        ELSE
!
          WRITE(lu,21) op
21        FORMAT(1x,'OS (BIEF) : Z MISSING AND OPERATION ',a8,' ASKED')
          CALL plante(1)
          stop
!
        ENDIF
!
      ELSE
        zz=>x
      ENDIF
!
!-----------------------------------------------------------------------
!     VECTORS
!-----------------------------------------------------------------------
!
      IF(typx.EQ.2) THEN
!
!     OPERATION WITH Y : Y IS CHECKED
!
        IF(yay) THEN
!         DIFFERENT TYPES: X THEN TAKES ITS STRUCTURE FROM Y
          IF(.NOT.cmpobj(x,y)) CALL cpstvc(y,x)
        ENDIF
!
!       CHECKS MEMORY
!
        IF(x%DIM1.GT.x%MAXDIM1) THEN
          WRITE(lu,101) x%NAME
101       FORMAT(1x,'OS (BIEF) : BEYOND ALLOWED MEMORY IN: ',a6)
          CALL plante(1)
          stop
        ENDIF
!
        IF(.NOT.PRESENT(iopt)) THEN
!
        IF(x%DIM2.GT.1) THEN
!
          DO idim = 1 , x%DIM2
            CALL ov_2(op,x%R,idim,yy%R,idim,
     &                            zz%R,idim,cc,x%MAXDIM1,x%DIM1)
          END DO
!
        ELSE
!
          IF ( modass .EQ.1 .OR. modass .EQ. 2) THEN
            CALL ov(op,x%R,yy%R,zz%R,cc,x%DIM1)
          ELSEIF (modass .EQ. 3 .OR. modass .EQ. 4) THEN
            CALL ov_comp(op,x%R,yy%R,zz%R,cc,x%DIM1,
     &        x%E, yy%E , zz%E)
          ENDIF
!
        ENDIF
!
        ELSE
!
        IF(x%DIM2.GT.1) THEN
!
          DO idim = 1 , x%DIM2
            CALL ovd_2(op,x%R,idim,yy%R,idim,zz%R,idim,cc,
     &                 x%MAXDIM1,x%DIM1,iopt,infini,zero)
          END DO
!
        ELSE
!
          CALL ovd(op,x%R,yy%R,zz%R,cc,x%DIM1,iopt,infini,zero)
!
        ENDIF
!
        ENDIF
!
!-----------------------------------------------------------------------
!
      ELSEIF(typx.EQ.4) THEN
!
!-----------------------------------------------------------------------
!     BLOCKS
!-----------------------------------------------------------------------
!
        DO ibl = 1 , x%N
          IF(yay) THEN
            IF(.NOT.cmpobj(x%ADR(ibl)%P,y%ADR(ibl)%P)) THEN
              CALL cpstvc(y%ADR(ibl)%P,x%ADR(ibl)%P)
            ENDIF
          ENDIF
!
!         CHECKS MEMORY
!
          n = x%ADR(ibl)%P%DIM1
          nmax = x%ADR(ibl)%P%MAXDIM1
          IF(n.GT.nmax) THEN
            WRITE(lu,101) x%ADR(ibl)%P%NAME
            WRITE(lu,201) x%NAME
201         FORMAT(1x,'            THIS VECTOR IS IN BLOCK: ',a6)
            CALL plante(1)
            stop
          ENDIF
!
          IF(.NOT.PRESENT(iopt)) THEN
!
          IF(x%ADR(ibl)%P%DIM2.GT.1) THEN
!
          DO idim = 1 , x%ADR(ibl)%P%DIM2
            CALL ov_2(op,x%ADR(ibl)%P%R,idim,
     &                  yy%ADR(ibl)%P%R,idim,
     &                  zz%ADR(ibl)%P%R,idim, cc , nmax , n )
          END DO
!
          ELSE
!
            CALL ov(op,x%ADR(ibl)%P%R,
     &                yy%ADR(ibl)%P%R,
     &                zz%ADR(ibl)%P%R, cc , n )
!
          ENDIF
!
          ELSE
!
          IF(x%ADR(ibl)%P%DIM2.GT.1) THEN
!
          DO idim = 1 , x%ADR(ibl)%P%DIM2
            CALL ovd_2(op,x%ADR(ibl)%P%R,idim,
     &                   yy%ADR(ibl)%P%R,idim,
     &                   zz%ADR(ibl)%P%R,idim, cc , nmax , n ,
     &                   iopt,infini,zero)
          END DO
!
          ELSE
!
            CALL ovd(op,x%ADR(ibl)%P%R,
     &                 yy%ADR(ibl)%P%R,
     &                 zz%ADR(ibl)%P%R, cc , n ,iopt,infini,zero)
!
          ENDIF
!
          ENDIF
!
!
        ENDDO ! IBL
!
!-----------------------------------------------------------------------
!
!     ERROR OR OBJECT NOT TREATED
!
      ELSE
!
        WRITE(lu,1001) x%TYPE,x%NAME
1001    FORMAT(1x,'OS (BIEF): OBJECT TYPE NOT IMPLEMENTED: ',1i3,/,
     &         1x,'NAME: ',1a6)
        CALL plante(1)
        stop
!
      ENDIF
!
!-----------------------------------------------------------------------
!
      RETURN
      END