libf/dyn3d/divgrad2.f

!
! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/divgrad2.F,v 1.1.1.1 2004/05/19 12:53:06 lmdzadmin Exp $
!
      SUBROUTINE divgrad2 ( klevel, h, deltapres, lh, divgra )
c
c     P. Le Van
c
c   ***************************************************************
c
c     .....   calcul de  (div( grad ))   de (  pext * h ) .....
c   ****************************************************************
c   h ,klevel,lh et pext  sont des arguments  d'entree pour le s-prg
c         divgra     est  un argument  de sortie pour le s-prg
c
      use dimens_m
      use paramet_m
      use comgeom
            use inidissip_m
      IMPLICIT NONE
c

c    .......    variables en arguments   .......
c
      INTEGER klevel
      REAL h( ip1jmp1,klevel ), deltapres( ip1jmp1,klevel )
      REAL divgra( ip1jmp1,klevel)
c
c    .......    variables  locales    ..........
c
      REAL     signe, nudivgrs, sqrtps( ip1jmp1,llm )
      INTEGER  l,ij,iter
      integer, intent(in):: lh
c    ...................................................................

c
      signe    = (-1.)**lh
      nudivgrs = signe * cdivh

      CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 )

c
      CALL laplacien( klevel, divgra, divgra )
     
      DO l = 1, klevel
       DO ij = 1, ip1jmp1
        sqrtps( ij,l ) = SQRT( deltapres(ij,l) )
       ENDDO
      ENDDO
c
      DO l = 1, klevel
        DO ij = 1, ip1jmp1
         divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
        ENDDO
      ENDDO
   
c    ........    Iteration de l'operateur  laplacien_gam    ........
c
      DO  iter = 1, lh - 2
       CALL laplacien_gam ( klevel,cuvscvgam2,cvuscugam2,unsair_gam2,
     *                     unsapolnga2, unsapolsga2,  divgra, divgra )
      ENDDO
c
c    ...............................................................
 
      DO l = 1, klevel
        DO ij = 1, ip1jmp1
          divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
        ENDDO
      ENDDO
c
      CALL laplacien ( klevel, divgra, divgra )
c
      DO l  = 1,klevel
      DO ij = 1,ip1jmp1
      divgra(ij,l) =  nudivgrs * divgra(ij,l) / deltapres(ij,l)
      ENDDO
      ENDDO

      RETURN
      END
1	!
2	! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/divgrad2.F,v 1.1.1.1 2004/05/19 12:53:06 lmdzadmin Exp $
3	!
4	SUBROUTINE divgrad2 ( klevel, h, deltapres, lh, divgra )
5	c
6	c P. Le Van
7	c
8	c ***************************************************************
9	c
10	c ..... calcul de (div( grad )) de ( pext * h ) .....
11	c ****************************************************************
12	c h ,klevel,lh et pext sont des arguments d'entree pour le s-prg
13	c divgra est un argument de sortie pour le s-prg
14	c
15	use dimens_m
16	use paramet_m
17	use comgeom
18	use inidissip_m
19	IMPLICIT NONE
20	c
21
22	c ....... variables en arguments .......
23	c
24	INTEGER klevel
25	REAL h( ip1jmp1,klevel ), deltapres( ip1jmp1,klevel )
26	REAL divgra( ip1jmp1,klevel)
27	c
28	c ....... variables locales ..........
29	c
30	REAL signe, nudivgrs, sqrtps( ip1jmp1,llm )
31	INTEGER l,ij,iter
32	integer, intent(in):: lh
33	c ...................................................................
34
35	c
36	signe = (-1.)**lh
37	nudivgrs = signe * cdivh
38
39	CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 )
40
41	c
42	CALL laplacien( klevel, divgra, divgra )
43
44	DO l = 1, klevel
45	DO ij = 1, ip1jmp1
46	sqrtps( ij,l ) = SQRT( deltapres(ij,l) )
47	ENDDO
48	ENDDO
49	c
50	DO l = 1, klevel
51	DO ij = 1, ip1jmp1
52	divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
53	ENDDO
54	ENDDO
55
56	c ........ Iteration de l'operateur laplacien_gam ........
57	c
58	DO iter = 1, lh - 2
59	CALL laplacien_gam ( klevel,cuvscvgam2,cvuscugam2,unsair_gam2,
60	* unsapolnga2, unsapolsga2, divgra, divgra )
61	ENDDO
62	c
63	c ...............................................................
64
65	DO l = 1, klevel
66	DO ij = 1, ip1jmp1
67	divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
68	ENDDO
69	ENDDO
70	c
71	CALL laplacien ( klevel, divgra, divgra )
72	c
73	DO l = 1,klevel
74	DO ij = 1,ip1jmp1
75	divgra(ij,l) = nudivgrs * divgra(ij,l) / deltapres(ij,l)
76	ENDDO
77	ENDDO
78
79	RETURN
80	END