The TELEMAC-MASCARET system  trunk
os.f
Go to the documentation of this file.
1 ! *************
2  SUBROUTINE os
3 ! *************
4 !
5  & ( op , x , y , z , c , iopt , infini , zero )
6 !
7 !***********************************************************************
8 ! BIEF V6P1 21/08/2010
9 !***********************************************************************
10 !
11 !brief OPERATIONS ON STRUCTURES.
12 !code
13 !+ OP IS A STRING OF 8 CHARACTERS, WHICH INDICATES THE OPERATION TO BE
14 !+ PERFORMED ON VECTORS X,Y AND Z AND CONSTANT C.
15 !+
16 !+ THE RESULT IS VECTOR X.
17 !+
18 !+ ON ARRAYS OR VECTORS :
19 !+
20 !+ OP = 'X=C ' : SETS X TO C
21 !+ OP = 'X=0 ' : SETS X TO 0
22 !+ OP = 'X=Y ' : COPIES Y IN X
23 !+ OP = 'X=+Y ' : IDEM
24 !+ OP = 'X=-Y ' : COPIES -Y IN X
25 !+ OP = 'X=1/Y ' : COPIES INVERSE OF Y IN X
26 !+ OP = 'X=Y+Z ' : ADDS Y AND Z
27 !+ OP = 'X=Y-Z ' : SUBTRACTS Z TO Y
28 !+ OP = 'X=YZ ' : Y.Z
29 !+ OP = 'X=-YZ ' : -Y.Z
30 !+ OP = 'X=XY ' : X.Y
31 !+ OP = 'X=X+YZ ' : ADDS Y.Z TO X
32 !+ OP = 'X=X-YZ ' : SUBTRACTS Y.Z FROM X
33 !+ OP = 'X=CXY ' : C.X.Y
34 !+ OP = 'X=CYZ ' : C.Y.Z
35 !+ OP = 'X=CXYZ ' : C.X.Y.Z
36 !+ OP = 'X=X+CYZ ' : ADDS C.Y.Z TO X
37 !+ OP = 'X=Y/Z ' : DIVIDES Y BY Z
38 !+ OP = 'X=CY/Z ' : DIVIDES C.Y BY Z
39 !+ OP = 'X=CXY/Z ' : DIVIDES C.X.Y BY Z
40 !+ OP = 'X=X+CY/Z' : ADDS C.Y/Z TO X
41 !+ OP = 'X=X+Y ' : ADDS Y TO X
42 !+ OP = 'X=X-Y ' : SUBTRACTS Y FROM X
43 !+ OP = 'X=CX ' : MULTIPLIES X BY C
44 !+ OP = 'X=CY ' : MULTIPLIES Y BY C
45 !+ OP = 'X=Y+CZ ' : ADDS C.Z TO Y
46 !+ OP = 'X=X+CY ' : ADDS C.Y TO X
47 !+ OP = 'X=SQR(Y)' : SQUARE ROOT OF Y
48 !+ OP = 'X=ABS(Y)' : ABSOLUTE VALUE OF Y
49 !+ OP = 'X=N(Y,Z)' : NORM OF THE VECTOR WITH COMPONENTS Y AND Z
50 !+ OP = 'X=Y+C ' : ADDS C TO Y
51 !+ OP = 'X=X+C ' : ADDS C TO X
52 !+ OP = 'X=Y**C ' : Y TO THE POWER C
53 !+ OP = 'X=COS(Y)' : COSINE OF Y
54 !+ OP = 'X=SIN(Y)' : SINE OF Y
55 !+ OP = 'X=ATN(Y)' : ARC TANGENT OF Y
56 !+ OP = 'X=A(Y,Z)' : ATAN2(Y,Z)
57 !+ OP = 'X=+(Y,C)' : MAXIMUM OF Y AND C
58 !+ OP = 'X=-(Y,C)' : MINIMUM OF Y AND C
59 !+ OP = 'X=+(Y,Z)' : MAXIMUM OF Y AND Z
60 !+ OP = 'X=-(Y,Z)' : MINIMUM OF Y AND Z
61 !+ OP = 'X=YIFZ<C' : COPIES Y IN X IF Z < C , FOR EACH POINT
62 !+ OP = 'X=C(Y-Z)' : MULTIPLIES C BY (Y-Z)
63 !
64 !warning OPERATIONS 1/Y AND Y/Z INTERNALLY TAKE CARE OF DIVISIONS
65 !+ BY 0. SUCCESSFUL EXIT OF OS IS THEREFORE NOT A PROOF THAT
66 !+ Y OR Z ARE NOT 0
67 !
68 !history J-M HERVOUET (LNHE)
69 !+ 18/08/05
70 !+ V5P6
71 !+
72 !
73 !history N.DURAND (HRW), S.E.BOURBAN (HRW)
74 !+ 13/07/2010
75 !+ V6P0
76 !+ Translation of French comments within the FORTRAN sources into
77 !+ English comments
78 !
79 !history N.DURAND (HRW), S.E.BOURBAN (HRW)
80 !+ 21/08/2010
81 !+ V6P0
82 !+ Creation of DOXYGEN tags for automated documentation and
83 !+ cross-referencing of the FORTRAN sources
84 !history R.NHEILI (Univerte de Perpignan, DALI)
85 !+ 24/02/2016
86 !+ V7P3
87 !+ ADD MODASS=3
88 !
89 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
90 !| C |-->| A GIVEN CONSTANT
91 !| INFINI |-->| PRESCRIBED VALUE IN CASE OF DIVISION BY 0.
92 !| IOPT |-->| OPTION FOR DIVISIONS BY ZERO
93 !| | | 1: NO TEST DONE (WILL CRASH IF DIVISION BY 0.).
94 !| | | 2: INFINITE TERMS REPLACED BY CONSTANT INFINI.
95 !| | | 3: STOP IF DIVISION BY ZERO.
96 !| | | 4: DIVISIONS BY 0. REPLACED BY DIVISIONS/ZERO
97 !| | | ZERO BEING AN OPTIONAL ARGUMENT
98 !| OP |-->| STRING INDICATING THE OPERATION TO BE DONE
99 !| X |<--| RESULT (A BIEF_OBJ STRUCTURE)
100 !| Y |-->| TO BE USED IN THE OPERATION
101 !| Z |-->| TO BE USED IN THE OPERATION
102 !| ZERO |-->| A THRESHOLD MINIMUM VALUE FOR DIVISIONS
103 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
104 !
105  USE bief, ex_os => os
106  USE declarations_telemac, ONLY : modass
107 !
109  IMPLICIT NONE
110 !
111 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
112 !
113 ! OPTIONAL ARGUMENTS
114 !
115  INTEGER, INTENT(IN), OPTIONAL :: IOPT
116  DOUBLE PRECISION, INTENT(IN), OPTIONAL :: INFINI
117  DOUBLE PRECISION, INTENT(IN), OPTIONAL :: ZERO
118 !
119 ! ARGUMENTS
120 !
121  TYPE(bief_obj), INTENT(INOUT), OPTIONAL, TARGET :: X
122  TYPE(bief_obj), INTENT(IN) , OPTIONAL, TARGET :: Y,Z
123  DOUBLE PRECISION, INTENT(IN) , OPTIONAL :: C
124  CHARACTER(LEN=8), INTENT(IN) :: OP
125 !
126 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
127 !
128 ! LOCAL VARIABLES
129 !
130  INTEGER IBL,TYPX,IDIM,N,NMAX
131  LOGICAL YAY,YAZ,YAC
132  TYPE(bief_obj), POINTER :: YY,ZZ
133  DOUBLE PRECISION CC
134 !
135 !-----------------------------------------------------------------------
136 !
137  typx = x%TYPE
138 !
139  yay=.false.
140  yaz=.false.
141  yac=.false.
142  IF(op(3:3).EQ.'Y'.OR.op(4:4).EQ.'Y'.OR.op(5:5).EQ.'Y'.OR.
143  & op(6:6).EQ.'Y'.OR.op(7:7).EQ.'Y'.OR.op(8:8).EQ.'Y') yay=.true.
144  IF(op(3:3).EQ.'Z'.OR.op(4:4).EQ.'Z'.OR.op(5:5).EQ.'Z'.OR.
145  & op(6:6).EQ.'Z'.OR.op(7:7).EQ.'Z'.OR.op(8:8).EQ.'Z') yaz=.true.
146 !
147 ! CHECKS THAT CONSTANT C IS IN THE REQUIRED OPERATION
148 ! I.E. IF THERE IS C IN OP, EXCEPT WHEN IT IS X=COS(Y)
149 !
150  IF((op(3:3).EQ.'C'.AND.op(4:4).NE.'O').OR.
151  & op(4:4).EQ.'C'.OR.op(5:5).EQ.'C'.OR.
152  & op(6:6).EQ.'C'.OR.op(7:7).EQ.'C'.OR.op(8:8).EQ.'C') yac=.true.
153 !
154  IF(PRESENT(c)) THEN
155  cc=c
156  ELSE
157  IF(yac) THEN
158  WRITE(lu,2) op
159 2 FORMAT(1x,'OS (BIEF) : C MISSING AND OPERATION ',a8,' ASKED')
160  CALL plante(1)
161  stop
162  ENDIF
163  ENDIF
164 !
165  IF(yay) THEN
166  IF(PRESENT(y)) THEN
167  yy=>y
168  ELSE
169  WRITE(lu,11) op
170 11 FORMAT(1x,'OS (BIEF) : Y MISSING AND OPERATION ',a8,' ASKED')
171  CALL plante(1)
172  stop
173  ENDIF
174  ELSE
175  yy=>x
176  ENDIF
177 !
178 ! OPERATION WITH Y AND Z (IF THERE IS Z THERE SHOULD BE Y)
179 !
180  IF(yaz) THEN
181 !
182  IF(PRESENT(z)) THEN
183 !
184  zz=>z
185 !
186 ! COMPARES TYPES OF Y AND Z
187 !
188  IF(.NOT.cmpobj(y,z)) THEN
189  WRITE(lu,41) y%NAME,y%ELM,z%NAME,z%ELM
190 41 FORMAT(1x,'OS (BIEF) : DIFFERENT TYPES FOR ',a6,' (',1i2,
191  & ') AND ',a6,' (',1i2,')')
192  CALL plante(1)
193  stop
194  ENDIF
195 !
196  ELSE
197 !
198  WRITE(lu,21) op
199 21 FORMAT(1x,'OS (BIEF) : Z MISSING AND OPERATION ',a8,' ASKED')
200  CALL plante(1)
201  stop
202 !
203  ENDIF
204 !
205  ELSE
206  zz=>x
207  ENDIF
208 !
209 !-----------------------------------------------------------------------
210 ! VECTORS
211 !-----------------------------------------------------------------------
212 !
213  IF(typx.EQ.2) THEN
214 !
215 ! OPERATION WITH Y : Y IS CHECKED
216 !
217  IF(yay) THEN
218 ! DIFFERENT TYPES: X THEN TAKES ITS STRUCTURE FROM Y
219  IF(.NOT.cmpobj(x,y)) CALL cpstvc(y,x)
220  ENDIF
221 !
222 ! CHECKS MEMORY
223 !
224  IF(x%DIM1.GT.x%MAXDIM1) THEN
225  WRITE(lu,101) x%NAME
226 101 FORMAT(1x,'OS (BIEF) : BEYOND ALLOWED MEMORY IN: ',a6)
227  CALL plante(1)
228  stop
229  ENDIF
230 !
231  IF(.NOT.PRESENT(iopt)) THEN
232 !
233  IF(x%DIM2.GT.1) THEN
234 !
235  DO idim = 1 , x%DIM2
236  CALL ov_2(op,x%R,idim,yy%R,idim,
237  & zz%R,idim,cc,x%MAXDIM1,x%DIM1)
238  END DO
239 !
240  ELSE
241 !
242  IF ( modass .EQ.1 .OR. modass .EQ. 2) THEN
243  CALL ov(op,x%R,yy%R,zz%R,cc,x%DIM1)
244  ELSEIF (modass .EQ. 3 .OR. modass .EQ. 4) THEN
245  CALL ov_comp(op,x%R,yy%R,zz%R,cc,x%DIM1,
246  & x%E, yy%E , zz%E)
247  ENDIF
248 !
249  ENDIF
250 !
251  ELSE
252 !
253  IF(x%DIM2.GT.1) THEN
254 !
255  DO idim = 1 , x%DIM2
256  CALL ovd_2(op,x%R,idim,yy%R,idim,zz%R,idim,cc,
257  & x%MAXDIM1,x%DIM1,iopt,infini,zero)
258  END DO
259 !
260  ELSE
261 !
262  CALL ovd(op,x%R,yy%R,zz%R,cc,x%DIM1,iopt,infini,zero)
263 !
264  ENDIF
265 !
266  ENDIF
267 !
268 !-----------------------------------------------------------------------
269 !
270  ELSEIF(typx.EQ.4) THEN
271 !
272 !-----------------------------------------------------------------------
273 ! BLOCKS
274 !-----------------------------------------------------------------------
275 !
276  DO ibl = 1 , x%N
277  IF(yay) THEN
278  IF(.NOT.cmpobj(x%ADR(ibl)%P,y%ADR(ibl)%P)) THEN
279  CALL cpstvc(y%ADR(ibl)%P,x%ADR(ibl)%P)
280  ENDIF
281  ENDIF
282 !
283 ! CHECKS MEMORY
284 !
285  n = x%ADR(ibl)%P%DIM1
286  nmax = x%ADR(ibl)%P%MAXDIM1
287  IF(n.GT.nmax) THEN
288  WRITE(lu,101) x%ADR(ibl)%P%NAME
289  WRITE(lu,201) x%NAME
290 201 FORMAT(1x,' THIS VECTOR IS IN BLOCK: ',a6)
291  CALL plante(1)
292  stop
293  ENDIF
294 !
295  IF(.NOT.PRESENT(iopt)) THEN
296 !
297  IF(x%ADR(ibl)%P%DIM2.GT.1) THEN
298 !
299  DO idim = 1 , x%ADR(ibl)%P%DIM2
300  CALL ov_2(op,x%ADR(ibl)%P%R,idim,
301  & yy%ADR(ibl)%P%R,idim,
302  & zz%ADR(ibl)%P%R,idim, cc , nmax , n )
303  END DO
304 !
305  ELSE
306 !
307  CALL ov(op,x%ADR(ibl)%P%R,
308  & yy%ADR(ibl)%P%R,
309  & zz%ADR(ibl)%P%R, cc , n )
310 !
311  ENDIF
312 !
313  ELSE
314 !
315  IF(x%ADR(ibl)%P%DIM2.GT.1) THEN
316 !
317  DO idim = 1 , x%ADR(ibl)%P%DIM2
318  CALL ovd_2(op,x%ADR(ibl)%P%R,idim,
319  & yy%ADR(ibl)%P%R,idim,
320  & zz%ADR(ibl)%P%R,idim, cc , nmax , n ,
321  & iopt,infini,zero)
322  END DO
323 !
324  ELSE
325 !
326  CALL ovd(op,x%ADR(ibl)%P%R,
327  & yy%ADR(ibl)%P%R,
328  & zz%ADR(ibl)%P%R, cc , n ,iopt,infini,zero)
329 !
330  ENDIF
331 !
332  ENDIF
333 !
334 !
335  ENDDO ! IBL
336 !
337 !-----------------------------------------------------------------------
338 !
339 ! ERROR OR OBJECT NOT TREATED
340 !
341  ELSE
342 !
343  WRITE(lu,1001) x%TYPE,x%NAME
344 1001 FORMAT(1x,'OS (BIEF): OBJECT TYPE NOT IMPLEMENTED: ',1i3,/,
345  & 1x,'NAME: ',1a6)
346  CALL plante(1)
347  stop
348 !
349  ENDIF
350 !
351 !-----------------------------------------------------------------------
352 !
353  RETURN
354  END
logical function cmpobj(OBJ1, OBJ2)
Definition: cmpobj.f:7
subroutine ov_comp(OP, X, Y, Z, C, NPOIN, X_ERR, Y_ERR, Z_ERR)
Definition: ov_comp.f:8
subroutine ov(OP, X, Y, Z, C, DIM1)
Definition: ov.f:7
subroutine ov_2(OP, X, DIMX, Y, DIMY, Z, DIMZ, C, DIM1, NPOIN)
Definition: ov_2.f:7
subroutine ovd(OP, X, Y, Z, C, NPOIN, IOPT, D, EPS)
Definition: ovd.f:7
subroutine ovd_2(OP, X, DIMX, Y, DIMY, Z, DIMZ, C, DIM1, NPOIN, IOPT, INFINI, ZERO)
Definition: ovd_2.f:8
subroutine cpstvc(X, Y)
Definition: cpstvc.f:7
subroutine os(OP, X, Y, Z, C, IOPT, INFINI, ZERO)
Definition: os.f:7
Definition: bief.f:3