twcale.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\artemis\twcale.f
00002 !
00061                      SUBROUTINE TWCALE
00062 !                    *****************
00063 !      DALE,PDALE,PMAX,PMIN,TETMAX,TETMIN
00064 !
00065 !***********************************************************************
00066 ! ARTEMIS   V7P0                                  07/2014
00067 !***********************************************************************
00068 !
00069 !
00070 !
00071 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00072 !| DALE           |-->| ISO ENERGY DIRECTIONS TO BE SOLVED
00073 !| PDALE          |-->| MATRIX : FOR EACH ISO-ENERGY DIRECTION
00074 !|                               GIVES THE ISO-ENERGY FREQUENCIES
00075 !| PMAX           |-->| MAXIMUM FREQUENCY FOR SPECTRUM
00076 !| PMIN           |-->| MINIMUM FREQUENCY FOR SPECTRUM
00077 !| TETMAX         |-->| MAXIMUM DIRECTION FOR SPECTRUM
00078 !| TETMIN         |-->| MINIMUM DIRECTION FOR SPECTRUM
00079 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00080 !
00081 !
00082       USE BIEF
00083       USE DECLARATIONS_ARTEMIS
00084       USE INTERFACE_ARTEMIS, ONLY: STWC
00085 
00086       IMPLICIT NONE
00087 !
00088       INTEGER LNG,LU
00089       COMMON/INFO/LNG,LU
00090 !
00091       INTEGER NPASF,NPASD
00092       INTEGER IDALE,JPALE,ID,IFF,I,J
00093 !
00094       DOUBLE PRECISION SUMB  ,SUMICI ,DF    ,VAR,DTETA
00095       DOUBLE PRECISION FMIN  ,FMAX
00096       DOUBLE PRECISION POIDS,DEGRAD
00097       DOUBLE PRECISION SUMD
00098 !      DOUBLE PRECISION HI(1000)
00099 !
00100       DEGRAD=4D0*ATAN(1D0)/180D0
00101 !     CHECK IF TETMIN<TETMAX
00102       IF(TETMAX.LE.TETMIN) THEN
00103         WRITE(LU,*) 'ROUTINE twcale.f, tomawac spectrum discretization'
00104         WRITE(LU,*) '------ !! MAX DIRECTION < MIN DIRECTION !! ------'
00105         WRITE(LU,*) ' CHANGE MAXIMUM OR MINIMUM ANGLE OF PROPAGATION  '
00106         WRITE(LU,*) ' IN THE USER PARAMETER FILE.                     '
00107         CALL PLANTE(0)
00108       ENDIF
00109 
00110 !     CHECK IF PMIN<PMAX
00111       IF(PMAX.LE.PMIN) THEN
00112         WRITE(LU,*) 'ROUTINE twcale.f, tomawac spectrum discretization'
00113         WRITE(LU,*) '--------- !! MAX PERIOD < MIN PERIOD !! ---------'
00114         WRITE(LU,*) ' CHANGE MAXIMUM OR MINIMUM SPECTRAL PERIOD       '
00115         WRITE(LU,*) ' IN THE USER PARAMETER FILE.                     '
00116         CALL PLANTE(0)
00117       ENDIF
00118 
00119 !     MIN/MAX FREQUENCY
00120       FMIN = 1.D0 / PMAX
00121       FMAX = 1.D0 / PMIN
00122 !
00123 !     NUMBER OF INTEGRATION INTERVALS FOR THE TRAPEZOIDS METHOD : DIRECTIONS
00124       NPASD = 500*NDALE
00125 !
00126 !     NUMBER OF INTEGRATION INTERVALS FOR THE TRAPEZOIDS METHOD : FREQUENCIES
00127       NPASF = 500*NPALE
00128 !
00129 !     WIDTH OF AN INTEGRATION INTERVAL
00130       DTETA = (TETMAX-TETMIN)/FLOAT(NPASD)
00131 !
00132 !     WIDTH OF AN INTEGRATION INTERVAL
00133       DF = (FMAX-FMIN)/FLOAT(NPASF)
00134 !
00135 !     SIGNIFICANT WAVE HEIGHT INIT.
00136       HSCAL=0D0
00137 
00138 !-----------------------------------------------------------------------
00139 !     INTEGRAL OF THE SPECTRUM (trapezoidal method)
00140       SUMB = 0D0
00141       DO ID = 1,NPASD+1
00142         SUMD=0D0
00143         DO IFF = 1,NPASF+1
00144 !.......IF FREQ AND/OR DIR ON THE BOUNDARY OF THE INTEGRATION DOMAIN :  contribution/2
00145           POIDS=1D0
00146           IF ((IFF.EQ.1).OR.(IFF.EQ.NPASF+1)) THEN
00147             POIDS=POIDS/2D0
00148           ENDIF
00149           IF ((ID.EQ.1).OR.(ID.EQ.NPASD+1)) THEN
00150             POIDS=POIDS/2D0
00151           ENDIF
00152 !........
00153           VAR=STWC(FMIN+FLOAT(IFF-1)*DF,TETMIN+FLOAT(ID-1)*DTETA)
00154           SUMD = SUMD + POIDS*VAR*DF
00155         ENDDO
00156         SUMB=SUMB+SUMD*DTETA*DEGRAD
00157       ENDDO
00158 !     WRITE(6,*) 'SUM SP=',SUMB
00159 !     SIGNIFICANT WAVE HEIGHT CORRESPONDIG TO TOTAL ENERGY STORAGE
00160       HSCAL=SQRT(SUMB*16D0)
00161 !-----------------------------------------------------------------------
00162       WRITE(LU,*) '========== START SPECTRUM INTERPOLATION ==========='
00163 !     =======================================================
00164 !                          DIRECTIONS
00165 !     =======================================================
00166 !     DIVIDES THE SPECTRUM INTO 2*NDALE BANDS OF EQUAL ENERGY
00167       SUMB = SUMB/FLOAT(2*NDALE)
00168 !     WRITE(6,*) 'SUMB dir=',SUMB
00169 !
00170 !     FIRST TERM OF DIRECTION DISCRETIZATION
00171       I=1
00172       DTWC(I) = 1
00173 !
00174 !     IDENTIFIES THE ANGLES EVERY (I)*SUMB (I=1,NDALE)
00175       SUMICI = 0D0
00176 !
00177       DO ID = 1,NPASD+1
00178 !       COMPUTE INTERGAL AS ABOVE
00179 !       --------
00180         SUMD=0D0
00181         DO IFF = 1,NPASF+1
00182 !.........IF FREQ AND/OR DIR ON THE BOUNDARY OF THE INTEGRATION DOMAIN :  contribution/2
00183           POIDS=1D0
00184           IF ((IFF.EQ.1).OR.(IFF.EQ.NPASF+1)) THEN
00185             POIDS=POIDS/2D0
00186           ENDIF
00187           IF ((ID.EQ.1).OR.(ID.EQ.NPASD+1)) THEN
00188             POIDS=POIDS/2D0
00189           ENDIF
00190 !........
00191           VAR=STWC(FMIN+FLOAT(IFF-1)*DF,TETMIN+FLOAT(ID-1)*DTETA)
00192           SUMD = SUMD + POIDS*VAR*DF
00193         ENDDO
00194         SUMICI=SUMICI+SUMD*DTETA*DEGRAD
00195 !       --------
00196 !       CHECK IF SUMB/(2 NDALE) IS REACHED AND SAVE TETA
00197 !       --------
00198         IF ((SUMICI.GE.SUMB*FLOAT(I)).OR.(ID.EQ.NPASD+1)) THEN
00199           I=I+1
00200           DTWC(I) = ID
00201         ENDIF
00202 !       --------
00203       ENDDO
00204 ! NOW WE HAVE IN DTWC :
00205 !  TETMIN   T1   Ts1   T2   Ts2     ......... Tn Tmax
00206 !  TETMIN -> Ts1,Ts2... : SUMB/NDALE limit
00207 !     &      T1,T2...   : mean direction to be computed by ARTEMIS
00208 !
00209 !----------------------------------------------------------------------
00210 !     =======================================================
00211 !                          FREQUENCIES
00212 !     =======================================================
00213 !     DIVIDES THE SPECTRUM/NDALE INTO 2*NPALE BANDS OF EQUAL ENERGY
00214       SUMB = SUMB/FLOAT(NPALE)
00215 !     WRITE(6,*) 'SUMB=',SUMB
00216 !     IDENTIFIES THE FREQUENCIES EVERY (I)*SUMB (I=1,NPALE)
00217       I    =1
00218       IDALE=1
00219 !
00220 ! FOR EACH DIRECTION DOMAIN
00221   98  CONTINUE
00222       SUMICI = 0D0
00223       J=1
00224       FTWC(J) = FMIN
00225       DO IFF = 1,NPASF+1
00226 !       COMPUTE INTERGAL AS ABOVE
00227 !       --------
00228         SUMD=0D0
00229         DO ID = DTWC(I),DTWC(I+2)
00230           POIDS=1D0
00231           IF ((IFF.EQ.1).OR.(IFF.EQ.NPASF+1)) THEN
00232             POIDS=POIDS/2D0
00233           ENDIF
00234           IF ((ID.EQ.1).OR.(ID.EQ.NPASD+1)) THEN
00235             POIDS=POIDS/2D0
00236           ENDIF
00237           VAR=STWC(FMIN+FLOAT(IFF-1)*DF,TETMIN+FLOAT(ID-1)*DTETA)
00238           SUMD = SUMD + POIDS*VAR*DTETA*DEGRAD
00239         ENDDO
00240         SUMICI=SUMICI+SUMD*DF
00241 !       --------
00242 !       CHECK IF SUMB/(2 NPALE) IS REACHED AND SAVE TETA
00243 !       --------
00244         IF ((SUMICI.GE.SUMB*FLOAT(J) ).OR.(IFF.EQ.NPASF+1)) THEN
00245           J=J+1
00246           FTWC(J) = FMIN+FLOAT(IFF-1)*DF
00247 !         HI(J)=SUMICI
00248 !         WRITE(6,*) 'HI(J)=',HI(J)-HI(J-1)
00249         ENDIF
00250 !      --------
00251       ENDDO
00252 
00253 !     STOCK PERIODS IN A LINE OF PDALE
00254       DO JPALE=1,NPALE
00255         PDALE%R((IDALE-1)*NPALE+(NPALE-JPALE+1)) = 1D0/FTWC(2*JPALE)
00256       ENDDO
00257 !  NOW WE HAVE IN PDALE :
00258 !  DIRECTION1 :  T11   T12   T13  .....
00259 !  DIRECTION2 :  T21   T22   T23  .....
00260 !     .
00261 !     .
00262 !     .
00263 !  (DIRECTION i is given in DALE)
00264 !
00265 !
00266 !    GO TO NEXT DIRECTION
00267       IF (I.LE.(2*NDALE-1)) THEN
00268         DALE%R(IDALE)=TETMIN+FLOAT(DTWC(I+1)-1)*DTETA
00269         I    = I    +2
00270         IDALE= IDALE+1
00271         GOTO 98
00272       ENDIF
00273 !-----------------------------------------------------------------------
00274 !
00275       WRITE(LU,*) '=========== END SPECTRUM INTERPOLATION ============'
00276       WRITE(LU,*) '==================================================='
00277       RETURN
00278       END
00279 

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