- 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/IOM/iom.F90
r3211 r3432 35 35 # endif 36 36 USE zpermute, ONLY : permute_z_last ! Re-order a 3d array back to external (z-last) ordering 37 37 USE timing, ONLY : timing_start, timing_stop 38 38 IMPLICIT NONE 39 39 PUBLIC ! must be public to be able to access iom_def through iom … … 184 184 ! end halo size for x,y dimensions 185 185 !--------------------------------------------------------------------- 186 187 CALL timing_start('iom_open') 188 186 189 ! Initializations and control 187 190 ! ============= … … 323 326 ENDIF 324 327 ! 328 CALL timing_stop('iom_open') 329 325 330 END SUBROUTINE iom_open 326 331 … … 340 345 CHARACTER(LEN=100) :: clinfo ! info character 341 346 !--------------------------------------------------------------------- 347 ! 348 CALL timing_start('iom_close') 342 349 ! 343 350 clinfo = ' iom_close ~~~ ' … … 373 380 ENDIF 374 381 ! 382 CALL timing_stop('iom_close') 383 375 384 END SUBROUTINE iom_close 376 385 … … 392 401 LOGICAL :: llstop ! local definition of ldstop 393 402 !!----------------------------------------------------------------------- 403 CALL timing_start('iom_varid') 404 394 405 iom_varid = 0 ! default definition 395 406 ! do we call ctl_stop if we look for non-existing variable? … … 441 452 ENDIF 442 453 ! 454 CALL timing_stop('iom_varid') 455 ! 443 456 END FUNCTION iom_varid 444 457 … … 455 468 ! 456 469 IF( kiomid > 0 ) THEN 470 CALL timing_start('iom_g0d') 457 471 idvar = iom_varid( kiomid, cdvar ) 458 472 IF( iom_file(kiomid)%nfid > 0 .AND. idvar > 0 ) THEN … … 465 479 END SELECT 466 480 ENDIF 481 CALL timing_stop('iom_g0d') 467 482 ENDIF 468 483 END SUBROUTINE iom_g0d 469 484 470 SUBROUTINE iom_g1d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount )485 SUBROUTINE iom_g1d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lzfirst ) 471 486 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 472 487 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read … … 476 491 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kstart ! start axis position of the reading 477 492 INTEGER , INTENT(in ), DIMENSION(1), OPTIONAL :: kcount ! number of points in each axis 493 LOGICAL , INTENT(in ) , OPTIONAL :: lzfirst ! Whether array being read has been 494 ! ftrans'd to make z index first 478 495 ! 479 496 IF( kiomid > 0 ) THEN 480 497 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r1d=pvar, & 481 & ktime=ktime, kstart=kstart, kcount=kcount )498 & ktime=ktime, kstart=kstart, kcount=kcount, lzfirst=lzfirst ) 482 499 ENDIF 483 500 END SUBROUTINE iom_g1d 484 501 485 SUBROUTINE iom_g2d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount )502 SUBROUTINE iom_g2d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lzfirst ) 486 503 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 487 504 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read … … 491 508 INTEGER , INTENT(in ), DIMENSION(2) , OPTIONAL :: kstart ! start axis position of the reading 492 509 INTEGER , INTENT(in ), DIMENSION(2) , OPTIONAL :: kcount ! number of points in each axis 510 LOGICAL , INTENT(in ) , OPTIONAL :: lzfirst ! Whether array being read has been 511 ! ftrans'd to make z index first 493 512 ! 494 513 IF( kiomid > 0 ) THEN 495 514 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r2d=pvar, & 496 & ktime=ktime, kstart=kstart, kcount=kcount )515 & ktime=ktime, kstart=kstart, kcount=kcount, lzfirst=lzfirst ) 497 516 ENDIF 498 517 END SUBROUTINE iom_g2d 499 518 500 SUBROUTINE iom_g3d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount )519 SUBROUTINE iom_g3d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lzfirst ) 501 520 INTEGER , INTENT(in ) :: kiomid ! Identifier of the file 502 521 INTEGER , INTENT(in ) :: kdom ! Type of domain to be read … … 506 525 INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kstart ! start axis position of the reading 507 526 INTEGER , INTENT(in ), DIMENSION(3) , OPTIONAL :: kcount ! number of points in each axis 527 LOGICAL , INTENT(in ), OPTIONAL :: lzfirst ! Whether array being read has been 528 ! ftrans'd to make z index first 508 529 ! 509 530 IF( kiomid > 0 ) THEN 510 531 IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r3d=pvar, & 511 & ktime=ktime, kstart=kstart, kcount=kcount )532 & ktime=ktime, kstart=kstart, kcount=kcount, lzfirst=lzfirst ) 512 533 ENDIF 513 534 END SUBROUTINE iom_g3d … … 516 537 SUBROUTINE iom_get_123d( kiomid, kdom , cdvar , & 517 538 & pv_r1d, pv_r2d, pv_r3d, & 518 & ktime , kstart, kcount )539 & ktime , kstart, kcount, lzfirst ) 519 540 !!----------------------------------------------------------------------- 520 541 !! *** ROUTINE iom_get_123d *** … … 533 554 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kstart ! start position of the reading in each axis 534 555 INTEGER , DIMENSION(:) , INTENT(in ), OPTIONAL :: kcount ! number of points to be read in each axis 556 LOGICAL , INTENT(in ), OPTIONAL :: lzfirst ! Whether array being read has been 557 ! ftrans'd to make z index first 535 558 ! 536 559 LOGICAL :: llnoov ! local definition to read overlap … … 556 579 CHARACTER(LEN=1) :: clrankpv, cldmspc ! 557 580 558 #if defined key_z_first581 !#if defined key_z_first 559 582 !! DCSE_NEMO: need a work array to match layout on disk, which is always z-last 560 583 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: wpv_r3d ! copy of pv_r3d with dimensions permuted … … 562 585 INTEGER, DIMENSION(3) :: ishape_pv_r3d ! size of the dimensions of pv_r3d 563 586 INTEGER :: jk ! loop counter 587 !#endif 588 LOGICAL :: lftrans ! DCSE_NEMO: Whether ftrans is 589 ! in effect for the array we're reading 590 !--------------------------------------------------------------------- 591 ! 592 CALL timing_start('iom_get_123d') 593 594 #if defined key_z_first 595 IF( PRESENT(lzfirst) )THEN 596 lftrans = lzfirst 597 ELSE 598 ! DCSE_NEMO: If we're built with key_z_first then we assume array 599 ! being read has been ftrans'd in the calling routine unless told 600 ! otherwise 601 lftrans = .TRUE. 602 END IF 603 #else 604 ! If we've not been built with key_z_first then we effectively ignore 605 ! the lzfirst argument because ftrans can't have been used. 606 lftrans = .FALSE. 564 607 #endif 565 608 566 !---------------------------------------------------------------------567 !568 609 clname = iom_file(kiomid)%name ! esier to read 569 610 clinfo = ' iom_get_123d, file: '//trim(clname)//', var: '//trim(cdvar) … … 650 691 ELSE 651 692 IF( .NOT. PRESENT(pv_r1d) ) THEN ! not a 1D array 652 IF( idom == jpdom_data ) THEN ; istart(1:2) = (/ mig(1), mjg(1) /) ! icnt(1:2) done bel low653 ELSEIF( idom == jpdom_global ) THEN ; istart(1:2) = (/ nimpp , njmpp /) ! icnt(1:2) done bel low693 IF( idom == jpdom_data ) THEN ; istart(1:2) = (/ mig(1), mjg(1) /) ! icnt(1:2) done below 694 ELSEIF( idom == jpdom_global ) THEN ; istart(1:2) = (/ nimpp , njmpp /) ! icnt(1:2) done below 654 695 ENDIF 655 696 ! we do not read the overlap -> we start to read at nldi, nldj … … 683 724 END DO 684 725 685 #if defined key_z_first686 726 !! DCSE_NEMO: Allocate 3d work-array with z-index last 687 !! to match layout on disk 688 IF ( PRESENT(pv_r3d)) THEN727 !! to match layout on disk if ftrans in use 728 IF (lftrans .AND. PRESENT(pv_r3d)) THEN 689 729 ishape_pv_r3d = SHAPE(pv_r3d) 690 730 IF (ishape_pv_r3d(1) /= jpk) THEN … … 693 733 CALL ctl_warn( trim(clinfo), 'beware: possible problem with 3d array, ', ctmp1 ) 694 734 ENDIF 695 ALLOCATE(wpv_r3d(ishape_pv_r3d(2),ishape_pv_r3d(3),ishape_pv_r3d(1)),STAT=istat_wpv_r3d) 735 ! This assumes that the array we're to read has been ftrans'd in the 736 ! calling routine and therefore that it's z/depth index is its 1st 737 ! whereas on disk it will be its 3rd. 738 ALLOCATE(wpv_r3d(ishape_pv_r3d(2),ishape_pv_r3d(3),ishape_pv_r3d(1)),& 739 STAT=istat_wpv_r3d) 696 740 IF (istat_wpv_r3d /= 0) THEN 697 741 CALL ctl_stop( trim(clinfo), 'failed to allocate wpv_r3d' ) 698 742 ENDIF 699 743 ENDIF 700 #endif701 744 702 745 ! check that icnt matches the input array … … 708 751 IF( irankpv == 1 ) ishape(1:1) = SHAPE(pv_r1d) 709 752 IF( irankpv == 2 ) ishape(1:2) = SHAPE(pv_r2d) 710 #if defined key_z_first 711 IF( irankpv == 3 ) ishape(1:3) = SHAPE(wpv_r3d) 712 #else 713 IF( irankpv == 3 ) ishape(1:3) = SHAPE(pv_r3d) 714 #endif 753 IF( irankpv == 3 )THEN 754 IF( lftrans )THEN 755 ishape(1:3) = SHAPE(wpv_r3d) 756 ELSE 757 ishape(1:3) = SHAPE(pv_r3d) 758 END IF 759 END IF 715 760 ctmp1 = 'd' 716 761 ELSE … … 725 770 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 726 771 ! ishape(1:3) = SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1 = 'd(nldi:nlei,nldj:nlej,:)' 727 #if defined key_z_first 728 IF( llnoov ) THEN 729 ishape(1:3)=SHAPE(wpv_r3d(nldi:nlei,nldj:nlej,:)) 730 ctmp1='d(nldi:nlei,nldj:nlej,:)' 772 IF( lftrans )THEN 773 IF( llnoov ) THEN 774 ishape(1:3)=SHAPE(wpv_r3d(nldi:nlei,nldj:nlej,:)) 775 ctmp1='d(nldi:nlei,nldj:nlej,:)' 776 ELSE 777 ishape(1:3)=SHAPE(wpv_r3d(1 :nlci,1 :nlcj,:)) 778 ctmp1='d(1:nlci,1:nlcj,:)' 779 ENDIF 731 780 ELSE 732 ishape(1:3)=SHAPE(wpv_r3d(1 :nlci,1 :nlcj,:)) 733 ctmp1='d(1:nlci,1:nlcj,:)' 734 ENDIF 735 #else 736 IF( llnoov ) THEN 737 ishape(1:3)=SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) 738 ctmp1='d(nldi:nlei,nldj:nlej,:)' 739 ELSE 740 ishape(1:3)=SHAPE(pv_r3d(1 :nlci,1 :nlcj,:)) 741 ctmp1='d(1:nlci,1:nlcj,:)' 742 ENDIF 743 #endif 744 ENDIF 745 ENDIF 781 IF( llnoov ) THEN 782 ishape(1:3)=SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) 783 ctmp1='d(nldi:nlei,nldj:nlej,:)' 784 ELSE 785 ishape(1:3)=SHAPE(pv_r3d(1 :nlci,1 :nlcj,:)) 786 ctmp1='d(1:nlci,1:nlcj,:)' 787 ENDIF 788 ENDIF ! ftrans in use 789 ENDIF 790 ENDIF ! ipdom == jpdom_unknown 746 791 747 792 DO jl = 1, irankpv … … 771 816 ENDIF 772 817 773 #if defined key_z_first774 818 SELECT CASE (iom_file(kiomid)%iolib) 775 819 CASE (jpioipsl ) 776 IF ( PRESENT(pv_r3d)) THEN820 IF (lftrans) THEN 777 821 CALL iom_ioipsl_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d, wpv_r3d ) 778 822 ELSE 779 CALL iom_ioipsl_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d )823 CALL iom_ioipsl_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d, pv_r3d ) 780 824 ENDIF 781 825 CASE (jpnf90 ) 782 IF ( PRESENT(pv_r3d)) THEN826 IF (lftrans) THEN 783 827 CALL iom_nf90_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d, wpv_r3d ) 784 828 ELSE 785 CALL iom_nf90_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d )829 CALL iom_nf90_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d, pv_r3d ) 786 830 ENDIF 787 831 CASE (jprstdimg) 788 IF ( PRESENT(pv_r3d)) THEN832 IF (lftrans) THEN 789 833 CALL iom_rstdimg_get( kiomid, idom, idvar, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d, wpv_r3d ) 790 834 ELSE 791 CALL iom_rstdimg_get( kiomid, idom, idvar, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d )835 CALL iom_rstdimg_get( kiomid, idom, idvar, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d, pv_r3d ) 792 836 ENDIF 793 837 CASE DEFAULT 794 838 CALL ctl_stop( TRIM(clinfo)//' accepted IO library are only jpioipsl, jpnf90 and jprstdimg' ) 795 839 END SELECT 796 #else 797 SELECT CASE (iom_file(kiomid)%iolib) 798 CASE (jpioipsl ) ; CALL iom_ioipsl_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, & 799 & pv_r1d, pv_r2d, pv_r3d ) 800 CASE (jpnf90 ) ; CALL iom_nf90_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, & 801 & pv_r1d, pv_r2d, pv_r3d ) 802 CASE (jprstdimg) ; CALL iom_rstdimg_get( kiomid, idom, idvar, ix1, ix2, iy1, iy2, & 803 & pv_r1d, pv_r2d, pv_r3d ) 804 CASE DEFAULT 805 CALL ctl_stop( TRIM(clinfo)//' accepted IO library are only jpioipsl, jpnf90 and jprstdimg' ) 806 END SELECT 807 #endif 808 809 #if defined key_z_first 840 810 841 !! DCSE_NEMO: if necessary, copy 3d work array back into pv_r3d, 811 842 !! and de-allocate the work array 812 IF (PRESENT(pv_r3d)) THEN 813 ! This assumes that pv_r3d is not ftransed 814 DO jk = 1, ishape_pv_r3d(3) 815 DO jj = 1, ishape_pv_r3d(2) 816 DO ji = 1, ishape_pv_r3d(1) 843 IF (lftrans .AND. PRESENT(pv_r3d)) THEN 844 ! This assumes that pv_r3d is ftrans'd in the calling routine so that 845 ! its first dimension rather than last dimension is 'z' 846 ! wpv_r3d is allocated with SHAPE(ishape_pv_r3d(2),ishape_pv_r3d(3),ishape_pv_r3d(1)) 847 DO ji = 1, ishape_pv_r3d(2) 848 DO jj = 1, ishape_pv_r3d(3) 849 DO jk = 1, ishape_pv_r3d(1) 817 850 pv_r3d(jk, ji, jj) = wpv_r3d(ji, jj, jk) 818 851 ENDDO … … 821 854 DEALLOCATE(wpv_r3d) 822 855 ENDIF 823 #endif824 856 825 857 IF( istop == nstop ) THEN ! no additional errors until this point... … … 861 893 ENDIF 862 894 ! 895 CALL timing_stop('iom_get_123d') 896 863 897 END SUBROUTINE iom_get_123d 864 898 … … 883 917 !--------------------------------------------------------------------- 884 918 ! 919 CALL timing_start('iom_gettime') 920 885 921 IF ( PRESENT(cdvar) ) THEN 886 922 tname = cdvar … … 924 960 ENDIF 925 961 ! 962 CALL timing_stop('iom_gettime') 963 ! 926 964 END SUBROUTINE iom_gettime 927 965 … … 961 999 INTEGER :: ivid ! variable id 962 1000 IF( kiomid > 0 ) THEN 1001 ! CALL timing_start('iom_rp0d') 963 1002 IF( iom_file(kiomid)%nfid > 0 ) THEN 964 1003 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) … … 971 1010 END SELECT 972 1011 ENDIF 1012 ! CALL timing_stop('iom_rp0d') 973 1013 ENDIF 974 1014 END SUBROUTINE iom_rp0d … … 983 1023 INTEGER :: ivid ! variable id 984 1024 IF( kiomid > 0 ) THEN 1025 ! CALL timing_start('iom_rp1d') 985 1026 IF( iom_file(kiomid)%nfid > 0 ) THEN 986 1027 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) … … 993 1034 END SELECT 994 1035 ENDIF 1036 ! CALL timing_stop('iom_rp1d') 995 1037 ENDIF 996 1038 END SUBROUTINE iom_rp1d … … 1005 1047 INTEGER :: ivid ! variable id 1006 1048 IF( kiomid > 0 ) THEN 1049 ! CALL timing_start('iom_rp2d') 1007 1050 IF( iom_file(kiomid)%nfid > 0 ) THEN 1008 1051 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) … … 1015 1058 END SELECT 1016 1059 ENDIF 1060 ! CALL timing_stop('iom_rp2d') 1017 1061 ENDIF 1018 1062 END SUBROUTINE iom_rp2d … … 1032 1076 INTEGER :: ji, jj, jk ! Dummy loop indices 1033 1077 IF( kiomid > 0 ) THEN 1078 ! CALL timing_start('iom_rp3d') 1034 1079 IF( iom_file(kiomid)%nfid > 0 ) THEN 1035 1080 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) … … 1056 1101 DEALLOCATE( pvar_trans ) 1057 1102 ENDIF 1103 ! CALL timing_stop('iom_rp3d') 1058 1104 ENDIF 1059 1105 #else 1060 1106 IF( kiomid > 0 ) THEN 1107 ! CALL timing_start('iom_rp3d') 1061 1108 IF( iom_file(kiomid)%nfid > 0 ) THEN 1062 1109 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) … … 1069 1116 END SELECT 1070 1117 ENDIF 1118 ! CALL timing_stop('iom_rp3d') 1071 1119 ENDIF 1072 1120 #endif
Note: See TracChangeset
for help on using the changeset viewer.
