stock_msg.F File Reference

#include "implicit_f.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	stock_msg (id, itype, sbufmsg, bufmsg)

Function/Subroutine Documentation

stock_msg()

subroutine stock_msg	(	integer, intent(in)	id,
		integer, intent(in)	itype,
		integer, intent(in)	sbufmsg,
		character(len=ncharline100), dimension(sbufmsg), intent(in)	bufmsg )

Definition at line 31 of file stock_msg.F.

C-----------------------------------------------
C  M o d u l e s
C-----------------------------------------------
      USE message_mod
      USE names_and_titles_mod, ONLY: ncharline100
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER,INTENT(IN)              :: ID,ITYPE,SBUFMSG
      CHARACTER(LEN=NCHARLINE100), INTENT(IN) :: BUFMSG(SBUFMSG)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,JDX,IBACKSLASH
C-----------------------------------------------
C   S o u r c e   L i n e s
C-----------------------------------------------
      IF (ALLOCATED(messages(itype,id)%MESSAGE)) THEN
        DEALLOCATE(messages(itype,id)%MESSAGE)
      END IF
      IF (sbufmsg==0) THEN
        messages(itype,id)%SMESSAGE=1
        ALLOCATE(messages(itype,id)%MESSAGE(1))
        IF (itype==1) THEN
          messages(itype,id)%MESSAGE(1)=' !!! EMPTY TITLE !!! '
        ELSE IF (itype==2) THEN
          messages(itype,id)%MESSAGE(1)=' !!! EMPTY DESCRIPTION !!! '
        END IF
      ELSE
        ALLOCATE(messages(itype,id)%MESSAGE(sbufmsg))
        messages(itype,id)%SMESSAGE=sbufmsg
        DO i=1,sbufmsg
          jdx=1
          messages(itype,id)%MESSAGE(i)=' '
          j=1
          DO WHILE(j<=ncharline100)
            IF (bufmsg(i)(j:j)==achar(92)) then !'\') THEN
C             => skip \ print next
              IF (j<ncharline100) THEN
                j=j+1 
                IF (bufmsg(i)(j:j)=='n') THEN
                  messages(itype,id)%MESSAGE(i)(jdx:jdx)=char(10)
                  jdx=jdx+1
C add here other special cases
                ELSE
C                 keep back slash for further use
                  messages(itype,id)%MESSAGE(i)(jdx:jdx)= bufmsg(i)(j-1:j-1)
                  jdx=jdx+1
                  messages(itype,id)%MESSAGE(i)(jdx:jdx)= bufmsg(i)(j:j)
                  jdx=jdx+1
                END IF
              ELSE
C               => end of loop
                j=j+1
              END IF
            ELSE
              messages(itype,id)%MESSAGE(i)(jdx:jdx)=bufmsg(i)(j:j)
              jdx=jdx+1
            END IF
            j=j+1
          END DO
        END DO
      END IF