| 1 | SUBROUTINE prism_def_var_proto(id_nports, cdport, id_part, |
|---|
| 2 | $ id_var_nodims, kinout, id_var_shape, ktype, kinfo) |
|---|
| 3 | c |
|---|
| 4 | c **** Def_var *** PRISM 1.0 |
|---|
| 5 | c |
|---|
| 6 | c purpose: |
|---|
| 7 | c -------- |
|---|
| 8 | c define a port |
|---|
| 9 | c |
|---|
| 10 | c interface: |
|---|
| 11 | c ---------- |
|---|
| 12 | c id_nports : port number of the field |
|---|
| 13 | c cdport : symbolic name of the field |
|---|
| 14 | c id_part : field decomposition |
|---|
| 15 | c id_var_nodims(1) : rank of array variable |
|---|
| 16 | c id_var_nodims(2) : number of bundles |
|---|
| 17 | c kinout : port status in/out |
|---|
| 18 | c id_var_shape : description of the local partition in the |
|---|
| 19 | c global index space |
|---|
| 20 | c ktype : type of data |
|---|
| 21 | c kinfo : output status |
|---|
| 22 | c |
|---|
| 23 | c lib mp: |
|---|
| 24 | c ------- |
|---|
| 25 | c mpi-1 |
|---|
| 26 | c |
|---|
| 27 | c author: |
|---|
| 28 | c ------- |
|---|
| 29 | c Eric Sevault - METEO FRANCE |
|---|
| 30 | c Laurent Terray - CERFACS |
|---|
| 31 | c |
|---|
| 32 | c ---------------------------------------------------------------- |
|---|
| 33 | USE mod_kinds_model |
|---|
| 34 | USE mod_prism_proto |
|---|
| 35 | USE mod_comprism_proto |
|---|
| 36 | c ---------------------------------------------------------------- |
|---|
| 37 | INTEGER (kind=ip_intwp_p) kinout, ktype, kinfo, id_nports, |
|---|
| 38 | $ id_part |
|---|
| 39 | INTEGER (kind=ip_intwp_p) id_var_nodims(2), |
|---|
| 40 | $ id_var_shape(2*id_var_nodims(1)) |
|---|
| 41 | CHARACTER*(*) cdport |
|---|
| 42 | c ---------------------------------------------------------------- |
|---|
| 43 | c |
|---|
| 44 | c* 0. First Check |
|---|
| 45 | c -------------- |
|---|
| 46 | c |
|---|
| 47 | IF ( nexit.NE.1 ) THEN |
|---|
| 48 | kinfo = CLIM_FastExit |
|---|
| 49 | WRITE(nulprt,FMT='(A)') 'Def_var - should not be called' |
|---|
| 50 | GO TO 1010 |
|---|
| 51 | ENDIF |
|---|
| 52 | kinfo = CLIM_Ok |
|---|
| 53 | c |
|---|
| 54 | c* 1. define the port |
|---|
| 55 | c ------------------ |
|---|
| 56 | c |
|---|
| 57 | WRITE(nulprt,*) 'Def_var - port name, status : ',cdport, kinout |
|---|
| 58 | WRITE(nulprt,*) 'Def_var - data type: ',ktype |
|---|
| 59 | c |
|---|
| 60 | IF ( ktype .ne. PRISM_Real ) THEN |
|---|
| 61 | WRITE(nulprt,FMT='(A,I4)') |
|---|
| 62 | $ 'Def_var - ERROR - Bad data type:',ktype |
|---|
| 63 | WRITE(nulprt,*) |
|---|
| 64 | $ 'Calling MPI_Abort in prism_def_var' |
|---|
| 65 | CALL FLUSH(nulprt) |
|---|
| 66 | CALL MPI_ABORT (mpi_comm, 0, ierror) |
|---|
| 67 | ENDIF |
|---|
| 68 | c |
|---|
| 69 | IF ( kinout.EQ.CLIM_InOut ) THEN |
|---|
| 70 | CALL prism_defport (id_nports, cdport, CLIM_In, ktype, id_part, |
|---|
| 71 | $ kinfo ) |
|---|
| 72 | IF (kinfo.EQ.CLIM_Ok) THEN |
|---|
| 73 | CALL prism_defport (id_nports, cdport, CLIM_Out, ktype, |
|---|
| 74 | $ id_part, kinfo ) |
|---|
| 75 | ENDIF |
|---|
| 76 | ELSE |
|---|
| 77 | CALL prism_defport ( id_nports,cdport, kinout, ktype, id_part, |
|---|
| 78 | $ kinfo ) |
|---|
| 79 | ENDIF |
|---|
| 80 | c |
|---|
| 81 | c ---------------------------------------------------------------- |
|---|
| 82 | c |
|---|
| 83 | 1010 CONTINUE |
|---|
| 84 | CALL FLUSH(nulprt) |
|---|
| 85 | RETURN |
|---|
| 86 | END |
|---|
| 87 | c |
|---|
| 88 | c ==================================================================== |
|---|
| 89 | |
|---|
| 90 | SUBROUTINE prism_defport(id_nports,cdport,kinout,ktype,id_part, |
|---|
| 91 | $ kinfo) |
|---|
| 92 | c |
|---|
| 93 | c* *** Define *** CLIM 2.2 |
|---|
| 94 | c |
|---|
| 95 | c purpose: |
|---|
| 96 | c -------- |
|---|
| 97 | c define a port |
|---|
| 98 | c |
|---|
| 99 | c interface: |
|---|
| 100 | c ---------- |
|---|
| 101 | c id_nports : port number of the field |
|---|
| 102 | c cdport : symbolic name of the field |
|---|
| 103 | c kinout : port status in/out |
|---|
| 104 | c ktype : type of data |
|---|
| 105 | c kparal : type of parallel decomposition |
|---|
| 106 | c kinfo : output status |
|---|
| 107 | c |
|---|
| 108 | c lib mp: |
|---|
| 109 | c ------- |
|---|
| 110 | c mpi-2 |
|---|
| 111 | c |
|---|
| 112 | c author: |
|---|
| 113 | c ------- |
|---|
| 114 | c Eric Sevault - METEO FRANCE |
|---|
| 115 | c Laurent Terray - CERFACS |
|---|
| 116 | c Jean Latour - F.S.E. (mpi-2) |
|---|
| 117 | c |
|---|
| 118 | c ---------------------------------------------------------------- |
|---|
| 119 | USE mod_kinds_model |
|---|
| 120 | USE mod_prism_proto |
|---|
| 121 | USE mod_comprism_proto |
|---|
| 122 | c ---------------------------------------------------------------- |
|---|
| 123 | INTEGER (kind=ip_intwp_p) kinout, ktype, kinfo |
|---|
| 124 | CHARACTER*(*) cdport |
|---|
| 125 | c ---------------------------------------------------------------- |
|---|
| 126 | INTEGER (kind=ip_intwp_p) ip, id_nports, id_part, ierror |
|---|
| 127 | REAL(kind=ip_realwp_p) rl_testvar |
|---|
| 128 | REAL(kind=ip_double_p) dl_testvar |
|---|
| 129 | CHARACTER*32 cltest |
|---|
| 130 | c ---------------------------------------------------------------- |
|---|
| 131 | c |
|---|
| 132 | rl_testvar = 0.0_ip_realwp_p |
|---|
| 133 | dl_testvar = 0.0_ip_double_p |
|---|
| 134 | c |
|---|
| 135 | c* 1. check if this port already exist |
|---|
| 136 | c ----------------------------------- |
|---|
| 137 | c |
|---|
| 138 | cltest= cdport |
|---|
| 139 | c |
|---|
| 140 | DO ip=1,nports |
|---|
| 141 | IF (cltest.EQ.cports(ip).AND.kinout.EQ.myport(1,ip)) THEN |
|---|
| 142 | kinfo = PRISM_DoubleDef |
|---|
| 143 | WRITE(nulprt,FMT='(A,A)') |
|---|
| 144 | $ 'Def_var - WARNING - duplicate definition of port ', |
|---|
| 145 | $ cdport |
|---|
| 146 | GO TO 1010 |
|---|
| 147 | ENDIF |
|---|
| 148 | ENDDO |
|---|
| 149 | c |
|---|
| 150 | c* 2. save arguments as half a link |
|---|
| 151 | c -------------------------------- |
|---|
| 152 | c |
|---|
| 153 | nports = nports + 1 |
|---|
| 154 | id_nports = nports |
|---|
| 155 | DO il=1, ig_clim_nfield |
|---|
| 156 | IF (cltest.EQ.cg_cnaminp(il).or.cltest.eq.cg_cnamout(il)) THEN |
|---|
| 157 | IF (cltest .EQ. cg_cnaminp(il)) then |
|---|
| 158 | cga_clim_locator(nports) = cga_clim_locatorbf(il) |
|---|
| 159 | ELSE IF (cltest .EQ. cg_cnamout(il)) then |
|---|
| 160 | cga_clim_locator(nports) = cga_clim_locatoraf(il) |
|---|
| 161 | ENDIF |
|---|
| 162 | IF (ig_clim_state(il) .eq. ip_exported .or. |
|---|
| 163 | $ ig_clim_state(il) .eq. ip_expout .or. |
|---|
| 164 | $ ig_clim_state(il) .eq. ip_auxilary) THEN |
|---|
| 165 | cports(nports) = cltest |
|---|
| 166 | ig_def_lag(nports)=ig_clim_lag(il) |
|---|
| 167 | !AC |
|---|
| 168 | IF (cltest.EQ.cg_cnamout(il)) THEN |
|---|
| 169 | ig_def_reverse(nports)=ig_clim_reverse(il) |
|---|
| 170 | ELSEIF (cltest.EQ.cg_cnaminp(il)) THEN |
|---|
| 171 | ig_def_invert(nports)=ig_clim_invert(il) |
|---|
| 172 | ENDIF |
|---|
| 173 | !AC |
|---|
| 174 | ig_def_freq(nports)=ig_clim_freq(il) |
|---|
| 175 | ig_def_seq(nports)=ig_clim_seq(il) |
|---|
| 176 | cg_def_rstfile(nports)=cg_clim_rstfile(il) |
|---|
| 177 | ig_def_norstfile(nports)=ig_clim_norstfile(il) |
|---|
| 178 | ig_def_state(nports)=ig_clim_state(il) |
|---|
| 179 | ig_def_trans(nports)=ig_clim_trans(il) |
|---|
| 180 | cg_def_inpfile(nports)=cg_clim_inpfile(il) |
|---|
| 181 | !RV |
|---|
| 182 | ig_def_numlab(nports)=ig_clim_numlab(il) |
|---|
| 183 | !RV |
|---|
| 184 | ELSE |
|---|
| 185 | IF (ig_clim_state(il) .eq. ip_ignout) |
|---|
| 186 | $ cg_ignout_field(nports) = cltest |
|---|
| 187 | cports(nports) = cg_cnamout(il) |
|---|
| 188 | ig_def_lag(nports)=ig_clim_lag(il) |
|---|
| 189 | !AC |
|---|
| 190 | IF (cltest.EQ.cg_cnamout(il)) THEN |
|---|
| 191 | ig_def_reverse(nports)=ig_clim_reverse(il) |
|---|
| 192 | ELSEIF (cltest.EQ.cg_cnaminp(il)) THEN |
|---|
| 193 | ig_def_invert(nports)=ig_clim_invert(il) |
|---|
| 194 | ENDIF |
|---|
| 195 | !AC |
|---|
| 196 | ig_def_freq(nports)=ig_clim_freq(il) |
|---|
| 197 | ig_def_seq(nports)=ig_clim_seq(il) |
|---|
| 198 | cg_def_rstfile(nports)=cg_clim_rstfile(il) |
|---|
| 199 | ig_def_norstfile(nports)=ig_clim_norstfile(il) |
|---|
| 200 | ig_def_state(nports)=ig_clim_state(il) |
|---|
| 201 | ig_def_trans(nports)=ig_clim_trans(il) |
|---|
| 202 | cg_def_inpfile(nports)=cg_clim_inpfile(il) |
|---|
| 203 | !RV |
|---|
| 204 | ig_def_numlab(nports)=ig_clim_numlab(il) |
|---|
| 205 | !RV |
|---|
| 206 | ENDIF |
|---|
| 207 | ENDIF |
|---|
| 208 | ENDDO |
|---|
| 209 | c |
|---|
| 210 | IF (ig_def_freq(nports) .eq. 0) THEN |
|---|
| 211 | WRITE(nulprt,FMT=*) |
|---|
| 212 | $ 'Def_var - WARNING ' |
|---|
| 213 | WRITE(nulprt,FMT=*) |
|---|
| 214 | $ 'You have a file which is not defined in the namcouple ' |
|---|
| 215 | WRITE(nulprt,FMT=*) |
|---|
| 216 | $ 'This file will not be exchanged !' |
|---|
| 217 | GOTO 1010 |
|---|
| 218 | ELSEIF (ig_def_freq(nports) .gt. ig_ntime) THEN |
|---|
| 219 | WRITE(nulprt,FMT=*) |
|---|
| 220 | $ 'Def_var - WARNING ' |
|---|
| 221 | WRITE(nulprt,FMT=*) |
|---|
| 222 | $ 'You have a file defined with a coupling period greater ' |
|---|
| 223 | WRITE(nulprt,FMT=*) |
|---|
| 224 | $ 'than the time of the simulation. So, this file will not ' |
|---|
| 225 | WRITE(nulprt,FMT=*) |
|---|
| 226 | $ 'be exchanged !' |
|---|
| 227 | GOTO 1010 |
|---|
| 228 | ELSE |
|---|
| 229 | myport(1,nports) = kinout |
|---|
| 230 | myport(5,nports) = 0 |
|---|
| 231 | c |
|---|
| 232 | c IF ( ktype.EQ.CLIM_Integer ) THEN |
|---|
| 233 | c WRITE(nulprt,FMT=*) |
|---|
| 234 | c $ ' Communication with integer as type of data is not supported' |
|---|
| 235 | c call flush(nulprt) |
|---|
| 236 | c call MPI_ABORT (mpi_comm, 0, ierror) |
|---|
| 237 | c ELSEIF ( ktype.EQ.PRISM_Real ) THEN |
|---|
| 238 | IF ( ktype .EQ. PRISM_Real ) THEN |
|---|
| 239 | myport(2,nports) = PRISM_Real |
|---|
| 240 | myport(3,nports) = kind(rl_testvar) |
|---|
| 241 | c ELSEIF ( ktype.EQ.PRISM_Double ) THEN |
|---|
| 242 | c myport(2,nports) = PRISM_Double |
|---|
| 243 | c myport(3,nports) = kind(dl_testvar) |
|---|
| 244 | ELSE |
|---|
| 245 | kinfo = CLIM_BadType |
|---|
| 246 | WRITE(nulprt,FMT='(A,I4)') |
|---|
| 247 | $ 'Def_var - WARNING - Bad data type:',ktype |
|---|
| 248 | ENDIF |
|---|
| 249 | c |
|---|
| 250 | mydist (:,nports) = ig_def_part (:,id_part) |
|---|
| 251 | myport (4,nports) = ig_length_part (id_part) |
|---|
| 252 | ENDIF |
|---|
| 253 | c |
|---|
| 254 | c |
|---|
| 255 | c ---------------------------------------------------------------- |
|---|
| 256 | c |
|---|
| 257 | 1010 CONTINUE |
|---|
| 258 | CALL FLUSH(nulprt) |
|---|
| 259 | RETURN |
|---|
| 260 | END |
|---|
