updating random number

SMoorthi-emc · Aug 19, 2020 · b87c8e8 · b87c8e8
1 parent 4ccdcf6
commit b87c8e8
Show file tree

Hide file tree

Showing 2 changed files with 27 additions and 17 deletions.
diff --git a/sorc/ncep_post.fd/CALWXT_BOURG.f b/sorc/ncep_post.fd/CALWXT_BOURG.f
@@ -83,13 +83,11 @@ subroutine calwxt_bourg_post(im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1,   &
 !
       integer i,j,ifrzl,iwrml,l,lhiwrm,lmhk,jlen
       real pintk1,areane,tlmhk,areape,pintk2,surfw,area1,dzkl,psfck,r1,r2
-      real rn(im*jm*2)
+      real (kind=8) :: rn(im*jm*2)
 !
 !     initialize weather type array to zero (ie, off).
 !     we do this since we want ptype to represent the
 !     instantaneous weather type on return.
-      print *,'in calwxtbg, jsta,jend=',jsta,jend,' im=',im
-      print *,'in calwxtbg,me=',me,'iseed=',iseed
 !     
 !$omp  parallel do
       do j=jsta,jend
@@ -102,14 +100,13 @@ subroutine calwxt_bourg_post(im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1,   &
       call random_setseed(iseed)
       call random_number(rn)
 !     call random_number(rn,iseed)
+
 !
 !!$omp  parallel do                                                   &
 !     & private(a,lmhk,tlmhk,iwrml,psfck,lhiwrm,pintk1,pintk2,area1,  &
 !     &         areape,dzkl,surfw,r1,r2)
-      print *,'incalwxtbg, rn',maxval(rn),minval(rn)
 
       do j=jsta,jend
-!     if(me==1)print *,'incalwxtbg, j=',j
         do i=1,im
            lmhk  = min(nint(lmh(i,j)),lm)
            psfck = pint(i,j,lmhk+1)
@@ -258,10 +255,7 @@ subroutine calwxt_bourg_post(im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1,   &
                end if
              end if
            end if
-!     write(1000+me,*)' finished for i, j,  from calbourge me=',me,i,j
         end do
-!     write(1000+me,*)' finished for  j,  from calbourge me=',me,j
       end do
-!     write(1000+me,*)' returning from calbourge me=',me
       return
       end
diff --git a/sorc/ncep_post.fd/SURFCE.f b/sorc/ncep_post.fd/SURFCE.f
@@ -99,6 +99,8 @@ SUBROUTINE SURFCE
                             lp1, imp_physics, me, asrfc, tsrfc, pt, pdtop,   &
                             mpi_comm_comp, im, jm
       use rqstfld_mod, only: iget, lvls, id, iavblfld, lvlsxml
+
+      use mersenne_twister, only: random_number, random_setseed
 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
        implicit none
 !
@@ -149,6 +151,9 @@ SUBROUTINE SURFCE
 
       real,external :: fpvsnew
 
+      real (kind=8) :: wrk(1)
+      integer       :: iseed0
+
 !****************************************************************************
 !
 !     START SURFCE.
@@ -4362,10 +4367,16 @@ SUBROUTINE SURFCE
                ENDDO
              ENDDO
 
+             write(0,*)'in SURFCE,me=',me,'sdat=',sdat,' ihrst=',ihrst,' ifhr=',ifhr,' ifmin=',ifmin
 ! BOURGOUIN ALGORITHM
-             ISEED=44641*(INT(SDAT(1)-1)*24*31+INT(SDAT(2))*24+IHRST)+   &
-     &             MOD(IFHR*60+IFMIN,44641)+4357
-!            write(0,*)'in SURFCE,me=',me,'bef 1st CALWXT_BOURG_POST iseed=',iseed
+!            ISEED=44641*(INT(SDAT(1)-1)*24*31+INT(SDAT(2))*24+IHRST)+   &
+!    &             MOD(IFHR*60+IFMIN,44641)+4357
+
+             iseed0 = sdat(1) + sdat(2) + sdat(3) + ihrst
+             call random_setseed(iseed0)
+             call random_number(wrk)
+             iseed = iseed0 + nint(wrk(1)*1000.0d0) + ifhr + ifmin
+             
              CALL CALWXT_BOURG_POST(IM,JM,JSTA_2L,JEND_2U,JSTA,JEND,LM,LP1,&
      &                              ISEED,G,PTHRESH,                       &
      &                              T,Q,PMID,PINT,LMH,PREC,ZINT,IWX1,me)
@@ -4577,11 +4588,16 @@ SUBROUTINE SURFCE
            ENDDO
 
 ! BOURGOUIN ALGORITHM
-           ISEED=44641*(INT(SDAT(1)-1)*24*31+INT(SDAT(2))*24+IHRST)+   &
-     &           MOD(IFHR*60+IFMIN,44641)+4357
-!          write(0,*)'in SURFCE,me=',me,'bef sec CALWXT_BOURG_POST'
+!          ISEED=44641*(INT(SDAT(1)-1)*24*31+INT(SDAT(2))*24+IHRST)+   &
+!    &           MOD(IFHR*60+IFMIN,44641)+4357
+
+             iseed0 = sdat(1) + sdat(2) + sdat(3) + ihrst
+             call random_setseed(iseed0)
+             call random_number(wrk)
+             iseed = iseed0 + nint(wrk(1)*1000.0d0) + ifhr + ifmin
+
            CALL CALWXT_BOURG_POST(IM,JM,JSTA_2L,JEND_2U,JSTA,JEND,LM,LP1,&
-     &                        ISEED,G,PTHRESH,                            &
+     &                        ISEED,G,PTHRESH,                           &
      &                        T,Q,PMID,PINT,LMH,AVGPREC,ZINT,IWX1,me)
 !          write(0,*)'in SURFCE,me=',me,'aft sec CALWXT_BOURG_POST'
 !          print *,'in SURFCE,me=',me,'IWX1=',IWX1(1:30,JSTA)
@@ -6008,7 +6024,7 @@ SUBROUTINE SURFCE
           datapd(1:im,1:jend-jsta+1,cfld)=GRID1(1:im,jsta:jend)
         endif
       ENDIF
-      if (me==0)print*,'starting computing canopy conductance'
+!     if (me==0)print*,'starting computing canopy conductance'
 !
 ! CANOPY CONDUCTANCE
 ! ONLY OUTPUT NEW LSM FIELDS FOR NMM AND ARW BECAUSE RSM USES OLD SOIL TYPES
@@ -6020,7 +6036,7 @@ SUBROUTINE SURFCE
      & .OR. IGET(239).GT.0 .OR. IGET(240).GT.0             &
      & .OR. IGET(241).GT.0 .OR. IGET(254).GT.0 ) THEN
         IF (iSF_SURFACE_PHYSICS .EQ. 2) THEN    !NSOIL == 4
-          if(me==0)print*,'starting computing canopy conductance'
+!         if(me==0)print*,'starting computing canopy conductance'
          allocate(rsmin(im,jsta:jend), smcref(im,jsta:jend), gc(im,jsta:jend), &
                   rcq(im,jsta:jend), rct(im,jsta:jend), rcsoil(im,jsta:jend), rcs(im,jsta:jend))
          DO J=JSTA,JEND