text:
module latlon_lake_logger_mod

use netcdf
use check_return_code_netcdf_mod

implicit none

integer,parameter,private :: dp = selected_real_kind(12)

integer, parameter :: print_interval = 1000
integer, parameter :: first_logging_timestep = 99999
integer, parameter :: maximum_output_per_timestep = 10000
integer, parameter :: info_dump_timestep = 99999

type latlon_lake_logger
  integer :: timestep
  integer, dimension(print_interval,4) :: lake_process_log
  real(dp) :: lake_volumes(print_interval)
  character(len=30), dimension(print_interval) :: process_names
  integer :: log_position
  integer :: timestep_total_output
  logical :: logging_status
  contains
    procedure :: initialise_latlon_lake_logger
    procedure :: increment_timestep
    procedure :: log_process
    procedure :: print_log
    procedure :: create_info_dump
end type latlon_lake_logger

interface latlon_lake_logger
  procedure :: latlon_lake_logger_constructor
end interface latlon_lake_logger

type(latlon_lake_logger),pointer :: global_lake_logger

contains

subroutine initialise_latlon_lake_logger(this)
  class(latlon_lake_logger) :: this
    this%timestep = 0
    this%lake_process_log(:,:) = 0
    this%lake_volumes(:) = 0
    this%process_names(:) = ""
    this%logging_status = .false.
    this%log_position = 0
    this%timestep_total_output = 0
end subroutine initialise_latlon_lake_logger

subroutine increment_timestep(this)
  class(latlon_lake_logger) :: this
    this%timestep = this%timestep+1
    if (this%logging_status) then
        call this%print_log()
        write(*,'(A,I6)') "Running lake timestep: ",this%timestep
        this%timestep_total_output = 0
        this%lake_process_log(:,:) = 0
        this%lake_volumes(:) = 0
        this%process_names(:) = ""
        this%log_position = 0
    end if
    if (this%timestep > first_logging_timestep) then
      this%logging_status = .true.
      this%timestep_total_output = 0
    end if
end subroutine increment_timestep

subroutine create_info_dump(this,water_to_lakes,lake_volumes, &
                            nlat,nlon,nlat_coarse,nlon_coarse)
  class(latlon_lake_logger) :: this
  real(dp), dimension(:,:),pointer :: water_to_lakes
  real(dp), dimension(:,:),pointer :: lake_volumes
  integer ::  nlat,nlon,nlat_coarse,nlon_coarse
  character(len = *),parameter :: info_dump_filename = &
    "/Users/thomasriddick/Documents/data/temp/info_dump.nc"
  integer :: ncid,varid_volumes,varid_water_to_lakes
  integer :: lat_dimid,lon_dimid,lat_dimid_coarse,lon_dimid_coarse
  integer, dimension(2) :: dimids,dimids_coarse
    if(this%timestep == info_dump_timestep) then
        call check_return_code(nf90_create(info_dump_filename,nf90_noclobber,ncid))
        call check_return_code(nf90_def_dim(ncid, "lat",nlat,lat_dimid))
        call check_return_code(nf90_def_dim(ncid, "lon",nlon,lon_dimid))
        call check_return_code(nf90_def_dim(ncid, "lat_coarse",nlat_coarse,&
                                            lat_dimid_coarse))
        call check_return_code(nf90_def_dim(ncid, "lon_coarse",nlon_coarse,&
                                            lon_dimid_coarse))
        dimids = (/lat_dimid,lon_dimid/)
        dimids_coarse = (/lat_dimid_coarse,lon_dimid_coarse/)
        call check_return_code(nf90_def_var(ncid, "lake_volumes",&
                                            nf90_real, dimids,varid_volumes))
        call check_return_code(nf90_def_var(ncid, "water_to_lakes",&
                                            nf90_real, dimids_coarse,&
                                            varid_water_to_lakes))
        call check_return_code(nf90_enddef(ncid))
        call check_return_code(nf90_put_var(ncid,varid_volumes,lake_volumes))
        call check_return_code(nf90_put_var(ncid,varid_water_to_lakes,&
                                            water_to_lakes))
        call check_return_code(nf90_close(ncid))
    end if
    deallocate(lake_volumes)
end subroutine create_info_dump

subroutine log_process(this,lake_number,lake_center_lat,lake_center_lon, &
                       lake_type,lake_volume,process_name)
  class(latlon_lake_logger) :: this
  integer :: lake_number
  integer :: lake_center_lat
  integer :: lake_center_lon
  integer :: lake_type
  real(dp) :: lake_volume
  character(len=*) :: process_name
  character(len=30) :: process_name_fixed_length
    write(process_name_fixed_length,*) process_name
    if(this%logging_status) then
      this%log_position = this%log_position + 1
      this%timestep_total_output = this%timestep_total_output + 1
      this%lake_process_log(this%log_position,1) = lake_number
      this%lake_process_log(this%log_position,2) = lake_center_lat
      this%lake_process_log(this%log_position,3) = lake_center_lon
      this%lake_process_log(this%log_position,4) = lake_type
      this%lake_volumes(this%log_position) = lake_volume
      this%process_names(this%log_position) = process_name
      if (this%timestep_total_output >= maximum_output_per_timestep) then
        call this%print_log()
        write(*,*) "!!!Maximum printout length for a single timestep reached!!!"
        this%lake_process_log(:,:) = 0
        this%lake_volumes(:) = 0
        this%process_names(:) = ""
        this%log_position = 0
        this%logging_status = .false.
      else if (this%log_position >= print_interval) then
        call this%print_log()
        this%lake_process_log(:,:) = 0
        this%lake_volumes(:) = 0
        this%process_names(:) = ""
        this%log_position = 0
      end if
    end if
end subroutine

subroutine print_log(this)
  class(latlon_lake_logger) :: this
  integer :: i
    if (this%log_position > 0) then
      do i = 1,this%log_position
        write(*,'(4(X,I8),3X,ES14.7,3X,A)') this%lake_process_log(i,1),this%lake_process_log(i,2),&
                   this%lake_process_log(i,3),this%lake_process_log(i,4),&
                   this%lake_volumes(i),this%process_names(i)
      end do
    end if
end subroutine print_log

function latlon_lake_logger_constructor() result(constructor)
  type(latlon_lake_logger),pointer :: constructor
    allocate(constructor)
    call constructor%initialise_latlon_lake_logger()
end function latlon_lake_logger_constructor

subroutine setup_logger()
    global_lake_logger => latlon_lake_logger()
end subroutine setup_logger

subroutine increment_timestep_wrapper()
    call global_lake_logger%increment_timestep()
end subroutine increment_timestep_wrapper

subroutine log_process_wrapper(lake_number,lake_center_lat,lake_center_lon,&
                               lake_type,lake_volume,process_name)
  integer :: lake_number
  integer :: lake_center_lat
  integer :: lake_center_lon
  integer :: lake_type
  real(dp) :: lake_volume
  character(len=*) :: process_name
    call global_lake_logger%log_process(lake_number,lake_center_lat,&
                                        lake_center_lon,lake_type,&
                                        lake_volume,process_name)
end subroutine log_process_wrapper

subroutine create_info_dump_wrapper(water_to_lakes,lake_volumes, &
                                    nlat,nlon,nlat_coarse,nlon_coarse)
  real(dp), dimension(:,:),pointer :: water_to_lakes
  real(dp), dimension(:,:),pointer :: lake_volumes
  integer ::  nlat,nlon,nlat_coarse,nlon_coarse
    call global_lake_logger%create_info_dump(water_to_lakes,lake_volumes, &
                                             nlat,nlon,nlat_coarse,nlon_coarse)
end subroutine create_info_dump_wrapper

function is_logging()
  logical :: is_logging
    is_logging = global_lake_logger%logging_status
end function

end module latlon_lake_logger_mod

max_stars_repo_name: ThomasRiddick/DynamicHD

max_issues_repo_name: ThomasRiddick/DynamicHD

max_forks_repo_name: ThomasRiddick/DynamicHD


text:
program run_dStar
	use iso_fortran_env, only : error_unit
    use NScool_def
    use NScool_lib
    use argparse

    character(len=*), parameter :: default_dStar_dir = '../../dStar'
    character(len=*), parameter :: default_inlist_file = 'inlist'
    character(len=64) :: my_dStar_dir
    character(len=64) :: inlist
    type(NScool_info), pointer :: s=>null()
    integer :: ierr, NScool_id

    ierr = 0

    call command_arg_set( &
        & 'dStar_directory',"sets the main dStar root directory",ierr, &
        & flag='D',takes_parameter=.TRUE.)
    call check_okay('set command argument dStar_directory',ierr)

    call command_arg_set( &
        & 'inlist_file','sets the namelist parameter file',ierr, &
        & flag='I',takes_parameter=.TRUE.)
    call check_okay('set command argument inlist file',ierr)

    call parse_arguments(ierr)
    call check_okay('parse_arguments',ierr)

    my_dStar_dir = trim(get_command_arg('dStar_directory'))
    if (len_trim(my_dStar_dir)==0) my_dStar_dir = default_dStar_dir
    inlist = trim(get_command_arg('inlist_file'))
    if (len_trim(inlist)==0) inlist = default_inlist_file

    call NScool_init(my_dStar_dir, ierr)
    call check_okay('NScool_init',ierr)

    NScool_id = alloc_NScool(ierr)
    call check_okay('NScool_id',ierr)

    call NScool_setup(NScool_id,inlist,ierr)
    call check_okay('NScool_setup',ierr)

    call NScool_create_model(NScool_id,ierr)
    call check_okay('NScool_create_model',ierr)

    call NScool_evolve_model(NScool_id,ierr)
    call check_okay('NScool_evolve_model',ierr)

    call NScool_shutdown

contains
	subroutine check_okay(msg,ierr)
		character(len=*), intent(in) :: msg
		integer, intent(inout) :: ierr
		if (ierr /= 0) then
			write (error_unit,*) trim(msg)//': ierr = ',ierr
			if (ierr < 0) stop
		end if
	end subroutine check_okay
end program run_dStar

ext: f

max_stars_repo_name: LBJ-Wade/dStar

max_issues_repo_name: LBJ-Wade/dStar

max_forks_repo_name: LBJ-Wade/dStar


text:
      subroutine shift(ww,ww1,wwr,xx,xxc,volc,rlvc,revc)
c
c     ******************************************************************
c     *                                                                *
c     *   exchanges data for the next mesh                             *
c     *   with data in common blocks                                   *
c     *                                                                *
c     ******************************************************************
c
c     w(i,j,1)  = density
c     w(i,j,2)  = momentum in x direction
c     w(i,j,3)  = momentum in y direction
c     w(i,j,4)  = total energy
c
c     ******************************************************************
c
      use dims
      use dimsc
c
c     ******************************************************************
c
      use flo_var
      use mesh_var
      use solv_var
c
c     ******************************************************************
c
      use flo_param
      use mg_param
c
c     ******************************************************************
c
      implicit none
c
c     ******************************************************************
c
      real, dimension(0:iib,0:jjb,4)          :: ww
      real, dimension(iie,jje,4)              :: ww1,wwr
      real, dimension(iie,jje)                :: rlvc,revc
      real, dimension(iil,jjl,2)              :: xx
      real, dimension(0:iib,0:jjb,2)          :: xxc
      real, dimension(0:iib,0:jjb)            :: volc
c
c     ******************************************************************
c
c     local variables
c
c     ******************************************************************
c
      integer  :: i,j,n
c
c     ******************************************************************
c
      real     :: a
c
c     ******************************************************************
c
      do n=1,2
         do j=1,jjl
         do i=1,iil
            a         = x(i,j,n)
            x(i,j,n)  = xx(i,j,n)
            xx(i,j,n) = a
         end do
         end do
      end do

      if (mode.lt.0) return

      do n=1,2
         do j=1,jjb
         do i=1,iib
            a           = xc(i,j,n)
            xc(i,j,n)   = xxc(i,j,n)
            xxc(i,j,n)  = a
         end do
         end do
      end do

      do j=1,jjb
      do i=1,iib
         a         = vol(i,j)
         vol(i,j)  = volc(i,j)
         volc(i,j) = a
      end do
      end do

      do n=1,4
         do j=1,jjb
         do i=1,iib
            a         = w(i,j,n)
            w(i,j,n)  = ww(i,j,n)
            ww(i,j,n) = a
         end do
         end do
      end do

      do n=1,4
         do j=1,jje
         do i=1,iie
            a           = w1(i,j,n)
            w1(i,j,n)   = ww1(i,j,n)
            ww1(i,j,n)  = a
         end do
         end do
      end do

      do n=1,4
         do j=1,jje
         do i=1,iie
            a           = wr(i,j,n)
            wr(i,j,n)   = wwr(i,j,n)
            wwr(i,j,n)  = a
         end do
         end do
      end do

      if (kvis.gt.0) then
         do j=1,jje
         do i=1,iie
            a         = rlv(i,j)
            rlv(i,j)  = rlvc(i,j)
            rlvc(i,j) = a
         end do
         end do
      end if

      if (kvis.gt.1) then
         do j=1,jje
         do i=1,iie
            a         = rev(i,j)
            rev(i,j)  = revc(i,j)
            revc(i,j) = a
         end do
         end do
      end if

      return

      end

max_stars_repo_name: AlexT-L/RANS

max_issues_repo_name: AlexT-L/RANS

max_forks_repo_name: AlexT-L/RANS


text:
Fleet Feet is a specialty running store that provides expert advice regarding all aspects of Running running.  They offer a free Shoe Stores & Repair footwear fitting service to help you choose the best pair of running shoes based on your foot size, gait pattern, and biomechanical needs. Information and clinics are also available on a range of topics including nutrition and running for beginners.  Fleet Feet Davis hosts training sessions for the local Davis chapter of the Roadrunners Club, the Golden Valley Harriers, and are free and open to the public.  They also offer training sessions for walkers.  Fleet Feet Davis has a mailing list to keep runners up to date on clinics, training sessions, new products, sales and upcoming races.  They also have a free personal rewards program that for every $250 you spend in the store over any length of time you get a free $25 in store credit.  There is no card to carry or no cost to join, your purchases are tracked in the computer by your name and phone number. Your purchases and any other personal information are kept confidential.

Fleet Feet offers excellent marathon and half marathon training programs. The fall program trains for the http://www.sacramentocowtownmarathon.com/ Cowtown Half Marathon, run in Sacramento in October, and the http://www.runcim.org/ California International Marathon, run from Folsom to the Capitol the first Sunday in December. The winter program trains for the http://www.fleetfeetsacramento.com/shamrocknhalfmarathon5km Shamrockn Half Marathon, run in Sacramento in March. The group meets twice a week for coached workoutsTuesdays at 6:00 PM for a shorter, speed session, and Saturdays at 8:00 AM, for a long run. With enrollment, participants get a training schedule and information packet, a noncotton technical running shirt, $10 off a pair of shoes at Fleet Feet Davis and $5 off a sports bra (for the ladies), plus additional perks and goodies.

Media
http://www.davislifemagazine.com/2010/03/runningforwomen/ Read a Running for Women story in a March 2010 post by Davis Life Magazine.

4/17/06 You will pay as much for sneakers here as you would at most mall shops or upscale department stores.  The difference is you will walk out with the best shoes for your feet and activity.  I spent $90ish on a pair of running shoes, but we went through six or seven different pairs, with me running up and down the street in each pair so the shoe guy could better define which would keep me from bashing the hell out of my knees and ankles.  After all this we talked about proper stretching and how to alter my warmup routine to take my own needs into account.  $90 sounds like a lot of money, but $90 and over a half hour of trying and testing may save me who knows how much more in money on orthopedic repair down the road.  Get into their database as a customer, and for every $250 you spend they give you $25 in instore credit. Users/BlancheNonken

I bought some running shoes here 2 years ago, they make you run to past the avid reader and back to look at your form. Service was pretty good.  Users/StevenDaubert

20080623 19:47:03 nbsp does anyone know their return policy Users/MattHh

20090210 12:23:47 nbsp Highly recommend. I went to the store just as they were closing and the staff (I think it was the owner) stayed open an extra 20 minutes to help me. The service was great. She took plenty of time to fit my feet and talk to me about what I needed. I ended up with a great pair of shoes that I couldnt be happier with. I will definitely go back next time I need running shoes. I dont think the price is higher here than at other comparable stores. They may be more expensive than a Big 5 or Sports Authority, but thats because you get what you pay for. If you pay more here youre going to get a better pair of shoes that will feel better when you run and last longer.  Users/BethanyHelmboldt

20090620 17:42:15 nbsp This place is great. Excellent customer service: informed and very attentive. Users/jsg718

20091226 19:27:23 nbsp I bought some pretty awesome socks for my jogging better half here! Users/StevenDaubert

20100324 13:25:19 nbsp I absolutely love this store. You get a $25 gift certifcate for every $200 you spend...just ask them about it. Users/anaxor

20101023 13:59:48 nbsp I went to this place today and was very pleased with the customer service. The sneakers I got out with are great and not more expensive than the prices I had seen in other equivalent stores. The salesperson spent about 20 minutes helping me figure out what shoes were appropriate for me. He observed me running on the sidewalk and looked at the pattern of wearing on my old pair of sneakers to help me make an informed decision. The store will give you U$25 credit after you spend U$ 200 and seem to have a fair return policy (though I have not tried to return anything to validate this information).  Users/AlessandraRung

20110205 11:34:25 nbsp Just stopped in here for a knee strap. It was totally buzzing (there was a sale going on), but the customer service was still really impressive!! It took less than 5 seconds before someone approached me to help. He took his time helping me out, explaining the options, etc., before I found the right thing. Another employee (possibly the owner?) even apologized when I had to wait about a minute for a cashier. Great service, and the strap wouldnt have been any cheaper at Big 5, but would have been lower quality. Users/MeganCleary

20110417 16:36:13 nbsp I went here today to find some track spikes for me since I am on the Harper Track Team. The woman there was super helpful and she found me 3 pairs of shoes to try on. She let me know what to look for, and how I should improve my speed/jump. She set me up with some New Balance 500 cleats and they are AMAZING! She also found me a pair of socks to go with them. And she put the spikes on for me! for free!  Users/Churro615

   Putting the spikes in, is like taking a breath, it is that easy.
   Nikhil

20111031 06:46:15 nbsp Love this place!  Miracles happen here! Users/AshleyHamidi

20111223 21:46:12 nbsp This store came highly recommended to me by a physical therapist.  I bought a great pair of comfortable, affordable walking shoes here.  The people who work here have an astounding knowledge of shoes and the bodies and their feet that go in them.  They watched me walk down to the corner and back in a few pairs and really guided me in the fitting process.  I didnt realize Fleet Feet offered so many info sessions and training workshops until I read this page.  I plan to check them out.  Great shoes, great people! Users/ActionFigureBarbie

20120123 20:28:23 nbsp The people at Fleet Feet are likely the nicest people I have ever dealt with. They really take their time to find you what you need and dont try to sell you stuff you dont. I have been in the shop numerous times over the past few months as Ive started my running career and they have been so supremely helpful that I cant even put into words how happy I am with the service Ive gotten there. YOU GUYS ROCK. Users/Hastings1066

20120320 12:49:11 nbsp Before you purchase anything there, check the prices on other sports stores also in Davis. You will be surprised. Not to mention online prices for tings. I was looking into a belt to hold water for running and the one I liked cost 47 bucks in this store. At amazon, it cost 27. I understand that we need to support the local business, but to which extend are we morally obliged to enrich the pockets of those who want to overcharge for certain items?
 Users/AChaves
 It is not uncommon for some items to be on Amazon at nearly wholesale. $27 is probably a little more than the wholesale price. Brickandmortar stores often run into this. Nobody could make a living selling things at slightly above wholesale in a physical walkin retail location. I suppose regular retailers could just discontinue carrying things that are sold nearly at cost on Amazon, so you could do all of your shopping online. But they arent overcharging when retailers use industrystandard markups. Yeah, you can find things cheaper online sometimes. Of course, dont forget the shipping costs youll pay. Users/DonShor
  You might also find interesting http://www.mcall.com/news/local/mcallentownamazoncomplaints20110917,0,7937001,full.story this article about one of the ways in which Amazon is able to keep its prices low, namely, by mistreating its workers.   Users/CovertProfessor

20120509 22:36:35 nbsp Fleet feet is the place to go for good running shoes.  I tend to alternate between Fleet Feet and purchasing shoes online, since FF is a bit on the pricey side, but year or two its worth going in to try on some new stuff and make sure youre still going with the best fit, comfort, and durability.  I switched to a new model of Asics today after the salesperson recommended it, and I absolutely love them so far.  Quite a bit more cushion than what Ive been using, which may help with some occasional knee trouble that pops up after long runs.  It certainly doesnt hurt that the service is extremely friendly. Users/TomGarberson

20120516 20:00:39 nbsp DonShor, I paid no shipping costs. My point is that Fleet Feet is selling a product for MUCH more than you can get at Amazon. Not just a bit more, which I would be willing to pay to have a business running in my town. How can Fleet Feet survive the competition? I came by the other day and the product is still selling for... 20 bucks more. Give me a break.
 Users/AChaves
  Sunset Western Garden Book just came out with a new edition. It is prepriced at MSR $34.99. I would pay $20.99 wholesale. Amazon is selling it for $21.63. How much would you suggest I retail it for? Should I sell it at all? Users/DonShor

  You also pay for the service and fitting. A professional fitting like they are able to provide is well worth the premium you pay on the shoes. I havent been to the Fleet Feet in Davis but Ive been to several others in the chain, and they are all quite popular. Some people go there to get a shoe fitted and then dont buy. Very cheap, and a little dishonest. Users/TheOneElectronic

20130622 15:45:26 nbsp I had an excellent experience here today. The person assisting me, Aisha, was friendly and very knowledgable about products for walking and running. I would highly recommend going here if you want to be fitted for running shoes. Users/JocelynW

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
      SUBROUTINE tetr(dvol,x,xcen)
!---------------------------------------------------
!***  calculates volume of a tetrahedral
!---------------------------------------------------

      IMPLICIT NONE

      REAL(kind=8):: dvol,x(3,3),xcen(3)

      REAL(kind=8) :: x1(3),x2(3),x3(3),xp(3)

      X1(:) = X(:,2)-X(:,1)
      X2(:) = X(:,3)-X(:,1)
      X3(:) = X(:,1)-XCEN(:)
      CALL vecpro(x1,x2,xp)
      dvol = DOT_PRODUCT(x3,xp)
      dvol = dvol/6.d0

      END SUBROUTINE tetr

max_stars_repo_name: jerebenitez/IFE-simpact-openfoam

max_issues_repo_name: jerebenitez/IFE-simpact-openfoam

max_forks_repo_name: jerebenitez/IFE-simpact-openfoam


text: #redirect CommuniCare Health Center


text:
C  CALL SUBROUTINE FST2SAC1 TO GET SAC-SMA MOISTURE STATES
C
      SUBROUTINE FRZ2SAC1(PX,ZSOIL,SMC,SH2O,NUPL,NSAC,SWLT,RTUZ,RTLZ,
     +           FRZST,SACST,FROST, HRAPX,HRAPY)

      PARAMETER (FRST_FACT = 5.0)
      REAL ZSOIL(*),SMC(*),SH2O(*),FRZST(*),SACST(*)
      REAL LZTWC,LZFSC,LZFPC,LZTWH,LZFSH,LZFPH

C--      COMMON/FSMCO1/UZTWC,UZFWC,LZTWC,LZFSC,LZFPC,ADIMC,FGCO(6),RSUM(7),
C--     1           PPE,PSC,PTA,PWE,PSH,TSOIL(8)
C--      COMMON/FRZCNST/ FRST_FACT,ZBOT

C  GET UPPER ZONE STATES
      UZTWH=FRZST(6)
      UZFWH=FRZST(7)
      UZTWC=SACST(1)
      UZFWC=SACST(2)
      XH=0.
      XC=0.

c      WRITE( *, *) 'UZFWH = ', UZFWH, ' UZFWC = ', UZFWC, ' UZTWH = ',
c     + UZTWH
      CALL FST2SAC1(ZSOIL,SMC,SH2O,2,NUPL,SWLT,RTUZ,UZTWH,UZFWH,XH,
     +              UZTWC,UZFWC,XC,FROST1,PX, HRAPX,HRAPY)

      IF(FROST1 .EQ. 0.) THEN
       FROST=0.
      ELSE
       FROST=-FROST1/FRST_FACT
      ENDIF
      FRZST(6)=UZTWH
      FRZST(7)=UZFWH

C  GET LOWER ZONE STATES
      LZTWH=FRZST(8)
      LZFSH=FRZST(9)
      LZFPH=FRZST(10)
      LZTWC=SACST(3)
      LZFSC=SACST(4)
      LZFPC=SACST(5)
      NUP=NUPL+1

      CALL FST2SAC1(ZSOIL,SMC,SH2O,NUP,NSAC,SWLT,RTLZ,LZTWH,LZFSH,
     +              LZFPH,LZTWC,LZFSC,LZFPC,FROST2,0., HRAPX,HRAPY)

      IF(FROST2 .NE. 0.) FROST=FROST-FROST2/FRST_FACT
      FRZST(8)=LZTWH
      FRZST(9)=LZFSH
      FRZST(10)=LZFPH

      RETURN
      END

max_stars_repo_name: KathyNie/LISF

max_issues_repo_name: dmocko/LISF

max_forks_repo_name: dmocko/LISF


text:
C
C      $Id: cn10f.f,v 1.8 2010-03-15 22:49:23 haley Exp $
C
C***********************************************************************
C                                                                      *
C                Copyright (C)  1995                                   *
C        University Corporation for Atmospheric Research               *
C     The use of this Software is governed by a License Agreement      *
C                                                                      *
C***********************************************************************
C
C   File:       cn10f.f
C
C   Author:     Fred Clare (converted to Fortran by Mary Haley)
C           National Center for Atmospheric Research
C           PO 3000, Boulder, Colorado
C
C   Date:       Mon Sep 25 16:07:14 MDT 1995
C
C   Description:    Reads a netCDF file and produces five plots:
C
C                      1.)  A quick-and-dirty contour plot.
C                      2.)  An improved contour plot.
C                      3.)  A contour plot of a sub-area of plot 2.)
C                      4.)  An XyPlot that is a slice through the
C                           the contoured area in 2.)
C                      5.)  An overlay of the contour plot in 2.) on
C                           an MapPlot object.
C
      external NhlFAppClass
      external NhlFNcgmWorkstationClass
      external NhlFPSWorkstationClass
      external NhlFPDFWorkstationClass
      external NhlFCairoPSPDFWorkstationClass
      external NhlFCairoImageWorkstationClass
      external NhlFCairoWindowWorkstationClass
      external NhlFScalarFieldClass
      external NhlFCoordArraysClass
      external NhlFContourPlotClass
      external NhlFMapPlotClass
      external NhlFXyPlotClass
C
C Define the maximum number of colors.
C
      parameter(NCOLORS=27)
C
C Declare variables for the HLU routine calls.
C
      integer appid, work_id, field1, field2, con1, con2
      integer dataspec, mapid, y_dataid, xy_id
      integer srlist, grlist, i
      real ymin, ymax, special_value
      data special_value/-9999./
C
C Declare variables for defining color map.
C
      integer length(2), colors(13)
      real cmap(3,NCOLORS)
C
C Declare variables for getting information from netCDF file.
C
      integer ncid, mnd_id, xdim_id, ydim_id
      real mound(18,15), mound2(5,5), xdim(20), ydim(20)
      integer start(2), count(2), xlen, ylen, flen
      character*256 filename
      character*50 recname

      character*7  wks_type
C
C Define the workstation type
C
      wks_type = "x11"
C
C
C Initialize the HLU library and set up resource template.
C
      call NhlFInitialize
      call NhlFRLCreate(srlist,'setrl')
C
C Modify the color map.  Color indices '1' and '2' are the background
C and foreground colors respectively.
C
      cmap(1, 1) = 1.00
      cmap(2, 1) = 1.00
      cmap(3, 1) = 1.00
      cmap(1, 2) = 0.00
      cmap(2, 2) = 0.00
      cmap(3, 2) = 0.00
      cmap(1, 3) = 0.00
      cmap(2, 3) = 0.15
      cmap(3, 3) = 1.00
      cmap(1, 4) = 0.00
      cmap(2, 4) = 0.05
      cmap(3, 4) = 1.00
      cmap(1, 5) = 0.04
      cmap(2, 5) = 0.00
      cmap(3, 5) = 1.00
      cmap(1, 6) = 0.14
      cmap(2, 6) = 0.00
      cmap(3, 6) = 1.00
      cmap(1, 7) = 0.24
      cmap(2, 7) = 0.00
      cmap(3, 7) = 1.00
      cmap(1, 8) = 0.34
      cmap(2, 8) = 0.00
      cmap(3, 8) = 1.00
      cmap(1, 9) = 0.43
      cmap(2, 9) = 0.00
      cmap(3, 9) = 1.00
      cmap(1,10) = 0.53
      cmap(2,10) = 0.00
      cmap(3,10) = 1.00
      cmap(1,11) = 0.63
      cmap(2,11) = 0.00
      cmap(3,11) = 1.00
      cmap(1,12) = 0.73
      cmap(2,12) = 0.00
      cmap(3,12) = 1.00
      cmap(1,13) = 0.83
      cmap(2,13) = 0.00
      cmap(3,13) = 1.00
      cmap(1,14) = 0.92
      cmap(2,14) = 0.00
      cmap(3,14) = 1.00
      cmap(1,15) = 1.00
      cmap(2,15) = 0.00
      cmap(3,15) = 0.98
      cmap(1,16) = 1.00
      cmap(2,16) = 0.00
      cmap(3,16) = 0.88
      cmap(1,17) = 1.00
      cmap(2,17) = 0.00
      cmap(3,17) = 0.78
      cmap(1,18) = 1.00
      cmap(2,18) = 0.00
      cmap(3,18) = 0.68
      cmap(1,19) = 1.00
      cmap(2,19) = 0.00
      cmap(3,19) = 0.59
      cmap(1,20) = 1.00
      cmap(2,20) = 0.00
      cmap(3,20) = 0.49
      cmap(1,21) = 1.00
      cmap(2,21) = 0.00
      cmap(3,21) = 0.39
      cmap(1,22) = 1.00
      cmap(2,22) = 0.00
      cmap(3,22) = 0.29
      cmap(1,23) = 1.00
      cmap(2,23) = 0.00
      cmap(3,23) = 0.20
      cmap(1,24) = 1.00
      cmap(2,24) = 0.00
      cmap(3,24) = 0.10
      cmap(1,25) = 1.00
      cmap(2,25) = 0.00
      cmap(3,25) = 0.00
C
C  Colors used for labels.
C
      cmap(1,26) = 0.00
      cmap(2,26) = 0.00
      cmap(3,26) = 0.00
      cmap(1,27) = 0.40
      cmap(2,27) = 0.00
      cmap(3,27) = 0.40
      length(1) = 3
      length(2) = NCOLORS
C
C Create Application object.  The Application object name is used to
C determine the name of the resource file, which is "cn10.res" in
C this case.
C
      call NhlFRLClear(srlist)
      call NhlFRLSetString(srlist,'appDefaultParent','True',ierr)
      call NhlFRLSetString(srlist,'appUsrDir','./',ierr)
      call NhlFCreate(appid,'cn10',NhlFAppClass,0,srlist,ierr)

      if (wks_type.eq."ncgm".or.wks_type.eq."NCGM") then
C
C Create an NCGM workstation.
C
         call NhlFRLClear(srlist)
         call NhlFRLSetString(srlist,'wkMetaName','./cn10f.ncgm',ierr)
         call NhlFRLSetMDFloatArray(srlist,'wkColorMap',cmap,2,length,
     +        ierr)
         call NhlFCreate(work_id,'cn10Work',
     +        NhlFNcgmWorkstationClass,0,srlist,ierr)
      else if (wks_type.eq."x11".or.wks_type.eq."X11") then
C
C Create an X11 workstation.
C
         call NhlFRLClear(srlist)
         call NhlFRLSetString(srlist,'wkPause','True',ierr)
         call NhlFRLSetMDFloatArray(srlist,'wkColorMap',cmap,2,length,
     +        ierr)
         call NhlFCreate(work_id,'cn10Work',
     +        NhlFCairoWindowWorkstationClass,
     +        0,srlist,ierr)
      else if (wks_type.eq."oldps".or.wks_type.eq."OLDPS") then
C
C Create an older-style PostScript workstation.
C
         call NhlFRLClear(srlist)
         call NhlFRLSetString(srlist,'wkPSFileName','./cn10f.ps',ierr)
         call NhlFRLSetMDFloatArray(srlist,'wkColorMap',cmap,2,length,
     +        ierr)
         call NhlFCreate(work_id,'cn10Work',
     +        NhlFPSWorkstationClass,0,srlist,ierr)
      else if (wks_type.eq."oldpdf".or.wks_type.eq."OLDPDF") then
C
C Create an older-style PDF workstation.
C
         call NhlFRLClear(srlist)
         call NhlFRLSetString(srlist,'wkPDFFileName','./cn10f.pdf',ierr)
         call NhlFRLSetMDFloatArray(srlist,'wkColorMap',cmap,2,length,
     +        ierr)
         call NhlFCreate(work_id,'cn10Work',
     +        NhlFPDFWorkstationClass,0,srlist,ierr)
      else if (wks_type.eq."pdf".or.wks_type.eq."PDF".or.
     +         wks_type.eq."ps".or.wks_type.eq."PS") then
C
C Create a cairo PS/PDF workstation.
C
         call NhlFRLClear(srlist)
         call NhlFRLSetString(srlist,'wkFileName','./cn10f',ierr)
         call NhlFRLSetString(srlist,'wkFormat',wks_type,ierr)
         call NhlFRLSetMDFloatArray(srlist,'wkColorMap',cmap,2,length,
     +        ierr)
         call NhlFCreate(work_id,'cn10Work',
     +        NhlFCairoPSPDFWorkstationClass,0,srlist,ierr)
      else if (wks_type.eq."png".or.wks_type.eq."PNG") then
C
C Create a cairo PNG workstation.
C
         call NhlFRLClear(srlist)
         call NhlFRLSetString(srlist,'wkFileName','./cn10f',ierr)
         call NhlFRLSetString(srlist,'wkFormat',wks_type,ierr)
         call NhlFRLSetMDFloatArray(srlist,'wkColorMap',cmap,2,length,
     +        ierr)
         call NhlFCreate(work_id,'cn10Work',
     +        NhlFCairoImageWorkstationClass,0,srlist,ierr)
      endif
C
C Open the netCDF file.
C
      call gngpat(filename,'data',ierr)
      flen = 13
      do 10 i=1,256
         if( filename(i:i).eq.char(0) ) then
            filename(i:i+flen)='/cdf/cn10n.cdf'
            goto 15
         endif
 10   continue
C
C The second argument to 'ncopn' should be NCNOWRIT, but since we
C can't include 'netcdf.inc', we are using the value '0' instead.
C
 15   ncid = ncopn(filename,0,ierr)
C
C Get the mound length.
C
      xdim_id = ncdid(ncid,'xdim',ierr)
      ydim_id = ncdid(ncid,'ydim',ierr)
      mnd_id = ncvid(ncid,'mound',ierr)
      call ncdinq(ncid,xdim_id,recname,xlen,ierr)
      call ncdinq(ncid,ydim_id,recname,ylen,ierr)
      xdim_id = ncvid(ncid,'xdim',ierr)
      ydim_id = ncvid(ncid,'ydim',ierr)
C
C Get data and dimentions values for the mound.
C
      start(1) = 1
      start(2) = 1
      count(1) = ylen
      count(2) = xlen
      call ncvgt(ncid,mnd_id,start,count,mound,ierr)
      count(1) = xlen
      call ncvgt(ncid,xdim_id,start,count,xdim,ierr)
      count(1) = ylen
      call ncvgt(ncid,ydim_id,start,count,ydim,ierr)
C
C Create a data field.
C
      count(1) = ylen
      count(2) = xlen
      call NhlFRLClear(srlist)
      call NhlFRLSetMDFloatArray(srlist,'sfDataArray',mound,2,count,
     +     ierr)
      call NhlFRLSetFloat(srlist,'sfMissingValueV',special_value,ierr)
      call NhlFRLSetFloat(srlist,'sfXCStartV',ydim(1),ierr)
      call NhlFRLSetFloat(srlist,'sfXCEndV',ydim(ylen),ierr)
      call NhlFRLSetFloat(srlist,'sfYCStartV',xdim(1),ierr)
      call NhlFRLSetFloat(srlist,'sfYCEndV',xdim(xlen),ierr)
      call NhlFCreate(field1,'field1',nhlfscalarfieldclass,appid,srlist,
     +     ierr)
C
C Create a ContourPlot object using the above data field.
C
      call NhlFRLClear(srlist)
      call NhlFRLSetInteger(srlist,'cnScalarFieldData',field1,ierr)
      call NhlFRLSetFloat(srlist,'vpXF',0.15,ierr)
      call NhlFRLSetFloat(srlist,'vpYF',0.9,ierr)
      call NhlFRLSetFloat(srlist,'vpWidthF',0.79,ierr)
      call NhlFRLSetFloat(srlist,'vpHeightF',0.79,ierr)
      call NhlFCreate(con1,'con1',nhlfcontourplotclass,work_id,srlist,
     +     ierr)
C
C Picture 1:  A quick-and-dirty contour plot.
C
      call NhlFDraw(con1,ierr)
      call NhlFFrame(work_id,ierr)
C
C Picture 2:  An improved contour plot.
C
      call NhlFRLClear(srlist)
      call NhlFRLSetString(srlist,'cnFillOn','True',ierr)
      call NhlFRLSetString(srlist,'cnMonoFillColor','False',ierr)
      call NhlFRLSetFloat(srlist,'cnLevelSpacingF',2.0,ierr)
      call NhlFRLSetFloat(srlist,'cnLevelSpacingF',2.0,ierr)
      call NhlFRLSetString(srlist,'cnSmoothingOn','True',ierr)
      call NhlFRLSetFloat(srlist,'cnMaxPointDistanceF',0.0,ierr)
      call NhlFRLSetInteger(srlist,'cnLineColor',0,ierr)
      call NhlFRLSetInteger(srlist,'cnLineLabelFontColor',25,ierr)
      call NhlFRLSetInteger(srlist,'cnLineLabelFont',22,ierr)
      call NhlFRLSetFloat(srlist,'cnLineLabelFontHeightF',.02,ierr)
      call NhlFRLSetInteger(srlist,'cnLineLabelInterval',3,ierr)
      call NhlFRLSetString(srlist,'cnLineLabelPlacementMode','COMPUTED',
     +     ierr)
      call NhlFRLSetInteger(srlist,'cnHighLabelFont',22,ierr)
      call NhlFRLSetFloat(srlist,'cnHighLabelFontHeightF',.025,ierr)
      call NhlFRLSetInteger(srlist,'cnHighLabelFontColor',25,ierr)
      call NhlFRLSetString(srlist,'cnInfoLabelOn','False',ierr)

      call NhlFRLSetInteger(srlist,'tmXBMinorPerMajor',2,ierr)

      call NhlFRLSetInteger(srlist,'tmYLMajorLineColor',26,ierr)
      call NhlFRLSetInteger(srlist,'tmYLMinorLineColor',26,ierr)
      call NhlFRLSetFloat(srlist,'tmYLMinorThicknessF',2.,ierr)
      call NhlFRLSetInteger(srlist,'tmXBMajorLineColor',26,ierr)
      call NhlFRLSetInteger(srlist,'tmXBMinorLineColor',26,ierr)
      call NhlFRLSetFloat(srlist,'tmXBMinorThicknessF',2.,ierr)

      call NhlFRLSetInteger(srlist,'tmXBLabelFont',21,ierr)
      call NhlFRLSetFloat(srlist,'tmXBLabelFontHeightF',.03,ierr)
      call NhlFRLSetInteger(srlist,'tmXBLabelFontColor',26,ierr)

      call NhlFRLSetInteger(srlist,'tmYLLabelFont',21,ierr)
      call NhlFRLSetFloat(srlist,'tmYLLabelFontHeightF',.03,ierr)
      call NhlFRLSetInteger(srlist,'tmYLLabelFontColor',26,ierr)

      call NhlFRLSetInteger(srlist,'tmBorderLineColor',26,ierr)

      call NhlFRLSetString(srlist,'tiMainOn','True',ierr)
      call NhlFRLSetInteger(srlist,'tiMainFont',26,ierr)
      call NhlFRLSetFloat(srlist,'tiMainFontHeightF',.04,ierr)
      call NhlFRLSetString(srlist,'tiMainString','The Hot Zone',ierr)
      call NhlFRLSetFloat(srlist,'tiMainOffsetYF',-0.025,ierr)
      call NhlFRLSetInteger(srlist,'tiMainFontColor',26,ierr)
      call NhlFSetValues(con1,srlist,ierr)
      call NhlFDraw(con1,ierr)
      call NhlFFrame(work_id,ierr)
C
C Picture 3:  Zero in on the top of the mound.
C
      start(1) = 5
      start(2) = 3
      count(1) = 5
      count(2) = 5
      call ncvgt(ncid,mnd_id,start,count,mound2,ierr)

      call NhlFRLClear(srlist)
      call NhlFRLSetMDFloatArray(srlist,'sfDataArray',mound2,2,count,
     +     ierr)
      call NhlFRLSetFloat(srlist,'sfXCStartV',-20.,ierr)
      call NhlFRLSetFloat(srlist,'sfXCEndV',20.,ierr)
      call NhlFRLSetFloat(srlist,'sfYCStartV', -20.,ierr)
      call NhlFRLSetFloat(srlist,'sfYCEndV',20.,ierr)
      call NhlFSetValues(field1,srlist,ierr)

      call NhlFRLClear(srlist)
      call NhlFRLSetString(srlist,'tiMainString','A closer look',ierr)
      call NhlFRLSetInteger(srlist,'tmXBMinorPerMajor',4,ierr)
      call NhlFRLSetInteger(srlist,'tmYLMinorPerMajor',4,ierr)
      call NhlFRLSetFloat(srlist,'cnLevelSpacingF',0.15,ierr)
      do 20 i = 1,11
         colors(i) = i+8
 20   continue
      colors(12) = 21
      colors(13) = 23
      call NhlFRLSetIntegerArray(srlist,'cnFillColors',colors,13,ierr)
      call NhlFSetValues(con1,srlist,ierr)
      call NhlFDraw(con1,ierr)
      call NhlFFrame(work_id,ierr)
C
C Picture 4:  Plot an XyPlot of X values for a specific Y value.
C
      call NhlFRLClear(srlist)
      call NhlFRLSetFloatArray(srlist,'caXArray',ydim,ylen,ierr)
      call NhlFRLSetFloatArray(srlist,'caYArray',mound(1,6),ylen,ierr)
      call NhlFCreate(y_dataid,'xyData',nhlfcoordarraysclass,appid,
     +     srlist,ierr)

      call NhlFRLClear(srlist)
      call NhlFRLSetFloat(srlist,'vpXF',.2,ierr)
      call NhlFRLSetFloat(srlist,'vpYF',.85,ierr)
      call NhlFRLSetFloat(srlist,'vpWidthF',.7,ierr)
      call NhlFRLSetFloat(srlist,'vpHeightF',.7,ierr)

      call NhlFRLSetString(srlist,'xyComputeYMax','False',ierr)
      call NhlFRLSetString(srlist,'xyComputeYMin','False',ierr)

      call NhlFRLSetString(srlist,'tiMainOn','True',ierr)
      call NhlFRLSetInteger(srlist,'tiMainFont',26,ierr)
      call NhlFRLSetFloat(srlist,'tiMainFontHeightF',.0275,ierr)
      call NhlFRLSetString(srlist,'tiMainString','For X = 10.',ierr)
      call NhlFRLSetFloat(srlist,'tiMainOffsetYF',-0.00,ierr)
      call NhlFRLSetInteger(srlist,'tiMainFontColor',26,ierr)
      call NhlFRLSetString(srlist,'tiXAxisString','Y',ierr)
      call NhlFRLSetInteger(srlist,'tiXAxisFont',26,ierr)
      call NhlFRLSetInteger(srlist,'tiXAxisFontColor',26,ierr)
      call NhlFRLSetFloat(srlist,'tiXAxisFontHeightF',.025,ierr)
      call NhlFRLSetString(srlist,'tiYAxisString','F(Y)',ierr)
      call NhlFRLSetInteger(srlist,'tiYAxisFont',26,ierr)
      call NhlFRLSetInteger(srlist,'tiYAxisFontColor',26,ierr)
      call NhlFRLSetFloat(srlist,'tiYAxisFontHeightF',.025,ierr)

      call NhlFRLSetString(srlist,'tmXTBorderOn','False',ierr)
      call NhlFRLSetString(srlist,'tmYRBorderOn','False',ierr)
      call NhlFRLSetString(srlist,'tmXTOn','False',ierr)
      call NhlFRLSetString(srlist,'tmYROn','False',ierr)
      call NhlFRLSetInteger(srlist,'tmYLMajorLineColor',26,ierr)
      call NhlFRLSetInteger(srlist,'tmYLMinorLineColor',26,ierr)
      call NhlFRLSetFloat(srlist,'tmYLMinorThicknessF',2.,ierr)
      call NhlFRLSetInteger(srlist,'tmXBMajorLineColor',26,ierr)
      call NhlFRLSetInteger(srlist,'tmXBMinorLineColor',26,ierr)
      call NhlFRLSetFloat(srlist,'tmXBMinorThicknessF',2.,ierr)

      call NhlFRLSetInteger(srlist,'tmXBMinorPerMajor',2,ierr)
      call NhlFRLSetInteger(srlist,'tmYLMinorPerMajor',2,ierr)
      call NhlFRLSetInteger(srlist,'tmBorderLineColor',26,ierr)

      call NhlFRLSetInteger(srlist,'tmXBLabelFont',21,ierr)
      call NhlFRLSetFloat(srlist,'tmXBLabelFontHeightF',.025,ierr)
      call NhlFRLSetInteger(srlist,'tmXBLabelFontColor',26,ierr)
      call NhlFRLSetInteger(srlist,'tmYLLabelFont',21,ierr)
      call NhlFRLSetFloat(srlist,'tmYLLabelFontHeightF',.025,ierr)
      call NhlFRLSetInteger(srlist,'tmYLLabelFontColor',26,ierr)
      call NhlFCreate(xy_id,'XyPlotData',nhlfxyplotclass,work_id,srlist,
     +     ierr)

      call NhlFAddData(xy_id,'xyCoordData',y_dataid,dataspec)

      call NhlFRLClear(srlist)
      call NhlFRLSetString(srlist,'xyMonoLineColor','True',ierr)
      call NhlFRLSetInteger(srlist,'xyLineColor',24,ierr)
      call NhlFRLSetFloat(srlist,'xyLineThicknessF',2.,ierr)
      call NhlFSetValues(dataspec,srlist,ierr)

      call NhlFRLCreate(grlist,'getrl')
      call NhlFRLClear(grlist)
      call NhlFRLGetFloat(grlist,'tmYLTickStartF',ymin,ierr)
      call NhlFRLGetFloat(grlist,'tmYLTickEndF',ymax,ierr)
      call NhlFGetValues(xy_id,grlist,ierr)

      call NhlFRLClear(srlist)
      call NhlFRLSetFloat(srlist,'trYMinF',ymin,ierr)
      call NhlFRLSetFloat(srlist,'trYMaxF',ymax,ierr)
      call NhlFSetValues(xy_id,srlist,ierr)

      call NhlFDraw(xy_id,ierr)
      call NhlFFrame(work_id,ierr)
C
C Picture 5:  Overlay the mound on top of Colorado.
C
      call NhlFRLClear(srlist)

      call NhlFRLSetString(srlist,'pmTitleDisplayMode','always',ierr)

      call NhlFRLSetString(srlist,'tiMainOn','True',ierr)
      call NhlFRLSetInteger(srlist,'tiMainFont',26,ierr)
      call NhlFRLSetFloat(srlist,'tiMainFontHeightF',0.037,ierr)
      call NhlFRLSetFloat(srlist,'tiMainOffsetYF',-0.00,ierr)
      call NhlFRLSetInteger(srlist,'tiMainFontColor',26,ierr)
      call NhlFRLSetString(srlist,'tiMainString','Mound over Colorado',
     +     ierr)

      call NhlFRLSetFloat(srlist,'vpXF',.1,ierr)
      call NhlFRLSetFloat(srlist,'vpYF',.9,ierr)
      call NhlFRLSetFloat(srlist,'vpWidthF',.79,ierr)
      call NhlFRLSetFloat(srlist,'vpHeightF',.79,ierr)

      call NhlFRLSetString(srlist,'mpFillOn','False',ierr)
      call NhlFRLSetString(srlist,'mpOutlineBoundarySets',
     +     'allBoundaries',ierr)
      call NhlFRLSetString(srlist,'mpProjection','LambertConformal',
     +     ierr)
      call NhlFRLSetFloat(srlist,'mpLambertParallel1F',30.,ierr)
      call NhlFRLSetFloat(srlist,'mpLambertParallel2F',45.,ierr)
      call NhlFRLSetFloat(srlist,'mpLambertMeridianF',-100.,ierr)
      call NhlFRLSetString(srlist,'mpLimitMode','LatLon',ierr)
      call NhlFRLSetFloat(srlist,'mpMinLatF',33.,ierr)
      call NhlFRLSetFloat(srlist,'mpMaxLatF',44.,ierr)
      call NhlFRLSetFloat(srlist,'mpMinLonF',-115.,ierr)
      call NhlFRLSetFloat(srlist,'mpMaxLonF',-93.,ierr)
      call NhlFRLSetInteger(srlist,'mpUSStateLineColor',25,ierr)
      call NhlFRLSetFloat(srlist,'mpUSStateLineThicknessF',2.,ierr)
      call NhlFRLSetString(srlist,'mpPerimOn','True',ierr)
      call NhlFRLSetString(srlist,'mpGridAndLimbOn','False',ierr)
      call NhlFRLSetInteger(srlist,'mpPerimLineColor',26,ierr)
      call NhlFRLSetFloat(srlist,'mpPerimLineThicknessF',2.,ierr)
      call NhlFCreate(mapid,'Map0',nhlfmapplotclass,work_id,srlist,ierr)

      call NhlFRLClear(srlist)
      count(1) = ylen
      count(2) = xlen
      call NhlFRLSetMDFloatArray(srlist,'sfDataArray',mound,2,count,
     +     ierr)
      call NhlFRLSetFloat(srlist,'sfXCStartV',-109.05,ierr)
      call NhlFRLSetFloat(srlist,'sfXCEndV',-102.05,ierr)
      call NhlFRLSetFloat(srlist,'sfYCStartV',37.,ierr)
      call NhlFRLSetFloat(srlist,'sfYCEndV',41.,ierr)
      call NhlFCreate(field2,'field2',nhlfscalarfieldclass,appid,srlist,
     +     ierr)

      call NhlFRLClear(srlist)
      call NhlFRLSetInteger(srlist,'cnScalarFieldData',field2,ierr)
      call NhlFRLSetString(srlist,'cnFillOn','True',ierr)
      call NhlFRLSetString(srlist,'cnMonoFillColor','False',ierr)
      call NhlFRLSetFloat(srlist,'cnLevelSpacingF',8.0,ierr)
      call NhlFRLSetString(srlist,'cnSmoothingOn','True',ierr)
      call NhlFRLSetFloat(srlist,'cnMaxPointDistanceF',0.0,ierr)
      call NhlFRLSetInteger(srlist,'cnLineColor',0,ierr)
      call NhlFRLSetString(srlist,'cnLineLabelsOn','False',ierr)
      call NhlFRLSetString(srlist,'cnHighLabelsOn','False',ierr)
      call NhlFRLSetString(srlist,'cnInfoLabelOn','False',ierr)
      colors(1) = 3
      colors(2) = 7
      colors(3) = 11
      colors(4) = 15
      colors(5) = 19
      colors(6) = 23
      call NhlFRLSetIntegerArray(srlist,'cnFillColors',colors,6,ierr)
      call NhlFCreate(con2,'con2',nhlfcontourplotclass,work_id,srlist,
     +     ierr)
      call NhlFAddOverlay(mapid,con2,-1,ierr)
      call NhlFDraw(mapid,ierr)
      call NhlFFrame(work_id,ierr)
C
C Close the netCDF file.
C
      call ncclos(ncid,ierr)
C
C NhlDestroy destroys the given id and all of its children
C
      call NhlFRLDestroy(srlist)
      call NhlFDestroy(appid,ierr)
C
C Restores state.
C
      call NhlFClose
      stop
      end

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


text:
Finding yourself out of Davis in the town of Winters?  Need a good Restaurants place to eat?  Here are some choices that might appeal to you.  (You could also travel to Sacramento Restaurants Sacramento, West Sacramento Restaurants West Sacramento, Woodland Restaurants Woodland, Dixon Restaurants Dixon, Vacaville Restaurants Vacaville... or just head home to Restaurants Davis).

 American (U.S.)
 Fine Dining
  Buckhorn Steak and Roadhouse
  Monticello Bistro

 Coffee/Cafes
  Irish Pub & Coffee House
  Putah Creek Cafe

 Latin
  Chuys Taqueria


text:
module Svc {

  @ A component for downlinking files
  active component FileDownlink {

    # ----------------------------------------------------------------------
    # General ports
    # ----------------------------------------------------------------------

    @ Run input port
    async input port Run: Svc.Sched

    @ Mutexed Sendfile input port
    guarded input port SendFile: Svc.SendFileRequest

    @ File complete output port
    output port FileComplete: [FileDownCompletePorts] Svc.SendFileComplete

    @ Buffer return input port
    async input port bufferReturn: Fw.BufferSend

    @ Buffer send output port
    output port bufferSendOut: Fw.BufferSend

    @ Ping input port
    async input port pingIn: Svc.Ping

    @ Ping output port
    output port pingOut: Svc.Ping

    # ----------------------------------------------------------------------
    # Special ports
    # ----------------------------------------------------------------------

    @ Time get port
    time get port timeCaller

    @ Command registration port
    command reg port cmdRegOut

    @ Command receive port
    command recv port cmdIn

    @ Command response port
    command resp port cmdResponseOut

    @ Event port
    event port eventOut

    @ Text event port
    text event port textEventOut

    @ Telemetry port
    telemetry port tlmOut

    # ----------------------------------------------------------------------
    # Commands
    # ----------------------------------------------------------------------

    include "Commands.fppi"

    # ----------------------------------------------------------------------
    # Telemetry
    # ----------------------------------------------------------------------

    include "Telemetry.fppi"

    # ----------------------------------------------------------------------
    # Events
    # ----------------------------------------------------------------------

    include "Events.fppi"

  }

}

ext: fpp

max_stars_repo_name: cadomani/fprime

max_issues_repo_name: cadomani/fprime

max_forks_repo_name: cadomani/fprime


subroutine integratecvHB(z13,z35,i1,i2,pia13,pia35,z35mod,pwc,n0w,&
     ngates,nfreq,node,dr,imu,dpia13,dpia35,kext,salb,asym,rrate,d0)
  use tables2
  implicit none
  integer :: nfreq
  integer :: ngates,node(5),imu(ngates),i1,i2
  real :: z35mod(ngates)
  real :: z13(ngates), z35(ngates),n0w(ngates), pwc(ngates)
  integer :: i, j, i0, j0
  real :: pia13, pia35, dpia13, dpia35, zb

  real :: kext(ngates,nfreq),salb(ngates,nfreq),asym(ngates,nfreq)
  real :: rrate(ngates), d0(ngates)
  real :: dr,f
  integer :: igoto, iNoAd
  if(n0w(i1)<-3.0) then
     n0w(i1)=-3.0
  endif
  if(n0w(i1)>3.0) then
     n0w(i1)=3.0
  endif

  igoto=1
  iNoAd=0
10 continue
  if(isnan(n0w(i1))) then
     n0w(i1)=-1
     iNoAd=1
  endif
!  write(*,*)  i1,i2,node
  if(n0w(i1)<-5) then
     dpia13=0
     dpia35=0
     kext(i1,1:nfreq)=0
     salb(i1,1:nfreq)=0
     asym(i1,1:nfreq)=0
     print*, 'here'
     return
  endif
  do i=max(i1,node(1)),min(i2,node(2)-1)
     dpia13=0.
     dpia35=0.
     i0=(z13(i)-10.*n0w(i)-zmin)/dzbin+1
     if(i0<1) i0=1
     if(i0>nbinS2) i0=nbinS2
     dpia13=att13TableS2(i0,imu(i))*10.**n0w(i)*dr
     dpia35=att35TableS2(i0,imu(i))*10.**n0w(i)*dr
     pwc(i)=pwc13TableS2(i0,imu(i))+n0w(i)
     rrate(i)=pr13TableS2(i0,imu(i))*10.**n0w(i)
     rrate(i)=pr13TableS2(i0,imu(i))*10.**n0w(i)
     d0(i)=d013TableS2(i0,imu(i))
     !print*, pwc(i)
     if(10.**pwc(i)>0.2 .and. z13(i)-10.*n0w(i)<zmin .and. igoto<3) then
        n0w(i)=n0w(i)-0.3
        igoto=igoto+1
        goto 10
     endif
     kext(i,1:nfreq)=kextTableS2(i0,1:nfreq,imu(i))*10.**n0w(i)
     salb(i,1:nfreq)=salbTableS2(i0,1:nfreq,imu(i))
     asym(i,1:nfreq)=asymTableS2(i0,1:nfreq,imu(i))
!  SFM  begin  06/16/2014; for M.Grecu, multiple scattering
     z35mod(i)=z35TableS2(i0,imu(i))+10*n0w(i)-(pia35+dpia35)
     z35(i)=z35TableS2(i0,imu(i))+10*n0w(i)
!  SFM  end    06/16/2014
     !pia13=pia13+dpia13
     !pia35=pia35+dpia35
  enddo

  zb=0
  do i=max(i1,node(2)),min(i2,node(4)-1)
     dpia13=0.
     dpia35=0.
     f=((i-node(2)+0.)/(node(4)-node(2)+0.))**2
     !f=1.
     i0=(z13(i)-10.*n0w(i)-zmin)/dzbin+1
     if(i0<1) i0=1
     if(i0>nbinS2) i0=nbinS2
     dpia13=((1-f)*att13TableS2(i0,imu(i))+&
          f*att13Table(i0,imu(i)))*10.**n0w(i)*dr
     dpia35=((1-f)*att35TableS2(i0,imu(i))+&
          f*att35Table(i0,imu(i)))*10.**n0w(i)*dr
!  S2FM  begin  06/16/2014; for M.Grecu, multiple scattering
     z35mod(i)=((1-f)*z35TableS2(i0,imu(i))+&
          f*(z35Table(i0,imu(i))))+10*n0w(i)-(pia35+dpia35)
!  S2FM  end  06/16/2014
     z35(i)=((1-f)*z35TableS2(i0,imu(i))+f*(z35Table(i0,imu(i))))+10*n0w(i)
     pwc(i)=((1-f)*pwc13TableS2(i0,imu(i))+f*pwc13Table(i0,imu(i)))+n0w(i)
     rrate(i)=pr13TableS2(i0,imu(i))*10.**n0w(i)*(1-f)+&
          pr13Table(i0,imu(i))*10.**n0w(i)*(f)
     d0(i)=d013TableS2(i0,imu(i))*(1-f)+f*d013Table(i0,imu(i))
     kext(i,1:nfreq)=(1-f)*kextTableS2(i0,1:nfreq,imu(i))*10.**n0w(i)+ &
          f*kextTable(i0,1:nfreq,imu(i))*10.**n0w(i)
     salb(i,1:nfreq)=(1-f)*kextTableS2(i0,1:nfreq,imu(i))*&
          10.**n0w(i)*salbTableS2(i0,1:nfreq,imu(i))+&
          f*kextTable(i0,1:nfreq,imu(i))*10.**n0w(i)*&
          salbTable(i0,1:nfreq,imu(i))
     asym(i,1:nfreq)=(1-f)*kextTableS2(i0,1:nfreq,imu(i))*&
          10.**n0w(i)*salbTableS2(i0,1:nfreq,imu(i))*&
          asymTableS2(i0,1:nfreq,imu(i))+ &
          f*kextTable(i0,1:nfreq,imu(i))*10.**n0w(i)*&
          salbTable(i0,1:nfreq,imu(i))*&
          asymTable(i0,1:nfreq,imu(i))

     asym(i,1:nfreq)=asym(i,1:nfreq)/salb(i,1:nfreq)
     salb(i,1:nfreq)=salb(i,1:nfreq)/kext(i,1:nfreq)
     salb(i,1:nfreq)=(1-f)*salbTableS2(i0,1:nfreq,imu(i))+&
          f*salbTable(i0,1:nfreq,imu(i))
     asym(i,1:nfreq)=(1-f)*&
          asymTableS2(i0,1:nfreq,imu(i))+ &
          f*asymTable(i0,1:nfreq,imu(i))
     !pia13=pia13+dpia13
     !pia35=pia35+dpia35
  enddo

  do i=max(i1,node(4)),min(i2,node(5))
     dpia13=0.
     dpia35=0.
     i0=(z13(i)-10.*n0w(i)-zmin)/dzbin+1
     if(i0<1) i0=1
     if(i0>nbins) i0=nbins
     dpia13=att13Table(i0,imu(i))*10.**n0w(i)*dr
     !pia13=pia13+dpia13
     dpia35=att35Table(i0,imu(i))*10.**n0w(i)*dr
     pwc(i)=pwc13Table(i0,imu(i))+n0w(i)
     d0(i)=d013Table(i0,imu(i))
     rrate(i)=pr13Table(i0,imu(i))*10.**n0w(i)
     kext(i,1:nfreq)=kextTable(i0,1:nfreq,imu(i))*10.**n0w(i)
     if(kext(i,nfreq)>60 .and. igoto<3 .and. iNoAd==0) then
        n0w(i)=n0w(i)+log(60/kext(i,nfreq))
        igoto=igoto+1
        goto 10
        !print*, rrate(i), kext(i,nfreq), 10.**n0w(i), pia13, i, node(5)
     endif
     salb(i,1:nfreq)=salbTable(i0,1:nfreq,imu(i))
     asym(i,1:nfreq)=asymTable(i0,1:nfreq,imu(i))
!  S2FM  begin  06/16/2014; for M.Grecu, multiple scattering
     z35mod(i)=z35Table(i0,imu(i))+10*n0w(i)-(pia35+dpia35)
!  S2FM  end    06/16/2014
     z35(i)=z35Table(i0,imu(i))+10*n0w(i)
     !print*, z35mod(i), z35(i), i1,i2,i
     !pia35=pia35+dpia35
  enddo
  if(rrate(i1)>=201 .and. igoto<3 .and. iNoAd==0) then
     !write(*,*) rrate(i1), n0w(i1), z13(i1), i0, pr13Table(i0,imu(i1))
     n0w(i1)=n0w(i1)+log10(200/rrate(i1))
     igoto=igoto+1
     goto 10
  endif

  dpia13=dpia13/dr
  dpia35=dpia35/dr
  pwc(i1)=10.**pwc(i1)
end subroutine integratecvHB

subroutine integratestHB(z13,z13obs,z35,i1,i2,pia13,pia35,z35mod,pwc,n0w,&
     ngates,nfreq,node,dr,imu, dpia13, dpia35,kext,salb,asym,rrate,d0,dz1,dz2) !Sept 17, 2015 MG begin
  use tables2
  implicit none
  integer :: nfreq
  real :: dr, f
  integer :: ngates,node(5),imu(ngates),i1,i2
  real :: z35mod(ngates), z13obs(ngates)
  real :: z13(ngates), z35(ngates),n0w(ngates), pwc(ngates)
  integer :: i, j, i0, j0
  real :: pia13, pia35, dpia13, dpia35, zb
  real :: kext(ngates,nfreq),salb(ngates,nfreq),asym(ngates,nfreq)
  real :: rrate(ngates),d0(ngates)
  real :: n0bb, dz1, dz2
  integer :: igoto, iNoAd
  igoto=1
  iNoAd=0

10 continue

  if(n0w(i1)<-3.0) then
     n0w(i1)=-3.0
  endif
  if(n0w(i1)>3.0) then
     n0w(i1)=3.0
  endif

  if(isnan(n0w(i1))) then
     n0w(i1)=-1
     iNoAd=1
  endif

  if(n0w(i1)<-5) then
     dpia13=0
     dpia35=0
     kext(i1,1:nfreq)=0
     salb(i1,1:nfreq)=0
     asym(i1,1:nfreq)=0
     return
  endif
  do i=max(i1,node(1)),min(i2,node(2)-1)
        dpia13=0.
        dpia35=0.
        i0=int((z13(i)-10.*n0w(i)-zmin)/dzbin)+1
        if(i0<1) i0=1
        if(i0>nbinS2) i0=nbinS2
        dpia13=att13TableS2(i0,imu(i))*10.**n0w(i)*dr
        dpia35=att35TableS2(i0,imu(i))*10.**n0w(i)*dr
        pwc(i)=pwc13TableS2(i0,imu(i))+n0w(i)
        rrate(i)=pr13TableS2(i0,imu(i))*10.**n0w(i)
        d0(i)=d013TableS2(i0,imu(i))

        kext(i,1:nfreq)=kextTableS2(i0,1:nfreq,imu(i))*10.**n0w(i)
        salb(i,1:nfreq)=salbTableS2(i0,1:nfreq,imu(i))
        asym(i,1:nfreq)=asymTableS2(i0,1:nfreq,imu(i))
!  S2FM  begin  06/16/2014; for M.Grecu, multiple scattering
        z35mod(i)=z35TableS2(i0,imu(i))+10*n0w(i)-(pia35+dpia35)
        z35(i)=z35TableS2(i0,imu(i))+10*n0w(i)
!  S2FM  end    06/16/2014
  enddo
  zb=0
  n0bb=-0.
  do i=max(i1,node(2)),min(i2,node(3)-1)
     dpia13=0.
     dpia35=0.
     !f=1.
     f=(i-node(2)+0.)/(node(3)-node(2)+0.)
     f=1-(maxval(z13obs(node(2):node(4)))-z13obs(i))/(dz1+0.1)
     if(f<0) f=0
     if(f>1) f=1
     i0=(z13(i)-10.*n0w(i)-10.*n0bb-zmin)/dzbin+1
     if(i0<1) i0=1
     if(i0>nbinS2) i0=nbinS2
     dpia13=((1-f)*att13TableS2(i0,imu(i))+f*att13TableBB(i0,imu(i)))*10.**(n0w(i)+n0bb)*dr
     dpia35=((1-f)*att35TableS2(i0,imu(i))+f*att35TableBB(i0,imu(i)))*10.**(n0w(i)+n0bb)*dr
!  S2FM  begin  06/16/2014; for M.Grecu, multiple scattering
     z35mod(i)=((1-f)*z35TableS2(i0,imu(i))+f*(z35TableBB(i0,imu(i))))+10*(n0w(i)+n0bb)-(pia35+dpia35)
     z35(i)=((1-f)*z35TableS2(i0,imu(i))+f*(z35TableBB(i0,imu(i))))+10*(n0w(i)+n0bb)
!  S2FM  end    06/16/2014
     pwc(i)=((1-f)*pwc13TableS2(i0,imu(i))+f*pwc13TableBB(i0,imu(i)))+(n0w(i)+n0bb)
     rrate(i)=pr13TableS2(i0,imu(i))*10.**(n0w(i)+n0bb)*(1-f)+pr13TableBB(i0,imu(i))*10.**(n0w(i)+n0bb)*(f)
     d0(i)=d013TableS2(i0,imu(i))*(1-f)+f*d013TableBB(i0,imu(i))
     kext(i,1:nfreq)=(1-f)*kextTableS2(i0,1:nfreq,imu(i))*10.**(n0w(i)+n0bb)+ &
          f*kextTableBB(i0,1:nfreq,imu(i))*10.**(n0w(i)+n0bb)
     salb(i,1:nfreq)=(1-f)*kextTableS2(i0,1:nfreq,imu(i))*10.**(n0w(i)+n0bb)* &
          salbTableS2(i0,1:nfreq,imu(i))+&
             f*kextTableBB(i0,1:nfreq,imu(i))*10.**(n0w(i)+n0bb)*salbTableBB(i0,1:nfreq,imu(i))
     asym(i,1:nfreq)=(1-f)*kextTableS2(i0,1:nfreq,imu(i))*&
          10.**(n0w(i)+n0bb)*salbTableS2(i0,1:nfreq,imu(i))*&
          asymTableS2(i0,1:nfreq,imu(i))+ &
          f*kextTableBB(i0,1:nfreq,imu(i))*10.**(n0w(i)+n0bb)*salbTableBB(i0,1:nfreq,imu(i))*&
          asymTableBB(i0,1:nfreq,imu(i))

     asym(i,1:nfreq)=asym(i,1:nfreq)/salb(i,1:nfreq)
     salb(i,1:nfreq)=salb(i,1:nfreq)/kext(i,1:nfreq)

  enddo

  do i=max(i1,node(3)),min(i2,node(4)-1)
        dpia13=0.
        dpia35=0.
        f=(i-node(3)+0.)/(node(4)-node(3)+0.)
        f=(maxval(z13obs(node(2):node(4)))-z13obs(i))/(dz2+0.1)
        if(f<0) f=0
        if(f>1) f=1
        !f=1.
        i0=(z13(i)-10.*(n0w(i)+n0bb)-zmin)/dzbin+1
        if(i0<1) i0=1
        if(i0>i0max(imu(i))) i0=i0max(imu(i))
        dpia13=((1-f)*att13TableBB(i0,imu(i))+f*att13Table(i0,imu(i)))*10.**(n0w(i)+n0bb)*dr

        dpia35=((1-f)*att35TableBB(i0,imu(i))+f*att35Table(i0,imu(i)))*10.**(n0w(i)+n0bb)*dr
        kext(i,1:nfreq)=(1-f)*kextTableBB(i0,1:nfreq,imu(i))*10.**(n0w(i)+n0bb)+ &
             f*kextTable(i0,1:nfreq,imu(i))*10.**(n0w(i)+n0bb)
        salb(i,1:nfreq)=(1-f)*kextTableBB(i0,1:nfreq,imu(i))*&
             10.**(n0w(i)+n0bb)*salbTableBB(i0,1:nfreq,imu(i))+&
             f*kextTable(i0,1:nfreq,imu(i))*10.**(n0w(i)+n0bb)*salbTable(i0,1:nfreq,imu(i))
        asym(i,1:nfreq)=(1-f)*kextTableBB(i0,1:nfreq,imu(i))*&
             10.**(n0w(i)+n0bb)*salbTableBB(i0,1:nfreq,imu(i))*&
             asymTableBB(i0,1:nfreq,imu(i))+ &
             f*kextTable(i0,1:nfreq,imu(i))*10.**(n0w(i)+n0bb)*salbTable(i0,1:nfreq,imu(i))*&
             asymTable(i0,1:nfreq,imu(i))
        asym(i,1:nfreq)=asym(i,1:nfreq)/salb(i,1:nfreq)
        salb(i,1:nfreq)=salb(i,1:nfreq)/kext(i,1:nfreq)
!        salb(i,1:nfreq)=(1-f)*salbTableBB(i0,1:nfreq,imu(i))+&
!             f*salbTable(i0,1:nfreq,imu(i))
!        asym(i,1:nfreq)=(1-f)*&
!             asymTableBB(i0,1:nfreq,imu(i))+ &
!             f*asymTable(i0,1:nfreq,imu(i))
        pwc(i)=((1-f)*pwc13TableBB(i0,imu(i))+f*pwc13Table(i0,imu(i)))+(n0w(i)+n0bb)
        rrate(i)=pr13TableBB(i0,imu(i))*10.**(n0w(i)+n0bb)*(1-f)+pr13Table(i0,imu(i))*10.**(n0w(i)+n0bb)*(f)
        d0(i)=d013TableBB(i0,imu(i))*(1-f)+f*d013Table(i0,imu(i))
!  S2FM  begin  06/16/2014; for M.Grecu, multiple scattering
        z35mod(i)=((1-f)*z35TableBB(i0,imu(i))+f*z35Table(i0,imu(i)))+10*(n0w(i)+n0bb)-(pia35+dpia35)
        z35(i)=((1-f)*z35TableBB(i0,imu(i))+f*z35Table(i0,imu(i)))+10*(n0w(i)+n0bb)
!  S2FM  end    06/16/2014
  enddo

  do i=max(i1,node(4)),min(i2,node(5))
     dpia13=0.
     dpia35=0.
     i0=(z13(i)-10.*n0w(i)-zmin)/dzbin+1
     if(i0<1) i0=1
     if(i0>nbins) i0=nbins
     dpia13=att13Table(i0,imu(i))*10.**n0w(i)*dr

     dpia35=att35Table(i0,imu(i))*10.**n0w(i)*dr
     pwc(i)=pwc13Table(i0,imu(i))+n0w(i)
     rrate(i)=pr13Table(i0,imu(i))*10.**n0w(i)
     d0(i)=d013Table(i0,imu(i))
     kext(i,1:nfreq)=kextTable(i0,1:nfreq,imu(i))*10.**n0w(i)
     salb(i,1:nfreq)=salbTable(i0,1:nfreq,imu(i))
     asym(i,1:nfreq)=asymTable(i0,1:nfreq,imu(i))
!  SFM  begin  06/16/2014; for M.Grecu, multiple scattering
     z35mod(i)=z35Table(i0,imu(i))+10*n0w(i)-(pia35+dpia35)
     z35(i)=z35Table(i0,imu(i))+10*n0w(i)
!  SFM  end    06/16/2014
     if(kext(i,nfreq)>60 .and. igoto<3 .and. iNoAd==0) then
        n0w(i)=n0w(i)+log(60/kext(i,nfreq))
        igoto=igoto+1
        goto 10
        !print*, rrate(i), kext(i,nfreq), 10.**n0w(i), pia13, i, node(5)
     endif
  enddo

  dpia35=dpia35/dr
  dpia13=dpia13/dr
  pwc(i1)=10.**pwc(i1)
!  if(salb(i1,6)>kext(i1,6)) then
!     print*, 'here we go', z13(i1), i1, node
!     stop
!  endif
end subroutine integratestHB !Sept 17, 2015 MG end

subroutine integrateanvHB(z13,z35,i1,i2,pia13,pia35,z35mod,pwc,n0w,&
     ngates,nfreq,node,dr,imu, dpia13, dpia35,kext,salb,asym,rrate,d0)
  use tables2
  implicit none
  integer :: nfreq
  real :: dr, f
  integer :: ngates,node(5),imu(ngates),i1,i2
  real :: z35mod(ngates)
  real :: z13(ngates), z35(ngates),n0w(ngates), pwc(ngates)
  integer :: i, j, i0, j0
  real :: pia13, pia35, dpia13, dpia35, zb
  real :: kext(ngates,nfreq),salb(ngates,nfreq),asym(ngates,nfreq)
  real :: rrate(ngates),d0(ngates)
  integer :: igoto
  igoto=1
10 continue

  if(n0w(i1)<-3.0) then
     n0w(i1)=-3.0
  endif
  if(n0w(i1)>3.0) then
     n0w(i1)=3.0
  endif
  if(n0w(i1)<-5) then
     dpia13=0
     dpia35=0
     kext(i1,1:nfreq)=0
     salb(i1,1:nfreq)=0
     asym(i1,1:nfreq)=0
     return
  endif
  do i=i1,i2
     dpia13=0.
     dpia35=0.
     i0=int((z13(i)-10.*n0w(i)-zmin)/dzbin)+1
     if(i0<1) i0=1
     if(i0>i0max(imu(i))-1) i0=i0max(imu(i))-1
     dpia13=att13TableS(i0,imu(i))*10.**n0w(i)*dr
     dpia35=att35TableS(i0,imu(i))*10.**n0w(i)*dr
     pwc(i)=pwc13TableS(i0,imu(i))+n0w(i)
     rrate(i)=pr13TableS(i0,imu(i))*10.**n0w(i)
     d0(i)=d013TableS(i0,imu(i))

     kext(i,1:nfreq)=kextTableS(i0,1:nfreq,imu(i))*10.**n0w(i)
     salb(i,1:nfreq)=salbTableS(i0,1:nfreq,imu(i))
     asym(i,1:nfreq)=asymTableS(i0,1:nfreq,imu(i))
     !  SFM  begin  06/16/2014; for M.Grecu, multiple scattering
     z35mod(i)=z35TableS(i0,imu(i))+10*n0w(i)-(pia35+dpia35)
     z35(i)=z35TableS(i0,imu(i))+10*n0w(i)
     !  SFM  end    06/16/2014
  enddo
end subroutine integrateanvHB


text: wiki:WikiPedia:Walid_Shoebat Walid Shoebat is scheduled to appear at UC Davis on Feb. 6 at 7 p.m. in Freeborn Hall. His claim to fame is predicated on being a former terrorist. There are those who are http://www.danielpipes.org/comments/20912 skeptical and others who are offended. His visit is sponsored by Foundation for the Defense of Democracies at UC Davis.


text:
      MODULE biotr1_I
      INTERFACE
!...Generated by Pacific-Sierra Research 77to90  4.3E  06:25:32  12/28/06
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
      SUBROUTINE biotr1 (PI, QI, NLI, NINSHLI, PF, QF, NLF, NINSHLF, NGRID, MXL&
         , SCR, LSCR, NTESTG, CISHL, CICI, CFSHL, CFCI)
      USE vast_kind_param,ONLY: DOUBLE
      REAL(DOUBLE), DIMENSION(NGRID,*) :: PI
      REAL(DOUBLE), DIMENSION(NGRID,*) :: QI
      INTEGER, DIMENSION(MXL), INTENT(IN) :: NLI
      INTEGER, DIMENSION(MXL) :: NINSHLI
      REAL(DOUBLE), DIMENSION(NGRID,*) :: PF
      REAL(DOUBLE), DIMENSION(NGRID,*) :: QF
      INTEGER, DIMENSION(MXL), INTENT(IN) :: NLF
      INTEGER, DIMENSION(MXL) :: NINSHLF
      INTEGER, INTENT(IN) :: NGRID
      INTEGER, INTENT(IN) :: MXL
      REAL(DOUBLE), DIMENSION(*), INTENT(INOUT) :: SCR
      INTEGER, INTENT(IN) :: LSCR
      INTEGER, INTENT(IN) :: NTESTG
      REAL(DOUBLE), DIMENSION(*) :: CISHL
      REAL(DOUBLE), DIMENSION(*) :: CICI
      REAL(DOUBLE), DIMENSION(*) :: CFSHL
      REAL(DOUBLE), DIMENSION(*) :: CFCI
      END SUBROUTINE
      END INTERFACE
      END MODULE

max_stars_repo_name: sylas/grasp-continuum

max_issues_repo_name: sylas/grasp-continuum

max_forks_repo_name: sylas/grasp-continuum


text:
!  maooam.f90
!
!> Fortran 90 implementation of the modular arbitrary-order ocean-atmosphere
!> model MAOOAM.
!
!> @copyright
!> 2015 Lesley De Cruz & Jonathan Demaeyer.
!> See LICENSE.txt for license information.
!
!---------------------------------------------------------------------------!

PROGRAM maooam
  USE params, only: ndim, dt, tw, tw_snap, t_trans, t_run, writeout
  USE aotensor_def, only: init_aotensor
  USE IC_def, only: load_IC, IC
  USE integrator, only: init_integrator,step
  USE stat
  IMPLICIT NONE

  REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: X       !< State variable in the model
  REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: Xnew    !< Updated state variable
  REAL(KIND=8) :: t=0.D0                             !< Time variable
  REAL(KIND=8) :: t_up
  INTEGER :: i, next, IndexSnap, WRSTAT
  CHARACTER(LEN=9) :: arg
  LOGICAL :: cont_evol    !< True if the initial state is to be read in snapshot_trans.dat (i.e. the previous evolution is to be continued)
  LOGICAL :: ex

  PRINT*, 'Model MAOOAM v1.3'
  PRINT*, 'Loading information...'

  ! Initializing cont_evol
  cont_evol=.FALSE.
  arg='arg'
  i=0
  DO WHILE ((.NOT. cont_evol) .AND. LEN_TRIM(arg) /= 0)
     CALL get_command_argument(i, arg)
     IF (TRIM(arg)=='continue') cont_evol=.TRUE.
     i=i+1
  END DO

  CALL init_aotensor    ! Compute the tensor

  CALL load_IC          ! Load the initial condition

  CALL init_integrator  ! Initialize the integrator

  t_up=dt/t_trans*100.D0

  IF (writeout) OPEN(10,file='evol_field.dat')

  ALLOCATE(X(0:ndim),Xnew(0:ndim))

  X=IC
  IF (cont_evol) THEN
     INQUIRE(FILE='snapshots_trans.dat',EXIST=ex,NEXTREC=next)
     IF (ex) THEN
        OPEN(11,file='snapshots_trans.dat')
        READ(11,REC=next-1) X
        CLOSE(11)
     END IF
  END IF

  IF (writeout) OPEN(11,file='snapshots_trans.dat',status='replace',form='UNFORMATTED',access='DIRECT',recl=8*ndim)

  PRINT*, 'Starting the transient time evolution...'

  IndexSnap=0
  DO WHILE (t<t_trans)
     CALL step(X,t,dt,Xnew)
     X=Xnew
     IF (mod(t/t_trans*100.D0,0.1)<t_up) WRITE(*,'(" Progress ",F6.1," %",A,$)') t/t_trans*100.D0,char(13)
     IF (writeout .AND. mod(t,tw_snap)<dt) THEN
        IndexSnap=IndexSnap+1
        WRITE(11,rec=IndexSnap,iostat=WRSTAT) X
     END IF
  END DO

  IF (writeout) CLOSE(11)

  PRINT*, 'Starting the time evolution...'

  CALL init_stat

  t=0.D0
  t_up=dt/t_run*100.D0

  IF (writeout) WRITE(10,*) t,X(1:ndim)

  DO WHILE (t<t_run)
     !STEVE: split this into: step_atmos(Xa,ta,dta,Xa_new) and step_ocean(Xo,to,dto,Xo_new)
     !call step_atmos(Xa,ta,dta,Xa_new)
     !call step_ocean(Xo,to,dta,Xo_new)
     !Xa = Xa_new
     !Xo = Xo_new
     CALL step(X,t,dt,Xnew)
     X=Xnew
     IF (mod(t,tw)<dt) THEN
        IF (writeout) WRITE(10,*) t,X(1:ndim)
        CALL acc(X)
     END IF
     IF (mod(t/t_run*100.D0,0.1)<t_up) WRITE(*,'(" Progress ",F6.1," %",A,$)') t/t_run*100.D0,char(13)
  END DO

  PRINT*, 'Evolution finished.'

  IF (writeout) CLOSE(10)

  IF (writeout) OPEN(10,file='mean_field.dat')

  X=mean()
  IF (writeout) WRITE(10,*) X(1:ndim)
  IF (writeout) CLOSE(10)

END PROGRAM maooam

max_stars_repo_name: JCSDA/MAOOAM

max_issues_repo_name: JCSDA/MAOOAM

max_forks_repo_name: JCSDA/MAOOAM


text:
      subroutine cdsld

      implicit double precision (a-h,o-z)
      save
      common /print/ iprint
      common /atomco/ den(30), dq1(30), dfl(30), ws, nqn(30), nql(30),
     1                nk(30), nmax(30), nel(30), norb, norbco

      common /dira/ dv(251), dr(251), dp(251), dq(251), dpas, tets,
     1              z, nstop, nes, np, nuc
      common /deux/ dvn(251), dvf(251), d(251), dc(251), dgc(251,30),
     1 dpc(251,30)

c titre = identification of the wave functions  s,p*,p,........
      character*40 ttl
      character*2  titre
      common /char/ titre(30), ttl

c  -- This read commented out to make input easier, not used for
c     PHASE calculations
      irm  = 0
      ins  = 0
      npun = 0
      nmfg = 0
      nmrk = 0
c     read (5,10) irm,ins,npun,nmfg,nmrk
   10 format (8i3)

c valeurs moyennes de r**j  if irm non-zero
c tabulation of the wave functions if ins non-zero
c the potential multiplied by r is perfore if npun non-zero
      if (irm.eq.0) go to 200
      if (iprint .ge. 5)  write(16,20) ttl
   20 format (1h1,40x,a40,/)
   30 read (5,10) j,l,n1,l1,j1,n2,l2,j2
      if (l.eq.0) go to 200

c valeur moyenne of (p1*p2+q1*q2)*r**j  if l positive
c valeur moyenne of (p1*q2+p2*q1)*r**j  if l negative
      if (n1.gt.0) go to 40
      if (((n1+1)*(n1+2)).ne.0) go to 60
      i1=1
      i2=1
      go to 80
   40 i1=0
      i2=0
      do 50 i=1,norb
      if (nqn(i).eq.n1.and.nql(i).eq.l1.and.(j1-1).eq.(-nk(i)/iabs(nk(i)
     1 ))) i1=i
      if (nqn(i).eq.n2.and.nql(i).eq.l2.and.(j2-1).eq.(-nk(i)/iabs(nk(i)
     1 ))) i2=i
   50 continue
      if (i1.ne.0.and.i2.ne.0) go to 80
   60 if (iprint .ge. 5)  write(16,70) j,l,n1,l1,j1,n2,l2,j2
   70 format (1h0,'    error for the card     ',8i3)
      go to 30
   80 dval=dfl(i1)+dfl(i2)
      if ((dval+j).gt.-1.0) go to 90
      if (n1) 170,170,60
   90 im=nmax(i1)
      if (nmax(i2).lt.im) im=nmax(i2)
      if (l.lt.0) go to 110
      do 100 i=1,im
      dv(i)=dgc(i,i1)*dgc(i,i2)
  100 dq(i)=dpc(i,i1)*dpc(i,i2)
      go to 130
  110 do 120 i=1,im
      dv(i)=dgc(i,i1)*dpc(i,i2)
  120 dq(i)=dgc(i,i2)*dpc(i,i1)
  130 call somm (dr,dv,dq,dpas,dval,j,im)
      if (l.lt.0) go to 150
      if (iprint .ge. 5)  write(16,140) j,nqn(i1),titre(i1),nqn(i2),
     1                                   titre(i2),dval
  140 format (24x,'(p1p2+q1q2)r**',i2,' for  ',i1,a2,i3,a2,5x,'=',1pe14.
     1 7,/)
      go to 170
  150 if (iprint .ge. 5)  write(16,160) j,nqn(i1),titre(i1),nqn(i2),
     1                                   titre(i2),dval
  160 format (24x,'(p1q2+q1p2)r**',i2,' for  ',i1,a2,i3,a2,5x,'=',1pe14.
     1 7,/)
  170 if (n1+1) 190,180,30
  180 i1=i1+1
      i2=i1
      if (i1-norb) 80,80,30
  190 i2=i2+1
      if (i2-norb) 80,80,180
  200 if (ins.eq.0) go to 260
      do 250 i=1,norb,3
      j=i+2
      if (j.gt.norb) j=norb
      im=0
      do 210 l=i,j
      if (nmax(l).gt.im) im=nmax(l)
  210 continue
      do 230 k=1,im
      if (((k-1)*(k-48*(k/48))).ne.0) go to 230
      if (iprint .ge. 5)  write(16,20) ttl
      if (iprint .ge. 5)  write(16,220) (nqn(l),titre(l),nqn(l),
     1                                     titre(l),l=i,j)
  220 format (9x,'r',14x,3(i1,a2,'g.c.',i11,a2,'p.c.',10x))
  230 if (iprint .ge. 5)  write(16,240) dr(k),
     1                                   (dgc(k,l),dpc(k,l),l=i,j)
  240 format (7(1pe17.7))
  250 continue
  260 if (npun.eq.0) go to 300
      do 270 i=1,np
  270 dp(i)=dvf(i)*dr(i)
c     write(8,280) ttl
  280 format (a40)
c     write(8,290) (dp(i),i=1,np)
  290 format (8f9.4)
  300 do 310 i=1,np
  310 d(i)=0.0
      nag=1
      if (nmfg.eq.0) go to 470
      if (iprint .ge. 5)  write(16,20)
      if (iprint .ge. 5)  write(16,320)
  320 format (/,30x,'integrales magnetiques directes et d echange'//)
  330 read (5,10) i1,i2,n1
      if (i1.le.0) go to 470
      if (i2.gt.0) go to 350
      if (((i2+1)*(i2+2)).ne.0) go to 340
      if (n1.le.0) n1=1
      i1=n1
      n1=i2
      i2=i1
      go to 360
  340 if (iprint .ge. 5)  write(16,70) i1,i2,n1
      go to 330
  350 if (i1.gt.norb.or.i2.gt.norb) go to 340
      n1=1
  360 j1=2*iabs(nk(i1))-1
      j2=2*iabs(nk(i2))-1
      kma=min0(j1,j2)
      nm=nmax(i2)
      do 380 j=1,kma,2
      call ykdir (i1,i1,j,nag)
      do 370 i=1,nm
  370 dp(i)=dq(i)*dgc(i,i2)*dpc(i,i2)
      dval=j+1
      call somm (dr,d,dp,dpas,dval,-1,nm)
  380 if (iprint .ge. 5)  write(16,390) j,nqn(i1),titre(i1),nqn(i2),
     1                                   titre(i2),dval
  390 format (20x,'fm',i2,' (',i1,a2,',',i1,a2,') =',1pe14.7)
      if (i1.eq.i2) go to 440
      j1=(iabs(1-2*nk(i1))-1)/2
      j2=(iabs(1-2*nk(i2))-1)/2
      kma=max0(nql(i1)+j2,nql(i2)+j1)
      j1=iabs(nql(i2)-j1)
      j2=iabs(nql(i1)-j2)
      kmi=min0(j1,j2)
      j1=kmi+nql(i1)+nql(i2)
      j1=j1-2*(j1/2)
      if (j1.eq.0) kmi=kmi+1
      nm=min0(nmax(i1),nmax(i2))
      do 420 j=kmi,kma,2
      call ykdir (i1,i2,j,nag)
      do 400 i=1,nm
      dp(i)=dq(i)*dgc(i,i1)*dpc(i,i2)
  400 dc(i)=dq(i)*dgc(i,i2)*dpc(i,i1)
      dval=j+1
      dvalp=dval
      dvalm=dval
      call somm (dr,d,dp,dpas,dvalp,-1,nm)
      call somm (dr,d,dc,dpas,dval,-1,nm)
      call ykdir (i2,i1,j,nag)
      do 410 i=1,nm
  410 dp(i)=dq(i)*dgc(i,i2)*dpc(i,i1)
      call somm (dr,d,dp,dpas,dvalm,-1,nm)
  420 if (iprint .ge. 5)  write(16,430) j,nqn(i1),titre(i1),nqn(i2),
     1                                   titre(i2),dvalm,dval,dvalp
  430 format (' gm',i2,' (',i1,a2,',',i1,a2,')',5x,'(-1)=',1pe14.7,5x,'(
     10)=',1pe14.7,5x,'(+1)=',1pe14.7)
  440 if (n1+1) 460,450,330
  450 i1=i1+1
      i2=i1
      if (i1-norb) 360,360,330
  460 i2=i2+1
      if (i2-norb) 360,360,450
  470 if (nmrk.eq.0) go to 530
      if (iprint .ge. 5)  write(16,20)
      if (iprint .ge. 5)  write(16,480)
  480 format (/,20x,'integrales magnetiques rk=integrale de p1(1)*q2(1)*
     1uk(1,2)*p3(2)*q4(2)'//)
  490 read (5,10) i1,i2,i3,i4,k
      if (i1.le.0) go to 530
      if (i1.le.norb.and.i2.gt.0.and.i2.le.norb.and.i3.gt.0.and.i3.le
     1 .norb.and.i4.gt.0.and.i4.le.norb.and.k.ge.0) go to 500
      if (iprint .ge. 5)  write(16,70) i1,i2,i3,i4,k
      go to 490
  500 call ykdir (i1,i2,k,nag)
      do 510 i=1,np
  510 dp(i)=dq(i)*dgc(i,i3)*dpc(i,i4)
      dval=k+1
      call somm (dr,d,dp,dpas,dval,-1,np)
      if (iprint .ge. 5)  write(16,520) k,nqn(i1),titre(i1),nqn(i2),
     1              titre(i2),nqn(i3),titre(i3),nqn(i4),titre(i4),dval
  520 format (20x,'rm',i2,' (',i1,a2,',',i1,a2,',',i1,a2,',',i1,a2,') ='
     1 ,1pe14.7)
      go to 490
  530 return
      end

max_stars_repo_name: keechul/ifeffit

max_stars_repo_licenses: Naumen Condor-1.1 MS-PL

max_issues_repo_name: bruceravel/ifeffit

max_issues_repo_licenses: Naumen Condor-1.1 MS-PL

max_forks_repo_name: bruceravel/ifeffit

max_forks_repo_licenses: Naumen Condor-1.1 MS-PL


text:
	SUBROUTINE GG_LTNG ( dattim, ktminc, kcolrs, numc, ppmark,
     +			     pnmark, iflgs, iret )
C************************************************************************
C* GG_LTNG								*
C*									*
C* This subroutine sets up the times and attributes for plotting        *
C* lightning data.                                                      *
C*									*
C* GG_LTNG ( DATTIM, KTMINC, KCOLRS, NUMC, PPMARK, PNMARK, IFLGS, IRET )*
C*                                                                      *
C* Input parameters:							*
C*	DATTIM		CHAR*		Ending time for lightning data  *
C*	KTMINC(*)	INTEGER 	Time increments in minutes      *
C*	KCOLRS(*)	INTEGER		Color for each time increment   *
C*	NUMC		INTEGER		Number of colors                *
C*	PPMARK(*)	REAL		Marker values for + strikes     *
C*	PNMARK(*)	REAL		Marker values for - strikes     *
C*	IFLGS(*)	INTEGER		Flag values for data 		*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*									*
C**									*
C* Log:									*
C* D. Kidwell/NCEP	12/99	                                        *
C* S. Jacobs/NCEP	12/99	Added color bar				*
C* D. Kidwell/NCEP	 2/00	Added multiple data sources;restructured*
C* S. Jacobs/NCEP	 3/00	Renamed KSORC to IFLGS; Changed call to	*
C*				GG_LTRP to add Pos and Neg flags	*
C* M. Li/GSC             5/00   Added MXNMFL and MXFLSZ                 *
C* J. Wu/GSC             7/00   Added checks for TI_STAN return status	*
C* S. Jacobs/NCEP	 3/01	Increased file template to 48 chars	*
C* S. Jacobs/NCEP	10/01	Removed loop for getting attributes	*
C* A. Hardy/SAIC         2/02   Changed call FL_SCND			*
C* B. Yin/SAIC           3/04   Changed SS_GTIM to CSS_GTIM             *
C* T. Lee/SAIC		 9/04	Replaced FL_TMPL with CTB_DTGET		*
C* T. Lee/SAIC		10/04	Increased ALIAS size to append NULL	*
C* A. Hardy/NCEP	11/04	Added calls to ST_RNUL			*
C* m.gamazaychikov/SAIC 12/04   Added ion flag to CTB_DTGET CS          *
C* m.gamazaychikov/SAIC 01/06   Changed templ string length to MXTMPL   *
C* m.gamazaychikov/SAIC 04/06   Added idtmch flag to CTB_DTGET CS       *
C* F. J. Yen/NCEP        4/08   Added bin mins & mstrct to CTB_DTGET CSC*
C* S. Jacobs/NCEP	 7/08	Fixed calc of time increments		*
C* L. Hinson/AWC         4/11   Add LTGA Alias for ATDNet Lightning     *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	dattim
	INTEGER		ktminc (*), kcolrs (*), iflgs (*)
	REAL 		ppmark (*), pnmark (*)
C*
	PARAMETER	( NUMSRC = 4 )
C*
	CHARACTER	path*25, templ*(MXTMPL), cdttm*20, dattm2*20,
     +         		tfile*128, stime*20, flstrt*160, datfil*20,
     +			datgrp (LLCLEV)*20
	CHARACTER*(MXFLSZ)      filnam, files (MXNMFL), alias (NUMSRC)
	INTEGER		itarr(5), jtarr(5), itminc (LLCLEV),
     +			icolrs (LLCLEV), mark (6), itype
	REAL		ftminc(LLCLEV), szmrkr (2)
	LOGICAL		done
C*
	DATA		alias / 'LTNG', 'LTGO', 'LTGT', 'LTGA' /
C-----------------------------------------------------------------------
	iret = 0
C
	numclr = numc
	IF ( numclr .gt. 0 ) THEN
 	    DO ii = 1, numclr
		itminc ( ii ) = ktminc ( ii )
		ftminc ( ii ) = ktminc ( ii )
		icolrs ( ii ) = kcolrs ( ii )
	    END DO
	  ELSE
C
C*	    No times or colors were specified.  Set defaults.
C
	    numclr = 1
	    itminc ( 1 ) = 5
	    ftminc ( 1 ) = 5.
	    icolrs ( 1 ) = 2
	END IF
	ftminc (numclr+1) = ftminc (numclr)
	icolrs (numclr+1) = 0
        nexp   = MXNMFL
	iorder = 1
C
C*	Check for the last file requested by the user.
C
	CALL ST_LCUC ( dattim, dattim, ier )
	itype = 1
	IF  ( dattim .eq. 'LAST' ) THEN
	    CALL CSS_GTIM ( itype, dattm2, ier )
	  ELSE IF ( dattim .eq. 'ALL' ) THEN
	    RETURN
	  ELSE
	    CALL CSS_GTIM ( itype, cdttm, ier )
	    CALL TI_STAN ( dattim, cdttm, dattm2, ier )
	    IF ( ier .ne. 0 ) THEN
	    	CALL ER_WMSG ( 'TI', ier, dattim, ierr )
	    	iret = ier
	    	return
	    ENDIF
	END IF
C
C*	Calculate how far to go back by using the last time increment.
C
	minuts = itminc ( numclr )
	CALL TI_CTOI ( dattm2, itarr, ier )
	CALL TI_SUBM ( itarr, minuts, jtarr, ier )
	CALL TI_ITOC ( jtarr, stime, ier )
C
C*	Get the break times for changing the marker color.
C*	Subtract each increment from the frame time and add it to
C*	the list with the earliest time first.
C
	ntimes = numclr + 1
	datgrp ( ntimes ) = dattm2
	CALL TI_CTOI ( dattm2, itarr, ier )
	indx = 1
	DO ii = numclr, 1, -1
	    CALL TI_SUBM ( itarr, itminc(ii), jtarr, ier )
	    CALL TI_ITOC ( jtarr, datgrp(indx), ier )
	    indx = indx + 1
	END DO
C
C*	Get the marker attributes.
C
	mark ( 1 )   = NINT ( ppmark ( 1 ) )
	mark ( 2 )   = 0
	mark ( 3 )   = NINT ( ppmark ( 3 ) )
	szmrkr ( 1 ) = ppmark (2)
C
	mark ( 4 )   = NINT ( pnmark ( 1 ) )
	mark ( 5 )   = 0
	mark ( 6 )   = NINT ( pnmark ( 3 ) )
	szmrkr ( 2 ) = pnmark ( 2 )
C
C*	Set the default values.
C
	IF ( mark ( 1 ) .eq. 0 )  mark ( 1 ) = 1
	IF ( mark ( 3 ) .eq. 0 )  mark ( 3 ) = 1
	IF ( mark ( 4 ) .eq. 0 )  mark ( 4 ) = 22
	IF ( mark ( 6 ) .eq. 0 )  mark ( 6 ) = 1
C
	IF ( szmrkr ( 1 ) .eq. 0. ) szmrkr ( 1 ) = 1.
	IF ( szmrkr ( 2 ) .eq. 0. ) szmrkr ( 2 ) = 1.
C
	CALL GQCOLR ( jcolr, ier )
	CALL GQMRKR ( jmark, jmkhw, szmark, jmkwid, ier )
C
C*	Loop on the data sources.
C
	DO ks = 1, NUMSRC
	    IF ( iflgs ( ks+2 ) .ne. 0 ) THEN
C
C*	        Scan the directory for all of the lightning data files.
C
		CALL ST_NULL ( alias ( ks ), alias ( ks ), na, ier )
		path  = ' '
		templ = ' '
		CALL CTB_DTGET ( alias ( ks ), path, templ,
     +				 ic, is, if, ir, ii, ion, ihb, mnb,
     +				 iha, mna, mstrct, idtmch, ier )
		CALL ST_RNUL ( path, path, lens, ier )
		CALL ST_RNUL ( templ, templ, lens, ier )
	        CALL ST_LSTR ( path, lenp, ier )
	        CALL FL_SCND ( path, templ, iorder, nexp, files, nfile,
     +                         ier )
		IF ( ier .eq. 0 ) THEN
C
C*		    This data source exists.  Make the file name for the
C*		    last file requested.
C
	            CALL FL_MNAM ( dattm2, templ, filnam, ier )
C
C*	            Find the earliest file to start searching.
C
	            CALL FL_MNAM ( stime, templ, flstrt, ier )
C
C*	            Decode each file until the end time is reached.
C
	            done = .false.
	            ifl  = 1
	            DO WHILE ( ( ifl .le. nfile ) .and. ( .not. done ) )
	                IF  ( files(ifl) .gt. filnam )  THEN
		            done = .true.
	                  ELSE
		            IF  ( files(ifl) .ge. flstrt )  THEN
		                tfile = path(:lenp) // '/' // files(ifl)
		                CALL FL_DOPN ( tfile, 1, .false., lunf,
     +					       ier )
C
C*		                Get the time for this data from the file
C*				name.
C
		                CALL FL_MDAT ( files ( ifl ), templ,
     +				  	       dattm2, datfil, ier )
C
C*				Read and plot the lightning data.
C
				CALL GG_LTRP ( lunf, dattm2, datfil,
     +					       datgrp, ntimes, icolrs,
     +					       mark, szmrkr, iflgs(1),
     +					       iflgs(2), ier )
		            END IF
	                END IF
	                ifl = ifl + 1
	            END DO
C
	        END IF
	    END IF
	END DO
C
C*	Draw the color bar.
C
	CALL GG_CBAR ( '1/V/LR/.995;.05/.5;.01/-1',
     +			numclr, ftminc, icolrs, ier )
C
C*	Reset the saved attributes.
C
	CALL GSCOLR ( jcolr, ier )
	CALL GSMRKR ( jmark, jmkhw, szmark, jmkwid, ier )
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
      module comparttr
!***********************************************************************
! $Id: comparttr.f,v 1.3 2006/09/20 19:48:05 zvd Exp $
!***********************************************************************
!  Copyright, 2002, 2004,  The  Regents of the University of California.
!  This  program  was  prepared by  the  Regents  of the  University  of
!  California  at Los Alamos National Laboratory (the  University) under
!  contract No. W-7405-ENG-36 with the U. S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is  granted to the  public to copy  and  use this software
!  without  charge,  provided that this  Notice  and  any  statement  of
!  authorship are reproduced on all copies. Neither the U. S. Government
!  nor  the  University  makes any  warranty,  express  or  implied,  or
!  assumes any liability or responsibility for the use of this software.
!***********************************************************************
!     Module containing particle tracking arrays and variables
!
!     Identifier      Type     Description
!
!     npart           integer  number of particles in the simulation
!                                (input in simulation input file, as
!                                opposed to n_particles, input in the
!                                sptr output file. Code checks to make
!                                sure they are the same)
!     start_no        integer  starting particle number for each source,
!                                array of size n_sources
!     end_no          integer  ending particle number for each source,
!                                array of size n_sources
!     step_no         integer  step in do loop for particles associated
!                                with each source, array of size
!                                n_sources
!     n_part_source   integer  number of particles associated with each
!                                source, array of size n_sources
!     n_packed        integer  total number of cells all particles pass
!                                through
!     n_cells         integer  number of cells that each particle passed
!                                through during simulation, array of
!                                size n_particles
!     cell_packed     integer  array of cell numbers that each particle
!                                enters, array of size total sum of
!                                cells passed through for all particles
!     time_packed     real*8   array of times that each particle enters
!                                the corresponding cell in the
!                                cell_packed array, array of size total
!                                sum of cells passed through for all
!                                particles
!     adv_packed      real*8   array of delta times that the particle
!                               takes for the advective step across
!                               the cell in the cell packed array,
!                               array of size total sum of cells passed
!                               through for all particles
!     x_packed        real*8   array of x coordinates where each particle
!                                enters the corresponding cell in the
!                                cell_packed array, array of size total
!                                sum of cells passed through for all
!                                particles
!     y_packed        real*8   array of y coordinates where each particle
!                                enters the corresponding cell in the
!                                cell_packed array, array of size total
!                                sum of cells passed through for all
!                                particles
!     z_packed        real*8   array of z coordinates where each particle
!                                enters the corresponding cell in the
!                                cell_packed array, array of size total
!                                sum of cells passed through for all
!                                particles
!     cell_index      integer  array of locations in the packed arrays
!                                where each particle information starts,
!                                array of size n_particles
!     cell_path       integer  array denoting whether a particle has
!                                passed through the grid cell, array of
!                                size n_grid_points
!     n_touched_cells integer  number of cells that particles have
!                                passed through
!     touched_cells   integer  array containing the condensed version of
!                                cell_path, i.e. an array of only those
!                                cells that have particles passing
!                                through them, array of size
!                                n_touched_cells
!     concentration   real*8   array of computed concentrations for the
!                                cells in the compact array, array of
!                                size n_touched_cells
!     conc_mobile     real*8   array of computed mobile concentrations
!                                for the cells in the compact array,
!                                array of size n_touched_cells
!     conc_total      real*8   array of computed total concentrations
!                                for the cells in the compact array,
!                                array of size n_touched_cells
!     conc_mobtot     real*8   array of computed total mobile
!                                concentrations for the cells in the
!                                compact array, array of size
!                                n_touched_cells
!     kdecay          real*8   1st order decay constant
!     cfavg           real*8   computed outlet concentration from each
!                                flux averaged concentration zone,
!                                array of size nfavgzones
!     zone_vol        real*8   computed zone volume for each flux
!                                averaged concentration zone,
!                                array of size nfavgzones
!     cmin            real*8   minimum output concentration parameter,
!                                if the calculated concentration is less
!                                than cmin it will be set to 0
!     cthreshold      real*8   minimum output concentration threshold,
!                                if the calculated concentration is less
!                                than cthreshold it will not be output for
!                                the favg pckd output option
!***********************************************************************

      integer npart
      integer, allocatable :: start_no(:)
      integer, allocatable :: end_no(:)
      integer, allocatable :: step_no(:)
      integer, allocatable :: n_part_source(:)
      integer n_packed
      integer, allocatable :: n_cells(:)
      integer, allocatable :: cell_packed(:)
      real*8, allocatable :: time_packed(:)
      real*8, allocatable :: adv_packed(:)
      real*8, allocatable :: x_packed(:)
      real*8, allocatable :: y_packed(:)
      real*8, allocatable :: z_packed(:)
      integer, allocatable :: cell_index(:)
      integer, allocatable :: cell_path(:)
      integer n_touched_cells
      integer, allocatable :: touched_cells(:)
      real*8, allocatable :: concentration(:)
      real*8, allocatable :: conc_mobile(:)
      real*8, allocatable :: conc_total(:)
      real*8, allocatable :: conc_mobtot(:)
      real*8, allocatable :: zone_vol(:)
      real*8 kdecay
      real*8, allocatable :: cfavg(:)
      real*8 cmin
      real*8 cthreshold
      parameter (cmin = 1.e-30)

      end module comparttr

max_stars_repo_name: lanl/PLUMECALC

max_issues_repo_name: lanl/PLUMECALC

max_forks_repo_name: lanl/PLUMECALC