w_rwar.F File Reference

#include "implicit_f.inc"
#include "com04_c.inc"
#include "param_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	w_rwar (nprw, lprw, rwl, rwsav, lwsav_l, lrw_pen_l, nrw_pen_l, rwstif_pen, sln_pen, cep, proc, len_am)

Function/Subroutine Documentation

w_rwar()

subroutine w_rwar	(	integer, dimension(*)	nprw,
		integer, dimension(*)	lprw,
			rwl,
			rwsav,
		integer	lwsav_l,
		integer, intent(in)	lrw_pen_l,
		integer, intent(in)	nrw_pen_l,
		intent(in)	rwstif_pen,
		integer, intent(in)	sln_pen,
		integer, dimension(*)	cep,
		integer	proc,
		integer	len_am )

Definition at line 31 of file w_rwar.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------  
 
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
       INTEGER  PROC, LEN_AM, LWSAV_L, LPRW(*), NPRW(*),
     .          CEP(*)
       INTEGER,  INTENT(IN   ) :: LRW_PEN_L, NRW_PEN_L, SLN_PEN
       my_real
     .          rwl(nrwlp,*), rwsav(*)
      my_real, DIMENSION(SLN_PEN), INTENT(IN   )  :: rwstif_pen
C-----------------------------------------------
C   F u n c t i o n
C-----------------------------------------------
      INTEGER  NLOCAL
      EXTERNAL nlocal    
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER  J, K, KK, N, NN, IE, NE, IFQ, N4,
     .        ILP, NSL, NSL_L, KSAV, KSAV_L,N_P,IPEN,LSPEN
      my_real    , DIMENSION(:),ALLOCATABLE :: rwsav_l
      my_real    , DIMENSION(:,:),ALLOCATABLE :: rwl_l
      my_real    , DIMENSION(:),ALLOCATABLE :: rwpen1_l,rw_pen_l
C
      IF(nrwall>0) THEN
        ALLOCATE(rwl_l(nrwlp,nrwall))
        IF(lwsav_l>0) ALLOCATE(rwsav_l(3*lwsav_l))
        IF(lrw_pen_l>0) THEN 
          ALLOCATE(rwpen1_l(nrw_pen_l))
          ALLOCATE(rw_pen_l(4*lrw_pen_l))
        ENDIF
        k = 0
        ksav = 0
        ksav_l = 0
        DO n = 1, nrwall
          DO j = 1, nrwlp
            rwl_l(j,n) = rwl(j,n)
          ENDDO
C
          nsl = nprw(n)
C
          ifq = nint(rwl(15,n))
          IF(ifq>0) THEN
            nsl_l = 0
            DO kk = 1, nsl
              nn = lprw(k+kk)
              IF(nlocal(nn,proc+1)==1)THEN            
                rwsav_l(ksav_l+3*nsl_l+1) = rwsav(ksav+3*(kk-1)+1)
                rwsav_l(ksav_l+3*nsl_l+2) = rwsav(ksav+3*(kk-1)+2)
                rwsav_l(ksav_l+3*nsl_l+3) = rwsav(ksav+3*(kk-1)+3)
                nsl_l = nsl_l + 1
              ENDIF
            ENDDO
            ksav = ksav + 3*nsl
            ksav_l = ksav_l + 3*nsl_l
          ENDIF
C
          k = k + nsl
C
          n4 = n + 3*nrwall
          IF(nprw(n4)==-1) THEN
C RW ALE TH
           ne = nint(rwl(8,n))
           IF(ne>0)THEN
            ilp = 0
            DO j = 1, ne
              ie = lprw(k+j)/10
              IF(cep(ie)==proc) THEN
                ilp = ilp + 1
              ENDIF
            ENDDO
            rwl_l(8,n) = ilp
            k = k + ne
           ENDIF
          ENDIF
        ENDDO
C
        CALL write_db(rwl_l,nrwlp*nrwall)
        len_am = len_am + nrwlp*nrwall
        DEALLOCATE(rwl_l)
        IF(lwsav_l>0) THEN
          CALL write_db(rwsav_l,lwsav_l*3)
          len_am = len_am + lwsav_l*3
          DEALLOCATE(rwsav_l)
        ENDIF
        IF(lrw_pen_l>0) THEN
          rw_pen_l = zero
          n_p = 0
          nsl_l = 0
          k = 0
          DO n = 1, nrwall
            nsl = nprw(n) 
            ipen = nprw(n+8*nrwall)
            IF (ipen>0) THEN
              DO j = 1, nsl
                 nn = lprw(k+j)
                 IF(nlocal(nn,proc+1)==1)THEN            
                   nsl_l = nsl_l + 1
                   rw_pen_l(nsl_l) = rwstif_pen(n_p+j)
                 ENDIF
              END DO 
              n_p = n_p + nsl
            END IF 
            k = k + nsl
          END DO 
          lspen = n_p
          rwpen1_l = zero
          n_p = 0
          k = 0
          DO n = 1, nrwall
            nsl = nprw(n) 
            ipen = nprw(n+8*nrwall)
            IF (ipen>0) THEN
              nsl_l = 0
              DO j = 1, nsl
                 nn = lprw(k+j)
                 IF(nlocal(nn,proc+1)==1) nsl_l = nsl_l + 1
              END DO 
              IF (nsl_l>0) THEN
                n_p = n_p + 1
                rwpen1_l(n_p) = rwstif_pen(n_p+lspen) 
              END IF 
            END IF 
            k = k + nsl
          END DO 
          CALL write_db(rwpen1_l,nrw_pen_l)
          CALL write_db(rw_pen_l,lrw_pen_l*4)
          len_am = len_am + nrw_pen_l + lrw_pen_l*4
          DEALLOCATE(rw_pen_l) 
          DEALLOCATE(rwpen1_l) 
        END IF
      ENDIF
C
      RETURN