r2r_prelec_name.F File Reference

#include "implicit_f.inc"
#include "r2r_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	r2r_prelec_name (kdom, lsubmodel)

Function/Subroutine Documentation

r2r_prelec_name()

subroutine r2r_prelec_name	(	integer	kdom,
		type(submodel_data), dimension(*), intent(in)	lsubmodel )

Definition at line 39 of file r2r_prelec_name.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE message_mod
        USE restmod
        USE r2r_mod
        USE submodel_mod
        USE hm_option_read_mod
        USE names_and_titles_mod , ONLY : nchartitle, ncharkey
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      "r2r_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER KDOM
        TYPE(SUBMODEL_DATA),INTENT(IN)::LSUBMODEL(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER I,NUSER,N,RLEN,STAT,DEB,K,FLAG_FMT,ID,NEL
        CHARACTER(LEN=NCHARKEY)::KEY
        CHARACTER(LEN=NCHARTITLE)::LOCNAME,TITR
        LOGICAL IS_AVAILABLE
C=======================================================================
C
        is_available = .false.
        CALL hm_option_start('/SUBDOMAIN')
        nb_part_sub = 0
C
        IF (ipid==0) THEN
C--------------------------------------------------------------------C
C------Prereading of domain names --> Child process -----------------C
C--------------------------------------------------------------------C
 
          flag_fmt = 0
 
          DO n=1,nsubdom
C
            CALL hm_option_read_key(lsubmodel,
     .                              option_id = id,
     .                              option_titr = titr,
     .                              keyword2 = key)
C---
            IF(n == kdom)THEN
              dom_name = ''//trim(titr)
            ENDIF
C-----    Computation of total number of parts
            CALL hm_get_intv('idsmax',nel,is_available,lsubmodel)
            nb_part_sub = nb_part_sub + nel
          END DO
 
        ELSE
C--------------------------------------------------------------------C
C------Prereading of domain names --> father process ----------------C
C--------------------------------------------------------------------C
 
          n = 0
          deb = 1
 
C      DO WHILE(N < NSUBDOM)
          DO n=1,nsubdom
C---
C
            CALL hm_option_read_key(lsubmodel,
     .                              option_id = id,
     .                              option_titr = titr,
     .                              keyword2 = key)
 
            locname = ''//trim(titr)
            rlen = len_trim(locname)
            dom_name(deb:deb+rlen-1)=locname(1:rlen)
            isubdom(7,n)=rlen
            isubdom(8,n)=deb
            deb=deb+rlen
C-----    Computation of total number of parts
            CALL hm_get_intv('idsmax',nel,is_available,lsubmodel)
            nb_part_sub = nb_part_sub + nel
C
          END DO
 
C------Check of domain names ----------------C
 
          DO n=1,nsubdom
            DO k=n+1,nsubdom
              IF (isubdom(7,n)==isubdom(7,k)) THEN
                rlen = isubdom(7,n)
                key(1:rlen)=dom_name(isubdom(8,n):isubdom(8,n)+rlen-1)
                titr(1:rlen)=dom_name(isubdom(8,k):isubdom(8,k)+rlen-1)
                IF (key(1:rlen) == titr(1:rlen)) THEN
                  CALL ancmsg(msgid=826,
     .                      msgtype=msgerror,
     .                      anmode=aninfo,i1=isubdom(1,n),
     .                      c1=key(1:rlen))
                  ierr=ierr+1
                ENDIF
              ENDIF
            ENDDO
          ENDDO
 
        ENDIF
 
        RETURN