| PUMA 219 Portable University Model of the Atmosphere

- Main Page
- Data Types List
- Files

- File List
- File Members

/Users/home/WC/puma/src/guimod.f90
Go to the documentation of this file.

    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