Changeset 1087 for LMDZ4/branches/LMDZ4-dev/libf/dyn3d
- Timestamp:
- Feb 3, 2009, 11:00:25 AM (16 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
LMDZ4/branches/LMDZ4-dev/libf/dyn3d/groupeun.F
r524 r1087 2 2 ! $Header$ 3 3 ! 4 subroutinegroupeun(jjmax,llmax,q)5 implicit none4 SUBROUTINE groupeun(jjmax,llmax,q) 5 IMPLICIT NONE 6 6 7 7 #include "dimensions.h" … … 10 10 #include "comgeom2.h" 11 11 12 integerjjmax,llmax13 realq(iip1,jjmax,llmax)12 INTEGER jjmax,llmax 13 REAL q(iip1,jjmax,llmax) 14 14 15 integerngroup16 parameter(ngroup=3)15 INTEGER ngroup 16 PARAMETER (ngroup=3) 17 17 18 real airen,airecn,qn19 real aires,airecs,qs18 REAL airecn,qn 19 REAL airecs,qs 20 20 21 integeri,j,l,ig,j1,j2,i0,jd21 INTEGER i,j,l,ig,j1,j2,i0,jd 22 22 23 Champs 3D 23 c--------------------------------------------------------------------c 24 c Strategie d'optimisation c 25 c stocker les valeurs systematiquement recalculees c 26 c et identiques d'un pas de temps sur l'autre. Il s'agit des c 27 c aires des cellules qui sont sommees. S'il n'y a pas de changement c 28 c de grille au cours de la simulation tout devrait bien se passer. c 29 c Autre optimisation : determination des bornes entre lesquelles "j" c 30 c varie, au lieu de faire un test à chaque fois... 31 c--------------------------------------------------------------------c 32 33 INTEGER j_start, j_finish 34 35 REAL, SAVE :: airen_tab(iip1,jjp1,0:1) 36 REAL, SAVE :: aires_tab(iip1,jjp1,0:1) 37 38 LOGICAL, SAVE :: first = .TRUE. 39 40 IF (first) THEN 41 CALL INIT_GROUPEUN(airen_tab, aires_tab) 42 first = .FALSE. 43 ENDIF 44 45 c Champs 3D 24 46 jd=jjp1-jjmax 25 do l=1,llm26 j1=1+jd27 j2=228 do ig=1,ngroup29 do j=j1-jd,j2-jd30 c print*,'groupe ',ig,' j= ',j,2**(ngroup-ig+1),'pts groupes'31 do i0=1,iim,2**(ngroup-ig+1)32 airen=0.33 airecn=0.34 qn=0.35 aires=0.36 airecs=0.37 qs=0.38 do i=i0,i0+2**(ngroup-ig+1)-139 airen=airen+aire(i,j)40 aires=aires+aire(i,jjp1-j+1)41 qn=qn+q(i,j,l)42 qs=qs+q(i,jjp1-j+1-jd,l)43 enddo44 airecn=0.45 airecs=0.46 do i=i0,i0+2**(ngroup-ig+1)-147 q(i,j,l)=qn*aire(i,j)/airen48 q(i,jjp1-j+1-jd,l)=qs*aire(i,jjp1-j+1)/aires49 enddo50 enddo51 q(iip1,j,l)=q(1,j,l)52 q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l)53 enddo54 j1=j2+155 j2=j2+2**ig56 enddo57 enddo58 47 59 return 60 end 48 DO l=1,llm 49 j1=1+jd 50 j2=2 51 DO ig=1,ngroup 52 53 c Concerne le pole nord 54 j_start = j1-jd 55 j_finish = j2-jd 56 DO j=j_start, j_finish 57 DO i0=1,iim,2**(ngroup-ig+1) 58 qn=0. 59 DO i=i0,i0+2**(ngroup-ig+1)-1 60 qn=qn+q(i,j,l) 61 ENDDO 62 DO i=i0,i0+2**(ngroup-ig+1)-1 63 q(i,j,l)=qn*airen_tab(i,j,jd) 64 ENDDO 65 ENDDO 66 q(iip1,j,l)=q(1,j,l) 67 ENDDO 68 69 !c Concerne le pole sud 70 j_start = j1-jd 71 j_finish = j2-jd 72 DO j=j_start, j_finish 73 DO i0=1,iim,2**(ngroup-ig+1) 74 qs=0. 75 DO i=i0,i0+2**(ngroup-ig+1)-1 76 qs=qs+q(i,jjp1-j+1-jd,l) 77 ENDDO 78 DO i=i0,i0+2**(ngroup-ig+1)-1 79 q(i,jjp1-j+1-jd,l)=qs*aires_tab(i,jjp1-j+1,jd) 80 ENDDO 81 ENDDO 82 q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l) 83 ENDDO 84 85 j1=j2+1 86 j2=j2+2**ig 87 ENDDO 88 ENDDO 89 90 RETURN 91 END 92 93 94 95 SUBROUTINE INIT_GROUPEUN(airen_tab, aires_tab) 96 IMPLICIT NONE 97 98 #include "dimensions.h" 99 #include "paramet.h" 100 #include "comconst.h" 101 #include "comgeom2.h" 102 103 INTEGER ngroup 104 PARAMETER (ngroup=3) 105 106 REAL airen,airecn 107 REAL aires,airecs 108 109 INTEGER i,j,l,ig,j1,j2,i0,jd 110 111 INTEGER j_start, j_finish 112 113 REAL :: airen_tab(iip1,jjp1,0:1) 114 REAL :: aires_tab(iip1,jjp1,0:1) 115 116 DO jd=0, 1 117 j1=1+jd 118 j2=2 119 DO ig=1,ngroup 120 121 ! c Concerne le pole nord 122 j_start = j1-jd 123 j_finish = j2-jd 124 DO j=j_start, j_finish 125 DO i0=1,iim,2**(ngroup-ig+1) 126 airen=0. 127 DO i=i0,i0+2**(ngroup-ig+1)-1 128 airen = airen+aire(i,j) 129 ENDDO 130 DO i=i0,i0+2**(ngroup-ig+1)-1 131 airen_tab(i,j,jd) = 132 & aire(i,j) / airen 133 ENDDO 134 ENDDO 135 ENDDO 136 137 ! c Concerne le pole sud 138 j_start = j1-jd 139 j_finish = j2-jd 140 DO j=j_start, j_finish 141 DO i0=1,iim,2**(ngroup-ig+1) 142 aires=0. 143 DO i=i0,i0+2**(ngroup-ig+1)-1 144 aires=aires+aire(i,jjp1-j+1) 145 ENDDO 146 DO i=i0,i0+2**(ngroup-ig+1)-1 147 aires_tab(i,jjp1-j+1,jd) = 148 & aire(i,jjp1-j+1) / aires 149 ENDDO 150 ENDDO 151 ENDDO 152 153 j1=j2+1 154 j2=j2+2**ig 155 ENDDO 156 ENDDO 157 158 RETURN 159 END
Note: See TracChangeset
for help on using the changeset viewer.