Changeset 1749 for trunk/NEMO/OFF_SRC/IOM/iom.F90
- Timestamp:
- 2009-11-23T11:52:11+01:00 (15 years ago)
- File:
-
- 1 edited
-
trunk/NEMO/OFF_SRC/IOM/iom.F90 (modified) (14 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMO/OFF_SRC/IOM/iom.F90
r1697 r1749 27 27 28 28 #if defined key_iomput 29 USE domngb ! ocean space and time domain 30 USE phycst ! physical constants 31 USE dianam ! build name of file 29 32 USE mod_event_client 33 USE mod_attribut 30 34 # endif 31 35 … … 34 38 35 39 #if defined key_iomput 36 LOGICAL, PUBLIC, PARAMETER :: lk_iomput = .TRUE. !: iom_put flag40 LOGICAL, PUBLIC, PARAMETER :: lk_iomput = .TRUE. !: iom_put flag 37 41 #else 38 42 LOGICAL, PUBLIC, PARAMETER :: lk_iomput = .FALSE. !: iom_put flag 39 43 #endif 40 41 44 PUBLIC iom_init, iom_open, iom_close, iom_setkt, iom_varid, iom_get, iom_gettime, iom_rstput, iom_put 42 45 … … 55 58 END INTERFACE 56 59 INTERFACE iom_put 57 MODULE PROCEDURE iom_p 2d, iom_p3d60 MODULE PROCEDURE iom_p0d, iom_p2d, iom_p3d 58 61 END INTERFACE 59 62 #if defined key_iomput … … 71 74 CONTAINS 72 75 73 SUBROUTINE iom_init ( pjulian )76 SUBROUTINE iom_init 74 77 !!---------------------------------------------------------------------- 75 78 !! *** ROUTINE *** … … 78 81 !! 79 82 !!---------------------------------------------------------------------- 80 REAL(wp), INTENT(in) :: pjulian !: julian day at nit000 = 081 83 #if defined key_iomput 84 REAL(wp) :: ztmp 82 85 !!---------------------------------------------------------------------- 83 86 ! read the xml file … … 85 88 86 89 ! calendar parameters 87 CALL event__set_time_parameters( nit000 - 1, pjulian, rdt ) 90 SELECT CASE ( nleapy ) ! Choose calendar for IOIPSL 91 CASE ( 1) ; CALL event__set_calendar('gregorian') 92 CASE ( 0) ; CALL event__set_calendar('noleap' ) 93 CASE (30) ; CALL event__set_calendar('360d' ) 94 END SELECT 95 ztmp = fjulday - adatrj 96 IF( ABS(ztmp - REAL(NINT(ztmp),wp)) < 0.1 / rday ) ztmp = REAL(NINT(ztmp),wp) ! avoid truncation error 97 CALL event__set_time_parameters( nit000 - 1, ztmp, rdt ) 88 98 89 99 ! horizontal grid definition 100 CALL set_scalar 90 101 CALL set_grid( "grid_T", glamt, gphit ) 91 102 CALL set_grid( "grid_U", glamu, gphiu ) … … 98 109 CALL event__set_vert_axis( "depthv", gdept_0 ) 99 110 CALL event__set_vert_axis( "depthw", gdepw_0 ) 111 112 ! automatic definitions of some of the xml attributs 113 CALL set_xmlatt 100 114 101 115 ! end file definition … … 180 194 ! do we read the overlap 181 195 ! ugly patch SM+JMM+RB to overwrite global definition in some cases 182 llnoov = (jpni * jpnj ) == jpnij 196 llnoov = (jpni * jpnj ) == jpnij .AND. .NOT. lk_agrif 183 197 ! create the file name by added, if needed, TRIM(Agrif_CFixed()) and TRIM(clsuffix) 184 198 ! ============= … … 525 539 ! do we read the overlap 526 540 ! ugly patch SM+JMM+RB to overwrite global definition in some cases 527 llnoov = (jpni * jpnj ) == jpnij 541 llnoov = (jpni * jpnj ) == jpnij .AND. .NOT. lk_agrif 528 542 ! check kcount and kstart optionals parameters... 529 543 IF( PRESENT(kcount) .AND. (.NOT. PRESENT(kstart)) ) CALL ctl_stop(trim(clinfo), 'kcount present needs kstart present') … … 894 908 895 909 !!---------------------------------------------------------------------- 896 !! INTERFACE iom_ rstput910 !! INTERFACE iom_put 897 911 !!---------------------------------------------------------------------- 912 SUBROUTINE iom_p0d( cdname, pfield0d ) 913 CHARACTER(LEN=*), INTENT(in) :: cdname 914 REAL(wp) , INTENT(in) :: pfield0d 915 #if defined key_iomput 916 CALL event__write_field2D( cdname, RESHAPE( (/pfield0d/), (/1,1/) ) ) 917 #else 918 IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings 919 #endif 920 END SUBROUTINE iom_p0d 921 898 922 SUBROUTINE iom_p2d( cdname, pfield2d ) 899 923 CHARACTER(LEN=*) , INTENT(in) :: cdname … … 901 925 #if defined key_iomput 902 926 CALL event__write_field2D( cdname, pfield2d(nldi:nlei, nldj:nlej) ) 927 #else 928 IF( .FALSE. ) WRITE(numout,*) cdname, pfield2d ! useless test to avoid compilation warnings 903 929 #endif 904 930 END SUBROUTINE iom_p2d … … 909 935 #if defined key_iomput 910 936 CALL event__write_field3D( cdname, pfield3d(nldi:nlei, nldj:nlej, :) ) 937 #else 938 IF( .FALSE. ) WRITE(numout,*) cdname, pfield3d ! useless test to avoid compilation warnings 911 939 #endif 912 940 END SUBROUTINE iom_p3d … … 920 948 !! *** ROUTINE *** 921 949 !! 922 !! ** Purpose : 950 !! ** Purpose : define horizontal grids 923 951 !! 924 952 !!---------------------------------------------------------------------- … … 934 962 END SUBROUTINE set_grid 935 963 964 965 SUBROUTINE set_scalar 966 !!---------------------------------------------------------------------- 967 !! *** ROUTINE *** 968 !! 969 !! ** Purpose : define fake grids for scalar point 970 !! 971 !!---------------------------------------------------------------------- 972 REAL(wp), DIMENSION(1,1) :: zz = 1. 973 !!---------------------------------------------------------------------- 974 CALL event__set_grid_dimension( 'scalarpoint', jpnij, 1) 975 CALL event__set_grid_domain ( 'scalarpoint', 1, 1, narea, 1, zz, zz ) 976 CALL event__set_grid_type_nemo( 'scalarpoint' ) 977 978 END SUBROUTINE set_scalar 979 980 981 SUBROUTINE set_xmlatt 982 !!---------------------------------------------------------------------- 983 !! *** ROUTINE *** 984 !! 985 !! ** Purpose : automatic definitions of some of the xml attributs... 986 !! 987 !!---------------------------------------------------------------------- 988 CHARACTER(len=6),DIMENSION( 8) :: clsuff ! suffix name 989 CHARACTER(len=1),DIMENSION( 3) :: clgrd ! suffix name 990 CHARACTER(len=50) :: clname ! file name 991 CHARACTER(len=1) :: cl1 ! 1 character 992 CHARACTER(len=2) :: cl2 ! 1 character 993 INTEGER :: idt ! time-step in seconds 994 INTEGER :: iddss, ihhss ! number of seconds in 1 day, 1 hour and 1 year 995 INTEGER :: iyymo ! number of months in 1 year 996 INTEGER :: jg, jh, jd, jm, jy ! loop counters 997 INTEGER :: ix, iy ! i-,j- index 998 REAL(wp) ,DIMENSION(11) :: zlontao ! longitudes of tao moorings 999 REAL(wp) ,DIMENSION( 7) :: zlattao ! latitudes of tao moorings 1000 REAL(wp) ,DIMENSION( 4) :: zlonrama ! longitudes of rama moorings 1001 REAL(wp) ,DIMENSION(11) :: zlatrama ! latitudes of rama moorings 1002 REAL(wp) ,DIMENSION( 3) :: zlonpira ! longitudes of pirata moorings 1003 REAL(wp) ,DIMENSION( 9) :: zlatpira ! latitudes of pirata moorings 1004 !!---------------------------------------------------------------------- 1005 ! 1006 idt = NINT( rdttra(1) ) 1007 iddss = NINT( rday ) ! number of seconds in 1 day 1008 ihhss = NINT( rmmss * rhhmm ) ! number of seconds in 1 hour 1009 iyymo = NINT( raamo ) ! number of months in 1 year 1010 1011 ! frequency of the call of iom_put (attribut: freq_op) 1012 CALL event__set_attribut( 'field_definition', attr( field__freq_op, idt ) ) ! model time-step 1013 1014 ! output file names (attribut: name) 1015 clsuff(:) = (/ 'grid_T', 'grid_U', 'grid_V', 'grid_W', 'icemod', 'ptrc_T', 'diad_T', 'scalar' /) 1016 DO jg = 1, SIZE(clsuff) ! grid type 1017 DO jh = 1, 12 ! 1, 2, 3, 4, 6, 12 hours 1018 IF( MOD(12,jh) == 0 ) THEN 1019 WRITE(cl2,'(i2)') jh 1020 CALL dia_nam( clname, jh * ihhss, clsuff(jg), ldfsec = .TRUE. ) 1021 CALL event__set_attribut( TRIM(ADJUSTL(cl2))//'h_'//clsuff(jg), attr( file__name, TRIM(clname) ) ) 1022 ENDIF 1023 END DO 1024 DO jd = 1, 5, 2 ! 1, 3, 5 days 1025 WRITE(cl1,'(i1)') jd 1026 CALL dia_nam( clname, jd * iddss, clsuff(jg), ldfsec = .TRUE. ) 1027 CALL event__set_attribut( cl1//'d_'//clsuff(jg), attr( file__name, TRIM(clname) ) ) 1028 END DO 1029 DO jm = 1, 6 ! 1, 2, 3, 4, 6 months 1030 IF( MOD(6,jm) == 0 ) THEN 1031 WRITE(cl1,'(i1)') jm 1032 CALL dia_nam( clname, -jm, clsuff(jg) ) 1033 CALL event__set_attribut( cl1//'m_'//clsuff(jg), attr( file__name, TRIM(clname) ) ) 1034 ENDIF 1035 END DO 1036 DO jy = 1, 10 ! 1, 2, 5, 10 years 1037 IF( MOD(10,jy) == 0 ) THEN 1038 WRITE(cl2,'(i2)') jy 1039 CALL dia_nam( clname, -jy * iyymo, clsuff(jg) ) 1040 CALL event__set_attribut( TRIM(ADJUSTL(cl2))//'y_'//clsuff(jg), attr( file__name, TRIM(clname) ) ) 1041 ENDIF 1042 END DO 1043 END DO 1044 1045 ! Zooms... 1046 clgrd = (/ 'T', 'U', 'W' /) 1047 DO jg = 1, SIZE(clgrd) ! grid type 1048 cl1 = clgrd(jg) 1049 ! Equatorial section (attributs: jbegin, ni, name_suffix) 1050 CALL dom_ngb( 0., 0., ix, iy, cl1 ) 1051 CALL event__set_attribut( 'Eq'//cl1, attr( zoom__jbegin , iy ) ) 1052 CALL event__set_attribut( 'Eq'//cl1, attr( zoom__ni , jpiglo ) ) 1053 CALL event__set_attribut( 'Eq'//cl1, attr( file__name_suffix, '_Eq' ) ) 1054 END DO 1055 ! TAO moorings (attributs: ibegin, jbegin, name_suffix) 1056 zlontao = (/ 137.0, 147.0, 156.0, 165.0, -180.0, -170.0, -155.0, -140.0, -125.0, -110.0, -95.0 /) 1057 zlattao = (/ -8.0, -5.0, -2.0, 0.0, 2.0, 5.0, 8.0 /) 1058 CALL set_mooring( zlontao, zlattao ) 1059 ! RAMA moorings (attributs: ibegin, jbegin, name_suffix) 1060 zlonrama = (/ 55.0, 67.0, 80.5, 90.0 /) 1061 zlatrama = (/ -16.0, -12.0, -8.0, -4.0, -1.5, 0.0, 1.5, 4.0, 8.0, 12.0, 15.0 /) 1062 CALL set_mooring( zlonrama, zlatrama ) 1063 ! PIRATA moorings (attributs: ibegin, jbegin, name_suffix) 1064 zlonpira = (/ -38.0, -23.0, -10.0 /) 1065 zlatpira = (/ -19.0, -14.0, -8.0, 0.0, 4.0, 8.0, 12.0, 15.0, 20.0 /) 1066 CALL set_mooring( zlonpira, zlatpira ) 1067 1068 END SUBROUTINE set_xmlatt 1069 1070 1071 SUBROUTINE set_mooring( plon, plat) 1072 !!---------------------------------------------------------------------- 1073 !! *** ROUTINE *** 1074 !! 1075 !! ** Purpose : automatic definitions of moorings xml attributs... 1076 !! 1077 !!---------------------------------------------------------------------- 1078 REAL(wp), DIMENSION(:), INTENT(in) :: plon, plat ! longitudes/latitudes oft the mooring 1079 ! 1080 !!$ CHARACTER(len=1),DIMENSION(4) :: clgrd = (/ 'T', 'U', 'V', 'W' /) ! suffix name 1081 CHARACTER(len=1),DIMENSION(1) :: clgrd = (/ 'T' /) ! suffix name 1082 CHARACTER(len=50) :: clname ! file name 1083 CHARACTER(len=1) :: cl1 ! 1 character 1084 CHARACTER(len=6) :: clon,clat ! name of longitude, latitude 1085 INTEGER :: ji, jj, jg ! loop counters 1086 INTEGER :: ix, iy ! i-,j- index 1087 REAL(wp) :: zlon, zlat 1088 !!---------------------------------------------------------------------- 1089 DO jg = 1, SIZE(clgrd) 1090 cl1 = clgrd(jg) 1091 DO ji = 1, SIZE(plon) 1092 DO jj = 1, SIZE(plat) 1093 zlon = plon(ji) 1094 zlat = plat(jj) 1095 ! modifications for RAMA moorings 1096 IF( zlon == 67. .AND. zlat == 15. ) zlon = 65. 1097 IF( zlon == 90. .AND. zlat <= -4. ) zlon = 95. 1098 IF( zlon == 95. .AND. zlat == -4. ) zlat = -5. 1099 ! modifications for PIRATA moorings 1100 IF( zlon == -38. .AND. zlat == -19. ) zlon = -34. 1101 IF( zlon == -38. .AND. zlat == -14. ) zlon = -32. 1102 IF( zlon == -38. .AND. zlat == -8. ) zlon = -30. 1103 IF( zlon == -38. .AND. zlat == 0. ) zlon = -35. 1104 IF( zlon == -23. .AND. zlat == 20. ) zlat = 21. 1105 IF( zlon == -10. .AND. zlat == -14. ) zlat = -10. 1106 IF( zlon == -10. .AND. zlat == -8. ) zlat = -6. 1107 IF( zlon == -10. .AND. zlat == 4. ) THEN ; zlon = 0. ; zlat = 0. ; ENDIF 1108 CALL dom_ngb( zlon, zlat, ix, iy, cl1 ) 1109 IF( zlon >= 0. ) THEN 1110 IF( zlon == REAL(NINT(zlon), wp) ) THEN ; WRITE(clon, '(i3, a)') NINT( zlon), 'e' 1111 ELSE ; WRITE(clon, '(f5.1,a)') zlon , 'e' 1112 ENDIF 1113 ELSE 1114 IF( zlon == REAL(NINT(zlon), wp) ) THEN ; WRITE(clon, '(i3, a)') NINT(-zlon), 'w' 1115 ELSE ; WRITE(clon, '(f5.1,a)') -zlon , 'w' 1116 ENDIF 1117 ENDIF 1118 IF( zlat >= 0. ) THEN 1119 IF( zlat == REAL(NINT(zlat), wp) ) THEN ; WRITE(clat, '(i2, a)') NINT( zlat), 'n' 1120 ELSE ; WRITE(clat, '(f4.1,a)') zlat , 'n' 1121 ENDIF 1122 ELSE 1123 IF( zlat == REAL(NINT(zlat), wp) ) THEN ; WRITE(clat, '(i2, a)') NINT(-zlat), 's' 1124 ELSE ; WRITE(clat, '(f4.1,a)') -zlat , 's' 1125 ENDIF 1126 ENDIF 1127 clname = TRIM(ADJUSTL(clat))//TRIM(ADJUSTL(clon)) 1128 CALL event__set_attribut( TRIM(clname)//cl1, attr( zoom__ibegin , ix ) ) 1129 CALL event__set_attribut( TRIM(clname)//cl1, attr( zoom__jbegin , iy ) ) 1130 CALL event__set_attribut( TRIM(clname)//cl1, attr( file__name_suffix, '_'//TRIM(clname) ) ) 1131 END DO 1132 END DO 1133 END DO 1134 1135 END SUBROUTINE set_mooring 1136 936 1137 #else 937 1138 938 1139 SUBROUTINE iom_setkt( kt ) 939 1140 INTEGER, INTENT(in ):: kt 1141 IF( .FALSE. ) WRITE(numout,*) kt ! useless test to avoid compilation warnings 940 1142 END SUBROUTINE iom_setkt 941 1143
Note: See TracChangeset
for help on using the changeset viewer.
