text:
c     Subroutine to place monthly values on common date stamp
c     AJ_Kettle, Nov30/2017
c     Dec5/2017: modified to include totals; total month ppt exported

      SUBROUTINE common_month_variables(f_ndflag,i_ndflag,l_prod,
     +  s_day_date,
     +  f_dayavg_airt_k,f_daytot_ppt_mm,
     +  f_dayavg_wspd_ms,f_dayavg_slpres_hpa,
     +  s_dayavg_airtk_stime,s_dayavg_airtk_timezone,
     +  s_daytot_ppt_stime,s_daytot_ppt_timezone,
     +  s_dayavg_wspd_stime,s_dayavg_wspd_timezone,
     +  s_dayavg_slpres_stime,s_dayavg_slpres_timezone,

     +  l_monrec_common,s_monrec_common_month,s_monrec_common_year,
     +  f_monrec_common_nseconds,
     +  s_monrec_common_stime,s_monrec_common_timezone5,
     +  f_monrec_airt_k,i_monrec_airt_flag,
     +  f_monrec_wspd_ms,i_monrec_wspd_flag,
     +  f_monrec_slpres_hpa,i_monrec_slpres_flag,
     +  f_monrec_ppt_mm,i_monrec_ppt_flag)

c     +  l_monrec_airt,
c     +  s_monrec_airt_month,s_monrec_airt_year,
c     +  f_monrec_airt_k,i_monrec_airt_flag,
c     +  l_monrec_wspd,
c     +  s_monrec_wspd_month,s_monrec_wspd_year,
c     +  f_monrec_wspd_ms,i_monrec_wspd_flag,
c     +  l_monrec_slpres,
c     +  s_monrec_slpres_month,s_monrec_slpres_year,
c     +  f_monrec_slpres_hpa,i_monrec_slpres_flag,
c     +  l_monrec_ppt,
c     +  s_monrec_ppt_month,s_monrec_ppt_year,
c     +  f_monrec_ppt_mm,i_monrec_ppt_flag)

      IMPLICIT NONE
c************************************************************************
      REAL                :: f_ndflag
      INTEGER             :: i_ndflag
      INTEGER             :: l_prod
      CHARACTER(LEN=8)    :: s_day_date(100000)
      REAL                :: f_dayavg_airt_k(100000)
      REAL                :: f_daytot_ppt_mm(100000)
      REAL                :: f_dayavg_wspd_ms(100000)
      REAL                :: f_dayavg_slpres_hpa(100000)

      CHARACTER(LEN=8)    :: s_dayavg_airtk_stime(100000)
      CHARACTER(LEN=5)    :: s_dayavg_airtk_timezone(100000)
      CHARACTER(LEN=8)    :: s_dayavg_wspd_stime(100000)
      CHARACTER(LEN=5)    :: s_dayavg_wspd_timezone(100000)
      CHARACTER(LEN=8)    :: s_dayavg_slpres_stime(100000)
      CHARACTER(LEN=5)    :: s_dayavg_slpres_timezone(100000)
      CHARACTER(LEN=8)    :: s_daytot_ppt_stime(100000)
      CHARACTER(LEN=5)    :: s_daytot_ppt_timezone(100000)
c****
      INTEGER             :: l_monrec_common
      CHARACTER(LEN=2)    :: s_monrec_common_month(5000)
      CHARACTER(LEN=4)    :: s_monrec_common_year(5000)
      REAL                :: f_monrec_common_nseconds(5000)
      CHARACTER(LEN=8)    :: s_monrec_common_stime(5000)
      CHARACTER(LEN=5)    :: s_monrec_common_timezone5(5000)

c      INTEGER             :: l_monrec_airt
c      CHARACTER(LEN=2)    :: s_monrec_airt_month(5000)
c      CHARACTER(LEN=4)    :: s_monrec_airt_year(5000)
      REAL                :: f_monrec_airt_k(5000)
      INTEGER             :: i_monrec_airt_flag(5000)

c      INTEGER             :: l_monrec_wspd
c      CHARACTER(LEN=2)    :: s_monrec_wspd_month(5000)
c      CHARACTER(LEN=4)    :: s_monrec_wspd_year(5000)
      REAL                :: f_monrec_wspd_ms(5000)
      INTEGER             :: i_monrec_wspd_flag(5000)

c      INTEGER             :: l_monrec_slpres
c      CHARACTER(LEN=2)    :: s_monrec_slpres_month(5000)
c      CHARACTER(LEN=4)    :: s_monrec_slpres_year(5000)
      REAL                :: f_monrec_slpres_hpa(5000)
      INTEGER             :: i_monrec_slpres_flag(5000)

c      INTEGER             :: l_monrec_ppt
c      CHARACTER(LEN=2)    :: s_monrec_ppt_month(5000)
c      CHARACTER(LEN=4)    :: s_monrec_ppt_year(5000)
      REAL                :: f_monrec_ppt_mm(5000)
      INTEGER             :: i_monrec_ppt_flag(5000)
c****
      INTEGER             :: l_monraw_airt
      CHARACTER(LEN=2)    :: s_monraw_airt_month(5000)
      CHARACTER(LEN=4)    :: s_monraw_airt_year(5000)
      REAL                :: f_monraw_airt_k(5000)
      INTEGER             :: i_monraw_airt_flag(5000)
      REAL                :: f_monraw_airt_nseconds(5000)
      CHARACTER(LEN=8)    :: s_monraw_airt_stime(5000)
      CHARACTER(LEN=5)    :: s_monraw_airt_timezone(5000)
      REAL                :: f_monraw_airt_tot_k(5000)

      INTEGER             :: l_monraw_wspd
      CHARACTER(LEN=2)    :: s_monraw_wspd_month(5000)
      CHARACTER(LEN=4)    :: s_monraw_wspd_year(5000)
      REAL                :: f_monraw_wspd_ms(5000)
      INTEGER             :: i_monraw_wspd_flag(5000)
      REAL                :: f_monraw_wspd_nseconds(5000)
      CHARACTER(LEN=8)    :: s_monraw_wspd_stime(5000)
      CHARACTER(LEN=5)    :: s_monraw_wspd_timezone(5000)
      REAL                :: f_monraw_wspd_tot_ms(5000)

      INTEGER             :: l_monraw_slpres
      CHARACTER(LEN=2)    :: s_monraw_slpres_month(5000)
      CHARACTER(LEN=4)    :: s_monraw_slpres_year(5000)
      REAL                :: f_monraw_slpres_hpa(5000)
      INTEGER             :: i_monraw_slpres_flag(5000)
      REAL                :: f_monraw_slpres_nseconds(5000)
      CHARACTER(LEN=8)    :: s_monraw_slpres_stime(5000)
      CHARACTER(LEN=5)    :: s_monraw_slpres_timezone(5000)
      REAL                :: f_monraw_slpres_tot_hpa(5000)

      INTEGER             :: l_monraw_ppt
      CHARACTER(LEN=2)    :: s_monraw_ppt_month(5000)
      CHARACTER(LEN=4)    :: s_monraw_ppt_year(5000)
      REAL                :: f_monraw_ppt_mm(5000)
      INTEGER             :: i_monraw_ppt_flag(5000)
      REAL                :: f_monraw_ppt_nseconds(5000)
      CHARACTER(LEN=8)    :: s_monraw_ppt_stime(5000)
      CHARACTER(LEN=5)    :: s_monraw_ppt_timezone(5000)
      REAL                :: f_monraw_ppt_tot_mm(5000)

      INTEGER             :: ist
      INTEGER             :: ien

      INTEGER             :: ist_vec(4)
      INTEGER             :: ien_vec(4)

      INTEGER             :: i_com_minst
      INTEGER             :: i_com_maxen

      INTEGER             :: i,j,k,ii,jj,kk
c************************************************************************
c      Calculate monthly values from daily values
c       CALL calc_monthly_values(l_prod,s_day_date,
c     +   f_dayavg_airt_c,f_daytot_ppt_mm,
c     +   f_dayavg_wspd_ms,f_dayavg_pres_mb)

       CALL calc_monthly_values2(f_ndflag,i_ndflag,
     +   l_prod,s_day_date,f_dayavg_airt_k,
     +   s_dayavg_airtk_stime,s_dayavg_airtk_timezone,
     +   l_monraw_airt,
     +   s_monraw_airt_year,s_monraw_airt_month,
     +   f_monraw_airt_k,i_monraw_airt_flag,
     +   f_monraw_airt_nseconds,
     +   s_monraw_airt_stime,s_monraw_airt_timezone,
     +   f_monraw_airt_tot_k)

       CALL calc_monthly_values2(f_ndflag,i_ndflag,
     +   l_prod,s_day_date,f_dayavg_wspd_ms,
     +   s_dayavg_wspd_stime,s_dayavg_wspd_timezone,
     +   l_monraw_wspd,
     +   s_monraw_wspd_year,s_monraw_wspd_month,
     +   f_monraw_wspd_ms,i_monraw_wspd_flag,
     +   f_monraw_wspd_nseconds,
     +   s_monraw_wspd_stime,s_monraw_wspd_timezone,
     +   f_monraw_wspd_tot_ms)

       CALL calc_monthly_values2(f_ndflag,i_ndflag,
     +   l_prod,s_day_date,f_dayavg_slpres_hpa,
     +   s_dayavg_slpres_stime,s_dayavg_slpres_timezone,
     +   l_monraw_slpres,
     +   s_monraw_slpres_year,s_monraw_slpres_month,
     +   f_monraw_slpres_hpa,i_monraw_slpres_flag,
     +   f_monraw_slpres_nseconds,
     +   s_monraw_slpres_stime,s_monraw_slpres_timezone,
     +   f_monraw_slpres_tot_hpa)

       CALL calc_monthly_values2(f_ndflag,i_ndflag,
     +   l_prod,s_day_date,f_daytot_ppt_mm,
     +   s_daytot_ppt_stime,s_daytot_ppt_timezone,
     +   l_monraw_ppt,
     +   s_monraw_ppt_year,s_monraw_ppt_month,
     +   f_monraw_ppt_mm,i_monraw_ppt_flag,
     +   f_monraw_ppt_nseconds,
     +   s_monraw_ppt_stime,s_monraw_ppt_timezone,
     +   f_monraw_ppt_tot_mm)

c      print*,'l_monraw..',l_monraw_airt,l_monraw_wspd,l_monraw_slpres,
c     +   l_monraw_ppt
c************************************************************************
c      Find earliest common ist; latest common ien (4 possible)

c      Initialize search vectors with ndflag
       DO i=1,4
        ist_vec(i)=i_ndflag
        ien_vec(i)=i_ndflag
       ENDDO
c****
c      airt
       ii=1
       DO i=1,l_monraw_airt
        IF (f_monraw_airt_k(i).NE.f_ndflag) THEN
         ist_vec(ii)=i
c         print*,'f_monraw_airt_k=',f_monraw_airt_k(i)
         GOTO 10
        ENDIF
       ENDDO
10     CONTINUE
c****
c      wspd
       ii=2
       DO i=1,l_monraw_wspd
        IF (f_monraw_wspd_ms(i).NE.f_ndflag) THEN
         ist_vec(ii)=i
c         print*,'f_monraw_wspd_ms=',f_monraw_wspd_ms(i)
         GOTO 12
        ENDIF
       ENDDO
12     CONTINUE
c****
c      slpres
       ii=3
       DO i=1,l_monraw_slpres
        IF (f_monraw_slpres_hpa(i).NE.f_ndflag) THEN
         ist_vec(ii)=i
c         print*,'f_monraw_slpres_hpa=',f_monraw_slpres_hpa(i)
         GOTO 14
        ENDIF
       ENDDO
14     CONTINUE
c****
c      wspd
       ii=4
       DO i=1,l_monraw_ppt
        IF (f_monraw_ppt_mm(i).NE.f_ndflag) THEN
         ist_vec(ii)=i
c         print*,'f_monraw_ppt_mm=',f_monraw_ppt_mm(i)
         GOTO 16
        ENDIF
       ENDDO
16     CONTINUE
c************************************************************************
c      ENDPOINTS
c      airt
       ii=1
       DO i=l_monraw_airt,1,-1
        IF (f_monraw_airt_k(i).NE.f_ndflag) THEN
         ien_vec(ii)=i
         GOTO 20
        ENDIF
       ENDDO
20     CONTINUE
c****
c      wspd
       ii=2
       DO i=l_monraw_wspd,1,-1
        IF (f_monraw_wspd_ms(i).NE.f_ndflag) THEN
         ien_vec(ii)=i
         GOTO 22
        ENDIF
       ENDDO
22     CONTINUE
c****
c      slpres
       ii=3
       DO i=l_monraw_slpres,1,-1
        IF (f_monraw_slpres_hpa(i).NE.f_ndflag) THEN
         ien_vec(ii)=i
         GOTO 24
        ENDIF
       ENDDO
24     CONTINUE
c****
c      wspd
       ii=4
       DO i=l_monraw_ppt,1,-1
        IF (f_monraw_ppt_mm(i).NE.f_ndflag) THEN
         ien_vec(ii)=i
         GOTO 26
        ENDIF
       ENDDO
26     CONTINUE
c************************************************************************
c     Find common index for start & end month

c      print*,'ist_vec=',(ist_vec(i),i=1,4)
c      print*,'ien_vec=',(ien_vec(i),i=1,4)

c     Find common min_ist
      i_com_minst=10000
      DO i=1,4
       IF (ist_vec(i).NE.i_ndflag) THEN
        i_com_minst=MIN(i_com_minst,ist_vec(i))
       ENDIF
      ENDDO

      i_com_maxen=0
      DO i=1,4
       IF (ien_vec(i).NE.i_ndflag) THEN
        i_com_maxen=MAX(i_com_maxen,ien_vec(i))
       ENDIF
      ENDDO

c      print*,'i_com_minst,i_com_maxen=',i_com_minst,i_com_maxen
c************************************************************************
c     Extract clipped datasets

      ii=0
      jj=0

      DO i=i_com_minst,i_com_maxen
      jj=jj+1

      IF (LEN_TRIM(s_monraw_airt_stime(i)).GT.0) THEN
       ii=ii+1
c       l_monrec_common=l_monrec_common+1
       s_monrec_common_month(ii)    =s_monraw_airt_month(i)
       s_monrec_common_year(ii)     =s_monraw_airt_year(i)
       f_monrec_common_nseconds(ii) =f_monraw_airt_nseconds(i)
       s_monrec_common_stime(ii)    =s_monraw_airt_stime(i)
       s_monrec_common_timezone5(ii)=s_monraw_airt_timezone(i)

c       IF (LEN_TRIM(s_monraw_airt_stime(i)).EQ.0) THEN
c        print*,'i=',i,s_monraw_airt_stime(i),s_monraw_wspd_stime(i),
c     +    s_monraw_slpres_stime(i),s_monraw_ppt_stime(i)
c        call sleep(1)
c       ENDIF

       f_monrec_airt_k(ii)      =f_monraw_airt_k(i)
       i_monrec_airt_flag(ii)   =i_monraw_airt_flag(i)
       f_monrec_wspd_ms(ii)     =f_monraw_wspd_ms(i)
       i_monrec_wspd_flag(ii)   =i_monraw_wspd_flag(i)
       f_monrec_slpres_hpa(ii)  =f_monraw_slpres_hpa(i)
       i_monrec_slpres_flag(ii) =i_monraw_slpres_flag(i)
       f_monrec_ppt_mm(ii)      =f_monraw_ppt_tot_mm(i)
       i_monrec_ppt_flag(ii)    =i_monraw_ppt_flag(i)
      ENDIF
      ENDDO

      l_monrec_common=ii

c      print*,'l_monrec_common=',l_monrec_common
c      print*,'ii,jj=',ii,jj
c      CALL SLEEP(5)
c************************************************************************
c     Test time & timezone for gaps
c      DO i=1,l_monrec_common
c       IF (LEN_TRIM(s_monrec_common_stime(i)).EQ.0) THEN
c        print*,'emergency stop stime not filled',i,l_monrec_common
c        CALL SLEEP(1)
c       ENDIF
c      ENDDO
c************************************************************************
c      print*,'f_monrec_airt_k=',    (f_monrec_airt_k(i),i=1,10)
c      print*,'f_monrec_wspd_ms=',   (f_monrec_wspd_ms(i),i=1,10)
c      print*,'f_monrec_slpres_hpa=',(f_monrec_slpres_hpa(i),i=1,10)
c      print*,'f_monrec_ppt_mm=',    (f_monrec_ppt_mm(i),i=1,10)
c      print*,'n_seconds',(f_monrec_common_nseconds(i),i=1,10)
c      CALL SLEEP(5)

      RETURN
      END

max_stars_repo_name: ajkettle/glamod-nuim

max_issues_repo_name: ajkettle/glamod-nuim

max_forks_repo_name: ajkettle/glamod-nuim


text:
      subroutine evolve_daatheta(n_Athth,n_DDLthetatheta,n_DDLxx,n_JStht
     &h,n_JSxx,n_Pthetatheta,n_RRthetatheta,n_RRxx,n_Uthetatheta,n_alpha
     &,n_em4phi,n_metthetatheta,n_metxx,np1_Athth,np1_DDLthetatheta,np1_
     &DDLxx,np1_JSthth,np1_JSxx,np1_Pthetatheta,np1_RRthetatheta,np1_RRx
     &x,np1_Uthetatheta,np1_alpha,np1_em4phi,np1_metthetatheta,np1_metxx
     &,x,Nx,ht,hx,myzero,zepsdis,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 hx
      real*8 myzero
      real*8 zepsdis
      real*8 n_Athth(Nx)
      real*8 n_DDLthetatheta(Nx)
      real*8 n_DDLxx(Nx)
      real*8 n_JSthth(Nx)
      real*8 n_JSxx(Nx)
      real*8 n_Pthetatheta(Nx)
      real*8 n_RRthetatheta(Nx)
      real*8 n_RRxx(Nx)
      real*8 n_Uthetatheta(Nx)
      real*8 n_alpha(Nx)
      real*8 n_em4phi(Nx)
      real*8 n_metthetatheta(Nx)
      real*8 n_metxx(Nx)
      real*8 np1_Athth(Nx)
      real*8 np1_DDLthetatheta(Nx)
      real*8 np1_DDLxx(Nx)
      real*8 np1_JSthth(Nx)
      real*8 np1_JSxx(Nx)
      real*8 np1_Pthetatheta(Nx)
      real*8 np1_RRthetatheta(Nx)
      real*8 np1_RRxx(Nx)
      real*8 np1_Uthetatheta(Nx)
      real*8 np1_alpha(Nx)
      real*8 np1_em4phi(Nx)
      real*8 np1_metthetatheta(Nx)
      real*8 np1_metxx(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = -0.1D1 * myzero * x(i)
      res(i)=qb
      end do
      endif
      if (phys_bdy(1) .eq. 1) then
      do i=2, 2, 1
      qb = np1_Athth(i) - 0.32D2 / (0.7D1 * zepsdis * hx + 0.64D2 * ht)
     #* hx * ht * (hx * myzero + 0.5000000000000000D0 * (-0.3D1 * np1_At
     #hth(i - 1) + 0.4D1 * np1_Athth(i) - 0.1D1 * np1_Athth(i + 1)) / hx
     # + 0.3125000000000000D-1 * zepsdis / ht * (0.7D1 * np1_Athth(i) +
     #np1_Athth(i + 2) - 0.4D1 * np1_Athth(i + 1) - 0.4D1 * np1_Athth(i
     #- 1)) + 0.3125000000000000D-1 * zepsdis / ht * (0.7D1 * n_Athth(i)
     # + n_Athth(i + 2) - 0.4D1 * n_Athth(i + 1) - 0.4D1 * n_Athth(i - 1
     #)))
      res(i)=qb
      end do
      endif
      do i=3, Nx-2, 1
      qb = np1_Athth(i) - 0.16D2 / (0.16D2 + 0.3D1 * zepsdis) * ht * (-0
     #.1D1 * (n_Athth(i) - 0.1D1 * np1_Athth(i)) / ht + 0.16666666666666
     #67D0 / np1_metxx(i) * np1_alpha(i) * np1_metthetatheta(i) * np1_RR
     #xx(i) * np1_em4phi(i) - 0.1666666666666667D0 / np1_metxx(i) * np1_
     #em4phi(i) * np1_alpha(i) * np1_JSxx(i) * np1_metthetatheta(i) - 0.
     #1666666666666667D0 * np1_alpha(i) * np1_RRthetatheta(i) * np1_em4p
     #hi(i) + 0.1666666666666667D0 * np1_alpha(i) * np1_JSthth(i) * np1_
     #em4phi(i) - 0.5000000000000000D0 * np1_alpha(i) * np1_Uthetatheta(
     #i) - 0.1666666666666667D0 / np1_metxx(i) * np1_DDLxx(i) * np1_mett
     #hetatheta(i) * np1_em4phi(i) + 0.1666666666666667D0 * np1_DDLtheta
     #theta(i) * np1_em4phi(i) - 0.5000000000000000D0 * np1_Pthetatheta(
     #i) + 0.1666666666666667D0 / n_metxx(i) * n_alpha(i) * n_metthetath
     #eta(i) * n_RRxx(i) * n_em4phi(i) - 0.1666666666666667D0 / n_metxx(
     #i) * n_em4phi(i) * n_alpha(i) * n_JSxx(i) * n_metthetatheta(i) - 0
     #.1666666666666667D0 * n_alpha(i) * n_RRthetatheta(i) * n_em4phi(i)
     # + 0.1666666666666667D0 * n_alpha(i) * n_JSthth(i) * n_em4phi(i) -
     # 0.5000000000000000D0 * n_alpha(i) * n_Uthetatheta(i) - 0.16666666
     #66666667D0 / n_metxx(i) * n_DDLxx(i) * n_metthetatheta(i) * n_em4p
     #hi(i) + 0.1666666666666667D0 * n_DDLthetatheta(i) * n_em4phi(i) -
     #0.5000000000000000D0 * n_Pthetatheta(i) + 0.3125000000000000D-1 *
     #zepsdis / ht * (0.6D1 * np1_Athth(i) + np1_Athth(i + 2) + np1_Atht
     #h(i - 2) - 0.4D1 * np1_Athth(i + 1) - 0.4D1 * np1_Athth(i - 1)) +
     #0.3125000000000000D-1 * zepsdis / ht * (0.6D1 * n_Athth(i) + n_Ath
     #th(i + 2) + n_Athth(i - 2) - 0.4D1 * n_Athth(i + 1) - 0.4D1 * n_At
     #hth(i - 1)))
      res(i)=qb
      end do
      do i=Nx-1, Nx-1, 1
      qb = np1_Athth(i) - 0.1D1 * ht * (-0.1D1 * (n_Athth(i) - 0.1D1 * n
     #p1_Athth(i)) / ht + 0.1666666666666667D0 / np1_metxx(i) * np1_alph
     #a(i) * np1_metthetatheta(i) * np1_RRxx(i) * np1_em4phi(i) - 0.1666
     #666666666667D0 / np1_metxx(i) * np1_em4phi(i) * np1_alpha(i) * np1
     #_JSxx(i) * np1_metthetatheta(i) - 0.1666666666666667D0 * np1_alpha
     #(i) * np1_RRthetatheta(i) * np1_em4phi(i) + 0.1666666666666667D0 *
     # np1_alpha(i) * np1_JSthth(i) * np1_em4phi(i) - 0.5000000000000000
     #D0 * np1_alpha(i) * np1_Uthetatheta(i) - 0.1666666666666667D0 / np
     #1_metxx(i) * np1_DDLxx(i) * np1_metthetatheta(i) * np1_em4phi(i) +
     # 0.1666666666666667D0 * np1_DDLthetatheta(i) * np1_em4phi(i) - 0.5
     #000000000000000D0 * np1_Pthetatheta(i) + 0.1666666666666667D0 / n_
     #metxx(i) * n_alpha(i) * n_metthetatheta(i) * n_RRxx(i) * n_em4phi(
     #i) - 0.1666666666666667D0 / n_metxx(i) * n_em4phi(i) * n_alpha(i)
     #* n_JSxx(i) * n_metthetatheta(i) - 0.1666666666666667D0 * n_alpha(
     #i) * n_RRthetatheta(i) * n_em4phi(i) + 0.1666666666666667D0 * n_al
     #pha(i) * n_JSthth(i) * n_em4phi(i) - 0.5000000000000000D0 * n_alph
     #a(i) * n_Uthetatheta(i) - 0.1666666666666667D0 / n_metxx(i) * n_DD
     #Lxx(i) * n_metthetatheta(i) * n_em4phi(i) + 0.1666666666666667D0 *
     # n_DDLthetatheta(i) * n_em4phi(i) - 0.5000000000000000D0 * n_Pthet
     #atheta(i))
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = np1_Athth(i) - 0.1D1 * ht * (-0.1D1 * (n_Athth(i) - 0.1D1 * n
     #p1_Athth(i)) / ht - 0.1D1 * myzero * x(i))
      res(i)=qb
      end do
      endif
      END

ext: f


! Test the `-emit-mlir` option

!-------------
! RUN COMMANDS
!-------------
! RUN: %flang_fc1 -emit-mlir %s -o - | FileCheck %s
! RUN: %flang_fc1 -emit-fir %s -o - | FileCheck %s

! Verify that an `.mlir` file is created when `-emit-mlir` is used. Do it in a temporary directory, which will be cleaned up by the
! LIT runner.
! RUN: rm -rf %t-dir && mkdir -p %t-dir && cd %t-dir
! RUN: cp %s .
! RUN: %flang_fc1 -emit-mlir emit-mlir.f90 && ls emit-mlir.mlir

!----------------
! EXPECTED OUTPUT
!----------------
! CHECK: module attributes {
! CHECK-LABEL: func @_QQmain() {
! CHECK-NEXT:  return
! CHECK-NEXT: }
! CHECK-NEXT: }

!------
! INPUT
!------
end program


!
!  Copyright 2017 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
module salmon_parallel
  implicit none

  !!! multi process
  ! global
  integer, public :: nproc_group_global
  integer, public :: nproc_id_global
  integer, public :: nproc_size_global

  ! TDKS eq.
  integer, public :: nproc_group_tdks
  integer, public :: nproc_id_tdks
  integer, public :: nproc_size_tdks

  integer, public :: nproc_group_spin
  integer, public :: nproc_id_spin
  integer, public :: nproc_size_spin

  integer, public :: nproc_group_grid
  integer, public :: nproc_id_grid
  integer, public :: nproc_size_grid

  integer, public :: nproc_group_orbital
  integer, public :: nproc_id_orbital
  integer, public :: nproc_size_orbital

  integer, public :: nproc_group_h
  integer, public :: nproc_id_h
  integer, public :: nproc_size_h

  integer, public :: nproc_group_kgrid_except0
  integer, public :: nproc_id_kgrid_except0
  integer, public :: nproc_size_kgrid_except0

  integer, public :: nproc_group_korbital_vhxc
  integer, public :: nproc_id_korbital_vhxc
  integer, public :: nproc_size_korbital_vhxc

  integer, public :: nproc_group_bound(3)
  integer, public :: nproc_id_bound(3)
  integer, public :: nproc_size_bound(3)

  ! call once
  public :: setup_parallel
  public :: end_parallel

  ! util
  public :: get_thread_id

contains
  subroutine setup_parallel
    use salmon_communication
    implicit none
    call comm_init
    call comm_get_globalinfo(nproc_group_global, nproc_id_global, nproc_size_global)
  end subroutine

  subroutine end_parallel
    use salmon_communication
    implicit none
    call comm_finalize
  end subroutine

  function get_thread_id() result(nid)
#ifdef _OPENMP
    use omp_lib
#endif
    implicit none
    integer :: nid
#ifdef _OPENMP
    nid = omp_get_thread_num()
#else
    nid = 0
#endif
  end function
end module


text:
      SUBROUTINE TAVISPAK4(KREQMT,ELEMS,LUERR,IERR)
C
C THIS ROUTINE IS PART OF TOSS'S TAVISPAK SET OF SUBROUTINES.  IT
C WRITES MESSAGES FOR ERRORS FOUND DURING EXECUTION OF THE TARGET
C AVAILABILITY ALGORITHMS.
C
C***********************************************************************
C
C BY C PETRUZZ0, GSFC/742,  1/86.
C        MODIFIED....
C
C***********************************************************************
C
      CHARACTER*30 REQTEXT(3) /
     *    'HORIZON AVOIDANCE.',  'VELOCITY VECTOR AVOIDANCE.',
     *    '??????????????????' /
      REAL*8 ELEMS(5)
C
C
      IF(IERR.EQ.1) THEN
C      SET IN TAVISPAK1
        WRITE(LUERR,8001) KREQMT
C
      ELSE IF(IERR.EQ.2) THEN
C      SET IN TAVISPAK1
        WRITE(LUERR,8002) ELEMS(1),ELEMS(2)
C
      ELSE IF(IERR.EQ.3) THEN
C      SET IN TAVISPAK3A
        WRITE(LUERR,8003)
C
      ELSE IF(IERR.EQ.4) THEN
C      SET IN TAVISPAK3A
        WRITE(LUERR,8004) REQTEXT(KREQMT)
C
      ELSE IF(IERR.EQ.5) THEN
C      SET IN TAVISPAK1
        WRITE(LUERR,8005)
C
      ELSE IF(IERR.EQ.6) THEN
C      SET IN TAVISPAK1
        WRITE(LUERR,8006)
C
      ELSE IF(IERR.EQ.7) THEN
C      SET IN TAVISPAK1
        WRITE(LUERR,8007)
C
      ELSE IF(IERR.EQ.8) THEN
C      SET IN TAVISPAK3B
        WRITE(LUERR,8008)
C
      ELSE IF(IERR.EQ.9) THEN
C      SET IN TAVISPAK3B
        WRITE(LUERR,8009)
C
      ELSE
C      MISC ERROR.
        WRITE(LUERR,8099)
        END IF
C
 8001 FORMAT(/,' TAVISPAK4. INPUT ERROR. BAD REQUIREMENT IDENTIFIER.',
     *     '  VALUE=',I5)
 8002 FORMAT(/,' TAVISPAK4. INPUT ERROR. BAD SMA OR ECC.  VALUES=',
     *                 2G16.8)
 8003 FORMAT(/,' TAVISPAK4. ERROR. NUMERICAL ERROR IN TAVISPAK99.')
 8004 FORMAT(/,' TAVISPAK4. ERROR. ALGORITHM HAS NOT CONVERGED. ',
     *                'NO SOLUTION.'/,
     *         '            FUNCTION EXECUTED WAS ',A)
 8005 FORMAT(/,' TAVISPAK4. ERROR. SOLID EARTH ANGLE PLUS HORIZON ',
     *               'AVOIDANCE ANGLE '/,
     *         '            IS NOT IN 0 TO 180 DEG RANGE.')
 8006 FORMAT(/,' TAVISPAK4. ERROR. PERIGEE RADIUS BELOW EARTH SURFACE.')
 8007 FORMAT(/,' TAVISPAK4. ERROR. RAM OR ZENITH REQUIREMENT ANGLE '/,
     *         '            IS NOT IN 0 TO 180 DEG RANGE.')
 8008 FORMAT(/,' TAVISPAK4. ERROR. NUMERICAL ERROR IN TAVISPAK3B.')
 8009 FORMAT(/,' TAVISPAK4. ERROR. NUMERICAL ERROR IN TAVISPAK3X.')
 8099 FORMAT(/,' TAVISPAK4. ERROR. MISC ERROR.')
C
      RETURN
      END

ext: for


   PROGRAM chi_calcul
   IMPLICIT NONE

   INTEGER (KIND=8),PARAMETER::n=41

   INTEGER (KIND=8) :: i

   REAL (KIND=8),DIMENSION(n) :: eps,E,Cv,M1,M2,M3,chi1,chi2,chi3,slop_chi

!!!=======================================================================================
!!!=======================================================================================
!!!=======================================================================================
!!!=======================================================================================
   OPEN(unit=11,file='E_av_40_1.dat')
   OPEN(unit=12,file='chi_slop_40_1.txt')

   DO i=1,n
      READ(11,*)eps(i),E(i),Cv(i),M1(i),M2(i),M3(i),chi1(i),chi2(i),chi3(i)
   END DO

   slop_chi(:)=0.

   DO i=1,n-1
      WRITE(*,*)chi1(i),chi1(i+1),eps(i),eps(i+1)
      slop_chi(i+1)=(log(chi1(i+1))-log(chi1(i)))/(log(abs(eps(i+1)))-log(abs(eps(i))))

      WRITE(12,*)abs(eps(i+1)),slop_chi(i+1)
   END DO

!!!=======================================================================================

   CLOSE(11)
   CLOSE(12)

   END PROGRAM chi_calcul


text:
!***************************************************************************************************************************
! This is the code from the section (DYNAMIC == RATE) lines 4643 - 4706 of the original CSCAS code.The names of the
! dummy arguments are the same as in the original CSCAS code and the call statement and are declared here. The variables
! that are not arguments are declared in module YCA_First_Trans_m. Unless identified as by MF, all comments are those of
! the original CSCAS.FOR code.
!
! Subroutine YCA_Growth_Photo calculates assimilation.
!
! NOTE: Hidden code (commented out) gives very different output. Why?
!***************************************************************************************************************************

    SUBROUTINE YCA_Growth_Photo ( &
        CO2         , NFP         , SLPF        , SRAD        , TAIRHR      , TDEW        , TMAX        , TMIN         &
        )

        USE ModuleDefs
        USE ModuleData
        USE YCA_First_Trans_m
        USE YCA_Control_Photosyntesis

        IMPLICIT  NONE

        REAL    CO2         , NFP         , SLPF        , SRAD        , TAIRHR(24)  , TDEW        , TMAX        , TMIN
        REAL    CSVPSAT                                                                            ! REAL function call
        real availableCH2O

        SAVE

        !-----------------------------------------------------------------------
        !           Calculate C assimilation at beginning of day.
        !-----------------------------------------------------------------------

        ! PAR utilization efficiency
        PARU = PARUE

        ! Select method depending on choice in CONTROL FILE
        select case(MEPHO)
            case ('R')
                availableCH2O = availableCarbohydrate_methodR(PARMJFAC, SRAD, PARU, CO2FP, TFP, RSFP, VPDFP, SLPF, PARI, PLTPOP)
            case ('I')
                availableCH2O = availableCarbohydrate_methodI(CO2, CO2AIR, CO2EX, CO2FP, CO2COMPC, PARMJFAC, PARFC, PARI, PARU, PLTPOP, RATM, RCROP, RLFC, RLF, RSFP, SLPF, SRAD, TMAX, TMIN, TFP, WFP)
            case ('M')
                availableCH2O = availableCarbohydrate_methodM(CO2AIR,PARU, RATM, RCROP,RLFC, RLF, WFP, MJPERE, PARMJFAC, SRAD, TFP, RSFP, SLPF, PARI, PLTPOP)
            case ('V')
                availableCH2O = availableCarbohydrate_methodV(TMin, TMax, TDEW, SRAD, PHTV, PHSV, KCANI, LAI, PARUE)
            end select
        CARBOBEG = availableCH2O

    END SUBROUTINE YCA_Growth_Photo

max_stars_repo_name: vstocca/dssat-csm-os

max_issues_repo_name: vstocca/dssat-csm-os

max_forks_repo_name: vstocca/dssat-csm-os


text:
This editor can edit this entry and tell us a bit about themselves by clicking the Edit icon.

20090811 19:19:34 nbsp  Welcome to the Wiki. You can establish identity here in a variety of ways. Doing so will give more weight to your comment on the Alvarado Sunset Apartments page. Youve already chosen your Importance of using your RealName username, so the next step would be to introduce yourself and make some positive contributions like adding business reviews, Photo Requests uploading photos, or adding to Seed Pages List pages that need more information. Users/JasonAller

20100607 11:28:04 nbsp Sorry if I came across as rude, but the coincidence of that many people in so short a time span is laughable.  Welcome to the wiki, I hope you stick around! Is there anything in Davis other than your apartment manager that you like? Theres a whole lot of restaurants, parks and regular events events in Davis this nifty place.  Users/EdWins ES

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
C    @(#)savenetd.f	20.13 10/13/99
C****************************************************************
C
C   	File: savenetd.f
C
C   	Purpose: Write network data file in four dialects using base
C                case in residence: BPA, WSCC (IPS), PTI, & PECO.
C                                                                      *
C       Input parameters:
C
C       savfil         - the logical unit opened
C       saveflnm       - the name of the file opened (for diagnostics)
C       dialect        - a character string (BPA, WSCC, WSCC1, PTI)
C                        denoting the dialect of the WSCC record.
c       size           - a character string "80", "120" or "B80/L120"
C                        denoting the bus/branch output record size
c       ratings        - a character string denoting how extended
c                        line ratings are to be used (EXTENDED,
c                        NOMINAL, or MINIMUM)
c       sections       - a character string <null> or "PSEUDOBUSES"
c                        denoting how line sections are to be
c                        represented
c       type_e         - a character string <null> or "SYMMETRIC"
c                        denoting how assymetric type E-branches are
c                        to be represented
c       ipsfil         - a logical unit for a WSCC reference data file
c       ipsref_file    - a character string or <null> denoting the name
c                        of the WSCC reference file opened.
c       zonerenfil     - a logical unit for a zone rename change file
c                        name
c       zone_ren_file  - a character string or <null> denoting the name
c                        of a zone rename change reference file opened.
C
C   	Author: Walt Powell            Date: 13 January 1993
C   	Called by: p_svfile.f
C
C****************************************************************
C
      	integer function savenetd (savfil, saveflnm, dialect, size,
     &                             ratings, sections, type_e, ipsfil,
     &                             ipsref_file, zonerenfil,
     &                             zone_ren_file)
        integer savfil, ipsfil, zonerenfil
        character *(*) saveflnm, dialect, size, ratings, sections,
     &                 type_e, ipsref_file, zone_ren_file

      	include 'ipfinc/parametr.inc'

      	include 'ipfinc/blank.inc'
        include 'ipfinc/arcntl.inc'
        include 'ipfinc/area.inc'
      	include 'ipfinc/bus.inc'
      	include 'ipfinc/lfiles.inc'
      	include 'ipfinc/prt.inc'
        include 'ipfinc/jobctl.inc'
        include 'ipfinc/basval.inc'
        include 'ipfinc/header.inc'
        include 'ipfinc/coment.inc'
        include 'ipfinc/pti_data.inc'
        include 'ipfinc/wsccbase.inc'

        character ratcod*2, text*120, code*10, zmod(2,15)*2, zn*2
        integer lenrec, ext_ai, ext_bus, ext_brn, ftn_atoi, find_bus,
     &          status, zone_ren
        logical finished

        savenetd = 0
        num0 = 0
        numa = 0
        numb = 0
        numl = 0

        if (index (size, '120') .ne. 0) then
          lenrec = 120
        else
          lenrec = 80
        endif
        ratcod = ratings(1:1)

        if ( dialect .eq. 'PTI' ) then

c          PTI dialect

           do nb = 1, ntot
             if (wsccbase(nb) .ne. ' ') then
               pti_name(nb) = wsccbase(nb)
             else
               pti_name(nb) = code (base(nb), 4, 0)
             endif
           enddo

c          set up comment lines
c                          ....
           if (index (cspare(30), char(0)) .eq. 1 .or.
     &         cspare(30) .eq. ' ') cspare(30) = 'data'
           write (busbrn,110) cspare(30)
           write (busbrn,110) cspare(30)
           write (busbrn,110) cspare(30)
  110      format (' ', a)
C
C          Process zone rename card "Z"
           if (zone_ren_file .ne. ' ' .and.
     &         zone_ren_file(1:) .ne. char(0)) then
             status = zone_ren (zonerenfil)
           endif

c          Extract area interchanges and area interties
           numa = ext_ai ( savfil, dialect, lenrec, ratcod, sections,
     &                     type_e )

c          Extract bus data
           numb = ext_bus ( savfil, dialect, lenrec, ratcod, sections,
     &                      type_e )

c          Extract branch data
           numl = ext_brn ( savfil, dialect, lenrec, ratcod, sections,
     &                      type_e )

        elseif ( dialect(1:3) .eq. 'BPA' .or.
     &           dialect(1:4) .eq. 'WSCC') then

           do nb = 1, ntot
             if (wsccbase(nb) .ne. ' ') then
               pti_name(nb) = wsccbase(nb)
             else
               pti_name(nb) = code (base(nb), 4, 0)
             endif
           enddo

           if (dialect(1:4) .eq. 'WSCC' .and. ipsref_file .ne. ' ' .and.
     &         ipsref_file(1:1) .ne. char(0)) then

             text = ' '
             finished = .false.
             do while (.not. finished)
               read (ipsfil, fmt='(a)', end=118) text(1:80)
               if (text(1:1) .eq. 'B') then
                 basekv = ftn_atof (text(15:18))
                 nb = find_bus(text(7:14), basekv)
                 if (nb .ne. 0) then
                   pti_name(nb) = text(15:18)
                 endif
               endif
             enddo
  118        continue
           endif
C
C          Process zone rename card "Z"
C
           if (dialect(1:4) .eq. 'WSCC' .and. zone_ren_file .ne. ' '
     &         .and. zone_ren_file(1:1) .ne. char(0)) then
             status = zone_ren (zonerenfil)
           endif

c          Save case comments, headers, etc.
           write ( text, 120 ) basval(4)
  120      format ( '.#CASE_ID = ', a )
           last = lastch(text)
           if (last .gt. 80 .and. dialect(1:4) .eq. 'WSCC') last = 80
           write (savfil, '(a)') text(1:last)
           num0 = num0 + 1

           write ( text, 122) basval(7)
  122      format ( '.#CASE_DS = ', a )
           last = lastch (text)
           if (last .gt. 80 .and. dialect(1:4) .eq. 'WSCC') last = 80
           write (savfil, '(a)') text(1:last)
           num0 = num0 + 1

           write ( text, 124) prgvsn, basval(4)(1:10), basval(7),
     &       basval(5)(1:10)
  124      format ( '.#H1 Version: ', a, ' CaseID: ', a,
     &              ' Description: ', a, ' Date: ', a )
           last = lastch(text)
           if (last .gt. 80 .and. dialect(1:4) .eq. 'WSCC') last = 80
           write (savfil, '(a)') text(1:last)
           num0 = num0 + 1

           do i = 1, 2
              j = index (coment(i), char(0))
              if (j .gt. 0) coment(i)(j:) = ' '
              if (dialect(1:4) .eq. 'WSCC') then
                 write ( text, 126) i+1, coment(i)(1:75)
  126            format ( '.#H', i1, 1x, a )
                 last = lastch(text)
                 write (savfil, '(a)') text(1:last)
              else
                 write ( text, 126) i+1, coment(i)(1:115)
                 last = lastch(text)
                 write (savfil, '(a)') text(1:last)
              endif
              num0 = num0 + 1
           enddo

           do i = 1, ncom
              if (dialect(1:4) .eq. 'WSCC') then
                 write (text, 130) i, com(i)(1:73)
  130            format ('.#C', i3, 1x, a)
                 last = lastch (text)
                 write (savfil, '(a)') text(1:last)
              else
                 write (text, 130) i, com(i)(1:113)
                 last = lastch (text)
                 write (savfil, '(a)') text(1:last)
              endif
              num0 = num0 + 1

           enddo

c          Extract area interchanges and area interties
           numa = ext_ai ( savfil, dialect, lenrec, ratcod, sections,
     &                     type_e )
c
c          Redefine lenrec if hybrid 'B80/L120' is used
c
           if (index (size, '80') .ne. 0) then
             lenrec = 80
           else
             lenrec = 120
           endif

c          Extract bus data
           numb = ext_bus ( savfil, dialect, lenrec, ratcod, sections,
     &                      type_e )
c
c          Restore lenrec if hybrid 'B80/L120' is used
c
           if (index (size, '120') .ne. 0) then
             lenrec = 120
           else
             lenrec = 80
           endif

c          Extract branch data
           numl = ext_brn ( savfil, dialect, lenrec, ratcod, sections,
     &                      type_e )

        endif

        numrecs = num0 + numa + numb + numl
        write (outbuf, 170) numrecs, saveflnm
  170   format (1x, i5, ' records written to NETWORK_DATA file ', a)
        call prtout (1)
        errbuf(1) = outbuf
        call prterx ('I', 1)

        return
        end

max_stars_repo_name: mbheinen/bpa-ipf-tsp

max_issues_repo_name: cuihantao/bpa-ipf-tsp

max_forks_repo_name: mbheinen/bpa-ipf-tsp


text:
Emerson Junior High School is one 3 local Junior High schools.  They integrate English and DJUSD Spanish Immersion Program Spanish into the curriculum, producing bilingual children.  The school opened in 1980.

Since fall of 2009, Emerson JH campus has also housed grades 79 of the http://davincicharteracademy.net/ Da Vinci Charter Academy.  This responded to some declining demographics in the Emerson attendance area, and to growing interest in the Da Vinci HS, currently housed at the old campus of Valley Oak Elementary.

Notice the elephant shaped bush at the entrance to the school.  It also has a large studentproduced mural on the side of its gymnasium. Over 200 students worked on it at one time or another. Both works of art seem to generally withstand graffiti and vandalism which is something to note.  The mural was graffitied in 2005

Near the end of the school year 7th and 8th graders have a Day on the Green when the 9th graders go on the 9th grade trip.  Due to the design of the campus it is the site for Grad Night, celebrating graduates can effectively be locked in for the night.

Local musician Rita Hosking taught (teaches?) here.

20110805 16:09:16 nbsp Good old Emerson.  We used to call it Emerson State Penitentiary, since unlike the High School (and every other school in town), they effectively locked up the school after hours.  We snuck in anyway of course, and got caught... ended up picking up trash at lunch for a week (good old Mr. Gary, Vice Principal).  We also though we were cool because we had a pool (which has since been filled with sand? Beach volleyball I guess).  The pool at Arroyo park effectively replaced this one, but back in the day we used to be able to do some water sports in P.E. classes.  Also, one more memory that stands out: Last day of school every year, everyone in the school would take each and every piece of paper in their locker, backpack, etc. and I mean every piece, out of every binder, every notebook, EVERYTHING and toss it into the air.  By the time we all left, the ground was covered in what must have been 3 inches deep of paper, in almost every hall way.  The janitors must have really hated us, but it was a very liberating thing for a 13 year old kid to do. Users/OldDavis73


text:
! Demonstrate array intrinsic functions
program array_intrinsics
integer, parameter :: vec(3) = [4,1,9]
print*,minval(vec),maxval(vec) ! output: 1 9
print*,sum(vec),product(vec) ! 14 36
print*,minloc(vec),maxloc(vec) ! 2 3
print*,findloc(vec,9),findloc(vec,8) ! 3 0
end program array_intrinsics

max_stars_repo_name: awvwgk/FortranTip

max_issues_repo_name: awvwgk/FortranTip

max_forks_repo_name: awvwgk/FortranTip


text:
module rocfft_enums
  implicit none

  ! rocfft_status
  enum, bind(c)
     enumerator :: rocfft_status_success
     enumerator :: rocfft_status_failure
     enumerator :: rocfft_status_invalid_arg_value
     enumerator :: rocfft_status_invalid_dimensions
     enumerator :: rocfft_status_invalid_array_type
     enumerator :: rocfft_status_invalid_strides
     enumerator :: rocfft_status_invalid_distance
     enumerator :: rocfft_status_invalid_offset
  end enum

  !rocfft_transform_type
  enum, bind(c)
     enumerator :: rocfft_transform_type_complex_forward
     enumerator :: rocfft_transform_type_complex_inverse
     enumerator :: rocfft_transform_type_real_forward
     enumerator :: rocfft_transform_type_real_inverse
  end enum

  !rocfft_precision
  enum, bind(c)
     enumerator :: rocfft_precision_single
     enumerator :: rocfft_precision_double
  end enum

  !rocfft_result_placement
  enum, bind(c)
     enumerator :: rocfft_placement_inplace
     enumerator :: rocfft_placement_notinplace
  end enum

end module rocfft_enums

max_stars_repo_name: twhite-cray/hipfort

max_issues_repo_name: twhite-cray/hipfort

max_forks_repo_name: twhite-cray/hipfort


text: Hello! Looking to move to Davis in July! I have a few pets and am struggling with housing as I am not able to visit! I will be a Graduate Students graduate student at Davis!


text:
      SUBROUTINE DFPSAV(TOTIME,XPARAM,GD,XLAST,FUNCT1,MDFP,XDFP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES/NOLIST'
      DIMENSION XPARAM(*), GD(*), XLAST(*), MDFP(9),XDFP(9)
**********************************************************************
*
* DFPSAV STORES AND RESTORES DATA USED IN THE D-F-P GEOMETRY
*        OPTIMISATION.
*
*  ON INPUT TOTIME = TOTAL CPU TIME ELAPSED DURING THE CALCULATION.
*           XPARAM = CURRENT VALUE OF PARAMETERS.
*           GD     = OLD GRADIENT.
*           XLAST  = OLD VALUE OF PARAMETERS.
*           FUNCT1 = CURRENT VALUE OF HEAT OF FORMATION.
*           MDFP   = INTEGER CONSTANTS USED IN D-F-P.
*           XDFP   = REAL CONSTANTS USED IN D-F-P.
*           MDFP(9)= 1 FOR DUMP, 0 FOR RESTORE.
**********************************************************************
      COMMON /KEYWRD/ KEYWRD
      COMMON /TITLES/ KOMENT,TITLE
      COMMON /GRADNT/ GRAD(MAXPAR),GNORM
      COMMON /GEOVAR/ NVAR,LOC(2,MAXPAR), DUMY(MAXPAR)
      COMMON /DENSTY/ P(MPACK), PA(MPACK), PB(MPACK)
      COMMON /ALPARM/ ALPARM(3,MAXPAR),ILOOP,X0, X1, X2
      COMMON /REACTN/ STEP, GEOA(3,NUMATM), GEOVEC(3,NUMATM),CALCST
      COMMON /GMETRY/ GEO(3,NUMATM)
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM),
     +                NA(NUMATM),NB(NUMATM),NC(NUMATM)
      COMMON /PATH  / LATOM,LPARAM,REACT(100)
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),
     +                NLAST(NUMATM), NORBS, NELECS,
     1                NALPHA, NBETA, NCLOSE, NOPEN
      COMMON /FMATRX/ HESINV(MAXHES)
      COMMON /GEOSYM/ NDEP,LOCPAR(200),IDEPFN(200),LOCDEP(200)
      DIMENSION IEL1(3),Q(3)
      CHARACTER ELEMNT(99)*2, KEYWRD*80,KOMENT*80, TITLE*80
      LOGICAL FIRST
      DATA FIRST /.TRUE./
      DATA ELEMNT/' H','He',
     2 'Li','Be',' B',' C',' N',' O',' F','Ne',
     3 'Na','Mg','Al','Si',' P',' S','Cl','Ar',
     4 ' K','Ca','Sc','Ti',' V','Cr','Mn','Fe','Co','Ni','Cu',
     4 'Zn','Ga','Ge','As','Se','Br','Kr',
     5 'Rb','Sr',' Y','Zr','Nb','Mo','Tc','Ru','Rh','Pd','Ag',
     5 'Cd','In','Sn','Sb','Te',' I','Xe',
     6 'Cs','Ba','La','Ce','Pr','Nd','Pm','Sm','Eu','Gd','Tb','Dy',
     6 'Ho','Er','Tm','Yb','Lu','Hf','Ta',' W','Re','Os','Ir','Pt',
     6 'Au','Hg','Tl','Pb','Bi','Po','At','Rn',
     7 'Fr','Ra','Ac','Th','Pa',' U','Np','Pu','Am','Cm','Bk','Cf','XX'/
      DEGREE=57.29577951D0
      IR=9
      REWIND 10
      REWIND IR
      IF(MDFP(9) .EQ. 1) THEN
        WRITE(6,'(//10X,''- - - - - - - TIME UP - - - - - - -'',//)')
        IF(INDEX(KEYWRD,'SADDLE') .NE. 0) THEN
        WRITE(6,'(//10X,'' NO RESTART EXISTS FOR SADDLE'',//
     +  10X,'' HERE IS A DATA-FILE FILES THAT MIGHT BE SUITABLE'',/
     +  10X,'' FOR RESTARTING THE CALCULATION'',///)')
      WRITE(6,'(1X,A)')KEYWRD,KOMENT,TITLE
      DO 44 ILOOP=1,2
      GEO(2,1)=0.D0
      GEO(3,1)=0.D0
      GEO(1,1)=0.D0
      GEO(2,2)=0.D0
      GEO(3,2)=0.D0
      GEO(3,3)=0.D0
      IVAR=1
      NA(1)=0
      DO 112 I=1,NATOMS
          DO 122 J=1,3
  122         IEL1(J)=0
  123         CONTINUE
          IF(LOC(1,IVAR).EQ.I) THEN
              IEL1(LOC(2,IVAR))=1
              IVAR=IVAR+1
              GOTO 123
          ENDIF
      IF(I.LT.4) THEN
          IEL1(3)=0
          IF(I.LT.3) THEN
              IEL1(2)=0
              IF(I.LT.2) THEN
                  IEL1(1)=0
              ENDIF
          ENDIF
      ENDIF
      IF(I.EQ.LATOM)IEL1(LPARAM)=-1
      Q(1)=GEO(1,I)
      Q(2)=GEO(2,I)*DEGREE
      Q(3)=GEO(3,I)*DEGREE
  112     WRITE(6,'(2X,A2,3(F12.6,I3),I4,2I3)')
     +    ELEMNT(LABELS(I)),(Q(K),IEL1(K),K=1,3),NA(I),NB(I),NC(I)
          I=0
          X=0.D0
          WRITE(6,'(I4,3(F12.6,I3),I4,2I3)')
     +    I,X,I,X,I,X,I,I,I,I
      DO 45 I=1,NATOMS
      DO 45 J=1,3
  45  GEO(J,I)=GEOA(J,I)
  44  CONTINUE
      WRITE(6,'(///10X,''CALCULATION TERMINATED HERE'')')
      STOP
      ENDIF
        WRITE(6,'(//10X,'' - THE CALCULATION IS BEING DUMPED TO DISK'',
     +  /10X,''   RESTART IT USING THE MAGIC WORD "RESTART"'')')
        WRITE(6,'(//10X,''CURRENT VALUE OF HEAT OF FORMATION =''
     +  ,F12.6)')FUNCT1
      GEO(2,1)=0.D0
      GEO(3,1)=0.D0
      GEO(1,1)=0.D0
      GEO(2,2)=0.D0
      GEO(3,2)=0.D0
      GEO(3,3)=0.D0
      IVAR=1
      NA(1)=0
      WRITE(6,'(A)')KEYWRD,KOMENT,TITLE
      DO 110 I=1,NATOMS
          DO 120 J=1,3
  120         IEL1(J)=0
  121         CONTINUE
          IF(LOC(1,IVAR).EQ.I) THEN
              IEL1(LOC(2,IVAR))=1
              IVAR=IVAR+1
              GOTO 121
          ENDIF
      IF(I.LT.4) THEN
          IEL1(3)=0
          IF(I.LT.3) THEN
              IEL1(2)=0
              IF(I.LT.2) THEN
                  IEL1(1)=0
              ENDIF
          ENDIF
      ENDIF
      IF(I.EQ.LATOM)IEL1(LPARAM)=-1
      Q(1)=GEO(1,I)
      Q(2)=GEO(2,I)*DEGREE
      Q(3)=GEO(3,I)*DEGREE
  110     WRITE(6,'(2X,A2,3(F12.6,I3),I4,2I3)')
     +    ELEMNT(LABELS(I)),(Q(K),IEL1(K),K=1,3),NA(I),NB(I),NC(I)
          I=0
          X=0.D0
          WRITE(6,'(I4,3(F12.6,I3),I4,2I3)')
     +    I,X,I,X,I,X,I,I,I,I
      IF(NDEP.NE.0)THEN
        DO 130 I=1,NDEP
  130   WRITE(6,'(3(I4,'',''))')LOCPAR(I),IDEPFN(I),LOCDEP(I)
      WRITE(6,*)
      ENDIF
        WRITE(IR)MDFP,XDFP,TOTIME,FUNCT1
        WRITE(IR)(XPARAM(I),I=1,NVAR),(GD(I),I=1,NVAR)
        WRITE(IR)(XLAST(I),I=1,NVAR),(GRAD(I),I=1,NVAR)
        LINEAR=(NVAR*(NVAR+1))/2
        WRITE(IR)(HESINV(I),I=1,LINEAR)
        LINEAR=(NORBS*(NORBS+1))/2
        WRITE(10)(PA(I),I=1,LINEAR)
        IF(NALPHA.NE.0)WRITE(10)(PB(I),I=1,LINEAR)
        IF(LATOM .NE. 0) THEN
          WRITE(IR)((ALPARM(J,I),J=1,3),I=1,NVAR)
          WRITE(IR)ILOOP,X0, X1, X2
        ENDIF
        STOP
      ELSE
        IF (FIRST) WRITE(6,'(//10X,'' RESTORING DATA FROM DISK''/)')
        READ(IR)MDFP,XDFP,TOTIME,FUNCT1
        IF (FIRST) WRITE(6,'(10X,''FUNCTION ='',F13.6//)')FUNCT1
        READ(IR)(XPARAM(I),I=1,NVAR),(GD(I),I=1,NVAR)
        READ(IR)(XLAST(I),I=1,NVAR),(GRAD(I),I=1,NVAR)
        LINEAR=(NVAR*(NVAR+1))/2
        READ(IR)(HESINV(I),I=1,LINEAR)
        LINEAR=(NORBS*(NORBS+1))/2
        READ(10)(PA(I),I=1,LINEAR)
        IF(NALPHA.NE.0)READ(10)(PB(I),I=1,LINEAR)
        IF(LATOM.NE.0) THEN
          READ(IR)((ALPARM(J,I),J=1,3),I=1,NVAR)
          READ(IR)ILOOP,X0, X1, X2
        ENDIF
        FIRST=.FALSE.
        RETURN
      ENDIF
      END

max_stars_repo_name: openmopac/MOPAC-archive

max_issues_repo_name: openmopac/MOPAC-archive

max_forks_repo_name: openmopac/MOPAC-archive


text:
      subroutine mpi_util_allr_dp(array_dp, size)
      INCLUDE 'mpif.h'
      parameter (MAXPROC=9999)
      common /MPI/ myid, nprocs, ierr, istat(MPI_STATUS_SIZE)
      integer size;
      double precision array_dp(size);
      POINTER(qtmp,tmp(size));

      call alloc(qtmp,size,8);
      tmp(1:size) = 0.0;

      call MPI_ALLREDUCE(value,tmp_value,n,
     :     MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierror)
      array_dp(1:n) = tmp(1:size)
      if(qtmp_value.ne.0) call dalloc(qtmp_value,n)

      return
      end


text:
      subroutine count_range(ndimx,ndimy,ndimch,
     &isndrdata,imaximum,iminimum,istatus)
c
c routine determines the range for count values for each sounding
c data channel
c
      implicit none

      integer i,j,k
      integer ndimch,ndimy,ndimx
      integer istatus
      integer isndrdata(ndimx,ndimy,ndimch)
      integer imaximum(ndimch)
      integer iminimum(ndimch)
      integer i2_missing_data
      integer maxthresh
      integer icntm(ndimch)
      integer icnteth(ndimch)

      call get_i2_missing_data(i2_missing_data,istatus)
      if(istatus.ne.1)goto 999

      maxthresh=65535

      do k=1,ndimch

         imaximum(k)=0
         iminimum(k)=maxthresh
         icntm(k)=0
         icnteth(k)=0

         do j=1,ndimy

           do i=1,ndimx

             if(isndrdata(i,j,k).ne.i2_missing_data.and.
     &          isndrdata(i,j,k).lt.maxthresh)then

               if(isndrdata(i,j,k).gt.imaximum(k))then
                  imaximum(k)=isndrdata(i,j,k)
               endif

               if(isndrdata(i,j,k).lt.iminimum(k))then
                  iminimum(k)=isndrdata(i,j,k)
               endif

             elseif(isndrdata(i,j,k).eq.i2_missing_data)then
               icntm(k)=icntm(k)+1
             elseif(isndrdata(i,j,k).gt.maxthresh)then
               icnteth(k)=icnteth(k)+1
             endif

            enddo
         enddo
      enddo
c
      do k=1,ndimch
       write(6,*)'Ch/I2Missing/ExceedThresh: ',k,icntm(k),icnteth(k)
      enddo

      goto 1000
999   write(6,*)'Error getting i2_missing_data'

1000  return
      end

max_stars_repo_name: maxinye/laps-mirror

max_stars_repo_licenses: Intel Unlicense OLDAP-2.2.1 NetCDF

max_issues_repo_name: longwosion/laps-mirror

max_issues_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense

max_forks_repo_name: longwosion/laps-mirror

max_forks_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense


text:
	SUBROUTINE WW_US8 ( watch, lenw, irptr, mxp, wnum, rlat, rlon,
     +		            npt, isecnd, wnum2, iret )
C************************************************************************
C* WW_US8  								*
C*									*
C* This subroutine decodes the watch number(s) and updated line points  *
C* for a WWUS8 or WOUS20 status report.                                 *
C*                                                                      *
C* WW_US8 ( WATCH, LENW, IRPTR, MXP, WNUM, RLAT, RLON, NPT, ISECND,     *
C*	    WNUM2, IRET )      				   		*
C*                                                                      *
C* Input parameters:							*
C*	WATCH 		CHAR*		Report string                   *
C*	LENW		INTEGER		Length of report		*
C*	IRPTR		INTEGER		Pointer to location in report   *
C*	MXP 		INTEGER		Maximum number of points        *
C*									*
C* Output parameters:							*
C*	WNUM		CHAR*		Watch number                    *
C*	RLAT (*)	REAL            Latitudes of updated points     *
C*	RLON (*)	REAL		Longitudes of updated points    *
C*	NPT		INTEGER		Num. of updated points in line 1*
C*	ISECND		INTEGER		Flag for 2nd watch number or    *
C*					num. of updated points in line 2*
C*	WNUM2    	CHAR*		Second watch number             *
C*	IRET		INTEGER		Return code			*
C*				          0 = normal return             *
C*				         -3 = point not in table        *
C*				         -4 = no status points decoded  *
C*									*
C**									*
C* Log:									*
C* D. Kidwell/NCEP	 8/99	                                        *
C* D. Kidwell/NCEP	 9/99	Allow 2 lines to be defined; added doc. *
C* D. Kidwell/NCEP	10/99	Mods for variations in message format   *
C* D. Kidwell/NCEP	10/99	Do not look for # before watch number   *
C* D. Kidwell/NCEP	11/99	Checked for status report ending in '.' *
C* D. Kidwell/NCEP	 3/00	Fixed for station name containing 'TO'  *
C* D. Kidwell/NCEP	 3/00	Called ST_RPSL instead of ST_RPST       *
C* D. Kidwell/NCEP	 9/00	(WW_AXPT, WW_GTPT) -> CLO_DDDEC, fixed  *
C*				typo in DO initialization               *
C* D. Kidwell/NCEP	10/01	Added WOUS20 to prolog                  *
C* D. Kidwell/NCEP	 4/02	Fixes for 2nd status line - 'AND', fmt  *
C* D. Kidwell/NCEP	 5/02	Fixed for case of 'AND AND'             *
C* A. Hardy/NCEP	 7/03   Increased 'string' 120 -> 500		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	watch, wnum, wnum2
	REAL		rlat (*), rlon (*)
C*
C*	IFMT format code interpretation for location string -
C*	(See locator.tbl for further information)
C*	5 = nearest 5 miles
C*	2 = statute miles (SM)
C*	1 = 16 point compass direction
C*	2 = 3 character station id
C*
	PARAMETER	( IFMT = 5212 )
C*
	CHARACTER	sep*4, string*500, tmpstr*20, locnam*10, to*3
	LOGICAL		good, done, land
C------------------------------------------------------------------------
	iret   = 0
	wnum   = ' '
	npt    = 0
	isecnd = 0
	wnum2  = ' '
C
	DO i = 1, mxp
	    rlat ( i ) = RMISSD
	    rlon ( i ) = RMISSD
	END DO
C
C*	Check for watch number.
C
	iptr = irptr
	lens = MIN ( iptr + 120, lenw )
	indx = INDEX ( watch ( iptr:lens ), ' WW NUMBER ' )
	IF ( indx .gt. 0 ) THEN
	    iptr = iptr + indx + 10
	  ELSE
	    indx1 = INDEX ( watch ( iptr:lens ), ' WWS NUMBER ')
	    indx2 = INDEX ( watch ( iptr:lens ), ' WW NUMBERS ')
	    indx = MAX ( indx1, indx2 )
	    IF ( indx .gt. 0 ) THEN
C
C*		A second watch number was found.
C
		iptr   = iptr + indx + 11
		isecnd = -1
	    END IF
	END IF
C
	IF ( indx .eq. 0 ) THEN
C
C*	    Look for the NEW format, which omits the word NUMBER.
C
	    indx = INDEX ( watch ( iptr:lens ), ' WW ' )
	    IF ( indx .gt. 0 ) THEN
	        iptr = iptr + indx + 3
	      ELSE
	        indx = INDEX ( watch ( iptr:lens ), ' WWS ')
	        IF ( indx .gt. 0 ) THEN
C
C*		    A second watch number was found.
C
		    iptr   = iptr + indx + 4
		    isecnd = -1
	        END IF
	    END IF
	END IF
C
C*	Get the watch number(s).
C
	IF ( indx .gt. 0 ) THEN
	    CALL WW_WNUM ( watch ( iptr:iptr + 5 ), 6, wnum, ier )
	    IF ( isecnd .lt. 0 ) THEN
		indx = INDEX ( watch ( iptr:iptr + 10 ), ' AND ' )
		IF ( indx .gt. 0 ) THEN
		    iptr = iptr + indx + 4
	    	    CALL WW_WNUM ( watch (iptr:iptr+5), 6, wnum2, ier )
		  ELSE
		    isecnd = 0
		END IF
	    END IF
	END IF
C
C*	Check for definition of a severe weather line.  There can be up
C*	to two definitions.
C
	npts = 0
	land = .false.
	DO ii = 1, 2
	    good  = .true.
	    lens  = MIN ( iptr + 150, lenw )
	    indx1 = INDEX ( watch ( iptr:lens ), 'THREAT ' )
	    IF ( indx1 .gt. 0 ) THEN
      	        indx = INDEX ( watch ( iptr:lens ), 'CONTINUES ' )
		IF ( indx .lt. indx1 ) indx = 0
	      ELSE
		indx = 0
 	    END IF
	    IF ( land ) indx = 1
	    IF ( indx .le. 0 ) THEN
C
C*		Line definition keywords were not found.
C
	        good = .false.
	      ELSE
C
C*		A severe weather line definition may follow.  Check for
C*	  	either no change in area, or the presence of a second
C* 		watch number.  (If there is a second watch number, there
C*		can be no second line definition.)
C
	        iptr  = iptr + indx
	        IF ( ii .eq. 1 ) THEN
		    iptr = iptr + 9
		  ELSE
		    IF ( isecnd .lt. 0 ) good = .false.
		    iptr = iptr + 4
		END IF
	    END IF
C
	    IF ( good ) THEN
C
C*	        A severe weather line definition follows.
C
	        lens = MIN ( iptr + 100, lenw )
	        indx = INDEX ( watch ( iptr:lens ), 'LINE THROUGH ' )
C
C*		Determine location separators.
C
	        IF ( indx .gt. 0 ) THEN
	            sep    = '...'
		    lensep = 3
		    iptr   = iptr + indx + 12
	          ELSE
	            indx = INDEX ( watch ( iptr:lens ), 'LINE FROM ' )
	            IF ( indx .gt. 0 ) THEN
	                sep    = ' TO '
		        lensep = 4
		        iptr   = iptr + indx + 9
	              ELSE
		        IF ( .not. land ) good   = .false.
	            END IF
	        END IF
C
	        IF ( good ) THEN
C
C*		    Determine end of location string.
C
		    lens = INDEX ( watch ( iptr:lenw ), '. ' ) - 1
		    IF ( lens .lt. 0 ) lens = lenw - iptr
		    IF ( ii .eq. 1 ) THEN
C
C*			Look for ' AND ' as a second string indicator.
C
			done = .false.
			iocc = 1
			DO WHILE ( .not. done )
			    CALL ST_NOCC ( watch (iptr:lenw), ' AND ',
     +					   iocc, lena, ier )
			    IF ( ( lena .gt. 0 ) .and.
     +				 ( lena .lt. lens ) ) THEN
				to = watch(iptr+lena+4:iptr+lena+6)
				IF ( to .ne. 'TO ' )  THEN
				    land = .true.
C
C*				    The next line handles station 'AND'
C*				    followed by second string indicator.
C
				    IF ( to .eq. 'AND' ) lena = lena + 4
				  ELSE IF ( to .eq. 'TO ' ) THEN
				    nx = iptr + lena + 7
				    IF ( (watch(nx:nx+3) .eq. 'THE ')
     +				     .or. (watch(nx:nx+4) .eq. 'LEFT ')
     +				     .or. (watch(nx:nx+4) .eq. 'EAST ')
     +				     .or. (watch(nx:nx+4) .eq. 'WEST ')
     +				     .or. (watch(nx:nx+5) .eq. 'RIGHT ')
     +				     .or. (watch(nx:nx+5) .eq. 'NORTH ')
     +				     .or. (watch(nx:nx+5) .eq. 'SOUTH ')
     +				     ) THEN
				        land = .true.
				    END IF
				END IF
				IF ( land ) THEN
				    done = .true.
				    lens = lena - 1
				  ELSE
				    iocc = iocc + 1
				END IF
			      ELSE
				done = .true.
			    END IF
			END DO
		    END IF
C
		    string = watch ( iptr:iptr + lens - 1)
		    iptr = iptr + lens
		    done = .false.
		    num  = 0
C
C*		    Replace varying separator string with character '/'.
C
		    DO WHILE ( .not. done )
		        num = num + 1
		        CALL ST_RPSL ( string, sep, lensep, '/', 1,
     +				       ipos, string, ier )
		        IF ( ipos .eq. 0 ) done = .true.
		    END DO
		    num = MIN ( num, mxp )
C
C*		    Look for and remove the characters ' OF '.
C
		    done = .false.
		    DO WHILE ( .not. done )
		        CALL ST_RPSL ( string, ' OF ', 4, ' ', 1,
     +				       ipos, string, ier )
		        IF ( ipos .eq. 0 ) done = .true.
		    END DO
C
C*		    Get the points.
C
		    ib    = 1
		    DO i = 1, num
		        ie = INDEX ( string ( ib:lens ), '/' ) + ib - 2
		        IF ( ie .lt. ib ) ie = lens
			CALL ST_NULL ( string ( ib:ie ), tmpstr,
     +				       ll, ier )
			locnam = 'ANCHOR'
			CALL ST_NULL ( locnam, locnam, ll, ier )
		        CALL CLO_DDDEC ( locnam, IFMT, tmpstr, 1,
     +					 xlat, xlon, nstn, ier )
		        IF ( ier .eq. 0 ) THEN
	                    npts = npts + 1
	                    rlat ( npts ) = xlat
	                    rlon ( npts ) = xlon
			  ELSE IF ( ier .ne. ( -2 ) ) THEN
			    CALL DC_WLOG ( 2, 'DCWTCH', -4,
     +					   string ( ib:ie ), ir1 )
			  ELSE
			    ib = MAX ( 1, ie - 3 )
			    CALL DC_WLOG ( 0, 'DCWTCH', -3,
     +					   string ( ib:ie ), ir1 )
			    IF ( iret .eq. 0 ) iret = -3
			END IF
		        ib = ie + 2
		    END DO
		    IF ( npts .eq. 0 ) good = .false.
	        END IF
	    END IF
C
C*	    Save the number of points.
C
	    IF ( ii .eq. 1 ) THEN
		npt = npts
		IF ( .not. good ) iret = -4
	      ELSE
		IF ( good ) THEN
		    isecnd = npts - npt
		  ELSE
		    isecnd = MIN ( isecnd, 0 )
		END IF
	    END IF
	END DO
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
module Mod_nsc_pr_MatricesContribution
   use typre
   use Mod_nsc_pr_BaseElmope
   implicit none

   integer(ip), allocatable :: kfl_IsSet

contains

   subroutine SetPointersMatricesContribution(itask)
      implicit none
      integer(ip) :: itask
      select case (itask)

      case(0)
         allocate(kfl_IsSet)
         call a%Memor%allocObj(0,'kfl_IsSet','InitProcedurePointer',1)
         kfl_IsSet = -1

      case(1)

         if (kfl_IsSet == -1) then
            kfl_IsSet = 1

            call ConcatenateProcedures(ProcHook_nsc_pr_Initializations,AllocateMatricesContribution)
            call ConcatenateProcedures(ProcHook_nsc_pr_Finalizations,DeallocateMatricesContribution)

         endif

      case(100)
         deallocate(kfl_IsSet)
         call a%Memor%deallocObj(0,'kfl_IsSet','InitProcedurePointer',1)

      end select
   end subroutine

   !-----------------------------------------------------------------------
   subroutine AllocateMatricesContribution

      call a%Memor%alloc(e%mnode,Edd,'Edd','nsc_pr_elmope')
      call a%Memor%alloc(e%ndime,e%mnode,Edm,'Edm','nsc_pr_elmope')
      call a%Memor%alloc(e%mnode,Ede,'Ede','nsc_pr_elmope')
      call a%Memor%alloc(e%ndime,e%mnode,Emd,'Emd','nsc_pr_elmope')
      call a%Memor%alloc(e%ndime,e%ndime,e%mnode,Emm,'Emm','nsc_pr_elmope')
      call a%Memor%alloc(e%ndime,e%mnode,Eme,'Eme','nsc_pr_elmope')
      call a%Memor%alloc(e%mnode,Eed,'Eed','nsc_pr_elmope')
      call a%Memor%alloc(e%ndime,e%mnode,Eem,'Eem','nsc_pr_elmope')
      call a%Memor%alloc(e%mnode,Eee,'Eee','nsc_pr_elmope')
      call a%Memor%alloc(e%ndime,Erhm,'Erhm','nsc_pr_elmope')

   end subroutine

   subroutine ComputeEulerContribution
      implicit none

      Edd = Atdd*LHSdtinv + Add
      Edm =                 Adm
      Ede = Atde*LHSdtinv + Ade
      Emd = Atmd*LHSdtinv + Amd
      Emm = Atmm*LHSdtinv + Amm
      Eme = Atme*LHSdtinv + Ame
      Eed = Ated*LHSdtinv + Aed
      Eem = Atem*LHSdtinv + Aem
      Eee = Atee*LHSdtinv + Aee

   end subroutine

   subroutine ComputeRHSContribution(e,eltemp,eltemv,eltemt,elexp,elexv,elext,Erhd,Erhm,Erhe)
      implicit none
      class(FiniteElement) :: e
      real(rp),    intent(in)       :: eltemp,elexp
      real(rp),    intent(in)       :: eltemv(e%ndime),elexv(e%ndime)
      real(rp),    intent(in)       :: eltemt,elext
      real(rp),    intent(inout)    :: Erhd,Erhe
      real(rp),    intent(inout)    :: Erhm(e%ndime)

      real(rp) :: auxme

      auxme = dot_product(gpadv,eltemv)

      Erhd    = gpden*acbeta*eltemp - gpden*acalpha*eltemt + elexp
      Erhm(:) = gpden*acbeta*gpadv(:)*eltemp + gpden*eltemv(:) -&
                gpden*acalpha*gpadv(:)*eltemt + elexv(:)
      Erhe    = (aux*acbeta-acalpha*gpadt)*eltemp +&
                 gpden*auxme+&
                (gpden*accph-aux*acalpha)*eltemt + elext

   end subroutine

   subroutine DeallocateMatricesContribution

      call a%Memor%dealloc(e%mnode,Edd,'Edd','nsc_pr_elmope')
      call a%Memor%dealloc(e%ndime,e%mnode,Edm,'Edm','nsc_pr_elmope')
      call a%Memor%dealloc(e%mnode,Ede,'Ede','nsc_pr_elmope')
      call a%Memor%dealloc(e%ndime,e%mnode,Emd,'Emd','nsc_pr_elmope')
      call a%Memor%dealloc(e%ndime,e%ndime,e%mnode,Emm,'Emm','nsc_pr_elmope')
      call a%Memor%dealloc(e%ndime,e%mnode,Eme,'Eme','nsc_pr_elmope')
      call a%Memor%dealloc(e%mnode,Eed,'Eed','nsc_pr_elmope')
      call a%Memor%dealloc(e%ndime,e%mnode,Eem,'Eem','nsc_pr_elmope')
      call a%Memor%dealloc(e%mnode,Eee,'Eee','nsc_pr_elmope')
      call a%Memor%dealloc(e%ndime,Erhm,'Erhm','nsc_pr_elmope')

   end subroutine

end module

max_stars_repo_name: ciaid-colombia/InsFEM

max_issues_repo_name: ciaid-colombia/InsFEM

max_forks_repo_name: ciaid-colombia/InsFEM