 |
PUMA
219
Portable University Model of the Atmosphere
|
|
PUMA
219
Portable University Model of the Atmosphere
|
00001 ! *************************************************** 00002 ! * GUIMOD - Graphical User Interface Routines * 00003 ! * 21-Sep-2006 - Edilbert Kirk * 00004 ! *************************************************** 00005 ! * This file contains all interface routines for * 00006 ! * communication between model (PUMA or PLASIM) * 00007 ! * and the GUI routines in file "pumax.c". * 00008 ! * This file is identical for both models, if you * 00009 ! * make changes, make sure, that these either * 00010 ! * affect both models in a proper way or use the * 00011 ! * if (model == PUMA) ... endif * 00012 ! * if (model == PLASIM) ... endif * 00013 ! * statements. After changes copy the new version, * 00014 ! * so that ../puma/src/guimod.f90 and * 00015 ! * ../plasim/src/guimod.f90 are identical. * 00016 ! *************************************************** 00017 00018 subroutine guistart 00019 use pumamod 00020 00021 if (ngui == 0) return 00022 00023 call initgui(model,nguidbg,NLAT,mrpid,mrnum) 00024 00025 return 00026 end subroutine guistart 00027 00028 ! ================== 00029 ! SUBROUTINE GUISTOP 00030 ! ================== 00031 00032 subroutine guistop 00033 use pumamod 00034 00035 if (mypid == NROOT .and. ngui > 0) call guiclose 00036 00037 return 00038 end subroutine guistop 00039 00040 ! ======================= 00041 ! SUBROUTINE GUISTEP_PUMA 00042 ! ======================= 00043 00044 subroutine guistep_puma 00045 use pumamod 00046 00047 interface 00048 integer(kind=4) function iguistep(parc,idatim) 00049 real (kind=4), intent(inout) :: parc(*) 00050 integer(kind=4), intent(in) :: idatim(6) 00051 end function iguistep 00052 end interface 00053 00054 integer (kind=4) idatim(6) 00055 00056 nsyncold = nsync 00057 call mrsum(nsyncold) 00058 00059 if (mypid == NROOT) then 00060 parc(1) = disp 00061 parc(2) = dtep * CT; 00062 parc(3) = dtns * CT; 00063 parc(4) = nsync 00064 parc(5) = syncstr 00065 crap(:) = parc(:) 00066 idatim(:) = ndatim(:) 00067 nshutdown = iguistep(parc,idatim) ! GUI event handler 00068 if (parc(1) /= crap(1)) call change_disp(1) 00069 if (parc(2) /= crap(2)) call change_dtep(2) 00070 if (parc(3) /= crap(3)) call change_dtns(3) 00071 if (parc(4) /= crap(4)) call change_nsync(4) 00072 if (parc(5) /= crap(5)) call change_syncstr(5) 00073 endif 00074 00075 call mrsum(nshutdown) ! Any instance can signal shutdown 00076 call mpbci(nshutdown) 00077 call mpbcr(disp) 00078 00079 nsyncnew = nsync 00080 call mrsum(nsyncnew) ! Any instance can switch NSYNC 00081 if (nsyncnew > nsyncold) nsync = 1 00082 if (nsyncnew < nsyncold) nsync = 0 00083 00084 call mpbcl(ldtep) 00085 if (ldtep) then 00086 call mpbcr(dtep) ! broadcast changed value 00087 call mpscsp(sr1,srp1,NLEV) ! scatter changed array 00088 ldtep = .false. 00089 endif 00090 00091 call mpbcl(ldtns) 00092 if (ldtns) then 00093 call mpbcr(dtns) ! broadcast changed value 00094 call mpscsp(sr2,srp2,NLEV) ! scatter changed array 00095 ldtns = .false. 00096 endif 00097 00098 return 00099 end subroutine guistep_puma 00100 00101 ! ================ 00102 ! SUBROUTINE GUIPS 00103 ! ================ 00104 00105 subroutine guips(f,pmean) 00106 use pumamod 00107 real :: f(NLON,NLAT) 00108 real :: z(NLON,NLAT) 00109 real (kind=4) :: x(NLON+1,NLAT) 00110 00111 if (ngui == 0) return 00112 if (mypid == NROOT) then 00113 z(:,:) = f(:,:) 00114 call alt2reg(z,1) 00115 mlon = NLON/2 00116 pm = pmean * 0.01 ! [hPa] 00117 x( 1:mlon ,:) = z(mlon+1:NLON ,:) * pm 00118 x(mlon+1:NLON+1,:) = z( 1:mlon+1,:) * pm 00119 call guiput("GP" // char(0) ,x,NLON+1,NLAT,1) 00120 endif 00121 return 00122 end 00123 00124 ! ================= 00125 ! SUBROUTINE GUIHOR 00126 ! ================= 00127 00128 subroutine guihor(yname,f,klev,pm,pa) 00129 use pumamod 00130 character (len=*) :: yname 00131 real :: f(NLON,NLPP,klev) 00132 real :: z(NLON,NLAT,klev) 00133 real (kind=4) :: x(NLON+1,NLAT,klev) 00134 00135 if (ngui == 0) return 00136 00137 ! Incoming array f stores longitudes from 0 deg to (360 - delta lambda) 00138 ! GUI gets rotated array x stored from -180 deg to +180 deg 00139 00140 call mpgagp(z,f,klev) 00141 if (mypid == NROOT) then 00142 mlon = NLON/2 00143 x( 1:mlon ,:,:) = z(mlon+1:NLON ,:,:) * pm + pa 00144 x(mlon+1:NLON+1,:,:) = z( 1:mlon+1,:,:) * pm + pa 00145 call guiput(yname,x,NLON+1,NLAT,klev) 00146 endif 00147 return 00148 end 00149 00150 ! ================ 00151 ! SUBROUTINE GUIGV 00152 ! ================ 00153 00154 subroutine guigv(yname,f) 00155 use pumamod 00156 character (len=*) :: yname 00157 real :: f(NLON,NLPP,NLEV) 00158 real :: z(NLON,NLAT,NLEV) 00159 real (kind=4) :: x(NLON+1,NLAT,NLEV) 00160 00161 if (ngui == 0) return 00162 00163 call mpgagp(z,f,NLEV) 00164 if (model == PUMA) call alt2reg(z,NLEV) 00165 if (mypid == NROOT) then 00166 mlon = NLON/2 00167 do jlat = 1 , NLAT 00168 x( 1:mlon ,jlat,:) = z(mlon+1:NLON ,jlat,:) * CV * rcs(jlat) 00169 x(mlon+1:NLON+1,jlat,:) = z( 1:mlon+1,jlat,:) * CV * rcs(jlat) 00170 enddo 00171 call guiput(yname,x,NLON+1,NLAT,NLEV) 00172 endif 00173 return 00174 end 00175 00176 ! ================ 00177 ! SUBROUTINE GUIGT 00178 ! ================ 00179 00180 subroutine guigt(f) 00181 use pumamod 00182 real :: f(NLON,NLPP,NLEV) 00183 real :: z(NLON,NLAT,NLEV) 00184 real (kind=4) :: x(NLON+1,NLAT,NLEV) 00185 00186 if (ngui == 0) return 00187 00188 call mpgagp(z,f,NLEV) 00189 if (model == PUMA) call alt2reg(z,NLEV) 00190 if (mypid == NROOT) then 00191 mlon = NLON/2 00192 do jlon = 1 , mlon 00193 do jlat = 1 , NLAT 00194 x(jlon,jlat,:) = (z(jlon+mlon,jlat,:) + t0(:))*CT - 273.16 00195 enddo 00196 enddo 00197 do jlon = mlon+1,NLON+1 00198 do jlat = 1 , NLAT 00199 x(jlon,jlat,:) = (z(jlon-mlon,jlat,:) + t0(:))*CT - 273.16 00200 enddo 00201 enddo 00202 call guiput("GT" // char(0),x,NLON+1,NLAT,NLEV) 00203 endif 00204 return 00205 end 00206 00207 ! =================== 00208 ! SUBROUTINE GUIGVCOL 00209 ! =================== 00210 00211 subroutine guigvcol(yname,f,klon) 00212 use pumamod 00213 character (len=*) :: yname 00214 real :: f(NLON,NLPP,NLEV) 00215 real :: z(NLON,NLAT,NLEV) 00216 real (kind=4) :: x(NLEV,NLAT) 00217 00218 if (ngui == 0) return 00219 00220 call mpgagp(z,f,NLEV) 00221 if (mypid == NROOT) then 00222 do jlat = 1 , NLAT 00223 do jlev = 1 , NLEV 00224 x(jlev,jlat) = z(klon,jlat,jlev) * CV * rcs(jlat) 00225 enddo 00226 enddo 00227 call guiput(yname,x,NLEV,NLAT,1) 00228 endif 00229 return 00230 end 00231 00232 ! =================== 00233 ! SUBROUTINE GUIGTCOL 00234 ! =================== 00235 00236 subroutine guigtcol(f,klon) 00237 use pumamod 00238 real :: f(NLON,NLPP,NLEV) 00239 real :: z(NLON,NLAT,NLEV) 00240 real (kind=4) :: x(NLEV,NLAT) 00241 00242 if (ngui == 0) return 00243 00244 call mpgagp(z,f,NLEV) 00245 if (mypid == NROOT) then 00246 do jlat = 1 , NLAT 00247 do jlev = 1 , NLEV 00248 x(jlev,jlat) = z(klon,jlat,jlev) - TMELT 00249 enddo 00250 enddo 00251 call guiput("GTCOL" // char(0),x,NLEV,NLAT,1) 00252 endif 00253 return 00254 end 00255 00256 ! ==================== 00257 ! SUBROUTINE GUID3DCOL 00258 ! ==================== 00259 00260 subroutine guid3dcol(yname,f,klon,klev,pm,pa) 00261 use pumamod 00262 character (len=*) :: yname 00263 real :: f(NLON,NLPP,klev) 00264 real :: z(NLON,NLAT,klev) 00265 real (kind=4) :: x(NLEV,NLAT) 00266 00267 if (ngui == 0) return 00268 00269 call mpgagp(z,f,klev) 00270 if (mypid == NROOT) then 00271 do jlat = 1 , NLAT 00272 do jlev = 1 , NLEV 00273 x(jlev,jlat) = z(klon,jlat,jlev)*pm + pa 00274 enddo 00275 enddo 00276 call guiput(yname,x,NLEV,NLAT,1) 00277 endif 00278 return 00279 end 00280 00281 ! ======================= 00282 ! SUBROUTINE CHANGE_NSYNC 00283 ! ======================= 00284 00285 subroutine change_nsync(k) 00286 use pumamod 00287 write (*,7000) nstep,'NSYNC',crap(k),parc(k) 00288 nsync = parc(k) + 0.001 00289 return 00290 7000 format('Step',i8,': User changed ',a,' from ',f6.2,' to ',f6.2) 00291 end 00292 00293 ! ========================= 00294 ! SUBROUTINE CHANGE_SYNCSTR 00295 ! ========================= 00296 00297 subroutine change_syncstr(k) 00298 use pumamod 00299 write (*,7000) nstep,'SYNCSTR',crap(k),parc(k) 00300 syncstr = parc(k) 00301 return 00302 7000 format('Step',i8,': User changed ',a,' from ',f6.2,' to ',f6.2) 00303 end 00304 00305 ! ====================== 00306 ! SUBROUTINE CHANGE_DISP 00307 ! ====================== 00308 00309 subroutine change_disp(k) 00310 use pumamod 00311 write (*,7000) nstep,'DISP ',crap(k),parc(k) 00312 disp = parc(k) 00313 return 00314 7000 format('Step',i8,': User changed ',a,' from ',f6.2,' to ',f6.2) 00315 end 00316 00317 ! ====================== 00318 ! SUBROUTINE CHANGE_DTEP 00319 ! ====================== 00320 00321 subroutine change_dtep(k) 00322 use pumamod 00323 write (*,7000) nstep,'DTEP ',crap(k),parc(k) 00324 dtep = parc(k) / CT; 00325 zttrop = tgr-dtrop*ALR 00326 ztps = (zttrop/tgr)**(GA/(ALR*GASCON)) 00327 do jlev = 1 , NLEV 00328 zfac = sin(0.5*PI*(sigma(jlev)-ztps)/(1.-ztps)) 00329 if (zfac < 0.0) zfac = 0.0 00330 sr1(5,jlev) = -2.0/3.0 * sqrt(0.4) * dtep * zfac 00331 enddo 00332 ldtep = .true. 00333 return 00334 7000 format('Step',i8,': User changed ',a,' from ',f7.2,' to ',f7.2) 00335 end 00336 00337 ! ====================== 00338 ! SUBROUTINE CHANGE_DTNS 00339 ! ====================== 00340 00341 subroutine change_dtns(k) 00342 use pumamod 00343 write (*,7000) nstep,'DTNS ',crap(k),parc(k) 00344 dtns = parc(k) / CT; 00345 zttrop = tgr-dtrop*ALR 00346 ztps = (zttrop/tgr)**(GA/(ALR*GASCON)) 00347 do jlev = 1 , NLEV 00348 zfac = sin(0.5*PI*(sigma(jlev)-ztps)/(1.-ztps)) 00349 if (zfac < 0.0) zfac = 0.0 00350 sr2(3,jlev) = (1.0 / sqrt(6.0)) * dtns * zfac 00351 enddo 00352 ldtns = .true. 00353 return 00354 7000 format('Step',i8,': User changed ',a,' from ',f7.2,' to ',f7.2) 00355 end 00356 00357 00358 ! ======================== 00359 ! SUBROUTINE CHANGE_SELLON 00360 ! ======================== 00361 00362 subroutine change_sellon(k) 00363 use pumamod 00364 sellon = nint(parc(k) * NLON / 360.0 + 1.0) 00365 if (sellon < 1) sellon = 1 00366 if (sellon > NLON) sellon = NLON 00367 return 00368 end
