- Timestamp:
- 2012-04-30T12:50:36+02:00 (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2012/dev_r3337_NOCS10_ICB/NEMOGCM/NEMO/OPA_SRC/ICB/icbutl.F90
r3370 r3372 11 11 !!---------------------------------------------------------------------- 12 12 !!---------------------------------------------------------------------- 13 !! i nterp_flds:14 !! bilin:15 !! bilin_e:13 !! icb_utl_interp : 14 !! icb_utl_bilin : 15 !! icb_utl_bilin_e : 16 16 !!---------------------------------------------------------------------- 17 17 USE par_oce ! ocean parameters … … 34 34 PRIVATE 35 35 36 PUBLIC copy_flds ! routine called in icbrun module 37 PUBLIC interp_flds ! routine called in icbdyn, icbthm modules 38 PUBLIC bilin ! routine called in icbini, icbdyn modules 39 PUBLIC bilin_x ! routine called in icbdyn module 40 PRIVATE bilin_e 41 PUBLIC add_new_berg_to_list ! routine called in icbini.F90, icbclv, icblbc and icbrst modules 42 PRIVATE insert_berg_into_list 43 PUBLIC delete_iceberg_from_list ! routine called in icblbc, icbthm modules 44 PUBLIC destroy_iceberg ! routine called in icbrun module 45 PUBLIC track_berg ! routine not currently used, retain just in case 46 PUBLIC print_berg ! routine called in icbthm module 47 PUBLIC print_bergs ! routine called in icbini, icbrun module 48 PUBLIC count_bergs ! routine called in icbdia, icbini, icblbc, icbrst modules 49 PUBLIC increment_kounter ! routine called in icbini, icbclv modules 50 PUBLIC yearday ! routine called in icbclv, icbrun module 51 PUBLIC sum_mass ! routine called in icbdia module 52 PUBLIC sum_heat ! routine called in icbdia module 53 54 PRIVATE create_iceberg 36 PUBLIC icb_utl_copy ! routine called in icbrun module 37 PUBLIC icb_utl_interp ! routine called in icbdyn, icbthm modules 38 PUBLIC icb_utl_bilin ! routine called in icbini, icbdyn modules 39 PUBLIC icb_utl_bilin_x ! routine called in icbdyn module 40 PUBLIC icb_utl_add ! routine called in icbini.F90, icbclv, icblbc and icbrst modules 41 PUBLIC icb_utl_delete ! routine called in icblbc, icbthm modules 42 PUBLIC icb_utl_destroy ! routine called in icbrun module 43 PUBLIC icb_utl_track ! routine not currently used, retain just in case 44 PUBLIC icb_utl_print_berg ! routine called in icbthm module 45 PUBLIC icb_utl_print ! routine called in icbini, icbrun module 46 PUBLIC icb_utl_count ! routine called in icbdia, icbini, icblbc, icbrst modules 47 PUBLIC icb_utl_incr ! routine called in icbini, icbclv modules 48 PUBLIC icb_utl_yearday ! routine called in icbclv, icbrun module 49 PUBLIC icb_utl_mass ! routine called in icbdia module 50 PUBLIC icb_utl_heat ! routine called in icbdia module 55 51 56 52 !!---------------------------------------------------------------------- … … 62 58 CONTAINS 63 59 64 SUBROUTINE copy_flds()65 !!---------------------------------------------------------------------- 66 !! *** ROUTINE copy_flds***60 SUBROUTINE icb_utl_copy() 61 !!---------------------------------------------------------------------- 62 !! *** ROUTINE icb_utl_copy *** 67 63 !! 68 64 !! ** Purpose : iceberg initialization. … … 109 105 CALL lbc_lnk_e( ssh_e, 'T', +1._wp, 1, 1 ) 110 106 ! 111 END SUBROUTINE copy_flds112 113 114 SUBROUTINE i nterp_flds( pi, pe1, puo, pui, pua, pssh_i, &115 & pj, pe2, pvo, pvi, pva, pssh_j, &107 END SUBROUTINE icb_utl_copy 108 109 110 SUBROUTINE icb_utl_interp( pi, pe1, puo, pui, pua, pssh_i, & 111 & pj, pe2, pvo, pvi, pva, pssh_j, & 116 112 & psst, pcn, phi, pff ) 117 113 !!---------------------------------------------------------------------- 118 !! *** ROUTINE i nterp_flds***114 !! *** ROUTINE icb_utl_interp *** 119 115 !! 120 116 !! ** Purpose : iceberg initialization. … … 138 134 !!---------------------------------------------------------------------- 139 135 140 pe1 = bilin_e( e1t, e1u, e1v, e1f, pi, pj )! scale factors141 pe2 = bilin_e( e2t, e2u, e2v, e2f, pi, pj )142 ! 143 puo = bilin( uo_e, pi, pj, 'U', 1, 1 )! ocean velocities144 pvo = bilin( vo_e, pi, pj, 'V', 1, 1 )145 psst = bilin( sst_m, pi, pj, 'T', 0, 0 )! SST146 pcn = bilin( fr_i , pi, pj, 'T', 0, 0 )! ice concentration147 pff = bilin( ff_e , pi, pj, 'F', 1, 1 )! Coriolis parameter148 ! 149 pua = bilin( ua_e , pi, pj, 'U', 1, 1 )! 10m wind150 pva = bilin( va_e , pi, pj, 'V', 1, 1 )! here (ua,va) are stress => rough conversion from stress to speed136 pe1 = icb_utl_bilin_e( e1t, e1u, e1v, e1f, pi, pj ) ! scale factors 137 pe2 = icb_utl_bilin_e( e2t, e2u, e2v, e2f, pi, pj ) 138 ! 139 puo = icb_utl_bilin( uo_e, pi, pj, 'U', 1, 1 ) ! ocean velocities 140 pvo = icb_utl_bilin( vo_e, pi, pj, 'V', 1, 1 ) 141 psst = icb_utl_bilin( sst_m, pi, pj, 'T', 0, 0 ) ! SST 142 pcn = icb_utl_bilin( fr_i , pi, pj, 'T', 0, 0 ) ! ice concentration 143 pff = icb_utl_bilin( ff_e , pi, pj, 'F', 1, 1 ) ! Coriolis parameter 144 ! 145 pua = icb_utl_bilin( ua_e , pi, pj, 'U', 1, 1 ) ! 10m wind 146 pva = icb_utl_bilin( va_e , pi, pj, 'V', 1, 1 ) ! here (ua,va) are stress => rough conversion from stress to speed 151 147 zcd = 1.22_wp * 1.5e-3_wp ! air density * drag coefficient 152 148 zmod = 1._wp / MAX( 1.e-20, SQRT( zcd * SQRT( pua*pua + pva*pva) ) ) … … 155 151 156 152 #if defined key_lim2 || defined key_lim3 157 pui = bilin( ui_e, pi, pj, 'U', 1, 1 )! sea-ice velocities158 pvi = bilin( vi_e, pi, pj, 'V', 1, 1 )159 phi = bilin( hi , pi, pj, 'T', 0, 0 )! ice thickness153 pui = icb_utl_bilin( ui_e, pi, pj, 'U', 1, 1 ) ! sea-ice velocities 154 pvi = icb_utl_bilin( vi_e, pi, pj, 'V', 1, 1 ) 155 phi = icb_utl_bilin( hi , pi, pj, 'T', 0, 0 ) ! ice thickness 160 156 #else 161 157 pui = 0._wp … … 165 161 166 162 ! Estimate SSH gradient in i- and j-direction (centred evaluation) 167 pssh_i = ( bilin( ssh_e, pi+0.1_wp, pj, 'T', 1, 1 ) - bilin( ssh_e, pi-0.1_wp, pj, 'T', 1, 1 ) ) / ( 0.2_wp * pe1 ) 168 pssh_j = ( bilin( ssh_e, pi, pj+0.1_wp, 'T', 1, 1 ) - bilin( ssh_e, pi, pj-0.1_wp, 'T', 1, 1 ) ) / ( 0.2_wp * pe2 ) 169 ! 170 END SUBROUTINE interp_flds 171 172 173 REAL(wp) FUNCTION bilin( pfld, pi, pj, cd_type, kdi, kdj ) 174 !!---------------------------------------------------------------------- 175 !! *** FUNCTION bilin *** 163 pssh_i = ( icb_utl_bilin( ssh_e, pi+0.1_wp, pj, 'T', 1, 1 ) - & 164 & icb_utl_bilin( ssh_e, pi-0.1_wp, pj, 'T', 1, 1 ) ) / ( 0.2_wp * pe1 ) 165 pssh_j = ( icb_utl_bilin( ssh_e, pi, pj+0.1_wp, 'T', 1, 1 ) - & 166 & icb_utl_bilin( ssh_e, pi, pj-0.1_wp, 'T', 1, 1 ) ) / ( 0.2_wp * pe2 ) 167 ! 168 END SUBROUTINE icb_utl_interp 169 170 171 REAL(wp) FUNCTION icb_utl_bilin( pfld, pi, pj, cd_type, kdi, kdj ) 172 !!---------------------------------------------------------------------- 173 !! *** FUNCTION icb_utl_bilin *** 176 174 !! 177 175 !! ** Purpose : bilinear interpolation at berg location depending on the grid-point type … … 220 218 ij = ij - njmpp + 1 221 219 ! 222 bilin = ( pfld(ii,ij ) * (1.-zi) + pfld(ii+1,ij ) * zi ) * (1.-zj) &223 & + ( pfld(ii,ij+1) * (1.-zi) + pfld(ii+1,ij+1) * zi ) * zj224 ! 225 END FUNCTION bilin226 227 228 REAL(wp) FUNCTION bilin_x( pfld, pi, pj )229 !!---------------------------------------------------------------------- 230 !! *** FUNCTION bilin_x ***220 icb_utl_bilin = ( pfld(ii,ij ) * (1.-zi) + pfld(ii+1,ij ) * zi ) * (1.-zj) & 221 & + ( pfld(ii,ij+1) * (1.-zi) + pfld(ii+1,ij+1) * zi ) * zj 222 ! 223 END FUNCTION icb_utl_bilin 224 225 226 REAL(wp) FUNCTION icb_utl_bilin_x( pfld, pi, pj ) 227 !!---------------------------------------------------------------------- 228 !! *** FUNCTION icb_utl_bilin_x *** 231 229 !! 232 230 !! ** Purpose : bilinear interpolation at berg location depending on the grid-point type … … 242 240 INTEGER :: ii, ij ! local integer 243 241 REAL(wp) :: zi, zj ! local real 242 REAL(wp) :: zret ! local real 244 243 REAL(wp), DIMENSION(4) :: z4 245 244 !!---------------------------------------------------------------------- … … 264 263 ENDIF 265 264 ! 266 bilin_x = (z4(1) * (1.-zi) + z4(2) * zi) * (1.-zj) + (z4(3) * (1.-zi) + z4(4) * zi) * zj 267 IF( bilin_x > 180._wp ) bilin_x = bilin_x - 360._wp 268 ! 269 END FUNCTION bilin_x 270 271 272 REAL(wp) FUNCTION bilin_e( pet, peu, pev, pef, pi, pj ) 265 zret = (z4(1) * (1.-zi) + z4(2) * zi) * (1.-zj) + (z4(3) * (1.-zi) + z4(4) * zi) * zj 266 IF( zret > 180._wp ) zret = zret - 360._wp 267 icb_utl_bilin_x = zret 268 ! 269 END FUNCTION icb_utl_bilin_x 270 271 272 REAL(wp) FUNCTION icb_utl_bilin_e( pet, peu, pev, pef, pi, pj ) 273 273 !!---------------------------------------------------------------------- 274 274 !! *** FUNCTION dom_init *** … … 336 336 ENDIF 337 337 ! 338 bilin_e = ( ze01 * (1.-zi) + ze11 * zi ) * zj &339 & + ( ze00 * (1.-zi) + ze10 * zi ) * (1.-zj)340 ! 341 END FUNCTION bilin_e342 343 344 SUBROUTINE add_new_berg_to_list( bergvals, ptvals )345 !!---------------------------------------------------------------------- 346 !! *** ROUTINE add_new_berg_to_list***338 icb_utl_bilin_e = ( ze01 * (1.-zi) + ze11 * zi ) * zj & 339 & + ( ze00 * (1.-zi) + ze10 * zi ) * (1.-zj) 340 ! 341 END FUNCTION icb_utl_bilin_e 342 343 344 SUBROUTINE icb_utl_add( bergvals, ptvals ) 345 !!---------------------------------------------------------------------- 346 !! *** ROUTINE icb_utl_add *** 347 347 !! 348 348 !! ** Purpose : add a new berg to the iceberg list … … 357 357 ! 358 358 new => NULL() 359 CALL create_iceberg( new, bergvals, ptvals )360 CALL i nsert_berg_into_list( new )359 CALL icb_utl_create( new, bergvals, ptvals ) 360 CALL icb_utl_insert( new ) 361 361 new => NULL() ! Clear new 362 362 ! 363 END SUBROUTINE add_new_berg_to_list364 365 366 SUBROUTINE create_iceberg( berg, bergvals, ptvals )367 !!---------------------------------------------------------------------- 368 !! *** ROUTINE add_new_berg_to_list***363 END SUBROUTINE icb_utl_add 364 365 366 SUBROUTINE icb_utl_create( berg, bergvals, ptvals ) 367 !!---------------------------------------------------------------------- 368 !! *** ROUTINE icb_utl_create *** 369 369 !! 370 370 !! ** Purpose : add a new berg to the iceberg list … … 380 380 !!---------------------------------------------------------------------- 381 381 ! 382 IF( ASSOCIATED(berg) ) CALL ctl_stop( 'icebergs, create_iceberg: berg already associated' )382 IF( ASSOCIATED(berg) ) CALL ctl_stop( 'icebergs, icb_utl_create: berg already associated' ) 383 383 ALLOCATE(berg, STAT=istat) 384 384 IF( istat /= 0 ) CALL ctl_stop( 'failed to allocate iceberg' ) … … 393 393 berg%current_point => pt 394 394 ! 395 END SUBROUTINE create_iceberg396 397 398 SUBROUTINE i nsert_berg_into_list( newberg )399 !!---------------------------------------------------------------------- 400 !! *** ROUTINE i nsert_berg_into_list ***395 END SUBROUTINE icb_utl_create 396 397 398 SUBROUTINE icb_utl_insert( newberg ) 399 !!---------------------------------------------------------------------- 400 !! *** ROUTINE icb_utl_insert *** 401 401 !! 402 402 !! ** Purpose : add a new berg to the iceberg list … … 422 422 ENDIF 423 423 ! 424 END SUBROUTINE i nsert_berg_into_list425 426 427 REAL(wp) FUNCTION yearday(kmon, kday, khr, kmin, ksec)428 !!---------------------------------------------------------------------- 429 !! *** FUNCTION yearday ***424 END SUBROUTINE icb_utl_insert 425 426 427 REAL(wp) FUNCTION icb_utl_yearday(kmon, kday, khr, kmin, ksec) 428 !!---------------------------------------------------------------------- 429 !! *** FUNCTION icb_utl_yearday *** 430 430 !! 431 431 !! ** Purpose : … … 442 442 !!---------------------------------------------------------------------- 443 443 ! 444 yearday = FLOAT( SUM( imonths(1:kmon) ) )445 yearday =yearday + FLOAT(kday-1) + (FLOAT(khr) + (FLOAT(kmin) + FLOAT(ksec)/60.)/60.)/24.446 ! 447 END FUNCTION yearday444 icb_utl_yearday = FLOAT( SUM( imonths(1:kmon) ) ) 445 icb_utl_yearday = icb_utl_yearday + FLOAT(kday-1) + (FLOAT(khr) + (FLOAT(kmin) + FLOAT(ksec)/60.)/60.)/24. 446 ! 447 END FUNCTION icb_utl_yearday 448 448 449 449 !!------------------------------------------------------------------------- 450 450 451 SUBROUTINE delete_iceberg_from_list( first, berg )452 !!---------------------------------------------------------------------- 453 !! *** ROUTINE delete_iceberg_from_list***451 SUBROUTINE icb_utl_delete( first, berg ) 452 !!---------------------------------------------------------------------- 453 !! *** ROUTINE icb_utl_delete *** 454 454 !! 455 455 !! ** Purpose : … … 467 467 ! 468 468 ! Bye-bye berg 469 CALL destroy_iceberg(berg)470 ! 471 END SUBROUTINE delete_iceberg_from_list472 473 474 SUBROUTINE destroy_iceberg( berg )475 !!---------------------------------------------------------------------- 476 !! *** ROUTINE destroy_iceberg***469 CALL icb_utl_destroy(berg) 470 ! 471 END SUBROUTINE icb_utl_delete 472 473 474 SUBROUTINE icb_utl_destroy( berg ) 475 !!---------------------------------------------------------------------- 476 !! *** ROUTINE icb_utl_destroy *** 477 477 !! 478 478 !! ** Purpose : … … 488 488 DEALLOCATE(berg) 489 489 ! 490 END SUBROUTINE destroy_iceberg491 492 493 SUBROUTINE track_berg( knum, cd_label, kt )494 !!---------------------------------------------------------------------- 495 !! *** ROUTINE track_berg***490 END SUBROUTINE icb_utl_destroy 491 492 493 SUBROUTINE icb_utl_track( knum, cd_label, kt ) 494 !!---------------------------------------------------------------------- 495 !! *** ROUTINE icb_utl_track *** 496 496 !! 497 497 !! ** Purpose : … … 513 513 IF( this%number(k) /= knum(k) ) match = .FALSE. 514 514 END DO 515 IF( match ) CALL print_berg(this, kt)515 IF( match ) CALL icb_utl_print_berg(this, kt) 516 516 this => this%next 517 517 END DO 518 518 ! 519 END SUBROUTINE track_berg520 521 522 SUBROUTINE print_berg( berg, kt )523 !!---------------------------------------------------------------------- 524 !! *** ROUTINE print_berg ***519 END SUBROUTINE icb_utl_track 520 521 522 SUBROUTINE icb_utl_print_berg( berg, kt ) 523 !!---------------------------------------------------------------------- 524 !! *** ROUTINE icb_utl_print_berg *** 525 525 !! 526 526 !! ** Purpose : … … 539 539 9200 FORMAT(5x,i5,2x,i10,6(2x,2f10.4)) 540 540 ! 541 END SUBROUTINE print_berg542 543 544 SUBROUTINE print_bergs( cd_label, kt )545 !!---------------------------------------------------------------------- 546 !! *** ROUTINE print_bergs***541 END SUBROUTINE icb_utl_print_berg 542 543 544 SUBROUTINE icb_utl_print( cd_label, kt ) 545 !!---------------------------------------------------------------------- 546 !! *** ROUTINE icb_utl_print *** 547 547 !! 548 548 !! ** Purpose : … … 563 563 ENDIF 564 564 DO WHILE( ASSOCIATED(this) ) 565 CALL print_berg(this, kt)565 CALL icb_utl_print_berg(this, kt) 566 566 this => this%next 567 567 END DO 568 ibergs = count_bergs()568 ibergs = icb_utl_count() 569 569 inbergs = ibergs 570 570 IF( lk_mpp ) CALL mpp_sum(inbergs) … … 572 572 & cd_label, ibergs, inbergs, narea 573 573 ! 574 END SUBROUTINE print_bergs575 576 577 SUBROUTINE i ncrement_kounter()578 !!---------------------------------------------------------------------- 579 !! *** ROUTINE i ncrement_kounter ***574 END SUBROUTINE icb_utl_print 575 576 577 SUBROUTINE icb_utl_incr() 578 !!---------------------------------------------------------------------- 579 !! *** ROUTINE icb_utl_incr *** 580 580 !! 581 581 !! ** Purpose : … … 607 607 ENDIF 608 608 ! 609 END SUBROUTINE i ncrement_kounter610 611 612 INTEGER FUNCTION count_bergs()613 !!---------------------------------------------------------------------- 614 !! *** FUNCTION count_bergs***609 END SUBROUTINE icb_utl_incr 610 611 612 INTEGER FUNCTION icb_utl_count() 613 !!---------------------------------------------------------------------- 614 !! *** FUNCTION icb_utl_count *** 615 615 !! 616 616 !! ** Purpose : … … 619 619 !!---------------------------------------------------------------------- 620 620 ! 621 count_bergs= 0621 icb_utl_count = 0 622 622 this => first_berg 623 623 DO WHILE( ASSOCIATED(this) ) 624 count_bergs = count_bergs+1624 icb_utl_count = icb_utl_count+1 625 625 this => this%next 626 626 END DO 627 627 ! 628 END FUNCTION count_bergs629 630 631 REAL(wp) FUNCTION sum_mass( first, justbits, justbergs )632 !!---------------------------------------------------------------------- 633 !! *** FUNCTION sum_mass ***628 END FUNCTION icb_utl_count 629 630 631 REAL(wp) FUNCTION icb_utl_mass( first, justbits, justbergs ) 632 !!---------------------------------------------------------------------- 633 !! *** FUNCTION icb_utl_mass *** 634 634 !! 635 635 !! ** Purpose : compute the mass all iceberg, all bergies or all bergs. … … 641 641 TYPE(iceberg), POINTER :: this 642 642 !!---------------------------------------------------------------------- 643 sum_mass = 0._wp643 icb_utl_mass = 0._wp 644 644 this => first 645 645 ! … … 647 647 DO WHILE( ASSOCIATED( this ) ) 648 648 pt => this%current_point 649 sum_mass = sum_mass + pt%mass * this%mass_scaling649 icb_utl_mass = icb_utl_mass + pt%mass * this%mass_scaling 650 650 this => this%next 651 651 END DO … … 653 653 DO WHILE( ASSOCIATED( this ) ) 654 654 pt => this%current_point 655 sum_mass = sum_mass + pt%mass_of_bits * this%mass_scaling655 icb_utl_mass = icb_utl_mass + pt%mass_of_bits * this%mass_scaling 656 656 this => this%next 657 657 END DO … … 659 659 DO WHILE( ASSOCIATED( this ) ) 660 660 pt => this%current_point 661 sum_mass = sum_mass + ( pt%mass + pt%mass_of_bits ) * this%mass_scaling661 icb_utl_mass = icb_utl_mass + ( pt%mass + pt%mass_of_bits ) * this%mass_scaling 662 662 this => this%next 663 663 END DO 664 664 ENDIF 665 665 ! 666 END FUNCTION sum_mass667 668 669 REAL(wp) FUNCTION sum_heat( first, justbits, justbergs )670 !!---------------------------------------------------------------------- 671 !! *** FUNCTION sum_heat ***666 END FUNCTION icb_utl_mass 667 668 669 REAL(wp) FUNCTION icb_utl_heat( first, justbits, justbergs ) 670 !!---------------------------------------------------------------------- 671 !! *** FUNCTION icb_utl_heat *** 672 672 !! 673 673 !! ** Purpose : compute the heat in all iceberg, all bergies or all bergs. … … 679 679 TYPE(point) , POINTER :: pt 680 680 !!---------------------------------------------------------------------- 681 sum_heat = 0._wp681 icb_utl_heat = 0._wp 682 682 this => first 683 683 ! … … 685 685 DO WHILE( ASSOCIATED( this ) ) 686 686 pt => this%current_point 687 sum_heat = sum_heat + pt%mass * this%mass_scaling * pt%heat_density687 icb_utl_heat = icb_utl_heat + pt%mass * this%mass_scaling * pt%heat_density 688 688 this => this%next 689 689 END DO … … 691 691 DO WHILE( ASSOCIATED( this ) ) 692 692 pt => this%current_point 693 sum_heat = sum_heat + pt%mass_of_bits * this%mass_scaling * pt%heat_density693 icb_utl_heat = icb_utl_heat + pt%mass_of_bits * this%mass_scaling * pt%heat_density 694 694 this => this%next 695 695 END DO … … 697 697 DO WHILE( ASSOCIATED( this ) ) 698 698 pt => this%current_point 699 sum_heat = sum_heat + ( pt%mass + pt%mass_of_bits ) * this%mass_scaling * pt%heat_density699 icb_utl_heat = icb_utl_heat + ( pt%mass + pt%mass_of_bits ) * this%mass_scaling * pt%heat_density 700 700 this => this%next 701 701 END DO 702 702 ENDIF 703 703 ! 704 END FUNCTION sum_heat704 END FUNCTION icb_utl_heat 705 705 706 706 !!======================================================================
Note: See TracChangeset
for help on using the changeset viewer.
