- Timestamp:
- 2011-12-11T16:00:26+01:00 (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90
r2715 r3211 19 19 !!-------------------------------------------------------------------- 20 20 USE dom_oce ! ocean space and time domain 21 USE lbclnk ! late al boundary condition / mpp exchanges21 USE lbclnk ! lateral boundary condition / mpp exchanges 22 22 USE iom_def ! iom variables definitions 23 23 USE iom_ioipsl ! NetCDF format with IOIPSL library … … 34 34 USE mod_attribut 35 35 # endif 36 USE zpermute, ONLY : permute_z_last ! Re-order a 3d array back to external (z-last) ordering 36 37 37 38 IMPLICIT NONE … … 70 71 END INTERFACE 71 72 # endif 73 74 !! * Control permutation of array indices 75 # include "dom_oce_ftrans.h90" 72 76 73 77 !!---------------------------------------------------------------------- … … 540 544 INTEGER :: ix1, ix2, iy1, iy2 ! subdomain indexes 541 545 INTEGER :: ji, jj ! loop counters 542 INTEGER :: irankpv 546 INTEGER :: irankpv ! 543 547 INTEGER :: ind1, ind2 ! substring index 544 548 INTEGER, DIMENSION(jpmax_dims) :: istart ! starting point to read for each axis … … 551 555 CHARACTER(LEN=100) :: clname ! file name 552 556 CHARACTER(LEN=1) :: clrankpv, cldmspc ! 557 558 #if defined key_z_first 559 !! DCSE_NEMO: need a work array to match layout on disk, which is always z-last 560 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: wpv_r3d ! copy of pv_r3d with dimensions permuted 561 INTEGER :: istat_wpv_r3d ! result of attempt to allocate the above 562 INTEGER, DIMENSION(3) :: ishape_pv_r3d ! size of the dimensions of pv_r3d 563 INTEGER :: jk ! loop counter 564 #endif 565 553 566 !--------------------------------------------------------------------- 554 567 ! … … 670 683 END DO 671 684 685 #if defined key_z_first 686 !! DCSE_NEMO: Allocate 3d work-array with z-index last 687 !! to match layout on disk 688 IF (PRESENT(pv_r3d)) THEN 689 ishape_pv_r3d = SHAPE(pv_r3d) 690 IF (ishape_pv_r3d(1) /= jpk) THEN 691 WRITE( ctmp1, FMT="('leading dimension is ',i5,', not ',i5,' (jpk) as expected')" ) & 692 & ishape_pv_r3d(1), jpk 693 CALL ctl_warn( trim(clinfo), 'beware: possible problem with 3d array, ', ctmp1 ) 694 ENDIF 695 ALLOCATE(wpv_r3d(ishape_pv_r3d(2),ishape_pv_r3d(3),ishape_pv_r3d(1)),STAT=istat_wpv_r3d) 696 IF (istat_wpv_r3d /= 0) THEN 697 CALL ctl_stop( trim(clinfo), 'failed to allocate wpv_r3d' ) 698 ENDIF 699 ENDIF 700 #endif 701 672 702 ! check that icnt matches the input array 673 703 !- 704 705 !! DCSE_NEMO: beware! want ishape to match wpv_r3d, not pv_r3d 706 674 707 IF( idom == jpdom_unknown ) THEN 675 708 IF( irankpv == 1 ) ishape(1:1) = SHAPE(pv_r1d) 676 709 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 677 713 IF( irankpv == 3 ) ishape(1:3) = SHAPE(pv_r3d) 714 #endif 678 715 ctmp1 = 'd' 679 716 ELSE … … 688 725 ! JMM + SM: ugly patch before getting the new version of lib_mpp) 689 726 ! ishape(1:3) = SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1 = 'd(nldi:nlei,nldj:nlej,:)' 690 IF( llnoov ) THEN ; ishape(1:3)=SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1='d(nldi:nlei,nldj:nlej,:)' 691 ELSE ; ishape(1:3)=SHAPE(pv_r3d(1 :nlci,1 :nlcj,:)) ; ctmp1='d(1:nlci,1:nlcj,:)' 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,:)' 731 ELSE 732 ishape(1:3)=SHAPE(wpv_r3d(1 :nlci,1 :nlcj,:)) 733 ctmp1='d(1:nlci,1:nlcj,:)' 692 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 693 744 ENDIF 694 745 ENDIF … … 720 771 ENDIF 721 772 773 #if defined key_z_first 774 SELECT CASE (iom_file(kiomid)%iolib) 775 CASE (jpioipsl ) 776 IF (PRESENT(pv_r3d)) THEN 777 CALL iom_ioipsl_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d, wpv_r3d ) 778 ELSE 779 CALL iom_ioipsl_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d ) 780 ENDIF 781 CASE (jpnf90 ) 782 IF (PRESENT(pv_r3d)) THEN 783 CALL iom_nf90_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d, wpv_r3d ) 784 ELSE 785 CALL iom_nf90_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d ) 786 ENDIF 787 CASE (jprstdimg) 788 IF (PRESENT(pv_r3d)) THEN 789 CALL iom_rstdimg_get( kiomid, idom, idvar, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d, wpv_r3d ) 790 ELSE 791 CALL iom_rstdimg_get( kiomid, idom, idvar, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d ) 792 ENDIF 793 CASE DEFAULT 794 CALL ctl_stop( TRIM(clinfo)//' accepted IO library are only jpioipsl, jpnf90 and jprstdimg' ) 795 END SELECT 796 #else 722 797 SELECT CASE (iom_file(kiomid)%iolib) 723 798 CASE (jpioipsl ) ; CALL iom_ioipsl_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, & … … 730 805 CALL ctl_stop( TRIM(clinfo)//' accepted IO library are only jpioipsl, jpnf90 and jprstdimg' ) 731 806 END SELECT 807 #endif 808 809 #if defined key_z_first 810 !! DCSE_NEMO: if necessary, copy 3d work array back into pv_r3d, 811 !! 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) 817 pv_r3d(jk, ji, jj) = wpv_r3d(ji, jj, jk) 818 ENDDO 819 ENDDO 820 ENDDO 821 DEALLOCATE(wpv_r3d) 822 ENDIF 823 #endif 732 824 733 825 IF( istop == nstop ) THEN ! no additional errors until this point... 734 826 IF(lwp) WRITE(numout,"(10x,' read ',a,' (rec: ',i4,') in ',a,' ok')") TRIM(cdvar), itime, TRIM(iom_file(kiomid)%name) 735 827 736 !--- overlap areas and extra hal lows (mpp)828 !--- overlap areas and extra haloes (mpp) 737 829 IF( PRESENT(pv_r2d) .AND. idom /= jpdom_unknown ) THEN 738 830 CALL lbc_lnk( pv_r2d,'Z',-999.,'no0' ) … … 934 1026 INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type 935 1027 INTEGER :: ivid ! variable id 1028 #if defined key_z_first 1029 !! DCSE_NEMO: Need to transpose the dimensions of pvar from internal to external orderings 1030 ! We do not use ftrans here 1031 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: pvar_trans ! transposed pvar 1032 INTEGER :: ji, jj, jk ! Dummy loop indices 1033 IF( kiomid > 0 ) THEN 1034 IF( iom_file(kiomid)%nfid > 0 ) THEN 1035 ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 1036 IF ( (SIZE(pvar, DIM=1) /= jpk ) & 1037 & .OR. (SIZE(pvar, DIM=2) /= jpi ) & 1038 & .OR. (SIZE(pvar, DIM=3) /= jpj ) ) THEN 1039 CALL ctl_stop( 'iom_rp3d: unexpected shape for variable ', cdvar ) 1040 END IF 1041 ALLOCATE( pvar_trans(jpi, jpj, jpk) ) 1042 DO jk = 1, jpk 1043 DO jj = 1, jpj 1044 DO ji = 1, jpi 1045 pvar_trans(ji, jj, jk) = pvar(jk, ji, jj) 1046 END DO 1047 END DO 1048 END DO 1049 SELECT CASE (iom_file(kiomid)%iolib) 1050 CASE (jpioipsl ) ; CALL iom_ioipsl_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = pvar_trans ) 1051 CASE (jpnf90 ) ; CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = pvar_trans ) 1052 CASE (jprstdimg) ; IF( kt == kwrite ) CALL iom_rstdimg_rstput( kiomid, cdvar, ivid, pv_r3d = pvar_trans ) 1053 CASE DEFAULT 1054 CALL ctl_stop( 'iom_rp3d: accepted IO library are only jpioipsl and jprstdimg' ) 1055 END SELECT 1056 DEALLOCATE( pvar_trans ) 1057 ENDIF 1058 ENDIF 1059 #else 936 1060 IF( kiomid > 0 ) THEN 937 1061 IF( iom_file(kiomid)%nfid > 0 ) THEN … … 946 1070 ENDIF 947 1071 ENDIF 1072 #endif 948 1073 END SUBROUTINE iom_rp3d 949 1074 … … 976 1101 REAL(wp), DIMENSION(:,:,:), INTENT(in) :: pfield3d 977 1102 #if defined key_iomput 1103 #if defined key_z_first 1104 !FTRANS ASSERT :z :I 1105 !FTRANS pfield3d :I :I :z 1106 CALL event__write_field3D( cdname, permute_z_last(pfield3d(nldi:nlei, nldj:nlej, :)) ) 1107 #else 1108 !FTRANS ASSERT :I :z 978 1109 CALL event__write_field3D( cdname, pfield3d(nldi:nlei, nldj:nlej, :) ) 1110 #endif 979 1111 #else 980 1112 IF( .FALSE. ) WRITE(numout,*) cdname, pfield3d ! useless test to avoid compilation warnings
Note: See TracChangeset
for help on using the changeset viewer.
