- Timestamp:
- 2012-07-11T13:22:58+02:00 (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r3187 r3432 73 73 USE mod_ioclient 74 74 #endif 75 USE partition_mod ! irregular domain partitioning 76 USE timing, ONLY: timing_init, timing_finalize, timing_disable, timing_enable 77 78 !#define ARPDEBUG 75 79 76 80 IMPLICIT NONE … … 125 129 IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA 126 130 131 CALL timing_enable() 127 132 ! !-----------------------! 128 133 ! !== time stepping ==! … … 171 176 ENDIF 172 177 ! 178 CALL timing_finalize ! Timing report 179 173 180 CALL nemo_closefile 174 181 #if defined key_oasis3 || defined key_oasis4 … … 189 196 INTEGER :: ji ! dummy loop indices 190 197 INTEGER :: ilocal_comm ! local integer 191 CHARACTER(len=80), DIMENSION( 16) :: cltxt198 CHARACTER(len=80), DIMENSION(24) :: cltxt 192 199 !! 193 200 NAMELIST/namctl/ ln_ctl , nn_print, nn_ictls, nn_ictle, & … … 195 202 !!---------------------------------------------------------------------- 196 203 ! 197 cltxt = ''204 cltxt(:) = '' 198 205 ! 199 206 ! ! open Namelist file … … 228 235 lwp = (narea == 1) .OR. ln_ctl ! control of all listing output print 229 236 237 CALL timing_init ! Init timing module 238 CALL timing_disable ! but disable during startup 239 230 240 ! If dimensions of processor grid weren't specified in the namelist file 231 241 ! then we calculate them here now that we have our communicator size 232 242 IF( (jpni < 1) .OR. (jpnj < 1) )THEN 233 243 #if defined key_mpp_mpi 244 #if defined key_mpp_rkpart 245 IF( Agrif_Root() ) CALL nemo_recursive_partition(mppsize) 246 #else 234 247 IF( Agrif_Root() ) CALL nemo_partition(mppsize) 248 #endif 235 249 #else 236 250 jpni = 1 … … 244 258 ! than variables 245 259 IF( Agrif_Root() ) THEN 260 #if ! defined key_mpp_rkpart 246 261 jpi = ( jpiglo-2*jpreci + (jpni-1) ) / jpni + 2*jpreci ! first dim. 247 262 jpj = ( jpjglo-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj ! second dim. 248 jpk = jpkdta ! third dim249 263 jpim1 = jpi-1 ! inner domain indices 250 264 jpjm1 = jpj-1 ! " " 251 jpkm1 = jpk-1 ! " "252 265 jpij = jpi*jpj ! jpi x j 266 #endif 267 jpk = jpkdta ! third dim 268 jpkm1 = jpk-1 ! inner domain indices 253 269 ENDIF 254 270 … … 264 280 WRITE(numout,*) 265 281 WRITE(numout,*) 266 DO ji = 1, SIZE(cltxt )282 DO ji = 1, SIZE(cltxt,1) 267 283 IF( TRIM(cltxt(ji)) /= '' ) WRITE(numout,*) cltxt(ji) ! control print of mynode 268 284 END DO … … 282 298 283 299 ! ! Domain decomposition 300 #if defined key_mpp_rkpart 301 CALL mpp_init3 ! Remainder of set-up for 302 ! recursive partitioning 303 #else 284 304 IF( jpni*jpnj == jpnij ) THEN ; CALL mpp_init ! standard cutting out 285 305 ELSE ; CALL mpp_init2 ! eliminate land processors 286 306 ENDIF 307 #endif 287 308 ! 288 309 ! ! General initialization 310 ! CALL timing_init! Timing module 289 311 CALL phy_cst ! Physical constants 290 312 CALL eos_init ! Equation of state … … 482 504 USE trc_oce , ONLY: trc_oce_alloc 483 505 USE wrk_nemo , ONLY: wrk_alloc 506 USE exchmod , ONLY: exchmod_alloc 484 507 ! 485 508 INTEGER :: ierr … … 498 521 ierr = ierr + wrk_alloc(numout, lwp) ! workspace 499 522 ! 523 ierr = ierr + exchmod_alloc() ! New mpp msg framework 524 ! 500 525 IF( lk_mpp ) CALL mpp_sum( ierr ) 501 526 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'nemo_alloc : unable to allocate standard ocean arrays' ) … … 505 530 506 531 SUBROUTINE nemo_partition( num_pes ) 532 USE mapcomm_mod, ONLY: trimmed 507 533 !!---------------------------------------------------------------------- 508 534 !! *** ROUTINE nemo_partition *** … … 545 571 jpnij = jpni*jpnj 546 572 ! 573 574 ! Array that stores whether domain boundaries have been trimmed. Not used in 575 ! this case (regular domain decomp.) so set all to false. 576 ALLOCATE(trimmed(4,jpnij)) 577 trimmed(:,:) = .FALSE. 578 547 579 END SUBROUTINE nemo_partition 580 581 582 SUBROUTINE nemo_recursive_partition( num_pes ) 583 USE dom_oce, ONLY: ln_zco, ntopo 584 USE iom, ONLY: jpiglo, jpjglo, wp, jpdom_unknown, & 585 iom_open, iom_get, iom_close 586 USE mapcomm_mod, ONLY: ielb, ieub, pielb, pjelb, pieub, pjeub, & 587 iesub, jesub, jeub, ilbext, iubext, jubext, & 588 jlbext, pnactive, piesub, pjesub, jelb, pilbext, & 589 piubext, pjlbext, pjubext, LAND 590 USE partition_mod, ONLY: partition_rk, partition_mca_rk, imask, smooth_bathy 591 USE par_oce, ONLY: do_exchanges 592 #if defined key_mpp_mpi 593 USE mpi 594 #endif 595 !!---------------------------------------------------------------------- 596 !! *** ROUTINE nemo_recursive_partition *** 597 !! 598 !! ** Purpose : Work out a sensible factorisation of the number of 599 !! processors for the x and y dimensions. 600 !! ** Method : 601 !!---------------------------------------------------------------------- 602 IMPLICIT none 603 INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have 604 ! Local vars 605 INTEGER :: ierr ! Error flag 606 INTEGER :: inum ! temporary logical unit 607 INTEGER :: ii,jj,iproc ! Loop index 608 INTEGER :: jparray(2) ! Small array for gathering 609 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdta ! temporary data workspace 610 !!---------------------------------------------------------------------- 611 612 ! Allocate masking array (stored in partition_mod) and workspace array 613 ! for this routine 614 ALLOCATE(imask(jpiglo,jpjglo), zdta(jpiglo,jpjglo), Stat=ierr) 615 IF(ierr /= 0)THEN 616 CALL ctl_stop('nemo_recursive_partition: failed to allocate workspace arrays') 617 RETURN 618 END IF 619 620 ! Factorise the number of MPI PEs to get jpi and jpj as usual 621 CALL nemo_partition(num_pes) 622 623 ! Generate a global mask... 624 !!$#if defined ARPDEBUG 625 !!$ IF(lwp)THEN 626 !!$ WRITE(*,*) 'ARPDBG: nemo_recursive_partition: generating mask...' 627 !!$ WRITE(*,*) 'ARPDBG: nemo_recursive_partition: jp{i,j}glo = ',jpiglo,jpjglo 628 !!$ END IF 629 !!$#endif 630 631 ! ARPDBG - this is the correct variable to check but the dom_nam section 632 ! of the namelist file hasn't been read in at this stage. 633 ! IF( ntopo == 1 )THEN 634 ! open the file 635 ierr = 0 636 !!$ IF ( ln_zco ) THEN 637 !!$ ! Setting ldstop prevents ctl_stop() from being called if the file 638 !!$ ! doesn't exist 639 !!$ CALL iom_open ( 'bathy_level.nc', inum, ldstop=.FALSE. ) ! Level bathymetry 640 !!$ IF(inum > 0)CALL iom_get ( inum, jpdom_unknown, 'Bathy_level', zdta, & 641 !!$ kstart=(/jpizoom,jpjzoom/), & 642 !!$ kcount=(/jpiglo,jpjglo/) ) 643 !!$ ELSE 644 CALL iom_open ( 'bathy_meter.nc', inum, ldstop=.FALSE. ) ! Meter bathy in case of partial steps 645 IF(inum > 0)CALL iom_get ( inum, jpdom_unknown, 'Bathymetry' , zdta, & 646 kstart=(/jpizoom,jpjzoom/), & 647 kcount=(/jpiglo,jpjglo/) ) 648 !!$ ENDIF 649 IF(inum > 0)THEN 650 CALL iom_close (inum) 651 ELSE 652 ! Flag that an error occurred when reading the file 653 ierr = 1 654 ENDIF 655 ! ELSE 656 ! ! Topography not read from file in this case 657 ! ierr = 1 658 ! END IF 659 660 ! If ln_sco defined then the bathymetry gets smoothed before the 661 ! simulation begins and that process can alter the coastlines 662 ! therefore we do it here too before calculating our mask. 663 ! IF(ln_sco) 664 CALL smooth_bathy(zdta) 665 666 ! land/sea mask (zero on land, 1 otherwise) over the global/zoom domain 667 imask(:,:)=1 668 IF(ierr == 1)THEN 669 ! Failed to read bathymetry so assume all ocean 670 WRITE(*,*) 'ARPDBG: nemo_recursive_partition: no bathymetry file so setting mask to unity' 671 672 ! Mess with otherwise uniform mask to get an irregular decomposition 673 ! for testing ARPDBG 674 CALL generate_fake_land(imask) 675 ELSE 676 ! Comment-out line below to achieve a regular partition 677 WHERE ( zdta(:,:) <= 1.0E-20 ) imask = LAND 678 END IF 679 680 ! Allocate partitioning arrays. 681 682 IF ( .not.allocated(pielb) ) THEN 683 ALLOCATE (pielb(num_pes), pieub(num_pes), piesub(num_pes), & 684 pilbext(num_pes), piubext(num_pes), & 685 pjelb(num_pes), pjeub(num_pes), pjesub(num_pes), & 686 pjlbext(num_pes), pjubext(num_pes), pnactive(num_pes), & 687 Stat = ierr) 688 IF(ierr /= 0)THEN 689 CALL ctl_stop('STOP', & 690 'nemo_recursive_partition: failed to allocate partitioning arrays') 691 RETURN 692 END IF 693 ENDIF 694 695 ! Now we can do recursive k-section partitioning 696 ! ARPDBG - BUG if limits on array below are set to anything other than 697 ! 1 and jp{i,j}glo then check for external boundaries in a few lines 698 ! time WILL FAIL! 699 ! CALL partition_rk ( imask, 1, jpiglo, 1, jpjglo, ierr ) 700 701 ! Multi-core aware version of recursive k-section partitioning 702 CALL partition_mca_rk ( imask, 1, jpiglo, 1, jpjglo, ierr ) 703 704 ! Check the error code from partitioning. 705 IF ( ierr /= 0 ) THEN 706 CALL ctl_stop('STOP','nemo_recursive_partition: Partitioning failed') 707 RETURN 708 ENDIF 709 710 ! Set the mask correctly now we've partitioned 711 !WHERE ( zdta(:,:) <= 0. ) imask = 0 712 713 ! ARPDBG Quick and dirty dump to stdout in gnuplot form 714 !!$ IF(narea == 1)THEN 715 !!$ OPEN(UNIT=998, FILE="imask.dat", & 716 !!$ STATUS='REPLACE', ACTION='WRITE', IOSTAT=jj) 717 !!$ IF( jj == 0 )THEN 718 !!$ WRITE (998,*) '# Depth map' 719 !!$ DO jj = 1, jpjglo, 1 720 !!$ DO ii = 1, jpiglo, 1 721 !!$ WRITE (998,*) ii, jj, zdta(ii,jj) ! imask(ii,jj) 722 !!$ END DO 723 !!$ WRITE (998,*) 724 !!$ END DO 725 !!$ CLOSE(998) 726 !!$ END IF 727 !!$ END IF 728 729 jpkm1 = jpk - 1 730 731 ! This chunk taken directly from original mpp_ini - not sure why nbondi 732 ! is reset? However, if it isn't reset then bad things happen in dommsk 733 ! so I'm doing what the original code does... 734 nperio = 0 735 nbondi = 0 736 IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 ) THEN 737 IF( jpni == 1 )THEN 738 nbondi = 2 739 nperio = 1 740 END IF 741 END IF 742 743 #if defined ARPDEBUG 744 WRITE (*,FMT="(I4,' : ARPDBG: ielb, ieub, iesub = ',3I5)") narea-1,& 745 ielb, ieub, iesub 746 WRITE (*,FMT="(I4,' : ARPDBG: jelb, jeub, jesub = ',3I5)") narea-1,& 747 jelb, jeub, jesub 748 WRITE (*,FMT="(I4,' : ARPDBG: nldi, nlei, nlci = ',3I5)") narea-1, & 749 nldi, nlei, nlci 750 WRITE (*,FMT="(I4,' : ARPDBG: nldj, nlej, nlcj = ',3I5)") narea-1, & 751 nldj, nlej, nlcj 752 WRITE (*,FMT="(I4,' : ARPDBG: jpi, jpj = ',2I5)") narea-1, jpi, jpj 753 WRITE (*,FMT="(I4,' : ARPDBG: nimpp, njmpp = ',2I5)") narea-1, & 754 nimpp, njmpp 755 #endif 756 757 ! Debugging option - can turn off all halo exchanges by setting this to 758 ! false. 759 do_exchanges = .TRUE. 760 761 END SUBROUTINE nemo_recursive_partition 762 548 763 549 764 SUBROUTINE sqfact ( kn, kna, knb ) … … 565 780 566 781 fact_loop: DO kna=SQRT(REAL(kn)),1,-1 567 IF ( kn/kna*kna == kn ) THEN568 EXIT fact_loop569 ENDIF782 IF ( kn/kna*kna == kn ) THEN 783 EXIT fact_loop 784 ENDIF 570 785 END DO fact_loop 571 786 … … 577 792 END SUBROUTINE sqfact 578 793 794 795 SUBROUTINE generate_fake_land(imask) 796 !!---------------------------------------------------------------------- 797 !! Generate a fake land mass to test the decomposition code 798 !!---------------------------------------------------------------------- 799 USE par_oce, ONLY: jpiglo, jpjglo 800 USE partition_mod, ONLY: write_partition_map 801 IMPLICIT none 802 INTEGER, DIMENSION(jpiglo,jpjglo), INTENT(inout) :: imask 803 ! Locals 804 INTEGER :: ii, jj 805 INTEGER :: icentre, jcentre 806 INTEGER :: iwidth, iheight 807 INTEGER :: istart, istop 808 809 ! imask is zero on land points , unity on ocean points 810 iwidth = jpiglo/8 811 iheight = jpjglo/8 812 813 icentre = jpiglo/2 814 jcentre = jpjglo/2 815 816 istart = icentre - iwidth 817 istop = icentre + iwidth 818 DO jj = jcentre, jcentre - iheight, -1 819 imask(istart:istop,jj) = 0 820 istart = istart + 1 821 istop = istop - 1 822 END DO 823 istart = icentre - iwidth 824 istop = icentre + iwidth 825 DO jj = jcentre+1, jcentre + iheight, 1 826 imask(istart:istop,jj) = 0 827 istart = istart + 1 828 istop = istop - 1 829 END DO 830 831 ! Quick and dirty dump to stdout in gnuplot form 832 !!$ WRITE (*,*) 'GNUPLOT MAP' 833 !!$ DO jj = 1, jpjglo, 1 834 !!$ DO ii = 1, jpiglo, 1 835 !!$ WRITE (*,*) ii, jj, imask(ii,jj) 836 !!$ END DO 837 !!$ WRITE (*,*) 838 !!$ END DO 839 !!$ WRITE (*,*) 'END GNUPLOT MAP' 840 841 END SUBROUTINE generate_fake_land 842 579 843 !!====================================================================== 580 844 END MODULE nemogcm
Note: See TracChangeset
for help on using the changeset viewer.
