GCC Code Coverage Report

Directory: ./
File: dyn3d_common/divergf.f
Date: 2022-01-11 19:19:34
Exec Total Coverage
Lines: 20 20 100.0%
Branches: 14 14 100.0%
Line Branch Exec Source
1 !
2 ! $Header$
3 !
4 1590 SUBROUTINE divergf(klevel,x,y,div)
5 c
6 c P. Le Van
7 c
8 c *********************************************************************
9 c ... calcule la divergence a tous les niveaux d'1 vecteur de compos.
10 c x et y...
11 c x et y etant des composantes covariantes ...
12 c *********************************************************************
13 IMPLICIT NONE
14 c
15 c x et y sont des arguments d'entree pour le s-prog
16 c div est un argument de sortie pour le s-prog
17 c
18 c
19 c ---------------------------------------------------------------------
20 c
21 c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ .
22 c
23 c ---------------------------------------------------------------------
24 !-----------------------------------------------------------------------
25 ! INCLUDE 'dimensions.h'
26 !
27 ! dimensions.h contient les dimensions du modele
28 ! ndm est tel que iim=2**ndm
29 !-----------------------------------------------------------------------
30
31 INTEGER iim,jjm,llm,ndm
32
33 PARAMETER (iim= 32,jjm=32,llm=39,ndm=1)
34
35 !-----------------------------------------------------------------------
36 !
37 ! $Header$
38 !
39 !
40 ! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
41 ! veillez n'utiliser que des ! pour les commentaires
42 ! et bien positionner les & des lignes de continuation
43 ! (les placer en colonne 6 et en colonne 73)
44 !
45 !
46 !-----------------------------------------------------------------------
47 ! INCLUDE 'paramet.h'
48
49 INTEGER iip1,iip2,iip3,jjp1,llmp1,llmp2,llmm1
50 INTEGER kftd,ip1jm,ip1jmp1,ip1jmi1,ijp1llm
51 INTEGER ijmllm,mvar
52 INTEGER jcfil,jcfllm
53
54 PARAMETER( iip1= iim+1,iip2=iim+2,iip3=iim+3 &
55 & ,jjp1=jjm+1-1/jjm)
56 PARAMETER( llmp1 = llm+1, llmp2 = llm+2, llmm1 = llm-1 )
57 PARAMETER( kftd = iim/2 -ndm )
58 PARAMETER( ip1jm = iip1*jjm, ip1jmp1= iip1*jjp1 )
59 PARAMETER( ip1jmi1= ip1jm - iip1 )
60 PARAMETER( ijp1llm= ip1jmp1 * llm, ijmllm= ip1jm * llm )
61 PARAMETER( mvar= ip1jmp1*( 2*llm+1) + ijmllm )
62 PARAMETER( jcfil=jjm/2+5, jcfllm=jcfil*llm )
63
64 !-----------------------------------------------------------------------
65 !
66 ! $Header$
67 !
68 !CDK comgeom
69 COMMON/comgeom/ &
70 & cu(ip1jmp1),cv(ip1jm),unscu2(ip1jmp1),unscv2(ip1jm), &
71 & aire(ip1jmp1),airesurg(ip1jmp1),aireu(ip1jmp1), &
72 & airev(ip1jm),unsaire(ip1jmp1),apoln,apols, &
73 & unsairez(ip1jm),airuscv2(ip1jm),airvscu2(ip1jm), &
74 & aireij1(ip1jmp1),aireij2(ip1jmp1),aireij3(ip1jmp1), &
75 & aireij4(ip1jmp1),alpha1(ip1jmp1),alpha2(ip1jmp1), &
76 & alpha3(ip1jmp1),alpha4(ip1jmp1),alpha1p2(ip1jmp1), &
77 & alpha1p4(ip1jmp1),alpha2p3(ip1jmp1),alpha3p4(ip1jmp1), &
78 & fext(ip1jm),constang(ip1jmp1),rlatu(jjp1),rlatv(jjm), &
79 & rlonu(iip1),rlonv(iip1),cuvsurcv(ip1jm),cvsurcuv(ip1jm), &
80 & cvusurcu(ip1jmp1),cusurcvu(ip1jmp1),cuvscvgam1(ip1jm), &
81 & cuvscvgam2(ip1jm),cvuscugam1(ip1jmp1), &
82 & cvuscugam2(ip1jmp1),cvscuvgam(ip1jm),cuscvugam(ip1jmp1), &
83 & unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2, &
84 & unsair_gam1(ip1jmp1),unsair_gam2(ip1jmp1),unsairz_gam(ip1jm), &
85 & aivscu2gam(ip1jm),aiuscv2gam(ip1jm),xprimu(iip1),xprimv(iip1)
86
87 !
88 REAL &
89 & cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,unsaire,apoln ,&
90 & apols,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4,&
91 & alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 ,&
92 & fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2 ,&
93 & cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1,unsapolnga2&
94 & ,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2,unsairz_gam ,&
95 & aivscu2gam ,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu,cusurcvu,xprimu&
96 & , xprimv
97 !
98 c
99 c .......... variables en arguments ...................
100 c
101 INTEGER klevel
102 REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
103 INTEGER l,ij
104 c
105 c ............... variables locales .........................
106
107 REAL aiy1( iip1 ) , aiy2( iip1 )
108 REAL sumypn,sumyps
109 c ...................................................................
110 c
111 REAL SSUM
112 c
113 c
114
2/2
✓ Branch 0 taken 56310 times.
✓ Branch 1 taken 1590 times.
 57900 DO 10 l = 1,klevel
115 c
116
2/2
✓ Branch 0 taken 57548820 times.
✓ Branch 1 taken 56310 times.
 57605130 DO ij = iip2, ip1jm - 1
117 div( ij + 1, l ) =
118 * cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) +
119 57605130 * cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l)
120 ENDDO
121 c
122 c .... correction pour div( 1,j,l) ......
123 c .... div(1,j,l)= div(iip1,j,l) ....
124 c
125 CDIR$ IVDEP
126 1745610 DO ij = iip2,ip1jm,iip1
127
2/2
✓ Branch 0 taken 1689300 times.
✓ Branch 1 taken 56310 times.
 1745610 div( ij,l ) = div( ij + iim,l )
128 ENDDO
129 c
130 c .... calcul aux poles .....
131 c
132
2/2
✓ Branch 0 taken 1801920 times.
✓ Branch 1 taken 56310 times.
 1858230 DO ij = 1,iim
133 1801920 aiy1(ij) = cuvsurcv( ij ) * y( ij , l )
134 1858230 aiy2(ij) = cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
135 ENDDO
136 56310 sumypn = SSUM ( iim,aiy1,1 ) / apoln
137 56310 sumyps = SSUM ( iim,aiy2,1 ) / apols
138 c
139
2/2
✓ Branch 0 taken 1858230 times.
✓ Branch 1 taken 56310 times.
 1914540 DO ij = 1,iip1
140 1858230 div( ij , l ) = - sumypn
141 1914540 div( ij + ip1jm, l ) = sumyps
142 ENDDO
143 1590 10 CONTINUE
144 c
145
146 1590 CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 )
147
148 c
149
2/2
✓ Branch 0 taken 56310 times.
✓ Branch 1 taken 1590 times.
 57900 DO l = 1, klevel
150
2/2
✓ Branch 0 taken 57605130 times.
✓ Branch 1 taken 56310 times.
 57663030 DO ij = iip2,ip1jm
151 57661440 div(ij,l) = div(ij,l) * unsaire(ij)
152 ENDDO
153 ENDDO
154 c
155 1590 RETURN
156 END
157