[4] | 1 | !> \file diagno-ant-0.6_mod.f90 |
---|
| 2 | !! TOOOOOOOOOOO DOOOOOOOOOOOOO |
---|
| 3 | !< |
---|
| 4 | |
---|
| 5 | !> \namespace diagno_mod |
---|
| 6 | !! TOOOOOOOOOOOOO DOOOOOOOOOOO |
---|
| 7 | !! \author Cat |
---|
| 8 | !! \date Avril 2007 |
---|
| 9 | !! @note Used module |
---|
| 10 | !! @note - use module3D_phy |
---|
| 11 | !! @note - use module_choix |
---|
| 12 | !! @note - use eq_elliptique_mod |
---|
| 13 | !< |
---|
| 14 | |
---|
| 15 | |
---|
| 16 | module diagno_mod ! mise en module Cat avril 2007 |
---|
| 17 | |
---|
| 18 | use module3D_phy |
---|
| 19 | use module_choix |
---|
| 20 | use eq_elliptique_mod |
---|
| 21 | implicit none |
---|
| 22 | |
---|
| 23 | |
---|
| 24 | |
---|
| 25 | real :: somint,test,delp,prec |
---|
| 26 | real, dimension(nx,ny) :: un |
---|
| 27 | real, dimension(nx,ny) :: epsilon |
---|
| 28 | real, dimension(nx,ny) :: uxb1 |
---|
| 29 | real, dimension(nx,ny) :: uyb1 |
---|
| 30 | |
---|
| 31 | integer :: itour_pvi |
---|
| 32 | integer :: iplus1,jplus1 |
---|
| 33 | integer :: ctvisco,iumax,jumax |
---|
| 34 | real :: delumax,errmax |
---|
| 35 | real :: phiphi,bt2,d02,discr,ttau |
---|
| 36 | character :: numvisco*1 |
---|
| 37 | real :: sf3,sf1,epsxxm,epsyym,epsm,sf01,sf03 |
---|
| 38 | real :: viscm |
---|
| 39 | |
---|
| 40 | |
---|
| 41 | logical :: stopvisco,viscolin |
---|
| 42 | logical :: test_visc |
---|
| 43 | |
---|
| 44 | contains |
---|
| 45 | !------------------------------------------------------------------------------------ |
---|
| 46 | subroutine init_diagno |
---|
| 47 | |
---|
| 48 | namelist/diagno_rheol/ sf01,sf03 |
---|
| 49 | |
---|
| 50 | ! attribution des coefficients de viscosite |
---|
| 51 | |
---|
| 52 | ! formats pour les ecritures dans 42 |
---|
| 53 | 428 format(A) |
---|
| 54 | |
---|
| 55 | ! lecture des parametres du run block draghwat |
---|
| 56 | !-------------------------------------------------------------------- |
---|
| 57 | |
---|
| 58 | rewind(num_param) ! pour revenir au debut du fichier param_list.dat |
---|
| 59 | read(num_param,diagno_rheol) |
---|
| 60 | |
---|
| 61 | write(num_rep_42,428)'!___________________________________________________________' |
---|
| 62 | write(num_rep_42,428) '&diagno_rheol ! nom du bloc diagno_rheol' |
---|
| 63 | write(num_rep_42,*) |
---|
| 64 | write(num_rep_42,*) 'sf01 = ',sf01 |
---|
| 65 | write(num_rep_42,*) 'sf03 = ',sf03 |
---|
| 66 | write(num_rep_42,*)'/' |
---|
| 67 | write(num_rep_42,428) '! coefficients par rapport a la loi glace posee ' |
---|
| 68 | write(num_rep_42,428) '! sf01 : coefficient viscosite loi lineaire ' |
---|
| 69 | write(num_rep_42,428) '! sf03 : coefficient viscosite loi n=3 ' |
---|
| 70 | write(num_rep_42,*) |
---|
| 71 | |
---|
| 72 | |
---|
| 73 | ! Precision utilisee dans de calcul |
---|
| 74 | prec = 1.e-2 |
---|
| 75 | itour_pvi=0 |
---|
| 76 | |
---|
| 77 | return |
---|
| 78 | end subroutine init_diagno |
---|
| 79 | |
---|
| 80 | !------------------------------------------------------------------------------------ |
---|
| 81 | subroutine diagnoshelf !(ifail) |
---|
| 82 | |
---|
| 83 | integer :: itest |
---|
| 84 | |
---|
| 85 | if (itracebug.eq.1) call tracebug(' Entree dans diagnoshelf') |
---|
| 86 | ! Resolution numerique des equations diagnostiques |
---|
| 87 | |
---|
| 88 | ! initialisation epsilon |
---|
| 89 | epsilon(:,:)=1.e-5 |
---|
| 90 | |
---|
| 91 | itour_pvi=itour_pvi+1 |
---|
| 92 | |
---|
| 93 | |
---|
| 94 | |
---|
| 95 | ! initialisation de un et oldu |
---|
| 96 | ! -------------------------------------- |
---|
| 97 | |
---|
| 98 | do i=1,nx-1 |
---|
| 99 | do j=1,ny-1 |
---|
| 100 | un(i,j) = sqrt(((uxbar(i,j)+uxbar(i+1,j))/2)**2 & |
---|
| 101 | + ((uybar(i,j)+uybar(i,j+1))/2.)**2) |
---|
| 102 | end do |
---|
| 103 | end do |
---|
| 104 | |
---|
| 105 | numvisco=' ' |
---|
| 106 | |
---|
| 107 | ! loi polynomiale + couplage thermomécanique |
---|
| 108 | !-------------------------------------------------------------------- |
---|
| 109 | ! les deformations sont supposées indépendantes de la profondeur |
---|
| 110 | ! et sont calculées dans strain_rate (appelé par main) |
---|
| 111 | |
---|
| 112 | ! eps(i,j) -> eps |
---|
| 113 | ! ttau -> tau (2eme invariant du deviateur des contraintes) |
---|
| 114 | ! BT2 loi en n=3, phiphi loi en n=1 calculés dans flowlaw |
---|
| 115 | ! Attention ne marche que si la loi est la loi en n=3 + n=1 |
---|
| 116 | ! |
---|
| 117 | |
---|
| 118 | pvi(:,:)=0. |
---|
| 119 | Taushelf(:,:)=0. |
---|
| 120 | |
---|
| 121 | ! La viscosité est calculée partout y compris pour la glace posée (ou elle est moins |
---|
| 122 | ! précise qu'un calcul direct avec la loi de déformation.) |
---|
| 123 | ! Pour les noeuds posés mais ayant un voisin stream ou flottant, on calcule |
---|
| 124 | ! la viscosité avec stream/shelves |
---|
| 125 | |
---|
| 126 | ! le calcul se fait sur les noeuds majeurs |
---|
| 127 | |
---|
| 128 | |
---|
| 129 | do j=1,ny |
---|
| 130 | do i=1,nx |
---|
| 131 | iplus1=min(i+1,nx) |
---|
| 132 | jplus1=min(j+1,ny) |
---|
| 133 | |
---|
| 134 | |
---|
| 135 | |
---|
| 136 | !!$ test_visc=(flot(i,j).or.flgzmx(i,j).or.flgzmx(iplus1,j).or. & |
---|
| 137 | !!$ flgzmy(i,j).or.flgzmy(i,jplus1) ) |
---|
| 138 | !!$ |
---|
| 139 | !!$ |
---|
| 140 | !!$ if (test_visc) then |
---|
| 141 | !!$ sf3=sf03 |
---|
| 142 | !!$ sf1=sf01 |
---|
| 143 | !!$ else |
---|
| 144 | !!$ sf1=1. |
---|
| 145 | !!$ sf3=1. |
---|
| 146 | !!$ endif |
---|
| 147 | |
---|
| 148 | |
---|
| 149 | if (flot(i,j)) then ! noeuds flottants |
---|
| 150 | sf3=sf03 |
---|
| 151 | sf1=sf01 |
---|
| 152 | else if (gzmx(i,j).or.gzmx(iplus1,j).or.gzmy(i,j).or.gzmy(i,jplus1)) then |
---|
| 153 | sf1=sf01 |
---|
| 154 | sf3=max(sf03,0.01) ! pour les fleuves de glace, un peu de Glen |
---|
| 155 | |
---|
| 156 | else if (ilemx(i,j).or.ilemx(iplus1,j).or.ilemy(i,j).or.ilemy(i,jplus1)) then |
---|
| 157 | sf1=sf01 |
---|
| 158 | sf3=max(sf03,0.01) ! pour les iles aussi |
---|
| 159 | else |
---|
| 160 | sf1=1 |
---|
| 161 | sf3=3 |
---|
| 162 | endif |
---|
| 163 | |
---|
| 164 | |
---|
| 165 | |
---|
| 166 | do k=1,nz |
---|
| 167 | |
---|
| 168 | |
---|
| 169 | BT2=BTT(i,j,k,1)*sf3 ! changement du sf |
---|
| 170 | phiphi=BTT(i,j,k,2)*sf1 ! changement du sf |
---|
| 171 | |
---|
| 172 | |
---|
| 173 | if (BT2.lt.1.e-25) then |
---|
| 174 | visc(i,j,k)=1./phiphi |
---|
| 175 | ttau=2.*visc(i,j,k)*eps(i,j) |
---|
| 176 | else |
---|
| 177 | |
---|
| 178 | |
---|
| 179 | ! en mettant Bt2 en facteur |
---|
| 180 | d02=eps(i,j) |
---|
| 181 | discr=((phiphi/3.)**3.)/Bt2+d02**2 |
---|
| 182 | discr=discr**0.5 |
---|
| 183 | |
---|
| 184 | ttau=(d02+discr)**(1./3.)-(discr-d02)**(1./3.) |
---|
| 185 | |
---|
| 186 | |
---|
| 187 | ttau=ttau*Bt2**(-1./3.) |
---|
| 188 | |
---|
| 189 | |
---|
| 190 | visc(i,j,k)=Bt2*ttau*ttau+phiphi |
---|
| 191 | if (visc(i,j,k).gt.1.e-15) then |
---|
| 192 | visc(i,j,k)=1./visc(i,j,k) |
---|
| 193 | else |
---|
| 194 | visc(i,j,k)=1.e15 |
---|
| 195 | endif |
---|
| 196 | endif |
---|
| 197 | pvi(i,j)=pvi(i,j)+visc(i,j,k) |
---|
| 198 | |
---|
| 199 | Taushelf(i,j)=Taushelf(i,j)+ttau |
---|
| 200 | |
---|
| 201 | end do |
---|
| 202 | |
---|
| 203 | |
---|
| 204 | |
---|
| 205 | pvi(i,j)=pvi(i,j)*H(i,j)/nz |
---|
| 206 | |
---|
| 207 | Taushelf(i,j)=Taushelf(i,j)/nz |
---|
| 208 | |
---|
| 209 | |
---|
| 210 | |
---|
| 211 | end do |
---|
| 212 | end do |
---|
| 213 | |
---|
| 214 | |
---|
| 215 | ! calcul de la viscosite integree au milieu des mailles (pvm) |
---|
| 216 | |
---|
| 217 | do i=2,nx |
---|
| 218 | do j=2,ny |
---|
| 219 | |
---|
| 220 | ! les lignes suivantes pour un pvm moyenne des pvi |
---|
| 221 | pvm(i,j)=0.25*((pvi(i,j)+pvi(i-1,j-1))+ & |
---|
| 222 | (pvi(i,j-1)+pvi(i-1,j))) |
---|
| 223 | |
---|
| 224 | |
---|
| 225 | |
---|
| 226 | ! le point ij de pvm est au milieu des points majeurs |
---|
| 227 | ! (i,j),(i-1,j),(i,j-1,i-1,j-1) |
---|
| 228 | |
---|
| 229 | ! calcul de epsm sur les noeuds pvm |
---|
| 230 | |
---|
| 231 | ! ATTENTION A l'ATTRIBUTION DES SF |
---|
| 232 | |
---|
| 233 | |
---|
| 234 | !!$ |
---|
| 235 | !!$ |
---|
| 236 | !!$ |
---|
| 237 | !!$ epsxxm=0.25*((epsxx(i,j)+epsxx(i-1,j-1))+ & |
---|
| 238 | !!$ (epsxx(i,j-1)+epsxx(i-1,j))) |
---|
| 239 | !!$ epsyym=0.25*((epsyy(i,j)+epsyy(i-1,j-1))+ & |
---|
| 240 | !!$ (epsyy(i,j-1)+epsyy(i-1,j))) |
---|
| 241 | !!$ |
---|
| 242 | !!$ epsm=epsxxm**2+epsyym**2+epsxxm*epsyym+epsxy(i,j)**2 |
---|
| 243 | !!$ epsm=epsm**0.5 |
---|
| 244 | !!$ |
---|
| 245 | !!$! |
---|
| 246 | !!$ pvm(i,j)=0. |
---|
| 247 | !!$ do k=1,nz |
---|
| 248 | !!$ BT2=((BTT(i,j,k,1)+BTT(i-1,j-1,k,1))+ & |
---|
| 249 | !!$ (BTT(i,j-1,k,1)+BTT(i-1,j,k,1)))*sf3*0.25 |
---|
| 250 | !!$ phiphi=((BTT(i,j,k,2)+BTT(i-1,j-1,k,2))+ & |
---|
| 251 | !!$ (BTT(i,j-1,k,2)+BTT(i-1,j,k,2)))*sf1*0.25 |
---|
| 252 | !!$ |
---|
| 253 | !!$ |
---|
| 254 | !!$ |
---|
| 255 | !!$! nouvelle version en mettant Bt2 en facteur et avec cas bt2=0 |
---|
| 256 | !!$ |
---|
| 257 | !!$ if (BT2.lt.1.e-25) then |
---|
| 258 | !!$ viscm=1./phiphi |
---|
| 259 | !!$ else |
---|
| 260 | !!$ |
---|
| 261 | !!$ |
---|
| 262 | !!$ d02=eps(i,j) |
---|
| 263 | !!$ discr=((phiphi/3.)**3.)/Bt2+d02**2 |
---|
| 264 | !!$ discr=discr**0.5 |
---|
| 265 | !!$ ttau=(d02+discr)**(1./3.)-(discr-d02)**(1./3.) |
---|
| 266 | !!$ ttau=ttau*Bt2**(-1./3.) |
---|
| 267 | !!$ viscm=Bt2*ttau*ttau+phiphi |
---|
| 268 | !!$ if (viscm.gt.1.e-15) then |
---|
| 269 | !!$ viscm=1./viscm |
---|
| 270 | !!$ else |
---|
| 271 | !!$ viscm=1.e15 |
---|
| 272 | !!$ endif |
---|
| 273 | !!$ endif |
---|
| 274 | !!$ |
---|
| 275 | !!$ |
---|
| 276 | !!$ pvm(i,j)=pvm(i,j)+viscm |
---|
| 277 | !!$ end do |
---|
| 278 | !!$ |
---|
| 279 | !!$ pvm(i,j)=pvm(i,j)*(Hmx(i,j)+HMX(i,j-1))/nz*0.5 |
---|
| 280 | |
---|
| 281 | |
---|
| 282 | ! pour découplage des contraintes de cisaillement horizontal. Cat 30 janvier 2005 |
---|
| 283 | ! pvm(i,j)=1.E6 ! donne n'importe quoi |
---|
| 284 | ! pvm(i,j)=pvm(i,j)/2. |
---|
| 285 | |
---|
| 286 | end do |
---|
| 287 | end do |
---|
| 288 | |
---|
| 289 | |
---|
| 290 | ! Remplissage de la matrice creuse, rearrangement et resolution: |
---|
| 291 | ! -------------------------------------------------------------- |
---|
| 292 | |
---|
| 293 | ! plus de decoupage de l'Antarctique en 4 domaines de tailles inegales |
---|
| 294 | ! selon la geographie pour eviter les iterations |
---|
| 295 | |
---|
| 296 | |
---|
| 297 | |
---|
| 298 | CALL FLOTTAB_RESCUE !test pour voir resultats avec old method |
---|
| 299 | !----------------------------------------------------------------------- |
---|
| 300 | |
---|
| 301 | !!$! -------------------------------------------------test de symetrie |
---|
| 302 | !!$call detect_assym(nx,ny,0,41,1,0,1,0,Uxbar,itest) |
---|
| 303 | !!$ |
---|
| 304 | !!$if (itest.gt.0) then |
---|
| 305 | !!$ write(6,*) 'avant remplidom asymetrie sur uxbar pour time=',time |
---|
| 306 | !!$ stop |
---|
| 307 | !!$else |
---|
| 308 | !!$! write(6,*) 'apres icethick pas d asymetrie sur H pour time=',time |
---|
| 309 | !!$end if |
---|
| 310 | ! ----------------------------------------------fin test de symetrie |
---|
| 311 | |
---|
| 312 | ! call flottab_rescue !Attention modif juillet 2007, pour test |
---|
| 313 | |
---|
| 314 | |
---|
| 315 | call remplidom(nx,ny,uxbar,uybar,uxb1,uyb1,ifail) |
---|
| 316 | |
---|
| 317 | !!$! -------------------------------------------------test de symetrie |
---|
| 318 | !!$call detect_assym(nx,ny,0,41,1,0,1,0,Uxb1,itest) |
---|
| 319 | !!$ |
---|
| 320 | !!$if (itest.gt.0) then |
---|
| 321 | !!$ write(6,*) 'apres remplidom asymetrie sur uxb1 pour time=',time |
---|
| 322 | !!$ stop |
---|
| 323 | !!$else |
---|
| 324 | !!$! write(6,*) 'apres icethick pas d asymetrie sur H pour time=',time |
---|
| 325 | !!$end if |
---|
| 326 | !!$! ----------------------------------------------fin test de symetrie |
---|
| 327 | |
---|
| 328 | |
---|
| 329 | |
---|
| 330 | |
---|
| 331 | if (ifail.gt.0) then |
---|
| 332 | print*,'call flottab_rescue at time',time |
---|
| 333 | call flottab_rescue |
---|
| 334 | call remplidom(nx,ny,uxbar,uybar,uxb1,uyb1,ifail) |
---|
| 335 | endif |
---|
| 336 | |
---|
| 337 | ! nouvelles vitesses attention les deux lignes suivants semblaient manquer |
---|
| 338 | uxbar(:,:)=uxb1(:,:) |
---|
| 339 | uybar(:,:)=uyb1(:,:) |
---|
| 340 | |
---|
| 341 | do i=2,nx-1 |
---|
| 342 | do j=2,ny-1 |
---|
| 343 | un(i,j) = sqrt(((uxbar(i,j)+uxbar(i+1,j))/2)**2 & |
---|
| 344 | + ((uybar(i,j)+uybar(i,j+1))/2.)**2) |
---|
| 345 | end do |
---|
| 346 | end do |
---|
| 347 | |
---|
| 348 | |
---|
| 349 | |
---|
| 350 | ! calcul de tobmx et tobmy (frottement basal) apres calcul des vitesses |
---|
| 351 | ! --------------------------------------------------------------------- |
---|
| 352 | do j=1,ny |
---|
| 353 | do i=1,nx |
---|
| 354 | tobmx(i,j)=-betamx(i,j)*uxbar(i,j) |
---|
| 355 | tobmy(i,j)=-betamy(i,j)*uybar(i,j) |
---|
| 356 | enddo |
---|
| 357 | enddo |
---|
| 358 | |
---|
| 359 | ! Mise ne réserve des vitesses flgzmx et flgzmy |
---|
| 360 | where (flgzmx(:,:)) |
---|
| 361 | uxflgz(:,:)=uxbar(:,:) |
---|
| 362 | elsewhere |
---|
| 363 | uxflgz(:,:)=0. |
---|
| 364 | endwhere |
---|
| 365 | |
---|
| 366 | where (flgzmy(:,:)) |
---|
| 367 | uyflgz(:,:)=uybar(:,:) |
---|
| 368 | elsewhere |
---|
| 369 | uyflgz(:,:)=0. |
---|
| 370 | endwhere |
---|
| 371 | |
---|
| 372 | |
---|
| 373 | |
---|
| 374 | return |
---|
| 375 | end subroutine diagnoshelf |
---|
| 376 | |
---|
| 377 | end module diagno_mod |
---|