The TELEMAC-MASCARET system  trunk
stwc2.f
Go to the documentation of this file.
1 ! ****************
2  SUBROUTINE stwc2
3 ! ****************
4 !
5  &(imin,imax,n,dir2,sdir)
6 !
7 !***********************************************************************
8 ! ARTEMIS V7P4 Nov 2017
9 !***********************************************************************
10 !
11 !brief COMPUTES THE ENERGY DENSITY BASED ON A TOMAWAC SPECTRUM.
12 !
13 !history N.DURAND (HRW)
14 !+ November 2017
15 !+ V7P4
16 !+ New. Wrapper around calls to STIRLING and LISSAGE, when linear
17 !+ interpolation (STWC1) is not sufficient
18 !
19 !history N.DURAND (HRW)
20 !+ January 2019
21 !+ V8P0
22 !+ Added USE BIEF_DEF since TYPE SPECTRUM is now defined in BIEF_DEF
23 !
24 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
25 !| IMIN |-->| DIRECTION INDEX FOR TETMIN
26 !| IMAX |-->| DIRECTION INDEX FOR TETMAX
27 !| N |-->| NUMBER OF FINER RESOLUTION POINTS
28 !| DIR2 |<--| ARTEMIS DIR COMPONENTS
29 !| SDIR |<->| ARTEMIS SPECTRUM, INTEGRATED FOR EACH DIR COMPONENT
30 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
31 !
32  USE bief_def, ONLY: spectrum
35  IMPLICIT NONE
36 !
37 !=======================================================================
38 !
39  INTEGER :: IDD,IMIN,IMAX,N
40  DOUBLE PRECISION :: SDIR(n),DIR2(n)
41  DOUBLE PRECISION,ALLOCATABLE :: SDIR2(:)
42  DOUBLE PRECISION :: DTETA2
43 !
44  INTEGER :: LISS
45  INTEGER :: IERR
46 !
47 !-----------------------------------------------------------------------
48 !
49  ALLOCATE(sdir2(n),stat=ierr)
50  CALL check_allocate(ierr,'STWC2:SDIR2')
51 !
52 !=======================================================================
53 ! TOMAWAC SPECTRUM IS GIVEN AT DISCRETE FREQUENCIES AND DIRECTIONS
54 ! THAT ARE COARSER THAN REQUIRED TO GIVE A SMOOTH ESTIMATE OF ENERGY
55 ! IN SPECTRUM
56 ! => REQUIRES INTERPOLATION (WITHIN RANGE) WITH STIRLING,
57 ! FOLLOWED BY SMOOTHING WITH LISSAGE
58 !-----------------------------------------------------------------------
59 !
60  DO idd = 1,n
61  dir2(idd) = 0.d0
62  sdir2(idd) = 0.d0
63  ENDDO
64 !
65  IF(imax.LT.imin) THEN
66  DO idd = imin,ndir
67  dir2(idd-imin+1) = s_tom%DIR(idd)-360.0d0
68  sdir2(idd-imin+1) = sdir(idd)
69  ENDDO
70  DO idd = 1,imax
71  dir2(ndir-imin+1+idd) = s_tom%DIR(idd)
72  sdir2(ndir-imin+1+idd) = sdir(idd)
73  ENDDO
74  CALL stirling( ndir-imin+1+imax, dir2, sdir2,
75  & n, dteta2, sdir )
76 !
77  ELSE
78  DO idd = imin,imax
79  dir2(idd-imin+1) = s_tom%DIR(idd)
80  sdir2(idd-imin+1) = sdir(idd)
81  ENDDO
82  CALL stirling( imax-imin+1, dir2, sdir2,
83  & n, dteta2, sdir )
84  ENDIF
85 !
86  DO idd = 1,n
87  dir2(idd) = dir2(1)+float(idd-1)*dteta2
88  ENDDO
89 !
90  DO liss = 1,250
91  CALL lissage( n, sdir, sdir2)
92  CALL ov('X=Y ', sdir, sdir2, sdir2, 0.d0, n)
93  ENDDO
94 ! DO IDD = 1,N
95 ! WRITE(LU,*) DIR2(IDD),SDIR(IDD)
96 ! ENDDO
97 !
98 !-----------------------------------------------------------------------
99 !
100  DEALLOCATE(sdir2)
101 !
102 !=======================================================================
103 !
104  RETURN
105  END
subroutine ov(OP, X, Y, Z, C, DIM1)
Definition: ov.f:7
subroutine stwc2(IMIN, IMAX, N, DIR2, SDIR)
Definition: stwc2.f:7
subroutine stirling(NI, XI, YI, NO, XOSTEP, YO)
Definition: stirling.f:7
subroutine lissage(DIM, ENTREE, SORTIE)
Definition: lissage.f:7