- Timestamp:
- 2011-10-12T19:08:14+02:00 (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2011/dev_r2802_MERCATOR9_floats/NEMOGCM/NEMO/OPA_SRC/FLO/flodom.F90
r2844 r2907 27 27 PRIVATE 28 28 29 PUBLIC flo_dom ! routine called by floats.F90 29 PUBLIC flo_dom ! routine called by floats.F90 30 PUBLIC flo_dom_alloc ! Routine called in floats.F90 30 31 31 32 CHARACTER (len=21) :: clname1 = 'init_float' ! floats initialisation filename 32 33 CHARACTER (len=21) :: clname2 = 'init_float_ariane' ! ariane floats initialisation filename 34 35 36 INTEGER , ALLOCATABLE, DIMENSION(:) :: iimfl, ijmfl, ikmfl ! index mesh of floats 37 INTEGER , ALLOCATABLE, DIMENSION(:) :: idomfl, ivtest, ihtest ! - 38 REAL(wp), ALLOCATABLE, DIMENSION(:) :: zgifl, zgjfl, zgkfl ! distances in indexes 33 39 34 40 !! * Substitutions … … 89 95 90 96 IF( ln_ariane )THEN !Add new floats with ariane convention 91 CALL add_new_ariane_floats(jpnrstflo+1,jpnfl)97 CALL flo_add_new_ariane_floats(jpnrstflo+1,jpnfl) 92 98 ELSE !Add new floats with long/lat convention 93 CALL add_new_floats(jpnrstflo+1,jpnfl)99 CALL flo_add_new_floats(jpnrstflo+1,jpnfl) 94 100 ENDIF 95 101 ENDIF … … 101 107 102 108 IF( ln_ariane )THEN !Add new floats with ariane convention 103 CALL add_new_ariane_floats(1,jpnfl)109 CALL flo_add_new_ariane_floats(1,jpnfl) 104 110 ELSE !Add new floats with long/lat convention 105 CALL add_new_floats(1,jpnfl)111 CALL flo_add_new_floats(1,jpnfl) 106 112 ENDIF 107 113 … … 110 116 END SUBROUTINE flo_dom 111 117 112 SUBROUTINE add_new_floats(kfl_start, kfl_end)118 SUBROUTINE flo_add_new_floats(kfl_start, kfl_end) 113 119 !! ------------------------------------------------------------- 114 120 !! *** SUBROUTINE add_new_arianefloats *** … … 134 140 LOGICAL :: llinmesh 135 141 CHARACTER(len=80) :: cltmp 136 137 INTEGER , DIMENSION(jpnfl) :: iimfl, ijmfl, ikmfl ! index mesh of floats138 INTEGER , DIMENSION(jpnfl) :: idomfl, ivtest, ihtest ! -139 REAL(wp), DIMENSION(jpnfl) :: zgifl, zgjfl, zgkfl140 142 !!--------------------------------------------------------------------- 141 143 ifl = kfl_end-kfl_start+1 … … 164 166 # endif 165 167 ! For each float we find the indexes of the mesh 166 CALL f indmesh(glamf(ji-1,jj-1),gphif(ji-1,jj-1), &167 glamf(ji-1,jj ),gphif(ji-1,jj ), &168 glamf(ji ,jj ),gphif(ji ,jj ), &169 glamf(ji ,jj-1),gphif(ji ,jj-1), &170 flxx(jfl) ,flyy(jfl) , &171 glamt(ji ,jj ),gphit(ji ,jj ), llinmesh)168 CALL flo_findmesh(glamf(ji-1,jj-1),gphif(ji-1,jj-1), & 169 glamf(ji-1,jj ),gphif(ji-1,jj ), & 170 glamf(ji ,jj ),gphif(ji ,jj ), & 171 glamf(ji ,jj-1),gphif(ji ,jj-1), & 172 flxx(jfl) ,flyy(jfl) , & 173 glamt(ji ,jj ),gphit(ji ,jj ), llinmesh) 172 174 IF( llinmesh )THEN 173 175 iimfl(jfl) = ji … … 231 233 ! A--------|-----D 232 234 ! 233 zdxab = dstnce( flxx(jfl), flyy(jfl), glamf(iimfl(jfl)-1,ijmfl(jfl)-1), flyy(jfl) )234 zdyad = dstnce( flxx(jfl), flyy(jfl), flxx(jfl), gphif(iimfl(jfl)-1,ijmfl(jfl)-1) )235 zdxab = flo_dstnce( flxx(jfl), flyy(jfl), glamf(iimfl(jfl)-1,ijmfl(jfl)-1), flyy(jfl) ) 236 zdyad = flo_dstnce( flxx(jfl), flyy(jfl), flxx(jfl), gphif(iimfl(jfl)-1,ijmfl(jfl)-1) ) 235 237 236 238 ! Translation of this distances (in meter) in indexes … … 277 279 ENDIF 278 280 279 END SUBROUTINE add_new_floats280 281 SUBROUTINE add_new_ariane_floats(kfl_start, kfl_end)281 END SUBROUTINE flo_add_new_floats 282 283 SUBROUTINE flo_add_new_ariane_floats(kfl_start, kfl_end) 282 284 !! ------------------------------------------------------------- 283 285 !! *** SUBROUTINE add_new_arianefloats *** … … 349 351 350 352 351 END SUBROUTINE add_new_ariane_floats352 353 354 SUBROUTINE f indmesh( pax, pay, pbx, pby, &355 pcx, pcy, pdx, pdy, &356 px ,py ,ptx, pty, ldinmesh )353 END SUBROUTINE flo_add_new_ariane_floats 354 355 356 SUBROUTINE flo_findmesh( pax, pay, pbx, pby, & 357 pcx, pcy, pdx, pdy, & 358 px ,py ,ptx, pty, ldinmesh ) 357 359 !! ------------------------------------------------------------- 358 360 !! *** ROUTINE findmesh *** … … 410 412 ENDIF 411 413 ! 412 END SUBROUTINE f indmesh413 414 415 FUNCTION dstnce( pla1, phi1, pla2, phi2 )414 END SUBROUTINE flo_findmesh 415 416 417 FUNCTION flo_dstnce( pla1, phi1, pla2, phi2 ) 416 418 !! ------------------------------------------------------------- 417 419 !! *** Function dstnce *** … … 423 425 REAL(wp), INTENT(in) :: pla1, phi1, pla2, phi2 ! ??? 424 426 !! 425 REAL(wp) :: 426 REAL(wp) :: 427 REAL(wp) :: dly1, dly2, dlx1, dlx2, dlx, dls, dld, dpi 428 REAL(wp) :: flo_dstnce 427 429 !!--------------------------------------------------------------------- 428 430 ! 429 dpi = 2. * ASIN(1.)430 dls = dpi / 180. 431 dpi = 2._wp * ASIN(1._wp) 432 dls = dpi / 180._wp 431 433 dly1 = phi1 * dls 432 434 dly2 = phi2 * dls … … 436 438 dlx = SIN(dly1) * SIN(dly2) + COS(dly1) * COS(dly2) * COS(dlx2-dlx1) 437 439 ! 438 IF( ABS(dlx) > 1.0 ) dlx = 1.0 439 ! 440 dld = ATAN(DSQRT( 1.d0 * ( 1.-dlx )/( 1.+dlx ) )) * 222.24 / dls 441 dstnce = dld * 1000. 442 ! 443 END FUNCTION dstnce 444 445 446 # else 440 IF( ABS(dlx) > 1.0_wp ) dlx = 1.0_wp 441 ! 442 dld = ATAN(DSQRT( 1._wp * ( 1._wp-dlx )/( 1._wp+dlx ) )) * 222.24_wp / dls 443 flo_dstnce = dld * 1000._wp 444 ! 445 END FUNCTION flo_dstnce 446 447 INTEGER FUNCTION flo_dom_alloc() 448 !!---------------------------------------------------------------------- 449 !! *** FUNCTION flo_dom_alloc *** 450 !!---------------------------------------------------------------------- 451 452 ALLOCATE( iimfl(jpnfl) , ijmfl(jpnfl) , ikmfl(jpnfl) , & 453 idomfl(jpnfl), ivtest(jpnfl), ihtest(jpnfl), & 454 zgifl(jpnfl) , zgjfl(jpnfl) , zgkfl(jpnfl) , STAT=flo_dom_alloc ) 455 ! 456 IF( lk_mpp ) CALL mpp_sum ( flo_dom_alloc ) 457 IF( flo_dom_alloc /= 0 ) CALL ctl_warn('flo_dom_alloc: failed to allocate arrays') 458 END FUNCTION flo_dom_alloc 459 460 461 #else 447 462 !!---------------------------------------------------------------------- 448 463 !! Default option Empty module
Note: See TracChangeset
for help on using the changeset viewer.
